SUBROUTINE W3FI85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3,
* JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC,
* KIF,KDESC,NRDESC,ISEC2D,ISEC2B,
* KDATA,KARY,KBUFR,IERRTN)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3FI85 GENERATE BUFR MESSAGE
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: USING INFORMATION AVAILABLE IN SUPPLIED ARRAYS, GENERATE
C A BUFR MESSAGE (WMO CODE FM94). THERE MAY BE A SECTION 2
C INCLUDED IN THE BUFR MESSAGE IF THE USER FOLLOWS PROPER PROCEDURE.
C MESSAGES ARE CONSTRUCTED IN ACCORDANCE WITH BUFR EDITION 2. ENTRIES
C FOR SECTION 1 MUST BE PASSED TO THIS ROUTINE IN THE ISECT1 ARRAY.
C ENTRIES FOR SECTION 3 MUST BE PASSED TO THIS ROUTINE IN ISECT3.
C
C
C IN THE EVENT THAT THE USER REQUESTS A REDUCTION OF REPORTS
C IN A BUFR MESSAGE IF A PARTICULAR MESSAGE BECOMES OVERSIZED, THE
C POSSIBILITY EXISTS OF THE LAST BLOCK OF DATA PRODUCING AN OVERSIZED
C MESSAGE. THE USER MUST VERIFY THAT ISECT3(6) DOES IN FACT EQUAL
C ZERO TO ASSURE THAT ALL OF THE DATA HAS BEEN INCLUDED AS OUTPUT.
C
C PROGRAM HISTORY LOG:
C 93-09-29 CAVANAUGH
C 94-03-22 J. HOPPA - CORRECTED AN ERROR WHEN WRITING THE
C DESCRIPTORS INTO THE BUFR MESSAGE
C 94-03-31 J. HOPPA - ADDED THE SUBSET NUMBER TO THE PARAMETER LIST
C OF SUBROUTINE FI8501
C 94-04-15 J. HOPPA - ADDED KBUFR TO THE PARAMETER LIST OF
C SUBROUTINE FI8502
C 94-04-20 J. HOPPA - ADDED THE KDATA PARAMETER COUNTER TO THE
C PARAMETER LIST OF SUBROUTINE FI8501
C 95-04-29 J. HOPPA - CHANGED NQ AND N TO KARY(2)
C - CHANGED JK TO KARY(11)
C - ADDED AN ASSIGNMENT TO KARY(2) SO HAVE
C SOMETHING TO PASS TO SUBROUTINES
C - DELETED JK AND LL FROM CALL TO FI8501
C
C USAGE: CALL W3FI85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3,
C * JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC,
C * KIF,KDESC,NRDESC,ISEC2D,ISEC2B,
C * KDATA,KARY,KBUFR,IERRTN)
C INPUT ARGUMENT LIST:
C ISTEP - KEY FOR SELECTION OF PROCESSING STEP
C 1 = PROCESS INTEGER/TEXT ARRAY INTO KDATA
C 2 = PROCESS REAL/TEXT ARRAY INTO KDATA
C 3 = CONSTRUCT BUFR MESSAGE
C IUNITB - UNIT NUMBER OF DEVICE CONTAINING TABLE B
C IUNITD - UNIT NUMBER OF DEVICE CONTAINING TABLE D
C IBFSIZ - SIZE IN BYTES OF BUFR MESSAGE ARRAY (KBUFR)
C SHOULD BE A MULTIPLE OF WORD SIZE.
C ISECT1 - CONTAINS INFORMATION TO ENTER INTO SECTION 1
C ( 1) EDITION NUMBER
C ( 2) BUFR MASTER TABLE NUMBER
C 0 = METEOROLOGICAL
C OTHERS NOT YET DEFINED
C ( 3) ORIGINATING CENTER - SUBCENTER NUMBER
C ( 4) ORIGINATING CENTER NUMBER
C ( 5) UPDATE SEQUENCE NUMBER
C ( 6) OPTIONAL SECTION FLAG
C SHOULD BE SET TO ZERO UNLESS USER
C WRITE ADDITIONAL CODE TO ENTER LOCAL
C INFORMATION INTO SECTION 3
C ( 7) BUFR MESSAGE TYPE
C ( 8) BUFR MESSAGE SUB_TYPE
C ( 9) MASTER TABLE VERSION NUMBER
C (10) LOCAL TABLE VERSION NUMBER
C (11) YEAR OF CENTURY - REPRESENTATIVE OF DATA
C (12) MONTH - REPRESENTATIVE OF DATA
C (13) DAY - REPRESENTATIVE OF DATA
C (14) HOUR - REPRESENTATIVE OF DATA
C (15) MINUTE - REPRESENTATIVE OF DATA
C (16)-(20) UNUSED
C
C ISECT3 - VALUES TO BE INSERTED INTO SECTION 3, AND
C TO CONTROL REPORT REDUCTION FOR OVERSIZED MESSAGES
C (1) NUMBER OF SUBSETS
C DEFINES THE NUMBER OF SUBSETS BEING PASSED TO THE
C ENCODER ROUTINE FOR INCLUSION INTO A BUFR MESSAGE.
C IF THE USER HAS SPECIFIED THE USE OF THE
C SUBSET/REPORT REDUCTION ACTIVATION SWITCH, THEN
C A PART OF THOSE SUBSETS MAY BE USED FOR THE CURRENT
C MESSAGE AND THE REMAINDER RETAINED FOR A
C SUBSEQUENT MESSAGE.
C (2) OBSERVED FLAG
C 0 = OBSERVED DATA
C 1 = OTHER DATA
C (3) COMPRESSED FLAG
C 0 = NONCOMPRESSED
C 1 = COMPRESSED
C (4) SUBSET/REPORT REDUCTION ACTIVATION SWITCH
C USED TO CONTROL THE NUMBER OF REPORTS ENTERED INTO
C A BUFR MESSAGE WHEN MAXIMUM MESSAGE SIZE IS EXCEEDED
C 0 = OPTION NOT ACTIVE
C 1 = OPTION IS ACTIVE. UNUSED SUBSETS WILL BE
C SHIFTED TO LOW ORDER POSITIONS OF ENTRY ARRAY.
C 2 = OPTION IS ACTIVE. UNUSED SUBSETS WILL REMAIN
C IN ENTRY POSITIONS.
C
C NOTE:- IF THIS FLAG IS SET TO ANY OTHER
C VALUES, PROGRAM WILL BE TERMINATED WITH AN
C ERROR CONDITION.
C (5) NUMBER OF REPORTS TO DECREMENT BY, IF OVERSIZED MESSAGE
C (MINIMUM VALUE = ONE). IF ZERO IS ENTERED, IT WILL
C BE REPLACED BY ONE.
C (6) NUMBER OF UNUSED REPORTS RETURNED TO USER
C (7) NUMBER OF REPORTS INCLUDED IN MESSAGE
C (8) NUMBER OF TABLE B ENTRIES AVAILABLE TO DECODER
C (9) NUMBER OF TABLE D ENTRIES AVAILABLE TO DECODER
C (10) TEXT INPUT FLAG
C 0 = ASCII INPUT
C 1 = EBCIDIC INPUT
C
C JIF - JDESC INPUT FORMAT FLAG
C 0 = F X Y
C 1 = DECIMAL FORMAT
C JDESC - LIST OF DESCRIPTORS TO GO INTO SECTION 3
C EACH DESCRIPTOR = F * 16384 + X * 256 + Y
C THEY MAY OR MAY NOT BE AN EXACT MATCH OF THE
C WORKING DESCRIPTOR LIST IN KDESC. THIS SET OF
C DESCRIPTORS MAY CONTAIN SEQUENCE DESCRIPTORS TO
C PROVIDE ADDITIONAL COMPRESSION WITHIN THE BUFR
C MESSAGE. THERE MAY BE AS FEW AS ONE SEQUENCE
C DESCRIPTOR, OR AS MANY DESCRIPTORS AS THERE ARE
C IN KDESC.
C NEWNR - NR OF DESCRIPTORS IN JDESC
C IDATA - INTEGER ARRAY DIMENSIONED BY THE NUMBER OF
C DESCRIPTORS TO BE USED
C RDATA - REAL ARRAY DIMENSIONED BY THE NUMBER OF
C DESCRIPTORS TO BE USED
C ATEXT - ARRAY CONTAINING ALL TEXT DATA ASSOCIATED WITH A
C SPECIFIC REPORT. ALL DATA IDENTIFIED AS TEXT DATA MUST
C BE IN ASCII.
C KASSOC - INTEGER ARRAY DIMENSIONED BY THE NUMBER OF DESCRIPTORS
C TO BE USED, CONTAINING THE ASSOCIATED FIELD VALUES
C FOR ANY ENTRY IN THE DESCRIPTOR LIST.
C KIF - KDESC INPUT FORMAT FLAG
C 0 = F X Y
C 1 = DECIMAL FORMAT
C KDESC - LIST OF DESCRIPTORS TO GO INTO SECTION 3
C FULLY EXPANDED SET OF WORKING DESCRIPTORS. THERE
C SHOULD BE AN ELEMENT DESCRIPTOR FOR EVERY DATA
C ENTRY, BUT THERE SHOULD BE
C NO SEQUENCE DESCRIPTORS
C NRDESC - NR OF DESCRIPTORS IN KDESC
C ISEC2D - DATA OR TEXT TO BE ENTERED INTO SECTION 2
C ISEC2B - NUMBER OF BYTES OF DATA IN ISEC2D
C
C OUTPUT ARGUMENT LIST:
C KDATA - SOURCE DATA ARRAY . A 2-DIMENSION INTEGER ARRAY
C WHERE KDATA(SUBSET,PARAM)
C SUBSET = SUBSET NUMBER
C PARAM = PARAMETER NUMBER
C KARY - WORKING ARRAY FOR MESSAGE UNDER CONSTRUCTION
C (1) UNUSED
C (2) PARAMETER POINTER
C (3) MESSAGE BIT POINTER
C (4) DELAYED REPLICATION FLAG
C 0 = NO DELAYED REPLICATION
C 1 = CONTAINS DELAYED REPLICATION
C (5) BIT POINTER FOR START OF SECTION 4
C (6) UNUSED
C (7) NR OF BITS FOR PARAMETER/DATA PACKING
C (8) TOTAL BITS FOR ASCII DATA
C (9) SCALE CHANGE VALUE
C (10) INDICATOR (USED IN W3FI85)
C 1 = NUMERIC DATA
C 2 = TEXT DATA
C (11) POINTER TO CURRENT POS IN KDESC
C (12) UNUSED
C (13) UNUSED
C (14) UNUSED
C (15) DATA TYPE
C (16) UNUSED
C (17) UNUSED
C (18) WORDS ADDED FOR TEXT OR ASSOCIATED FIELDS
C (19) LOCATION FOR TOTAL BYTE COUNT
C (20) SIZE OF SECTION 0
C (21) SIZE OF SECTION 1
C (22) SIZE OF SECTION 2
C (23) SIZE OF SECTION 3
C (24) SIZE OF SECTION 4
C (25) SIZE OF SECTION 5
C (26) NR BITS ADDED BY TABLE C OPERATOR
C (27) BIT WIDTH OF ASSOCIATED FIELD
C (28) JDESC INPUT FORM FLAG
C 0 = DESCRIPTOR IN F X Y FORM
C F IN JDESC(1,I)
C X IN JDESC(2,I)
C Y IN JDESC(3,I)
C 1 = DESCRIPTOR IN DECIMAL FORM IN JDESC(1,I)
C (29) KDESC INPUT FORM FLAG
C 0 = DESCRIPTOR IN F X Y FORM
C F IN KDESC(1,I)
C X IN KDESC(2,I)
C Y IN KDESC(3,I)
C 1 = DESCRIPTOR IN DECIMAL FORM IN KDESC(1,I)
C (30) BUFR MESSAGE TOTAL BYTE COUNT
C KBUFR - ARRAY TO CONTAIN COMPLETED BUFR MESSAGE
C IERRTN - ERROR RETURN FLAG
C KSEQ - WORKING ARRAY FOR TABLE D INITIAL SEARCH KEY
C KNUM - WORKING ARRAY FOR TABLE D NUMBER OF DESC'S IN SEQ
C KLIST - WORKING ARRAY FOR TABLE D SEQUENCES
C ANAME - TABLE B DESCRIPTOR NAMES
C AUNITS - TABLE B DESCRIPTOR UNITS
C LDESC - TABLE B DECIMAL EQUIV OF F X Y VALUES
C KSCALE - TABLE B STANDARD SCALE VALUES
C KFRVAL - TABLE B REFERENCE VALUES
C KRFVSW - TABLE B SWITCHES TO INDICATE IF HAVE NEW/OLD REF VAL
C NEWRFV - TABLE B NEW REFERENCE VALUES
C KWIDTH - ARRAY OF BIT WIDTHS FOR EACH ENTRY IN TABLE B
C
C REMARKS:
C IERRTN = 0 NORMAL RETURN, BUFR MESSAGE RESIDES IN KBUFR
C IF ISECT3(4)= 0, ALL REPORTS HAVE BEEN
C PROCESSED INTO A BUFR
C MESSAGE
C IF ISECT3(4)= 1, A BUFR MESSAGE HAS BEEN
C GENERATED WITH ALL OR PART OF
C THE DATA PASSED TO THIS
C ROUTINE. ISECT3(6) CONTAINS
C THE NUMBER OF REPORTS THAT
C WERE NOT USED BUT ARE BEING
C HELD FOR THE NEXT MESSAGE.
C = 1 BUFR MESSAGE CONSTRUCTION WAS HALTED
C BECAUSE CONTENTS EXCEEDED MAXIMUM SIZE
C (ONLY WHEN ISECT3(4) = 0)
C = 2 BUFR MESSAGE CONSTRUCTION WAS HALTED
C BECAUSE OF ENCOUNTER WITH A DESCRIPTOR
C NOT FOUND IN TABLE B.
C = 3 ROUTINE WAS CALLED WITH NO SUBSETS
C = 4 ERROR OCCURED WHILE READING TABLE B
C = 5 AN ATTEMPT WAS MADE TO EXPAND JDESC
C INTO KDESC, BUT A DESCRIPTOR INDICATING
C DELAYED REPLICATION WAS ENCOUNTERED
C = 6 ERROR OCCURED WHILE READING TABLE D
C = 7 DATA VALUE COULD NOT BE CONTAINED
C IN SPECIFIED BIT WIDTH
C = 8 DELAYED REPLICATION NOT PERMITTED
C IN COMPRESSED DATA FORMAT
C = 9 AN OPERATOR DESCRIPTOR 2 04 YYY OPENING
C AN ASSOCIATED FIELD (YYY NOT EQ ZERO)
C WAS NOT FOLLOWED BY THE DEFINING DESCRIPTOR
C 0 31 021 (7957 DECIMAL).
C = 10 DELAYED REPLICATION DESCRIPTOR WAS NOT
C FOLLOWED BY DESCRIPTOR FOR DELAYED
C REPLICATION FACTOR.
C 0 31 001
C 0 31 002
C 0 31 011
C 0 31 012
C = 11 ENCOUNTERED A REFERENCE VALUE THAT FORCED A
C DATA ELEMENT TO BECOME NEGATIVE
C = 12 NO MATCHING TABLE D ENTRY FOR SEQUENCE
C DESCRIPTOR.
C = 13 ENCOUNTERED A NON-ACCEPTABLE DATA ENTRY FLAG.
C ISECT3(6) SHOULD BE 0 OR 1.
C = 14 CONVERTING DESCRIPTORS FXY->DECIMAL,
C NUMBER TO CONVERT = 0
C = 15 NO DESCRIPTORS SPECIFIED FOR SECTION 3
C = 16 INCOMPLETE TABLE B, NUMBER OF DESCRIPTORS
C IN TABLE B DOES NOT MATCH NUMBER OF
C DESCRIPTORS NEEDED TO CONSTRUCT BUFR MESSAGE
C = 20 INCORRECT ENTRY OF REPLICATION OR SEQUENCE
C DESCRIPTOR IN LIST OF REFERENCE VALUE CHANGES
C = 21 INCORRECT OPERATOR DESCRIPTOR IN LIST OF
C REFERENCE VALUE CHANGES
C = 22 ATTEMPTING TO ENTER NEW REFERENCE VALUE INTO
C TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN
C CURRENT MODIFIED TABLE B
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
REAL RDATA(*)
C
INTEGER IDATA(*),LOWEST,MAXVAL,JSTART
INTEGER KARY(*),MISG,LL
INTEGER KDESC(3,*),KASSOC(*)
INTEGER IBITS(32)
INTEGER ZEROS(255)
INTEGER INDEXB(16383)
CHARACTER*9 CCITT
CHARACTER*4 AHOLD(2)
CHARACTER*1 ATEXT(*)
LOGICAL*1 TEXT
LOGICAL*1 MSGFLG,DUPFLG
C =====================================
C INFORMATION REQUIRED FOR CONSTRUCTION OF BUFR MESSAGE
INTEGER ISECT1(*)
INTEGER ISEC2B,ISEC2D(255)
INTEGER ISECT3(*)
INTEGER JDESC(3,*)
INTEGER NEWNR
INTEGER KDATA(500,*)
INTEGER KBUFR(*)
C =====================================
C TABLE B INFORMATION
INTEGER LDESC(800),KT(800)
INTEGER KSCALE(800)
INTEGER KRFVAL(800),KRFVSW(800),NEWRFV(800)
INTEGER KWIDTH(800)
CHARACTER*40 ANAME(800)
CHARACTER*25 AUNITS(800)
C =====================================
C TABLE D INFORMATION
INTEGER KSEQ(300),KNUM(300)
INTEGER KLIST(300,10)
C =====================================
SAVE
C
DATA CCITT /'CCITT IA5'/
DATA IBITS / 1, 3, 7, 15,
* 31, 63, 127, 255,
* 511, 1023, 2047, 4095,
* 8191, 16383, 32767, 65535,
* Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
* Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
* Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
* Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
DATA LL /0/
DATA MISG /99999/
DATA ZEROS /255*0/
C =====================================
C THERE MUST BE DESCRIPTORS IN JDESC
C AND A COUNT IN NEWNR
C =====================================
IF (NEWNR.EQ.0) THEN
IERRTN = 15
RETURN
END IF
C =====================================
C IF INPUT FORM IS F X Y SEGMENTS THEN
C CONVERT INPUT FORM OF JDESC FROM FXY TO DECIMAL
C =====================================
IF (JIF.EQ.0) THEN
C CONVERT TO DECIMAL
CALL FI8505(JIF,JDESC,NEWNR,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
END IF
C =====================================
C IF PROCESSING DELAYED REPLICATION, MUST RELOAD
C KDESC FROM JDESC
C =====================================
IF (KARY(4).NE.0) THEN
NRDESC = 0
END IF
C =====================================
C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
C =====================================
C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
IF (NRDESC.EQ.0) THEN
DO 50 I = 1, NEWNR
KDESC(1,I) = JDESC(1,I)
50 CONTINUE
NRDESC = NEWNR
KIF = 1
ELSE IF (NRDESC.NE.0) THEN
C KDESC ALL READY EXISTS
IF (KIF.EQ.0) THEN
C CONVERT INPUT FORM OF KDESC FROM FXY TO DECIMAL
CALL FI8505(KIF,KDESC,NRDESC,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
END IF
END IF
C =====================================
C READ IN TABLE B SUBSET, IF NOT ALL READY IN PLACE
C =====================================
IF (ISECT3(8).EQ.0) THEN
CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
* LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
* IUNITD,KSEQ,KNUM,KLIST,INDEXB)
IF (IERRTN.NE.0) GO TO 9000
END IF
C =====================================
C ROUTE TO SELECTED PROCESSING
C =====================================
KSUB = ISECT3(1)
IF (ISTEP.EQ.1) THEN
C PROCESSING INTEGER DATA INPUT
CALL FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
* KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
* KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
RETURN
ELSE IF (ISTEP.EQ.2) THEN
C PROCESSING REAL DATA INPUT
CALL FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
* KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
* KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
RETURN
ELSE IF (ISTEP.NE.3) THEN
IERRTN = 20
RETURN
END IF
C =====================================
C IF INDICATING ZERO SUBSETS, HAVE AN ERROR CONDITION
C =====================================
IF (ISECT3(1).LE.0) THEN
IERRTN = 3
RETURN
END IF
C =====================================
C SET FOR BUFR MESSAGE
C =====================================
C
C CLEAR OUTPUT AREA
C BYTES IN EACH FULL WORD
KWORD = 4
C
C GET NUMBER OF SUBSETS
C
MXRPTS = ISECT3(1)
ISECT3(7) = ISECT3(1)
ISECT3(6) = ISECT3(1)
C
C RE-START POINT FOR PACKING FEWER SUBSETS ?
C
5 CONTINUE
C
KARY(18) = 0
KARY(26) = 0
C =====================================
C ENTER 'BUFR' - SECTION 0
C CONSTRUCT UNDER RULES OF EDITION 2
C =====================================
KARY(3) = 0
NBUFR = 1112884818
CALL SBYTE (KBUFR,NBUFR,KARY(3),32)
KARY(3) = KARY(3) + 32
C SAVE POINTER FOR TOTAL BYTE COUNT
C IN MESSAGE
KARY(19) = KARY(3)
KARY(3) = KARY(3) + 24
C SET EDITION NR IN PLACE
CALL SBYTE (KBUFR,2,KARY(3),8)
KARY(3) = KARY(3) + 8
KARY(20) = 8
C PRINT *,'SECTION 0'
C =====================================
C COMPLETE ENTRIES FOR - SECTION 1
C =====================================
C ----- 1,3 SECTION COUNT
KARY(21) = 18
CALL SBYTE (KBUFR,KARY(21),KARY(3),24)
KARY(3) = KARY(3) + 24
C ----- 4 RESERVED
CALL SBYTE (KBUFR,0,KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 5 ORIGINATING SUB-CENTER
CALL SBYTE (KBUFR,ISECT1(3),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 6 ORIGINATING CENTER
CALL SBYTE (KBUFR,ISECT1(4),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 7 UPDATE SEQUENCE NUMBER
CALL SBYTE (KBUFR,ISECT1(5),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 8
C INDICATE NO SECTION 2
CALL SBYTE (KBUFR,ISECT1(6),KARY(3),1)
KARY(3) = KARY(3) + 1
CALL SBYTE (KBUFR,0,KARY(3),7)
KARY(3) = KARY(3) + 7
C ----- 9 BUFR MESSAGE TYPE
CALL SBYTE (KBUFR,ISECT1(7),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 10 BUFR MESSAGE SUB-TYPE
CALL SBYTE (KBUFR,ISECT1(8),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 11 VERSION OF MASTER TABLE
CALL SBYTE (KBUFR,ISECT1(9),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 12 VERSION OF LOCAL TABLE
CALL SBYTE (KBUFR,ISECT1(10),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 13 YEAR
CALL SBYTE (KBUFR,ISECT1(11),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 14 MONTH
CALL SBYTE (KBUFR,ISECT1(12),KARY(3),8)
KARY(3) = KARY(3) + 8
C ---- 15 DAY
CALL SBYTE (KBUFR,ISECT1(13),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 16 HOUR
CALL SBYTE (KBUFR,ISECT1(14),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 17 MINUTE
CALL SBYTE (KBUFR,ISECT1(15),KARY(3),8)
KARY(3) = KARY(3) + 8
C ----- 18 FILL
CALL SBYTE (KBUFR,0,KARY(3),8)
KARY(3) = KARY(3) + 8
C PRINT *,'SECTION 1'
C =====================================
C SKIP - SECTION 2
C =====================================
IF (ISECT1(6).NE.0) THEN
C BUILD SECTION COUNT
KARY(22) = 4 + ISEC2B
IF (MOD(KARY(22),2).NE.0) KARY(22) = KARY(22) + 1
C INSERT SECTION COUNT
CALL SBYTE (KBUFR,KARY(22),KARY(3),24)
KARY(3) = KARY(3) + 24
C INSERT RESERVED POSITION
CALL SBYTE (KBUFR,0,KARY(3),8)
KARY(3) = KARY(3) + 8
C INSERT SECTION 2 DATA
CALL SBYTES(KBUFR,ISEC2D,KARY(3),8,0,ISEC2B)
KARY(3) = KARY(3) + (ISEC2B * 8)
IF (MOD(ISEC2B,2).NE.0) THEN
CALL SBYTE (KBUFR,0,KARY(3),8)
KARY(3) = KARY(3) + 8
END IF
ELSE
KARY(22) = 0
END IF
C =====================================
C MAKE PREPARATIONS FOR SECTION 3 DESCRIPTORS
C =====================================
KARY(23) = 7 + NEWNR*2 + 1
C SECTION 3 SIZE
CALL SBYTE (KBUFR,KARY(23),KARY(3),24)
KARY(3) = KARY(3) + 24
C RESERVED BYTE
CALL SBYTE (KBUFR,0,KARY(3),8)
KARY(3) = KARY(3) + 8
C NUMBER OF SUBSETS
CALL SBYTE (KBUFR,ISECT3(1),KARY(3),16)
KARY(3) = KARY(3) + 16
C SET OBSERVED DATA SWITCH
CALL SBYTE (KBUFR,ISECT3(2),KARY(3),1)
KARY(3) = KARY(3) + 1
C SET COMPRESSED DATA SWITCH
CALL SBYTE (KBUFR,ISECT3(3),KARY(3),1)
KARY(3) = KARY(3) + 1
CALL SBYTE (KBUFR,0,KARY(3),6)
KARY(3) = KARY(3) + 6
C =====================================
C DESCRIPTORS - SECTION 3
C =====================================
DO 37 KH = 1, NEWNR
C PRINT *,'INSERTING',JDESC(1,KH),' INTO SECTION 3'
CALL SBYTE (KBUFR,JDESC(1,KH),KARY(3),16)
KARY(3) = KARY(3) + 16
37 CONTINUE
C FILL TO TWO BYTE BOUNDARY
CALL SBYTE (KBUFR,0,KARY(3),8)
KARY(3) = KARY(3) + 8
C PRINT *,'SECTION 3'
C =====================================
C INITIALIZE FOR - SECTION 4
C =====================================
C SAVE POINTER TO COUNT POSITION
C PRINT *,'START OF SECTION 4',KARY(3)
KARY(5) = KARY(3)
KARY(3) = KARY(3) + 24
CALL SBYTE (KBUFR,0,KARY(3),8)
KARY(3) = KARY(3) + 8
C SKIP TO FIRST DATA POSITION
C =====================================
C BIT PATTERNS - SECTION 4
C =====================================
KEND4 = IBFSIZ * 8 - 32
C PACK ALL DATA INTO BUFR MESSAGE
C
IF (ISECT3(3).EQ.0) THEN
C **********************************************
C * *
C * PROCESS AS NON-COMPRESSED MESSAGE *
C * *
C **********************************************
CALL FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
* LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
* KSEQ,KNUM,KLIST,IBFSIZ,
* KDATA,KBUFR,IERRTN,INDEXB)
IF (IERRTN.NE.0) THEN
IF (IERRTN.EQ.1) GO TO 5500
RETURN
END IF
ELSE
C **********************************************
C * *
C * PROCESS AS COMPRESSED MESSAGE *
C * *
C **********************************************
KARY(18) = 0
C MUST LOOK AT EVERY DESCRIPTOR IN KDESC
KARY(11) = 1
3000 CONTINUE
IF (KARY(11).GT.NRDESC) THEN
GO TO 5200
ELSE
C DO 5000 JK = 1, NRDESC
C RE-ENTRY POINT FOR INSERTION OF
C REPLICATION OR SEQUENCES
4000 CONTINUE
C ISOLATE TABLE
KFUNC = KDESC(1,KARY(11)) / 16384
C ISOLATE CLASS
KCLASS = MOD(KDESC(1,KARY(11)),16384) / 256
KSEG = MOD(KDESC(1,KARY(11)),256)
KARY(2) = KARY(11) + KARY(18)
IF (KFUNC.EQ.1) THEN
C DELAYED REPLICATION NOT ALLOWED
C IN COMPRESSED MESSAGE
IF (KSEG.EQ.0) THEN
IERRTN = 8
RETURN
END IF
C REPLICATION DESCRIPTOR
CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
* KDATA,LL,KDESC,NRDESC,IERRTN)
C GO TO 4000
ELSE IF (KFUNC.EQ.2) THEN
CALL FI8502(*4000,KBUFR,KCLASS,KSEG,
* KDESC,NRDESC,I,ISTEP,
* KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 5000
ELSE IF (KFUNC.EQ.3) THEN
CALL FI8503(KARY(11),KDESC,NRDESC,
* ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 4000
END IF
C FALL THRU WITH ELEMENT DESCRIPTOR
C POINT TO CORRECT TABLE B ENTRY
L = INDEXB(KDESC(1,KARY(11)))
IF (L.LT.0) THEN
IERRTN = 2
C PRINT *,'W3FI85 - IERRTN = 2'
RETURN
END IF
C
IF (AUNITS(L)(1:9).EQ.CCITT) THEN
TEXT = .TRUE.
ELSE
TEXT = .FALSE.
END IF
KARY(7) = KWIDTH(L)
C
IF (TEXT) THEN
C PROCESS TEXT DATA
KBZ = KARY(3) + (ISECT3(1) + 1) * KARY(7) + 6
IF (KBZ.GT.KEND4) THEN
GO TO 5500
END IF
C NBINC IS NUMBER OF CHARS
NBINC = KARY(7) / 8
C LOWEST = 0
CALL SBYTES(KBUFR,ZEROS,KARY(3),8,0,NBINC)
KARY(3) = KARY(3) + KARY(7)
CALL SBYTE (KBUFR,NBINC,KARY(3),6)
KARY(3) = KARY(3) + 6
C HOW MANY FULL WORDS
NKPASS = KARY(7) / 32
C HOW MANY BYTES IN PARTIAL WORD
KREM = MOD(KARY(7),32)
C KSKIP = KARY(7) - 32
DO 4080 NSS = 1, ISECT3(1)
C POINT TO TEXT FOR THIS SUBSET
KARY(2) = KARY(11) + KARY(18)
IF (NKPASS.GE.1) THEN
C PROCESS TEXT IN A SUBSET
DO 4070 NPP = 1, NKPASS
C PROCESS FULL WORDS
IF (ISECT3(10).EQ.1) THEN
CALL W3AI38 (KDATA(NSS,KARY(2)),4)
END IF
CALL SBYTE (KBUFR,KDATA(NSS,KARY(2)),
* KARY(3),32)
KARY(3) = KARY(3) + 32
C POINT TO NEXT DATA WORD FOR MORE TEXT
KARY(2) = KARY(2) + 1
4070 CONTINUE
END IF
C PROCESS PARTIALS - LESS THAN 4 BYTES
IF (KREM.GT.0) THEN
IF (ISECT3(10).EQ.1) THEN
CALL W3AI38 (KDATA(NSS,KARY(2)),4)
END IF
CALL SBYTE (KBUFR,KDATA(NSS,KARY(2)),
* KARY(3),KREM)
KARY(3) = KARY(3) + KREM
END IF
4080 CONTINUE
C ADJUST EXTRA WORD COUNT
IF (KREM.GT.0) THEN
KARY(18) = KARY(18) + NKPASS
ELSE
KARY(18) = KARY(18) + NKPASS - 1
END IF
C -------------------------------------------------------------
GO TO 5000
ELSE
KARY(2) = KARY(11) + KARY(18)
KARY(7) = KWIDTH(L) + KARY(26)
C
C NON TEXT/NUMERIC DATA
C
C PROCESS ASSOCIATED FIELD DATA
IF (KARY(27).GT.0.AND.KDESC(1,KARY(11)).NE.7957) THEN
DUPFLG = .TRUE.
DO 4130 J = 2, ISECT3(1)
IF (KDATA(J,KARY(2)).NE.KDATA(1,KARY(2)))THEN
DUPFLG = .FALSE.
GO TO 4131
END IF
4130 CONTINUE
4131 CONTINUE
IF (DUPFLG) THEN
C ALL VALUES ARE EQUAL
KBZ = KARY(3) + KARY(7) + 6
IF (KBZ.GT.KEND4) THEN
GO TO 5500
END IF
NBINC = 0
C ENTER COMMON VALUE
IF (KDATA(1,KARY(2)).EQ.MISG) THEN
CALL SBYTE(KBUFR,IBITS(KARY(7)),
* KARY(3),KARY(27))
ELSE
CALL SBYTE(KBUFR,KDATA(1,KARY(2)),
* KARY(3),KARY(27))
END IF
KARY(3) = KARY(3) + KARY(27)
C ENTER NBINC
CALL SBYTE (KBUFR,NBINC,KARY(3),6)
KARY(3) = KARY(3) + 6
ELSE
C MIX OF MISSING AND VALUES
C GET LARGEST DIFFERENCE VALUE
MSGFLG = .FALSE.
DO 4132 J = 1, ISECT3(7)
IF (KDATA(J,KARY(2)).EQ.MISG) THEN
MSGFLG = .TRUE.
GO TO 4133
END IF
4132 CONTINUE
4133 CONTINUE
DO 4134 J = 1, ISECT3(7)
IF (KDATA(J,KARY(2)).LT.IBITS(KARY(27))
* .AND.KDATA(J,KARY(2)).GE.0.AND.
* KDATA(J,KARY(2)).NE.MISG) THEN
LOWEST = KDATA(J,KARY(2))
MAXVAL = KDATA(J,KARY(2))
JSTART = J + 1
GO TO 4135
END IF
4134 CONTINUE
4135 CONTINUE
DO 4136 J = JSTART, ISECT3(7)
IF (KDATA(J,KARY(2)).NE.MISG) THEN
IF (KDATA(J,KARY(2)).LT.LOWEST) THEN
LOWEST = KDATA(J,KARY(2))
ELSE IF(KDATA(J,KARY(2)).GT.MAXVAL)THEN
MAXVAL = KDATA(J,KARY(2))
END IF
END IF
4136 CONTINUE
MXDIFF = MAXVAL - LOWEST
C FIND NBINC
MXBITS = KARY(27)
DO 4142 LJ = 1, MXBITS
NBINC = LJ
IF (MXDIFF.LT.IBITS(LJ)) THEN
GO TO 4143
END IF
4142 CONTINUE
4143 CONTINUE
KBZ = KARY(3) + MXBITS + 6 + ISECT3(1) * NBINC
IF (KBZ.GT.KEND4) THEN
GO TO 5500
END IF
IF (NBINC.GT.MXBITS) THEN
IERRTN = 3
RETURN
END IF
C ENTER LOWEST
CALL SBYTE(KBUFR,LOWEST,KARY(3),MXBITS)
KARY(3) = KARY(3) + MXBITS
CALL SBYTE(KBUFR,NBINC,KARY(3),6)
KARY(3) = KARY(3) + 6
C GET DIFFERENCE VALUES
IF (MSGFLG) THEN
DO 4144 M = 1, ISECT3(1)
IF (KDATA(M,KARY(2)).EQ.MISG) THEN
KT(M) = IBITS(NBINC)
ELSE
KT(M) = KDATA(M,KARY(2)) - LOWEST
END IF
4144 CONTINUE
ELSE
DO 4146 M = 1, ISECT3(1)
KT(M) = KDATA(M,KARY(2)) - LOWEST
4146 CONTINUE
END IF
C ENTER DATA VALUES
CALL SBYTES(KBUFR,KT,KARY(3),NBINC,
* 0,ISECT3(1))
KARY(3) = KARY(3) + ISECT3(1) * NBINC
END IF
KARY(18) = KARY(18) + 1
END IF
C ---------------------------------------------------
C STANDARD DATA
C ---------------------------------------------------
KARY(2) = KARY(11) + KARY(18)
MXBITS = KARY(7) + KARY(26)
DUPFLG = .TRUE.
DO 4030 J = 2, ISECT3(7)
IF (KDATA(J,KARY(2)).NE.KDATA(1,KARY(2))) THEN
DUPFLG = .FALSE.
GO TO 4031
END IF
4030 CONTINUE
4031 CONTINUE
IF (DUPFLG) THEN
C ALL VALUES ARE EQUAL
KBZ = KARY(3) + KARY(7) + 6
IF (KBZ.GT.KEND4) THEN
GO TO 5500
END IF
NBINC = 0
C ENTER COMMON VALUE
IF (KDATA(1,KARY(2)).EQ.MISG) THEN
CALL SBYTE(KBUFR,IBITS(MXBITS),
* KARY(3),MXBITS)
ELSE
CALL SBYTE(KBUFR,KDATA(1,KARY(2)),
* KARY(3),MXBITS)
END IF
KARY(3) = KARY(3) + KARY(7)
C ENTER NBINC
CALL SBYTE (KBUFR,NBINC,KARY(3),6)
KARY(3) = KARY(3) + 6
ELSE
C MIX OF MISSING AND VALUES
C GET LARGEST DIFFERENCE VALUE
MSGFLG = .FALSE.
DO 4032 J = 1, ISECT3(7)
IF (KDATA(J,KARY(2)).EQ.MISG) THEN
MSGFLG = .TRUE.
GO TO 4033
END IF
4032 CONTINUE
4033 CONTINUE
DO 4034 J = 1, ISECT3(7)
IF (KDATA(J,KARY(2)).NE.MISG) THEN
LOWEST = KDATA(J,KARY(2))
MAXVAL = KDATA(J,KARY(2))
C PRINT *,' '
C PRINT *,'START VALUES',LOWEST,MAXVAL,
C * 'J=',J,' KARY(2)=',KARY(2)
GO TO 4035
END IF
4034 CONTINUE
4035 CONTINUE
DO 4036 J = 1, ISECT3(1)
IF (KDATA(J,KARY(2)).NE.MISG) THEN
IF (KDATA(J,KARY(2)).LT.LOWEST) THEN
LOWEST = KDATA(J,KARY(2))
C PRINT *,'NEW LOWEST=',LOWEST,J
ELSE IF (KDATA(J,KARY(2)).GT.MAXVAL) THEN
MAXVAL = KDATA(J,KARY(2))
C PRINT *,'NEW MAXVAL=',MAXVAL,J
END IF
END IF
4036 CONTINUE
MXDIFF = MAXVAL - LOWEST
C FIND NBINC
DO 4042 LJ = 1, MXBITS
NBINC = LJ
IF (MXDIFF.LT.IBITS(LJ)) GO TO 4043
IF (NBINC.EQ.MXBITS) GO TO 4043
4042 CONTINUE
4043 CONTINUE
KBZ = KARY(3) + MXBITS + 38 + ISECT3(1) * NBINC
IF (KBZ.GT.KEND4) THEN
GO TO 5500
END IF
C PRINT 4444,KARY(11),KDESC(1,KARY(11)),LOWEST,
C * MAXVAL,MXDIFF,KARY(7),NBINC,ISECT3(1),ISECT3(7)
C4444 FORMAT(9(1X,I8))
C ENTER LOWEST
C ADJUST WITH REFERENCE VALUE
IF (KRFVSW(L).EQ.0) THEN
JRV = KRFVAL(L)
ELSE
JRV = NEWRFV(L)
END IF
LVAL = LOWEST - JRV
CALL SBYTE(KBUFR,LVAL,KARY(3),MXBITS)
KARY(3) = KARY(3) + MXBITS
IF (NBINC.GT.MXBITS) THEN
IERRTN = 3
RETURN
END IF
CALL SBYTE(KBUFR,NBINC,KARY(3),6)
KARY(3) = KARY(3) + 6
C GET DIFFERENCE VALUES
IF (MSGFLG) THEN
DO 4044 M = 1, ISECT3(1)
IF (KDATA(M,KARY(2)).EQ.MISG) THEN
KT(M) = IBITS(NBINC)
ELSE
KT(M) = KDATA(M,KARY(2)) - LOWEST
END IF
4044 CONTINUE
ELSE
DO 4046 M = 1, ISECT3(1)
KT(M) = KDATA(M,KARY(2)) - LOWEST
4046 CONTINUE
END IF
C ENTER DATA VALUES
CALL SBYTES(KBUFR,KT,KARY(3),NBINC,
* 0,ISECT3(1))
KARY(3) = KARY(3) + ISECT3(1) * NBINC
END IF
GO TO 5000
END IF
C -------------------------------------------------------------
5000 CONTINUE
KARY(11) = KARY(11) + 1
GO TO 3000
ENDIF
5200 CONTINUE
END IF
ISECT3(6) = 0
GO TO 6000
5500 CONTINUE
C THE SEGMENT OF CODE BETWEEN STATEMENTS
C 5500-6000 ARE ACTIVATED IF AND WHEN THE
C MAXIMUM MESSAGE SIZE HAS BEEN EXCEEDED
C
C ARE WE REDUCING IF OVERSIZED ???
IF (ISECT3(4).NE.0) THEN
C INCREMENT REDUCTION COUNT
ISECT3(6) = ISECT3(6) + ISECT3(5)
C REDUCE NUMBER TO INCLUDE
ISECT3(7) = ISECT3(1) - ISECT3(5)
ISECT3(1) = ISECT3(7)
PRINT *,'REDUCED BY ',ISECT3(5),' ON THIS PASS'
GO TO 5
ELSE
IERRTN = 1
RETURN
END IF
6000 CONTINUE
C ---------------------------------------------------------------
C FILL IN SECTION 4 OCTET COUNT
NBUFR = MOD((KARY(3) - KARY(5)),16)
C MAY BE NECESSARY TO ADJUST COUNT
IF (NBUFR.NE.0) THEN
KARY(3) = KARY(3) + 16 - NBUFR
END IF
KARY(24) = (KARY(3) - KARY(5)) / 8
CALL SBYTE (KBUFR,KARY(24),KARY(5),24)
C PRINT *,'SECTION 4'
C =====================================
C ENDING KEY '7777' - SECTION 5
C =====================================
KARY(25) = 4
NBUFR = 926365495
CALL SBYTE (KBUFR,NBUFR,KARY(3),32)
KARY(3) = KARY(3) + 32
C CONSTRUCT TOTAL BYTE COUNT FOR SECTION 0
ITOTAL = KARY(3) / 8
CALL SBYTE (KBUFR,ITOTAL,32,24)
KARY(30) = ITOTAL
C WRITE (6,8601) ITOTAL
8601 FORMAT (1X,22HTHIS MESSAGE CONTAINS ,I10,6H BYTES)
C =======================================
C KBUFR CONTAINS A COMPLETED MESSAGE
IF (ISECT3(4).NE.0.AND.ISECT3(5).NE.0) THEN
C ADJUST KDATA ARRAY
NR = MXRPTS - ISECT3(1)
ISECT3(7) = ISECT3(7) + 1
DO 7500 I = 1, NR
DO 7000 J = 1, NRDESC
KDATA(I,J) = KDATA(ISECT3(7),J)
7000 CONTINUE
ISECT3(7) = ISECT3(7) + 1
7500 CONTINUE
KARY(14) = NR
ELSE
ISECT3(7) = ISECT3(1)
END IF
C =======================================
IERRTN = 0
9000 CONTINUE
RETURN
END
SUBROUTINE FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
* KDATA,NSUB,KDESC,NRDESC,IERRTN)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8501 PERFORM REPLICATION OF DESCRIPTORS
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: HAVE ENCOUNTERED A REPLICATION DESCRIPTOR . IT MAY INCLUDE
C DELAYED REPLICATION OR NOT. THAT DECISION SHOULD HAVE BEEN
C MADE PRIOR TO CALLING THIS ROUTINE.
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C 94-03-25 HOPPA ADDED LINE TO INITIALIZE NXTPTR TO CORRECT
C AN ERROR IN THE STANDARD REPLICATION.
C 94-03-28 HOPPA CORRECTED AN ERROR IN THE STANDARD REPLICATION
C THAT WAS ADDING EXTRA ZEROS TO THE BUFR
C MESSAGE AFTER THE REPLICATED DATA.
C 94-03-31 HOPPA ADDED THE SUBSET NUMBER TO THE PARAMETER LIST.
C CORRECTED THE EQUATION FOR THE NUMBER OF
C REPLICATIONS WITH DELAYED REPLICATION.
C (ISTART AND K DON'T EXIST)
C 94-04-19 HOPPA SWITCHED THE VARIABLES NEXT AND NXTPRT
C 94-04-20 HOPPA ADDED THE KDATA PARAMETER COUNTER TO THE
C PARAMETER LIST. IN THE ASSIGNMENT OF NREPS
C WHEN HAVE DELAYED REPLICATION, CHANGED INDEX
C IN KDATA FROM N TO K.
C 94-04-29 HOPPA - REMOVED N AND K FROM THE INPUT LIST
C - CHANGED N TO KARY(11) AND K TO KARY(2)
C
C USAGE: CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
C * KDATA,N,NSUB,KDESC,NRDESC,IERRTN)
C INPUT ARGUMENT LIST:
C ISTEP -
C KCLASS -
C KKSEG -
C IDATA -
C RDATA -
C KDATA -
C N - CURRENT POSITION IN DESCRIPTOR LIST
C NSUB - CURRENT SUBSET
C KDESC - LIST OF DESCRIPTORS
C NRDESC - NUMBER OF DESCRIPTORS IN KDESC
C
C OUTPUT ARGUMENT LIST:
C N - CURRENT POSITION IN DESCRIPTOR LIST
C KDESC - MODIFIED LIST OF DESCRIPTORS
C NRDESC - NEW NUMBER OF DESCRIPTORS IN KDESC
C IERRTN - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
REAL RDATA(*)
C
INTEGER IDATA(*),NREPS,KARY(*)
INTEGER KCLASS,KSEG
INTEGER KDESC(3,*),NRDESC,KDATA(500,*)
INTEGER IERRTN
INTEGER ITAIL(1600)
INTEGER IHOLD(1600),ISTEP
C
SAVE
C
C TEST KFUNC FOR DESCRIPTOR TYPE
C DO REPLICATION
C ****************************************************************
IERRTN = 0
C REPLICATION DESCRIPTOR
C STANDARD REPLICATION WILL SIMPLY
C BE PROCESSED FROM ITS DESCRIPTOR
C PARTS
C
C DELAYED REPLICATION DESCRIPTOR
C MUST BE FOLLOWED BY ONE OF THE
C DESCRIPTORS FOR A DELAYED
C REPLICATION FACTOR
C 0 31 001 (7937 DECIMAL)
C 0 31 002 (7938 DECIMAL)
C 0 31 011 (7947 DECIMAL)
C 0 31 012 (7948 DECIMAL)
IF (KSEG.NE.0) THEN
C HAVE NUMBER OF REPLICATIONS AS KSEG
NREPS = KSEG
IPUT = KARY(11)
NEXT = IPUT + 1
NXTPTR = IPUT + 1 + KCLASS
ELSE IF (KSEG.EQ.0) THEN
IF (KDESC(1,KARY(11)+1).EQ.7937.OR.
* KDESC(1,KARY(11)+1).EQ.7938.OR.
* KDESC(1,KARY(11)+1).EQ.7947.OR.
* KDESC(1,KARY(11)+1).EQ.7948) THEN
C PRINT *,'HAVE DELAYED REPLICATION'
KARY(4) = 1
C MOVE REPLICATION DEFINITION
KDESC(1,KARY(11)) = KDESC(1,KARY(11)+1)
C MUST DETERMINE HOW MANY REPLICATIONS
IF (ISTEP.EQ.1) THEN
NREPS = IDATA(KARY(11))
ELSE IF (ISTEP.EQ.2) THEN
NREPS = RDATA(KARY(11))
ELSE
NREPS = KDATA(NSUB,KARY(2))
END IF
IPUT = KARY(11) + 1
NXTPTR = IPUT + KCLASS + 1
NEXT = IPUT + 1
C POINT TO REPLICATION DESCRIPTOR
END IF
ELSE
IERRTN = 10
RETURN
END IF
C EXTRACT DESCRIPTORS TO BE REPLICATED
C IF NREPS = 0, THIS LIST OF DESCRIPTORS IS NOT TO
C BE USED IN DEFINING THE DATA,
C OTHERWISE
C IT WILL BE USED TO DEFINE THE DATA
IF (NREPS.NE.0) THEN
DO 1000 IJ = 1, KCLASS
IHOLD(IJ) = KDESC(1,NEXT)
NEXT = NEXT + 1
1000 CONTINUE
C SKIP THE NUMBER OF DESCRIPTORS DEFINED BY KCLASS
END IF
C SAVE OFF TAIL OF DESC STREAM
C START AT FIRST POSITION OF TAIL
IGOT = 0
DO 1100 IJ = NXTPTR, NRDESC
IGOT = IGOT + 1
ITAIL(IGOT) = KDESC(1,IJ)
1100 CONTINUE
C INSERT ALL REPLICATED DESC'S
IF (NREPS.NE.0) THEN
DO 1300 KR = 1, NREPS
DO 1200 KD = 1, KCLASS
KDESC(1,IPUT) = IHOLD(KD)
IPUT = IPUT + 1
1200 CONTINUE
1300 CONTINUE
END IF
C RESTORE TAIL
DO 1400 ITL = 1, IGOT
KDESC(1,IPUT) = ITAIL(ITL)
IPUT = IPUT + 1
1400 CONTINUE
C
C RESET NUMBER OF DESCRIPTORS IN KDESC
NRDESC = IPUT - 1
C ****************************************************************
RETURN
END
SUBROUTINE FI8502(*,KBUFR,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP,
* KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8502 PROCESS AN OPERATOR DESCRIPTOR
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: HAVE ENCOUNTERED AN OPERATOR DESCRIPTOR
C
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C 94-04-15 J. HOPPA - ADDED KBUFR TO INPUT PARAMETER LIST.
C - ADDED BLOCK OF DATA TO CORRECTLY USE SBYTE
C WHEN WRITING A 205YYY DESCRIPTOR TO THE
C BUFR MESSAGE.
C THE PREVIOUS WAY DIDN'T WORK BECAUSE KDATA
C WAS GETTING INCREMETED BY THE KSUB VALUE,
C NOT THE PARAM VALUE.
C 94-04-29 J. HOPPA - CHANGED K TO KARY(2)
C - REMOVED A LINE THAT BECAME OBSOLETE WITH
C ABOVE CHANGE
C 94-05-18 J. HOPPA - ADDED A KARY(2) INCREMENT
C
C USAGE: CALL FI8502(*,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP,
C * KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
C INPUT ARGUMENT LIST:
C KCLASS -
C KSEG -
C KDESC -
C NRDESC -
C I -
C ISTEP -
C KARY -
C
C OUTPUT ARGUMENT LIST:
C KDESC -
C NRDESC -
C KARY -
C IERRTN - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
INTEGER KCLASS,KSEG,ZEROES(255)
INTEGER KRFVSW(*),NEWRFV(*),LDESC(*)
INTEGER I,KDESC(3,*),KDATA(500,*),ISECT3(*)
INTEGER NRDESC
INTEGER KARY(*)
INTEGER IERRTN
INTEGER NLEFT
C
SAVE
C
DATA ZEROES/255*0/
C
C ****************************************************************
IERRTN = 0
C OPERATOR DESCRIPTOR
IF (KCLASS.EQ.1) THEN
C BITS ADDED TO DESCRIPTOR WIDTH
IF (ISTEP.EQ.3) THEN
IF (KSEG.NE.0) THEN
KARY(26) = KSEG - 128
ELSE
KARY(26) = 0
END IF
END IF
ELSE IF (KCLASS.EQ.2) THEN
C NEW SCALE VALUE
IF (ISTEP.EQ.3) THEN
IF (KSEG.EQ.0) THEN
KARY(9) = 0
ELSE
KARY(9) = KSEG - 128
END IF
END IF
ELSE IF (KCLASS.EQ.3) THEN
C CHANGE REFERENCE VALUE
C MUST ACCEPT INTO OUTPUT THE
C REFERENCE VALUE CHANGE AND ACTIVATE
C THE CHANGE WHILE PROCESSING
IF (ISTEP.EQ.3) THEN
C HAVE OPERATOR DESCRIPTOR FOR REFERENCE VALUES
IF (KSEG.EQ.0) THEN
DO 100 IQ = 1, ISECT3(8)
C RESET ALL NEW REFERENCE VALUES
KRFVSW(IQ) = 0
100 CONTINUE
END IF
200 CONTINUE
C GET NEXT DESCRIPTOR
KARY(11) = KARY(11) + 1
IF (KDESC(1,KARY(11)).GT.16383) THEN
C NOT AN ELEMENT DESCRIPTOR
NFUNC = KDESC(1,KARY(11)) / 16384
IF (NFUNC.EQ.1.OR.NFUNC.EQ.3) THEN
IERRTN = 20
PRINT *,'INCORRECT ENTRY OF REPLICATION OR ',
* 'SEQUENCE DESCRIPTOR IN LIST OF ',
* 'REFERENCE VALUE CHANGES'
RETURN
END IF
NCLASS = (KDESC(1,KARY(11)) - NFUNC*16384) / 256
IF (NCLASS.EQ.3) THEN
NSEG = MOD(KDESC(1,KARY(11)),256)
IF (NSEG.EQ.255) THEN
RETURN
END IF
END IF
IERRTN = 21
PRINT *,'INCORRECT OPERATOR DESCRIPTOR ENTRY ',
* 'IN LIST OF REFERENCE VALUE CHANGES'
RETURN
END IF
C ELEMENT DESCRIPTOR W/NEW REFERENCE VALUE
C FIND MATCH FOR CURRENT DESCRIPTOR
IQ = INDEXB(KDESC(1,KARY(11)))
IF (IQ.LT.1) THEN
IERRTN = 22
PRINT *,'ATTEMPTING TO ENTER NEW REFERENCE VALUE ',
* 'INTO TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN ',
* 'CURRENT MODIFIED TABLE B'
RETURN
END IF
END IF
ELSE IF (KCLASS.EQ.4) THEN
C SET/RESET ASSOCIATED FIELD WIDTH
IF (ISTEP.EQ.3) THEN
KARY(27) = KSEG
END IF
ELSE IF (KCLASS.EQ.5) THEN
C SET TO PROCESS TEXT/ASCII DATA
C SET TO TEXT
C PROCESS TEXT
KARY(2) = KARY(11) + KARY(18)
IF (ISTEP.EQ.3) THEN
C KSEG TELLS HOW MANY BYTES EACH ITERATION
IF (MOD(KSEG,4).NE.0) THEN
ITER = KSEG / 4 + 1
ELSE
ITER = KSEG / 4
END IF
C POINT AT CORRECT KDATA WORD
IF (ISECT3(3).NE.0) THEN
C COMPRESSED
C ---------------------------------------------------
CALL SBYTES(KBUFR,ZEROES,KARY(3),32,0,ITER)
KARY(3) = KARY(3) + KSEG * 8
C
CALL SBYTE (KBUFR,KSEG*8,KARY(3),6)
KARY(3) = KARY(3) + 6
C TEXT ENTRY BY SUBSET
DO 2000 M = 1, ISECT3(1)
JAY = KARY(3)
C NUMBER OF SUBSETS
DO 1950 KL = 1, ITER
C NUMBER OF WORDS
KK = KARY(2) + KL - 1
IF (ISECT3(10).EQ.1) THEN
CALL W3AI38(KDATA(M,KK),4)
END IF
CALL SBYTE (KBUFR,KDATA(M,KK),JAY,32)
JAY = JAY + 32
1950 CONTINUE
KARY(3) = KARY(3) + KSEG * 8
2000 CONTINUE
C ---------------------------------------------------
ELSE
C NOT COMPRESSED
C CALL SBYTE FOR EACH KDATA VALUE (4 CHARACTERS PER VALUE).
C AN ADDITIONAL CALL IS DONE IF HAVE A VALUE WITH LESS THAN
C 4 CHARACTERS.
NBIT = 32
NLEFT = MOD(KSEG,4)
DO 3000 J=KARY(2),ITER+KARY(2)-1
IF((J.EQ.(ITER+KARY(2)-1)).AND.(NLEFT.NE.0))THEN
NBIT = 8 * NLEFT
ENDIF
IF (ISECT3(10).NE.0) THEN
CALL W3AI38 (KDATA(I,J),4)
END IF
CALL SBYTE(KBUFR,KDATA(I,J),KARY(3),NBIT)
KARY(3) = KARY(3) + NBIT
3000 CONTINUE
C ADJUST FOR EXTRA WORDS
KARY(18) = KARY(18) + ITER - 1
END IF
KARY(2) = KARY(2) + ITER
END IF
ELSE IF (KCLASS.EQ.6) THEN
C SET TO SKIP PROCESSING OF NEXT DESCRIPTOR
C IF IT IS NOT IN BUFR TABLE B
C DURING THE ENCODING PROCESS, THIS HAS NO MEANING
C ELIMINATE IN PROCESSING
C MOVE DESCRIPTOR LIST UP ONE POSITION AND RESTART
C PROCESSING AT SAME LOCATION.
KM = I - 1
DO 9000 KL = I+1, NRDESC
KM = KM + 1
KDESC(1,KM) = KDESC(1,KL)
9000 CONTINUE
NRDESC = KM
RETURN 1
END IF
C ****************************************************************
RETURN
END
SUBROUTINE FI8503(I,KDESC,NRDESC,
* ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8503 EXPAND SEQUENCE DESCRIPTOR
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: HAVE ENCOUNTERED A SEQUENCE DESCRIPTOR. MUST PERFORM
C PROPER REPLACMENT OF DESCRIPTORS IN LINE.
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8503(I,KDESC,NRDESC,
C * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
C INPUT ARGUMENT LIST:
C I - CURRENT POSITION IN DESCRIPTOR LIST
C KDESC - LIST OF DESCRIPTORS
C NRDESC - NUMBER OF DESCRIPTORS IN KDESC
C IUNITD -
C KSEQ -
C KNUM -
C KLIST -
C
C OUTPUT ARGUMENT LIST:
C I - CURRENT POSITION IN DESCRIPTOR LIST
C KDESC - MODIFIED LIST OF DESCRIPTORS
C NRDESC - NEW NUMBER OF DESCRIPTORS IN KDESC
C IERRTN - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
INTEGER I
INTEGER KDESC(3,*)
INTEGER NRDESC
INTEGER ISECT3(*)
INTEGER IUNITD
INTEGER KSEQ(*)
INTEGER KNUM(*)
INTEGER KLIST(300,*)
INTEGER IERRTN
INTEGER ITAIL(1600)
C INTEGER IHOLD(200)
C
SAVE
C
C ****************************************************************
IERRTN = 0
C READ IN TABLE D IF NEEDED
IF (ISECT3(9).EQ.0) THEN
CALL FI8513 (IUNITD,ISECT3,KSEQ,
* KNUM,KLIST,IERRTN)
IF (IERRTN.NE.0) THEN
C PRINT *,'EXIT FI8503A'
RETURN
END IF
END IF
C HAVE TABLE D
C
C FIND MATCHING SEQUENCE DESCRIPTOR
DO 100 L = 1, ISECT3(9)
IF (KDESC(1,I).EQ.KSEQ(L)) THEN
C JEN - DELETE NEXT PRINT LINE
C PRINT *,'FOUND ',KDESC(1,I)
C HAVE A MATCH
GO TO 200
END IF
100 CONTINUE
IERRTN = 12
RETURN
200 CONTINUE
C REPLACE SEQUENCE DESCRIPTOR WITH IN LINE SEQUENCE
IPUT = I
C SAVE TAIL
ISTART = I + 1
KK = 0
DO 400 IJ = ISTART, NRDESC
KK = KK + 1
ITAIL(KK) = KDESC(1,IJ)
400 CONTINUE
C INSERT SEQUENCE OF DESCRIPTORS AT
C CURRENT LOCATION
KL = 0
DO 600 KQ = 1, KNUM(L)
KDESC(1,IPUT) = KLIST(L,KQ)
IPUT = IPUT + 1
600 CONTINUE
C RESTORE TAIL
DO 800 KL = 1, KK
KDESC(1,IPUT) = ITAIL(KL)
IPUT = IPUT + 1
800 CONTINUE
C RESET NUMBER OF DESCRIPTORS IN KDESC
NRDESC = IPUT - 1
C JEN - DELETE NEXT PRINT LINE
C PRINT *,' NRDESC IS ',NRDESC
C RESET CURRENT POSITION & RETURN
RETURN
END
SUBROUTINE FI8505(MIF,MDESC,NR,IERRTN)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8505 CONVERT DESCRIPTORS FXY TO DECIMAL
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT DECIMAL DESCRIPTOR VALUES FROM F X AND Y SEGMENTS
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8505(MIF,MDESC,NR,IERRTN)
C INPUT ARGUMENT LIST:
C MIF - INPUT FLAG
C MDESC - LIST OF DESCRIPTORS IN F X Y FORM
C NR - NUMBER OF DESCRIPTORS IN MDESC
C
C OUTPUT ARGUMENT LIST:
C MDESC - LIST OF DESCRIPTORS IN DECIMAL FORM
C IERRTN - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
INTEGER MDESC(3,*), NR
C
SAVE
C
IF (NR.EQ.0) THEN
IERRTN = 14
RETURN
END IF
C
DO 100 I = 1, NR
MDESC(1,I) = MDESC(1,I) * 16384 + MDESC(2,I) * 256
* + MDESC(3,I)
C JEN - DELETE NEXT PRINT LINE
C PRINT *,MDESC(2,I),MDESC(3,I),' BECOMES ',MDESC(1,I)
100 CONTINUE
MIF = 1
RETURN
END
SUBROUTINE FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
* LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
* KSEQ,KNUM,KLIST,IBFSIZ,
* KDATA,KBUFR,IERRTN,INDEXB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8506 PROCESS DATA IN NON-COMPRESSED FORMAT
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: PROCESS DATA INTO NON-COMPRESSED FORMAT FOR INCLUSION INTO
C SECTION 4 OF THE BUFR MESSAGE
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C 94-03-24 J. HOPPA - CHANGED THE INNER LOOP FROM A DO LOOP TO A
C GOTO LOOP SO NRDESC ISN'T A SET VALUE.
C - CORRECTED A VALUE IN THE CALL TO FI8503.
C 94-03-31 J. HOPPA - CORRECTED AN ERROR IN SENDING THE SUBSET
C NUMBER RATHER THAN THE DESCRIPTOR NUMBER
C TO SUBROUTINE FI8501.
C - ADDED THE SUBSET NUMBER TO THE FI8501
C PARAMETER LIST.
C 94-04015 J. HOPPA - ADDED LINE TO KEEP THE PARAMETER POINTER
C KARY(2) UP TO DATE. THIS VARIABLE IS USED
C IN SUBROUTINE FI8502.
C - ADDED KBUFR TO THE PARAMETER LIST IN THE CALL
C TO SUBROUTINE FI8502.
C - CORRECTED AN INFINITE LOOP WHEN HAVE AN
C OPERATOR DESCRIPTOR THAT WAS CAUSED BY
C A CORRECTION MADE 94-03-24
C 94-04-20 J. HOPPA - ADDED K TO CALL TO SUBROUTINE W3FI01
C 94-04-29 J. HOPPA - CHANGED N TO KARY(11) AND K TO KARY(2)
C - REMOVED K AND N FROM THE CALL TO FI8501
C 94-05-03 J. HOPPA - ADDED AN INCREMENT TO KARY(11) TO PREVENT
C AND INFINITE LOOP WHEN HAVE A MISSING VALUE
C 94-05-18 J. HOPPA - CHANGED SO INCREMENTS KARY(2) AFTER EACH
C CALL TO SBYTE AND DELETED
C KARY(2) = KARY(11) + KARY(18)
C
C
C USAGE CALL FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
C * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
C * KSEQ,KNUM,KLIST,
C * KDATA,KBUFR,IERRTN,INDEXB)
C
C INPUT ARGUMENT LIST:
C ISTEP -
C ISECT3 -
C KARY -
C JDESC -
C NEWNR -
C KDESC -
C NRDESC -
C LDESC -
C ANAME -
C AUNITS -
C KSCALE -
C KRFVAL -
C KWIDTH -
C KRFVSW -
C NEWRFV -
C KSEQ -
C KNUM -
C KLIST -
C
C OUTPUT ARGUMENT LIST:
C KDATA -
C KBUFR -
C IERRTN -
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
C -------------------------------------------------------------
INTEGER ISTEP,INDEXB(*)
INTEGER KBUFR(*)
INTEGER ISECT3(*)
INTEGER KARY(*)
INTEGER NRDESC,NEWNR,KDESC(3,*),JDESC(3,*)
INTEGER KDATA(500,*)
INTEGER KRFVSW(*),KSCALE(*),KRFVAL(*),KWIDTH(*),NEWRFV(*)
INTEGER IERRTN
INTEGER LDESC(*)
INTEGER IBITS(32)
INTEGER MISG
INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
CHARACTER*40 ANAME(*)
CHARACTER*25 AUNITS(*)
CHARACTER*9 CCITT
LOGICAL TEXT
C
SAVE
C -------------------------------------------------------------
DATA IBITS / 1, 3, 7, 15,
* 31, 63, 127, 255,
* 511, 1023, 2047, 4095,
* 8191, 16383, 32767, 65535,
* Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
* Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
* Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
* Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
DATA CCITT /'CCITT IA5'/
DATA MISG /99999/
C -------------------------------------------------------------
KEND = IBFSIZ * 8 - 32
C **********************************************
C * *
C * PROCESS AS NON-COMPRESSED MESSAGE *
C * *
C * I POINTS TO SUBSET *
C * N POINTS TO DESCRIPTOR *
C * K ADJUSTS N TO CORRECT DATA ENTRY *
C * *
C **********************************************
DO 4500 I = 1, ISECT3(1)
C OUTER LOOP FOR EACH SUBSET
C DO UNTIL ALL DESCRIPTORS HAVE
C BEEN PROCESSED
C SET ADDED BIT FOR WIDTH TO 0
KARY(26) = 0
C SET ASSOCIATED FIELD WIDTH TO 0
KARY(27) = 0
KARY(18) = 0
C IF MESSAGE CONTAINS DELAYED REPLICATION
C WE NEED TO EXPAND THE ORIGINAL DESCRIPTOR LIST
C TO MATCH THE INPUT DATA.
C START WITH JDESC
IF (KARY(4).NE.0) THEN
DO 100 M = 1, NEWNR
KDESC(1,M) = JDESC(1,M)
100 CONTINUE
NRDESC = NEWNR
END IF
KARY(11) = 1
KARY(2) = 1
4300 CONTINUE
IF(KARY(11).GT.NRDESC) GOTO 4305
C INNER LOOP FOR PARAMETER
4200 CONTINUE
C KARY(2) = KARY(11) + KARY(18)
C PRINT *,'LOOKING AT DESCRIPTOR',KARY(11),
C * KDESC(1,KARY(11)),
C * KARY(2),KDATA(I,KARY(2))
C
C PROCESS ONE DESCRIPTOR AT A TIME
C
C ISOLATE TABLE
C
KFUNC = KDESC(1,KARY(11)) / 16384
C ISOLATE CLASS
KCLASS = MOD(KDESC(1,KARY(11)),16384) / 256
KSEG = MOD(KDESC(1,KARY(11)),256)
IF (KFUNC.EQ.1) THEN
C REPLICATION DESCRIPTOR
CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
* KDATA,I,KDESC,NRDESC,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 4200
ELSE IF (KFUNC.EQ.2) THEN
C OPERATOR DESCRIPTOR
CALL FI8502(*4200,KBUFR,KCLASS,KSEG,
* KDESC,NRDESC,I,ISTEP,
* KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
IF (IERRTN.NE.0) THEN
RETURN
END IF
KARY(11) = KARY(11) + 1
GO TO 4300
ELSE IF (KFUNC.EQ.3) THEN
C SEQUENCE DESCRIPTOR
CALL FI8503(KARY(11),KDESC,NRDESC,
* ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 4200
END IF
C FALL THRU WITH ELEMENT DESCRIPTOR
C FIND MATCHING TABLE B ENTRY
LK = INDEXB(KDESC(1,KARY(11)))
IF (LK.LT.1) THEN
C FALL THRU WITH NO MATCHING B ENTRY
PRINT *,'FI8506 3800',KARY(11),KDESC(1,KARY(11)),
* NRDESC,LK,LDESC(LK)
IERRTN = 2
RETURN
END IF
C
IF (AUNITS(LK).EQ.CCITT) THEN
TEXT = .TRUE.
ELSE
TEXT = .FALSE.
END IF
C
IF (TEXT) THEN
JWIDE = KWIDTH(LK)
3775 CONTINUE
IF (JWIDE.GT.32) THEN
IF(ISECT3(10).NE.0) THEN
CALL W3AI38 (KDATA(I,KARY(2)),4)
END IF
IF ((KARY(3)+32).GT.KEND) THEN
IERRTN = 1
RETURN
END IF
CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),32)
KARY(3) = KARY(3) + 32
C ADD A WORD HERE ONLY
KARY(18) = KARY(18) + 1
C KARY(2) = KARY(11) + KARY(18)
KARY(2) = KARY(2) + 1
JWIDE = JWIDE - 32
GO TO 3775
ELSE IF (JWIDE.EQ.32) THEN
IF(ISECT3(10).NE.0) THEN
CALL W3AI38 (KDATA(I,KARY(2)),4)
END IF
IF ((KARY(3)+32).GT.KEND) THEN
IERRTN = 1
RETURN
END IF
CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),32)
KARY(3) = KARY(3) + 32
KARY(2) = KARY(2) + 1
JWIDE = JWIDE - 32
ELSE IF (JWIDE.GT.0) THEN
IF(ISECT3(10).NE.0) THEN
CALL W3AI38 (KDATA(I,KARY(2)),4)
END IF
IF ((KARY(3)+JWIDE).GT.KEND) THEN
IERRTN = 1
RETURN
END IF
CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),JWIDE)
KARY(3) = KARY(3) + JWIDE
KARY(2) = KARY(2) + 1
END IF
ELSE
C NOT TEXT
IF (KARY(27).NE.0.AND.KDESC(1,KARY(11)).NE.7957) THEN
C ENTER ASSOCIATED FIELD
IF ((KARY(3)+KARY(27)).GT.KEND) THEN
IERRTN = 1
RETURN
END IF
CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),
* KARY(27))
KARY(3) = KARY(3) + KARY(27)
KARY(18) = KARY(18) + 1
C KARY(2) = KARY(11) + KARY(18)
KARY(2) = KARY(2) + 1
END IF
C
JWIDE = KWIDTH(LK) + KARY(26)
IF (KDATA(I,KARY(2)).EQ.MISG) THEN
C MISSING DATA, SET ALL BITS ON
IF ((KARY(3)+JWIDE).GT.KEND) THEN
IERRTN = 1
RETURN
END IF
CALL SBYTE (KBUFR,IBITS(JWIDE),KARY(3),JWIDE)
KARY(3) = KARY(3) + JWIDE
KARY(2) = KARY(2) + 1
KARY(11) = KARY(11) + 1
GO TO 4300
END IF
C CAN DATA BE CONTAINED IN SPECIFIED
C BIT WIDTH, IF NOT - ERROR
IF (KDATA(I,KARY(2)).GT.IBITS(JWIDE)) THEN
IERRTN = 1
RETURN
END IF
C ADJUST WITH REFERENCE VALUE
IF (KRFVSW(LK).EQ.0) THEN
JRV = KRFVAL(LK)
ELSE
JRV = NEWRFV(LK)
END IF
C
KDATA(I,KARY(2)) = KDATA(I,KARY(2)) - JRV
C IF NEW VALUE IS NEGATIVE - ERROR
IF (KDATA(I,KARY(2)).LT.0) THEN
IERRTN = 11
RETURN
END IF
C PACK DATA INTO OUTPUT ARRAY
IF ((KARY(3)+JWIDE).GT.KEND) THEN
IERRTN = 1
RETURN
END IF
CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),JWIDE)
KARY(2) = KARY(2) + 1
KARY(3) = KARY(3) + JWIDE
END IF
KARY(11) = KARY(11) + 1
GOTO 4300
4305 CONTINUE
C RESET ALL REFERENCE VALUES TO ORIGINAL
DO 4310 LX = 1, ISECT3(8)
KRFVSW(LX) = 0
4310 CONTINUE
4500 CONTINUE
RETURN
END
SUBROUTINE FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
* KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
* KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8508 COMBINE INTEGER/TEXT DATA
C PRGMMR: CAVANAUGH W/NMC42 DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT INTEGER SUBSET FROM REAL AND TEXT DATA
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C 94-03-31 HOPPA ADDED KSUB TO FI8501 PARAMETER LIST.
C 94-04-18 HOPPA ADDED DUMMY VARIABLE IDUM TO FI8502 PARAMETER
C LIST.
C 94-04-20 HOPPA ADDED DUMMY VARIABLE LL TO FI8501 PARAMETER
C LIST.
C 94-04-29 HOPPA - CHANGED I TO KARY(11)
C - ADDED A KARY(2) ASSIGNMENT SO HAVE SOMETHING
C TO PASS TO SUBROUTINES ** TEST THIS **
C - REMOVED I AND LL FROM CALL TO FI8501
C 94-05-13 HOPPA - ADDED CODE TO CALCULATE KWORDS WHEN KFUNC=2
C 94-05-18 HOPPA - DELETED KARY(2) ASSIGNMENT
C
C
C USAGE: CALL FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
C * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
C * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C INPUT ARGUMENT LIST:
C ISTEP -
C IUNITB - UNIT NUMBER OF DEVICE CONTAINING TABLE B
C IDATA - INTEGER WORKING ARRAY
C KDESC - EXPANDED DESCRIPTOR SET
C NRDESC - NUMBER OF DESCRIPTORS IN KDESC
C ATEXT - TEXT DATA FOR CCITT IA5 AND TEXT OPERATOR FIELDS
C KSUB - SUBSET NUMBER
C KARY - WORKING ARRAY
C ISECT3 -
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - ARRAY CONTAINING INTEGER SUBSETS
C LDESC - LIST OF TABLE B DESCRIPTORS (DECIMAL)
C ANAME - LIST OF DESCRIPTOR NAMES
C AUNITS - UNITS FOR EACH DESCRIPTOR
C KSCALE - BASE 10 SCALE FACTOR FOR EACH DESCRIPTOR
C KRFVAL - REFERENCE VALUE FOR EACH DESCRIPTOR
C KRFVSW -
C NEWRFV -
C KWIDTH - STANDARD BIT WIDTH TO CONTAIN EACH VALUE
C FOR SPECIFIC DESCRIPTOR
C KASSOC -
C IERRTN - ERROR RETURN FLAG
C
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C TAKE EACH NON-TEXT ENTRY OF SECTION 2
C ACCEPT IT
C
C TAKE EACH TEXT ENTRY
C INSERT INTO INTEGER ARRAY,
C ADDING FULL WORDS AS NECESSARY
C MAKE SURE ANY LAST WORD HAS TEXT DATA
C RIGHT JUSTIFIED
C ---------------------------------------------------------------------
C PASS BACK CONVERTED ENTRY TO LOCATION
C SPECIFIED BY USER
C
C REFERENCE VALUE WILL BE APPLIED DURING
C ENCODING OF MESSAGE
C ---------------------------------------------------------------------
INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
INTEGER KDESC(3,*),NRDESC,KASSOC(*)
INTEGER IDATA(*),ISTEP
INTEGER KDATA(500,*)
INTEGER KARY(*),INDEXB(*)
INTEGER KSUB,K
INTEGER LDESC(*)
INTEGER IBITS(32)
INTEGER KSCALE(*)
INTEGER KRFVAL(*)
INTEGER KRFVSW(*)
INTEGER KWIDTH(*)
INTEGER MISG
INTEGER MPTR,ISECT3(*)
CHARACTER*1 ATEXT(*)
CHARACTER*1 AHOLD1(256)
INTEGER IHOLD4(64)
CHARACTER*25 AUNITS(*)
CHARACTER*25 CCITT
CHARACTER*40 ANAME(*)
C
SAVE
C
EQUIVALENCE (AHOLD1,IHOLD4)
C
C =====================================
DATA CCITT /'CCITT IA5 '/
DATA IBITS / 1, 3, 7, 15,
* 31, 63, 127, 255,
* 511, 1023, 2047, 4095,
* 8191, 16383, 32767, 65535,
* Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
* Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
* Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
* Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
DATA MISG /99999/
C
IF (ISECT3(8).EQ.0) THEN
CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
* LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
* IUNITD,KSEQ,KNUM,KLIST,INDEXB)
IF (IERRTN.NE.0) THEN
RETURN
END IF
END IF
C HAVE TABLE B AVAILABLE NOW
C
C LOOK AT EACH DATA ENTRY
C CONVERT NON TEXT
C MOVE TEXT
C
KPOS = 0
MPTR = 0
KARY(11) = 0
1000 CONTINUE
KARY(11) = KARY(11) + 1
IF (KARY(11).GT.NRDESC) GO TO 1500
C
C RE-ENTRY POINT FOR REPLICATION AND SEQUENCE DESCR'S
C
500 CONTINUE
KFUNC = KDESC(1,KARY(11)) / 16384
KL = KDESC(1,KARY(11)) - 16384 * KFUNC
KCLASS = KL / 256
KSEG = MOD(KL,256)
C KARY(2) = KARY(11) + KARY(18)
IF (KFUNC.EQ.1) THEN
C REPLICATION DESCRIPTOR
CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
* KDATA,KSUB,KDESC,NRDESC,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 500
ELSE IF (KFUNC.EQ.2) THEN
IF (KCLASS.EQ.5) THEN
C HANDLE TEXT OPERATORS
CC
KAVAIL = IDATA(KARY(11))
C UNUSED POSITIONS IN LAST WORD
KREM = MOD(KAVAIL,4)
IF (KREM.NE.0) THEN
KWORDS = KAVAIL / 4 + 1
ELSE
KWORDS = KAVAIL / 4
END IF
CC
JWIDE = KSEG * 8
GO TO 1200
END IF
ELSE IF (KFUNC.EQ.3) THEN
C SEQUENCE DESCRIPTOR - ERROR
CALL FI8503(KARY(11),KDESC,NRDESC,
* ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 500
ELSE
C
C FIND MATCHING DESCRIPTOR
C
K = INDEXB(KDESC(1,KARY(11)))
IF (K.LT.1) THEN
PRINT *,'FI8508-NOT FOUND',KARY(11),KDESC(1,KARY(11)),
* ISECT3(8),LDESC(K)
IERRTN = 2
RETURN
END IF
C HAVE MATCHING DESCRIPTOR
200 CONTINUE
IF (AUNITS(K)(1:9).NE.CCITT(1:9)) THEN
IF (KARY(27).NE.0) THEN
IF (KDESC(1,KARY(11)).LT.7937.OR.
* KDESC(1,KARY(11)).GT.8191) THEN
C ASSOC FLD FOR ALL BUT CLASS 31
KPOS = KPOS + 1
IF (KASSOC(KARY(11)).EQ.IBITS(KARY(27))) THEN
KDATA(KSUB,KPOS) = MISG
ELSE
KDATA(KSUB,KPOS) = KASSOC(KARY(11))
END IF
END IF
END IF
C IF NOT MISSING DATA
IF (IDATA(KARY(11)).EQ.99999) THEN
KPOS = KPOS + 1
KDATA(KSUB,KPOS) = MISG
ELSE
C PROCESS INTEGER VALUES
KPOS = KPOS + 1
KDATA(KSUB,KPOS) = IDATA(KARY(11))
END IF
ELSE
C PROCESS TEXT
C NUMBER OF BYTES REQUIRED BY TABLE B
KREQ = KWIDTH(K) / 8
C NUMBER BYTES AVAILABLE IN ATEXT
KAVAIL = IDATA(KARY(11))
C UNUSED POSITIONS IN LAST WORD
KREM = MOD(KAVAIL,4)
IF (KREM.NE.0) THEN
KWORDS = KAVAIL / 4 + 1
ELSE
KWORDS = KAVAIL / 4
END IF
C MOVE TEXT CHARACTERS TO KDATA
JWIDE = KWIDTH(K)
GO TO 1200
END IF
END IF
GO TO 1000
1200 CONTINUE
300 CONTINUE
NPTR = MPTR
DO 400 IJ = 1, KWORDS
KPOS = KPOS + 1
CALL GBYTE(ATEXT,KDATA(KSUB,KPOS),NPTR,32)
NPTR = NPTR + 32
400 CONTINUE
MPTR = MPTR + JWIDE
GO TO 1000
1500 CONTINUE
RETURN
END
SUBROUTINE FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
* KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
* KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8509 CONVERT REAL/TEXT INPUT TO INTEGER
C PRGMMR: CAVANAUGH W/NMC42 DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT INTEGER SUBSET FROM REAL AND TEXT DATA
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C 94-03-31 HOPPA ADDED KSUB TO THE FI8501 PARAMETER LIST.
C 94-04-18 HOPPA ADDED DUMMY VARIABLE IDUM TO FI8502 PARAMETER
C LIST.
C 94-04-20 HOPPA ADDED DUMMY VARIABLE LL TO FI8501 PARAMETER
C LIST.
C 94-04-29 HOPPA - CHANGED I TO KARY(11)
C - ADDED A KARY(2) ASSIGNMENT SO HAVE SOMETHING
C TO PASS TO SUBROUTINES ** TEST THIS **
C - REMOVED I AND LL FROM CALL TO FI8501
C 94-05-18 HOPPA - DELETED KARY(2) ASSIGNMENT
C
C USAGE: CALL FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
C * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
C * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C INPUT ARGUMENT LIST:
C IUNITB - UNIT NUMBER OF DEVICE CONTAINING TABLE B
C RDATA - REAL WORKING ARRAY
C KDESC - EXPANDED DESCRIPTOR SET
C NRDESC - NUMBER OF DESCRIPTORS IN KDESC
C ATEXT - TEXT DATA FOR CCITT IA5 AND TEXT OPERATOR FIELDS
C KSUB - SUBSET NUMBER
C KARY - WORKING ARRAY
C ISECT3 -
C IUNITD -
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - ARRAY CONTAINING INTEGER SUBSETS
C LDESC - LIST OF TABLE B DESCRIPTORS (DECIMAL)
C ANAME - LIST OF DESCRIPTOR NAMES
C AUNITS - UNITS FOR EACH DESCRIPTOR
C KSCALE - BASE 10 SCALE FACTOR FOR EACH DESCRIPTOR
C KRFVAL - REFERENCE VALUE FOR EACH DESCRIPTOR
C KRFVSW -
C NEWRFV -
C KASSOC -
C KWIDTH - STANDARD BIT WIDTH TO CONTAIN EACH VALUE
C FOR SPECIFIC DESCRIPTOR
C IERRTN - ERROR RETURN FLAG
C KSEG -
C KNUM -
C KLIST -
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C TAKE EACH NON-TEXT ENTRY OF SECTION 2
C SCALE IT
C ROUND IT
C CONVERT TO INTEGER
C
C TAKE EACH TEXT ENTRY
C INSERT INTO INTEGER ARRAY,
C ADDING FULL WORDS AS NECESSARY
C MAKE SURE ANY LAST WORD HAS TEXT DATA
C RIGHT JUSTIFIED
C PASS BACK CONVERTED ENTRY TO LOCATION
C SPECIFIED BY USER
C
C REFERENCE VALUE WILL BE APPLIED DURING
C ENCODING OF MESSAGE
C ---------------------------------------------------------------------
REAL RDATA(*)
INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
INTEGER IBITS(32),INDEXB(*)
INTEGER KDESC(3,*),ISTEP
INTEGER KDATA(500,*)
INTEGER KASSOC(*)
INTEGER KARY(*)
INTEGER KSUB,K
INTEGER LDESC(*)
INTEGER NRDESC
INTEGER IERRTN
INTEGER KSCALE(*)
INTEGER KRFVAL(*)
INTEGER KRFVSW(*)
INTEGER KWIDTH(*)
INTEGER MPTR,ISECT3(*)
INTEGER MISG
CHARACTER*1 AHOLD1(256)
INTEGER IHOLD4(64)
CHARACTER*1 ATEXT(*)
CHARACTER*25 AUNITS(*)
CHARACTER*25 CCITT
CHARACTER*40 ANAME(*)
C
SAVE
C =====================================
EQUIVALENCE (AHOLD1,IHOLD4)
C
DATA IBITS/ 1, 3, 7, 15,
* 31, 63, 127, 255,
* 511, 1023, 2047, 4095,
* 8191, 16383, 32767, 65535,
* Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
* Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
* Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
* Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
C
DATA CCITT /'CCITT IA5 '/
DATA MISG /99999/
C =====================================
C
IF (ISECT3(8).EQ.0) THEN
CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
* LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
* IUNITD,KSEQ,KNUM,KLIST,INDEXB)
IF (IERRTN.NE.0) THEN
RETURN
END IF
END IF
C HAVE TABLE B AVAILABLE NOW
C
C LOOK AT EACH DATA ENTRY
C CONVERT NON TEXT
C MOVE TEXT
C
KPOS = 0
MPTR = 0
KARY(11) = 0
1000 CONTINUE
KARY(11) = KARY(11) + 1
IF (KARY(11).GT.NRDESC) GO TO 1500
C RE-ENRY POINT FOR REPLICATION AND
C SEQUENCE DESCRIPTORS
500 CONTINUE
KFUNC = KDESC(1,KARY(11)) / 16384
KL = KDESC(1,KARY(11)) - 16384 * KFUNC
KCLASS = KL / 256
KSEG = MOD(KL,256)
C KARY(2) = KARY(11) + KARY(18)
IF (KFUNC.EQ.1) THEN
C REPLICATION DESCRIPTOR
CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
* KDATA,KSUB,KDESC,NRDESC,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 500
ELSE IF (KFUNC.EQ.2) THEN
C HANDLE OPERATORS
IF (KCLASS.EQ.5) THEN
C NUMBER BYTES AVAILABLE IN ATEXT
KAVAIL = RDATA(KARY(11))
C UNUSED POSITIONS IN LAST WORD
KREM = MOD(KAVAIL,4)
IF (KREM.NE.0) THEN
KWORDS = KAVAIL / 4 + 1
ELSE
KWORDS = KAVAIL / 4
END IF
JWIDE = KSEG * 8
GO TO 1200
ELSE IF (KCLASS.EQ.2) THEN
IF (KSEG.EQ.0) THEN
KARY(9) = 0
ELSE
KARY(9) = KSEG - 128
END IF
GO TO 1200
END IF
ELSE IF (KFUNC.EQ.3) THEN
C SEQUENCE DESCRIPTOR - ERROR
CALL FI8503(KDESC,NRDESC,
* ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 500
ELSE
C
C FIND MATCHING DESCRIPTOR
C
K = INDEXB(KDESC(1,KARY(11)))
IF (K.LT.1) THEN
IERRTN = 2
C PRINT *,'FI8509 - IERRTN = 2'
RETURN
END IF
C HAVE MATCHING DESCRIPTOR
200 CONTINUE
IF (AUNITS(K)(1:9).NE.CCITT(1:9)) THEN
IF (KARY(27).NE.0) THEN
IF (KDESC(1,KARY(11)).LT.7937.OR.
* KDESC(1,KARY(11)).GT.8191) THEN
C ASSOC FLD FOR ALL BUT CLASS 31
KPOS = KPOS + 1
IF (KASSOC(KARY(11)).EQ.IBITS(KARY(27))) THEN
KDATA(KSUB,KPOS) = MISG
ELSE
KDATA(KSUB,KPOS) = KASSOC(KARY(11))
END IF
END IF
END IF
C IF NOT MISSING DATA
IF (RDATA(KARY(11)).EQ.99999.) THEN
KPOS = KPOS + 1
KDATA(KSUB,KPOS) = MISG
ELSE
C PROCESS REAL VALUES
IF (KSCALE(K).NE.0) THEN
C SCALING ALLOWING FOR CHANGE SCALE
SCALE = 10. **(IABS(KSCALE(K)) + KARY(9))
IF (KSCALE(K).LT.0) THEN
RDATA(KARY(11)) = RDATA(KARY(11)) / SCALE
ELSE
RDATA(KARY(11)) = RDATA(KARY(11)) * SCALE
END IF
END IF
C PERFORM ROUNDING
RDATA(KARY(11)) = RDATA(KARY(11)) +
* SIGN(0.5,RDATA(KARY(11)))
C CONVERT TO INTEGER
KPOS = KPOS + 1
KDATA(KSUB,KPOS) = RDATA(KARY(11))
C
END IF
ELSE
C PROCESS TEXT
C NUMBER OF BYTES REQUIRED BY TABLE B
KREQ = KWIDTH(K) / 8
C NUMBER BYTES AVAILABLE IN ATEXT
KAVAIL = RDATA(KARY(11))
C UNUSED POSITIONS IN LAST WORD
KREM = MOD(KAVAIL,4)
IF (KREM.NE.0) THEN
KWORDS = KAVAIL / 4 + 1
ELSE
KWORDS = KAVAIL / 4
END IF
C MOVE TEXT CHARACTERS TO KDATA
JWIDE = KWIDTH(K)
GO TO 1200
END IF
END IF
GO TO 1000
1200 CONTINUE
300 CONTINUE
NPTR = MPTR
DO 400 IJ = 1, KWORDS
KPOS = KPOS + 1
CALL GBYTE(ATEXT,KDATA(KSUB,KPOS),NPTR,32)
NPTR = NPTR + 32
400 CONTINUE
MPTR = MPTR + JWIDE
GO TO 1000
1500 CONTINUE
C DO 2000 I = 1, KPOS
C2000 CONTINUE
RETURN
END
SUBROUTINE FI8511(ISECT3,KARY,JIF,JDESC,NEWNR,
* KIF,KDESC,NRDESC,IERRTN)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8511 REBUILD KDESC FROM JDESC
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT WORKING DESCRIPTOR LIST FROM LIST OF DESCRIPTORS
C IN SECTION 3.
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8511(ISECT3,KARY,JIF,JDESC,NEWNR,
C * KIF,KDESC,NRDESC,IERRTN)
C INPUT ARGUMENT LIST:
C IUNITD - UNIT NUMBER OF TABLE D
C ISECT3 -
C KARY - UTILITY - ARRAY SEE MAIN ROUTINE
C JIF - DESCRIPTOR INPUT FORM FLAG
C JDESC - LIST OF DESCRIPTORS FOR SECTION 3
C NEWNR - NUMBER OF DESCRIPTORS IN JDESC
C KSEQ - SEQUENCE DESCRIPTOR KEY
C KNUM - NR OF DESCRIPTORS IN SEQUENCE
C KLIST - LIST OF DESCRIPTORS IN SEQUENCE
C
C OUTPUT ARGUMENT LIST:
C KIF - DESCRIPTOR FORM
C KDESC - WORKING LIST OF DESCRIPTORS
C NRDESC - NUMBER OF DESCRIPTORS IN KDESC
C IERRTN - ERROR RETURN
C IERRTN = 0 NORMAL RETURN
C IERRTN = 5 FOUND DELAYED REPLICATION DURING
C EXPANSION
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
INTEGER JDESC(3,*), NEWNR, KDESC(3,*), NRDESC
INTEGER KARY(*),IERRTN,KIF,JIF
INTEGER ISECT3(*)
C
SAVE
C
IF (NEWNR.EQ.0) THEN
IERRTN = 3
RETURN
END IF
C
NRDESC = NEWNR
IF (JIF.EQ.0) THEN
JIF = 1
DO 90 I = 1, NEWNR
KDESC(1,I) = JDESC(1,I)*16384 + JDESC(2,I)*256 + JDESC(3,I)
JDESC(1,I) = JDESC(1,I)*16384 + JDESC(2,I)*256 + JDESC(3,I)
90 CONTINUE
ELSE
DO 100 I = 1, NEWNR
KDESC(1,I) = JDESC(1,I)
100 CONTINUE
NRDESC = NEWNR
END IF
KIF = 1
9000 CONTINUE
RETURN
END
SUBROUTINE FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
* LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
* IUNITD,KSEQ,KNUM,KLIST,INDEXB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8512 READ IN TABLE B
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03
C
C ABSTRACT: READ IN TAILORED SET OF TABLE B DESCRIPTORS
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C 94-04-18 HOPPA AN ERROR HAS BEEN CORRECTED TO PREVENT LATER
C SEARCHING TABLE B IF THERE ARE ONLY OPERATOR
C DESCRIPTORS IN THE DESCRIPTOR LIST.
C 94-05-17 HOPPA CHANGED THE LOOP FOR EXPANDING SEQUENCE
C DESCRIPTORS FROM A DO LOOP TO A GOTO LOOP
C
C USAGE: CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
C * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
C * IUNITD,KSEQ,KNUM,KLIST,INDEXB)
C INPUT ARGUMENT LIST:
C IUNITB - UNIT WHERE TABLE B ENTRIES RESIDE
C KDESC - WORKING DESCRIPTOR LIST
C NRDESC - NUMBER OF DESCRIPTORS IN KDESC
C IUNITD - UNIT WHERE TABLE D ENTRIES RESIDE
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KARY -
C IERRTN -
C LDESC - DESCRIPTORS IN TABLE B (DECIMAL VALUES)
C ANAME - ARRAY CONTAINING NAMES OF DESCRIPTORS
C AUNITS - ARRAY CONTAINING UNITS OF DESCRIPTORS
C KSCALE - SCALE VALUES FOR EACH DESCRIPTOR
C KRFVAL - REFERENCE VALUES FOR EACH DESCRIPTOR
C WIDTH - BIT WIDTH OF EACH DESCRIPTOR
C KRFVSW - NEW REFERENCE VALUE SWITCH
C KSEQ - SEQUENCE DESCRIPTOR
C KNUM - NUMBER OF DESCRIPTORS IN SEQUENCE
C KLIST - SEQUENCE OF DESCRIPTORS
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
INTEGER KARY(*),LDESC(*),KSCALE(*),KRFVAL(*),KWIDTH(*)
INTEGER KDESC(3,*), NRDESC, IUNITB, IERRTN, KRFVSW(*)
INTEGER ISECT3(*),KEY(3,1600),INDEXB(*)
INTEGER IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
CHARACTER*40 ANAME(*)
CHARACTER*25 AUNITS(*)
C
INTEGER MDESC(800),MR,I,J
C
SAVE
C
C ===================================================================
IERRTN = 0
DO 100 I = 1, 30
KARY(I) = 0
100 CONTINUE
C INITIALIZE DESCRIPTOR POINTERS TO MISSING
DO 105 I = 1, 16383
INDEXB(I) = -1
105 CONTINUE
C
C ===================================================================
C MAKE A COPY OF THE DESCRIPTOR LIST
C ELIMINATING REPLICATION/OPERATORS
J = 0
DO 110 I = 1, NRDESC
IF (KDESC(1,I).GE.49152.OR.KDESC(1,I).LT.16384) THEN
J = J + 1
KEY(1,J) = KDESC(1,I)
END IF
110 CONTINUE
KCNT = J
C ===================================================================
C REPLACE ALL SEQUENCE DESCRIPTORS
C JEN - FIXED NEXT BLOCK
C DO 300 I = 1, KCNT
I = 1
300 IF(I.LE.KCNT)THEN
200 CONTINUE
IF (KEY(1,I).GE.49152) THEN
CALL FI8503(I,KEY,KCNT,
* ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
IF (IERRTN.NE.0) THEN
RETURN
END IF
GO TO 200
END IF
I=I+1
GOTO 300
ENDIF
C 300 CONTINUE
C ===================================================================
C ISOLATE SINGLE COPIES OF DESCRIPTORS
MR = 1
C THE FOLLOWING LINE IS TO PREVENT LATER SEARCHING TABLE B WHEN
C HAVE ONLY OPERATOR DESCRIPTORS
IF(KCNT.EQ.0) GOTO 9000
MDESC(MR) = KEY(1,1)
DO 500 I = 2, KCNT
DO 400 J = 1, MR
IF (KEY(1,I).EQ.MDESC(J)) THEN
GO TO 500
END IF
400 CONTINUE
MR = MR + 1
MDESC(MR) = KEY(1,I)
500 CONTINUE
C ===================================================================
C SORT INTO ASCENDING ORDER
C READ IN MATCHING ENTRIES FROM TABLE B
DO 700 KCUR = 1, MR
NEXT = KCUR + 1
IF (NEXT.LE.MR) THEN
DO 600 LR = NEXT, MR
IF (MDESC(KCUR).GT.MDESC(LR)) THEN
IHOLD = MDESC(LR)
MDESC(LR) = MDESC(KCUR)
MDESC(KCUR) = IHOLD
END IF
600 CONTINUE
END IF
700 CONTINUE
C ===================================================================
REWIND IUNITB
C
C READ IN A MODIFIED TABLE B -
C MODIFIED TABLE B CONTAINS ONLY
C THOSE DESCRIPTORS ASSOCIATED WITH
C CURRENT DATA.
C
KTRY = 0
DO 1500 NRTBLB = 1, MR
1000 CONTINUE
1001 FORMAT (I1,I2,I3,A40,A25,I4,8X,I7,I5)
READ (IUNITB,1001,END=2000,ERR=8000)KF,KX,KY,ANAME(NRTBLB),
* AUNITS(NRTBLB),KSCALE(NRTBLB),KRFVAL(NRTBLB),KWIDTH(NRTBLB)
KRFVSW(NRTBLB) = 0
LDESC(NRTBLB) = KX*256 + KY
C
IF (LDESC(NRTBLB).EQ.MDESC(NRTBLB)) THEN
C PRINT *,'1001',NRTBLB,LDESC(NRTBLB)
C PRINT *,LDESC(NRTBLB),ANAME(NRTBLB),KSCALE(NRTBLB),
C * KRFVAL(NRTBLB),KWIDTH(NRTBLB)
KTRY = KTRY + 1
INDEXB(LDESC(NRTBLB)) = KTRY
C PRINT *,'INDEX(',LDESC(NRTBLB),' = ',KTRY
ELSE IF (LDESC(NRTBLB).GT.MDESC(NRTBLB)) THEN
C PRINT *,'FI8512 - IERRTN=2'
IERRTN = 2
RETURN
ELSE
GO TO 1000
END IF
1500 CONTINUE
IF (KTRY.NE.MR) THEN
PRINT *,'DO NOT HAVE A COMPLETE SET OF TABLE B ENTRIES'
IERRTN = 2
RETURN
END IF
C DO 1998 I = 1, 16383, 30
C WRITE (6,1999) (INDEXB(I+J),J=0,23)
C1998 CONTINUE
C1999 FORMAT(30(1X,I3))
C
2000 CONTINUE
IERRTN = 0
ISECT3(8) = MR
GO TO 9000
8000 CONTINUE
IERRTN = 4
9000 CONTINUE
RETURN
END
SUBROUTINE FI8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8513 READ IN TABLE D
C PRGMMR: CAVANAUGH W/NMC42 DATE: 93-12-03
C
C ABSTRACT: READ IN TABLE D
C
C PROGRAM HISTORY LOG:
C 93-12-03 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
C INPUT ARGUMENT LIST:
C IUNITD - UNIT NUMBER OF INPUT DEVICE
C KARY - WORK ARRAY
C
C OUTPUT ARGUMENT LIST:
C KSEQ - KEY FOR SEQUENCE DESCRIPTORS
C KNUM - NUMBER IF DESCRIPTORS IN LIST
C KLIST - DESCRIPTORS LIST
C IERRTN - ERROR RETURN FLAG
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
INTEGER IUNITD, ISECT3(*)
INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
INTEGER KKF(10),KKX(10),KKY(10),KF,KX,KY
C
SAVE
C
REWIND IUNITD
J = 0
IERRTN = 0
1000 CONTINUE
READ (IUNITD,1001,END=9000,ERR=8000)KF,KX,KY,
* KKF(1),KKX(1),KKY(1),
* KKF(2),KKX(2),KKY(2),
* KKF(3),KKX(3),KKY(3),
* KKF(4),KKX(4),KKY(4),
* KKF(5),KKX(5),KKY(5),
* KKF(6),KKX(6),KKY(6),
* KKF(7),KKX(7),KKY(7),
* KKF(8),KKX(8),KKY(8),
* KKF(9),KKX(9),KKY(9),
* KKF(10),KKX(10),KKY(10)
1001 FORMAT (11(I1,I2,I3,1X),3X)
J = J + 1
C BUILD SEQUENCE KEY
KSEQ(J) = 16384*KF + 256*KX + KY
DO 2000 LM = 1, 10
C BUILD KLIST
KLIST(J,LM) = 16384*KKF(LM) + 256*KKX(LM) + KKY(LM)
IF(KLIST(J,LM).NE.0) THEN
KNUM(J) = LM
END IF
2000 CONTINUE
GO TO 1000
8000 CONTINUE
IERRTN = 6
9000 CONTINUE
ISECT3(9) = J
RETURN
END