ufbseq.f

Go to the documentation of this file.

C> @file
C> @brief Read/write an entire sequence of data values from/to
C> a data subset.

C> This subroutine reads or writes an entire sequence of data values
C> from or to the BUFR data subset that is currently open within the
C> BUFRLIB internal arrays.  The direction of the data transfer is
C> determined by the context of ABS(LUNIN):
C> - If ABS(LUNIN) points to a file that was previously opened for
C>   input using subroutine openbf(), then data values are read from
C>   the current data subset.
C> - If ABS(LUNIN) points to a file that was previously opened for
C>   output using subroutine openbf(), then data values are written to
C>   the current data subset.
C>
C> <p>This subroutine is specifically designed for use with a single
C> Table A or Table D mnemonic.  In the latter case, the mnemonic
C> may be replicated within the overall subset definition, and in
C> which case the subroutine will return all data values within all
C> replications of the sequence defined by the mnemonic.  But in
C> either case, the mnemonic itself may contain, within its own
C> sequence definition, any number of data values defined by Table B
C> mnemonics and/or subsequences of data values defined by other
C> Table D mnemonics, and any such subsequences may themselves be
C> replicated using any manner of fixed or delayed replication.
C> See [DX BUFR Tables](@ref ufbsubs) for more details including
C> an example use case, and see also subroutines ufbint(), ufbrep()
C> and ufbstp() which are also used to read/write one or more data
C> values from/to a data subset but cannot themselves be directly
C> used with Table A or Table D mnemonics.
C>
C> @authors J. Woollen
C> @authors J. Ator
C> @date 2000-09-19
C>
C> @param[in] LUNIN   -- integer: Absolute value is Fortran logical
C>                       unit number for BUFR file
C> @param[in,out] USR -- real*8(*,*): Data values
C>                         - If ABS(LUNIN) was opened for input, then
C>                           USR is output from this subroutine and
C>                           contains data values that were read
C>                           from the current data subset.
C>                         - If ABS(LUNIN) was opened for output, then
C>                           USR is input to this subroutine and
C>                           contains data values that are to be
C>                           written to the current data subset.
C> @param[in] I1 -- integer: Actual first dimension of USR as allocated
C>                  within the calling program
C> @param[in] I2 -- integer:
C>                    - If ABS(LUNIN) was opened for input, then I2
C>                      must be set equal to the actual second dimension
C>                      of USR as allocated within the calling program
C>                    - If ABS(LUNIN) was opened for output, then I2
C>                      must be set equal to the number of replications
C>                      of STR that are to be written to the data subset
C> @param[out] IRET -- integer: Number of replications of STR that were
C>                     actually read/written from/to the data subset
C> @param[in] STR -- character*(*): String consisting of a single Table A
C>                   or Table D mnemonic whose sequence definition is
C>                   in one-to-one correspondence with the number of data
C>                   values that will be read/written from/to the data
C>                   subset within the first dimension of USR
C>                   (see [DX BUFR Tables](@ref dfbftab) for further
C>                   information about Table A and Table D mnemonics)
C>
C> <p>It is the user's responsibility to ensure that USR is dimensioned
C> sufficiently large enough to accommodate the number of data values
C> that are to be read from or written to the data subset.  Note also
C> that USR is an array of real*8 values; therefore, any data that are
C> to be written out as character (i.e. CCITT IA5) values in
C> BUFR must be converted from character into real*8 format within the
C> application program before calling this subroutine.  Conversely,
C> when this subroutine is being used to read character values from a
C> data subset, the value that is returned will be in real*8 format
C> and must be converted back into character format by the application
C> program before it can be used as such.  Alternatively, there are
C> different subroutines such as readlc() and writlc() which can be
C> used to read/write character data directly from/to a data subset
C> without the need to convert from/to real*8 format as an intermediate
C> step.
C>
C> <p>Numeric (i.e. non-character) data values within USR are always in
C> the exact units specified for the corresponding mnemonic within the
C> relevant DX or master BUFR table, without any scale or reference
C> values applied.  Specifically, this means that, when writing
C> data values into an output subset, the user only needs to store each
C> respective value into USR using the units specified within the table,
C> and the BUFRLIB software will take care of any necessary scaling or
C> referencing of the value before it is actually encoded into BUFR.
C> Conversely, when reading data values from an input subset, the
C> values returned in USR are already de-scaled and de-referenced and,
C> thus, are already in the exact units that were defined for the
C> corresponding mnemonics within the table.
C>
C> <p>"Missing" values in USR are always denoted by a unique
C> placeholder value.  This placeholder value is initially set
C> to a default value of 10E10_8, but it can be reset to
C> any substitute value of the user's choice via a separate
C> call to subroutine setbmiss().  In any case, and whenever this
C> subroutine is used to read data values from an input subset, any
C> returned value in USR can be easily checked for equivalence to the
C> current placeholder value via a call to function ibfms(), and a
C> positive result means that the value for the corresponding mnemonic
C> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
C> original data subset.  Conversely, whenever this subroutine
C> is used to write data values to an output subset, the current
C> placeholder value can be obtained via a separate call to function
C> getbmiss(), and the resulting value can then be stored into the
C> USR array whereever the user desires a BUFR "missing" value (i.e.
C> all bits set to 1) to be encoded for the corresponding mnemonic
C> within the output subset.
C>
C> @remarks
C> - If LUNIN < 0, and if ABS(LUNIN) points to a file that is open
C> for output (writing BUFR), then the subroutine will treat the file
C> pointed to by ABS(LUNIN) as though it was open for input (reading
C> BUFR).  This is a special capability for use by some applications
C> that need to read certain values back out from a BUFR file during
C> the same time that it is in the process of being written to.
C> - If ABS(LUNIN) points to a file that is open for output
C> (writing BUFR), and if the data values to be written are part of
C> a sequence replicated using delayed replication, then a call to
C> subroutine drfini() must be made prior to calling this subroutine,
C> in order to pre-allocate the necessary internal array space for
C> the number of replications of the sequence.
C>
C> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2000-09-19 | J. Woollen | Original author |
C> | 2002-05-14 | J. Woollen | Improved generality; previously ufbseq would not recognize compressed delayed replication as a legitimate data structure |
C> | 2003-05-19 | J. Woollen | Corrected the logic array of exit conditions for the subroutine; previously, in some cases, proper exits were missed, generating bogus error messages |
C> | 2003-11-04 | S. Bender  | Added remarks and routine interdependencies |
C> | 2003-11-04 | D. Keyser  | Unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally |
C> | 2004-08-18 | J. Ator    | Added SAVE for IFIRST1 and IFIRST2 flags |
C> | 2007-01-19 | J. Ator    | Replaced call to parseq with call to parstr() |
C> | 2009-04-21 | J. Ator    | Use errwrt() |
C> | 2014-09-10 | J. Ator    | Fix bug involving nested delayed replication where first replication of outer sequence does not contain a replication of the inner sequence |
C> | 2014-12-10 | J. Ator    | Use modules instead of COMMON blocks |
C> | 2020-03-06 | J. Ator    | No longer abort when reading data and number of available levels is greater than I2; instead just return first I2 levels and print a diagnostic message |
C>
      SUBROUTINE ufbseq(LUNIN,USR,I1,I2,IRET,STR)

      USE modv_bmiss
      USE moda_usrint
      USE moda_msgcwd
      USE moda_tables

      parameter(mtag=10)

      COMMON /quiet / iprt

      CHARACTER*(*) str
      CHARACTER*156 bort_str
      CHARACTER*128 errstr
      CHARACTER*10  tags(mtag)
      REAL*8        usr(i1,i2)

      DATA ifirst1/0/,ifirst2/0/

      SAVE ifirst1, ifirst2

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      iret = 0

