NCEPLIBS-w3emc  2.9.2
w3unpk77.f
1 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
2 C . . . .
3 C SUBPROGRAM: W3UNPK77 DECODES SINGLE REPORT FROM BUFR MESSAGES
4 C PRGMMR: KEYSER ORG: NP22 DATE: 2002-03-05
5 C
6 C ABSTRACT: THIS SUBROUTINE DECODES A SINGLE REPORT FROM BUFR MESSAGES
7 C IN A JBUFR-TYPE DATA FILE. CURRENTLY WIND PROFILER, NEXRAD (VAD)
8 C WIND AND GOES SOUNDING/RADIANCE DATA TYPES ARE VALID. REPORT IS
9 C RETURNED IN QUASI-OFFICE NOTE 29 UNPACKED FORMAT (SEE REMARKS 4.).
10 C
11 C PROGRAM HISTORY LOG:
12 C 1996-12-16 KEYSER -- ORIGINAL AUTHOR (BASED ON W3LIB ROUTINE W3FI77)
13 C 1997-06-02 KEYSER -- ADDED NEXRAD (VAD) WIND DATA TYPE
14 C 1997-06-16 KEYSER -- ADDED GOES SOUNDING/RADIANCE DATA TYPE
15 C 1997-09-18 KEYSER -- ADDED INSTRUMENT DATA USED IN PROCESSING,
16 C SOLAR ZENITH ANGLE, AND SATELLITE ZENITH ANGLE
17 C TO LIST OF PARAMETERS RETURNED FROM GOES
18 C SOUNDING/RADIANCE DATA TYPE
19 C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ.
20 C SIGNIFICANCE, VERT. SIGNIFICANCE) TO ACCOUNT
21 C FOR UPDATES TO BUFRTABLE MNEMONICS IN /dcom;
22 C CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR
23 C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S
24 C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME
25 C CHAR. 6 TAG)
26 C 1998-08-19 KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 COMPLIANT
27 C 1999-03-16 KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED
28 C TO PORT THE CODE TO THE IBM SP
29 C 1999-05-17 KEYSER -- MADE CHANGES NECESSARY TO PORT THIS ROUTINE TO
30 C THE IBM SP
31 C 1999-09-26 KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE
32 C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
33 C PROFILER) BUFR DUMP FILE AFTER 3/2002: CAT. 10
34 C SURFACE DATA NOW ALL MISSING (MNEMONICS "PMSL",
35 C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO
36 C LONGER AVAILABLE); CAT. 11 MNEMONICS "ACAVH",
37 C "ACAVV", "SPP0", AND "NPHL" NO LONGER
38 C AVAILABLE; HEADER MNEMONIC "NPSM" IS NO LONGER
39 C AVAILABLE, HEADER MNEMONIC "TPSE" REPLACES
40 C "TPMI" (AVG. TIME IN MINUTES STILL OUTPUT);
41 C NUMBER OF UPPER-AIR LEVELS INCR. FROM 43 TO UP
42 C TO 64 (SIZE OF OUTPUT "RDATA" ARRAY INCR. FROM
43 C 600 TO 1200 TO ACCOUNT FOR THIS) (WILL STILL
44 C WORK PROPERLY FOR INPUT PROFLR DUMP FILES PRIOR
45 C TO 3/2002)
46 C
47 C
48 C USAGE: CALL W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET)
49 C INPUT ARGUMENT LIST:
50 C IDATE - 4-WORD ARRAY HOLDING "CENTRAL" DATE TO PROCESS
51 C - (YYYY, MM, DD, HH)
52 C IHE - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF
53 C - EARLIEST BUFR MESSAGE THAT IS TO BE DECODED; EARLIEST
54 C - DATE IS "IDATE" + "IHE" HOURS (IF "IHE" IS POSITIVE,
55 C - LATEST MESSAGE DATE IS AFTER "IDATE"; IF "IHE" IS
56 C - NEGATIVE LATEST MESSAGE DATE IS PRIOR TO "IDATE")
57 C - EXAMPLE: IF IHE=1, THEN EARLIEST DATE IS 1-HR AFTER
58 C - IDATE; IF IHE=-3, THEN EARLIEST DATE IS 3-HR PRIOR
59 C - TO IDATE
60 C IHL - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF
61 C - LATEST BUFR MESSAGE THAT IS TO BE DECODED; LATEST
62 C - DATE IS "IDATE" + ("IHL" HOURS PLUS 59 MIN) IF "IHL"
63 C - IS POSITIVE (LATEST MESSAGE DATE IS AFTER "IDATE"),
64 C - AND "IDATE" + ("IHL"+1 HOURS MINUS 1 MIN) IF "IHL"
65 C - IS NEGATIVE (LATEST MESSAGE DATE IS PRIOR TO "IDATE")
66 C - EXAMPLE: IF IHL=3, THEN LATEST DATE IS 3-HR 59-MIN
67 C - AFTER IDATE; IF IHL=-2, THEN LATEST DATE IS 1-HR 1-MIN
68 C - PRIOR TO IDATE
69 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
70 C IRET - CONTROLS DEGREE OF UNIT 6 PRINTOUT (.GE. 0 -LIMITED
71 C - PRINTOUT; = -1 SOME ADDITIONAL DIAGNOSTIC PRINTOUT;
72 C = .LT. -1 -EXTENSIVE PRINTOUT) (SEE REMARKS 3.)
73 C
74 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
75 C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29
76 C - UNPACKED FORMAT (SEE REMARKS 4.) (MINIMUM SIZE IS
77 C - 1200 WORDS)
78 C IRET - RETURN CODE AS FOLLOWS:
79 C IRET = 0 ---> REPORT SUCCESSFULLY RETURNED
80 C IRET > 0 ---> NO REPORT RETURNED DUE TO:
81 C = 1 ---> ALL REPORTS READ IN, END
82 C = 2 ---> LAT AND/OR LON DATA MISSING
83 C = 3 ---> RESERVED
84 C = 4 ---> SOME/ALL DATE INFORMATION MISSING
85 C = 5 ---> NO DATA LEVELS PROCESSED (ALL LEVELS ARE MISSING)
86 C = 6 ---> NUMBER OF LEVELS IN REPORT HEADER IS NOT 1
87 C = 7 ---> NUMBER OF LEVELS IN ANOTHER SINGLE LEVEL SEQUENCE
88 C IS NOT 1
89 C
90 C INPUT FILES:
91 C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA
92 C - IN THE FORM OF BUFR MESSAGES
93 C
94 C OUTPUT FILES:
95 C UNIT 06 - PRINTOUT
96 C
97 C SUBPROGRAMS CALLED:
98 C UNIQUE - UNPK7701 UNPK7702 UNPK7703 UNPK7704 UNPK7705
99 C - UNPK7706 UNPK7707 UNPK7708 UNPK7709
100 C LIBRARY:
101 C W3LIB - W3FI04 W3MOVDAT W3DIFDAT ERREXIT
102 C BUFRLIB - DATELEN DUMPBF OPENBF READMG UFBCNT
103 C - READSB UFBINT CLOSBF
104 C
105 C REMARKS: 1) A CONDITION CODE (STOP) OF 15 WILL OCCUR IF THE INPUT
106 C DATES FOR START AND/OR STOP TIME ARE SPECIFIED INCORRECTLY.
107 C 2) A CONDITION CODE (STOP) OF 22 WILL OCCUR IF THE
108 C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR EBCDIC.
109 C 3) THE INPUT ARGUMENT "IRET" SHOULD BE SET PRIOR TO EACH
110 C CALL TO THIS SUBROUTINE.
111 C
112 C ***************************************************************
113 C 4)
114 C BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA
115 C (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE)
116 C N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77
117 C EXCEPT WHERE NOTED
118 C ***************************************************************
119 C
120 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
121 C FORMAT FOR WIND PROFILER REPORTS
122 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
123 C HEADER
124 C WORD CONTENT UNIT FORMAT
125 C ---- ---------------------- ------------------- ---------
126 C 1 LATITUDE 0.01 DEGREES REAL
127 C 2 LONGITUDE 0.01 DEGREES WEST REAL
128 C 3 TIME SIGNIFICANCE (BUFR CODE TABLE "0 08 021") INTEGER
129 C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
130 cvvvvvdak port
131 C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
132 caaaaadak port
133 C LEFT-JUSTIFIED
134 C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
135 C 7 STATION ELEVATION METERS REAL
136 C 8 SUBMODE/EDITION NO. (SM X 10) + ED. NO. INTEGER
137 C (ED. NO.=2, CONSTANT; SEE &,~)
138 C 9 REPORT TYPE 71 (CONSTANT) INTEGER
139 C 10 AVERAGING TIME MINUTES INTEGER
140 C (NEGATIVE MEANS PRIOR TO OBS. TIME)
141 C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
142 C LEFT-JUSTIFIED
143 C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
144 C LEFT-JUSTIFIED
145 C
146 C 13-34 ZEROED OUT - NOT USED INTEGER
147 C 35 CATEGORY 10, NO. LEVELS COUNT INTEGER
148 C 36 CATEGORY 10, DATA INDEX COUNT INTEGER
149 C 37 CATEGORY 11, NO. LEVELS COUNT INTEGER
150 C 38 CATEGORY 11, DATA INDEX COUNT INTEGER
151 C 39-42 ZEROED OUT - NOT USED INTEGER
152 C
153 C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
154 C
155 C CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)
156 C WORD PARAMETER UNITS FORMAT
157 C ---- --------- ----------------- -------------
158 C(SEE @)1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL
159 C(SEE *)2 STATION PRESSURE 0.1 MILLIBARS REAL
160 C(SEE @)3 HORIZ. WIND DIR. DEGREES REAL
161 C(SEE @)4 HORIZ. WIND SPEED 0.1 M/S REAL
162 C(SEE @)5 AIR TEMPERATURE 0.1 DEGREES K REAL
163 C(SEE @)6 RELATIVE HUMIDITY PERCENT REAL
164 C(SEE @)7 RAINFALL RATE 0.0000001 M/S REAL
165 C
166 C CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE)
167 C (EACH LEVEL, SEE WORD 37 ABOVE)
168 C WORD PARAMETER UNITS FORMAT
169 C ---- --------- ----------------- -------------
170 C 1 HEIGHT ABOVE SEA-LVL METERS REAL
171 C 2 HORIZ. WIND DIR. DEGREES REAL
172 C 3 HORIZ. WIND SPEED 0.1 M/S REAL
173 C 4 QUALITY CODE (SEE %) INTEGER
174 C 5 VERT. WIND COMP. (W) 0.01 M/S REAL
175 C(SEE @)6 HORIZ. CONSENSUS NO. (SEE $) INTEGER
176 C(SEE @)7 VERT. CONSENSUS NO. (SEE $) INTEGER
177 C(SEE @)8 SPECTRAL PEAK POWER DB REAL
178 C 9 HORIZ. WIND SPEED 0.1 M/S REAL
179 C STANDARD DEVIATION 0.1 M/S REAL
180 C 10 VERT. WIND COMPONENT 0.1 M/S REAL
181 C STANDARD DEVIATION 0.1 M/S REAL
182 C(SEE @)11 MODE (SEE #) INTEGER
183 C
184 C *- ALWAYS MISSING
185 C &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77
186 C %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED
187 C 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE
188 C 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED
189 C 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED
190 C 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED
191 C $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE
192 C INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10)
193 C (BASED ON A ONE-HOUR AVERAGE)
194 C #- 1 - DATA FROM LOW MODE
195 C 2 - DATA FROM HIGH MODE
196 C 3 - MISSING
197 C @- THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET
198 C TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL)
199 C ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3
200 C (ITS MISSING VALUE)
201 C
202 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
203 C FORMAT FOR GOES SOUNDING/RADIANCE REPORTS
204 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
205 C HEADER
206 C WORD CONTENT UNIT FORMAT
207 C ---- ---------------------- ------------------- ---------
208 C 1 LATITUDE 0.01 DEGREES REAL
209 C 2 LONGITUDE 0.01 DEGREES WEST REAL
210 C 3 FIELD OF VIEW NUMBER NUMERIC INTEGER
211 C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
212 cvvvvvdak port
213 C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
214 caaaaadak port
215 C LEFT-JUSTIFIED
216 C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
217 C 7 STATION ELEVATION METERS REAL
218 C 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER
219 C 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED)
220 C 9 REPORT TYPE 61 (CONSTANT) INTEGER
221 C 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER
222 C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
223 C LEFT-JUSTIFIED
224 C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
225 C LEFT-JUSTIFIED (SEE %)
226 C
227 C 13-26 ZEROED OUT - NOT USED
228 C 27 CATEGORY 08, NO. LEVELS COUNT INTEGER
229 C 28 CATEGORY 08, DATA INDEX COUNT INTEGER
230 C 29-38 ZEROED OUT - NOT USED
231 C 39 CATEGORY 12, NO. LEVELS COUNT INTEGER
232 C 40 CATEGORY 12, DATA INDEX COUNT INTEGER
233 C 41 CATEGORY 13, NO. LEVELS COUNT INTEGER
234 C 42 CATEGORY 13, DATA INDEX COUNT INTEGER
235 C
236 C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
237 C
238 C CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE;
239 C EACH LEVEL, SEE 39 ABOVE)
240 C WORD PARAMETER UNITS FORMAT
241 C ---- --------- ----------------- -------------
242 C 1 PRESSURE 0.1 MILLIBARS REAL
243 C 2 GEOPOTENTIAL METERS REAL
244 C 3 TEMPERATURE 0.1 DEGREES C REAL
245 C 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL
246 C 5 NOT USED SET TO MISSING REAL
247 C 6 NOT USED SET TO MISSING REAL
248 C 7 QUALITY MARKERS 4-CHARACTERS CHARACTER
249 C LEFT-JUSTIFIED (SEE &)
250 C
251 C CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE
252 C 41 ABOVE)
253 C WORD PARAMETER UNITS FORMAT
254 C ---- --------- ----------------- -------------
255 C 1 CHANNEL NUMBER NUMERIC INTEGER
256 C 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL
257 C 3 QUALITY MARKERS 4-CHARACTERS CHARACTER
258 C LEFT-JUSTIFIED (SEE &&)
259 C
260 C CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @
261 C BELOW)
262 C WORD PARAMETER UNITS FORMAT
263 C ---- --------- ----------------- -------------
264 C 1 VARIABLE SEE @ BELOW REAL
265 C 2 CODE FIGURE SEE @ BELOW REAL
266 C 3 MARKERS 2-CHARACTERS CHARACTER
267 C LEFT-JUSTIFIED (SEE #)
268 C
269 C %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS:
270 C "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR.
271 C "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR.
272 
273 C "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR.
274 C "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR.
275 
276 C "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR.
277 C "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR.
278 
279 C "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR.
280 C "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR.
281 
282 C "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN
283 
284 C &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL
285 C SECOND CHARACTER IS Q.M. FOR TEMPERATURE
286 C THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE
287 C FOURTH CHARACTER IS NOT USED
288 C " " - INDICATES DATA NOT SUSPECT
289 C "Q" - INDICATES DATA ARE SUSPECT
290 C "F" - INDICATES DATA ARE BAD
291 C &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE
292 C SECOND-FOURTH CHARACTERS ARE NOT USED
293 C " " - INDICATES DATA NOT SUSPECT
294 C "Q" - INDICATES DATA ARE SUSPECT
295 C "F" - INDICATES DATA ARE BAD
296 C @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED
297 C AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED)
298 C 1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250.
299 C 2 - TOTAL PRECIP. WATER -- .01 MILLIMETERS -- C. FIG. 251.
300 C 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252.
301 C 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253.
302 C 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254.
303 C 6 - SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255.
304 C 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256.
305 C 8 - CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257.
306 C 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258.
307 C 10 - INSTR. DATA USED IN PROC.
308 C (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259.
309 C 11 - SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260.
310 C 12 - SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261.
311 C #- FIRST CHARACTER IS Q.M. FOR THE DATUM
312 C " " - INDICATES DATA NOT SUSPECT
313 C "Q" - INDICATES DATA ARE SUSPECT
314 C "F" - INDICATES DATA ARE BAD
315 C SECOND CHARACTER IS NOT USED
316 C
317 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
318 C FORMAT FOR NEXRAD (VAD) WIND REPORTS
319 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
320 C HEADER
321 C WORD CONTENT UNIT FORMAT
322 C ---- ---------------------- ------------------- ---------
323 C 1 LATITUDE 0.01 DEGREES REAL
324 C 2 LONGITUDE 0.01 DEGREES WEST REAL
325 C 3 ** RESERVED ** SET TO 99999 INTEGER
326 C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
327 cvvvvvdak port
328 C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
329 caaaaadak port
330 C LEFT-JUSTIFIED
331 C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
332 C 7 STATION ELEVATION METERS REAL
333 C 8 ** RESERVED ** SET TO 99999 INTEGER
334 C
335 C 9 REPORT TYPE 72 (CONSTANT) INTEGER
336 C 10 ** RESERVED ** SET TO 99999 INTEGER
337 C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
338 C LEFT-JUSTIFIED
339 C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
340 C LEFT-JUSTIFIED
341 C
342 C 13-18 ZEROED OUT - NOT USED INTEGER
343 C 19 CATEGORY 04, NO. LEVELS COUNT INTEGER
344 C 20 CATEGORY 04, DATA INDEX COUNT INTEGER
345 C 21-42 ZEROED OUT - NOT USED INTEGER
346 C
347 C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
348 C
349 C CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE)
350 C (EACH LEVEL, SEE WORD 19 ABOVE)
351 C WORD PARAMETER UNITS FORMAT
352 C ---- --------- ----------------- -------------
353 C 1 HEIGHT ABOVE SEA-LVL METERS REAL
354 C 2 HORIZ. WIND DIR. DEGREES REAL
355 C 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL
356 C 4 QUALITY MARKERS 4-CHARACTERS CHARACTER
357 C LEFT-JUSTIFIED (SEE %)
358 C
359 C *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29
360 C (WHERE UNITS ARE KNOTS)
361 C %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH
362 C CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT-
363 C MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS
364 C DEFINED AS FOLLOWS:
365 C 'A' = RMS OF 1.9 KNOTS
366 C 'B' = RMS OF 3.9 KNOTS
367 C 'C' = RMS OF 5.8 KNOTS
368 C 'D' = RMS OF 7.8 KNOTS
369 C 'E' = RMS OF 9.7 KNOTS
370 C 'F' = RMS OF 11.7 KNOTS
371 C 'G' = RMS > 13.6 KNOTS
372 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
373 C
374 C FOR ALL REPORT TYPES, MISSING VALUES ARE:
375 C 99999. FOR REAL
376 C 99999 FOR INTEGER
377 C 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER
378 C BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER
379 C AND FOR CHARACTERS IN ANY CATEGORY LEVEL
380 C
381 C ATTRIBUTES:
382 C LANGUAGE: FORTRAN 90
383 C MACHINE: IBM-SP, CRAY, SGI
384 C
385 C$$$
386  SUBROUTINE w3unpk77(IDATE,IHE,IHL,LUNIT,RDATA,IRET)
387  CHARACTER*4 CBUFR
388  INTEGER IDATE(4),LSDATE(4),jdate(8),IDATA(1200)
389  dimension rinc(5)
390  REAL RDATA(*),RDATX(1200)
391  COMMON /pk77bb/kdate(8),ldate(8),iprint
392  COMMON /pk77cc/index
393  COMMON /pk77dd/lshe,lshl,icdate(5),iddate(5)
394  COMMON /pk77ff/ifov(3),kntsat(250:260)
395 
396  SAVE
397 
398  equivalence(rdatx,idata)
399  DATA itm/0/,lunitl/-99/,kount/0/
400  iprint = 0
401  IF(iret.LT.0) iprint = iabs(iret)
402  iret = 0
403  IF(itm.EQ.0) THEN
404 C-----------------------------------------------------------------------
405 
406 C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS....
407 
408  itm = 1
409  ifov = 0
410  kntsat = 0
411 C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF
412 C CHARACTER SET {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)}
413  CALL w3fi04(iendn,ichtp,lw)
414  print 2213, lw, ichtp, iendn
415  2213 FORMAT(/' ---> W3UNPK77: CALL TO W3FI04 RETURNS: LW = ',i3,
416  $ ', ICHTP = ',i3,', IENDN = ',i3/)
417  IF(ichtp.GT.1) THEN
418 C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22
419  print 217
420  217 FORMAT(' *** W3UNPK77 ERROR: CHARACTERS ON THIS MACHINE ',
421  $ 'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/)
422  CALL errexit(22)
423  END IF
424 C-----------------------------------------------------------------------
425  END IF
426  IF(lunit.NE.lunitl) THEN
427 C-----------------------------------------------------------------------
428 
429 C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME
430 C THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1
431 
432  lunitl = lunit
433  jret = 1
434  print 101, lunit
435  101 FORMAT(//' ---> W3UNPK77: VERSION 03/05/2002: JBUFR DATA SET ',
436  $ 'READ FROM UNIT ',i4/)
437 C-----------------------------------------------------------------------
438  ELSE
439 
440 C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME,
441 C TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST
442 C TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE
443 C JRET = 0), WILL TEST JRET SOON
444 
445  jret = 1
446  DO i = 4,1,-1
447  IF(idate(i).NE.lsdate(i)) GO TO 88
448  ENDDO
449  IF(ihe.NE.lshe.OR.ihl.NE.lshl) GO TO 88
450  jret = 0
451  88 CONTINUE
452 C-----------------------------------------------------------------------
453  END IF
454  IF(jret.EQ.1) THEN
455  print 6680
456  6680 FORMAT(/' JRET = 1 - REWIND DATA FILE & SET-UP TO DO DATE CHECK'/)
457 C-----------------------------------------------------------------------
458 
459 C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR
460 C IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL
461 
462 C CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN)
463 C REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME,
464 C OPEN BUFR DATA SET
465 
466 C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES
467 
468 C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED)
469 
470 C-----------------------------------------------------------------------
471 
472  CALL closbf(lunit)
473 
474  rewind lunit
475 
476  READ(lunit,END=9999,ERR=9999) cbufr
477  IF(cbufr.NE.'BUFR') GO TO 9999
478 
479  call datelen(10)
480 
481  CALL dumpbf(lunit,icdate,iddate)
482 cppppp
483  print *,'CENTER DATE (ICDATE) = ',icdate
484  print *,'DUMP DATE (IDDATE) = ',iddate
485 cppppp
486 
487  if(icdate(1).le.0) then
488 C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
489 C - RETURN WITH IRET = 1
490  print *, ' *** W3UNPK77 ERROR: CENTER DATE COULD NOT BE ',
491  $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit
492  go to 9998
493  end if
494  if(iddate(1).le.0) then
495 C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
496 C - RETURN WITH IRET = 1
497  print *, ' *** W3UNPK77 ERROR: DUMP DATE COULD NOT BE ',
498  $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit
499  go to 9998
500  end if
501  IF(icdate(1).LT.100) THEN
502 
503 C If 2-digit year returned in ICDATE(1), must use "windowing" technique
504 C to create a 4-digit year
505 
506 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
507 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
508 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
509 
510  print *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
511  $ 'HAPPEN!!!!!'
512  print *, '##W3UNPK77 - 2-DIGIT YEAR IN ICDATE(1) ',
513  $ 'RETURNED FROM DUMPBF (ICDATE IS: ',icdate,') - USE ',
514  $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
515  IF(icdate(1).GT.20) THEN
516  icdate(1) = 1900 + icdate(1)
517  ELSE
518  icdate(1) = 2000 + icdate(1)
519  ENDIF
520  print *, '##WW3UNPK77 - CORRECTED ICDATE(1) WITH 4-DIGIT ',
521  $ 'YEAR, ICDATE NOW IS: ',icdate
522  ENDIF
523 
524  IF(iddate(1).LT.100) THEN
525 
526 C If 2-digit year returned in IDDATE(1), must use "windowing" technique
527 C to create a 4-digit year
528 
529 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
530 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
531 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
532 
533  print *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
534  $ 'HAPPEN!!!!!'
535  print *, '##W3UNPK77 - 2-DIGIT YEAR IN IDDATE(1) ',
536  $ 'RETURNED FROM DUMPBF (IDDATE IS: ',iddate,') - USE ',
537  $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
538  IF(iddate(1).GT.20) THEN
539  iddate(1) = 1900 + iddate(1)
540  ELSE
541  iddate(1) = 2000 + iddate(1)
542  ENDIF
543  print *, '##W3UNPK77 - CORRECTED IDDATE(1) WITH 4-DIGIT ',
544  $ 'YEAR, IDDATE NOW IS: ',iddate
545  END IF
546 
547 C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES)
548 
549  CALL openbf(lunit,'IN',lunit)
550  print 100, lunit
551  100 FORMAT(/5x,'===> BUFR DATA SET IN UNIT',i3,' SUCCESSFULLY ',
552  $ 'OPENED FOR INPUT; DCTNY MESSAGES CONTAIN BUFR TABLES A,B,D'/)
553  index = 0
554  kount = 0
555  jdate(1:3) = idate(1:3)
556  jdate(4) = 0
557  jdate(5) = idate(4)
558  jdate(6:8) = 0
559  print 6681, idate
560  6681 FORMAT(/' %%% REQUESTED "CENTRAL" DATE IS :',i5,3i3,' 0'/)
561 C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
562  call w3movdat((/0.,real(ihe),0.,0.,0./),jdate,kdate)
563  print 6682, (kdate(i),i=1,3),kdate(5),kdate(6)
564  6682 FORMAT(/' --> EARLIEST DATE FOR ACCEPTING BUFR MSGS IS:',i5,4i3/)
565 C DETERMINE LATEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
566  if(ihl.ge.0) then
567  xminl = (ihl * 60) + 59
568  else
569  xminl = ((ihl + 1) * 60) - 1
570  end if
571  call w3movdat((/0.,0.,xminl,0.,0./),jdate,ldate)
572  print 6683, (ldate(i),i=1,3),ldate(5),ldate(6)
573  6683 FORMAT(/' --> LATEST DATE FOR ACCEPTING BUFR MSGS IS:',i5,4i3/)
574  call w3difdat(ldate,kdate,3,rinc)
575  IF(rinc(3).LT.0) THEN
576  print 104
577  104 FORMAT(' *** W3UNPK77 ERROR: DATES SPECIFIED INCORRECTLY -',
578  $ ' STOP 15'/)
579  CALL errexit(15)
580  END IF
581 C-----------------------------------------------------------------------
582  END IF
583 C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE
584  CALL unpk7701(lunit,itp,iret)
585 C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD
586 C (REWIND DATA FILE AND RETURN W/ IRET=1)
587 C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN)
588 C (ACTUALLY IRET.GE.2 CURRENTLY CANNOT HAPPEN OUT OF UNPK7701)
589  IF(iret.GE.1) THEN
590  IF(iret.EQ.1) THEN
591  rewind lunit
592  IF(itp.EQ.2) THEN
593  print 8101, ifov
594  8101 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
595  $ ' BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/15x,
596  $ '# WITH F-O-V NO. 00 TO 02:',i6,' - GET "BAD" Q.MARK'/15x,
597  $ '# WITH F-O-V NO. 03 TO 09:',i6,' - GET "SUSPECT" Q.MARK'/15x,
598  $ '# WITH F-O-V NO. 10 TO 25:',i6,' - GET "NEUTRAL" Q.MARK'/20x,
599  $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK)'/)
600  print 8102
601  8102 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
602  $ ' BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/)
603  DO idsat = 250,259
604  IF(kntsat(idsat).GT.0) print 8103, idsat,kntsat(idsat)
605  ENDDO
606  8103 FORMAT(15x,'NUMBER FROM SAT. ID',i4,4x,':',i6)
607  IF(kntsat(260).GT.0) print 8104
608  8104 FORMAT(15x,'NUMBER FROM UNKNOWN SAT. ID:',i6)
609  print 8105
610  8105 FORMAT(/)
611  END IF
612  END IF
613  GO TO 99
614  END IF
615  kount = kount + 1
616 C INITIALIZE THE OUTPUT ON29 ARRAY
617  CALL unpk7702(rdata,itp)
618  IF(itp.EQ.1) THEN
619 C-----------------------------------------------------------------------
620 C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS
621 C-----------------------------------------------------------------------
622 C STORE THE HEADER INFORMATION INTO ON29 FORMAT
623  CALL unpk7703(lunit,rdata,iret)
624 C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
625  IF(iret.GE.2) GO TO 99
626 C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10)
627  CALL unpk7704(lunit,rdata)
628 C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 11)
629  CALL unpk7705(lunit,rdata)
630  rdatx(1:1200) = rdata(1:1200)
631  IF(idata(35)+idata(37).EQ.0) iret = 5
632  ELSE IF(itp.EQ.2) THEN
633 C-----------------------------------------------------------------------
634 C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS
635 C-----------------------------------------------------------------------
636 C STORE THE HEADER INFORMATION INTO ON29 FORMAT
637  CALL unpk7708(lunit,rdata,kount,iret)
638 C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
639  IF(iret.GE.2) GO TO 99
640 C STORE THE UPPER-AIR DATA/RADIANCE INTO ON29 FORMAT (CATEGORY 12, 13)
641  CALL unpk7709(lunit,rdata,iret)
642  ELSE IF(itp.EQ.3) THEN
643 C-----------------------------------------------------------------------
644 C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS
645 C-----------------------------------------------------------------------
646 C STORE THE HEADER INFORMATION INTO ON29 FORMAT
647  CALL unpk7706(lunit,rdata,iret)
648 C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
649  IF(iret.GE.2) GO TO 99
650 C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4)
651  CALL unpk7707(lunit,rdata,iret)
652 C-----------------------------------------------------------------------
653  END IF
654  99 CONTINUE
655 C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL
656  lsdate = idate
657  lshe = ihe
658  lshl = ihl
659  RETURN
660 C-----------------------------------------------------------------------
661  9999 CONTINUE
662 C COME HERE IF NULL OR NON-BUFR FILE IS INPUT - RETURN WITH IRET = 1
663  print *, ' *** W3UNPK77 ERROR: INPUT FILE IN UNIT ',lunit,' IS ',
664  $ 'EITHER A NULL OR NON-BUFR FILE'
665  9998 continue
666  rewind lunit
667  iret = 1
668  lsdate = idate
669  lshe = ihe
670  lshl = ihl
671  END
672 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
673 C . . . .
674 C SUBPROGRAM: UNPK7701 READS A SINGLE REPORT OUT OF BUFR DATASET
675 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16
676 C
677 C ABSTRACT: CALLS BUFRLIB ROUTINES TO READ IN A BUFR MESSAGE AND THEN
678 C READ A SINGLE REPORT (SUBSET) OUT OF THE MESSAGE.
679 C
680 C PROGRAM HISTORY LOG:
681 C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
682 C
683 C USAGE: CALL UNPK7701(LUNIT,ITP,IRET)
684 C INPUT ARGUMENT LIST:
685 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
686 C
687 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
688 C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 -
689 C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND}
690 C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
691 C
692 C INPUT FILES:
693 C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA
694 C - IN THE FORM OF BUFR MESSAGES
695 C
696 C OUTPUT FILES:
697 C UNIT 06 - PRINTOUT
698 C
699 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
700 C
701 C ATTRIBUTES:
702 C LANGUAGE: FORTRAN 90
703 C MACHINE: IBM-SP, CRAY, SGI
704 C
705 C$$$
706  SUBROUTINE unpk7701(LUNIT,ITP,IRET)
707  CHARACTER*8 SUBSET
708  integer mdate(4),ndate(8)
709  dimension rinc(5)
710  COMMON /pk77bb/kdate(8),ldate(8),iprint
711  COMMON /pk77cc/index
712  COMMON /pk77dd/lshe,lshl,icdate(5),iddate(5)
713 
714  SAVE
715 
716  DATA irec/0/
717 
718  10 CONTINUE
719 C=======================================================================
720  IF(index.EQ.0) THEN
721 
722 C READ IN NEXT BUFR MESSAGE
723 
724  CALL readmg(lunit,subset,ibdate,jret)
725  IF(jret.NE.0) THEN
726 C-----------------------------------------------------------------------
727  print 101
728  101 FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/)
729  iret = 1
730  RETURN
731 C-----------------------------------------------------------------------
732  END IF
733  if(ibdate.lt.100000000) then
734 c If input BUFR file does not return messages with a 4-digit year,
735 c something is wrong (even non-compliant BUFR messages should
736 c construct a 4-digit year as long as datelen(10) has been called
737  print *, '##W3UNP777/UNPK7701 - A 10-digit Sect. 1 BUFR ',
738  $ 'message date was not returned in unit ',lunit,' - ',
739  $ 'problem with BUFR file - ier = 1'
740  iret = 1
741  return
742  end if
743  CALL ufbcnt(lunit,irec,isub)
744  mdate(1) = ibdate/1000000
745  mdate(2) = mod((ibdate/10000),100)
746  mdate(3) = mod((ibdate/100),100)
747  mdate(4) = mod(ibdate,100)
748 C ALL JBUFR MESSAGES CURRENTLY HAVE "00" FOR MINUTES IN SECTION 1
749  ndate(1:3) = mdate(1:3)
750  ndate(4) = 0
751  ndate(5) = mdate(4)
752  ndate(6:8) = 0
753  IF(iprint.GE.1) THEN
754  print *,'HAVE SUCCESSFULLY READ IN A BUFR MESSAGE'
755  print 103
756  103 FORMAT(' BUFR FOUND BEGINNING AT BYTE 1 OF MESSAGE')
757  print 105, irec,mdate,subset
758  105 FORMAT(8x,'HAVE READ IN A BUFR MESSAGE NO.',i3,', DATE: ',
759  $ i6,3i4,' 0; TABLE A ENTRY = ',a8,' AND EDIT. NO. = 2'/)
760  END IF
761  IF(subset.EQ.'NC002007') THEN
762  IF(iprint.GE.1) print *, 'THIS MESSAGE CONTAINS WIND ',
763  $ 'PROFILER REPORTS'
764  itp = 1
765  ELSE IF(subset.EQ.'NC002008') THEN
766  IF(iprint.GE.1) print *, 'THIS MESSAGE CONTAINS NEXRAD ',
767  $ '(VAD) WIND REPORTS'
768  itp = 3
769  ELSE IF(subset.EQ.'NC003001') THEN
770  IF(iprint.GE.1) print *, 'THIS MESSAGE CONTAINS GOES ',
771  $ 'SOUNDING/RADIANCE REPORTS'
772  itp = 2
773  ELSE
774  print 107, irec
775  107 FORMAT(' *** W3UNPK77 WARNING: BUFR MESSAGE NO.',i3,' CONTAINS ',
776  $ 'REPORTS THAT CANNOT BE DECODED BY W3UNPK77, TRY READING NEXT ',
777  $ 'MSG'/)
778  index = 0
779  GO TO 10
780  END IF
781  call w3difdat(kdate,ndate,3,rinc)
782  kmin = rinc(3)
783  call w3difdat(ldate,ndate,3,rinc)
784  lmin = rinc(3)
785 C CHECK DATE OF MESSAGE AGAINST SPECIFIED TIME RANGES
786  if((kmin.gt.0.or.lmin.lt.0).AND.irec.GT.2) then
787  print 106, irec,mdate
788  106 FORMAT(' BUFR MESSAGE NO.',i3,' WITH DATE:',i5,3i3,' 0 NOT W/I',
789  $ ' REQ. TIME RANGE, TRY READING NEXT MSG'/)
790  index = 0
791  GO TO 10
792  END IF
793  END IF
794 C=======================================================================
795 C READ NEXT SUBSET (REPORT) IN MESSAGE
796 
797  IF(iprint.GT.1) print *,'CALL READSB'
798  CALL readsb(lunit,jret)
799  IF(iprint.GT.1) print *,'BACK FROM READSB'
800  IF(jret.NE.0) THEN
801  IF(index.GT.0) THEN
802 
803 C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL
804 C MESSAGES READ IN NO MORE DATA TO PROCESS)
805 
806  IF(iprint.GT.1) print *, 'ALL REPORTS IN THIS MESSAGE ',
807  $ 'DECODED, GO ON TO NEXT MESSAGE'
808  ELSE
809 
810 C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS
811 C ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND
812 C DATA DUMP TIME ONLY; READ IN NEXT MESSAGE
813 
814  IF(irec.EQ.1) THEN
815  print 4567, icdate
816  4567 FORMAT(/'===> BUFR MESSAGE NO. 1 IS A DUMMY MESSAGE CONTAINING ',
817  $ 'ONLY CENTER DATE (',i5,4i3,') - NO DATA - GO ON TO NEXT ',
818  $ 'MESSAGE'/)
819  ELSE IF(irec.EQ.2) THEN
820  print 4568, iddate
821  4568 FORMAT(/'===> BUFR MESSAGE NO. 2 IS A DUMMY MESSAGE CONTAINING ',
822  $ 'ONLY DUMP DATE (',i5,4i3,') - NO DATA - GO ON TO NEXT ',
823  $ 'MESSAGE'/)
824  ELSE
825  print 4569, irec,mdate
826  4569 FORMAT(/'===> BUFR MESSAGE NO.',i3,' (DATE:',i5,3i3,' 0) ',
827  $ 'CONTAINS ZERO REPORTS FOR SOME UNEXPLAINED REASON - GO ON TO ',
828  $ 'NEXT MESSAGE'/)
829  END IF
830  END IF
831  index = 0
832  GO TO 10
833  END IF
834 C-----------------------------------------------------------------------
835  IF(iprint.GT.1) print *, 'READY TO PROCESS NEW DECODED REPORT'
836 C***********************************************************************
837 C A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED
838 C***********************************************************************
839  index = index + 1
840  IF(iprint.GE.1) print *, 'WORKING WITH SUBSET NUMBER ',index
841  RETURN
842  END
843 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
844 C . . . .
845 C SUBPROGRAM: UNPK7702 INITIALIZES THE OUTPUT ARRAY FOR A REPORT
846 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16
847 C
848 C ABSTRACT: INITIALIZES THE OUTPUT ARRAY WHICH HOLDS A SINGLE REPORT
849 C IN THE QUASI-OFFICE NOTE 29 UNPACKED FORMAT TO ALL MISSING.
850 C
851 C PROGRAM HISTORY LOG:
852 C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
853 C
854 C USAGE: CALL UNPK7702(RDATA,ITP)
855 C INPUT ARGUMENT LIST:
856 C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 -
857 C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND}
858 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
859 C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29
860 C UNPACKED FORMAT; ALL DATA ARE MISSING
861 C
862 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
863 C
864 C ATTRIBUTES:
865 C LANGUAGE: FORTRAN 90
866 C MACHINE: IBM-SP, CRAY, SGI
867 C
868 C$$$
869  SUBROUTINE unpk7702(RDATA,ITP)
870  REAL RDATA(*),RDATX(1200)
871  INTEGER IDATA(1200),IRTYP(3)
872  CHARACTER*8 COB
873 C
874  SAVE
875 C
876  equivalence(rdatx,idata),(cob,iob)
877  DATA xmsg/99999./,imsg/99999/,irtyp/71,61,72/
878  rdatx(1) = xmsg
879  rdatx(2) = xmsg
880  idata(3) = imsg
881  rdatx(4) = xmsg
882  cob = '999999 '
883  idata(5) = iob
884  cob = '9999 '
885  idata(6) = iob
886  rdatx(7) = xmsg
887  idata(8) = imsg
888  idata(9) = irtyp(itp)
889  idata(10) = imsg
890  cob = ' '
891  idata(11) = iob
892  idata(12) = iob
893 C
894 C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS
895 C
896  idata(13:42) = 0
897 C
898 C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION
899 C
900  rdatx(43:1200) = xmsg
901  IF(itp.EQ.1) THEN
902 C
903 C PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE
904 C (Current limit of 104 Cat. 11 levels)
905 C
906  idata(53:1200:11) = imsg
907  idata(55:1200:11) = imsg
908  idata(56:1200:11) = imsg
909  idata(60:1200:11) = imsg
910  ELSE IF(itp.EQ.2) THEN
911 C
912 C GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12
913 C LEVEL QUALITY MARKERS
914 C (Current limit of 50 Cat. 12 levels)
915 C (could be expanded if need be)
916 C
917  idata(49:392:7) = iob
918 C
919 C GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08
920 C LEVEL QUALITY MARKER
921 C (Current limit of 9 Cat. 08 levels)
922 C (could be expanded if need be)
923 C
924  idata(395:419:3) = iob
925 C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER
926 C -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL
927 C QUALITY MARKER
928 C (Current limit of 60 Cat. 13 levels)
929 C (could be expanded if need be)
930 C
931  idata(420:599:3) = imsg
932  idata(422:599:3) = iob
933  ELSE IF(itp.EQ.3) THEN
934 C
935 C VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04
936 C LEVEL QUALITY MARKER
937 C (Current limit of 70 Cat. 04 levels)
938 C (could be expanded if need be)
939 C
940  idata(46:1200:4) = iob
941  END IF
942  rdata(1:1200) = rdatx(1:1200)
943  RETURN
944  END
945 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
946 C . . . .
947 C SUBPROGRAM: UNPK7703 FILLS IN HEADER IN O-PUT ARRAY - PFLR RPT
948 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05
949 C
950 C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
951 C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
952 C HEADER DATA FOR WIND PROFILER REPORT. HEADER IS THEN FILLED INTO
953 C THE OUTPUT ARRAY WHICH HOLDS A SINGLE WIND PROFILER REPORT IN THE
954 C QUASI-OFFICE NOTE 29 UNPACKED FORMAT.
955 C
956 C PROGRAM HISTORY LOG:
957 C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
958 C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
959 C PROFILER) BUFR DUMP FILE AFTER 3/2002: MNEMONIC
960 C "NPSM" IS NO LONGER AVAILABLE, MNEMONIC "TPSE"
961 C REPLACES "TPMI" (AVG. TIME IN MINUTES STILL
962 C OUTPUT) (WILL STILL WORK PROPERLY FOR INPUT
963 C PROFLR DUMP FILES PRIOR TO 3/2002)
964 C
965 C USAGE: CALL UNPK7703(LUNIT,RDATA,IRET)
966 C INPUT ARGUMENT LIST:
967 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
968 C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
969 C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING
970 C
971 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
972 C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
973 C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN
974 C - (ALL OTHER DATA REMAINS MISSING)
975 C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
976 C
977 C OUTPUT FILES:
978 C UNIT 06 - PRINTOUT
979 C
980 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
981 C
982 C ATTRIBUTES:
983 C LANGUAGE: FORTRAN 90
984 C MACHINE: IBM-SP, CRAY, SGI
985 C
986 C$$$
987  SUBROUTINE unpk7703(LUNIT,RDATA,IRET)
988  CHARACTER*6 STNID
989  CHARACTER*8 COB
990  CHARACTER*35 HDR1,HDR2
991  INTEGER IDATA(1200)
992  REAL(8) HDR_8(16)
993  REAL HDR(16),RDATA(*),RDATX(1200)
994  COMMON /pk77bb/kdate(8),ldate(8),iprint
995 
996  SAVE
997 
998  equivalence(rdatx,idata),(cob,iob)
999  DATA xmsg/99999./,imsg/99999/
1000  DATA hdr1/'CLAT CLON TSIG SELV NPSM TPSE WMOB '/
1001  DATA hdr2/'WMOS YEAR MNTH DAYS HOUR MINU TPMI '/
1002  rdatx(1:1200) = rdata(1:1200)
1003  hdr_8 = 10.0e10
1004  CALL ufbint(lunit,hdr_8,16,1,nlev,hdr1//hdr2);hdr=hdr_8
1005  IF(nlev.NE.1) THEN
1006 C.......................................................................
1007 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
1008 C SET IRET = 6 AND RETURN
1009  print 217, nlev
1010  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
1011  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
1012  iret = 6
1013  RETURN
1014 C.......................................................................
1015  END IF
1016 
1017 C LATITUDE (STORED AS REAL)
1018 
1019  m = 1
1020  IF(iprint.GT.1) print 199, hdr(1),m
1021  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
1022  IF(hdr(1).LT.xmsg) THEN
1023  rdatx(1) = nint(hdr(1) * 100.)
1024  nnnnn = 1
1025  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1026  198 FORMAT(5x,'DATA(',i5,') STORED AS: ',f10.2)
1027  ELSE
1028  iret = 2
1029  print 102
1030  102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR WIND PROFILER ',
1031  $ 'REPORT'/)
1032  RETURN
1033  END IF
1034 
1035 C LONGITUDE (STORED AS REAL)
1036 
1037  m = 2
1038  IF(iprint.GT.1) print 199, hdr(2),m
1039  IF(hdr(2).LT.xmsg) THEN
1040  rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
1041  nnnnn = 2
1042  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1043  ELSE
1044  iret = 2
1045  print 104
1046  104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR WIND PROFILER ',
1047  $ 'REPORT'/)
1048  RETURN
1049  END IF
1050 
1051 C TIME SIGNIFICANCE (STORED AS INTEGER)
1052 
1053  m = 3
1054  IF(iprint.GT.1) print 199, hdr(3),m
1055  IF(hdr(3).LT.xmsg) idata(3) = nint(hdr(3))
1056  nnnnn = 3
1057  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
1058  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
1059 
1060 C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
1061 C (STORED AS REAL)
1062 
1063  m = 4
1064  IF(iprint.GT.1) print 199, hdr(4),m
1065  IF(hdr(4).LT.xmsg) rdatx(7) = nint(hdr(4))
1066  nnnnn = 7
1067  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1068 
1069 C SUBMODE INFORMATION
1070 C EDITION NUMBER (ALWAYS = 2)
1071 C (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER)
1072 C {NOTE: After 3/2002, the submode information is no longer
1073 C available and is stored as missing (3).}
1074 
1075  m = 5
1076  iedtn = 2
1077  idata(8) = (3 * 10) + iedtn
1078  IF(iprint.GT.1) print 199, hdr(5),m
1079  IF(hdr(5).LT.xmsg) idata(8) = (nint(hdr(5)) * 10) + iedtn
1080  nnnnn = 8
1081  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
1082 
1083 C AVERAGING TIME (STORED AS INTEGER)
1084 C (NOTE: Prior to 3/2002, this is decoded in minutes, after
1085 C 3/2002 this is decoded in seconds - in either case
1086 C it is stored in minutes)
1087 
1088  m = 6
1089  IF(iprint.GT.1) print 199, hdr(6),m
1090  IF(iprint.GT.1) print 199, hdr(14),m
1091  IF(hdr(6).LT.xmsg) THEN
1092  idata(10) = nint(hdr(6)/60.)
1093  ELSE IF(hdr(14).LT.xmsg) THEN
1094  idata(10) = nint(hdr(14))
1095  END IF
1096  nnnnn = 10
1097  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
1098 C-----------------------------------------------------------------------
1099 
1100 C STATION IDENTIFICATION (STORED AS CHARACTER)
1101 C (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS)
1102 
1103  stnid = ' '
1104 
1105 C WMO BLOCK NUMBER (STORED AS CHARACTER)
1106 
1107  m = 7
1108  IF(iprint.GT.1) print 199, hdr(7),m
1109  IF(hdr(7).LT.xmsg) WRITE(stnid(1:2),'(I2.2)') nint(hdr(7))
1110 
1111 C WMO STATION NUMBER (STORED AS CHARACTER)
1112 
1113  m = 8
1114  IF(iprint.GT.1) print 199, hdr(8),m
1115  IF(hdr(8).LT.xmsg) WRITE(stnid(3:5),'(I3.3)') nint(hdr(8))
1116  cob(1:4) = stnid(1:4)
1117  idata(11) = iob
1118  nnnnn = 11
1119  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
1120  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
1121  cob(1:4) = stnid(5:6)//' '
1122  idata(12) = iob
1123  nnnnn = 12
1124  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
1125 
1126 cvvvvvdak port
1127 C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
1128 caaaaadak port
1129 
1130  m = 9
1131  IF(iprint.GT.1) print 199, hdr(9),m
1132  iyear = imsg
1133  IF(hdr(9).LT.xmsg) iyear = nint(hdr(9))
1134  m = 10
1135  IF(iprint.GT.1) print 199, hdr(10),m
1136  IF(hdr(10).LT.xmsg.AND.iyear.LT.imsg) THEN
1137 cvvvvvdak port
1138  iyear = mod(iyear,100)
1139 caaaaadak port
1140  iyear = nint(hdr(10)) + (iyear * 100)
1141 cvvvvvdak port
1142 cdak WRITE(COB,'(I6.6,2X)') IYEAR
1143  WRITE(cob,'(I4.4,4X)') iyear
1144 caaaaadak port
1145  idata(5) = iob
1146  nnnnn = 5
1147  IF(iprint.GT.1) print 9196, nnnnn,cob(1:6)
1148  9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
1149  ELSE
1150  GO TO 30
1151  END IF
1152 
1153 C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
1154 C AND THE OBSERVATION TIME (STORED AS REAL)
1155 
1156  m = 11
1157  IF(iprint.GT.1) print 199, hdr(11),m
1158  iday = imsg
1159  IF(hdr(11).LT.xmsg) iday = nint(hdr(11))
1160  m = 12
1161  IF(iprint.GT.1) print 199, hdr(12),m
1162  IF(hdr(12).LT.xmsg.AND.iday.LT.imsg) THEN
1163  ihrt = nint(hdr(12))
1164  m = 13
1165  IF(iprint.GT.1) print 199, hdr(13),m
1166  IF(hdr(13).GE.xmsg) GO TO 30
1167  rmnt = hdr(13)
1168  rdatx(4) = nint((ihrt * 100.) + (rmnt * 100.)/60.)
1169  nnnnn = 4
1170  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1171  ihrt = ihrt + (iday * 100)
1172  WRITE(cob(1:4),'(I4.4)') ihrt
1173  idata(6) = iob
1174  nnnnn = 6
1175  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
1176  ELSE
1177  GO TO 30
1178  END IF
1179  rdata(1:1200) = rdatx(1:1200)
1180  RETURN
1181  30 CONTINUE
1182  iret = 4
1183  RETURN
1184  END
1185 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1186 C . . . .
1187 C SUBPROGRAM: UNPK7704 FILLS CAT.10 INTO O-PUT ARRAY - PFLR RPT
1188 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05
1189 C
1190 C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
1191 C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
1192 C SURFACE DATA FOR WIND PROFILER REPORT. SURFACE DATA ARE THEN
1193 C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 10. THE OUPUT ARRAY
1194 C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29
1195 C UNPACKED FORMAT.
1196 C
1197 C PROGRAM HISTORY LOG:
1198 C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
1199 C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
1200 C PROFILER) BUFR DUMP FILE AFTER 3/2002: SURFACE
1201 C DATA NOW ALL MISSING (MNEMONICS "PMSL",
1202 C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO
1203 C LONGER AVAILABLE) (WILL STILL WORK PROPERLY FOR
1204 C INPUT PROFLR DUMP FILES PRIOR TO 3/2002)
1205 C
1206 C USAGE: CALL UNPK7704(LUNIT,RDATA)
1207 C INPUT ARGUMENT LIST:
1208 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
1209 C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
1210 C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED
1211 C - IN (ALL OTHER DATA REMAINS MISSING)
1212 C
1213 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
1214 C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
1215 C - UNPACKED FORMAT WITH SURFACE INFORMATION FILLED IN
1216 C - (AS WELL AS THE HEADER; ALL OTHER DATA REMAINS
1217 C - MISSING)
1218 C
1219 C OUTPUT FILES:
1220 C UNIT 06 - PRINTOUT
1221 C
1222 C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. AFTER 3/2002, THERE IS
1223 C NO SURFACE DATA AVAILABLE.
1224 C
1225 C ATTRIBUTES:
1226 C LANGUAGE: FORTRAN 90
1227 C MACHINE: IBM-SP, CRAY, SGI
1228 C
1229 C$$$
1230  SUBROUTINE unpk7704(LUNIT,RDATA)
1231  CHARACTER*40 SRFC
1232  INTEGER IDATA(1200)
1233  REAL(8) SFC_8(8)
1234  REAL SFC(8),RDATA(*),RDATX(1200)
1235  COMMON /pk77bb/kdate(8),ldate(8),iprint
1236 
1237  SAVE
1238 
1239  equivalence(rdatx,idata)
1240  DATA xmsg/99999./
1241  DATA srfc/'PMSL WDIR1 WSPD1 TMDB REHU REQV '/
1242  rdatx(1:1200) = rdata(1:1200)
1243  sfc_8 = 10.0e10
1244  CALL ufbint(lunit,sfc_8,8,1,nlev,srfc);sfc=sfc_8
1245  IF(nlev.NE.1) THEN
1246 C.......................................................................
1247 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
1248  print 217, nlev
1249  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
1250  $ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/)
1251  GO TO 99
1252 C.......................................................................
1253  END IF
1254 
1255 C MSL PRESSURE (STORED AS REAL)
1256 
1257  m = 1
1258  IF(iprint.GT.1) print 199, sfc(1),m
1259  199 FORMAT(5x,'SFC HERE IS: ',f17.4,'; INDEX IS: ',i3)
1260  IF((sfc(1)*0.1).LT.xmsg) rdatx(43) = nint(sfc(1) * 0.1)
1261  nnnnn = 43
1262  IF(iprint.GT.1) print 198, nnnnn,rdatx(43)
1263  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
1264 
1265 C SURFACE HORIZONTAL WIND DIRECTION (STORED AS REAL)
1266 
1267  m = 2
1268  IF(iprint.GT.1) print 199, sfc(2),m
1269  IF(sfc(2).LT.xmsg) rdatx(43+2) = nint(sfc(2))
1270  nnnnn = 43 + 2
1271  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+2)
1272 
1273 C SURFACE HORIZONTAL WIND SPEED (STORED AS REAL)
1274 
1275  m = 3
1276  IF(iprint.GT.1) print 199, sfc(3),m
1277  IF(sfc(3).LT.xmsg) rdatx(43+3) = nint(sfc(3) * 10.)
1278  nnnnn = 43 + 3
1279  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+3)
1280 
1281 C SURFACE TEMPERATURE (STORED AS REAL)
1282 
1283  m = 4
1284  IF(iprint.GT.1) print 199, sfc(4),m
1285  IF(sfc(4).LT.xmsg) rdatx(43+4) = nint(sfc(4) * 10.)
1286  nnnnn = 43 + 4
1287  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+4)
1288 
1289 C RELATIVE HUMIDITY (STORED AS REAL)
1290 
1291  m = 5
1292  IF(iprint.GT.1) print 199, sfc(5),m
1293  IF(sfc(5).LT.xmsg) rdatx(43+5) = nint(sfc(5))
1294  nnnnn = 43 + 5
1295  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+5)
1296 
1297 C RAINFALL RATE (STORED AS REAL)
1298 
1299  m = 6
1300  IF(iprint.GT.1) print 199, sfc(6),m
1301  IF(sfc(6).LT.xmsg) rdatx(43+6) = nint(sfc(6) * 1.e7)
1302  nnnnn = 43 + 6
1303  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+6)
1304 
1305 C SET CATEGORY COUNTERS FOR SURFACE DATA
1306 
1307  idata(35) = 1
1308  idata(36) = 43
1309  99 CONTINUE
1310  IF(iprint.GT.1) print *, 'IDATA(35)=',idata(35),'; IDATA(36)=',
1311  $ idata(36)
1312  rdata(1:1200) = rdatx(1:1200)
1313  RETURN
1314  END
1315 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1316 C . . . .
1317 C SUBPROGRAM: UNPK7705 FILLS CAT.11 INTO O-PUT ARRAY - PFLR RPT
1318 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05
1319 C
1320 C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
1321 C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
1322 C UPPER-AIR DATA FOR WIND PROFILER REPORT. UPPER-AIR DATA ARE THEN
1323 C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 11. THE OUPUT ARRAY
1324 C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29
1325 C UNPACKED FORMAT.
1326 C
1327 C PROGRAM HISTORY LOG:
1328 C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
1329 C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ.
1330 C SIGNIFICANCE, VERT. SIGNIFICANCE) PROCESSING
1331 C TO ACCOUNT FOR UPDATES TO BUFRTABLE MNEMONICS
1332 C IN /dcom
1333 C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
1334 C PROFILER) BUFR DUMP FILE AFTER 3/2002:
1335 C MNEMONICS "ACAVH", "ACAVV", "SPP0", AND "NPHL"
1336 C NO LONGER AVAILABLE; (WILL STILL WORK PROPERLY
1337 C FOR INPUT PROFLR DUMP FILES PRIOR TO 3/2002)
1338 C
1339 C USAGE: CALL UNPK7705(LUNIT,RDATA)
1340 C INPUT ARGUMENT LIST:
1341 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
1342 C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
1343 C - UNPACKED FORMAT WITH ONLY HEADER AND SURFACE
1344 C - INFORMATION FILLED IN (UPPER-AIR DATA MISSING)
1345 C
1346 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
1347 C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
1348 C - UNPACKED FORMAT WITH UPPER-AIR INFORMATION FILLED
1349 C - IN (ALL DATA FOR REPORT NOW FILLED)
1350 C
1351 C OUTPUT FILES:
1352 C UNIT 06 - PRINTOUT
1353 C
1354 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
1355 C
1356 C ATTRIBUTES:
1357 C LANGUAGE: FORTRAN 90
1358 C MACHINE: IBM-SP, CRAY, SGI
1359 C
1360 C$$$
1361  SUBROUTINE unpk7705(LUNIT,RDATA)
1362  CHARACTER*31 UAIR1,UAIR2
1363  CHARACTER*16 UAIR3
1364  INTEGER IDATA(1200)
1365  REAL(8) UAIR_8(16,255)
1366  REAL UAIR(16,255),RDATA(*),RDATX(1200)
1367  COMMON /pk77bb/kdate(8),ldate(8),iprint
1368 
1369  SAVE
1370 
1371  equivalence(rdatx,idata)
1372  DATA xmsg/99999./
1373  DATA uair1/'HEIT WDIR WSPD NPQC WCMP ACAVH '/
1374  DATA uair2/'ACAVV SPP0 SDHS SDVS NPHL '/
1375  DATA uair3/'HAST ACAV1 ACAV2'/
1376  rdatx(1:1200) = rdata(1:1200)
1377  nsfc = 0
1378  ilvl = 0
1379  ilc = 0
1380 C FIRST UPPER-AIR LEVEL IS THE SURFACE INFORMATION
1381  IF(iprint.GT.1) print 1078, ilc,ilvl
1382  1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',i5,'; NO. LEVELS ',
1383  $ 'PROCESSED TO NOW =',i5)
1384  rdatx(50+ilc) = rdatx(7)
1385  IF(iprint.GT.1) print 198, 50+ilc,rdatx(50+ilc)
1386  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
1387  IF(rdatx(50+ilc).LT.xmsg) nsfc = 1
1388  IF(idata(35).GE.1) THEN
1389  rdatx(50+ilc+1) = rdatx(idata(36)+2)
1390  rdatx(50+ilc+2) = rdatx(idata(36)+3)
1391  END IF
1392  IF(iprint.GT.1) print 198, 50+ilc+1,rdatx(50+ilc+1)
1393  IF(rdatx(50+ilc+1).LT.xmsg) nsfc = 1
1394  IF(iprint.GT.1) print 198, 50+ilc+2,rdatx(50+ilc+2)
1395  IF(rdatx(50+ilc+2).LT.xmsg) nsfc = 1
1396  ilvl = ilvl + 1
1397  ilc = ilc + 11
1398  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,' WITH ',
1399  $ 'NSFC=',nsfc,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
1400  uair_8 = 10.0e10
1401  CALL ufbint(lunit,uair_8,16,255,nlev,uair1//uair2//uair3)
1402  uair=uair_8
1403  IF(nlev.EQ.0) THEN
1404 C.......................................................................
1405 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
1406  IF(nsfc.EQ.0) THEN
1407 C ... NO UPPER AIR DATA PROCESSED
1408  print 217
1409  217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
1410  $ ' REPORT -- NLEV = 0 AND NSFC = 0'/)
1411  GO TO 99
1412  ELSE
1413 C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
1414  print 218
1415  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
1416  $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
1417  GO TO 98
1418  END IF
1419 C.......................................................................
1420  END IF
1421  IF(iprint.GT.1) print 1068, nlev
1422  1068 FORMAT(' THIS REPORT CONTAINS ',i3,' LEVELS OF DATA (NOT ',
1423  $ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
1424  DO i = 1,nlev
1425  IF(iprint.GT.1) print 1079, ilc,ilvl
1426  1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',i5,'; NO. LEVELS ',
1427  $ 'PROCESSED TO NOW =',i5)
1428 
1429 C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
1430 C (NOTE: At one time, possibly even now, the height above sea
1431 C level was erroneously stored under mnemonic "HAST"
1432 C when it should have been stored under mnemonic "HEIT".
1433 C ("HAST" is defined as the height above the station.)
1434 C Will test first for valid data in "HEIT" - if missing,
1435 C then will use data in "HAST" - this will allow this
1436 C routine to transition w/o change when the fix is made.)
1437 
1438  IF(uair(1,i).LT.xmsg) THEN
1439  m = 1
1440  IF(iprint.GT.1) print 199, uair(1,i),m
1441  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
1442  rdatx(50+ilc) = nint(uair(1,i))
1443  ELSE
1444  m = 12
1445  IF(iprint.GT.1) print 199, uair(12,i),m
1446  IF(uair(12,i).LT.xmsg) rdatx(50+ilc) = nint(uair(12,i))
1447  END IF
1448  IF(iprint.GT.1) print 198, 50+ilc,rdatx(50+ilc)
1449  ilvl = ilvl + 1
1450 
1451 C HORIZONTAL WIND DIRECTION (STORED AS REAL)
1452 
1453  m = 2
1454  IF(iprint.GT.1) print 199, uair(2,i),m
1455  IF(uair(2,i).LT.xmsg) rdatx(50+ilc+1) = nint(uair(2,i))
1456  IF(iprint.GT.1) print 198, 50+ilc+1,rdatx(50+ilc+1)
1457 
1458 C HORIZONTAL WIND SPEED (STORED AS REAL)
1459 
1460  m = 3
1461  IF(iprint.GT.1) print 199, uair(3,i),m
1462  IF(uair(3,i).LT.xmsg) rdatx(50+ilc+2) =nint(uair(3,i) * 10.)
1463  IF(iprint.GT.1) print 198, 50+ilc+2,rdatx(50+ilc+2)
1464 
1465 C QUALITY CODE (STORED AS INTEGER)
1466 
1467  m = 4
1468  IF(iprint.GT.1) print 199, uair(4,i),m
1469  IF(uair(4,i).LT.xmsg) idata(50+ilc+3) = nint(uair(4,i))
1470  IF(iprint.GT.1) print 197, 50+ilc+3,idata(50+ilc+3)
1471  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
1472 
1473 C VERTICAL WIND COMPONENT (W) (STORED AS REAL)
1474 
1475  m = 5
1476  IF(iprint.GT.1) print 199, uair(5,i),m
1477  IF(uair(5,i).LT.xmsg) rdatx(50+ilc+4) = nint(uair(5,i) * 100.)
1478  IF(iprint.GT.1) print 198, 50+ilc+4,rdatx(50+ilc+4)
1479 
1480 C HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER)
1481 C (NOTE: Prior to 2/18/1999, the horizonal consensus number was
1482 C stored under mnemonic "ACAV1".
1483 C From 2/18/1999 through 3/2002, the horizontal consensus
1484 C number was stored under mnemonic "ACAVH".
1485 C After 3/2002, the horizontal consensus number is no
1486 C longer stored.
1487 C Will test first for valid data in "ACAVH" - if missing,
1488 C then will test for data in "ACAV1" - this will allow
1489 C this routine to work properly with historical data.)
1490 
1491  IF(iprint.GT.1) print 199, uair(6,i),m
1492  IF(iprint.GT.1) print 199, uair(13,i),m
1493  IF(uair(6,i).LT.xmsg) THEN
1494  m = 6
1495  idata(50+ilc+5) = nint(uair(6,i))
1496  ELSE
1497  m = 13
1498  IF(uair(13,i).LT.xmsg) idata(50+ilc+5) = nint(uair(13,i))
1499  END IF
1500  IF(iprint.GT.1) print 197, 50+ilc+5,idata(50+ilc+5)
1501 
1502 C VERTICAL CONSENSUS NUMBER (STORED AS INTEGER)
1503 C (NOTE: Prior to 2/18/1999, the vertical consensus number was
1504 C stored under mnemonic "ACAV2".
1505 C From 2/18/1999 through 3/2002, the vertical consensus
1506 C number was stored under mnemonic "ACAVV".
1507 C After 3/2002, the vertical consensus number is no
1508 C longer stored.
1509 C Will test first for valid data in "ACAVV" - if missing,
1510 C then will test for data in "ACAV2" - this will allow
1511 C this routine to work properly with historical data.)
1512 
1513  IF(iprint.GT.1) print 199, uair(7,i),m
1514  IF(iprint.GT.1) print 199, uair(14,i),m
1515  IF(uair(7,i).LT.xmsg) THEN
1516  m = 7
1517  idata(50+ilc+6) = nint(uair(7,i))
1518  ELSE
1519  m = 14
1520  IF(uair(14,i).LT.xmsg) idata(50+ilc+6) = nint(uair(14,i))
1521  END IF
1522  IF(iprint.GT.1) print 197, 50+ilc+6,idata(50+ilc+6)
1523 
1524 C SPECTRAL PEAK POWER (STORED AS REAL)
1525 C (NOTE: After 3/2002, the spectral peak power is no longer
1526 C stored.)
1527 
1528  m = 8
1529  IF(iprint.GT.1) print 199, uair(8,i),m
1530  IF(uair(8,i).LT.xmsg) rdatx(50+ilc+7) = nint(uair(8,i))
1531  IF(iprint.GT.1) print 198, 50+ilc+7,rdatx(50+ilc+7)
1532 
1533 C HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL)
1534 
1535  m = 9
1536  IF(iprint.GT.1) print 199, uair(9,i),m
1537  IF(uair(9,i).LT.xmsg) rdatx(50+ilc+8)=nint(uair(9,i) * 10.)
1538  IF(iprint.GT.1) print 198, 50+ilc+8,rdatx(50+ilc+8)
1539 
1540 C VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL)
1541 
1542  m = 10
1543  IF(iprint.GT.1) print 199, uair(10,i),m
1544  IF(uair(10,i).LT.xmsg) rdatx(50+ilc+9) =nint(uair(10,i) * 10.)
1545  IF(iprint.GT.1) print 198, 50+ilc+9,rdatx(50+ilc+9)
1546 
1547 C MODE INFORMATION (STORED AS INTEGER)
1548 C (NOTE: After 3/2002, the mode information is no longer stored.)
1549 
1550  m = 11
1551  IF(iprint.GT.1) print 199, uair(11,i),m
1552  IF(uair(11,i).LT.xmsg) idata(50+ilc+10) = nint(uair(11,i))
1553  IF(iprint.GT.1) print 197, 50+ilc+10,idata(50+ilc+10)
1554 C.......................................................................
1555  ilc = ilc + 11
1556  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,
1557  $ '; GOING INTO NEXT LEVEL WITH ILC=',ilc
1558  ENDDO
1559 
1560 C SET CATEGORY COUNTERS FOR UPPER-AIR DATA
1561 
1562  98 CONTINUE
1563  idata(37) = ilvl
1564  idata(38) = 50
1565  99 CONTINUE
1566  IF(iprint.GT.1) print *, 'NSFC=',nsfc,'; IDATA(37)=',idata(37),
1567  $ '; IDATA(38)=',idata(38)
1568  rdata(1:1200) = rdatx(1:1200)
1569  RETURN
1570  END
1571 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1572 C . . . .
1573 C SUBPROGRAM: UNPK7706 FILLS IN HEADER IN O-PUT ARRAY - VADW RPT
1574 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02
1575 C
1576 C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
1577 C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
1578 C HEADER DATA FOR NEXRAD (VAD) WIND REPORT. HEADER IS THEN FILLED
1579 C INTO THE OUTPUT ARRAY WHICH HOLDS A SINGLE VAD WIND REPORT IN THE
1580 C QUASI-OFFICE NOTE 29 UNPACKED FORMAT.
1581 C
1582 C PROGRAM HISTORY LOG:
1583 C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR
1584 C
1585 C USAGE: CALL UNPK7706(LUNIT,RDATA,IRET)
1586 C INPUT ARGUMENT LIST:
1587 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
1588 C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
1589 C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING
1590 C
1591 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
1592 C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
1593 C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN
1594 C - (ALL OTHER DATA REMAINS MISSING)
1595 C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
1596 C
1597 C OUTPUT FILES:
1598 C UNIT 06 - PRINTOUT
1599 C
1600 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
1601 C
1602 C ATTRIBUTES:
1603 C LANGUAGE: FORTRAN 90
1604 C MACHINE: IBM-SP, CRAY, SGI
1605 C
1606 C$$$
1607  SUBROUTINE unpk7706(LUNIT,RDATA,IRET)
1608  CHARACTER*8 STNID,COB
1609  CHARACTER*45 HDR1
1610  INTEGER IDATA(1200)
1611  REAL(8) HDR_8(9)
1612  REAL HDR(9),RDATA(*),RDATX(1200)
1613  COMMON /pk77bb/kdate(8),ldate(8),iprint
1614 
1615  SAVE
1616 
1617  equivalence(rdatx,idata),(stnid,hdr_8(4)),(cob,iob)
1618  DATA xmsg/99999./,imsg/99999/
1619  DATA hdr1/'CLAT CLON SELV RPID YEAR MNTH DAYS HOUR MINU '/
1620  rdatx(1:1200) = rdata(1:1200)
1621  hdr_8 = 10.0e10
1622  CALL ufbint(lunit,hdr_8,9,1,nlev,hdr1);hdr=hdr_8
1623  IF(nlev.NE.1) THEN
1624 C.......................................................................
1625 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
1626 C SET IRET = 6 AND RETURN
1627  print 217, nlev
1628  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
1629  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
1630  iret = 6
1631  RETURN
1632 C.......................................................................
1633  END IF
1634 
1635 C LATITUDE (STORED AS REAL)
1636 
1637  m = 1
1638  IF(iprint.GT.1) print 199, hdr(1),m
1639  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
1640  IF(hdr(1).LT.xmsg) THEN
1641  rdatx(1) = nint(hdr(1) * 100.)
1642  nnnnn = 1
1643  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1644  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
1645  ELSE
1646  iret = 2
1647  print 102
1648  102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR VAD WIND REPORT'/)
1649  RETURN
1650  END IF
1651 
1652 C LONGITUDE (STORED AS REAL)
1653 
1654  m = 2
1655  IF(iprint.GT.1) print 199, hdr(2),m
1656  IF(hdr(2).LT.xmsg) THEN
1657  rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
1658  nnnnn = 2
1659  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1660  ELSE
1661  iret = 2
1662  print 104
1663  104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR VAD WIND REPORT'/)
1664  RETURN
1665  END IF
1666 
1667 C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
1668 C (STORED AS REAL)
1669 
1670  m = 3
1671  IF(iprint.GT.1) print 199, hdr(3),m
1672  IF(hdr(3).LT.xmsg) rdatx(7) = nint(hdr(3))
1673  nnnnn = 7
1674  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1675 
1676 C STATION IDENTIFICATION (STORED AS CHARACTER)
1677 C ('99'//LAST 3-CHARACTERS OF PRODUCT SOURCE ID//' ')
1678 
1679  m = 4
1680  IF(iprint.GT.1) print 299, stnid,m
1681  299 FORMAT(5x,'HDR HERE IS: ',9x,a8,'; INDEX IS: ',i3)
1682  cob(1:4) = '99'//stnid(2:3)
1683  idata(11) = iob
1684  nnnnn = 11
1685  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
1686  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
1687  cob(1:4) = stnid(4:4)//' '
1688  idata(12) = iob
1689  nnnnn = 12
1690  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
1691 
1692 cvvvvvdak port
1693 C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
1694 caaaaadak port
1695 
1696  m = 5
1697  IF(iprint.GT.1) print 199, hdr(5),m
1698  iyear = imsg
1699  IF(hdr(5).LT.xmsg) iyear = nint(hdr(5))
1700  m = 6
1701  IF(iprint.GT.1) print 199, hdr(6),m
1702  IF(hdr(6).LT.xmsg.AND.iyear.LT.imsg) THEN
1703 cvvvvvdak port
1704  iyear = mod(iyear,100)
1705 caaaaadak port
1706  iyear = nint(hdr(6)) + (iyear * 100)
1707 cvvvvvdak port
1708 cdak WRITE(COB,'(I6.6,2X)') IYEAR
1709  WRITE(cob,'(I4.4,4X)') iyear
1710 caaaaadak port
1711  idata(5) = iob
1712  nnnnn = 5
1713  IF(iprint.GT.1) print 9196, nnnnn,cob(1:6)
1714  9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
1715  ELSE
1716  GO TO 30
1717  END IF
1718 
1719 C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
1720 C AND THE OBSERVATION TIME (STORED AS REAL)
1721 
1722  m = 7
1723  IF(iprint.GT.1) print 199, hdr(7),m
1724  iday = imsg
1725  IF(hdr(7).LT.xmsg) iday = nint(hdr(7))
1726  m = 8
1727  IF(iprint.GT.1) print 199, hdr(8),m
1728  IF(hdr(8).LT.xmsg.AND.iday.LT.imsg) THEN
1729  ihrt = nint(hdr(8))
1730  m = 9
1731  IF(iprint.GT.1) print 199, hdr(9),m
1732  IF(hdr(9).GE.xmsg) GO TO 30
1733  rmnt = hdr(9)
1734  rdatx(4) = nint((ihrt * 100.) + (rmnt * 100.)/60.)
1735  nnnnn = 4
1736  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
1737  ihrt = ihrt + (iday * 100)
1738  WRITE(cob(1:4),'(I4.4)') ihrt
1739  idata(6) = iob
1740  nnnnn = 6
1741  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
1742  ELSE
1743  GO TO 30
1744  END IF
1745  rdata(1:1200) = rdatx(1:1200)
1746  RETURN
1747  30 CONTINUE
1748  iret = 4
1749  RETURN
1750  END
1751 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1752 C . . . .
1753 C SUBPROGRAM: UNPK7707 FILLS CAT. 4 INTO O-PUT ARRAY - VADW RPT
1754 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02
1755 C
1756 C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
1757 C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
1758 C UPPER-AIR DATA FOR NEXRAD (VAD) WIND REPORT. UPPER-AIR DATA ARE
1759 C THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 4. THE OUPUT ARRAY
1760 C HOLDS A SINGLE VAD WIND REPORT IN THE QUASI-OFFICE NOTE 29
1761 C UNPACKED FORMAT.
1762 C
1763 C PROGRAM HISTORY LOG:
1764 C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR
1765 C
1766 C USAGE: CALL UNPK7707(LUNIT,RDATA,IRET)
1767 C INPUT ARGUMENT LIST:
1768 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
1769 C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
1770 C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED
1771 C - IN (CATEGORY 4 DATA MISSING)
1772 C
1773 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
1774 C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
1775 C - UNPACKED FORMAT WITH CATEGORY 4 INFORMATION FILLED IN
1776 C - (ALL DATA FOR REPORT NOW FILLED)
1777 C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
1778 C
1779 C OUTPUT FILES:
1780 C UNIT 06 - PRINTOUT
1781 C
1782 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
1783 C
1784 C ATTRIBUTES:
1785 C LANGUAGE: FORTRAN 90
1786 C MACHINE: IBM-SP, CRAY, SGI
1787 C
1788 C$$$
1789  SUBROUTINE unpk7707(LUNIT,RDATA,IRET)
1790  CHARACTER*1 CRMS(0:12)
1791  CHARACTER*8 COB
1792  CHARACTER*25 UAIR1
1793  INTEGER IDATA(1200)
1794  REAL(8) UAIR_8(5,255)
1795  REAL UAIR(5,255),RDATA(*),RDATX(1200)
1796  COMMON /pk77bb/kdate(8),ldate(8),iprint
1797 
1798  SAVE
1799 
1800  equivalence(rdatx,idata),(cob,iob)
1801  DATA xmsg/99999./
1802  DATA uair1/'HEIT WDIR WSPD RMSW QMWN '/
1803  DATA crms/' ','A',' ','B',' ','C',' ','D',' ','E',' ','F',' '/
1804  rdatx(1:1200) = rdata(1:1200)
1805  nsfc = 0
1806  ilvl = 0
1807  ilc = 0
1808 C FIRST CATEGORY 4 LEVEL UPPER-AIR LEVEL CONTAINS ONLY HEIGHT (ELEV)
1809  IF(iprint.GT.1) print 1078, ilc,ilvl
1810  1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',i5,'; NO. LEVELS ',
1811  $ 'PROCESSED TO NOW =',i5)
1812  rdatx(43+ilc) = rdatx(7)
1813  IF(iprint.GT.1) print 198, 43+ilc,rdatx(43+ilc)
1814  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
1815  IF(rdatx(43+ilc).LT.xmsg) nsfc = 1
1816 C NOTE: The following was added because of a problem on the sgi-ha
1817 C platform related to equivalencing character and non-character
1818 C -- for now the addition of these two lines will set the quality
1819 C mark for sfc. cat . 4 level to the correct value of " "
1820 C rather than to "9999" - Mary McCann notified SGI of this
1821 C problem on 08-21-1998
1822  cob = ' '
1823  idata(43+ilc+3) = iob
1824  ilvl = ilvl + 1
1825  ilc = ilc + 4
1826  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,' WITH ',
1827  $ 'NSFC=',nsfc,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
1828  uair_8 = 10.0e10
1829  CALL ufbint(lunit,uair_8,5,255,nlev,uair1);uair=uair_8
1830  IF(nlev.EQ.0) THEN
1831 C.......................................................................
1832 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
1833  IF(nsfc.EQ.0) THEN
1834 C ... NO UPPER AIR DATA PROCESSED
1835  print 217
1836  217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
1837  $ ' REPORT -- NLEV = 0 AND NSFC = 0'/)
1838  GO TO 99
1839  ELSE
1840 C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
1841  print 218
1842  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
1843  $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
1844  GO TO 98
1845  END IF
1846 C.......................................................................
1847  END IF
1848  IF(iprint.GT.1) print 1068, nlev
1849  1068 FORMAT(' THIS REPORT CONTAINS ',i3,' LEVELS OF DATA (NOT ',
1850  $ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
1851  DO i = 1,nlev
1852  IF(iprint.GT.1) print 1079, ilc,ilvl
1853  1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',i5,'; NO. LEVELS ',
1854  $ 'PROCESSED TO NOW =',i5)
1855 
1856 C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
1857 
1858  m = 1
1859  IF(iprint.GT.1) print 199, uair(1,i),m
1860  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
1861  IF(uair(1,i).LT.xmsg) THEN
1862  rdatx(43+ilc) = nint(uair(1,i))
1863 
1864 C ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT
1865 
1866  ilvl = ilvl + 1
1867  ELSE
1868 
1869 C ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID
1870 C HEIGHT GO ON TO NEXT INPUT LEVEL
1871 
1872  IF(iprint.GT.1) print *, 'HEIGHT MISSING ON INPUT ',
1873  $ ' LEVEL ',i,', ALL OTHER DATA SET TO MSG ON THIS LEVEL'
1874  GO TO 10
1875  END IF
1876  IF(iprint.GT.1) print 198, 43+ilc,rdatx(43+ilc)
1877 
1878 C HORIZONTAL WIND DIRECTION (STORED AS REAL)
1879 
1880  m = 2
1881  IF(iprint.GT.1) print 199, uair(2,i),m
1882  IF(uair(2,i).LT.xmsg) rdatx(43+ilc+1) = nint(uair(2,i))
1883  IF(iprint.GT.1) print 198, 43+ilc+1,rdatx(43+ilc+1)
1884 
1885 C HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED
1886 C AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD
1887 C INDICATE FOR CAT. 4 WIND SPEED)
1888 
1889  m = 3
1890  IF(iprint.GT.1) print 199, uair(3,i),m
1891  IF(uair(3,i).LT.xmsg) rdatx(43+ilc+2) =nint(uair(3,i) * 10.)
1892  IF(iprint.GT.1) print 198, 43+ilc+2,rdatx(43+ilc+2)
1893 
1894 C CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR)
1895 C (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED
1896 C IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE
1897 C W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT
1898 C LAYOUT FOR VALUES
1899 
1900  m = 4
1901  IF(iprint.GT.1) print 199, uair(4,i),m
1902  IF(uair(4,i).LT.xmsg) THEN
1903 
1904 C ... CONVERT FROM M/S TO KNOTS
1905 
1906 CDAKCDAK KRMS = INT(1.93333 * UAIR(4,I))
1907  krms = int(1.9425 * uair(4,i))
1908  cob = ' '
1909  IF(krms.LT.13) THEN
1910  cob(4:4) = crms(krms)
1911  ELSE
1912  cob(4:4) = 'G'
1913  END IF
1914  idata(43+ilc+3) = iob
1915  END IF
1916  IF(iprint.GT.1) print 196, 43+ilc+3,cob(1:4)
1917  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
1918 
1919 C ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED)
1920 
1921  m = 5
1922  IF(iprint.GT.1) print 199, uair(5,i),m
1923 C.......................................................................
1924  ilc = ilc + 4
1925  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,
1926  $ '; GOING INTO NEXT LEVEL WITH ILC=',ilc
1927 
1928  10 CONTINUE
1929  ENDDO
1930 
1931 C SET CATEGORY COUNTERS FOR UPPER-AIR DATA
1932 
1933  98 CONTINUE
1934  idata(19) = ilvl
1935  99 CONTINUE
1936  IF(idata(19).EQ.0) THEN
1937  idata(20) = 0
1938  iret = 5
1939  ELSE
1940  idata(20) = 43
1941  END IF
1942  IF(iprint.GT.1) print *, 'NSFC=',nsfc,'; IDATA(37)=',idata(37),
1943  $ '; IDATA(38)=',idata(38)
1944  rdata(1:1200) = rdatx(1:1200)
1945  RETURN
1946  END
1947 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1948 C . . . .
1949 C SUBPROGRAM: UNPK7708 FILLS IN HEADER IN O-PUT ARRAY - GOES SND
1950 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-07-09
1951 C
1952 C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
1953 C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
1954 C HEADER DATA FOR GOES SOUNDING REPORT. HEADER IS THEN FILLED INTO
1955 C THE OUTPUT ARRAY WHICH HOLDS A SINGLE GOES SOUNDING REPORT IN THE
1956 C QUASI-OFFICE NOTE 29 UNPACKED FORMAT.
1957 C
1958 C PROGRAM HISTORY LOG:
1959 C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR
1960 C 1998-07-09 KEYSER -- CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR
1961 C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S
1962 C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME
1963 C CHAR. 6 TAG)
1964 C
1965 C USAGE: CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET)
1966 C INPUT ARGUMENT LIST:
1967 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
1968 C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
1969 C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING
1970 C KOUNT - NUMBER OF REPORTS PROCESSED INCLUDING THIS ONE
1971 C
1972 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
1973 C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
1974 C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN
1975 C - (ALL OTHER DATA REMAINS MISSING)
1976 C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
1977 C
1978 C OUTPUT FILES:
1979 C UNIT 06 - PRINTOUT
1980 C
1981 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
1982 C
1983 C ATTRIBUTES:
1984 C LANGUAGE: FORTRAN 90
1985 C MACHINE: IBM-SP, CRAY, SGI
1986 C
1987 C$$$
1988  SUBROUTINE unpk7708(LUNIT,RDATA,KOUNT,IRET)
1989  CHARACTER*1 C6TAG(3,0:3)
1990  CHARACTER*8 STNID,COB
1991  CHARACTER*35 HDR1,HDR2
1992  INTEGER IDATA(1200)
1993  REAL(8) HDR_8(12)
1994  REAL HDR(12),RDATA(*),RDATX(1200)
1995  COMMON /pk77bb/kdate(8),ldate(8),iprint
1996  COMMON /pk77ff/ifov(3),kntsat(250:260)
1997 
1998  SAVE
1999 
2000  equivalence(rdatx,idata),(cob,iob)
2001  DATA xmsg/99999./,imsg/99999/
2002  DATA hdr1/'CLAT CLON ACAV GSDP QMRK SAID YEAR '/
2003  DATA hdr2/'MNTH DAYS HOUR MINU SECO '/
2004 
2005 
2006 C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007)
2007 C -----------------------------------------------------------
2008 
2009 C GOES 6 -- 250 GOES 9 -- 253 GOES 12 -- 256
2010 C GOES 7 -- 251 GOES 10 -- 254 GOES 13 -- 257
2011 C GOES 8 -- 252 GOES 11 -- 255 GOES 14 -- 258
2012 
2013 C IDSAT = -- EVEN1 -- --- ODD1 -- -- EVEN2 -- --- ODD2 --
2014 C Sat. No. - 252,256,... 253,257,... 250,254,... 251,255,...
2015 C IRTYP = CLR COR UNKN CLR COR UNKN CLR COR UNKN CLR COR UNKN
2016 C --- --- ---- --- --- ---- --- --- ---- --- --- ----
2017 
2018  DATA c6tag/'I','J','?', 'L','M','?', 'O','P','?', 'Q','R','?' /
2019 
2020  rdatx(1:1200) = rdata(1:1200)
2021  hdr_8 = 10.0e10
2022  CALL ufbint(lunit,hdr_8,12,1,nlev,hdr1//hdr2);hdr=hdr_8
2023  IF(nlev.NE.1) THEN
2024 C.......................................................................
2025 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
2026 C SET IRET = 6 AND RETURN
2027  print 217, nlev
2028  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
2029  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
2030  iret = 6
2031  RETURN
2032 C.......................................................................
2033  END IF
2034 
2035 C LATITUDE (STORED AS REAL)
2036 
2037  m = 1
2038  IF(iprint.GT.1) print 199, hdr(1),m
2039  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
2040  IF(hdr(1).LT.xmsg) THEN
2041  rdatx(1) = nint(hdr(1) * 100.)
2042  nnnnn = 1
2043  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
2044  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
2045  ELSE
2046  iret = 2
2047  print 102
2048  102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR GOES SOUNDING'/)
2049  RETURN
2050  END IF
2051 
2052 C LONGITUDE (STORED AS REAL)
2053 
2054  m = 2
2055  IF(iprint.GT.1) print 199, hdr(2),m
2056  IF(hdr(2).LT.xmsg) THEN
2057  rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
2058  nnnnn = 2
2059  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
2060  ELSE
2061  iret = 2
2062  print 104
2063  104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR GOES SOUNDING'/)
2064  RETURN
2065  END IF
2066 
2067 C NUMBER OF FIELDS OF VIEW - SAMPLE SIZE (STORED AS INTEGER)
2068 
2069  m = 3
2070  IF(iprint.GT.1) print 199, hdr(3),m
2071  IF(hdr(3).LT.xmsg) idata(3) = nint(hdr(3))
2072  nnnnn = 3
2073  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
2074  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
2075 
2076 C STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL)
2077 C (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709
2078 
2079 
2080 C RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING
2081 C TECHNIQUE USED) (STORED AS INTEGER)
2082 
2083  m = 4
2084  IF(iprint.GT.1) print 199, hdr(4),m
2085  IF(hdr(4).LT.xmsg) idata(8) = nint(hdr(4))
2086  irtyp = 3
2087  IF(idata(8).EQ.21) THEN
2088  irtyp = 1
2089  ELSE IF(idata(8).EQ.23) THEN
2090  irtyp = 2
2091  END IF
2092  nnnnn = 8
2093  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
2094 
2095 C PRODUCT QUALITY BIT FLAGS - QUALITY INFO. (STORED AS INTEGER)
2096 
2097  m = 5
2098  IF(iprint.GT.1) print 199, hdr(5),m
2099  IF(hdr(5).LT.xmsg) idata(10) = nint(hdr(5))
2100  nnnnn = 10
2101  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
2102 
2103 C STATION IDENTIFICATION (STORED AS CHARACTER)
2104 C (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER,
2105 C 6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG)
2106 
2107  WRITE(stnid(1:5),'(I5.5)') min(kount,99999)
2108 
2109 C DECODE THE SATELLITE ID
2110 
2111  m = 6
2112  idsat = 2
2113  IF(iprint.GT.1) print 199, hdr(6),m
2114  IF(hdr(6).LT.xmsg) THEN
2115  idsat = mod(nint(hdr(6)),4)
2116  IF(nint(hdr(6)).GT.249.AND.nint(hdr(6)).LT.260) THEN
2117  kntsat(nint(hdr(6))) = kntsat(nint(hdr(6))) + 1
2118  ELSE
2119  kntsat(260) = kntsat(260) + 1
2120  END IF
2121  END IF
2122  IF(iprint.GT.1) print 2197, idsat,irtyp
2123  2197 FORMAT(5x,'IDSAT IS: ',i10,', IRTYP IS: ',i10)
2124  stnid(6:6) = c6tag(irtyp,idsat)
2125  cob(1:4) = stnid(1:4)
2126  idata(11) = iob
2127  nnnnn = 11
2128  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
2129  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
2130  cob(1:4) = stnid(5:6)//' '
2131  idata(12) = iob
2132  nnnnn = 12
2133  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
2134 
2135 cvvvvvdak port
2136 C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
2137 caaaaadak port
2138 
2139  m = 7
2140  IF(iprint.GT.1) print 199, hdr(7),m
2141  iyear = imsg
2142  IF(hdr(7).LT.xmsg) iyear = nint(hdr(7))
2143  m = 8
2144  IF(iprint.GT.1) print 199, hdr(8),m
2145  IF(hdr(8).LT.xmsg.AND.iyear.LT.imsg) THEN
2146 cvvvvvdak port
2147  iyear = mod(iyear,100)
2148 caaaaadak port
2149  iyear = nint(hdr(8)) + (iyear * 100)
2150 cvvvvvdak port
2151 cdak WRITE(COB,'(I6.6,2X)') IYEAR
2152  WRITE(cob,'(I4.4,4X)') iyear
2153 caaaaadak port
2154  idata(5) = iob
2155  nnnnn = 5
2156  IF(iprint.GT.1) print 9196, nnnnn,cob(1:6)
2157  9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
2158  ELSE
2159  GO TO 30
2160  END IF
2161 
2162 C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
2163 C AND THE OBSERVATION TIME (STORED AS REAL)
2164 
2165  m = 9
2166  IF(iprint.GT.1) print 199, hdr(9),m
2167  m = 10
2168  IF(iprint.GT.1) print 199, hdr(10),m
2169  IF(hdr(10).LT.xmsg.AND.hdr(9).LT.imsg) THEN
2170  m = 11
2171  IF(iprint.GT.1) print 199, hdr(11),m
2172  IF(hdr(11).GE.xmsg) GO TO 30
2173  m = 12
2174  IF(iprint.GT.1) print 199, hdr(12),m
2175  IF(hdr(12).GE.xmsg) GO TO 30
2176  rdatx(4) = nint(((hdr(10) + ((hdr(11) * 60.) + hdr(12))/3600.)
2177  $ * 100.) + 0.0000000001)
2178  nnnnn = 4
2179  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
2180  idayhr = nint(hdr(10)) + (nint(hdr(9)) * 100)
2181  WRITE(cob(1:4),'(I4.4)') idayhr
2182  idata(6) = iob
2183  nnnnn = 6
2184  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
2185  ELSE
2186  GO TO 30
2187  END IF
2188  rdata(1:1200) = rdatx(1:1200)
2189  RETURN
2190  30 CONTINUE
2191  iret = 4
2192  RETURN
2193  END
2194 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
2195 C . . . .
2196 C SUBPROGRAM: UNPK7709 FILLS CAT. 12,8 TO O-PUT ARRAY -GOES SNDG
2197 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-05
2198 C
2199 C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
2200 C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
2201 C UPPER-AIR (SOUNDING) AND ADDITIONAL DATA FOR GOES SOUNDING. UPPER-
2202 C AIR DATA ARE THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 12
2203 C (SATELLITE SOUNDING) AND ADDITIONAL DATA ARE FILLED AS CATEGORY 8.
2204 C THE OUPUT ARRAY HOLDS A SINGLE GOES SOUNDING IN THE QUASI-OFFICE
2205 C NOTE 29 UNPACKED FORMAT.
2206 C
2207 C PROGRAM HISTORY LOG:
2208 C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR
2209 C
2210 C USAGE: CALL UNPK7709(LUNIT,RDATA,IRET)
2211 C INPUT ARGUMENT LIST:
2212 C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
2213 C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
2214 C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED
2215 C - IN (CATEGORY 12 AND 8 DATA MISSING)
2216 C
2217 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
2218 C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
2219 C - UNPACKED FORMAT WITH CATEGORY 12 AND 8 INFORMATION
2220 C - FILLED IN (ALL DATA FOR REPORT NOW FILLED)
2221 C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
2222 C
2223 C OUTPUT FILES:
2224 C UNIT 06 - PRINTOUT
2225 C
2226 C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
2227 C
2228 C ATTRIBUTES:
2229 C LANGUAGE: FORTRAN 90
2230 C MACHINE: IBM-SP, CRAY, SGI
2231 C
2232 C$$$
2233  SUBROUTINE unpk7709(LUNIT,RDATA,IRET)
2234  CHARACTER*1 CQMFLG
2235  CHARACTER*8 COB
2236  CHARACTER*37 CAT8A,CAT8B
2237  CHARACTER*48 UAIR1,RAD1
2238  INTEGER IDATA(1200),ICDFG(12)
2239  REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255)
2240  REAL UAIR(4,255),CAT8(12),RDATA(*),RDATX(1200),SC8(12),RAD(2,255)
2241  COMMON /pk77bb/kdate(8),ldate(8),iprint
2242  COMMON /pk77ff/ifov(3),kntsat(250:260)
2243 
2244  SAVE
2245 
2246  equivalence(rdatx,idata),(cob,iob)
2247  DATA xmsg/99999./,ymsg/99999.8/
2248  DATA uair1/'PRLC HGHT TMDB TMDP '/
2249  DATA rad1 /'CHNM TMBR '/
2250  DATA cat8a/'GLFTI PH2O PH2O19 PH2O97 PH2O73 TMSK '/
2251  DATA cat8b/'GCDTT CDTP CLAM SIDU SOEL ELEV '/
2252  DATA icdfg/ 50 , 51 , 52 , 53 , 54 , 55 , 56 ,57 ,58,59, 60 , 61 /
2253  DATA sc8/100.,100.,100.,100.,100.,100.,100.,10.,1.,1.,100.,100./
2254  rdatx(1:1200) = rdata(1:1200)
2255 
2256 C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF-
2257 C VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING
2258 C --> NEUTRAL
2259 
2260  cqmflg = ' '
2261  IF(idata(3).LT.3) THEN
2262  cqmflg = 'F'
2263  ifov(1) = ifov(1) + 1
2264  ELSE IF(idata(3).LT.10.OR.idata(10).EQ.1) THEN
2265  cqmflg = 'Q'
2266  IF(idata(3).LT.10) ifov(2) = ifov(2) + 1
2267  END IF
2268  IF(idata(3).GT.9) ifov(3) = ifov(3) + 1
2269 
2270 C***********************************************************************
2271 C FILL CATEGORY 12 PART OF OUTPUT
2272 C***********************************************************************
2273 
2274  ilvl = 0
2275  ilc = 0
2276  uair_8 = 10.0e10
2277  CALL ufbint(lunit,uair_8,4,255,nlev,uair1);uair=uair_8
2278  IF(nlev.EQ.0) THEN
2279 C.......................................................................
2280 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
2281  print 217
2282  217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
2283  $ 'FOR THIS REPORT -- NLEV = 0'/)
2284  GO TO 98
2285  ELSE IF(nlev.GT.50) THEN
2286 C.......................................................................
2287 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 50 --
2288  print 218
2289  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
2290  $ 'FOR THIS REPORT -- NLEV > 50'/)
2291  GO TO 98
2292 C.......................................................................
2293  END IF
2294  IF(iprint.GT.1) print 1068, nlev
2295  1068 FORMAT(' THIS REPORT CONTAINS',i4,' INPUT LEVELS OF SOUNDING ',
2296  $ 'DATA')
2297  DO i = 1,nlev
2298  IF(iprint.GT.1) print 1079, i,ilc,ilvl
2299  1079 FORMAT(' ATTEMPTING NEW CAT. 12 INPUT LEVEL NUMBER',i4,' WITH ',
2300  $ 'ILC =',i5,'; NO. LEVELS PROCESSED TO NOW =',i5)
2301 
2302 C LEVEL PRESSURE (STORED AS REAL)
2303 
2304  m = 1
2305  IF(iprint.GT.1) print 199, uair(1,i),m
2306  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
2307  IF(i.EQ.1) THEN
2308  psfc = uair(1,i) * 0.1
2309  ELSE IF(uair(1,i)*0.1.GE.ymsg) THEN
2310 C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE
2311 C -- GO ON TO NEXT INPUT LEVEL (IF SFC LEVEL MSG, CONTINUE PROCESSING)
2312  IF(iprint.GT.1) print *, 'PRESSURE MISSING ON INPUT',
2313  $ ' LEVEL ',i,', SKIP THE PROCESSING OF THIS LEVEL'
2314  GO TO 10
2315  ELSE IF(uair(1,i)*0.1.GE.psfc) THEN
2316 C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE
2317 C IS BELOW THE SURFACE PRESSURE -- GO ON TO THE NEXT INPUT LEVEL
2318  IF(iprint.GT.1) print *,'PRESSURE ON INPUT LEVEL ',i,
2319  $ ' IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL'
2320  GO TO 10
2321  END IF
2322 
2323 C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE
2324 
2325  IF(uair(1,i)*0.1.LT.xmsg) rdatx(43+ilc) = nint(uair(1,i)*0.1)
2326  ilvl = ilvl + 1
2327  IF(iprint.GT.1) print 198, 43+ilc,rdatx(43+ilc)
2328  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
2329 
2330 C GEOPOTENTIAL HEIGHT (STORED AS REAL)
2331 
2332  m = 2
2333  IF(iprint.GT.1) print 199, uair(2,i),m
2334  IF(uair(2,i).LT.xmsg) rdatx(43+ilc+1) = nint(uair(2,i))
2335  IF(iprint.GT.1) print 198, 43+ilc+1,rdatx(43+ilc+1)
2336  IF(i.EQ.1) THEN
2337  IF(iprint.GT.1) print *, 'THIS IS SURFACE LEVEL, SO ',
2338  $ 'STORE HEIGHT ALSO AS ELEVATION IN HEADER'
2339  IF(uair(2,1).LT.xmsg) rdatx(7) = nint(uair(2,1))
2340  nnnnn = 7
2341  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
2342  END IF
2343 
2344 C TEMPERATURE (STORED AS REAL)
2345 
2346  m = 3
2347  IF(iprint.GT.1) print 199, uair(3,i),m
2348  itmp = nint(uair(3,i)*100.)
2349  IF(uair(3,i).LT.xmsg)
2350  $ rdatx(43+ilc+2) = nint((itmp - 27315) * 0.1)
2351  IF(iprint.GT.1) print 198, 43+ilc+2,rdatx(43+ilc+2)
2352 
2353 C DEWPOINT TEMPERATURE (STORED AS REAL)
2354 
2355  m = 4
2356  IF(iprint.GT.1) print 199, uair(4,i),m
2357  itmp = nint(uair(4,i)*100.)
2358  IF(uair(4,i).LT.xmsg)
2359  $ rdatx(43+ilc+3) = nint((itmp - 27315) * 0.1)
2360  IF(iprint.GT.1) print 198, 43+ilc+3,rdatx(43+ilc+3)
2361 
2362 C QUALITY MARKERS (STORED AS CHARACTER)
2363 
2364  cob = cqmflg//cqmflg//cqmflg//' '
2365  idata(43+ilc+6) = iob
2366  IF(iprint.GT.1) print 196, 43+ilc+6,cob(1:4)
2367  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
2368 C.......................................................................
2369  ilc = ilc + 7
2370  IF(i+1.LE.nlev.AND.iprint.GT.1) print *,'HAVE COMPLETED ',
2371  $ 'LEVEL ',ilvl,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
2372 
2373  10 CONTINUE
2374  ENDDO
2375 
2376 C SET CATEGORY COUNTERS FOR CATEGORY 12 (SOUNDING) DATA
2377 
2378  idata(39) = ilvl
2379  98 CONTINUE
2380  IF(iprint.GT.1) print *, idata(39),' CAT. 12 LEVELS PROCESSED'
2381  IF(idata(39).GT.0) idata(40) = 43
2382 
2383 C***********************************************************************
2384 C FILL CATEGORY 8 PART OF OUTPUT
2385 C WILL ATTEMPT TO FILL 12 "LEVELS"
2386 C LVL 1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250.
2387 C LVL 2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251.
2388 C LVL 3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252.
2389 C LVL 4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253.
2390 C LVL 5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254.
2391 C LVL 6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255.
2392 C LVL 7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256.
2393 C LVL 8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257.
2394 C LVL 9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258.
2395 C LVL 10- INSTR. DATA USED IN PROC.
2396 C (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259.
2397 C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260.
2398 C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100) --- CODE FIG. 261.
2399 C
2400 C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED
2401 C***********************************************************************
2402 
2403  ilvl = 0
2404  ilc = 0
2405  cat8_8 = 10.0e10
2406  CALL ufbint(lunit,cat8_8,12,1,nlev8,cat8a//cat8b);cat8=cat8_8
2407  IF(nlev8.NE.1) THEN
2408  IF(nlev8.EQ.0) THEN
2409 C.......................................................................
2410 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
2411  print 318
2412  318 FORMAT(/' ##W3UNPK77: NO ADDITIONAL (CAT. 8) DATA PROCESSED FOR ',
2413  $ 'THIS REPORT -- NLEV8 = 0'/)
2414  GO TO 99
2415 C.......................................................................
2416  ELSE
2417 C.......................................................................
2418 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
2419 C SET IRET = 7 AND RETURN
2420  print 219, nlev8
2421  219 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
2422  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/)
2423  iret = 7
2424  RETURN
2425 C.......................................................................
2426  END IF
2427  END IF
2428 
2429 C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO
2430 C DETERMINE Q. MARK FOR SKIN TEMPERATURE (IF 0 - OK, OTHERWISE - BAD)
2431 
2432  rtcsf_8 = 10.0e10
2433  CALL ufbint(lunit,rtcsf_8,1,1,nlev0,'TCSF');rtcsf=rtcsf_8
2434  itcsf = 1
2435  m = 1
2436  IF(iprint.GT.1) print 299, rtcsf,m
2437  299 FORMAT(5x,'RTCSF HERE IS: ',f17.4,'; INDEX IS: ',i3)
2438  IF(rtcsf.LT.xmsg) itcsf = nint(rtcsf)
2439  IF(iprint.GT.1) print 1798, itcsf
2440  1798 FORMAT(5x,'ITCSF IS: ',i10)
2441 
2442 C LOOP THROUGH THE 12 POSSIBLE ADDITIONAL DATA
2443 
2444  DO m = 1,12
2445  IF(iprint.GT.1) print 6079, m,ilc,ilvl
2446  6079 FORMAT(' ATTEMPTING MISCEL. INPUT',i5,' WITH ILC =',i5,'; NO. ',
2447  $ 'OUTPUT CAT. 8 LVLS PROCESSED TO NOW =',i5)
2448  IF(iprint.GT.1) print 399, cat8(m),m
2449  399 FORMAT(5x,'CAT8 HERE IS: ',f17.4,'; INDEX IS: ',i3)
2450  IF(cat8(m).LT.xmsg) THEN
2451 
2452 C WE HAVE A VALID CATEGORY 8 "LEVEL"
2453 
2454  ilvl = ilvl + 1
2455 
2456 C STORE THE DATUM IN WORD 1 OF THE CAT. 8 LEVEL
2457 
2458  rdatx(393+ilc) = nint(cat8(m) * sc8(m))
2459  IF(iprint.GT.1) print 198, 393+ilc,rdatx(393+ilc)
2460 
2461 C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 LEVEL
2462 
2463  rdatx(393+ilc+1) = real(200+icdfg(m))
2464  IF(iprint.GT.1) print 198, 393+ilc+1,rdatx(393+ilc+1)
2465 
2466 C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL
2467 
2468  cob = cqmflg//' '
2469 
2470 C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL
2471 C SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO "F"
2472 
2473  IF(m.EQ.6.AND.itcsf.NE.0) cob(1:1) = 'F'
2474  idata(393+ilc+2) = iob
2475  IF(iprint.GT.1) print 196, 393+ilc+2,cob(1:4)
2476  ilc = ilc + 3
2477  IF(m.LT.12.AND.iprint.GT.1) print *,'HAVE COMPLETED OUTPUT',
2478  $ ' LVL',ilvl,'; GOING INTO NEXT INPUT DATUM WITH ILC=',ilc
2479  ELSE
2480  IF(iprint.GT.1) print *, 'DATUM MISSING ON INPUT ',m,
2481  $ ', GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO ',
2482  $ 'FAR=',ilvl,'; ILC=',ilc,')'
2483  END IF
2484  ENDDO
2485 
2486 C SET CATEGORY COUNTERS FOR CATEGORY 8 (ADDITIONAL) DATA
2487 
2488  idata(27) = ilvl
2489  99 CONTINUE
2490  IF(iprint.GT.1) print *, idata(27),' CAT. 08 LEVELS PROCESSED'
2491  IF(idata(27).GT.0) idata(28) = 393
2492 
2493 C***********************************************************************
2494 C FILL CATEGORY 13 PART OF OUTPUT (RADIANCES)
2495 C***********************************************************************
2496 
2497  ilvl = 0
2498  ilc = 0
2499  rad_8 = 10.0e10
2500  CALL ufbint(lunit,rad_8,2,255,nlev13,rad1);rad=rad_8
2501  IF(nlev13.EQ.0) THEN
2502 C.......................................................................
2503 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
2504  print 417
2505  417 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
2506  $ 'REPORT -- NLEV13 = 0'/)
2507  GO TO 100
2508  ELSE IF(nlev13.GT.60) THEN
2509 C.......................................................................
2510 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 60 --
2511  print 418
2512  418 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
2513  $ 'REPORT -- NLEV13 > 60'/)
2514  GO TO 100
2515 C.......................................................................
2516  END IF
2517  IF(iprint.GT.1) print 2068, nlev13
2518  2068 FORMAT(' THIS REPORT CONTAINS',i4,' INPUT LEVELS (CHANNELS) OF ',
2519  $ 'RADIANCE DATA')
2520  DO i = 1,nlev13
2521  IF(iprint.GT.1) print 2079, i,ilc,ilvl
2522  2079 FORMAT(' ATTEMPTING NEW CAT. 13 INPUT "LEVEL" NUMBER',i4,' WITH ',
2523  $ 'ILC =',i5,'; NO. LEVELS (CHANNELS) PROCESSED TO NOW =',i5)
2524 
2525 C CHANNEL NUMBER (STORED AS INTEGER)
2526 
2527  m = 1
2528  IF(iprint.GT.1) print 499, rad(1,i),m
2529  499 FORMAT(5x,'RAD HERE IS: ',f17.4,'; INDEX IS: ',i3)
2530  IF(rad(1,i).GE.ymsg) THEN
2531 C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL
2532 C NUMBER -- GO ON TO NEXT INPUT LEVEL
2533  IF(iprint.GT.1) print *, 'CHANNEL NUMBER MISSING ON INPUT',
2534  $ ' LEVEL ',i,', SKIP THE PROCESSING OF THIS LEVEL'
2535  GO TO 210
2536  END IF
2537 
2538 C WE HAVE A VALID CATEGORY 13 LEVEL -- THERE IS A VALID CHANNEL NUMBER
2539 
2540  idata(429+ilc) = nint(rad(1,i))
2541  ilvl = ilvl + 1
2542  IF(iprint.GT.1) print 197, 429+ilc,idata(429+ilc)
2543  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
2544 
2545 C BRIGHTNESS TEMPERATURE (STORED AS REAL)
2546 
2547  m = 2
2548  IF(iprint.GT.1) print 499, rad(2,i),m
2549  IF(rad(2,i).LT.xmsg) rdatx(429+ilc+1) = nint(rad(2,i) * 100.)
2550  IF(iprint.GT.1) print 198, 429+ilc+1,rdatx(429+ilc+1)
2551 
2552 C QUALITY MARKERS (STORED AS CHARACTER)
2553 
2554  cob = ' '
2555  idata(429+ilc+2) = iob
2556  IF(iprint.GT.1) print 196, 429+ilc+2,cob(1:4)
2557 C.......................................................................
2558  ilc = ilc + 3
2559  IF(i+1.LE.nlev13.AND.iprint.GT.1) print *,'HAVE COMPLETED ',
2560  $ 'LEVEL ',ilvl,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
2561 
2562  210 CONTINUE
2563  ENDDO
2564 
2565 C SET CATEGORY COUNTERS FOR CATEGORY 13 (RADIANCE) DATA
2566 
2567  idata(41) = ilvl
2568  100 CONTINUE
2569  IF(iprint.GT.1) print *, idata(41),' CAT. 13 LEVELS PROCESSED'
2570  IF(idata(41).GT.0) idata(42) = 429
2571 
2572  IF(idata(27)+idata(39)+idata(41).EQ.0) iret = 5
2573 
2574  IF(iprint.GT.1) print *,'IDATA(39)=',idata(39),'; IDATA(40)=',
2575  $ idata(40),'; IDATA(27)=',idata(27),'; IDATA(28)=',idata(28),
2576  $ '; IDATA(41)=',idata(41),'; IDATA(42)=',idata(42)
2577 
2578  rdata(1:1200) = rdatx(1:1200)
2579  RETURN
2580  END
errexit
subroutine errexit(IRET)
Exit with a return code.
Definition: errexit.f:20
w3difdat
subroutine w3difdat(jdat, idat, it, rinc)
Returns the elapsed time interval from an NCEP absolute date and time given in the second argument un...
Definition: w3difdat.f:29
w3fi04
subroutine w3fi04(IENDN, ITYPEC, LW)
Subroutine computes word size, the type of character set, ASCII or EBCDIC, and if the computer is big...
Definition: w3fi04.f:30