wrfv2_fire/var/external/bufr/usrtpl.inc

   1       SUBROUTINE USRTPL(LUN,INVN,NBMP)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    USRTPL (docblock incomplete)
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL
   9 !   SUBSET ARRAYS IN COMMON BLOCK /USRINT/ FOR CASES OF NODE EXPANSION
  10 !   (I.E., NODE IS EITHER A TABLE A MNEMONIC OR A DELAYED REPLICATION
  11 !   FACTOR).
  12 !
  13 ! PROGRAM HISTORY LOG:
  14 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  15 ! 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  16 !                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  17 !                           ROUTINE "BORT"
  18 ! 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  19 !                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  20 !                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  21 !                           BUFR FILES UNDER THE MPI)
  22 ! 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  23 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  24 !                           INTERDEPENDENCIES
  25 ! 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  26 !                           INCREASED FROM 15000 TO 16000 (WAS IN
  27 !                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  28 !                           WRF; ADDED DOCUMENTATION (INCLUDING
  29 !                           HISTORY) (INCOMPLETE); OUTPUTS MORE
  30 !                           COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  31 !                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
  32 !                           HAPPEN; COMMENTED OUT HARDWIRE OF VTMP TO
  33 !                           "BMISS" (10E10) WHEN IT IS > 10E9 (CAUSED
  34 !                           PROBLEMS ON SOME FOREIGN MACHINES)
  35 !
  36 ! USAGE:    CALL USRTPL (LUN, INVN, NBMP)
  37 !   INPUT ARGUMENT LIST:
  38 !     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  39 !     INVN     - INTEGER: INVENTORY INDEX FOR ELEMENTS
  40 !     NBMP     - INTEGER  ....
  41 !
  42 !   OUTPUT FILES:
  43 !     UNIT 06  - STANDARD OUTPUT PRINT
  44 !
  45 ! REMARKS:
  46 !    THIS ROUTINE CALLS:        BORT
  47 !    THIS ROUTINE IS CALLED BY: CONWIN   DRFINI   DRSTPL   MSGUPD
  48 !                               OPENMB   OPENMG   RDCMPS   SUBUPD
  49 !                               TRYBUMP  UFBGET   UFBTAB   UFBTAM
  50 !                               WRCMPS   WRITLC
  51 !                               Normally not called by any application
  52 !                               programs.
  53 !
  54 ! ATTRIBUTES:
  55 !   LANGUAGE: FORTRAN 77
  56 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  57 !
  58 !$$$
  59
  60       INCLUDE 'bufrlib.prm'
  61
  62       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), &
  63                       INODE(NFILES),IDATE(NFILES)
  64 !     COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), &
  65 !                     JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), &
  66 !                     IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), &
  67 !                     ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), &
  68 !                     ISEQ(MAXJL,2),JSEQ(MAXJL)
  69 !     COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES)
  70       COMMON /QUIET / IPRT
  71
  72       CHARACTER*128 BORT_STR
  73 !     CHARACTER*10  TAG
  74 !     CHARACTER*3   TYP
  75       DIMENSION     ITMP(MAXJL)
  76       LOGICAL       DRP,DRS,DRB,DRX
  77       REAL*8        VTMP(MAXJL) !, VAL
  78
  79 !-----------------------------------------------------------------------
  80 !-----------------------------------------------------------------------
  81
  82       IF ( .NOT. ALLOCATED (NVAL) ) ALLOCATE ( NVAL(NFILES) )
  83       IF ( .NOT. ALLOCATED (INV) ) ALLOCATE ( INV(MAXJL,NFILES) )
  84       IF ( .NOT. ALLOCATED (VAL) ) ALLOCATE ( VAL(MAXJL,NFILES) )
  85
  86       IF(IPRT.GE.2)  THEN
  87       PRINT*
  88       PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
  89          PRINT*,'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ', &
  90           LUN,':',INVN,':',NBMP,':',TAG(INODE(LUN))
  91       PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
  92       PRINT*
  93       ENDIF
  94
  95       IF(NBMP.LE.0) THEN
  96          IF(IPRT.GE.1)  THEN
  97       PRINT*
  98       PRINT*,'+++++++++++++++++++++++WARNING+++++++++++++++++++++++++'
  99             PRINT*,'BUFRLIB: USRTPL - NBMP .LE. 0 - IMMEDIATE RETURN'
 100       PRINT*,'+++++++++++++++++++++++WARNING+++++++++++++++++++++++++'
 101       PRINT*
 102          ENDIF
 103          GOTO 100
 104       ENDIF
 105
 106       DRP = .FALSE.
 107       DRS = .FALSE.
 108       DRX = .FALSE.
 109
 110 !  SET UP A NODE EXPANSION
 111 !  -----------------------
 112
 113       IF(INVN.EQ.1) THEN
 114 !  .... case where node is a Table A mnemonic (nodi is positional index)
 115          NODI = INODE(LUN)
 116          INV(1,LUN) = NODI
 117          NVAL(LUN)  = 1
 118          IF(NBMP.NE.1) GOTO 900
 119       ELSEIF(INVN.GT.0 .AND. INVN.LE.NVAL(LUN)) THEN
 120 !  .... case where node is (hopefully) a delayed replication factor
 121          NODI = INV(INVN,LUN)
 122          DRP  = TYP(NODI) .EQ. 'DRP'
 123          DRS  = TYP(NODI) .EQ. 'DRS'
 124          DRB  = TYP(NODI) .EQ. 'DRB'
 125          DRX  = DRP .OR. DRS .OR. DRB
 126          IVAL = VAL(INVN,LUN)
 127          JVAL = 2**IBT(NODI)-1
 128          VAL(INVN,LUN) = IVAL+NBMP
 129          IF(DRB.AND.NBMP.NE.1) GOTO 901
 130          IF(.NOT.DRX         ) GOTO 902
 131          IF(IVAL.LT.0.       ) GOTO 903
 132          IF(IVAL+NBMP.GT.JVAL) GOTO 904
 133       ELSE
 134          GOTO 905
 135       ENDIF
 136
 137 !  RECALL A PRE-FAB NODE EXPANSION SEGMENT
 138 !  ---------------------------------------
 139
 140       NEWN = 0
 141       N1 = ISEQ(NODI,1)
 142       N2 = ISEQ(NODI,2)
 143
 144       IF(N1.EQ.0          ) GOTO 906
 145       IF(N2-N1+1.GT.MAXJL)  GOTO 907
 146
 147       DO N=N1,N2
 148       NEWN = NEWN+1
 149       ITMP(NEWN) = JSEQ(N)
 150       VTMP(NEWN) = VALI(JSEQ(N))
 151       ENDDO
 152
 153 !  MOVE OLD NODES - STORE NEW ONES
 154 !  -------------------------------
 155
 156       IF(NVAL(LUN)+NEWN*NBMP.GT.MAXJL) GOTO 908
 157
 158       DO J=NVAL(LUN),INVN+1,-1
 159       INV(J+NEWN*NBMP,LUN) = INV(J,LUN)
 160       VAL(J+NEWN*NBMP,LUN) = VAL(J,LUN)
 161       ENDDO
 162
 163       IF(DRP.OR.DRS) VTMP(1) = NEWN
 164       KNVN = INVN
 165
 166       DO I=1,NBMP
 167       DO J=1,NEWN
 168       KNVN = KNVN+1
 169       INV(KNVN,LUN) = ITMP(J)
 170       VAL(KNVN,LUN) = VTMP(J)
 171       ENDDO
 172       ENDDO
 173
 174 !  RESET POINTERS AND COUNTERS
 175 !  ---------------------------
 176
 177       NVAL(LUN) = NVAL(LUN) + NEWN*NBMP
 178
 179       IF(IPRT.GE.2)  THEN
 180       PRINT*
 181       PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
 182          PRINT*,'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:', &
 183           'NVAL(LUN) = ',TAG(INV(INVN,LUN)),':',NEWN,':',NBMP,':', &
 184           NVAL(LUN)
 185          DO I=1,NEWN
 186             PRINT*,'For I = ',I,', ITMP(I) = ',ITMP(I), &
 187              ', TAG(ITMP(I)) = ',TAG(ITMP(I))
 188          ENDDO
 189       PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
 190       PRINT*
 191       ENDIF
 192
 193       IF(DRX) THEN
 194          NODE = NODI
 195          INVR = INVN
 196 4        NODE = JMPB(NODE)
 197          IF(NODE.GT.0) THEN
 198             IF(ITP(NODE).EQ.0) THEN
 199                DO INVR=INVR-1,1,-1
 200                IF(INV(INVR,LUN).EQ.NODE) THEN
 201                   VAL(INVR,LUN) = VAL(INVR,LUN)+NEWN*NBMP
 202                   GOTO 4
 203                ENDIF
 204                ENDDO
 205                GOTO 909
 206             ELSE
 207                GOTO 4
 208             ENDIF
 209          ENDIF
 210       ENDIF
 211
 212 !  EXITS
 213 !  -----
 214
 215 100   RETURN
 216 900   WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// &
 217        'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET '// &
 218        'NODE) (",A,")")') NBMP,TAG(NODI)
 219       CALL BORT(BORT_STR)
 220 901   WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// &
 221        'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR)'// &
 222        ' (",A,")")') NBMP,TAG(NODI)
 223       CALL BORT(BORT_STR)
 224 902   WRITE(BORT_STR,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '// &
 225        'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")') &
 226         TYP(NODI),TAG(NODI)
 227       CALL BORT(BORT_STR)
 228 903   WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '// &
 229        'NEGATIVE (=",I5,") (",A,")")') IVAL,TAG(NODI)
 230       CALL BORT(BORT_STR)
 231 904   WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'// &
 232        ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') JVAL,TAG(NODI)
 233       CALL BORT(BORT_STR)
 234 905   WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '// &
 235        'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'// &
 236        ') (",A,")")') INVN,NVAL(LUN),TAG(NODI)
 237       CALL BORT(BORT_STR)
 238 906   WRITE(BORT_STR,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'// &
 239        'A,")")') TAG(NODI)
 240       CALL BORT(BORT_STR)
 241 907   WRITE(BORT_STR,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '// &
 242        'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI)
 243       CALL BORT(BORT_STR)
 244 908   WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'// &
 245        ', EXCEEDS THE LIMIT (",I6,") (",A,")")') &
 246        NVAL(LUN)+NEWN*NBMP,MAXJL,TAG(NODI)
 247       CALL BORT(BORT_STR)
 248 909   WRITE(BORT_STR,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'// &
 249        '")")') TAG(NODI)
 250       CALL BORT(BORT_STR)
 251       END SUBROUTINE USRTPL