var/external/bufr/usrtpl.f

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