var/external/bufr/ufdump.f

   1       SUBROUTINE UFDUMP(LUNIT,LUPRT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFDUMP
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2002-05-14
   7 C
   8 C ABSTRACT: THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE
   9 C   CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE
  10 C   INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT.
  11 C   LUNIT MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR
  12 C   ARCHIVE LIBRARY SUBROUTINE OPENBF.  THE DATA SUBSET MUST HAVE BEEN
  13 C   SUBSEQUENTLY READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY ARRAYS VIA
  14 C   A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR READERME,
  15 C   FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR VIA
  16 C   A SINGLE CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READNS!).  FOR A
  17 C   PARTICULAR SUBSET, THE PRINT LISTING CONTAINS EACH MNEMONIC
  18 C   ACCOMPANIED BY ITS CORRESPONDING DATA VALUE (INCLUDING THE ACTUAL
  19 C   BITS THAT WERE SET FOR FLAG TABLE VALUES!) AS WELL AS OTHER USEFUL
  20 C   IDENTIFICATION INFORMATION.  THIS SUBROUTINE IS SIMILAR TO BUFR
  21 C   ARCHIVE LIBRARY SUBROUTINE UFBDMP EXCEPT THAT IT DOES NOT PRINT
  22 C   POINTERS, COUNTERS AND OTHER MORE ESOTERIC INFORMATION DESCRIBING
  23 C   THE INTERNAL SUBSET STRUCTURES.  EACH SUBROUTINE, UFBDMP AND UFDUMP,
  24 C   IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP
  25 C   IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS.
  26 C
  27 C PROGRAM HISTORY LOG:
  28 C 2002-05-14  J. WOOLLEN -- ORIGINAL AUTHOR
  29 C 2003-11-04  J. WOOLLEN -- MODIFIED TO HANDLE PRINT OF CHARACTER
  30 C                           VALUES GREATER THAN EIGHT BYTES
  31 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  32 C                           INTERDEPENDENCIES
  33 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  34 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  35 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  36 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  37 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  38 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
  39 C 2004-08-18  J. ATOR    -- ADDED FUZZINESS TEST AND THRESHOLD FOR
  40 C                           MISSING VALUE; ADDED INTERACTIVE AND
  41 C                           SCROLLING CAPABILITY SIMILAR TO UFBDMP
  42 C 2006-04-14  J. ATOR    -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET
  43 C                           ACTUAL BITS THAT WERE SET TO GENERATE VALUE
  44 C 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS
  45 C 2009-03-23  J. ATOR    -- ADD LEVEL MARKERS TO OUTPUT FOR SEQUENCES
  46 C                           WHERE THE REPLICATION COUNT IS > 1; OUTPUT
  47 C                           ALL OCCURRENCES OF LONG CHARACTER STRINGS
  48 C 2012-02-24  J. ATOR    -- FIX MISSING CHECK FOR LONG CHARACTER STRINGS
  49 C 2012-03-02  J. ATOR    -- LABEL REDEFINED REFERENCE VALUES
  50 C
  51 C USAGE:    CALL UFDUMP (LUNIT, LUPRT)
  52 C   INPUT ARGUMENT LIST:
  53 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  54 C     LUPRT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT
  55 C                FILE
  56 C                       0 = LUPRT is set to 06
  57 C
  58 C   OUTPUT FILES:
  59 C     IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT)
  60 C     IF LUPRT = 0: UNIT 06      - STANDARD OUTPUT PRINT
  61 C
  62 C REMARKS:
  63 C    THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS
  64 C    AT A TIME WHEN LUPRT IS INPUT AS "0".  IN THIS CASE, THE EXECUTING
  65 C    SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND
  66 C    STANDARD OUTPUT.  INITIALLY, THE FIRST TWENTY ELEMENTS OF THE
  67 C    CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL,
  68 C    FOLLOWED BY THE PROMPT "(<enter> for MORE, q <enter> to QUIT)".
  69 C    IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY
  70 C    "<enter>" (e.g., "<enter>"), THE NEXT TWENTY ELEMENTS WILL BE
  71 C    DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT.  THIS CONTINUES
  72 C    UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL
  73 C    ENTERS "q" FOLLOWED BY "<enter>" AFTER THE PROMPT, IN WHICH CASE
  74 C    THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING
  75 C    PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE).
  76 C
  77 C    THIS ROUTINE CALLS:        BORT     ICBFMS   IBFMS    ISIZE
  78 C                               NEMTAB   READLC   RJUST    STATUS
  79 C                               STRSUC   UPFTBV
  80 C    THIS ROUTINE IS CALLED BY: None
  81 C                               Normally called only by application
  82 C                               programs.
  83 C
  84 C ATTRIBUTES:
  85 C   LANGUAGE: FORTRAN 77
  86 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  87 C
  88 C$$$
  89
  90       INCLUDE 'bufrlib.prm'
  91
  92       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  93      .                INODE(NFILES),IDATE(NFILES)
  94       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  95      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  96      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  97      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  98      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  99       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
 100       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
 101      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
 102      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
 103      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
 104      .                TABD(MAXTBD,NFILES)
 105       COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
 106      .                ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV
 107
 108
 109       CHARACTER*600 TABD
 110       CHARACTER*128 TABB
 111       CHARACTER*128 TABA
 112
 113       CHARACTER*80 FMT
 114       CHARACTER*64 DESC
 115       CHARACTER*24 UNIT
 116       CHARACTER*120 LCHR2
 117       CHARACTER*20  LCHR,PMISS
 118       CHARACTER*15 NEMO3
 119       CHARACTER*10 TAG,NEMO,NEMO2
 120       CHARACTER*6  NUMB
 121       CHARACTER*7  FMTF
 122       CHARACTER*8  CVAL,TAGNRV
 123       CHARACTER*3  TYP,TYPE
 124       CHARACTER*1  TAB,YOU
 125       EQUIVALENCE  (RVAL,CVAL)
 126       REAL*8       VAL,RVAL
 127       LOGICAL      TRACK,FOUND,RDRV
 128
 129       PARAMETER (MXFV=31)
 130       INTEGER   IFV(MXFV)
 131
 132       PARAMETER (MXSEQ=10)
 133       INTEGER   IDXREP(MXSEQ)
 134       INTEGER   NUMREP(MXSEQ)
 135       CHARACTER*10 SEQNAM(MXSEQ)
 136
 137       PARAMETER (MXLS=10)
 138       CHARACTER*10 LSNEMO(MXLS)
 139       INTEGER   LSCT(MXLS)
 140
 141       DATA PMISS /'             MISSING'/
 142       DATA YOU /'Y'/
 143
 144 C----------------------------------------------------------------------
 145 C----------------------------------------------------------------------
 146
 147       NSEQ = 0
 148       NLS = 0
 149
 150       IF(LUPRT.EQ.0) THEN
 151          LUOUT = 6
 152       ELSE
 153          LUOUT = LUPRT
 154       ENDIF
 155
 156 C  CHECK THE FILE STATUS AND I-NODE
 157 C  --------------------------------
 158
 159       CALL STATUS(LUNIT,LUN,IL,IM)
 160       IF(IL.EQ.0) GOTO 900
 161       IF(IL.GT.0) GOTO 901
 162       IF(IM.EQ.0) GOTO 902
 163       IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903
 164
 165       WRITE(LUOUT,*)
 166       WRITE(LUOUT,*) 'MESSAGE TYPE ',TAG(INODE(LUN))
 167       WRITE(LUOUT,*)
 168
 169 C  DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT LUNIT
 170 C  ---------------------------------------------------
 171
 172       DO NV=1,NVAL(LUN)
 173       IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN
 174
 175 C  When LUPRT=0, the output will be scrolled, 20 elements at a time
 176 C  ----------------------------------------------------------------
 177
 178          PRINT*,'(<enter> for MORE, q <enter> to QUIT)'
 179          READ(5,'(A1)') YOU
 180
 181 C  If the terminal enters "q" followed by "<enter>" after the prompt
 182 C  "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
 183 C  subroutine will return to the calling program
 184 C  -------------------------------------------------------------------
 185
 186          IF(YOU.EQ.'q') THEN
 187          PRINT*
 188          PRINT*,'==> You have chosen to stop the dumping of this subset'
 189          PRINT*
 190             GOTO 100
 191          ENDIF
 192       ENDIF
 193
 194       NODE = INV (NV,LUN)
 195       NEMO = TAG (NODE)
 196       ITYP = ITP (NODE)
 197       TYPE = TYP (NODE)
 198
 199       IF(ITYP.GE.1.AND.ITYP.LE.3) THEN
 200          CALL NEMTAB(LUN,NEMO,IDN,TAB,N)
 201          NUMB = TABB(N,LUN)(1:6)
 202          DESC = TABB(N,LUN)(16:70)
 203          UNIT = TABB(N,LUN)(71:94)
 204          RVAL = VAL(NV,LUN)
 205       ENDIF
 206
 207       IF((ITYP.EQ.0).OR.(ITYP.EQ.1)) THEN
 208
 209 C        Sequence descriptor or delayed descriptor replication factor
 210
 211          IF((TYPE.EQ.'REP').OR.(TYPE.EQ.'DRP').OR.(TYPE.EQ.'DRB')) THEN
 212
 213 C          Print the number of replications
 214
 215            NSEQ = NSEQ+1
 216            IF(NSEQ.GT.MXSEQ) GOTO 904
 217            IF(TYPE.EQ.'REP') THEN
 218              NUMREP(NSEQ) = IRF(NODE)
 219            ELSE
 220              NUMREP(NSEQ) = NINT(RVAL)
 221            ENDIF
 222            CALL STRSUC(NEMO,NEMO2,LNM2)
 223            FMT = '(11X,A,I6,1X,A)'
 224            WRITE(LUOUT,FMT) NEMO2(1:LNM2), NUMREP(NSEQ), 'REPLICATIONS'
 225
 226 C          How many times is this sequence replicated?
 227
 228            IF(NUMREP(NSEQ).GT.1) THEN
 229
 230 C            Track the sequence
 231
 232              SEQNAM(NSEQ) = NEMO
 233              IDXREP(NSEQ) = 1
 234            ELSE
 235
 236 C            Don't bother
 237
 238              NSEQ = NSEQ-1
 239            ENDIF
 240          ELSEIF( ((TYPE.EQ.'SEQ').OR.(TYPE.EQ.'RPC'))
 241      .             .AND. (NSEQ.GT.0) ) THEN
 242
 243 C          Is this one of the sequences being tracked?
 244
 245            II = NSEQ
 246            TRACK = .FALSE.
 247            CALL STRSUC(NEMO,NEMO2,LNM2)
 248            DO WHILE ((II.GE.1).AND.(.NOT.TRACK))
 249              IF(INDEX(SEQNAM(II),NEMO2(1:LNM2)).GT.0) THEN
 250                TRACK = .TRUE.
 251
 252 C              Mark this level in the output
 253
 254                FMT = '(4X,A,2X,A,2X,A,I6,2X,A)'
 255                WRITE(LUOUT,FMT) '++++++', NEMO2(1:LNM2),
 256      .                 'REPLICATION #', IDXREP(II), '++++++'
 257                IF(IDXREP(II).LT.NUMREP(II)) THEN
 258
 259 C                There are more levels to come
 260
 261                  IDXREP(II) = IDXREP(II)+1
 262                ELSE
 263
 264 C                This was the last level for this sequence, so stop
 265 C                tracking it
 266
 267                  NSEQ = NSEQ-1
 268                ENDIF
 269              ELSE
 270                II = II-1
 271              ENDIF
 272            ENDDO
 273          ENDIF
 274       ELSEIF(ITYP.EQ.2) THEN
 275
 276 C        Other numeric value
 277
 278 C        First check if this node contains a redefined reference
 279 C        value.  If so, modify the DESC field to label it as such.
 280
 281          JJ = 1
 282          RDRV = .FALSE.
 283          DO WHILE ((JJ.LE.NNRV).AND.(.NOT.RDRV))
 284             IF (NODE.EQ.INODNRV(JJ)) THEN
 285                RDRV = .TRUE.
 286                DESC = 'NEW REFERENCE VALUE FOR ' // NUMB
 287                UNIT = ' '
 288             ELSE
 289                JJ = JJ+1
 290             ENDIF
 291          ENDDO
 292
 293 C        Now print the value
 294
 295          IF(IBFMS(RVAL).NE.0) THEN
 296
 297 C           The value is "missing".
 298
 299             FMT = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)'
 300             WRITE(LUOUT,FMT) NUMB,NEMO,PMISS,UNIT,DESC
 301          ELSE
 302             FMT = '(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)'
 303
 304 C           Based upon the corresponding scale factor, select an
 305 C           appropriate format for the printing of this value.
 306
 307             WRITE(FMT(19:20),'(I2)') MAX(1,ISC(NODE))
 308             IF(UNIT(1:4).EQ.'FLAG') THEN
 309
 310 C              Print a listing of the bits corresponding to
 311 C              this value.
 312
 313                CALL UPFTBV(LUNIT,NEMO,RVAL,MXFV,IFV,NIFV)
 314                IF(NIFV.GT.0) THEN
 315                   UNIT(11:11) = '('
 316                   IPT = 12
 317                   DO II=1,NIFV
 318                     ISZ = ISIZE(IFV(II))
 319                     WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)'
 320                     IF((IPT+ISZ).LE.24) THEN
 321                        WRITE(UNIT(IPT:IPT+ISZ),FMTF) IFV(II), ','
 322                        IPT = IPT + ISZ + 1
 323                     ELSE
 324                        UNIT(12:23) = 'MANY BITS ON'
 325                        IPT = 25
 326                     ENDIF
 327                   ENDDO
 328                   UNIT(IPT-1:IPT-1) = ')'
 329                ENDIF
 330             ENDIF
 331             WRITE(LUOUT,FMT) NUMB,NEMO,RVAL,UNIT,DESC
 332          ENDIF
 333       ELSEIF(ITYP.EQ.3) THEN
 334
 335 C        Character (CCITT IA5) value
 336
 337          NCHR = IBT(NODE)/8
 338
 339          IF(IBFMS(RVAL).NE.0) THEN
 340             LCHR = PMISS
 341          ELSE IF(NCHR.LE.8) THEN
 342             LCHR = CVAL
 343          ELSE
 344
 345 C           Track the number of occurrences of this long character string, so
 346 C           that we can properly output each one.
 347
 348             II = 1
 349             FOUND = .FALSE.
 350             DO WHILE((II.LE.NLS).AND.(.NOT.FOUND))
 351                IF(NEMO.EQ.LSNEMO(II)) THEN
 352                  FOUND = .TRUE.
 353                ELSE
 354                  II = II + 1
 355                ENDIF
 356             ENDDO
 357
 358             IF(.NOT.FOUND) THEN
 359                NLS = NLS+1
 360                IF(NLS.GT.MXLS) GOTO 905
 361                LSNEMO(NLS) = NEMO
 362                LSCT(NLS) = 1
 363                NEMO3 = NEMO
 364             ELSE
 365                CALL STRSUC(NEMO,NEMO3,LNM3)
 366                LSCT(II) = LSCT(II) + 1
 367                WRITE(FMTF,'(A,I1,A)') '(2A,I', ISIZE(LSCT(II)), ')'
 368                WRITE(NEMO3,FMTF) NEMO(1:LNM3), '#', LSCT(II)
 369             ENDIF
 370
 371             CALL READLC(LUNIT,LCHR2,NEMO3)
 372             IF (ICBFMS(LCHR2,NCHR).NE.0) THEN
 373                LCHR = PMISS
 374             ELSE
 375                LCHR = LCHR2(1:20)
 376             ENDIF
 377          ENDIF
 378
 379          IF ( NCHR.LE.20 .OR. LCHR.EQ.PMISS ) THEN
 380             IRET = RJUST(LCHR)
 381             FMT = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)'
 382             WRITE(LUOUT,FMT) NUMB,NEMO,LCHR,NCHR,UNIT,DESC
 383          ELSE
 384             FMT = '(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)'
 385             WRITE(LUOUT,FMT) NUMB,NEMO,LCHR2(1:NCHR),NCHR,UNIT,DESC
 386          ENDIF
 387       ENDIF
 388
 389       ENDDO
 390
 391       WRITE(LUOUT,3)
 392 3     FORMAT(/' >>> END OF SUBSET <<< '/)
 393
 394 C  EXITS
 395 C  -----
 396
 397 100   RETURN
 398 900   CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT '//
 399      . 'MUST BE OPEN FOR INPUT')
 400 901   CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR '//
 401      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 402 902   CALL BORT('BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT '//
 403      . 'BUFR FILE, NONE ARE')
 404 903   CALL BORT('BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '//
 405      . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
 406      . 'INTERNAL SUBSET ARRAY')
 407 904   CALL BORT('BUFRLIB: UFDUMP - MXSEQ OVERFLOW')
 408 905   CALL BORT('BUFRLIB: UFDUMP - MXLS OVERFLOW')
 409       END