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