NCEPLIBS-w3emc/w3fi68_8f_source.html

C> @file

C> @brief Convert 25 word array to GRIB pds.

C> @author Ralph Jones @date 1991-05-08


C> 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> - Ralph Jones 1991-05-08

C> - Ralph Jones 1992-09-25 Change to 25 words of input, level

C> can be in two words. (10,11)

C> - Ralph Jones 1993-01-08 Change for time range indicator if 10,

C> store time p1 in pds bytes 19-20.

C> - Ralph Jones 1993-01-26 Correction for fixed height above

C> ground level

C> - Ralph Jones 1993-03-29 Add save statement

C> - Bill Cavanaugh 1993-06-24 Modified program to allow for generation

C> of pds greater than 28 bytes (the desired

C> pds size is in id(1).

C> - Farley 1993-09-30 Change to allow for subcenter id; put

C> id(24) into pds(26).

C> - Ralph Jones 1993-10-12 Changes for on388 rev. oct 9,1993, new

C> levels 125, 200, 201.

C> - Ralph Jones 1994-02-23 Take out sbytes, replace with do loop

C> - Ralph Jones 1994-04-14 Changes for on388 rev. mar 24,1994, new

C> levels 115,116.

C> - Ralph Jones 1994-12-04 Change to add id words 26, 27 for pds

C> bytes 29 and 30.

C> - Ralph Jones 1995-09-07 Change for new level 117, 119.

C> - Mark Iredell 1995-10-31 REmoved saves and prints

C> - Ebisuzaki 1998-06-30 Linux port

C> - Stephen Gilbert 2001-06-05 Changed fortran intrinsic function OR() to

C> f90 standard intrinsic IOR().

C> - Mark Iredell 2003-02-25 Recognize level type 126

C> - D. C. Stokes 2005-05-06 Recognize level types 235, 237, 238

C>

C> @param[in] ID 25,27 word integer array.

C> @param[out] PDS 28 30 or greater character pds for edition 1.

C>

C> @note 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,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>          | :--------- | :---  | :---  | : ----------- |

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> @author Ralph Jones @date 1991-05-08


      SUBROUTINE w3fi68 (ID, PDS)

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

w3fi68
subroutine w3fi68(id, pds)
Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes...
Definition w3fi68.f:85