var/external/bufr/ufbevn.f

   1       SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBEVN
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT
   9 C   BUFR DATA SUBSET WITHIN INTERNAL ARRAYS.  THE DATA VALUES
  10 C   CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION
  11 C   SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE.  THE INNER
  12 C   SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER
  13 C   SEQUENCE WITH DATA "EVENTS".  THE BUFR FILE IN LOGICAL UNIT LUNIT
  14 C   MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE
  15 C   LIBRARY SUBROUTINE OPENBF.   IN ADDITION, THE DATA SUBSET MUST HAVE
  16 C   SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY
  17 C   ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR
  18 C   READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE
  19 C   READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY
  20 C   SUBROUTINE READNS).  OTHER THAN THE ADDITION OF A THIRD
  21 C   DIMENSION AND THE READ ONLY RESTRICTION, THE CONTEXT AND USAGE OF
  22 C   UFBEVN IS EXACTLY THE SAME AS FOR BUFR ARCHIVE LIBRARY SUBROUTINES
  23 C   UFBINT, UFBREP AND UFBSEQ.  THIS SUBROUTINE IS DESIGNED TO READ
  24 C   EVENT INFORMATION FROM "PREPBUFR" TYPE BUFR FILES.  PREPBUFR FILES
  25 C   HAVE THE FOLLOWING BUFR TABLE EVENT STRUCTURE (NOTE SIXTEEN
  26 C   CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN TO ALLOW THE
  27 C   TABLE TO FIT IN THIS DOCBLOCK):
  28 C
  29 C   | ADPUPA   | HEADR  {PLEVL}                                    |
  30 C   | HEADR    | SID  XOB  YOB  DHR  ELV  TYP  T29  TSB  ITP  SQN  |
  31 C   | PLEVL    | CAT <PINFO> <QINFO> <TINFO> <ZINFO> <WINFO>       |
  32 C   | PINFO    | [PEVN]             <PBACKG>  <PPOSTP>             |
  33 C   | QINFO    | [QEVN]    TDO      <QBACKG>  <QPOSTP>             |
  34 C   | TINFO    | [TEVN]    TVO      <TBACKG>  <TPOSTP>             |
  35 C   | ZINFO    | [ZEVN]             <ZBACKG>  <ZPOSTP>             |
  36 C   | WINFO    | [WEVN]             <WBACKG>  <WPOSTP>             |
  37 C   | PEVN     | POB  PQM  PPC  PRC                                |
  38 C   | QEVN     | QOB  QQM  QPC  QRC                                |
  39 C   | TEVN     | TOB  TQM  TPC  TRC                                |
  40 C   | ZEVN     | ZOB  ZQM  ZPC  ZRC                                |
  41 C   | WEVN     | UOB  WQM  WPC  WRC  VOB                           |
  42 C   | PBACKG   | POE  PFC                                          |
  43 C   | QBACKG   | QOE  QFC                                          |
  44 C   | TBACKG   | TOE  TFC                                          |
  45 C   | ZBACKG   | ZOE  ZFC                                          |
  46 C   | WBACKG   | WOE  UFC  VFC                                     |
  47 C   | PPOSTP   | PAN                                               |
  48 C   | QPOSTP   | QAN                                               |
  49 C   | TPOSTP   | TAN                                               |
  50 C   | ZPOSTP   | ZAN                                               |
  51 C   | WPOSTP   | UAN  VAN                                          |
  52 C
  53 C   NOTE THAT THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES "[xxxx]"
  54 C   ARE NESTED INSIDE ONE-BIT DELAYED REPLICATED SEQUENCES "<yyyy>".
  55 C   THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBIN3 DOES NOT WORK
  56 C   PROPERLY ON THIS TYPE OF EVENT STRUCTURE.  IT WORKS ONLY ON THE
  57 C   EVENT STRUCTURE FOUND IN "PREPFITS" TYPE BUFR FILES (SEE UFBIN3 FOR
  58 C   MORE DETAILS).  IN TURN, UFBEVN DOES NOT WORK PROPERLY ON THE EVENT
  59 C   STRUCTURE FOUND IN PREPFITS FILES (ALWAYS USE UFBIN3 IN THIS CASE).
  60 C   ONE OTHER DIFFERENCE BETWEEN UFBEVN AND UFBIN3 IS THAT UFBEVN
  61 C   STORES THE MAXIMUM NUMBER OF EVENTS FOUND FOR ALL DATA VALUES
  62 C   SPECIFIED AMONGST ALL LEVELS RETURNED INTERNALLY IN COMMON BLOCK
  63 C   /UFBN3C/.  UFBIN3 RETURNS THIS VALUE AS AN ADDITIONAL OUTPUT
  64 C   ARGUMENT.
  65 C
  66 C PROGRAM HISTORY LOG:
  67 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  68 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  69 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  70 C                           ROUTINE "BORT"; IMPROVED MACHINE
  71 C                           PORTABILITY
  72 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  73 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  74 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  75 C                           BUFR FILES UNDER THE MPI)
  76 C 2003-11-04  J. WOOLLEN -- SAVES THE MAXIMUM NUMBER OF EVENTS FOUND
  77 C                           FOR ALL DATA VALUES SPECIFIED AMONGST ALL
  78 C                           LEVELS RETURNED AS VARIABLE MAXEVN IN NEW
  79 C                           COMMON BLOCK /UFBN3C/
  80 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  81 C                           INTERDEPENDENCIES
  82 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  83 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  84 C                           VERIFICATION VERSION); ADDED CALL TO BORT
  85 C                           IF BUFR FILE IS OPEN FOR OUTPUT; UNIFIED/
  86 C                           PORTABLE FOR WRF; ADDED DOCUMENTATION
  87 C                           (INCLUDING HISTORY); OUTPUTS MORE COMPLETE
  88 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  89 C                           ABNORMALLY OR UNUSUAL THINGS HAPPEN
  90 C 2009-04-21  J. ATOR    -- USE ERRWRT
  91 C
  92 C USAGE:    CALL UFBEVN (LUNIT, USR, I1, I2, I3, IRET, STR)
  93 C   INPUT ARGUMENT LIST:
  94 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  95 C     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE
  96 C                NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER
  97 C                MUST BE .GE. LATTER)
  98 C     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF USR
  99 C     I3       - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM
 100 C                VALUE IS 255)
 101 C     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
 102 C                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
 103 C                DIMENSION OF USR
 104 C                  - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
 105 C                     TO TABLE B, THESE RETURN THE FOLLOWING
 106 C                     INFORMATION IN CORRESPONDING USR LOCATION:
 107 C                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
 108 C                     'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
 109 C                            MESSAGE (RECORD) NUMBER IN WHICH THIS
 110 C                            SUBSET RESIDES
 111 C                     'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
 112 C                            NUMBER OF THIS SUBSET WITHIN THE BUFR
 113 C                            MESSAGE (RECORD) NUMBER 'IREC'
 114 C
 115 C   OUTPUT ARGUMENT LIST:
 116 C     USR      - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES
 117 C                READ FROM DATA SUBSET
 118 C     IRET     - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM
 119 C                DATA SUBSET (MUST BE NO LARGER THAN I2)
 120 C
 121 C REMARKS:
 122 C    APPLICATION PROGRAMS READING PREPFITS FILES SHOULD NOT CALL THIS
 123 C    ROUTINE.
 124 C
 125 C    THIS ROUTINE CALLS:        BORT     CONWIN   ERRWRT   GETWIN
 126 C                               NVNWIN   NXTWIN   STATUS   STRING
 127 C    THIS ROUTINE IS CALLED BY: None
 128 C                               Normally called only by application
 129 C                               programs.
 130 C
 131 C ATTRIBUTES:
 132 C   LANGUAGE: FORTRAN 77
 133 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 134 C
 135 C$$$
 136
 137       INCLUDE 'bufrlib.prm'
 138
 139       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 140      .                INODE(NFILES),IDATE(NFILES)
 141       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
 142       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
 143       COMMON /UFBN3C/ MAXEVN
 144       COMMON /QUIET / IPRT
 145
 146       CHARACTER*(*) STR
 147       CHARACTER*128 ERRSTR
 148       DIMENSION     INVN(255)
 149       REAL*8        VAL,USR(I1,I2,I3)
 150
 151 C----------------------------------------------------------------------
 152 C----------------------------------------------------------------------
 153
 154       MAXEVN = 0
 155       IRET   = 0
 156
 157 C  CHECK THE FILE STATUS AND I-NODE
 158 C  --------------------------------
 159
 160       CALL STATUS(LUNIT,LUN,IL,IM)
 161       IF(IL.EQ.0) GOTO 900
 162       IF(IL.GT.0) GOTO 901
 163       IF(IM.EQ.0) GOTO 902
 164       IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903
 165
 166       IF(I1.LE.0) THEN
 167          IF(IPRT.GE.0) THEN
 168       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 169       ERRSTR = 'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS .LE. 0, ' //
 170      .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
 171       CALL ERRWRT(ERRSTR)
 172       CALL ERRWRT(STR)
 173       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 174       CALL ERRWRT(' ')
 175          ENDIF
 176          GOTO 100
 177       ELSEIF(I2.LE.0) THEN
 178          IF(IPRT.GE.0) THEN
 179       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 180       ERRSTR = 'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS .LE. 0, ' //
 181      .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
 182       CALL ERRWRT(ERRSTR)
 183       CALL ERRWRT(STR)
 184       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 185       CALL ERRWRT(' ')
 186          ENDIF
 187          GOTO 100
 188       ELSEIF(I3.LE.0) THEN
 189          IF(IPRT.GE.0) THEN
 190       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 191       ERRSTR = 'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS .LE. 0, ' //
 192      .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
 193       CALL ERRWRT(ERRSTR)
 194       CALL ERRWRT(STR)
 195       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 196       CALL ERRWRT(' ')
 197          ENDIF
 198          GOTO 100
 199       ENDIF
 200
 201 C  PARSE OR RECALL THE INPUT STRING
 202 C  --------------------------------
 203
 204       CALL STRING(STR,LUN,I1,0)
 205
 206 C  INITIALIZE USR ARRAY
 207 C  --------------------
 208
 209       DO K=1,I3
 210       DO J=1,I2
 211       DO I=1,I1
 212       USR(I,J,K) = BMISS
 213       ENDDO
 214       ENDDO
 215       ENDDO
 216
 217 C  LOOP OVER COND WINDOWS
 218 C  ----------------------
 219
 220       INC1 = 1
 221       INC2 = 1
 222
 223 1     CALL CONWIN(LUN,INC1,INC2)
 224       IF(NNOD.EQ.0) THEN
 225          IRET = I2
 226          GOTO 100
 227       ELSEIF(INC1.EQ.0) THEN
 228          GOTO 100
 229       ELSE
 230          DO I=1,NNOD
 231          IF(NODS(I).GT.0) THEN
 232             INS2 = INC1
 233             CALL GETWIN(NODS(I),LUN,INS1,INS2)
 234             IF(INS1.EQ.0) GOTO 100
 235             GOTO 2
 236          ENDIF
 237          ENDDO
 238          INS1 = INC1
 239          INS2 = INC2
 240       ENDIF
 241
 242 C  READ PUSH DOWN STACK DATA INTO 3D ARRAYS
 243 C  ----------------------------------------
 244
 245 2     IRET = IRET+1
 246       IF(IRET.LE.I2) THEN
 247          DO I=1,NNOD
 248          IF(NODS(I).GT.0) THEN
 249             NNVN = NVNWIN(NODS(I),LUN,INS1,INS2,INVN,I3)
 250             MAXEVN = MAX(NNVN,MAXEVN)
 251             DO N=1,NNVN
 252             USR(I,IRET,N) = VAL(INVN(N),LUN)
 253             ENDDO
 254          ENDIF
 255          ENDDO
 256       ENDIF
 257
 258 C  DECIDE WHAT TO DO NEXT
 259 C  ----------------------
 260
 261       CALL NXTWIN(LUN,INS1,INS2)
 262       IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2
 263       IF(NCON.GT.0) GOTO 1
 264
 265       IF(IRET.EQ.0)  THEN
 266          IF(IPRT.GE.1)  THEN
 267       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 268       ERRSTR = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, ' //
 269      .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
 270       CALL ERRWRT(ERRSTR)
 271       CALL ERRWRT(STR)
 272       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 273       CALL ERRWRT(' ')
 274          ENDIF
 275       ENDIF
 276
 277 C  EXITS
 278 C  -----
 279
 280 100   RETURN
 281 900   CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST'//
 282      . ' BE OPEN FOR INPUT')
 283 901   CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
 284      . ', IT MUST BE OPEN FOR INPUT')
 285 902   CALL BORT('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT '//
 286      . 'BUFR FILE, NONE ARE')
 287 903   CALL BORT('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '//
 288      . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
 289      . 'INTERNAL SUBSET ARRAY')
 290       END