ungrib/src/ngl/w3/w3fi68.f

   1       SUBROUTINE W3FI68 (ID, PDS)
   2 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   3 C                .      .    .                                       .
   4 C SUBPROGRAM:    W3FI68      CONVERT 25 WORD ARRAY TO GRIB PDS
   5 C   PRGMMR: R.E.JONES        ORG: W/NMC42    DATE: 91-05-14
   6 C
   7 C ABSTRACT: CONVERTS AN ARRAY OF 25, OR 27 INTEGER WORDS INTO A
   8 C   GRIB PRODUCT DEFINITION SECTION (PDS) OF 28 BYTES , OR 30 BYTES.
   9 C   IF PDS BYTES > 30, THEY ARE SET TO ZERO.
  10 C
  11 C PROGRAM HISTORY LOG:
  12 C   91-05-08  R.E.JONES
  13 C   92-09-25  R.E.JONES   CHANGE TO 25 WORDS OF INPUT, LEVEL
  14 C                         CAN BE IN TWO WORDS. (10,11)
  15 C   93-01-08  R.E.JONES   CHANGE FOR TIME RANGE INDICATOR IF 10,
  16 C                         STORE TIME P1 IN PDS BYTES 19-20.
  17 C   93-01-26  R.E.JONES   CORRECTION FOR FIXED HEIGHT ABOVE
  18 C                         GROUND LEVEL
  19 C   93-03-29  R.E.JONES   ADD SAVE STATEMENT
  20 C   93-06-24  CAVANOUGH   MODIFIED PROGRAM TO ALLOW FOR GENERATION
  21 C                         OF PDS GREATER THAN 28 BYTES (THE DESIRED
  22 C                         PDS SIZE IS IN ID(1).
  23 C   93-09-30  FARLEY      CHANGE TO ALLOW FOR SUBCENTER ID; PUT
  24 C                         ID(24) INTO PDS(26).
  25 C   93-10-12  R.E.JONES   CHANGES FOR ON388 REV. OCT 9,1993, NEW
  26 C                         LEVELS 125, 200, 201.
  27 C   94-02-23  R.E.JONES   TAKE OUT SBYTES, REPLACE WITH DO LOOP
  28 C   94-04-14  R.E.JONES   CHANGES FOR ON388 REV. MAR 24,1994, NEW
  29 C                         LEVELS 115,116.
  30 C   94-12-04  R.E.JONES   CHANGE TO ADD ID WORDS 26, 27 FOR PDS
  31 C                         BYTES 29 AND 30.
  32 C   95-09-07  R.E.JONES   CHANGE FOR NEW LEVEL 117, 119.
  33 C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
  34 C   98-06-30  EBISUZAKI   LINUX PORT
  35 C 2001-06-05  GILBERT     Changed fortran intrinsic function OR() to
  36 C                         f90 standard intrinsic IOR().
  37 C 2003-02-25  IREDELL     RECOGNIZE LEVEL TYPE 126
  38 C 2005-05-06  D.C.STOKES  RECOGNIZE LEVEL TYPES 235, 237, 238
  39 C
  40 C USAGE:    CALL W3FI68 (ID, PDS)
  41 C   INPUT ARGUMENT LIST:
  42 C     ID       - 25, 27 WORD INTEGER ARRAY
  43 C   OUTPUT ARGUMENT LIST:
  44 C     PDS      - 28 30,  OR GREATER CHARACTER PDS FOR EDITION 1
  45 C
  46 C REMARKS: LAYOUT OF 'ID' ARRAY:
  47 C     ID(1)  = NUMBER OF BYTES IN PRODUCT DEFINITION SECTION (PDS)
  48 C     ID(2)  = PARAMETER TABLE VERSION NUMBER
  49 C     ID(3)  = IDENTIFICATION OF ORIGINATING CENTER
  50 C     ID(4)  = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
  51 C     ID(5)  = GRID IDENTIFICATION
  52 C     ID(6)  = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
  53 C     ID(7)  = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
  54 C     ID(8)  = INDICATOR OF PARAMETER AND UNITS (TABLE 2)
  55 C     ID(9)  = INDICATOR OF TYPE OF LEVEL       (TABLE 3)
  56 C     ID(10) = VALUE 1 OF LEVEL  (0 FOR 1-100,102,103,105,107
  57 C              109,111,113,115,117,119,125,126,160,200,201,
  58 C              235,237,238
  59 C              LEVEL IS IN ID WORD 11)
  60 C     ID(11) = VALUE 2 OF LEVEL
  61 C     ID(12) = YEAR OF CENTURY
  62 C     ID(13) = MONTH OF YEAR
  63 C     ID(14) = DAY OF MONTH
  64 C     ID(15) = HOUR OF DAY
  65 C     ID(16) = MINUTE OF HOUR   (IN MOST CASES SET TO 0)
  66 C     ID(17) = FCST TIME UNIT
  67 C     ID(18) = P1 PERIOD OF TIME
  68 C     ID(19) = P2 PERIOD OF TIME
  69 C     ID(20) = TIME RANGE INDICATOR
  70 C     ID(21) = NUMBER INCLUDED IN AVERAGE
  71 C     ID(22) = NUMBER MISSING FROM AVERAGES
  72 C     ID(23) = CENTURY  (20, CHANGE TO 21 ON JAN. 1, 2001)
  73 C     ID(24) = SUBCENTER IDENTIFICATION
  74 C     ID(25) = SCALING POWER OF 10
  75 C     ID(26) = FLAG BYTE, 8 ON/OFF FLAGS
  76 C              BIT NUMBER  VALUE  ID(26)   DEFINITION
  77 C              1           0      0      FULL FCST FIELD
  78 C                          1      128    FCST ERROR FIELD
  79 C              2           0      0      ORIGINAL FCST FIELD
  80 C                          1      64     BIAS CORRECTED FCST FIELD
  81 C              3           0      0      ORIGINAL RESOLUTION RETAINED
  82 C                          1      32     SMOOTHED FIELD
  83 C              NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3.
  84 C              BITS 4-8 NOT USED, SET TO ZERO
  85 C              IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27).
  86 C     ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO.
  87 C
  88 C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  89 C
  90 C ATTRIBUTES:
  91 C   LANGUAGE: SiliconGraphics 3.5 FORTRAN 77
  92 C   MACHINE:  SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy
  93 C   LANGUAGE: CRAY CFT77 FORTRAN
  94 C   MACHINE:  CRAY C916/256, J916/2048
  95 C
  96 C$$$
  97 C
  98       INTEGER        ID(*)
  99 C
 100       CHARACTER * 1  PDS(*)
 101 C
 102         PDS(1)  = CHAR(MOD(ID(1)/65536,256))
 103         PDS(2)  = CHAR(MOD(ID(1)/256,256))
 104         PDS(3)  = CHAR(MOD(ID(1),256))
 105         PDS(4)  = CHAR(ID(2))
 106         PDS(5)  = CHAR(ID(3))
 107         PDS(6)  = CHAR(ID(4))
 108         PDS(7)  = CHAR(ID(5))
 109         i = 0
 110         if (ID(6).ne.0) i = i + 128
 111         if (ID(7).ne.0) i = i + 64
 112         PDS(8) = char(i)
 113
 114         PDS(9)  = CHAR(ID(8))
 115         PDS(10) = CHAR(ID(9))
 116         I9      = ID(9)
 117 C
 118 C       TEST TYPE OF LEVEL TO SEE IF LEVEL IS IN TWO
 119 C       WORDS OR ONE
 120 C
 121         IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR.
 122      &       I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR.
 123      &       I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR.
 124      &       I9.EQ.115.OR.I9.EQ.117.OR.I9.EQ.119.OR.
 125      &       I9.EQ.125.OR.I9.EQ.126.OR.I9.EQ.160.OR.
 126      &       I9.EQ.200.OR.I9.EQ.201.OR.I9.EQ.235.OR.
 127      &       I9.EQ.237.OR.I9.EQ.238) THEN
 128           LEVEL   = ID(11)
 129           IF (LEVEL.LT.0) THEN
 130             LEVEL = - LEVEL
 131             LEVEL = IOR(LEVEL,32768)
 132           END IF
 133           PDS(11) = CHAR(MOD(LEVEL/256,256))
 134           PDS(12) = CHAR(MOD(LEVEL,256))
 135         ELSE
 136           PDS(11) = CHAR(ID(10))
 137           PDS(12) = CHAR(ID(11))
 138         END IF
 139         PDS(13) = CHAR(ID(12))
 140         PDS(14) = CHAR(ID(13))
 141         PDS(15) = CHAR(ID(14))
 142         PDS(16) = CHAR(ID(15))
 143         PDS(17) = CHAR(ID(16))
 144         PDS(18) = CHAR(ID(17))
 145 C
 146 C       TEST TIME RANGE INDICATOR (PDS BYTE 21) FOR 10
 147 C       IF SO PUT TIME P1 IN PDS BYTES 19-20.
 148 C
 149         IF (ID(20).EQ.10) THEN
 150           PDS(19) = CHAR(MOD(ID(18)/256,256))
 151           PDS(20) = CHAR(MOD(ID(18),256))
 152         ELSE
 153           PDS(19) = CHAR(ID(18))
 154           PDS(20) = CHAR(ID(19))
 155         END IF
 156         PDS(21) = CHAR(ID(20))
 157         PDS(22) = CHAR(MOD(ID(21)/256,256))
 158         PDS(23) = CHAR(MOD(ID(21),256))
 159         PDS(24) = CHAR(ID(22))
 160         PDS(25) = CHAR(ID(23))
 161         PDS(26) = CHAR(ID(24))
 162         ISCALE  = ID(25)
 163         IF (ISCALE.LT.0) THEN
 164           ISCALE = -ISCALE
 165           ISCALE =  IOR(ISCALE,32768)
 166         END IF
 167         PDS(27) = CHAR(MOD(ISCALE/256,256))
 168         PDS(28) = CHAR(MOD(ISCALE    ,256))
 169         IF (ID(1).GT.28) THEN
 170           PDS(29) = CHAR(ID(26))
 171           PDS(30) = CHAR(ID(27))
 172         END IF
 173 C
 174 C       SET PDS 31-?? TO ZERO
 175 C
 176         IF (ID(1).GT.30) THEN
 177           K = ID(1)
 178           DO I = 31,K
 179             PDS(I) = CHAR(0)
 180           END DO
 181         END IF
 182 C
 183       RETURN
 184       END