SUBROUTINE W3FI68 (ID, PDS)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3FI68 CONVERT 25 WORD ARRAY TO GRIB PDS
C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 91-05-14
C
C ABSTRACT: CONVERTS AN ARRAY OF 25, OR 27 INTEGER WORDS INTO A
C GRIB PRODUCT DEFINITION SECTION (PDS) OF 28 BYTES , OR 30 BYTES.
C IF PDS BYTES > 30, THEY ARE SET TO ZERO.
C
C PROGRAM HISTORY LOG:
C 91-05-08 R.E.JONES
C 92-09-25 R.E.JONES CHANGE TO 25 WORDS OF INPUT, LEVEL
C CAN BE IN TWO WORDS. (10,11)
C 93-01-08 R.E.JONES CHANGE FOR TIME RANGE INDICATOR IF 10,
C STORE TIME P1 IN PDS BYTES 19-20.
C 93-01-26 R.E.JONES CORRECTION FOR FIXED HEIGHT ABOVE
C GROUND LEVEL
C 93-03-29 R.E.JONES ADD SAVE STATEMENT
C 93-06-24 CAVANOUGH MODIFIED PROGRAM TO ALLOW FOR GENERATION
C OF PDS GREATER THAN 28 BYTES (THE DESIRED
C PDS SIZE IS IN ID(1).
C 93-09-30 FARLEY CHANGE TO ALLOW FOR SUBCENTER ID; PUT
C ID(24) INTO PDS(26).
C 93-10-12 R.E.JONES CHANGES FOR ON388 REV. OCT 9,1993, NEW
C LEVELS 125, 200, 201.
C 94-02-23 R.E.JONES TAKE OUT SBYTES, REPLACE WITH DO LOOP
C 94-04-14 R.E.JONES CHANGES FOR ON388 REV. MAR 24,1994, NEW
C LEVELS 115,116.
C 94-12-04 R.E.JONES CHANGE TO ADD ID WORDS 26, 27 FOR PDS
C BYTES 29 AND 30.
C 95-09-07 R.E.JONES CHANGE FOR NEW LEVEL 117, 119.
C 95-10-31 IREDELL REMOVED SAVES AND PRINTS
C 98-06-30 EBISUZAKI LINUX PORT
C 2001-06-05 GILBERT Changed fortran intrinsic function OR() to
C f90 standard intrinsic IOR().
C 2003-02-25 IREDELL RECOGNIZE LEVEL TYPE 126
C 2005-05-06 D.C.STOKES RECOGNIZE LEVEL TYPES 235, 237, 238
C
C USAGE: CALL W3FI68 (ID, PDS)
C INPUT ARGUMENT LIST:
C ID - 25, 27 WORD INTEGER ARRAY
C OUTPUT ARGUMENT LIST:
C PDS - 28 30, OR GREATER CHARACTER PDS FOR EDITION 1
C
C REMARKS: LAYOUT OF 'ID' ARRAY:
C ID(1) = NUMBER OF BYTES IN PRODUCT DEFINITION SECTION (PDS)
C ID(2) = PARAMETER TABLE VERSION NUMBER
C ID(3) = IDENTIFICATION OF ORIGINATING CENTER
C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
C ID(5) = GRID IDENTIFICATION
C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
C ID(8) = INDICATOR OF PARAMETER AND UNITS (TABLE 2)
C ID(9) = INDICATOR OF TYPE OF LEVEL (TABLE 3)
C ID(10) = VALUE 1 OF LEVEL (0 FOR 1-100,102,103,105,107
C 109,111,113,115,117,119,125,126,160,200,201,
C 235,237,238
C LEVEL IS IN ID WORD 11)
C ID(11) = VALUE 2 OF LEVEL
C ID(12) = YEAR OF CENTURY
C ID(13) = MONTH OF YEAR
C ID(14) = DAY OF MONTH
C ID(15) = HOUR OF DAY
C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0)
C ID(17) = FCST TIME UNIT
C ID(18) = P1 PERIOD OF TIME
C ID(19) = P2 PERIOD OF TIME
C ID(20) = TIME RANGE INDICATOR
C ID(21) = NUMBER INCLUDED IN AVERAGE
C ID(22) = NUMBER MISSING FROM AVERAGES
C ID(23) = CENTURY (20, CHANGE TO 21 ON JAN. 1, 2001)
C ID(24) = SUBCENTER IDENTIFICATION
C ID(25) = SCALING POWER OF 10
C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS
C BIT NUMBER VALUE ID(26) DEFINITION
C 1 0 0 FULL FCST FIELD
C 1 128 FCST ERROR FIELD
C 2 0 0 ORIGINAL FCST FIELD
C 1 64 BIAS CORRECTED FCST FIELD
C 3 0 0 ORIGINAL RESOLUTION RETAINED
C 1 32 SMOOTHED FIELD
C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3.
C BITS 4-8 NOT USED, SET TO ZERO
C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27).
C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO.
C
C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C ATTRIBUTES:
C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77
C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY C916/256, J916/2048
C
C$$$
C
INTEGER ID(*)
C
CHARACTER * 1 PDS(*)
C
PDS(1) = CHAR(MOD(ID(1)/65536,256))
PDS(2) = CHAR(MOD(ID(1)/256,256))
PDS(3) = CHAR(MOD(ID(1),256))
PDS(4) = CHAR(ID(2))
PDS(5) = CHAR(ID(3))
PDS(6) = CHAR(ID(4))
PDS(7) = CHAR(ID(5))
i = 0
if (ID(6).ne.0) i = i + 128
if (ID(7).ne.0) i = i + 64
PDS(8) = char(i)
PDS(9) = CHAR(ID(8))
PDS(10) = CHAR(ID(9))
I9 = ID(9)
C
C TEST TYPE OF LEVEL TO SEE IF LEVEL IS IN TWO
C WORDS OR ONE
C
IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR.
& I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR.
& I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR.
& I9.EQ.115.OR.I9.EQ.117.OR.I9.EQ.119.OR.
& I9.EQ.125.OR.I9.EQ.126.OR.I9.EQ.160.OR.
& I9.EQ.200.OR.I9.EQ.201.OR.I9.EQ.235.OR.
& I9.EQ.237.OR.I9.EQ.238) THEN
LEVEL = ID(11)
IF (LEVEL.LT.0) THEN
LEVEL = - LEVEL
LEVEL = IOR(LEVEL,32768)
END IF
PDS(11) = CHAR(MOD(LEVEL/256,256))
PDS(12) = CHAR(MOD(LEVEL,256))
ELSE
PDS(11) = CHAR(ID(10))
PDS(12) = CHAR(ID(11))
END IF
PDS(13) = CHAR(ID(12))
PDS(14) = CHAR(ID(13))
PDS(15) = CHAR(ID(14))
PDS(16) = CHAR(ID(15))
PDS(17) = CHAR(ID(16))
PDS(18) = CHAR(ID(17))
C
C TEST TIME RANGE INDICATOR (PDS BYTE 21) FOR 10
C IF SO PUT TIME P1 IN PDS BYTES 19-20.
C
IF (ID(20).EQ.10) THEN
PDS(19) = CHAR(MOD(ID(18)/256,256))
PDS(20) = CHAR(MOD(ID(18),256))
ELSE
PDS(19) = CHAR(ID(18))
PDS(20) = CHAR(ID(19))
END IF
PDS(21) = CHAR(ID(20))
PDS(22) = CHAR(MOD(ID(21)/256,256))
PDS(23) = CHAR(MOD(ID(21),256))
PDS(24) = CHAR(ID(22))
PDS(25) = CHAR(ID(23))
PDS(26) = CHAR(ID(24))
ISCALE = ID(25)
IF (ISCALE.LT.0) THEN
ISCALE = -ISCALE
ISCALE = IOR(ISCALE,32768)
END IF
PDS(27) = CHAR(MOD(ISCALE/256,256))
PDS(28) = CHAR(MOD(ISCALE ,256))
IF (ID(1).GT.28) THEN
PDS(29) = CHAR(ID(26))
PDS(30) = CHAR(ID(27))
END IF
C
C SET PDS 31-?? TO ZERO
C
IF (ID(1).GT.30) THEN
K = ID(1)
DO I = 31,K
PDS(I) = CHAR(0)
END DO
END IF
C
RETURN
END