1 SUBROUTINE USRTPL(LUN,INVN,NBMP)
3 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
5 ! SUBPROGRAM: USRTPL (docblock incomplete)
6 ! PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
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
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
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
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)
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
43 ! UNIT 06 - STANDARD OUTPUT PRINT
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
51 ! Normally not called by any application
55 ! LANGUAGE: FORTRAN 77
56 ! MACHINE: PORTABLE TO ALL PLATFORMS
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)
72 CHARACTER*128 BORT_STR
76 LOGICAL DRP,DRS,DRB,DRX
77 REAL*8 VTMP(MAXJL) !, VAL
79 !-----------------------------------------------------------------------
80 !-----------------------------------------------------------------------
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) )
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++++++++++++++++++++'
98 PRINT*,'+++++++++++++++++++++++WARNING+++++++++++++++++++++++++'
99 PRINT*,'BUFRLIB: USRTPL - NBMP .LE. 0 - IMMEDIATE RETURN'
100 PRINT*,'+++++++++++++++++++++++WARNING+++++++++++++++++++++++++'
110 ! SET UP A NODE EXPANSION
111 ! -----------------------
114 ! .... case where node is a Table A mnemonic (nodi is positional index)
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
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
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
137 ! RECALL A PRE-FAB NODE EXPANSION SEGMENT
138 ! ---------------------------------------
144 IF(N1.EQ.0 ) GOTO 906
145 IF(N2-N1+1.GT.MAXJL) GOTO 907
150 VTMP(NEWN) = VALI(JSEQ(N))
153 ! MOVE OLD NODES - STORE NEW ONES
154 ! -------------------------------
156 IF(NVAL(LUN)+NEWN*NBMP.GT.MAXJL) GOTO 908
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)
163 IF(DRP.OR.DRS) VTMP(1) = NEWN
169 INV(KNVN,LUN) = ITMP(J)
170 VAL(KNVN,LUN) = VTMP(J)
174 ! RESET POINTERS AND COUNTERS
175 ! ---------------------------
177 NVAL(LUN) = NVAL(LUN) + NEWN*NBMP
181 PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
182 PRINT*,'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:', &
183 'NVAL(LUN) = ',TAG(INV(INVN,LUN)),':',NEWN,':',NBMP,':', &
186 PRINT*,'For I = ',I,', ITMP(I) = ',ITMP(I), &
187 ', TAG(ITMP(I)) = ',TAG(ITMP(I))
189 PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
198 IF(ITP(NODE).EQ.0) THEN
200 IF(INV(INVR,LUN).EQ.NODE) THEN
201 VAL(INVR,LUN) = VAL(INVR,LUN)+NEWN*NBMP
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)
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)
224 902 WRITE(BORT_STR,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '// &
225 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")') &
228 903 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '// &
229 'NEGATIVE (=",I5,") (",A,")")') IVAL,TAG(NODI)
231 904 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'// &
232 ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') JVAL,TAG(NODI)
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)
238 906 WRITE(BORT_STR,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'// &
241 907 WRITE(BORT_STR,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '// &
242 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI)
244 908 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'// &
245 ', EXCEEDS THE LIMIT (",I6,") (",A,")")') &
246 NVAL(LUN)+NEWN*NBMP,MAXJL,TAG(NODI)
248 909 WRITE(BORT_STR,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'// &
251 END SUBROUTINE USRTPL