var/external/bufr/ufbdmp.f

   1       SUBROUTINE UFBDMP(LUNIN,LUPRT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBDMP
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   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
  11 C   ABS(LUNIN).  ABS(LUNIN) MUST HAVE BEEN OPENED FOR INPUT VIA A
  12 C   PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF.  THE DATA
  13 C   SUBSET MUST HAVE BEEN SUBSEQUENTLY READ INTO THE INTERNAL BUFR
  14 C   ARCHIVE LIBRARY ARRAYS VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE
  15 C   READMG OR READERME, FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY
  16 C   SUBROUTINE READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY
  17 C   SUBROUTINE READNS!).  FOR A PARTICULAR SUBSET, THE PRINT LISTING
  18 C   CONTAINS EACH MNEMONIC ACCOMPANIED BY ITS CORRESPONDING DATA VALUE
  19 C   (INCLUDING THE ACTUAL BITS THAT WERE SET FOR FLAG TABLE VALUES!)
  20 C   ALONG WITH OTHER POTENTIALLY USEFUL INFORMATION SUCH AS WHICH OTHER
  21 C   MNEMONIC(S) THAT MNEMONIC WAS A CONSTITUENT OF WITHIN THE OVERALL
  22 C   DATA SUBSET.  HOWEVER, THE LISTING ALSO CONTAINS OTHER MORE ESOTERIC
  23 C   INFORMATION SUCH AS BUFR STORAGE CHARACTERISTICS AND A COPY OF THE
  24 C   JUMP/LINK TABLE USED INTERNALLY WITHIN THE BUFR ARCHIVE LIBRARY
  25 C   SOFTWARE.  THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE LIBRARY
  26 C   SUBROUTINE UFDUMP, EXCEPT THAT UFDUMP DOES NOT PRINT POINTERS,
  27 C   COUNTERS AND THE OTHER MORE ESOTERIC INFORMATION DESCRIBING THE
  28 C   INTERNAL SUBSET STRUCTURES.  EACH SUBROUTINE, UFBDMP AND UFDUMP,
  29 C   IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP
  30 C   IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS.
  31 C
  32 C PROGRAM HISTORY LOG:
  33 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  34 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  35 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  36 C                           ROUTINE "BORT"
  37 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  38 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  39 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  40 C                           BUFR FILES UNDER THE MPI)
  41 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  42 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  43 C                           INTERDEPENDENCIES
  44 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  45 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  46 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  47 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  48 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  49 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY OR
  50 C                           FOR INFORMATIONAL PURPOSES; TEST FOR A
  51 C                           MISSING VALUE NOW ALLOWS SOME FUZZINESS
  52 C                           ABOUT 10E10 (RATHER THAN TRUE EQUALITY AS
  53 C                           BEFORE) BECAUSE SOME MISSING VALUES (E.G.,
  54 C                           CHARACTER STRINGS < 8 CHARACTERS) WERE NOT
  55 C                           GETTING STAMPED OUT AS "MISSING"; ADDED
  56 C                           OPTION TO PRINT VALUES USING FORMAT EDIT
  57 C                           DESCRIPTOR "F15.6" IF LUNIN IS < ZERO,
  58 C                           IF LUNIN IS > ZERO EDIT DESCRIPTOR EXPANDED
  59 C                           FROM "G10.3" TO "G15.6" {REGARDLESS OF
  60 C                           LUNIN, ADDITIONAL VALUES
  61 C                           "IB,IS,IR,ND,JP,LK,JB" NOW PRINTED (THEY
  62 C                           WERE COMMENTED OUT)}
  63 C 2004-08-18  J. ATOR    -- MODIFIED FUZZINESS TEST;ADDED READLC OPTION;
  64 C                           RESTRUCTURED SOME LOGIC FOR CLARITY
  65 C 2006-04-14  D. KEYSER  -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET
  66 C                           ACTUAL BITS THAT WERE SET TO GENERATE VALUE
  67 C 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS
  68 C
  69 C USAGE:    CALL UFBDMP (LUNIN, LUPRT)
  70 C   INPUT ARGUMENT LIST:
  71 C     LUNIN    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
  72 C                FOR BUFR FILE
  73 C                  - IF LUNIN IS GREATER THAN ZERO, DATA VALUES ARE
  74 C                    PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR
  75 C                    "G15.6" (all values are printed since output
  76 C                    format adapts to the magnitude of the data, but
  77 C                    they are not lined up in columns according to
  78 C                    decimal point)
  79 C                  - IF LUNIN IS LESS THAN ZERO, DATA VALUES ARE
  80 C                    PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR
  81 C                    "F15.6" {values are lined up in columns according
  82 C                    to decimal point, but data of large magnitude,
  83 C                    (i.e., exceeding the format width of 15) get the
  84 C                    overflow ("***************") print}
  85 C     LUPRT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT
  86 C                FILE
  87 C                       0 = LUPRT is set to 06 (standard output) and
  88 C                           the subroutine will scroll the output,
  89 C                           twenty elements at a time (see REMARKS)
  90 C
  91 C   INPUT FILES:
  92 C     UNIT 05  - STANDARD INPUT (SEE REMARKS)
  93 C
  94 C   OUTPUT FILES:
  95 C     IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT)
  96 C     IF LUPRT = 0: UNIT 06      - STANDARD OUTPUT PRINT (SEE REMARKS)
  97 C
  98 C
  99 C REMARKS:
 100 C    THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS
 101 C    AT A TIME WHEN LUPRT IS INPUT AS "0".  IN THIS CASE, THE EXECUTING
 102 C    SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND
 103 C    STANDARD OUTPUT.  INITIALLY, THE FIRST TWENTY ELEMENTS OF THE
 104 C    CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL,
 105 C    FOLLOWED BY THE PROMPT "(<enter> for MORE, q <enter> to QUIT)".
 106 C    IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY
 107 C    "<enter>" (e.g., "<enter>"), THE NEXT TWENTY ELEMENTS WILL BE
 108 C    DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT.  THIS CONTINUES
 109 C    UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL
 110 C    ENTERS "q" FOLLOWED BY "<enter>" AFTER THE PROMPT, IN WHICH CASE
 111 C    THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING
 112 C    PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE).
 113 C
 114 C    THIS ROUTINE CALLS:        BORT     IBFMS    ISIZE    READLC
 115 C                               RJUST    STATUS   UPFTBV
 116 C    THIS ROUTINE IS CALLED BY: None
 117 C                               Normally called only by application
 118 C                               programs.
 119 C
 120 C ATTRIBUTES:
 121 C   LANGUAGE: FORTRAN 77
 122 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 123 C
 124 C$$$
 125
 126       INCLUDE 'bufrlib.prm'
 127
 128       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 129      .                INODE(NFILES),IDATE(NFILES)
 130       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
 131      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
 132      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
 133      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
 134      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
 135       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
 136       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
 137      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
 138      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
 139      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
 140      .                TABD(MAXTBD,NFILES)
 141
 142       CHARACTER*600 TABD
 143       CHARACTER*128 TABB
 144       CHARACTER*128 TABA
 145
 146       CHARACTER*20 LCHR
 147       CHARACTER*14 BITS
 148       CHARACTER*10 TAG,TG,TG_RJ
 149       CHARACTER*8  VC
 150       CHARACTER*7  FMTF
 151       CHARACTER*3  TYP,TP
 152       CHARACTER*1  TAB,YOU
 153       EQUIVALENCE  (VL,VC)
 154       REAL*8       VAL,VL
 155
 156       PARAMETER (MXFV=31)
 157       INTEGER   IFV(MXFV)
 158
 159       DATA YOU /'Y'/
 160
 161 C----------------------------------------------------------------------
 162 C----------------------------------------------------------------------
 163
 164       IF(LUPRT.EQ.0) THEN
 165          LUOUT = 6
 166       ELSE
 167          LUOUT = LUPRT
 168       ENDIF
 169
 170 C  CHECK THE FILE STATUS AND I-NODE
 171 C  --------------------------------
 172
 173       LUNIT = ABS(LUNIN)
 174       CALL STATUS(LUNIT,LUN,IL,IM)
 175       IF(IL.EQ.0) GOTO 900
 176       IF(IL.GT.0) GOTO 901
 177       IF(IM.EQ.0) GOTO 902
 178       IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903
 179
 180 C  DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT ABS(LUNIN)
 181 C  --------------------------------------------------------
 182
 183       DO NV=1,NVAL(LUN)
 184       IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN
 185
 186 C  When LUPRT=0, the output will be scrolled, 20 elements at a time
 187 C  ----------------------------------------------------------------
 188
 189          PRINT*,'(<enter> for MORE, q <enter> to QUIT)'
 190          READ(5,'(A1)') YOU
 191
 192 C  If the terminal enters "q" followed by "<enter>" after the prompt
 193 C  "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
 194 C  subroutine will return to the calling program
 195 C  -------------------------------------------------------------------
 196
 197          IF(YOU.EQ.'q') THEN
 198          PRINT*
 199          PRINT*,'==> You have chosen to stop the dumping of this subset'
 200          PRINT*
 201             GOTO 100
 202          ENDIF
 203       ENDIF
 204       ND = INV (NV,LUN)
 205       VL = VAL (NV,LUN)
 206       TG = TAG (ND)
 207       TP = TYP (ND)
 208       IT = ITP (ND)
 209       IB = IBT (ND)
 210       IS = ISC (ND)
 211       IR = IRF (ND)
 212       JP = JUMP(ND)
 213       LK = LINK(ND)
 214       JB = JMPB(ND)
 215       TG_RJ = TG
 216       RJ = RJUST(TG_RJ)
 217       IF(TP.NE.'CHR') THEN
 218          BITS = '              '
 219          IF(IT.EQ.2) THEN
 220             CALL NEMTAB(LUN,TG,IDN,TAB,N)
 221             IF(TABB(N,LUN)(71:75).EQ.'FLAG') THEN
 222
 223 C              Print a listing of the bits corresponding to
 224 C              this value.
 225
 226                CALL UPFTBV(LUNIT,TG,VL,MXFV,IFV,NIFV)
 227                IF(NIFV.GT.0) THEN
 228                   BITS(1:1) = '('
 229                   IPT = 2
 230                   DO II=1,NIFV
 231                     ISZ = ISIZE(IFV(II))
 232                     WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)'
 233                     IF((IPT+ISZ).LE.14) THEN
 234                        WRITE(BITS(IPT:IPT+ISZ),FMTF) IFV(II), ','
 235                        IPT = IPT + ISZ + 1
 236                     ELSE
 237                        BITS(2:13) = 'MANY BITS ON'
 238                        IPT = 15
 239                     ENDIF
 240                   ENDDO
 241                   BITS(IPT-1:IPT-1) = ')'
 242                ENDIF
 243             ENDIF
 244          ENDIF
 245          IF(IBFMS(VL).NE.0) THEN
 246             LCHR = 'MISSING'
 247             RJ = RJUST(LCHR)
 248             WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB
 249          ELSE
 250             IF(LUNIT.EQ.LUNIN) THEN
 251                WRITE(LUOUT,1) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK,
 252      .          JB
 253             ELSE
 254                WRITE(LUOUT,10) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK,
 255      .          JB
 256             ENDIF
 257          ENDIF
 258       ELSE
 259          IF(IB.GT.64) THEN
 260             CALL READLC(LUNIT,LCHR,TG_RJ)
 261          ELSE
 262             LCHR = VC
 263          ENDIF
 264          IF(IBFMS(VL).NE.0) LCHR = 'MISSING'
 265          RJ = RJUST(LCHR)
 266          WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB
 267       ENDIF
 268       ENDDO
 269
 270       WRITE(LUOUT,3)
 271
 272 1     FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,G15.6,1X,A14,7(1X,I5))
 273 10    FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,F15.6,1X,A14,7(1X,I5))
 274 2     FORMAT(I5,1X,A3,'-',I1,1X,A10,   A20,  15X,   7(1X,I5))
 275 3     FORMAT(/' >>> END OF SUBSET <<< '/)
 276
 277 C  EXITS
 278 C  -----
 279
 280 100   RETURN
 281 900   CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT '//
 282      . 'MUST BE OPEN FOR INPUT')
 283 901   CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR '//
 284      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 285 902   CALL BORT('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT '//
 286      . 'BUFR FILE, NONE ARE')
 287 903   CALL BORT('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '//
 288      . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
 289      . 'INTERNAL SUBSET ARRAY')
 290       END