SUBROUTINE W3FI92 (LOC,TTAAII,KARY,KWBX,IERR)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3FI92 BUILD 80-CHAR ON295 GRIB QUEUE DESCRIPTOR
C PRGMMR: CAVANAUGH ORG: NMC421 DATE:95-01-31
C
C ABSTRACT: BUILD 80 CHARACTER QUEUE DESCRIPTOR USING INFORMATION
C SUPPLIED BY USER, PLACING THE COMPLETED QUEUE DESCRIPTOR IN THE
C LOCATION SPECIFIED BY THE USER. (BASED ON OFFICE NOTE 295).
C NOTE - THIS IS A MODIFIED VERSION OF W3FI62 WHICH ADDS THE
C 'KWBX' PARAMETER. THIS VALUE WILL NOW BE ADDED TO
C BYTES 35-38 FOR ALL GRIB PRODUCTS.
C QUEUE DESCIPTORS FOR NON-GRIB PRODUCTS WILL CONTINUE
C TO BE GENERATYED BY W3FI62.
C
C PROGRAM HISTORY LOG:
C 91-06-21 CAVANAUGH
C 94-03-08 CAVANAUGH MODIFIED TO ALLOW FOR BULLETIN SIZES THAT
C EXCEED 20000 BYTES
C 94-04-28 R.E.JONES CHANGE FOR CRAY 64 BIT WORD SIZE AND
C FOR ASCII CHARACTER SET COMPUTERS
C 95-10-16 J.SMITH MODIFIED VERSION OF W3FI62 TO ADD 'KWBX'
C TO BYTES 35-38 OF QUEUE DESCRIPTOR.
C 96-01-29 R.E.JONES PRESET IERR TO ZERO.
C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I
C
C USAGE: CALL W3FI92 (LOC,TTAAII,KARY,KWBX,IERR)
C INPUT ARGUMENT LIST:
C TTAAII - FIRST 6 CHARACTERS OF WMO HEADER
C KARY - INTEGER ARRAY CONTAINING USER INFORMATION
C (1) = DAY OF MONTH
C (2) = HOUR OF DAY
C (3) = HOUR * 100 + MINUTE
C (4) = CATALOG NUMBER
C (5) = NUMBER OF 80 BYTE INCREMENTS
C (6) = NUMBER OF BYTES IN LAST INCREMENT
C (7) = TOTAL SIZE OF MESSAGE
C WMO HEADER + BODY OF MESSAGE IN BYTES
C (NOT INCLUDING QUEUE DESCRIPTOR)
C KWBX - = 4 CHARACTERS, REPRESENTING TH FCST MODEL
C THAT THE BULLETIN WAS DERIVED FROM.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C LOC - LOCATION TO RECEIVE QUEUE DESCRIPTOR
C KARY - SEE INPUT ARGUMENT LIST
C IERR - ERROR RETURN
C
C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES)
C LIBRARY:
C W3LIB - GBYTE W3FI01 W3AI15 W3AI39
C
C REMARKS: IF TOTAL SIZE IS ENTERED (KARY(7)) THEN KARY(5) AND
C KARY(6) WILL BE CALCULATED.
C IF KARY(5) AND KARY(6) ARE PROVIDED THEN KARY(7) WILL
C BE IGNORED.
C
C WARNING: EQUIVALENCE ARRAY LOC TO INTEGER ARRAY SO IT STARTS ON
C A WORD BOUNDARY FOR SBYTE SUBROUTINE.
C
C ERROR RETURNS
C IERR = 1 TOTAL BYTE COUNT AND/OR 80 BYTE INCREMENT
C COUNT IS MISSING. ONE OR THE OTHER IS
C REQUIRED TO COMPLETE THE QUEUE DESCRIPTOR.
C IERR = 2 TOTAL SIZE TOO SMALL
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: HDS
C
C$$$
C
INTEGER IHOLD(2)
INTEGER KARY(7),IERR
C
LOGICAL IBM370
C
CHARACTER*6 TTAAII,AHOLD
CHARACTER*80 LOC
CHARACTER*1 BLANK
CHARACTER*4 KWBX
C
EQUIVALENCE (AHOLD,IHOLD)
C
SAVE
C
C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
C SETS TO FIND IBM370 TYPE COMPUTER.
C
DATA BLANK /' '/
C ----------------------------------------------------------------
C
C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
C
CALL W3FI01(LW)
C
C TEST FOR EBCDIC CHARACTER SET
C
IBM370 = .FALSE.
IF (MOVA2I(BLANK).EQ.64) THEN
IBM370 = .TRUE.
END IF
C
INOFST = 0
C BYTES 1-16 'QUEUE DESCRIPTOR'
CALL SBYTE (LOC,-656095772,INOFST,32)
INOFST = INOFST + 32
CALL SBYTE (LOC,-985611067,INOFST,32)
INOFST = INOFST + 32
CALL SBYTE (LOC,-490481207,INOFST,32)
INOFST = INOFST + 32
CALL SBYTE (LOC,-672934183,INOFST,32)
INOFST = INOFST + 32
C BYTES 17-20 INTEGER ZEROES
CALL SBYTE (LOC,0,INOFST,32)
INOFST = INOFST + 32
C IF TOTAL COUNT IS INCLUDED
C THEN WILL DETERMINE THE NUMBER OF
C 80 BYTE INCREMENTS AND WILL DETERMINE
C THE NUMBER OF BYTES IN THE LAST INCREMENT
IERR = 0
IF (KARY(7).NE.0) THEN
IF (KARY(7).LT.35) THEN
C PRINT *,'LESS THAN MINIMUM SIZE'
IERR = 2
RETURN
END IF
KARY(5) = KARY(7) / 80
KARY(6) = MOD(KARY(7),80)
IF (KARY(6).EQ.0) THEN
KARY(6) = 80
ELSE
KARY(5) = KARY(5) + 1
END IF
ELSE
IF (KARY(5).LT.1) THEN
IERR = 1
RETURN
END IF
END IF
C BYTE 21-22 NR OF 80 BYTE INCREMENTS
CALL SBYTE (LOC,KARY(5),INOFST,16)
INOFST = INOFST + 16
C BYTE 23 NR OF BYTES IN LAST INCREMENT
CALL SBYTE (LOC,KARY(6),INOFST,8)
INOFST = INOFST + 8
C BYTES 24-28 INTEGER ZEROES
CALL SBYTE (LOC,0,INOFST,32)
INOFST = INOFST + 32
CALL SBYTE (LOC,0,INOFST,8)
INOFST = INOFST + 8
C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII
LOC(29:34) = TTAAII(1:6)
C
C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC
C
IF (.NOT.IBM370) CALL W3AI39(LOC(29:29),6)
C
INOFST = INOFST + 48
C BYTES 35-38 KWBX
C
LOC(35:38) = KWBX(1:4)
C
C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
C
IF (.NOT.IBM370) CALL W3AI39(LOC(35:35),4)
INOFST = INOFST + 32
C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION
C TWO BYTES AS 4 BIT BCD
KA = KARY(3) / 1000
KB = MOD(KARY(3),1000) / 100
KC = MOD(KARY(3),100) / 10
KD = MOD(KARY(3),10)
CALL SBYTE (LOC,KA,INOFST,4)
INOFST = INOFST + 4
CALL SBYTE (LOC,KB,INOFST,4)
INOFST = INOFST + 4
CALL SBYTE (LOC,KC,INOFST,4)
INOFST = INOFST + 4
CALL SBYTE (LOC,KD,INOFST,4)
INOFST = INOFST + 4
C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555)
IF (KARY(4).GE.1.AND.KARY(4).LE.99999) THEN
CALL W3AI15 (KARY(4),IHOLD,1,8,'-')
IF (LW.EQ.4) THEN
CALL SBYTE (LOC,IHOLD(1),INOFST,8)
INOFST = INOFST + 8
CALL SBYTE (LOC,IHOLD(2),INOFST,32)
INOFST = INOFST + 32
C
C ON CRAY 64 BIT COMPUTER
C
ELSE
CALL SBYTE (LOC,IHOLD,INOFST,40)
INOFST = INOFST + 40
END IF
C
C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC
C
IF (.NOT.IBM370) CALL W3AI39(LOC(41:41),5)
ELSE
CALL SBYTE (LOC,-168430091,INOFST,32)
INOFST = INOFST + 32
CALL SBYTE (LOC,245,INOFST,8)
INOFST = INOFST + 8
END IF
C BYTES 46-80 INTEGER ZEROES
DO 4676 I = 1, 8
CALL SBYTE (LOC,0,INOFST,32)
INOFST = INOFST + 32
4676 CONTINUE
CALL SBYTE (LOC,0,INOFST,24)
RETURN
END