368 lines
12 KiB
FortranFixed
368 lines
12 KiB
FortranFixed
|
SUBROUTINE W3FI74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR)
|
||
|
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
|
||
|
C . . . .
|
||
|
C SUBPROGRAM: W3FI74 CONSTRUCT GRID DEFINITION SECTION (GDS)
|
||
|
C PRGMMR: FARLEY ORG: W/NMC42 DATE: 93-08-24
|
||
|
C
|
||
|
C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB GRID DEFINITION
|
||
|
C SECTION.
|
||
|
C
|
||
|
C PROGRAM HISTORY LOG:
|
||
|
C 92-07-07 M. FARLEY ORIGINAL AUTHOR
|
||
|
C 92-10-16 R.E.JONES ADD CODE TO LAT/LON SECTION TO DO
|
||
|
C GAUSSIAN GRIDS.
|
||
|
C 93-03-29 R.E.JONES ADD SAVE STATEMENT
|
||
|
C 93-08-24 R.E.JONES CHANGES FOR GRIB GRIDS 37-44
|
||
|
C 93-09-29 R.E.JONES CHANGES FOR GAUSSIAN GRID FOR DOCUMENT
|
||
|
C CHANGE IN W3FI71.
|
||
|
C 94-02-15 R.E.JONES CHANGES FOR ETA MODEL GRIDS 90-93
|
||
|
C 95-04-20 R.E.JONES CHANGE 200 AND 201 TO 201 AND 202
|
||
|
C 95-10-31 IREDELL REMOVED SAVES AND PRINTS
|
||
|
C 98-08-20 BALDWIN ADD TYPE 203
|
||
|
C
|
||
|
C
|
||
|
C USAGE: CALL W3FI74 (IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
|
||
|
C INPUT ARGUMENT LIST:
|
||
|
C IGDS - INTEGER ARRAY SUPPLIED BY W3FI71
|
||
|
C ICOMP - TABLE 7- RESOLUTION & COMPONENT FLAG (BIT 5)
|
||
|
C FOR GDS(17) WIND COMPONENTS
|
||
|
C
|
||
|
C OUTPUT ARGUMENT LIST:
|
||
|
C GDS - COMPLETED GRIB GRID DEFINITION SECTION
|
||
|
C LENGDS - LENGTH OF GDS
|
||
|
C NPTS - NUMBER OF POINTS IN GRID
|
||
|
C IGERR - 1, GRID REPRESENTATION TYPE NOT VALID
|
||
|
C
|
||
|
C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
|
||
|
C
|
||
|
C ATTRIBUTES:
|
||
|
C LANGUAGE: CRAY CFT77 FORTRAN 77, IBM370 VS FORTRAN
|
||
|
C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256, HDS
|
||
|
C
|
||
|
C$$$
|
||
|
C
|
||
|
INTEGER IGDS (*)
|
||
|
C
|
||
|
CHARACTER*1 GDS (*)
|
||
|
C
|
||
|
C ================================= RCS keyword statements ==========
|
||
|
CHARACTER*68 RCSKW1,RCSKW2
|
||
|
DATA RCSKW1,RCSKW2 / '
|
||
|
.$Source: /fs/hseb/ob72/wfo_rfc/precip_proc/source/gribit/src/RCS/w3fi74.f,v $
|
||
|
. $', '
|
||
|
.$Id: w3fi74.f,v 1.1 2006/05/03 13:44:00 gsood Exp $
|
||
|
. $' /
|
||
|
C ===================================================================
|
||
|
C
|
||
|
C
|
||
|
ISUM = 0
|
||
|
IGERR = 0
|
||
|
C
|
||
|
C PRINT *,' '
|
||
|
C PRINT *,'(W3FI74-IGDS = )'
|
||
|
C PRINT *,(IGDS(I),I=1,18)
|
||
|
C PRINT *,' '
|
||
|
C
|
||
|
C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3)
|
||
|
C LENGTH = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON,
|
||
|
C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS
|
||
|
C LENGTH = 42 FOR MERCATOR, LAMBERT, TANGENT CONE
|
||
|
C LENGTH = 178 FOR MERCATOR, LAMBERT, TANGENT CONE
|
||
|
C
|
||
|
IF (IGDS(3) .EQ. 0 .OR. IGDS(3) .EQ. 2 .OR.
|
||
|
& IGDS(3) .EQ. 4 .OR. IGDS(3) .EQ. 5 .OR.
|
||
|
& IGDS(3) .EQ. 50 .OR. IGDS(3) .EQ. 201.OR.
|
||
|
& IGDS(3) .EQ. 202.OR. IGDS(3) .EQ. 203) THEN
|
||
|
LENGDS = 32
|
||
|
C
|
||
|
C CORRECTION FOR GRIDS 37-44
|
||
|
C
|
||
|
IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE.
|
||
|
& 255) THEN
|
||
|
LENGDS = IGDS(5) * 2 + 32
|
||
|
ENDIF
|
||
|
ELSE IF (IGDS(3) .EQ. 1 .OR. IGDS(3) .EQ. 3 .OR.
|
||
|
& IGDS(3) .EQ. 13) THEN
|
||
|
LENGDS = 42
|
||
|
ELSE
|
||
|
C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID'
|
||
|
IGERR = 1
|
||
|
RETURN
|
||
|
ENDIF
|
||
|
C
|
||
|
C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3
|
||
|
C
|
||
|
GDS(1) = CHAR(MOD(LENGDS/65536,256))
|
||
|
GDS(2) = CHAR(MOD(LENGDS/ 256,256))
|
||
|
GDS(3) = CHAR(MOD(LENGDS ,256))
|
||
|
C
|
||
|
C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS
|
||
|
C OCTET 5 = PV, PL OR 255
|
||
|
C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6)
|
||
|
C
|
||
|
GDS(4) = CHAR(IGDS(1))
|
||
|
GDS(5) = CHAR(IGDS(2))
|
||
|
GDS(6) = CHAR(IGDS(3))
|
||
|
C
|
||
|
C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION
|
||
|
C TYPE (TABLE 6)
|
||
|
C
|
||
|
C$$
|
||
|
C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA
|
||
|
C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS
|
||
|
C
|
||
|
IF (IGDS(3).EQ.0.OR.IGDS(3).EQ.4.OR.
|
||
|
& IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR.
|
||
|
& IGDS(3).EQ.203) THEN
|
||
|
GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
|
||
|
GDS( 8) = CHAR(MOD(IGDS(4) ,256))
|
||
|
GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
|
||
|
GDS(10) = CHAR(MOD(IGDS(5) ,256))
|
||
|
LATO = IGDS(6)
|
||
|
IF (LATO .LT. 0) THEN
|
||
|
LATO = -LATO
|
||
|
LATO = IOR(LATO,8388608)
|
||
|
ENDIF
|
||
|
GDS(11) = CHAR(MOD(LATO/65536,256))
|
||
|
GDS(12) = CHAR(MOD(LATO/ 256,256))
|
||
|
GDS(13) = CHAR(MOD(LATO ,256))
|
||
|
LONO = IGDS(7)
|
||
|
IF (LONO .LT. 0) THEN
|
||
|
LONO = -LONO
|
||
|
LONO = IOR(LONO,8388608)
|
||
|
ENDIF
|
||
|
GDS(14) = CHAR(MOD(LONO/65536,256))
|
||
|
GDS(15) = CHAR(MOD(LONO/ 256,256))
|
||
|
GDS(16) = CHAR(MOD(LONO ,256))
|
||
|
LATEXT = IGDS(9)
|
||
|
IF (LATEXT .LT. 0) THEN
|
||
|
LATEXT = -LATEXT
|
||
|
LATEXT = IOR(LATEXT,8388608)
|
||
|
ENDIF
|
||
|
GDS(18) = CHAR(MOD(LATEXT/65536,256))
|
||
|
GDS(19) = CHAR(MOD(LATEXT/ 256,256))
|
||
|
GDS(20) = CHAR(MOD(LATEXT ,256))
|
||
|
LONEXT = IGDS(10)
|
||
|
IF (LONEXT .LT. 0) THEN
|
||
|
LONEXT = -LONEXT
|
||
|
LONEXT = IOR(LONEXT,8388608)
|
||
|
ENDIF
|
||
|
GDS(21) = CHAR(MOD(LONEXT/65536,256))
|
||
|
GDS(22) = CHAR(MOD(LONEXT/ 256,256))
|
||
|
GDS(23) = CHAR(MOD(LONEXT ,256))
|
||
|
IRES = IAND(IGDS(8),128)
|
||
|
IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR.IGDS(3).EQ.203) THEN
|
||
|
GDS(24) = CHAR(MOD(IGDS(11)/256,256))
|
||
|
GDS(25) = CHAR(MOD(IGDS(11) ,256))
|
||
|
ELSE IF (IRES.EQ.0) THEN
|
||
|
GDS(24) = CHAR(255)
|
||
|
GDS(25) = CHAR(255)
|
||
|
ELSE
|
||
|
GDS(24) = CHAR(MOD(IGDS(12)/256,256))
|
||
|
GDS(25) = CHAR(MOD(IGDS(12) ,256))
|
||
|
END IF
|
||
|
IF (IGDS(3).EQ.4) THEN
|
||
|
GDS(26) = CHAR(MOD(IGDS(11)/256,256))
|
||
|
GDS(27) = CHAR(MOD(IGDS(11) ,256))
|
||
|
ELSE IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR.
|
||
|
& IGDS(3).EQ.203) THEN
|
||
|
GDS(26) = CHAR(MOD(IGDS(12)/256,256))
|
||
|
GDS(27) = CHAR(MOD(IGDS(12) ,256))
|
||
|
ELSE IF (IRES.EQ.0) THEN
|
||
|
GDS(26) = CHAR(255)
|
||
|
GDS(27) = CHAR(255)
|
||
|
ELSE
|
||
|
GDS(26) = CHAR(MOD(IGDS(11)/256,256))
|
||
|
GDS(27) = CHAR(MOD(IGDS(11) ,256))
|
||
|
END IF
|
||
|
GDS(28) = CHAR(IGDS(13))
|
||
|
GDS(29) = CHAR(0)
|
||
|
GDS(30) = CHAR(0)
|
||
|
GDS(31) = CHAR(0)
|
||
|
GDS(32) = CHAR(0)
|
||
|
IF (LENGDS.GT.32) THEN
|
||
|
ISUM = 0
|
||
|
I = 19
|
||
|
DO 10 J = 33,LENGDS,2
|
||
|
ISUM = ISUM + IGDS(I)
|
||
|
GDS(J) = CHAR(MOD(IGDS(I)/256,256))
|
||
|
GDS(J+1) = CHAR(MOD(IGDS(I) ,256))
|
||
|
I = I + 1
|
||
|
10 CONTINUE
|
||
|
END IF
|
||
|
C
|
||
|
C$$ PROCESS MERCATOR GRID TYPES
|
||
|
C
|
||
|
ELSE IF (IGDS(3) .EQ. 1) THEN
|
||
|
GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
|
||
|
GDS( 8) = CHAR(MOD(IGDS(4) ,256))
|
||
|
GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
|
||
|
GDS(10) = CHAR(MOD(IGDS(5) ,256))
|
||
|
LATO = IGDS(6)
|
||
|
IF (LATO .LT. 0) THEN
|
||
|
LATO = -LATO
|
||
|
LATO = IOR(LATO,8388608)
|
||
|
ENDIF
|
||
|
GDS(11) = CHAR(MOD(LATO/65536,256))
|
||
|
GDS(12) = CHAR(MOD(LATO/ 256,256))
|
||
|
GDS(13) = CHAR(MOD(LATO ,256))
|
||
|
LONO = IGDS(7)
|
||
|
IF (LONO .LT. 0) THEN
|
||
|
LONO = -LONO
|
||
|
LONO = IOR(LONO,8388608)
|
||
|
ENDIF
|
||
|
GDS(14) = CHAR(MOD(LONO/65536,256))
|
||
|
GDS(15) = CHAR(MOD(LONO/ 256,256))
|
||
|
GDS(16) = CHAR(MOD(LONO ,256))
|
||
|
LATEXT = IGDS(9)
|
||
|
IF (LATEXT .LT. 0) THEN
|
||
|
LATEXT = -LATEXT
|
||
|
LATEXT = IOR(LATEXT,8388608)
|
||
|
ENDIF
|
||
|
GDS(18) = CHAR(MOD(LATEXT/65536,256))
|
||
|
GDS(19) = CHAR(MOD(LATEXT/ 256,256))
|
||
|
GDS(20) = CHAR(MOD(LATEXT ,256))
|
||
|
LONEXT = IGDS(10)
|
||
|
IF (LONEXT .LT. 0) THEN
|
||
|
LONEXT = -LONEXT
|
||
|
LONEXT = IOR(LONEXT,8388608)
|
||
|
ENDIF
|
||
|
GDS(21) = CHAR(MOD(LONEXT/65536,256))
|
||
|
GDS(22) = CHAR(MOD(LONEXT/ 256,256))
|
||
|
GDS(23) = CHAR(MOD(LONEXT ,256))
|
||
|
GDS(24) = CHAR(MOD(IGDS(13)/65536,256))
|
||
|
GDS(25) = CHAR(MOD(IGDS(13)/ 256,256))
|
||
|
GDS(26) = CHAR(MOD(IGDS(13) ,256))
|
||
|
GDS(27) = CHAR(0)
|
||
|
GDS(28) = CHAR(IGDS(14))
|
||
|
GDS(29) = CHAR(MOD(IGDS(12)/65536,256))
|
||
|
GDS(30) = CHAR(MOD(IGDS(12)/ 256,256))
|
||
|
GDS(31) = CHAR(MOD(IGDS(12) ,256))
|
||
|
GDS(32) = CHAR(MOD(IGDS(11)/65536,256))
|
||
|
GDS(33) = CHAR(MOD(IGDS(11)/ 256,256))
|
||
|
GDS(34) = CHAR(MOD(IGDS(11) ,256))
|
||
|
GDS(35) = CHAR(0)
|
||
|
GDS(36) = CHAR(0)
|
||
|
GDS(37) = CHAR(0)
|
||
|
GDS(38) = CHAR(0)
|
||
|
GDS(39) = CHAR(0)
|
||
|
GDS(40) = CHAR(0)
|
||
|
GDS(41) = CHAR(0)
|
||
|
GDS(42) = CHAR(0)
|
||
|
C$$ PROCESS LAMBERT CONFORMAL GRID TYPES
|
||
|
ELSE IF (IGDS(3) .EQ. 3) THEN
|
||
|
GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
|
||
|
GDS( 8) = CHAR(MOD(IGDS(4) ,256))
|
||
|
GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
|
||
|
GDS(10) = CHAR(MOD(IGDS(5) ,256))
|
||
|
LATO = IGDS(6)
|
||
|
IF (LATO .LT. 0) THEN
|
||
|
LATO = -LATO
|
||
|
LATO = IOR(LATO,8388608)
|
||
|
ENDIF
|
||
|
GDS(11) = CHAR(MOD(LATO/65536,256))
|
||
|
GDS(12) = CHAR(MOD(LATO/ 256,256))
|
||
|
GDS(13) = CHAR(MOD(LATO ,256))
|
||
|
LONO = IGDS(7)
|
||
|
IF (LONO .LT. 0) THEN
|
||
|
LONO = -LONO
|
||
|
LONO = IOR(LONO,8388608)
|
||
|
ENDIF
|
||
|
GDS(14) = CHAR(MOD(LONO/65536,256))
|
||
|
GDS(15) = CHAR(MOD(LONO/ 256,256))
|
||
|
GDS(16) = CHAR(MOD(LONO ,256))
|
||
|
LONM = IGDS(9)
|
||
|
IF (LONM .LT. 0) THEN
|
||
|
LONM = -LONM
|
||
|
LONM = IOR(LONM,8388608)
|
||
|
ENDIF
|
||
|
GDS(18) = CHAR(MOD(LONM/65536,256))
|
||
|
GDS(19) = CHAR(MOD(LONM/ 256,256))
|
||
|
GDS(20) = CHAR(MOD(LONM ,256))
|
||
|
GDS(21) = CHAR(MOD(IGDS(10)/65536,256))
|
||
|
GDS(22) = CHAR(MOD(IGDS(10)/ 256,256))
|
||
|
GDS(23) = CHAR(MOD(IGDS(10) ,256))
|
||
|
GDS(24) = CHAR(MOD(IGDS(11)/65536,256))
|
||
|
GDS(25) = CHAR(MOD(IGDS(11)/ 256,256))
|
||
|
GDS(26) = CHAR(MOD(IGDS(11) ,256))
|
||
|
GDS(27) = CHAR(IGDS(12))
|
||
|
GDS(28) = CHAR(IGDS(13))
|
||
|
GDS(29) = CHAR(MOD(IGDS(15)/65536,256))
|
||
|
GDS(30) = CHAR(MOD(IGDS(15)/ 256,256))
|
||
|
GDS(31) = CHAR(MOD(IGDS(15) ,256))
|
||
|
GDS(32) = CHAR(MOD(IGDS(16)/65536,256))
|
||
|
GDS(33) = CHAR(MOD(IGDS(16)/ 256,256))
|
||
|
GDS(34) = CHAR(MOD(IGDS(16) ,256))
|
||
|
GDS(35) = CHAR(MOD(IGDS(17)/65536,256))
|
||
|
GDS(36) = CHAR(MOD(IGDS(17)/ 256,256))
|
||
|
GDS(37) = CHAR(MOD(IGDS(17) ,256))
|
||
|
GDS(38) = CHAR(MOD(IGDS(18)/65536,256))
|
||
|
GDS(39) = CHAR(MOD(IGDS(18)/ 256,256))
|
||
|
GDS(40) = CHAR(MOD(IGDS(18) ,256))
|
||
|
GDS(41) = CHAR(0)
|
||
|
GDS(42) = CHAR(0)
|
||
|
C$$ PROCESS POLAR STEREOGRAPHIC GRID TYPES
|
||
|
ELSE IF (IGDS(3) .EQ. 5) THEN
|
||
|
GDS( 7) = CHAR(MOD(IGDS(4)/256,256))
|
||
|
GDS( 8) = CHAR(MOD(IGDS(4) ,256))
|
||
|
GDS( 9) = CHAR(MOD(IGDS(5)/256,256))
|
||
|
GDS(10) = CHAR(MOD(IGDS(5) ,256))
|
||
|
LATO = IGDS(6)
|
||
|
IF (LATO .LT. 0) THEN
|
||
|
LATO = -LATO
|
||
|
LATO = IOR(LATO,8388608)
|
||
|
ENDIF
|
||
|
GDS(11) = CHAR(MOD(LATO/65536,256))
|
||
|
GDS(12) = CHAR(MOD(LATO/ 256,256))
|
||
|
GDS(13) = CHAR(MOD(LATO ,256))
|
||
|
LONO = IGDS(7)
|
||
|
IF (LONO .LT. 0) THEN
|
||
|
LONO = -LONO
|
||
|
LONO = IOR(LONO,8388608)
|
||
|
ENDIF
|
||
|
GDS(14) = CHAR(MOD(LONO/65536,256))
|
||
|
GDS(15) = CHAR(MOD(LONO/ 256,256))
|
||
|
GDS(16) = CHAR(MOD(LONO ,256))
|
||
|
LONM = IGDS(9)
|
||
|
IF (LONM .LT. 0) THEN
|
||
|
LONM = -LONM
|
||
|
LONM = IOR(LONM,8388608)
|
||
|
ENDIF
|
||
|
GDS(18) = CHAR(MOD(LONM/65536,256))
|
||
|
GDS(19) = CHAR(MOD(LONM/ 256,256))
|
||
|
GDS(20) = CHAR(MOD(LONM ,256))
|
||
|
GDS(21) = CHAR(MOD(IGDS(10)/65536,256))
|
||
|
GDS(22) = CHAR(MOD(IGDS(10)/ 256,256))
|
||
|
GDS(23) = CHAR(MOD(IGDS(10) ,256))
|
||
|
GDS(24) = CHAR(MOD(IGDS(11)/65536,256))
|
||
|
GDS(25) = CHAR(MOD(IGDS(11)/ 256,256))
|
||
|
GDS(26) = CHAR(MOD(IGDS(11) ,256))
|
||
|
GDS(27) = CHAR(IGDS(12))
|
||
|
GDS(28) = CHAR(IGDS(13))
|
||
|
GDS(29) = CHAR(0)
|
||
|
GDS(30) = CHAR(0)
|
||
|
GDS(31) = CHAR(0)
|
||
|
GDS(32) = CHAR(0)
|
||
|
ENDIF
|
||
|
C PRINT 10,(GDS(IG),IG=1,32)
|
||
|
C10 FORMAT (' GDS= ',32(1X,Z2.2))
|
||
|
C
|
||
|
C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING
|
||
|
C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER
|
||
|
C
|
||
|
IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE.
|
||
|
& 255) THEN
|
||
|
NPTS = ISUM
|
||
|
ELSE
|
||
|
NPTS = IGDS(4) * IGDS(5)
|
||
|
ENDIF
|
||
|
C
|
||
|
C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS
|
||
|
C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA)
|
||
|
C
|
||
|
ICOMP = ISHFT(ICOMP,3)
|
||
|
GDS(17) = CHAR(IOR(IGDS(8),ICOMP))
|
||
|
C
|
||
|
RETURN
|
||
|
END
|