ungrib/src/ngl/w3/w3fi74.f

   1       SUBROUTINE W3FI74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR)
   2 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   3 C                .      .    .                                       .
   4 C SUBPROGRAM:    W3FI74      CONSTRUCT GRID DEFINITION SECTION (GDS)
   5 C   PRGMMR: FARLEY           ORG: W/NMC42    DATE: 93-08-24
   6 C
   7 C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB GRID DEFINITION
   8 C   SECTION.
   9 C
  10 C PROGRAM HISTORY LOG:
  11 C   92-07-07  M. FARLEY   ORIGINAL AUTHOR
  12 C   92-10-16  R.E.JONES   ADD CODE TO LAT/LON SECTION TO DO
  13 C                         GAUSSIAN GRIDS.
  14 C   93-03-29  R.E.JONES   ADD SAVE STATEMENT
  15 C   93-08-24  R.E.JONES   CHANGES FOR GRIB GRIDS 37-44
  16 C   93-09-29  R.E.JONES   CHANGES FOR GAUSSIAN GRID FOR DOCUMENT
  17 C                         CHANGE IN W3FI71.
  18 C   94-02-15  R.E.JONES   CHANGES FOR ETA MODEL GRIDS 90-93
  19 C   95-04-20  R.E.JONES   CHANGE 200 AND 201 TO 201 AND 202
  20 C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
  21 C   98-08-20  BALDWIN     ADD TYPE 203
  22 C   07-03-20  VUONG       ADD TYPE 204
  23 C   10-01-21  GAYNO       ADD GRID 205 - ROTATED LAT/LON A,B,C,D STAGGERS
  24 C
  25 C
  26 C USAGE:    CALL W3FI74 (IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
  27 C   INPUT ARGUMENT LIST:
  28 C     IGDS        - INTEGER ARRAY SUPPLIED BY W3FI71
  29 C     ICOMP       - TABLE 7- RESOLUTION & COMPONENT FLAG (BIT 5)
  30 C                   FOR GDS(17) WIND COMPONENTS
  31 C
  32 C   OUTPUT ARGUMENT LIST:
  33 C     GDS       - COMPLETED GRIB GRID DEFINITION SECTION
  34 C     LENGDS    - LENGTH OF GDS
  35 C     NPTS      - NUMBER OF POINTS IN GRID
  36 C     IGERR     - 1, GRID REPRESENTATION TYPE NOT VALID
  37 C
  38 C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  39 C
  40 C ATTRIBUTES:
  41 C   LANGUAGE: CRAY CFT77 FORTRAN 77, IBM370 VS FORTRAN
  42 C   MACHINE:  CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256, HDS
  43 C
  44 C$$$
  45 C
  46       INTEGER       IGDS  (*)
  47 C
  48       CHARACTER*1   GDS   (*)
  49 C
  50       ISUM  = 0
  51       IGERR = 0
  52 C
  53 C       PRINT *,' '
  54 C       PRINT *,'(W3FI74-IGDS = )'
  55 C       PRINT *,(IGDS(I),I=1,18)
  56 C       PRINT *,' '
  57 C
  58 C     COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3)
  59 C       LENGDS =  32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON,
  60 C                    POLAR STEREOGRAPHIC, SPHERICAL HARMONICS,
  61 C                    ROTATED LAT/LON E-STAGGER
  62 C       LENGDS =  34 ROTATED LAT/LON A,B,C,D STAGGERS
  63 C       LENGDS =  42 FOR MERCATOR, LAMBERT, TANGENT CONE
  64 C       LENGDS = 178 FOR MERCATOR, LAMBERT, TANGENT CONE
  65 C
  66       IF (IGDS(3) .EQ. 0  .OR.  IGDS(3) .EQ. 2  .OR.
  67      &    IGDS(3) .EQ. 4  .OR.  IGDS(3) .EQ. 5  .OR.
  68      &    IGDS(3) .EQ. 50 .OR.  IGDS(3) .EQ. 201.OR.
  69      &    IGDS(3) .EQ. 202.OR.  IGDS(3) .EQ. 203.OR.
  70      &    IGDS(3) .EQ. 204 ) THEN
  71           LENGDS = 32
  72 C
  73 C       CORRECTION FOR GRIDS 37-44
  74 C
  75         IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE.
  76      &  255) THEN
  77           LENGDS = IGDS(5) * 2 + 32
  78         ENDIF
  79       ELSE IF (IGDS(3) .EQ. 1  .OR.  IGDS(3) .EQ. 3  .OR.
  80      &         IGDS(3) .EQ. 13) THEN
  81         LENGDS = 42
  82       ELSE IF (IGDS(3) .EQ. 205) THEN
  83         LENGDS = 34
  84       ELSE
  85 C       PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID'
  86         IGERR = 1
  87         RETURN
  88       ENDIF
  89 C
  90 C     PUT LENGTH OF GDS SECTION IN BYTES 1,2,3
  91 C
  92       GDS(1) = CHAR(MOD(LENGDS/65536,256))
  93       GDS(2) = CHAR(MOD(LENGDS/  256,256))
  94       GDS(3) = CHAR(MOD(LENGDS      ,256))
  95 C
  96 C     OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS
  97 C     OCTET 5 = PV, PL OR 255
  98 C     OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6)
  99 C
 100       GDS(4) = CHAR(IGDS(1))
 101       GDS(5) = CHAR(IGDS(2))
 102       GDS(6) = CHAR(IGDS(3))
 103 C
 104 C     FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION
 105 C     TYPE (TABLE 6)
 106 C
 107 C$$
 108 C     PROCESS ROTATED LAT/LON A,B,C,D STAGGERS
 109 C
 110       IF (IGDS(3).EQ.205) THEN
 111         GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
 112         GDS( 8) = CHAR(MOD(IGDS(4)    ,256))
 113         GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
 114         GDS(10) = CHAR(MOD(IGDS(5)    ,256))
 115         LATO    = IGDS(6) ! LAT OF FIRST POINT
 116         IF (LATO .LT. 0) THEN
 117           LATO = -LATO
 118           LATO = IOR(LATO,8388608)
 119         ENDIF
 120         GDS(11) = CHAR(MOD(LATO/65536,256))
 121         GDS(12) = CHAR(MOD(LATO/  256,256))
 122         GDS(13) = CHAR(MOD(LATO      ,256))
 123         LONO    = IGDS(7) ! LON OF FIRST POINT
 124         IF (LONO .LT. 0) THEN
 125           LONO = -LONO
 126           LONO = IOR(LONO,8388608)
 127         ENDIF
 128         GDS(14) = CHAR(MOD(LONO/65536,256))
 129         GDS(15) = CHAR(MOD(LONO/  256,256))
 130         GDS(16) = CHAR(MOD(LONO      ,256))
 131         LATEXT  = IGDS(9)  ! CENTER LAT
 132         IF (LATEXT .LT. 0) THEN
 133           LATEXT = -LATEXT
 134           LATEXT = IOR(LATEXT,8388608)
 135         ENDIF
 136         GDS(18) = CHAR(MOD(LATEXT/65536,256))
 137         GDS(19) = CHAR(MOD(LATEXT/  256,256))
 138         GDS(20) = CHAR(MOD(LATEXT      ,256))
 139         LONEXT  = IGDS(10) ! CENTER LON
 140         IF (LONEXT .LT. 0) THEN
 141           LONEXT = -LONEXT
 142           LONEXT = IOR(LONEXT,8388608)
 143         ENDIF
 144         GDS(21) = CHAR(MOD(LONEXT/65536,256))
 145         GDS(22) = CHAR(MOD(LONEXT/  256,256))
 146         GDS(23) = CHAR(MOD(LONEXT      ,256))
 147         GDS(24) = CHAR(MOD(IGDS(11)/256,256))
 148         GDS(25) = CHAR(MOD(IGDS(11)    ,256))
 149         GDS(26) = CHAR(MOD(IGDS(12)/256,256))
 150         GDS(27) = CHAR(MOD(IGDS(12)    ,256))
 151         GDS(28) = CHAR(IGDS(13))
 152         LATO    = IGDS(14) ! LAT OF LAST POINT
 153         IF (LATO .LT. 0) THEN
 154           LATO = -LATO
 155           LATO = IOR(LATO,8388608)
 156         ENDIF
 157         GDS(29) = CHAR(MOD(LATO/65536,256))
 158         GDS(30) = CHAR(MOD(LATO/  256,256))
 159         GDS(31) = CHAR(MOD(LATO      ,256))
 160         LONO    = IGDS(15) ! LON OF LAST POINT
 161         IF (LONO .LT. 0) THEN
 162           LONO = -LONO
 163           LONO = IOR(LONO,8388608)
 164         ENDIF
 165         GDS(32) = CHAR(MOD(LONO/65536,256))
 166         GDS(33) = CHAR(MOD(LONO/  256,256))
 167         GDS(34) = CHAR(MOD(LONO      ,256))
 168 C
 169 C     PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA
 170 C     STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS
 171 C
 172       ELSEIF (IGDS(3).EQ.0.OR.IGDS(3).EQ.4.OR.
 173      &    IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR.
 174      &    IGDS(3).EQ.203.OR.IGDS(3).EQ.204) THEN
 175         GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
 176         GDS( 8) = CHAR(MOD(IGDS(4)    ,256))
 177         GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
 178         GDS(10) = CHAR(MOD(IGDS(5)    ,256))
 179         LATO    = IGDS(6)
 180         IF (LATO .LT. 0) THEN
 181           LATO = -LATO
 182           LATO = IOR(LATO,8388608)
 183         ENDIF
 184         GDS(11) = CHAR(MOD(LATO/65536,256))
 185         GDS(12) = CHAR(MOD(LATO/  256,256))
 186         GDS(13) = CHAR(MOD(LATO      ,256))
 187         LONO    = IGDS(7)
 188         IF (LONO .LT. 0) THEN
 189           LONO = -LONO
 190           LONO = IOR(LONO,8388608)
 191         ENDIF
 192         GDS(14) = CHAR(MOD(LONO/65536,256))
 193         GDS(15) = CHAR(MOD(LONO/  256,256))
 194         GDS(16) = CHAR(MOD(LONO      ,256))
 195         LATEXT  = IGDS(9)
 196         IF (LATEXT .LT. 0) THEN
 197           LATEXT = -LATEXT
 198           LATEXT = IOR(LATEXT,8388608)
 199         ENDIF
 200         GDS(18) = CHAR(MOD(LATEXT/65536,256))
 201         GDS(19) = CHAR(MOD(LATEXT/  256,256))
 202         GDS(20) = CHAR(MOD(LATEXT      ,256))
 203         LONEXT  = IGDS(10)
 204         IF (LONEXT .LT. 0) THEN
 205           LONEXT = -LONEXT
 206           LONEXT = IOR(LONEXT,8388608)
 207         ENDIF
 208         GDS(21) = CHAR(MOD(LONEXT/65536,256))
 209         GDS(22) = CHAR(MOD(LONEXT/  256,256))
 210         GDS(23) = CHAR(MOD(LONEXT      ,256))
 211         IRES    = IAND(IGDS(8),128)
 212         IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR.
 213      &      IGDS(3).EQ.203.OR.IGDS(3).EQ.204) THEN
 214           GDS(24) = CHAR(MOD(IGDS(11)/256,256))
 215           GDS(25) = CHAR(MOD(IGDS(11)    ,256))
 216         ELSE IF (IRES.EQ.0) THEN
 217           GDS(24) = CHAR(255)
 218           GDS(25) = CHAR(255)
 219         ELSE
 220           GDS(24) = CHAR(MOD(IGDS(12)/256,256))
 221           GDS(25) = CHAR(MOD(IGDS(12)    ,256))
 222         END IF
 223         IF (IGDS(3).EQ.4) THEN
 224           GDS(26) = CHAR(MOD(IGDS(11)/256,256))
 225           GDS(27) = CHAR(MOD(IGDS(11)    ,256))
 226         ELSE IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR.
 227      &           IGDS(3).EQ.203.OR.IGDS(3).EQ.204)THEN
 228           GDS(26) = CHAR(MOD(IGDS(12)/256,256))
 229           GDS(27) = CHAR(MOD(IGDS(12)    ,256))
 230         ELSE IF (IRES.EQ.0) THEN
 231           GDS(26) = CHAR(255)
 232           GDS(27) = CHAR(255)
 233         ELSE
 234           GDS(26) = CHAR(MOD(IGDS(11)/256,256))
 235           GDS(27) = CHAR(MOD(IGDS(11)    ,256))
 236         END IF
 237         GDS(28) = CHAR(IGDS(13))
 238         GDS(29) = CHAR(0)
 239         GDS(30) = CHAR(0)
 240         GDS(31) = CHAR(0)
 241         GDS(32) = CHAR(0)
 242         IF (LENGDS.GT.32) THEN
 243           ISUM = 0
 244           I    = 19
 245           DO 10 J = 33,LENGDS,2
 246             ISUM     = ISUM + IGDS(I)
 247             GDS(J)   = CHAR(MOD(IGDS(I)/256,256))
 248             GDS(J+1) = CHAR(MOD(IGDS(I)    ,256))
 249             I        = I + 1
 250  10       CONTINUE
 251         END IF
 252 C
 253 C$$     PROCESS MERCATOR GRID TYPES
 254 C
 255       ELSE IF (IGDS(3) .EQ. 1) THEN
 256         GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
 257         GDS( 8) = CHAR(MOD(IGDS(4)    ,256))
 258         GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
 259         GDS(10) = CHAR(MOD(IGDS(5)    ,256))
 260         LATO = IGDS(6)
 261         IF (LATO .LT. 0) THEN
 262           LATO = -LATO
 263           LATO = IOR(LATO,8388608)
 264         ENDIF
 265         GDS(11) = CHAR(MOD(LATO/65536,256))
 266         GDS(12) = CHAR(MOD(LATO/  256,256))
 267         GDS(13) = CHAR(MOD(LATO      ,256))
 268         LONO = IGDS(7)
 269         IF (LONO .LT. 0) THEN
 270           LONO = -LONO
 271           LONO = IOR(LONO,8388608)
 272         ENDIF
 273         GDS(14) = CHAR(MOD(LONO/65536,256))
 274         GDS(15) = CHAR(MOD(LONO/  256,256))
 275         GDS(16) = CHAR(MOD(LONO      ,256))
 276         LATEXT = IGDS(9)
 277         IF (LATEXT .LT. 0) THEN
 278           LATEXT = -LATEXT
 279           LATEXT = IOR(LATEXT,8388608)
 280         ENDIF
 281         GDS(18) = CHAR(MOD(LATEXT/65536,256))
 282         GDS(19) = CHAR(MOD(LATEXT/  256,256))
 283         GDS(20) = CHAR(MOD(LATEXT      ,256))
 284         LONEXT  = IGDS(10)
 285         IF (LONEXT .LT. 0) THEN
 286           LONEXT = -LONEXT
 287           LONEXT = IOR(LONEXT,8388608)
 288         ENDIF
 289         GDS(21) = CHAR(MOD(LONEXT/65536,256))
 290         GDS(22) = CHAR(MOD(LONEXT/  256,256))
 291         GDS(23) = CHAR(MOD(LONEXT      ,256))
 292         GDS(24) = CHAR(MOD(IGDS(13)/65536,256))
 293         GDS(25) = CHAR(MOD(IGDS(13)/  256,256))
 294         GDS(26) = CHAR(MOD(IGDS(13)      ,256))
 295         GDS(27) = CHAR(0)
 296         GDS(28) = CHAR(IGDS(14))
 297         GDS(29) = CHAR(MOD(IGDS(12)/65536,256))
 298         GDS(30) = CHAR(MOD(IGDS(12)/  256,256))
 299         GDS(31) = CHAR(MOD(IGDS(12)      ,256))
 300         GDS(32) = CHAR(MOD(IGDS(11)/65536,256))
 301         GDS(33) = CHAR(MOD(IGDS(11)/  256,256))
 302         GDS(34) = CHAR(MOD(IGDS(11)      ,256))
 303         GDS(35) = CHAR(0)
 304         GDS(36) = CHAR(0)
 305         GDS(37) = CHAR(0)
 306         GDS(38) = CHAR(0)
 307         GDS(39) = CHAR(0)
 308         GDS(40) = CHAR(0)
 309         GDS(41) = CHAR(0)
 310         GDS(42) = CHAR(0)
 311 C$$     PROCESS LAMBERT CONFORMAL GRID TYPES
 312       ELSE IF (IGDS(3) .EQ. 3) THEN
 313         GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
 314         GDS( 8) = CHAR(MOD(IGDS(4)    ,256))
 315         GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
 316         GDS(10) = CHAR(MOD(IGDS(5)    ,256))
 317         LATO = IGDS(6)
 318         IF (LATO .LT. 0) THEN
 319           LATO = -LATO
 320           LATO = IOR(LATO,8388608)
 321         ENDIF
 322         GDS(11) = CHAR(MOD(LATO/65536,256))
 323         GDS(12) = CHAR(MOD(LATO/  256,256))
 324         GDS(13) = CHAR(MOD(LATO      ,256))
 325         LONO = IGDS(7)
 326         IF (LONO .LT. 0) THEN
 327           LONO = -LONO
 328           LONO = IOR(LONO,8388608)
 329         ENDIF
 330         GDS(14) = CHAR(MOD(LONO/65536,256))
 331         GDS(15) = CHAR(MOD(LONO/  256,256))
 332         GDS(16) = CHAR(MOD(LONO      ,256))
 333         LONM = IGDS(9)
 334         IF (LONM .LT. 0) THEN
 335           LONM = -LONM
 336           LONM = IOR(LONM,8388608)
 337         ENDIF
 338         GDS(18) = CHAR(MOD(LONM/65536,256))
 339         GDS(19) = CHAR(MOD(LONM/  256,256))
 340         GDS(20) = CHAR(MOD(LONM      ,256))
 341         GDS(21) = CHAR(MOD(IGDS(10)/65536,256))
 342         GDS(22) = CHAR(MOD(IGDS(10)/  256,256))
 343         GDS(23) = CHAR(MOD(IGDS(10)      ,256))
 344         GDS(24) = CHAR(MOD(IGDS(11)/65536,256))
 345         GDS(25) = CHAR(MOD(IGDS(11)/  256,256))
 346         GDS(26) = CHAR(MOD(IGDS(11)      ,256))
 347         GDS(27) = CHAR(IGDS(12))
 348         GDS(28) = CHAR(IGDS(13))
 349         GDS(29) = CHAR(MOD(IGDS(15)/65536,256))
 350         GDS(30) = CHAR(MOD(IGDS(15)/  256,256))
 351         GDS(31) = CHAR(MOD(IGDS(15)      ,256))
 352         GDS(32) = CHAR(MOD(IGDS(16)/65536,256))
 353         GDS(33) = CHAR(MOD(IGDS(16)/  256,256))
 354         GDS(34) = CHAR(MOD(IGDS(16)      ,256))
 355         GDS(35) = CHAR(MOD(IGDS(17)/65536,256))
 356         GDS(36) = CHAR(MOD(IGDS(17)/  256,256))
 357         GDS(37) = CHAR(MOD(IGDS(17)      ,256))
 358         GDS(38) = CHAR(MOD(IGDS(18)/65536,256))
 359         GDS(39) = CHAR(MOD(IGDS(18)/  256,256))
 360         GDS(40) = CHAR(MOD(IGDS(18)      ,256))
 361         GDS(41) = CHAR(0)
 362         GDS(42) = CHAR(0)
 363 C$$     PROCESS POLAR STEREOGRAPHIC GRID TYPES
 364       ELSE IF (IGDS(3) .EQ. 5) THEN
 365         GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
 366         GDS( 8) = CHAR(MOD(IGDS(4)    ,256))
 367         GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
 368         GDS(10) = CHAR(MOD(IGDS(5)    ,256))
 369         LATO = IGDS(6)
 370         IF (LATO .LT. 0) THEN
 371           LATO = -LATO
 372           LATO = IOR(LATO,8388608)
 373         ENDIF
 374         GDS(11) = CHAR(MOD(LATO/65536,256))
 375         GDS(12) = CHAR(MOD(LATO/  256,256))
 376         GDS(13) = CHAR(MOD(LATO      ,256))
 377         LONO = IGDS(7)
 378         IF (LONO .LT. 0) THEN
 379           LONO = -LONO
 380           LONO = IOR(LONO,8388608)
 381         ENDIF
 382         GDS(14) = CHAR(MOD(LONO/65536,256))
 383         GDS(15) = CHAR(MOD(LONO/  256,256))
 384         GDS(16) = CHAR(MOD(LONO      ,256))
 385         LONM = IGDS(9)
 386         IF (LONM .LT. 0) THEN
 387           LONM = -LONM
 388           LONM = IOR(LONM,8388608)
 389         ENDIF
 390         GDS(18) = CHAR(MOD(LONM/65536,256))
 391         GDS(19) = CHAR(MOD(LONM/   256,256))
 392         GDS(20) = CHAR(MOD(LONM       ,256))
 393         GDS(21) = CHAR(MOD(IGDS(10)/65536,256))
 394         GDS(22) = CHAR(MOD(IGDS(10)/  256,256))
 395         GDS(23) = CHAR(MOD(IGDS(10)      ,256))
 396         GDS(24) = CHAR(MOD(IGDS(11)/65536,256))
 397         GDS(25) = CHAR(MOD(IGDS(11)/  256,256))
 398         GDS(26) = CHAR(MOD(IGDS(11)      ,256))
 399         GDS(27) = CHAR(IGDS(12))
 400         GDS(28) = CHAR(IGDS(13))
 401         GDS(29) = CHAR(0)
 402         GDS(30) = CHAR(0)
 403         GDS(31) = CHAR(0)
 404         GDS(32) = CHAR(0)
 405       ENDIF
 406 C       PRINT 10,(GDS(IG),IG=1,32)
 407 C10     FORMAT ('  GDS= ',32(1X,Z2.2))
 408 C
 409 C     COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING
 410 C       IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER
 411 C
 412       IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE.
 413      & 255) THEN
 414         NPTS = ISUM
 415       ELSE
 416         NPTS = IGDS(4) * IGDS(5)
 417       ENDIF
 418 C
 419 C     'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS
 420 C       WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA)
 421 C
 422       ICOMP   = ISHFT(ICOMP,3)
 423       GDS(17) = CHAR(IOR(IGDS(8),ICOMP))
 424 C
 425       RETURN
 426       END