C  CHECK THE FILE STATUS AND I-NODE
C  --------------------------------

      lunit = abs(lunin)
      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) goto 900
      IF(im.EQ.0) goto 901

      io = min(max(0,il),1)
      IF(lunit.NE.lunin) io = 0

      IF(i1.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         goto 100
      ELSEIF(i2.LE.0) THEN
         IF(iprt.EQ.-1)  ifirst1 = 1
         IF(io.EQ.0 .OR. ifirst1.EQ.0 .OR. iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
            IF(iprt.EQ.0 .AND. io.EQ.1) THEN
      errstr = 'Note: Only the first occurrence of this WARNING ' //
     .   'message is printed, there may be more.  To output all ' //
     .   'such messages,'
      CALL errwrt(errstr)
      errstr = 'modify your application program to add ' //
     .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
     .   'to a BUFRLIB routine.'
      CALL errwrt(errstr)
            ENDIF
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
            ifirst1 = 1
         ENDIF
         goto 100
      ENDIF

C  CHECK FOR VALID SEQUENCE AND SEQUENCE LENGTH ARGUMENTS
C  ------------------------------------------------------

      CALL parstr(str,tags,mtag,ntag,' ',.true.)
      IF(ntag.LT.1) goto 902
      IF(ntag.GT.1) goto 903
      IF(i1.LE.0) goto 904
      IF(i2.LE.0) goto 905
      IF(inode(lun).NE.inv(1,lun)) goto 906


C  INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
C  --------------------------------------------------

      IF(io.EQ.0) THEN
         DO j=1,i2
         DO i=1,i1
         usr(i,j) = bmiss
         ENDDO
         ENDDO
      ENDIF


C  FIND THE PARAMETERS OF THE SPECIFIED SEQUENCE
C  ---------------------------------------------

      DO node=inode(lun),isc(inode(lun))
      IF(str.EQ.tag(node)) THEN
         IF(typ(node).EQ.'SEQ'.OR.typ(node).EQ.'RPC') THEN
            ins1 = 1
5           ins1 = invtag(node,lun,ins1,nval(lun))
            IF(ins1.EQ.0) goto 200
            IF(typ(node).EQ.'RPC'.AND.val(ins1,lun).EQ.0.) THEN
               ins1 = ins1+1
               goto 5
            ENDIF
            ins2 = invtag(node,lun,ins1+1,nval(lun))
            IF(ins2.EQ.0) ins2 = 10e5
            nods = node
            DO WHILE(link(nods).EQ.0.AND.jmpb(nods).GT.0)
            nods = jmpb(nods)
            ENDDO
            IF(link(nods).EQ.0) THEN
               insx = nval(lun)
            ELSEIF(link(nods).GT.0) THEN
               insx = invwin(link(nods),lun,ins1+1,nval(lun))-1
            ENDIF
            ins2 = min(ins2,insx)
         ELSEIF(typ(node).EQ.'SUB') THEN
            ins1 = 1
            ins2 = nval(lun)
         ELSE
            goto 907
         ENDIF
         nseq = 0
         DO isq=ins1,ins2
         ityp = itp(inv(isq,lun))
         IF(ityp.GT.1) nseq = nseq+1
         ENDDO
         IF(nseq.GT.i1) goto 908
         goto 1
      ENDIF
      ENDDO

      goto 200

C  FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME
C  ----------------------------------------------------

1     ins1 = invtag(node,lun,ins1,nval(lun))
      IF(ins1.GT.nval(lun)) goto 200
      IF(ins1.GT.0) THEN
         IF(typ(node).EQ.'RPC'.AND.val(ins1,lun).EQ.0.) THEN
            ins1 = ins1+1
            goto 1
         ELSEIF(io.EQ.0.AND.iret+1.GT.i2) THEN
            IF(iprt.GE.0)  THEN
      CALL errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
      WRITE ( unit=errstr, fmt='(A,I5,A,A,A)' )
     . 'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2,
     . ' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1),
     . ' WERE READ'
      CALL errwrt(errstr)
      CALL errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
      CALL errwrt(' ')
            ENDIF
            goto 200
         ENDIF
      ELSEIF(ins1.EQ.0) THEN
         IF(io.EQ.1.AND.iret.LT.i2) goto 910
      ELSE
         goto 911
      ENDIF

      IF(ins1.EQ. 0) goto 200
      IF(iret.EQ.i2) goto 200

      iret = iret+1
      ins1 = ins1+1

C  READ/WRITE USER VALUES
C  ----------------------

      j = ins1
      DO i=1,nseq
      DO WHILE(itp(inv(j,lun)).LT.2)
      j = j+1
      ENDDO
      IF(io.EQ.0) usr(i,iret) = val(j,lun )
      IF(io.EQ.1) val(j,lun ) = usr(i,iret)
      j = j+1
      ENDDO

C  CHECK FOR NEXT FRAME
C  --------------------

      goto 1

200   CONTINUE

      IF(iret.EQ.0)  THEN
         IF(io.EQ.0) THEN
            IF(iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
            ENDIF
         ELSE
            IF(iprt.EQ.-1)  ifirst2 = 1
            IF(ifirst2.EQ.0 .OR. iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
               IF(iprt.EQ.0) THEN
      errstr = 'Note: Only the first occurrence of this WARNING ' //
     .   'message is printed, there may be more.  To output all ' //
     .   'such messages,'
      CALL errwrt(errstr)
      errstr = 'modify your application program to add ' //
     .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
     .   'to a BUFRLIB routine.'
      CALL errwrt(errstr)
               ENDIF
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
               ifirst2 = 1
            ENDIF
         ENDIF
      ENDIF

C  EXITS
C  -----

100   RETURN
900   CALL bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'//
     . ' OPEN')
901   CALL bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '//
     . 'FILE, NONE ARE')
902   WRITE(bort_str,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '//
     . 'DOES NOT CONTAIN ANY MNEMONICS!!")') str
      CALL bort(bort_str)
903   WRITE(bort_str,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '//
     . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'//
     . ',")")') str,ntag
      CALL bort(bort_str)
904   WRITE(bort_str,'("BUFRLIB: UFBSEQ - THIRD ARGUMENT (INPUT) MUST'//
     . .GT.' BE  ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
     . i1,tags(1)
      CALL bort(bort_str)
905   WRITE(bort_str,'("BUFRLIB: UFBSEQ - FOURTH ARGUMENT (INPUT) '//
     . .GT.'MUST BE  ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
     . i2,tags(1)
      CALL bort(bort_str)
906   CALL bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '//
     . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
     . 'SUBSET ARRAY')
907   WRITE(bort_str,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '//
     . 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
      CALL bort(bort_str)
908   WRITE(bort_str,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'//
     . .GT.'" CONSISTS OF",I4," TABLE B MNEM.,  THE MAX. SPECIFIED IN'//
     . ' (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1
      CALL bort(bort_str)
910   WRITE(bort_str,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '//
     . .LT.'(",I5,")  NO. REQUESTED (",I5,") - INCOMPLETE WRITE '//
     . '(INPUT MNEMONIC IS ",A,")")')  iret,i2,tags(1)
      CALL bort(bort_str)
911   WRITE(bort_str,.GE.'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE  '//
     . 'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') ins1,tags(1)
      CALL bort(bort_str)
      END