Created a tag for the 2012 HWRF baseline tests.
[WPS-merge.git] / hwrf-baseline-20120103-1354 / ungrib / src / ngl / w3 / putgbn.f
blob671f1106be45114045a4e0b1555b663127f8b2cb
1 C-----------------------------------------------------------------------
2 SUBROUTINE PUTGBN(LUGB,KF,KPDS,KGDS,IBS,NBITS,LB,F,IRET)
3 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
5 C SUBPROGRAM: PUTGBN PACKS AND WRITES A GRIB MESSAGE
6 C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01
8 C ABSTRACT: PACK AND WRITE A GRIB MESSAGE.
9 C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB.
11 C PROGRAM HISTORY LOG:
12 C 94-04-01 IREDELL
13 C 95-10-31 IREDELL REMOVED SAVES AND PRINTS
15 C USAGE: CALL PUTGBN(LUGB,KF,KPDS,KGDS,NBITS,LB,F,IRET)
16 C INPUT ARGUMENTS:
17 C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE
18 C KF INTEGER NUMBER OF DATA POINTS
19 C KPDS INTEGER (200) PDS PARAMETERS
20 C (1) - ID OF CENTER
21 C (2) - GENERATING PROCESS ID NUMBER
22 C (3) - GRID DEFINITION
23 C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8)
24 C (5) - INDICATOR OF PARAMETER
25 C (6) - TYPE OF LEVEL
26 C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
27 C (8) - YEAR INCLUDING (CENTURY-1)
28 C (9) - MONTH OF YEAR
29 C (10) - DAY OF MONTH
30 C (11) - HOUR OF DAY
31 C (12) - MINUTE OF HOUR
32 C (13) - INDICATOR OF FORECAST TIME UNIT
33 C (14) - TIME RANGE 1
34 C (15) - TIME RANGE 2
35 C (16) - TIME RANGE FLAG
36 C (17) - NUMBER INCLUDED IN AVERAGE
37 C (18) - VERSION NR OF GRIB SPECIFICATION
38 C (19) - VERSION NR OF PARAMETER TABLE
39 C (20) - NR MISSING FROM AVERAGE/ACCUMULATION
40 C (21) - CENTURY OF REFERENCE TIME OF DATA
41 C (22) - UNITS DECIMAL SCALE FACTOR
42 C (23) - SUBCENTER NUMBER
43 C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS
44 C 128 IF FORECAST FIELD ERROR
45 C 64 IF BIAS CORRECTED FCST FIELD
46 C 32 IF SMOOTHED FIELD
47 C WARNING: CAN BE COMBINATION OF MORE THAN 1
48 C (25) - PDS BYTE 30, NOT USED
49 C KGDS INTEGER (200) GDS PARAMETERS
50 C (1) - DATA REPRESENTATION TYPE
51 C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS
52 C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
53 C PARAMETERS
54 C OR
55 C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
56 C IN EACH ROW
57 C OR
58 C 255 IF NEITHER ARE PRESENT
59 C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
60 C (22) - NUMBER OF WORDS IN EACH ROW
61 C LATITUDE/LONGITUDE GRIDS
62 C (2) - N(I) NR POINTS ON LATITUDE CIRCLE
63 C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
64 C (4) - LA(1) LATITUDE OF ORIGIN
65 C (5) - LO(1) LONGITUDE OF ORIGIN
66 C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
67 C (7) - LA(2) LATITUDE OF EXTREME POINT
68 C (8) - LO(2) LONGITUDE OF EXTREME POINT
69 C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT
70 C (10) - DJ LATITUDINAL DIRECTION INCREMENT
71 C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
72 C GAUSSIAN GRIDS
73 C (2) - N(I) NR POINTS ON LATITUDE CIRCLE
74 C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
75 C (4) - LA(1) LATITUDE OF ORIGIN
76 C (5) - LO(1) LONGITUDE OF ORIGIN
77 C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
78 C (7) - LA(2) LATITUDE OF EXTREME POINT
79 C (8) - LO(2) LONGITUDE OF EXTREME POINT
80 C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT
81 C (10) - N - NR OF CIRCLES POLE TO EQUATOR
82 C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
83 C (12) - NV - NR OF VERT COORD PARAMETERS
84 C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS
85 C OR
86 C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN
87 C EACH ROW (IF NO VERT COORD PARAMETERS
88 C ARE PRESENT
89 C OR
90 C 255 IF NEITHER ARE PRESENT
91 C POLAR STEREOGRAPHIC GRIDS
92 C (2) - N(I) NR POINTS ALONG LAT CIRCLE
93 C (3) - N(J) NR POINTS ALONG LON CIRCLE
94 C (4) - LA(1) LATITUDE OF ORIGIN
95 C (5) - LO(1) LONGITUDE OF ORIGIN
96 C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
97 C (7) - LOV GRID ORIENTATION
98 C (8) - DX - X DIRECTION INCREMENT
99 C (9) - DY - Y DIRECTION INCREMENT
100 C (10) - PROJECTION CENTER FLAG
101 C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28)
102 C SPHERICAL HARMONIC COEFFICIENTS
103 C (2) - J PENTAGONAL RESOLUTION PARAMETER
104 C (3) - K " " "
105 C (4) - M " " "
106 C (5) - REPRESENTATION TYPE
107 C (6) - COEFFICIENT STORAGE MODE
108 C MERCATOR GRIDS
109 C (2) - N(I) NR POINTS ON LATITUDE CIRCLE
110 C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
111 C (4) - LA(1) LATITUDE OF ORIGIN
112 C (5) - LO(1) LONGITUDE OF ORIGIN
113 C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
114 C (7) - LA(2) LATITUDE OF LAST GRID POINT
115 C (8) - LO(2) LONGITUDE OF LAST GRID POINT
116 C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION
117 C (10) - RESERVED
118 C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
119 C (12) - LONGITUDINAL DIR GRID LENGTH
120 C (13) - LATITUDINAL DIR GRID LENGTH
121 C LAMBERT CONFORMAL GRIDS
122 C (2) - NX NR POINTS ALONG X-AXIS
123 C (3) - NY NR POINTS ALONG Y-AXIS
124 C (4) - LA1 LAT OF ORIGIN (LOWER LEFT)
125 C (5) - LO1 LON OF ORIGIN (LOWER LEFT)
126 C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
127 C (7) - LOV - ORIENTATION OF GRID
128 C (8) - DX - X-DIR INCREMENT
129 C (9) - DY - Y-DIR INCREMENT
130 C (10) - PROJECTION CENTER FLAG
131 C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
132 C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
133 C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
134 C IBS INTEGER BINARY SCALE FACTOR (0 TO IGNORE)
135 C NBITS INTEGER NUMBER OF BITS IN WHICH TO PACK (0 TO IGNORE)
136 C LB LOGICAL*1 (KF) BITMAP IF PRESENT
137 C F REAL (KF) DATA
138 C OUTPUT ARGUMENTS:
139 C IRET INTEGER RETURN CODE
140 C 0 ALL OK
141 C OTHER W3FI72 GRIB PACKER RETURN CODE
143 C SUBPROGRAMS CALLED:
144 C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS
145 C GETBIT GET NUMBER OF BITS AND ROUND DATA
146 C W3FI72 PACK GRIB
147 C WRYTE WRITE DATA
149 C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
150 C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
152 C ATTRIBUTES:
153 C LANGUAGE: FORTRAN 77
154 C MACHINE: CRAY, WORKSTATIONS
156 C$$$
157 INTEGER KPDS(200),KGDS(200)
158 LOGICAL*1 LB(KF)
159 REAL F(KF)
160 PARAMETER(MAXBIT=16)
161 INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200)
162 REAL FR(KF)
163 CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8)
164 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
165 C GET W3FI72 PARAMETERS
166 CALL R63W72(KPDS,KGDS,IPDS,IGDS)
167 IBDS=0
168 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
169 C COUNT VALID DATA
170 KBM=KF
171 IF(IPDS(7).NE.0) THEN
172 KBM=0
173 DO I=1,KF
174 IF(LB(I)) THEN
175 IBM(I)=1
176 KBM=KBM+1
177 ELSE
178 IBM(I)=0
179 ENDIF
180 ENDDO
181 IF(KBM.EQ.KF) IPDS(7)=0
182 ENDIF
183 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
184 C GET NUMBER OF BITS AND ROUND DATA
185 IF(NBITS.GT.0) THEN
186 DO I=1,KF
187 FR(I)=F(I)
188 ENDDO
189 NBIT=NBITS
190 ELSE
191 IF(KBM.EQ.0) THEN
192 DO I=1,KF
193 FR(I)=0.
194 ENDDO
195 NBIT=0
196 ELSE
197 CALL GETBIT(IPDS(7),IBS,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT)
198 NBIT=MIN(NBIT,MAXBIT)
199 ENDIF
200 ENDIF
201 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
202 C PACK AND WRITE GRIB DATA
203 CALL W3FI72(0,FR,0,NBIT,0,IPDS,PDS,
204 & 1,255,IGDS,0,0,IBM,KF,IBDS,
205 & KFO,GRIB,LGRIB,IRET)
206 IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB)
207 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
208 RETURN