var/external/bufr/ufbin3.f

   1       SUBROUTINE UFBIN3(LUNIT,USR,I1,I2,I3,IRET,JRET,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBIN3
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2003-11-04
   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).  THIS SUBROUTINE IS DESIGNED TO READ EVENT
  21 C   INFORMATION FROM "PREPFITS" TYPE BUFR FILES (BUT NOT FROM
  22 C   "PREPBUFR" TYPE FILES!!).  PREPFITS FILES HAVE THE FOLLOWING BUFR
  23 C   TABLE EVENT STRUCTURE (NOTE SIXTEEN CHARACTERS HAVE BEEN REMOVED
  24 C   FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK):
  25 C
  26 C   | ADPUPA   | HEADR  {PLEVL}                                    |
  27 C   | HEADR    | SID XOB YOB DHR ELV TYP T29 ITP                   |
  28 C   | PLEVL    | CAT PRC PQM QQM TQM ZQM WQM CDTP_QM [OBLVL]       |
  29 C   | OBLVL    | SRC FHR <PEVN> <QEVN> <TEVN> <ZEVN> <WEVN> <CEVN> |
  30 C   | OBLVL    | <CTPEVN>                                          |
  31 C   | PEVN     | POB  PMO                                          |
  32 C   | QEVN     | QOB                                               |
  33 C   | TEVN     | TOB                                               |
  34 C   | ZEVN     | ZOB                                               |
  35 C   | WEVN     | UOB  VOB                                          |
  36 C   | CEVN     | CAPE CINH LI                                      |
  37 C   | CTPEVN   | CDTP GCDTT TOCC                                   |
  38 C
  39 C   NOTE THAT THE ONE-BIT DELAYED REPLICATED SEQUENCES "<xxxx>" ARE
  40 C   NESTED INSIDE THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES
  41 C   "[yyyy]".  THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBEVN
  42 C   DOES NOT WORK PROPERLY ON THIS TYPE OF EVENT STRUCTURE.  IT WORKS
  43 C   ONLY ON THE EVENT STRUCTURE FOUND IN "PREPBUFR" TYPE BUFR FILES
  44 C   (SEE UFBEVN FOR MORE DETAILS).  IN TURN, UFBIN3 DOES NOT WORK
  45 C   PROPERLY ON THE EVENT STRUCTURE FOUND IN PREPBUFR FILES (ALWAYS USE
  46 C   UFBEVN IN THIS CASE).  ONE OTHER DIFFERENCE BETWEEN UFBIN3 AND
  47 C   UFBEVN IS THAT UFBIN3 RETURNS THE MAXIMUM NUMBER OF EVENTS FOUND
  48 C   FOR ALL DATA VALUES SPECIFIED AS AN OUTPUT ARGUMENT (JRET).  UFBEVN
  49 C   DOES NOT DO THIS, BUT RATHER IT STORES THIS VALUE INTERNALLY IN
  50 C   COMMON BLOCK /UFBN3C/.
  51 C
  52 C PROGRAM HISTORY LOG:
  53 C 2003-11-04  J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION
  54 C                           VERSION)
  55 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  56 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  57 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  58 C                           ABNORMALLY OR UNUSUAL THINGS HAPPEN
  59 C 2009-04-21  J. ATOR    -- USE ERRWRT
  60 C
  61 C USAGE:    CALL UFBIN3 (LUNIT, USR, I1, I2, I3, IRET, JRET, STR)
  62 C   INPUT ARGUMENT LIST:
  63 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  64 C     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE
  65 C                NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER
  66 C                MUST BE .GE. LATTER)
  67 C     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF USR
  68 C     I3       - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM
  69 C                VALUE IS 255)
  70 C     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
  71 C                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
  72 C                DIMENSION OF USR
  73 C                  - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
  74 C                     TO TABLE B, THESE RETURN THE FOLLOWING
  75 C                     INFORMATION IN CORRESPONDING USR LOCATION:
  76 C                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
  77 C                     'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
  78 C                            MESSAGE (RECORD) NUMBER IN WHICH THIS
  79 C                            SUBSET RESIDES
  80 C                     'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
  81 C                            NUMBER OF THIS SUBSET WITHIN THE BUFR
  82 C                            MESSAGE (RECORD) NUMBER 'IREC'
  83 C
  84 C   OUTPUT ARGUMENT LIST:
  85 C     USR      - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES
  86 C                READ FROM DATA SUBSET
  87 C     IRET     - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM
  88 C                DATA SUBSET (MUST BE NO LARGER THAN I2)
  89 C     JRET     - INTEGER: MAXIMUM NUMBER OF "EVENTS" FOUND FOR ALL DATA
  90 C                VALUES SPECIFIED AMONGST ALL LEVELS READ FROM DATA
  91 C                SUBSET (MUST BE NO LARGER THAN I3)
  92 C
  93 C REMARKS:
  94 C    IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY THE VERIFICATION
  95 C               APPLICATION PROGRAM "GRIDTOBS", WHERE IT WAS PREVIOUSLY
  96 C               AN IN-LINE SUBROUTINE.  IN GENERAL, UFBIN3 DOES NOT
  97 C               WORK PROPERLY IN OTHER APPLICATION PROGRAMS (I.E, THOSE
  98 C               THAT ARE READING PREPBUFR FILES) AT THIS TIME.  ALWAYS
  99 C               USE UFBEVN INSTEAD!!
 100 C
 101 C    THIS ROUTINE CALLS:        BORT     CONWIN   ERRWRT   GETWIN
 102 C                               NEVN     NXTWIN   STATUS   STRING
 103 C    THIS ROUTINE IS CALLED BY: None
 104 C                               SHOULD NOT BE CALLED BY ANY APPLICATION
 105 C                               PROGRAMS EXCEPT GRIDTOBS!!
 106 C
 107 C ATTRIBUTES:
 108 C   LANGUAGE: FORTRAN 77
 109 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 110 C
 111 C$$$
 112
 113       INCLUDE 'bufrlib.prm'
 114
 115       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 116      .                INODE(NFILES),IDATE(NFILES)
 117       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
 118       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
 119       COMMON /QUIET / IPRT
 120
 121       CHARACTER*(*) STR
 122       CHARACTER*128 ERRSTR
 123       REAL*8        VAL,USR(I1,I2,I3)
 124
 125 C----------------------------------------------------------------------
 126 C----------------------------------------------------------------------
 127
 128       IRET = 0
 129       JRET = 0
 130
 131 C  CHECK THE FILE STATUS AND I-NODE
 132 C  --------------------------------
 133
 134       CALL STATUS(LUNIT,LUN,IL,IM)
 135       IF(IL.EQ.0) GOTO 900
 136       IF(IL.GT.0) GOTO 901
 137       IF(IM.EQ.0) GOTO 902
 138       IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903
 139
 140       IF(I1.LE.0) THEN
 141          IF(IPRT.GE.0) THEN
 142       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 143       ERRSTR = 'BUFRLIB: UFBIN3 - 3rd ARG. (INPUT) IS .LE. 0, ' //
 144      .   'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' //
 145      .   '8th ARG. (STR) ='
 146       CALL ERRWRT(ERRSTR)
 147       CALL ERRWRT(STR)
 148       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 149       CALL ERRWRT(' ')
 150          ENDIF
 151          GOTO 100
 152       ELSEIF(I2.LE.0) THEN
 153          IF(IPRT.GE.0) THEN
 154       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 155       ERRSTR = 'BUFRLIB: UFBIN3 - 4th ARG. (INPUT) IS .LE. 0, ' //
 156      .   'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' //
 157      .   '8th ARG. (STR) ='
 158       CALL ERRWRT(ERRSTR)
 159       CALL ERRWRT(STR)
 160       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 161       CALL ERRWRT(' ')
 162          ENDIF
 163          GOTO 100
 164       ELSEIF(I3.LE.0) THEN
 165          IF(IPRT.GE.0) THEN
 166       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 167       ERRSTR = 'BUFRLIB: UFBIN3 - 5th ARG. (INPUT) IS .LE. 0, ' //
 168      .   'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' //
 169      .   '8th ARG. (STR) ='
 170       CALL ERRWRT(ERRSTR)
 171       CALL ERRWRT(STR)
 172       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 173       CALL ERRWRT(' ')
 174          ENDIF
 175          GOTO 100
 176       ENDIF
 177
 178 C  PARSE OR RECALL THE INPUT STRING
 179 C  --------------------------------
 180
 181       CALL STRING(STR,LUN,I1,0)
 182
 183 C  INITIALIZE USR ARRAY
 184 C  --------------------
 185
 186       DO K=1,I3
 187       DO J=1,I2
 188       DO I=1,I1
 189       USR(I,J,K) = BMISS
 190       ENDDO
 191       ENDDO
 192       ENDDO
 193
 194 C  LOOP OVER COND WINDOWS
 195 C  ----------------------
 196
 197       INC1 = 1
 198       INC2 = 1
 199
 200 1     CALL CONWIN(LUN,INC1,INC2)
 201       IF(NNOD.EQ.0) THEN
 202         IRET = I2
 203         GOTO 100
 204       ELSEIF(INC1.EQ.0) THEN
 205         GOTO 100
 206       ELSE
 207         DO I=1,NNOD
 208         IF(NODS(I).GT.0) THEN
 209            INS2 = INC1
 210            CALL GETWIN(NODS(I),LUN,INS1,INS2)
 211            IF(INS1.EQ.0) GOTO 100
 212            GOTO 2
 213         ENDIF
 214         ENDDO
 215         INS1 = INC1
 216         INS2 = INC2
 217       ENDIF
 218
 219 C  READ PUSH DOWN STACK DATA INTO 3D ARRAYS
 220 C  ----------------------------------------
 221
 222 2     IRET = IRET+1
 223       IF(IRET.LE.I2) THEN
 224          DO I=1,NNOD
 225             NNVN = NEVN(NODS(I),LUN,INS1,INS2,I1,I2,I3,USR(I,IRET,1))
 226             JRET = MAX(JRET,NNVN)
 227          ENDDO
 228       ENDIF
 229
 230 C  DECIDE WHAT TO DO NEXT
 231 C  ----------------------
 232
 233       CALL NXTWIN(LUN,INS1,INS2)
 234       IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2
 235       IF(NCON.GT.0) GOTO 1
 236
 237       IF(IRET.EQ.0 .OR. JRET.EQ.0)  THEN
 238          IF(IPRT.GE.1)  THEN
 239       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 240       ERRSTR = 'BUFRLIB: UFBIN3 - NO SPECIFIED VALUES READ IN, ' //
 241      .   'SO RETURN WITH 6th AND/OR 7th ARGS. (IRET, JRET) = 0; ' //
 242      .   '8th ARG. (STR) ='
 243       CALL ERRWRT(ERRSTR)
 244       CALL ERRWRT(STR)
 245       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 246       CALL ERRWRT(' ')
 247          ENDIF
 248       ENDIF
 249
 250 C  EXITS
 251 C  -----
 252
 253 100   RETURN
 254 900   CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST'//
 255      . ' BE OPEN FOR INPUT')
 256 901   CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
 257      . ', IT MUST BE OPEN FOR INPUT')
 258 902   CALL BORT('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT '//
 259      . 'BUFR FILE, NONE ARE')
 260 903   CALL BORT('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '//
 261      . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
 262      . 'INTERNAL SUBSET ARRAY')
 263       END