var/external/bufr/ufbrw.f

   1       SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBRW
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM
   9 C   THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE
  10 C   DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO
  11 C   (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR
  12 C   INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET;
  13 C   OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET).
  14 C   THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED
  15 C   STRINGS OF MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION
  16 C   SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL.
  17 C
  18 C   THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM;
  19 C   INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE
  20 C   LIBRARY SUBROUTINE UFBINT.
  21 C
  22 C PROGRAM HISTORY LOG:
  23 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  24 C 1996-12-11  J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO
  25 C                           WRITE NON-EXISTING MNEMONICS
  26 C 1998-07-08  J. WOOLLEN -- IMPROVED MACHINE PORTABILITY
  27 C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  28 C                           LINING CODE WITH FPP DIRECTIVES
  29 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  30 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  31 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  32 C                           BUFR FILES UNDER THE MPI)
  33 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  34 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  35 C                           INTERDEPENDENCIES
  36 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  37 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  38 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  39 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  40 C                           HISTORY)
  41 C 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS
  42 C 2009-03-31  J. WOOLLEN -- ADD DOCUMENTATION
  43 C 2009-04-21  J. ATOR    -- USE ERRWRT; USE LSTJPB INSTEAD OF LSTRPS
  44 C
  45 C USAGE:    CALL UFBRW (LUN, USR, I1, I2, IO, IRET)
  46 C   INPUT ARGUMENT LIST:
  47 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  48 C     USR      - ONLY IF BUFR FILE OPEN FOR OUTPUT:
  49 C                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
  50 C                   WRITTEN TO DATA SUBSET
  51 C     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR
  52 C     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF USR
  53 C     IO       - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
  54 C                WITH LUN:
  55 C                       0 = input file
  56 C                       1 = output file
  57 C
  58 C   OUTPUT ARGUMENT LIST:
  59 C     USR      - ONLY IF BUFR FILE OPEN FOR INPUT:
  60 C                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
  61 C                   READ FROM DATA SUBSET
  62 C     IRET     - INTEGER:
  63 C                  - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF
  64 C                    DATA VALUES READ FROM DATA SUBSET (MUST BE NO
  65 C                    LARGER THAN I2)
  66 C                      -1 = NONE OF THE MNEMONICS IN THE STRING PASSED
  67 C                           TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE
  68 C                  - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS"
  69 C                    OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE
  70 C                    SAME AS I2)
  71 C                      -1 = NONE OF THE MNEMONICS IN THE STRING PASSED
  72 C                           TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE
  73 C
  74 C REMARKS:
  75 C    THIS ROUTINE CALLS:        CONWIN   DRSTPL   ERRWRT   GETWIN
  76 C                               IBFMS    INVWIN   LSTJPB   NEWWIN
  77 C                               NXTWIN
  78 C    THIS ROUTINE IS CALLED BY: TRYBUMP  UFBINT
  79 C                               Normally not called by any application
  80 C                               programs (they should call UFBINT).
  81 C
  82 C ATTRIBUTES:
  83 C   LANGUAGE: FORTRAN 77
  84 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  85 C
  86 C$$$
  87
  88       INCLUDE 'bufrlib.prm'
  89
  90       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  91      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  92      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  93      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  94      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  95       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  96       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
  97       COMMON /QUIET / IPRT
  98
  99       CHARACTER*128 ERRSTR
 100       CHARACTER*10 TAG
 101       CHARACTER*3  TYP
 102       REAL*8       USR(I1,I2),VAL
 103
 104 C----------------------------------------------------------------------
 105 C----------------------------------------------------------------------
 106
 107       IRET = 0
 108
 109 C  LOOP OVER COND WINDOWS
 110 C  ----------------------
 111
 112       INC1 = 1
 113       INC2 = 1
 114
 115 1     CALL CONWIN(LUN,INC1,INC2)
 116       IF(NNOD.EQ.0) THEN
 117          IRET = I2
 118          GOTO 100
 119       ELSEIF(INC1.EQ.0) THEN
 120          GOTO 100
 121       ELSE
 122          DO I=1,NNOD
 123          IF(NODS(I).GT.0) THEN
 124             INS2 = INC1
 125             CALL GETWIN(NODS(I),LUN,INS1,INS2)
 126             IF(INS1.EQ.0) GOTO 100
 127             GOTO 2
 128          ENDIF
 129          ENDDO
 130          IRET = -1
 131          GOTO 100
 132       ENDIF
 133
 134 C  LOOP OVER STORE NODES
 135 C  ---------------------
 136
 137 2     IRET = IRET+1
 138
 139       IF(IPRT.GE.2)  THEN
 140       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 141          WRITE ( UNIT=ERRSTR, FMT='(5(A,I4))' )
 142      .      'BUFRLIB: UFBRW - IRET:INS1:INS2:INC1:INC2 = ',
 143      .      IRET, ':', INS1, ':', INS2, ':', INC1, ':', INC2
 144          CALL ERRWRT(ERRSTR)
 145          KK = INS1
 146          DO WHILE ( ( INS2 - KK ) .GE. 5 )
 147             WRITE ( UNIT=ERRSTR, FMT='(5A10)' )
 148      .         (TAG(INV(I,LUN)),I=KK,KK+4)
 149             CALL ERRWRT(ERRSTR)
 150             KK = KK+5
 151          ENDDO
 152          WRITE ( UNIT=ERRSTR, FMT='(5A10)' )
 153      .      (TAG(INV(I,LUN)),I=KK,INS2)
 154          CALL ERRWRT(ERRSTR)
 155       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 156       CALL ERRWRT(' ')
 157       ENDIF
 158
 159 C  WRITE USER VALUES
 160 C  -----------------
 161
 162       IF(IO.EQ.1 .AND. IRET.LE.I2) THEN
 163          DO I=1,NNOD
 164          IF(NODS(I).GT.0) THEN
 165             IF(IBFMS(USR(I,IRET)).EQ.0) THEN
 166                INVN = INVWIN(NODS(I),LUN,INS1,INS2)
 167                IF(INVN.EQ.0) THEN
 168                   CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
 169                   IF(INVN.EQ.0) THEN
 170                      IRET = 0
 171                      GOTO 100
 172                   ENDIF
 173                   CALL NEWWIN(LUN,INC1,INC2)
 174                   VAL(INVN,LUN) = USR(I,IRET)
 175                ELSEIF(LSTJPB(NODS(I),LUN,'RPS').EQ.0) THEN
 176                   VAL(INVN,LUN) = USR(I,IRET)
 177                ELSEIF(IBFMS(VAL(INVN,LUN)).NE.0) THEN
 178                   VAL(INVN,LUN) = USR(I,IRET)
 179                ELSE
 180                   CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
 181                   IF(INVN.EQ.0) THEN
 182                      IRET = 0
 183                      GOTO 100
 184                   ENDIF
 185                   CALL NEWWIN(LUN,INC1,INC2)
 186                   VAL(INVN,LUN) = USR(I,IRET)
 187                ENDIF
 188             ENDIF
 189          ENDIF
 190          ENDDO
 191       ENDIF
 192
 193 C  READ USER VALUES
 194 C  ----------------
 195
 196       IF(IO.EQ.0 .AND. IRET.LE.I2) THEN
 197          DO I=1,NNOD
 198          USR(I,IRET) = BMISS
 199          IF(NODS(I).GT.0) THEN
 200             INVN = INVWIN(NODS(I),LUN,INS1,INS2)
 201             IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN)
 202          ENDIF
 203          ENDDO
 204       ENDIF
 205
 206 C  DECIDE WHAT TO DO NEXT
 207 C  ----------------------
 208
 209       IF(IO.EQ.1.AND.IRET.EQ.I2) GOTO 100
 210       CALL NXTWIN(LUN,INS1,INS2)
 211       IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2
 212       IF(NCON.GT.0) GOTO 1
 213
 214 C  EXIT
 215 C  ----
 216
 217 100   RETURN
 218       END