SUBROUTINE UFBSEQ(LUNIN,USR,I1,I2,IRET,STR)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: UFBSEQ
C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19
C
C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM
C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE
C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF
C ABS(LUNIN) {I.E., IF ABS(LUNIN) POINTS TO A BUFR FILE THAT IS OPEN
C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET;
C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET}.
C THE DATA VALUES CORRESPOND TO A SEQUENCE OF TABLE B MNEMONICS WHICH
C ARE REPRESENTED BY A SINGLE TABLE A OR TABLE D SEQUENCE MNEMONIC.
C THIS SEQUENCE MNEMONIC MAY ITSELF CONTAIN ONE OR MORE TABLE D
C SEQUENCE MNEMONICS ALONG WITH TABLE B MNEMONICS, THE SEQUENCE
C MNEMONICS HERE CAN USE EITHER DELAYED REPLICATION, REGULAR (I.E.,
C NON-DELAYED) REPLICATION OR THEY CAN HAVE NO REPLICATION AT ALL.
C HOWEVER, IN CASES WHERE THIS SUBROUTINE IS WRITING DATA VALUES TO
C SEQUENCES USING DELAYED-REPLICATION, THE APPLICATION PROGRAM MUST
C FIRST CALL BUFR ARCHIVE LIBRARY ROUTINE DRFINI TO PRE-ALLOCATE THE
C SPACE NEEDED TO EXPAND THE DELAYED-REPLICATION SEQUENCE (THE NUMBER
C OF REPLICATIONS IN DELAYED-REPLICATION IS SET TO ZERO BY DEFAULT).
C (SEE BUFR ARCHIVE LIBRARY DRFINI DOCBLOCK REMARKS FOR MORE
C INFORMATION.) IF UFBSEQ IS READING VALUES, THEN EITHER BUFR ARCHIVE
C LIBRARY SUBROUTINE READSB OR READNS MUST HAVE BEEN PREVIOUSLY
C CALLED TO READ THE SUBSET FROM UNIT ABS(LUNIN) INTO INTERNAL
C MEMORY. IF IT IS WRITING VALUES, THEN EITHER BUFR ARCHIVE LIBRARY
C SUBROUTINE OPENMG OR OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO
C OPEN AND INITIALIZE A BUFR MESSAGE WITHIN MEMORY FOR THIS
C ABS(LUNIN).
C
C PROGRAM HISTORY LOG:
C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR
C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY UFBSEQ
C WOULD NOT RECOGNIZE COMPRESSED DELAYED
C REPLICATION AS A LEGITIMATE DATA STRUCTURE
C 2003-05-19 J. WOOLLEN -- CORRECTED THE LOGIC ARRAY OF EXIT
C CONDITIONS FOR THE SUBROUTINE, PREVIOUSLY,
C IN SOME CASES, PROPER EXITS WERE MISSED,
C GENERATING BOGUS ERROR MESSAGES, BECAUSE OF
C SEVERAL MISCELLANEOUS BUGS WHICH ARE NOW
C REMOVED
C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
C INTERDEPENDENCIES
C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C INCREASED FROM 15000 TO 16000 (WAS IN
C VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C WRF; ADDED DOCUMENTATION (INCLUDING
C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR
C UNUSUAL THINGS HAPPEN
C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS
C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
C 2009-04-21 J. ATOR -- USE ERRWRT
C
C USAGE: CALL UFBSEQ (LUNIN, USR, I1, I2, IRET, STR)
C INPUT ARGUMENT LIST:
C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT
C NUMBER FOR BUFR FILE
C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIN IS LESS
C THAN ZERO, UFBSEQ TREATS THE BUFR FILE AS THOUGH
C IT WERE OPEN FOR INPUT
C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT:
C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
C WRITTEN TO DATA SUBSET
C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE
C NUMBER OF UNIQUE TABLE B MNEMONICS REPRESENTED BY THE
C SINGLE TABLE A OR TABLE D SEQUENCE MNEMONIC IN STR
C (FORMER MUST BE AT LEAST AS LARGE AS LATTER)
C I2 - INTEGER:
C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND
C DIMENSION OF USR
C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS"
C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET; THIS
C CORRESPONDS TO THE NUMBER OF REPLICATIONS OF THE
C MNEMONIC IN STR
C STR - CHARACTER*(*): STRING CONTAINING A SINGLE TABLE A OR
C TABLE D SEQUENCE MNEMONIC WHOSE SEQUENCE OF TABLE B
C MNEMONICS ARE IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
C DIMENSION OF USR
C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE
C "GENERIC" MNEMONICS NOT RELATED TO TABLE A OR D,
C THESE RETURN THE FOLLOWING INFORMATION IN
C CORRESPONDING USR LOCATION:
C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING")
C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
C MESSAGE (RECORD) NUMBER IN WHICH THIS
C SUBSET RESIDES
C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
C NUMBER OF THIS SUBSET WITHIN THE BUFR
C MESSAGE (RECORD) NUMBER 'IREC'
C
C OUTPUT ARGUMENT LIST:
C USR - ONLY IF BUFR FILE OPEN FOR INPUT:
C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
C READ FROM DATA SUBSET
C IRET - INTEGER:
C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF
C DATA VALUES READ FROM DATA SUBSET (MUST BE NO
C LARGER THAN I2)
C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS"
C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE
C SAME AS I2)
C
C REMARKS:
C THIS ROUTINE CALLS: BORT ERRWRT INVTAG INVWIN
C PARSTR STATUS
C THIS ROUTINE IS CALLED BY: None
C Normally called only by application
C programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
PARAMETER (MTAG=10)
COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
. INODE(NFILES),IDATE(NFILES)
COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
. JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
. IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
. ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
. ISEQ(MAXJL,2),JSEQ(MAXJL)
COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
COMMON /QUIET / IPRT
CHARACTER*(*) STR
CHARACTER*128 BORT_STR,ERRSTR
CHARACTER*10 TAG,TAGS(MTAG)
CHARACTER*3 TYP
REAL*8 USR(I1,I2),VAL
DATA IFIRST1/0/,IFIRST2/0/
SAVE IFIRST1, IFIRST2
C----------------------------------------------------------------------
C----------------------------------------------------------------------
IRET = 0
C CHECK THE FILE STATUS AND I-NODE
C --------------------------------
LUNIT = ABS(LUNIN)
CALL STATUS(LUNIT,LUN,IL,IM)
IF(IL.EQ.0) GOTO 900
IF(IM.EQ.0) GOTO 901
IO = MIN(MAX(0,IL),1)
IF(LUNIT.NE.LUNIN) IO = 0
IF(I1.LE.0) THEN
IF(IPRT.GE.0) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
ERRSTR = 'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0, ' //
. 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
CALL ERRWRT(ERRSTR)
CALL ERRWRT(STR)
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
GOTO 100
ELSEIF(I2.LE.0) THEN
IF(IPRT.EQ.-1) IFIRST1 = 1
IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
ERRSTR = 'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS .LE. 0, ' //
. 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
CALL ERRWRT(ERRSTR)
CALL ERRWRT(STR)
IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN
ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
. 'message is printed, there may be more. To output all ' //
. 'such messages,'
CALL ERRWRT(ERRSTR)
ERRSTR = 'modify your application program to add ' //
. '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
. 'to a BUFRLIB routine.'
CALL ERRWRT(ERRSTR)
ENDIF
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
IFIRST1 = 1
ENDIF
GOTO 100
ENDIF
C CHECK FOR VALID SEQUENCE AND SEQUENCE LENGTH ARGUMENTS
C ------------------------------------------------------
CALL PARSTR(STR,TAGS,MTAG,NTAG,' ',.TRUE.)
IF(NTAG.LT.1) GOTO 902
IF(NTAG.GT.1) GOTO 903
IF(I1.LE.0) GOTO 904
IF(I2.LE.0) GOTO 905
IF(INODE(LUN).NE.INV(1,LUN)) GOTO 906
C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
C --------------------------------------------------
IF(IO.EQ.0) THEN
DO J=1,I2
DO I=1,I1
USR(I,J) = BMISS
ENDDO
ENDDO
ENDIF
C FIND THE PARAMETERS OF THE SPECIFIED SEQUENCE
C ---------------------------------------------
DO NODE=INODE(LUN),ISC(INODE(LUN))
IF(STR.EQ.TAG(NODE)) THEN
IF(TYP(NODE).EQ.'SEQ'.OR.TYP(NODE).EQ.'RPC') THEN
INS1 = INVTAG(NODE,LUN, 1,NVAL(LUN))
INS2 = INVTAG(NODE,LUN,INS1+1,NVAL(LUN))
IF(INS1.EQ.0) GOTO 200
IF(INS2.EQ.0) INS2 = 10E5
NODS = NODE
DO WHILE(LINK(NODS).EQ.0.AND.JMPB(NODS).GT.0)
NODS = JMPB(NODS)
ENDDO
IF(LINK(NODS).EQ.0) THEN
INSX = NVAL(LUN)
ELSEIF(LINK(NODS).GT.0) THEN
INSX = INVWIN(LINK(NODS),LUN,INS1+1,NVAL(LUN))-1
ENDIF
INS2 = MIN(INS2,INSX)
ELSEIF(TYP(NODE).EQ.'SUB') THEN
INS1 = 1
INS2 = NVAL(LUN)
ELSE
GOTO 907
ENDIF
NSEQ = 0
DO ISQ=INS1,INS2
ITYP = ITP(INV(ISQ,LUN))
IF(ITYP.GT.1) NSEQ = NSEQ+1
ENDDO
IF(NSEQ.GT.I1) GOTO 908
GOTO 1
ENDIF
ENDDO
GOTO 200
C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME
C ----------------------------------------------------
1 INS1 = INVTAG(NODE,LUN,INS1,NVAL(LUN))
c .... previous SP version of BUFR ARCHIVE LIBRARY has line below
c (note ".gt.")
IF(INS1.GT.NVAL(LUN)) GOTO 200
IF(INS1.GT.0) THEN
c .... previous decoder version of BUFR ARCHIVE LIBRARY has line below
c (note ".ge.")
ccccc IF(INS1.GE.NVAL(LUN)) GOTO 200
IF(TYP(NODE).EQ.'RPC'.AND.VAL(INS1,LUN).EQ.0.) THEN
INS1 = INS1+1
GOTO 1
ELSEIF(IO.EQ.0.AND.IRET+1.GT.I2) THEN
GOTO 909
ENDIF
ELSEIF(INS1.EQ.0) THEN
IF(IO.EQ.1.AND.IRET.LT.I2) GOTO 910
ELSE
GOTO 911
ENDIF
IF(INS1.EQ. 0) GOTO 200
IF(IRET.EQ.I2) GOTO 200
IRET = IRET+1
INS1 = INS1+1
C READ/WRITE USER VALUES
C ----------------------
J = INS1
DO I=1,NSEQ
DO WHILE(ITP(INV(J,LUN)).LT.2)
J = J+1
ENDDO
IF(IO.EQ.0) USR(I,IRET) = VAL(J,LUN )
IF(IO.EQ.1) VAL(J,LUN ) = USR(I,IRET)
J = J+1
ENDDO
C CHECK FOR NEXT FRAME
C --------------------
GOTO 1
200 CONTINUE
IF(IRET.EQ.0) THEN
IF(IO.EQ.0) THEN
IF(IPRT.GE.1) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' //
. 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
CALL ERRWRT(ERRSTR)
CALL ERRWRT(STR)
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
ELSE
IF(IPRT.EQ.-1) IFIRST2 = 1
IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' //
. 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
CALL ERRWRT(ERRSTR)
CALL ERRWRT(STR)
CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)')
IF(IPRT.EQ.0) THEN
ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
. 'message is printed, there may be more. To output all ' //
. 'such messages,'
CALL ERRWRT(ERRSTR)
ERRSTR = 'modify your application program to add ' //
. '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
. 'to a BUFRLIB routine.'
CALL ERRWRT(ERRSTR)
ENDIF
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
IFIRST2 = 1
ENDIF
ENDIF
ENDIF
C EXITS
C -----
100 RETURN
900 CALL BORT('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'//
. ' OPEN')
901 CALL BORT('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '//
. 'FILE, NONE ARE')
902 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '//
. 'DOES NOT CONTAIN ANY MNEMONICS!!")') STR
CALL BORT(BORT_STR)
903 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '//
. 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'//
. ',")")') STR,NTAG
CALL BORT(BORT_STR)
904 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THIRD ARGUMENT (INPUT) MUST'//
. ' BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
. I1,TAGS(1)
CALL BORT(BORT_STR)
905 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - FOURTH ARGUMENT (INPUT) '//
. 'MUST BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
. I2,TAGS(1)
CALL BORT(BORT_STR)
906 CALL BORT('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '//
. 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
. 'SUBSET ARRAY')
907 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '//
. 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') TAGS(1),TYP(NODE)
CALL BORT(BORT_STR)
908 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'//
. '" CONSISTS OF",I4," TABLE B MNEM., .GT. THE MAX. SPECIFIED IN'//
. ' (INPUT) ARGUMENT 3 (",I3,")")') TAGS(1),NSEQ,I1
CALL BORT(BORT_STR)
909 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' READ > '//
. 'LIMIT OF",I4," IN THE 4-TH ARG. (INPUT) - INCOMPLETE READ '//
. '(INPUT MNEMONIC IS ",A,")")') I2,TAGS(1)
CALL BORT(BORT_STR)
910 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '//
. '(",I3,") .LT. NO. REQUESTED (",I3,") - INCOMPLETE WRITE '//
. '(INPUT MNEMONIC IS ",A,")")') IRET,I2,TAGS(1)
CALL BORT(BORT_STR)
911 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE .GE. '//
. 'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') INS1,TAGS(1)
CALL BORT(BORT_STR)
END