NCEPLIBS-bufr 11.7.1
usrtpl.f
Go to the documentation of this file.
1C> @file
2C> @author WOOLLEN @date 1994-01-06
3
4C> THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL
5C> SUBSET ARRAYS IN MODULE USRINT FOR CASES OF NODE EXPANSION
6C> (I.E. WHEN THE NODE IS EITHER A TABLE A MNEMONIC OR A DELAYED
7C> REPLICATION FACTOR).
8C>
9C> PROGRAM HISTORY LOG:
10C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
11C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
12C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
13C> ROUTINE "BORT"
14C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
15C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
16C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
17C> BUFR FILES UNDER THE MPI)
18C> 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
19C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
20C> INTERDEPENDENCIES
21C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
22C> INCREASED FROM 15000 TO 16000 (WAS IN
23C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
24C> WRF; ADDED DOCUMENTATION (INCLUDING
25C> HISTORY) (INCOMPLETE); OUTPUTS MORE
26C> COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
27C> TERMINATES ABNORMALLY OR UNUSUAL THINGS
28C> HAPPEN; COMMENTED OUT HARDWIRE OF VTMP TO
29C> "BMISS" (10E10) WHEN IT IS > 10E9 (CAUSED
30C> PROBLEMS ON SOME FOREIGN MACHINES)
31C> 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION
32C> 2009-04-21 J. ATOR -- USE ERRWRT
33C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
34C>
35C> USAGE: CALL USRTPL (LUN, INVN, NBMP)
36C> INPUT ARGUMENT LIST:
37C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
38C> INVN - INTEGER: STARTING JUMP/LINK TABLE INDEX OF THE NODE
39C> TO BE EXPANDED WITHIN THE SUBSET TEMPLATE
40C> NBMP - INTEGER: NUMBER OF TIMES BY WHICH INVN IS TO BE
41C> EXPANDED (I.E. NUMBER OF REPLICATIONS OF NODE)
42C>
43C> REMARKS:
44C> THIS ROUTINE CALLS: BORT ERRWRT
45C> THIS ROUTINE IS CALLED BY: DRFINI DRSTPL MSGUPD OPENMB
46C> OPENMG RDCMPS TRYBUMP UFBGET
47C> UFBTAB UFBTAM WRCMPS WRITLC
48C> Normally not called by any application
49C> programs.
50C>
51 SUBROUTINE usrtpl(LUN,INVN,NBMP)
52
53 USE modv_maxjl
54 USE modv_maxss
55
56 USE moda_usrint
57 USE moda_msgcwd
58 USE moda_tables
59 USE moda_ivttmp
60
61 COMMON /quiet / iprt
62
63 CHARACTER*128 BORT_STR,ERRSTR
64 LOGICAL DRP,DRS,DRB,DRX
65
66C-----------------------------------------------------------------------
67C-----------------------------------------------------------------------
68
69 IF(iprt.GE.2) THEN
70 CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
71 WRITE ( unit=errstr, fmt='(A,I3,A,I7,A,I5,A,A10)' )
72 . 'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ',
73 . lun, ':', invn, ':', nbmp, ':', tag(inode(lun))
74 CALL errwrt(errstr)
75 CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
76 CALL errwrt(' ')
77 ENDIF
78
79 IF(nbmp.LE.0) THEN
80 IF(iprt.GE.1) THEN
81 CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
82 CALL errwrt(.LE.'BUFRLIB: USRTPL - NBMP 0 - IMMEDIATE RETURN')
83 CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
84 CALL errwrt(' ')
85 ENDIF
86 GOTO 100
87 ENDIF
88
89 drp = .false.
90 drs = .false.
91 drx = .false.
92
93C SET UP A NODE EXPANSION
94C -----------------------
95
96 IF(invn.EQ.1) THEN
97c .... case where node is a Table A mnemonic (nodi is positional index)
98 nodi = inode(lun)
99 inv(1,lun) = nodi
100 nval(lun) = 1
101 IF(nbmp.NE.1) GOTO 900
102 ELSEIF(invn.GT.0 .AND. invn.LE.nval(lun)) THEN
103c .... case where node is (hopefully) a delayed replication factor
104 nodi = inv(invn,lun)
105 drp = typ(nodi) .EQ. 'DRP'
106 drs = typ(nodi) .EQ. 'DRS'
107 drb = typ(nodi) .EQ. 'DRB'
108 drx = drp .OR. drs .OR. drb
109 ival = val(invn,lun)
110 jval = 2**ibt(nodi)-1
111 val(invn,lun) = ival+nbmp
112 IF(drb.AND.nbmp.NE.1) GOTO 901
113 IF(.NOT.drx ) GOTO 902
114 IF(ival.LT.0. ) GOTO 903
115 IF(ival+nbmp.GT.jval) GOTO 904
116 ELSE
117 GOTO 905
118 ENDIF
119
120C RECALL A PRE-FAB NODE EXPANSION SEGMENT
121C ---------------------------------------
122
123 newn = 0
124 n1 = iseq(nodi,1)
125 n2 = iseq(nodi,2)
126
127 IF(n1.EQ.0 ) GOTO 906
128 IF(n2-n1+1.GT.maxjl) GOTO 907
129
130 DO n=n1,n2
131 newn = newn+1
132 itmp(newn) = jseq(n)
133 vtmp(newn) = vali(jseq(n))
134 ENDDO
135
136C MOVE OLD NODES - STORE NEW ONES
137C -------------------------------
138
139 IF(nval(lun)+newn*nbmp.GT.maxss) GOTO 908
140
141 DO j=nval(lun),invn+1,-1
142 inv(j+newn*nbmp,lun) = inv(j,lun)
143 val(j+newn*nbmp,lun) = val(j,lun)
144 ENDDO
145
146 IF(drp.OR.drs) vtmp(1) = newn
147 knvn = invn
148
149 DO i=1,nbmp
150 DO j=1,newn
151 knvn = knvn+1
152 inv(knvn,lun) = itmp(j)
153 val(knvn,lun) = vtmp(j)
154 ENDDO
155 ENDDO
156
157C RESET POINTERS AND COUNTERS
158C ---------------------------
159
160 nval(lun) = nval(lun) + newn*nbmp
161
162 IF(iprt.GE.2) THEN
163 CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
164 WRITE ( unit=errstr, fmt='(A,A,A10,2(A,I5),A,I7)' )
165 . 'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:',
166 . 'NVAL(LUN) = ', tag(inv(invn,lun)), ':', newn, ':',
167 . nbmp, ':', nval(lun)
168 CALL errwrt(errstr)
169 DO i=1,newn
170 WRITE ( unit=errstr, fmt='(2(A,I5),A,A10)' )
171 . 'For I = ', i, ', ITMP(I) = ', itmp(i),
172 . ', TAG(ITMP(I)) = ', tag(itmp(i))
173 CALL errwrt(errstr)
174 ENDDO
175 CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
176 CALL errwrt(' ')
177 ENDIF
178
179 IF(drx) THEN
180 node = nodi
181 invr = invn
1824 node = jmpb(node)
183 IF(node.GT.0) THEN
184 IF(itp(node).EQ.0) THEN
185 DO invr=invr-1,1,-1
186 IF(inv(invr,lun).EQ.node) THEN
187 val(invr,lun) = val(invr,lun)+newn*nbmp
188 GOTO 4
189 ENDIF
190 ENDDO
191 GOTO 909
192 ELSE
193 GOTO 4
194 ENDIF
195 ENDIF
196 ENDIF
197
198C EXITS
199C -----
200
201100 RETURN
202900 WRITE(bort_str,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'//
203 . 'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET '//
204 . 'NODE) (",A,")")') nbmp,tag(nodi)
205 CALL bort(bort_str)
206901 WRITE(bort_str,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'//
207 . 'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR)'//
208 . ' (",A,")")') nbmp,tag(nodi)
209 CALL bort(bort_str)
210902 WRITE(bort_str,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '//
211 . 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")')
212 . typ(nodi),tag(nodi)
213 CALL bort(bort_str)
214903 WRITE(bort_str,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '//
215 . 'NEGATIVE (=",I5,") (",A,")")') ival,tag(nodi)
216 CALL bort(bort_str)
217904 WRITE(bort_str,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'//
218 . ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') jval,tag(nodi)
219 CALL bort(bort_str)
220905 WRITE(bort_str,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '//
221 . 'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'//
222 . ') (",A,")")') invn,nval(lun),tag(nodi)
223 CALL bort(bort_str)
224906 WRITE(bort_str,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'//
225 . 'A,")")') tag(nodi)
226 CALL bort(bort_str)
227907 WRITE(bort_str,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '//
228 . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') maxjl,tag(nodi)
229 CALL bort(bort_str)
230908 WRITE(bort_str,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'//
231 . ', EXCEEDS THE LIMIT (",I6,") (",A,")")')
232 . nval(lun)+newn*nbmp,maxss,tag(nodi)
233 CALL bort(bort_str)
234909 WRITE(bort_str,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'//
235 . '")")') tag(nodi)
236 CALL bort(bort_str)
237 END
bort
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
errwrt
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:42
moda_tables
This module contains array and variable declarations used to store the internal jump/link table.
Definition: moda_tables.F:13
moda_tables::itp
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Definition: moda_tables.F:141
moda_tables::typ
character *3, dimension(:), allocatable typ
Type indicators corresponding to tag:
Definition: moda_tables.F:133
moda_tables::ibt
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
Definition: moda_tables.F:138
moda_tables::tag
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
Definition: moda_tables.F:132
moda_tables::vali
real *8, dimension(:), allocatable vali
Initialized data values corresponding to typ:
Definition: moda_tables.F:142
moda_tables::jmpb
integer, dimension(:), allocatable jmpb
Jump backward indices corresponding to tag and typ:
Definition: moda_tables.F:137
modv_maxjl
This module declares and initializes the MAXJL variable.
Definition: modv_MAXJL.f:13
modv_maxjl::maxjl
integer maxjl
Maximum number of entries in the internal jump/link table.
Definition: modv_MAXJL.f:18
modv_maxss
This module declares and initializes the MAXSS variable.
Definition: modv_MAXSS.f:13
modv_maxss::maxss
integer maxss
Maximum number of data values that can be read from or written into a data subset by the BUFRLIB soft...
Definition: modv_MAXSS.f:19
usrtpl
subroutine usrtpl(LUN, INVN, NBMP)
THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL SUBSET ARRAYS IN MODULE USRINT FOR CASES OF ...
Definition: usrtpl.f:52