60 CHARACTER*128 bort_str,errstr
61 LOGICAL drp,drs,drb,drx
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))
72 CALL
errwrt(
'++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
78 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
79 CALL
errwrt(.LE.
'BUFRLIB: USRTPL - NBMP 0 - IMMEDIATE RETURN')
80 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
98 IF(nbmp.NE.1) goto 900
99 ELSEIF(invn.GT.0 .AND. invn.LE.nval(lun))
THEN
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
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
124 IF(n1.EQ.0 ) goto 906
125 IF(n2-n1+1.GT.maxjl) goto 907
130 vtmp(newn) = vali(jseq(n))
136 IF(nval(lun)+newn*nbmp.GT.maxss) goto 908
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)
143 IF(drp.OR.drs) vtmp(1) = newn
149 inv(knvn,lun) = itmp(j)
150 val(knvn,lun) = vtmp(j)
157 nval(lun) = nval(lun) + newn*nbmp
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)
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))
172 CALL
errwrt(
'++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
181 IF(itp(node).EQ.0)
THEN
183 IF(inv(invr,lun).EQ.node)
THEN
184 val(invr,lun) = val(invr,lun)+newn*nbmp
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)
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)
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)
211 903
WRITE(bort_str,
'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '//
212 .
'NEGATIVE (=",I5,") (",A,")")') ival,tag(nodi)
214 904
WRITE(bort_str,
'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'//
215 .
' (EXCEEDS MAXIMUM OF",I6," (",A,")")') jval,tag(nodi)
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)
221 906
WRITE(bort_str,
'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'//
222 .
'A,")")') tag(nodi)
224 907
WRITE(bort_str,
'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '//
225 .
'EXCEEDS THE LIMIT (",I6,") (",A,")")') maxjl,tag(nodi)
227 908
WRITE(bort_str,
'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'//
228 .
', EXCEEDS THE LIMIT (",I6,") (",A,")")')
229 . nval(lun)+newn*nbmp,maxss,tag(nodi)
231 909
WRITE(bort_str,
'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'//
subroutine usrtpl(LUN, INVN, NBMP)
THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL SUBSET ARRAYS IN MODULE USRINT FOR CASES OF ...
This module contains array and variable declarations used to store the internal jump/link table...
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...