157 SUBROUTINE ufbseq(LUNIN,USR,I1,I2,IRET,STR)
169 CHARACTER*156 bort_str
171 CHARACTER*10 tags(mtag)
174 DATA ifirst1/0/,ifirst2/0/
176 SAVE ifirst1, ifirst2
187 CALL
status(lunit,lun,il,im)
191 io = min(max(0,il),1)
192 IF(lunit.NE.lunin) io = 0
196 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
197 errstr = .LE.
'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS 0, ' //
198 .
'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
201 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
206 IF(iprt.EQ.-1) ifirst1 = 1
207 IF(io.EQ.0 .OR. ifirst1.EQ.0 .OR. iprt.GE.1)
THEN
208 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
209 errstr = .LE.
'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS 0, ' //
210 .
'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
213 IF(iprt.EQ.0 .AND. io.EQ.1)
THEN
214 errstr =
'Note: Only the first occurrence of this WARNING ' //
215 .
'message is printed, there may be more. To output all ' //
218 errstr =
'modify your application program to add ' //
219 .
'"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
220 .
'to a BUFRLIB routine.'
223 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
233 CALL
parstr(str,tags,mtag,ntag,
' ',.true.)
234 IF(ntag.LT.1) goto 902
235 IF(ntag.GT.1) goto 903
238 IF(inode(lun).NE.inv(1,lun)) goto 906
256 DO node=inode(lun),isc(inode(lun))
257 IF(str.EQ.tag(node))
THEN
258 IF(typ(node).EQ.
'SEQ'.OR.typ(node).EQ.
'RPC')
THEN
260 5 ins1 =
invtag(node,lun,ins1,nval(lun))
261 IF(ins1.EQ.0) goto 200
262 IF(typ(node).EQ.
'RPC'.AND.val(ins1,lun).EQ.0.)
THEN
266 ins2 =
invtag(node,lun,ins1+1,nval(lun))
267 IF(ins2.EQ.0) ins2 = 10e5
269 DO WHILE(link(nods).EQ.0.AND.jmpb(nods).GT.0)
272 IF(link(nods).EQ.0)
THEN
274 ELSEIF(link(nods).GT.0)
THEN
275 insx =
invwin(link(nods),lun,ins1+1,nval(lun))-1
277 ins2 = min(ins2,insx)
278 ELSEIF(typ(node).EQ.
'SUB')
THEN
286 ityp = itp(inv(isq,lun))
287 IF(ityp.GT.1) nseq = nseq+1
289 IF(nseq.GT.i1) goto 908
299 1 ins1 =
invtag(node,lun,ins1,nval(lun))
300 IF(ins1.GT.nval(lun)) goto 200
302 IF(typ(node).EQ.
'RPC'.AND.val(ins1,lun).EQ.0.)
THEN
305 ELSEIF(io.EQ.0.AND.iret+1.GT.i2)
THEN
307 CALL
errwrt(
'++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
308 WRITE ( unit=errstr, fmt=
'(A,I5,A,A,A)' )
309 .
'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2,
310 .
' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1),
313 CALL
errwrt(
'++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
318 ELSEIF(ins1.EQ.0)
THEN
319 IF(io.EQ.1.AND.iret.LT.i2) goto 910
324 IF(ins1.EQ. 0) goto 200
325 IF(iret.EQ.i2) goto 200
335 DO WHILE(itp(inv(j,lun)).LT.2)
338 IF(io.EQ.0) usr(i,iret) = val(j,lun )
339 IF(io.EQ.1) val(j,lun ) = usr(i,iret)
353 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
354 errstr =
'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' //
355 .
'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
358 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
362 IF(iprt.EQ.-1) ifirst2 = 1
363 IF(ifirst2.EQ.0 .OR. iprt.GE.1)
THEN
364 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
365 errstr =
'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' //
366 .
'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
369 CALL
errwrt(
'MAY NOT BE IN THE BUFR TABLE(?)')
371 errstr =
'Note: Only the first occurrence of this WARNING ' //
372 .
'message is printed, there may be more. To output all ' //
375 errstr =
'modify your application program to add ' //
376 .
'"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
377 .
'to a BUFRLIB routine.'
380 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
391 900 CALL
bort(
'BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'//
393 901 CALL
bort(
'BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '//
395 902
WRITE(bort_str,
'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '//
396 .
'DOES NOT CONTAIN ANY MNEMONICS!!")') str
398 903
WRITE(bort_str,
'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '//
399 .
'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'//
402 904
WRITE(bort_str,
'("BUFRLIB: UFBSEQ - THIRD ARGUMENT (INPUT) MUST'//
403 . .GT.
' BE ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
406 905
WRITE(bort_str,
'("BUFRLIB: UFBSEQ - FOURTH ARGUMENT (INPUT) '//
407 . .GT.
'MUST BE ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
410 906 CALL
bort(
'BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '//
411 .
'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
413 907
WRITE(bort_str,
'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '//
414 .
'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
416 908
WRITE(bort_str,
'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'//
417 . .GT.
'" CONSISTS OF",I4," TABLE B MNEM., THE MAX. SPECIFIED IN'//
418 .
' (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1
420 910
WRITE(bort_str,
'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '//
421 . .LT.
'(",I5,") NO. REQUESTED (",I5,") - INCOMPLETE WRITE '//
422 .
'(INPUT MNEMONIC IS ",A,")")') iret,i2,tags(1)
424 911
WRITE(bort_str,.GE.
'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE '//
425 .
'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') ins1,tags(1)
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS...
This module declares and initializes the BMISS variable.
This module contains array and variable declarations used to store the internal jump/link table...
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
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() ...
function invwin(NODE, LUN, INV1, INV2)
THIS FUNCTION LOOKS FOR A SPECIFIED NODE WITHIN THE PORTION OF THE CURRENT SUBSET BUFFER BOUNDED BY T...
subroutine ufbseq(LUNIN, USR, I1, I2, IRET, STR)
This subroutine reads or writes an entire sequence of data values from or to the BUFR data subset tha...
function invtag(NODE, LUN, INV1, INV2)
THIS FUNCTION LOOKS FOR A SPECIFIED MNEMONIC WITHIN THE PORTION OF THE CURRENT SUBSET BUFFER BOUNDED ...