ufbrw.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM
C>   THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE
C>   DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO
C>   (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR
C>   INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET;
C>   OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET).
C>   THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED
C>   STRINGS OF MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION
C>   SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL.
C>
C>   THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM;
C>   INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE
C>   LIBRARY SUBROUTINE UFBINT.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1996-12-11  J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO
C>                           WRITE NON-EXISTING MNEMONICS
C> 1998-07-08  J. WOOLLEN -- IMPROVED MACHINE PORTABILITY
C> 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C>                           LINING CODE WITH FPP DIRECTIVES
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED DOCUMENTATION (INCLUDING
C>                           HISTORY)
C> 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS
C> 2009-03-31  J. WOOLLEN -- ADD DOCUMENTATION
C> 2009-04-21  J. ATOR    -- USE ERRWRT; USE LSTJPB INSTEAD OF LSTRPS
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL UFBRW (LUN, USR, I1, I2, IO, IRET)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     USR      - ONLY IF BUFR FILE OPEN FOR OUTPUT:
C>                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
C>                   WRITTEN TO DATA SUBSET
C>     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR
C>     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF USR
C>     IO       - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
C>                WITH LUN:
C>                       0 = input file
C>                       1 = output file
C>
C>   OUTPUT ARGUMENT LIST:
C>     USR      - ONLY IF BUFR FILE OPEN FOR INPUT:
C>                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
C>                   READ FROM DATA SUBSET
C>     IRET     - INTEGER:
C>                  - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF
C>                    DATA VALUES READ FROM DATA SUBSET (MUST BE NO
C>                    LARGER THAN I2)
C>                      -1 = NONE OF THE MNEMONICS IN THE STRING PASSED
C>                           TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE
C>                  - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS"
C>                    OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE
C>                    SAME AS I2)
C>                      -1 = NONE OF THE MNEMONICS IN THE STRING PASSED
C>                           TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        CONWIN   DRSTPL   ERRWRT   GETWIN
C>                               IBFMS    INVWIN   LSTJPB   NEWWIN
C>                               NXTWIN
C>    THIS ROUTINE IS CALLED BY: TRYBUMP  UFBINT
C>                               Normally not called by any application
C>                               programs (they should call UFBINT).
C>
      SUBROUTINE ufbrw(LUN,USR,I1,I2,IO,IRET)
 
      USE modv_bmiss
      USE moda_usrint
      USE moda_tables
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
      COMMON /quiet / iprt
 
      CHARACTER*128 ERRSTR
      real*8       usr(i1,i2)
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
      iret = 0
 
C  LOOP OVER COND WINDOWS
C  ----------------------
 
      inc1 = 1
      inc2 = 1
 
1     CALL conwin(lun,inc1,inc2)
      IF(nnod.EQ.0) THEN
         iret = i2
         GOTO 100
      ELSEIF(inc1.EQ.0) THEN
         GOTO 100
      ELSE
         DO i=1,nnod
         IF(nods(i).GT.0) THEN
            ins2 = inc1
            CALL getwin(nods(i),lun,ins1,ins2)
            IF(ins1.EQ.0) GOTO 100
            GOTO 2
         ENDIF
         ENDDO
         iret = -1
         GOTO 100
      ENDIF
 
C  LOOP OVER STORE NODES
C  ---------------------
 
2     iret = iret+1
 
      IF(iprt.GE.2)  THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
         WRITE ( unit=errstr, fmt='(5(A,I7))' )
     .      'BUFRLIB: UFBRW - IRET:INS1:INS2:INC1:INC2 = ',
     .      iret, ':', ins1, ':', ins2, ':', inc1, ':', inc2
         CALL errwrt(errstr)
         kk = ins1
         DO WHILE ( ( ins2 - kk ) .GE. 5 )
            WRITE ( unit=errstr, fmt='(5A10)' )
     .         (tag(inv(i,lun)),i=kk,kk+4)
            CALL errwrt(errstr)
            kk = kk+5
         ENDDO
         WRITE ( unit=errstr, fmt='(5A10)' )
     .      (tag(inv(i,lun)),i=kk,ins2)
         CALL errwrt(errstr)
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt(' ')
      ENDIF
 
C  WRITE USER VALUES
C  -----------------
 
      IF(io.EQ.1 .AND. iret.LE.i2) THEN
         DO i=1,nnod
         IF(nods(i).GT.0) THEN
            IF(ibfms(usr(i,iret)).EQ.0) THEN
               invn = invwin(nods(i),lun,ins1,ins2)
               IF(invn.EQ.0) THEN
                  CALL drstpl(nods(i),lun,ins1,ins2,invn)
                  IF(invn.EQ.0) THEN
                     iret = 0
                     GOTO 100
                  ENDIF
                  CALL newwin(lun,inc1,inc2)
                  val(invn,lun) = usr(i,iret)
               ELSEIF(lstjpb(nods(i),lun,'RPS').EQ.0) THEN
                  val(invn,lun) = usr(i,iret)
               ELSEIF(ibfms(val(invn,lun)).NE.0) THEN
                  val(invn,lun) = usr(i,iret)
               ELSE
                  CALL drstpl(nods(i),lun,ins1,ins2,invn)
                  IF(invn.EQ.0) THEN
                     iret = 0
                     GOTO 100
                  ENDIF
                  CALL newwin(lun,inc1,inc2)
                  val(invn,lun) = usr(i,iret)
               ENDIF
            ENDIF
         ENDIF
         ENDDO
      ENDIF
 
C  READ USER VALUES
C  ----------------
 
      IF(io.EQ.0 .AND. iret.LE.i2) THEN
         DO i=1,nnod
         usr(i,iret) = bmiss
         IF(nods(i).GT.0) THEN
            invn = invwin(nods(i),lun,ins1,ins2)
            IF(invn.GT.0) usr(i,iret) = val(invn,lun)
         ENDIF
         ENDDO
      ENDIF
 
C  DECIDE WHAT TO DO NEXT
C  ----------------------
 
      IF(io.EQ.1.AND.iret.EQ.i2) GOTO 100
      CALL nxtwin(lun,ins1,ins2)
      IF(ins1.GT.0 .AND. ins1.LT.inc2) GOTO 2
      IF(ncon.GT.0) GOTO 1
 
C  EXIT
C  ----
 
100   RETURN
      END