source: lmdz_wrf/WRFV3/external/io_grib2/bacio-1.3/baciof.F @ 1

C-----------------------------------------------------------------------
      MODULE BACIO_MODULE
C$$$  F90-MODULE DOCUMENTATION BLOCK
C
C F90-MODULE: BACIO_MODULE   BYTE-ADDRESSABLE I/O MODULE
C   PRGMMR: IREDELL          ORG: NP23        DATE: 98-06-04
C
C ABSTRACT: MODULE TO SHARE FILE DESCRIPTORS
C   IN THE BYTE-ADDESSABLE I/O PACKAGE.
C
C PROGRAM HISTORY LOG:
C   98-06-04  IREDELL
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      INTEGER,EXTERNAL:: BACIO
      INTEGER,DIMENSION(999),SAVE:: FD=999*0
      INTEGER,DIMENSION(20),SAVE:: BAOPTS=0
      INCLUDE 'baciof.h'
      END
C-----------------------------------------------------------------------
      SUBROUTINE BASETO(NOPT,VOPT)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BASETO         BYTE-ADDRESSABLE SET OPTIONS
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: SET OPTIONS FOR BYTE-ADDRESSABLE I/O.
C   ALL OPTIONS DEFAULT TO 0.
C   OPTION 1: BLOCKED READING OPTION
C             IF THE OPTION VALUE IS 1, THEN THE READING IS BLOCKED
C             INTO FOUR 4096-BYTE BUFFERS.  THIS MAY BE EFFICIENT IF
C             THE READS WILL BE REQUESTED IN MUCH SMALLER CHUNKS.
C             OTHERWISE, EACH CALL TO BAREAD INITIATES A PHYSICAL READ.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BASETO(NOPT,VOPT)
C   INPUT ARGUMENTS:
C     NOPT         INTEGER OPTION NUMBER
C     VOPT         INTEGER OPTION VALUE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      INTEGER NOPT,VOPT
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(NOPT.GE.1.AND.NOPT.LE.20) BAOPTS(NOPT)=VOPT
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BAOPEN(LU,CFN,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BAOPEN         BYTE-ADDRESSABLE OPEN
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BAOPEN(LU,CFN,IRET)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO OPEN
C     CFN          CHARACTER FILENAME TO OPEN
C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
C   OUTPUT ARGUMENTS:
C     IRET         INTEGER RETURN CODE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER CFN*(*)
      CHARACTER(80) CMSG
      INTEGER SIZE = 1

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(LU.LT.001.OR.LU.GT.999) THEN
        IRET=6
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IRET=BACIO(BACIO_OPENRW,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BAOPENR(LU,CFN,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BAOPENR        BYTE-ADDRESSABLE OPEN
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR READ ONLY.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BAOPENR(LU,CFN,IRET)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO OPEN
C     CFN          CHARACTER FILENAME TO OPEN
C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
C   OUTPUT ARGUMENTS:
C     IRET         INTEGER RETURN CODE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER CFN*(*)
      INTEGER SIZE = 1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(LU.LT.001.OR.LU.GT.999) THEN
        IRET=6
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IRET=BACIO(BACIO_OPENR,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BAOPENW(LU,CFN,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BAOPENW        BYTE-ADDRESSABLE OPEN
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BAOPENW(LU,CFN,IRET)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO OPEN
C     CFN          CHARACTER FILENAME TO OPEN
C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
C   OUTPUT ARGUMENTS:
C     IRET         INTEGER RETURN CODE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER CFN*(*)
      INTEGER SIZE = 1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(LU.LT.001.OR.LU.GT.999) THEN
        IRET=6
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IRET=BACIO(BACIO_OPENWT,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BAOPENWT(LU,CFN,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BAOPENWT       BYTE-ADDRESSABLE OPEN
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH TRUNCATION.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BAOPENWT(LU,CFN,IRET)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO OPEN
C     CFN          CHARACTER FILENAME TO OPEN
C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
C   OUTPUT ARGUMENTS:
C     IRET         INTEGER RETURN CODE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER CFN*(*)
      INTEGER SIZE = 1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(LU.LT.001.OR.LU.GT.999) THEN
        IRET=6
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IRET=BACIO(BACIO_OPENWT,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BAOPENWA(LU,CFN,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BAOPENWA       BYTE-ADDRESSABLE OPEN
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH APPEND.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BAOPENWA(LU,CFN,IRET)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO OPEN
C     CFN          CHARACTER FILENAME TO OPEN
C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
C   OUTPUT ARGUMENTS:
C     IRET         INTEGER RETURN CODE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER CFN*(*)
      INTEGER SIZE = 1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(LU.LT.001.OR.LU.GT.999) THEN
        IRET=6
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IRET=BACIO(BACIO_OPENWA,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BACLOSE(LU,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BACLOSE        BYTE-ADDRESSABLE CLOSE
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: CLOSE A BYTE-ADDRESSABLE FILE.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BACLOSE(LU,IRET)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO CLOSE
C   OUTPUT ARGUMENTS:
C     IRET         INTEGER RETURN CODE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      INTEGER SIZE = 1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(LU.LT.001.OR.LU.GT.999) THEN
        IRET=6
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IRET=BACIO(BACIO_CLOSE,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
      IF(IRET.EQ.0) FD(LU)=0
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BAREAD(LU,IB,NB,KA,A)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BAREAD         BYTE-ADDRESSABLE READ
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: READ A GIVEN NUMBER OF BYTES FROM AN UNBLOCKED FILE,
C   SKIPPING A GIVEN NUMBER OF BYTES.
C   THE PHYSICAL I/O IS BLOCKED INTO FOUR 4096-BYTE BUFFERS
C   IF THE BYTE-ADDRESSABLE OPTION 1 HAS BEEN SET TO 1 BY BASETO.
C   THIS BUFFERED READING IS INCOMPATIBLE WITH NO-SEEK READING.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BAREAD(LU,IB,NB,KA,A)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO READ
C     IB           INTEGER NUMBER OF BYTES TO SKIP
C                  (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING)
C     NB           INTEGER NUMBER OF BYTES TO READ
C   OUTPUT ARGUMENTS:
C     KA           INTEGER NUMBER OF BYTES ACTUALLY READ
C     A            CHARACTER*1 (NB) DATA READ
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER A(NB)
      CHARACTER CFN
      PARAMETER(NY=4096,MY=4)
      INTEGER NS(MY),NN(MY)
      CHARACTER Y(NY,MY)
      DATA LUX/0/
      SAVE JY,NS,NN,Y,LUX
      INTEGER SIZE=1
      INTEGER ZERO=0
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(FD(LU).LE.0) THEN
        KA=0
        RETURN
      ENDIF
      IF(IB.LT.0.AND.BAOPTS(1).EQ.1) THEN
        KA=0
        RETURN
      ENDIF
      IF(NB.LE.0) THEN
        KA=0
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  UNBUFFERED I/O
      IF(BAOPTS(1).NE.1) THEN
        IF(IB.GE.0) THEN
           
          IRET=BACIO(BACIO_READ,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
        ELSE
          IRET=BACIO(BACIO_READ+BACIO_NOSEEK,ZERO,JB,SIZE,NB,KA,
     &          FD(LU),CFN,A)
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  BUFFERED I/O
C  GET DATA FROM PREVIOUS CALL IF POSSIBLE
      ELSE
        KA=0
        IF(LUX.NE.LU) THEN
          JY=0
          NS=0
          NN=0
        ELSE
          DO I=1,MY
            IY=MOD(JY+I-1,MY)+1
            KY=IB+KA-NS(IY)
            IF(KA.LT.NB.AND.KY.GE.0.AND.KY.LT.NN(IY)) THEN
              K=MIN(NB-KA,NN(IY)-KY)
              A(KA+1:KA+K)=Y(KY+1:KY+K,IY)
              KA=KA+K
            ENDIF
          ENDDO
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SET POSITION AND READ BUFFER AND GET DATA
        IF(KA.LT.NB) THEN
          LUX=ABS(LU)
          JY=MOD(JY,MY)+1
          NS(JY)=IB+KA
          IRET=BACIO(BACIO_READ,NS(JY),JB,SIZE,NY,NN(JY),
     &               FD(LUX),CFN,Y(1,JY))
          IF(NN(JY).GT.0) THEN
            K=MIN(NB-KA,NN(JY))
            A(KA+1:KA+K)=Y(1:K,JY)
            KA=KA+K
          ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CONTINUE TO READ BUFFER AND GET DATA
          DOWHILE(NN(JY).EQ.NY.AND.KA.LT.NB)
            JY=MOD(JY,MY)+1
            NS(JY)=NS(JY)+NN(JY)
            IRET=BACIO(BACIO_READ+BACIO_NOSEEK,NS(JY),JB,SIZE,NY,NN(JY),
     &                 FD(LUX),CFN,Y(1,JY))
            IF(NN(JY).GT.0) THEN
              K=MIN(NB-KA,NN(JY))
              A(KA+1:KA+K)=Y(1:K,JY)
              KA=KA+K
            ENDIF
          ENDDO
        ENDIF
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE BAWRITE(LU,IB,NB,KA,A)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: BAWRITE        BYTE-ADDRESSABLE WRITE
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE,
C   SKIPPING A GIVEN NUMBER OF BYTES.
C
C PROGRAM HISTORY LOG:
C   1998-06-04  IREDELL
C
C USAGE:    CALL BAWRITE(LU,IB,NB,KA,A)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO WRITE
C     IB           INTEGER NUMBER OF BYTES TO SKIP
C                  (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING)
C     NB           INTEGER NUMBER OF BYTES TO WRITE
C     A            CHARACTER*1 (NB) DATA TO WRITE
C   OUTPUT ARGUMENTS:
C     KA           INTEGER NUMBER OF BYTES ACTUALLY WRITTEN
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER A(NB)
      CHARACTER CFN
      INTEGER SIZE=1
      INTEGER ZERO=0
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(FD(LU).LE.0) THEN
        KA=0
        RETURN
      ENDIF
      IF(NB.LE.0) THEN
        KA=0
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(IB.GE.0) THEN
        IRET=BACIO(BACIO_WRITE,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
      ELSE
        IRET=BACIO(BACIO_WRITE+BACIO_NOSEEK,ZERO,JB,SIZE,NB,KA,
     &        FD(LU),CFN,A)
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END
C-----------------------------------------------------------------------
      SUBROUTINE WRYTE(LU,NB,A)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: WRYTE          WRITE DATA OUT BY BYTES
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
C
C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE.
C
C PROGRAM HISTORY LOG:
C   92-10-31  IREDELL
C   95-10-31  IREDELL     WORKSTATION VERSION
C   1998-06-04  IREDELL   BACIO VERSION
C
C USAGE:    CALL WRYTE(LU,NB,A)
C   INPUT ARGUMENTS:
C     LU           INTEGER UNIT TO WHICH TO WRITE
C     NB           INTEGER NUMBER OF BYTES TO WRITE
C     A            CHARACTER*1 (NB) DATA TO WRITE
C
C MODULES USED:
C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
C
C SUBPROGRAMS CALLED:
C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
C
C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE BACIO_MODULE
      CHARACTER A(NB)
      CHARACTER CFN
      INTEGER SIZE=1
      INTEGER ZERO=0
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(FD(LU).LE.0) THEN
        RETURN
      ENDIF
      IF(NB.LE.0) THEN
        RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IRET=BACIO(BACIO_WRITE+BACIO_NOSEEK,ZERO,JB,SIZE,NB,KA,FD(LU),
     &        CFN,A)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END