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