NCEPLIBS-w3emc  2.9.2
w3miscan.f
1 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
2 C
3 C SUBPROGRAM: W3MISCAN READS 1 SSM/I SCAN LINE FROM BUFR D-SET
4 C PRGMMR: KEYSER ORG: NP22 DATE: 2011-08-04
5 C
6 C ABSTRACT: READS ONE SSM/I SCAN LINE (64 RETRIEVALS) FROM THE NCEP
7 C BUFR SSM/I DUMP FILE. EACH SCAN IS TIME CHECKED AGAINST THE
8 C USER-REQUESTED TIME WINDOW AND SATELLITE ID COMBINATIONS. WHEN A
9 C VALID SCAN IS READ THE PROGRAM RETURNS TO THE CALLING PROGRAM.
10 C THE USER MUST PASS IN THE TYPE OF THE INPUT SSM/I DUMP FILE,
11 C EITHER DERIVED PRODUCTS (REGARDLESS OF SOURCE) OR BRIGHTNESS
12 C TEMPERATURES (7-CHANNELS). IF THE LATTER IS CHOSEN, THE USER
13 C HAS THE FURTHER OPTION OF PROCESSING, IN ADDITION TO THE
14 C BRIGHTNESS TEMPERATURES, IN-LINE CALCULATION OF WIND SPEED
15 C PRODUCT VIA THE GOODBERLET ALGORITHM, AND/OR IN-LINE CALCULATION
16 C OF BOTH WIND SPEED AND TOTAL COLUMN PRECIPITABLE WATER (TPW)
17 C PRODUCTS USING THE NEURAL NET 3 ALGORITHM. IF THE WIND SPEED
18 C OR TPW IS CALCULATED HERE (EITHER ALGORITHM), THIS SUBROUTINE
19 C WILL CHECK FOR BRIGHTNESS TEMPERATURES OUTSIDE OF A PRESET RANGE
20 C AND WILL RETURN A MISSING WIND SPEED/TPW IF ANY B. TEMP IS
21 C UNREASONABLE. ALSO, FOR CALCULATED WIND SPEEDS AND TPW, THIS
22 C PROGRAM WILL CHECK TO SEE IF THE B. TEMPS ARE OVER LAND OR ICE,
23 C AND IF THEY ARE IT WILL ALSO RETURN MISSING VALUES SINCE THESE
24 C DATA ARE VALID ONLY OVER OCEAN.
25 C
26 C PROGRAM HISTORY LOG:
27 C 1996-07-30 D. A. KEYSER -- ORIGINAL AUTHOR - SUBROUTINE IS A
28 C MODIFIED VERSION OF W3LIB W3FI86 WHICH READ ONE SCAN
29 C LINE FROM THE 30-ORBIT SHARED PROCESSING DATA SETS
30 C 1997-05-22 D. A. KEYSER -- CRISIS FIX TO ACCOUNT FOR CLON NOW
31 C RETURNED FROM BUFR AS -180 TO 0 (WEST) OR 0 TO 180
32 C (EAST), USED TO RETURN AS 0 TO 360 EAST WHICH WAS NOT
33 C THE BUFR STANDARD
34 C 1998-01-28 D. A. KEYSER -- REPLACED NEURAL NET 2 ALGORITHM WHICH
35 C CALCULATED ONLY WIND SPEED PRODUCT WITH NEURAL NET 3
36 C ALGORITHM WHICH CALCULATES BOTH WIND SPEED AND TOTAL
37 C PRECIPITABLE WATER PRODUCTS (AMONG OTHERS) BUT, UNLIKE
38 C NN2, DOES NOT RETURN A RAIN FLAG VALUE (IT DOES SET
39 C ALL RETRIEVALS TO MISSING THAT FAIL RAIN FLAG AND ICE
40 C CONTAMINATION TESTS)
41 C 1998-03-30 D. A. KEYSER -- MODIFIED TO HANDLE NEURAL NET 3 SSM/I
42 C PRODUCTS INPUT IN A PRODUCTS BUFR DATA DUMP FILE; NOW
43 C PRINTS OUT NUMBER OF SCANS PROCESSED BY SATELLITE
44 C NUMBER IN FINAL SUMMARY
45 C 1998-10-23 D. A. KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90
46 C COMPLIANT
47 C 1999-02-18 D. A. KEYSER -- MODIFIED TO COMPILE AND RUN PROPERLY
48 C ON IBM-SP
49 C 2000-06-08 D. A. KEYSER -- CORRECTED MNEMONIC FOR RAIN RATE TO
50 C "REQV" (WAS "PRER" FOR SOME UNKNOWN REASON)
51 C 2001-01-03 D. A. KEYSER -- CHANGED UNITS OF RETURNED RAIN RATE
52 C FROM WHOLE MM/HR TO 10**6 MM/SEC, CHANGED UNITS OF
53 C RETURNED SURFACE TEMP FROM WHOLE KELVIN TO 10**2
54 C KELVIN (TO INCR. PRECISION TO THAT ORIG. IN INPUT BUFR
55 C FILE)
56 C 2004-09-12 D. A. KEYSER -- NOW DECODES SEA-SURFACE TEMPERATURE IF
57 C VALID INTO SAME LOCATION AS SURFACE TEMPERATURE, QUANTITY
58 C IS SURFACE TEMPERATURE IF SURFACE TAG IS NOT 5, OTHERWISE
59 C QUANTITY IS SEA-SURFACE TEMPERATURE (NCEP PRODUCTS DATA
60 C DUMP FILE NOW CONTAINS SST); CHECKS TO SEE IF OLD OR NEW
61 C VERSION OF MNEMONIC TABLE bufrtab.012 IS BEING USED HERE
62 C (OLD VERSION HAD "PH2O" INSTEAD OF "TPWT", "SNDP" INSTEAD
63 C OF "TOSD", "WSOS" INSTEAD OF "WSPD" AND "CH2O" INSTEAD OF
64 C THE SEQUENCE "METFET VILWC METFET"), AND DECODES USING
65 C WHICHEVER MNEMONICS ARE FOUND {NOTE: A FURTHER
66 C REQUIREMENT FOR "VILWC" IS THAT THE FIRST "METFET"
67 C (METEOROLOGICAL FEATURE) IN THE SEQUENCE MUST BE 12
68 C (=CLOUD), ELSE CLOUD WATER SET TO MISSING, REGARDLESS OF
69 C "VILWC" VALUE}
70 C 2011-08-04 D. A. KEYSER -- ADD IBDATE (INPUT BUFR MESSAGE DATE) TO
71 C OUTPUT ARGUMENT LIST (NOW USED BY CALLING PROGRAM
72 C PREPOBS_PREPSSMI)
73 C
74 C USAGE: CALL W3MISCAN(INDTA,INLSF,INGBI,INGBD,LSAT,LPROD,LBRIT,
75 C $ NNALG,GBALG,KDATE,LDATE,IGNRTM,IBUFTN,IBDATE,IER)
76 C INPUT ARGUMENT LIST:
77 C INDTA - UNIT NUMBER OF NCEP BUFR SSM/I DUMP DATA SET
78 C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE
79 C - (VALID ONLY IF LBRIT AND EITHER NNALG OR GBALG TRUE)
80 C INGBI - UNIT NUMBER OF GRIB INDEX FILE FOR GRIB FILE
81 C - CONTAINING GLOBAL 1-DEGREE SEA-SURFACE TEMP FIELD
82 C - (VALID ONLY IF LBRIT AND EITHER NNALG OR GBALG TRUE)
83 C INGBD - UNIT NUMBER OF GRIB FILE CONTAINING GLOBAL 1-DEGREE
84 C - SEA-SURFACE TEMP FIELD (VALID ONLY IF LBRIT AND EITHER
85 C - NNALG OR GBALG TRUE)
86 C LSAT - 10-WORD LOGICAL ARRAY (240:249) INDICATING WHICH
87 C SATELLITE IDS SHOULD BE PROCESSED (SEE REMARKS)
88 C LPROD - LOGICAL INDICATING IF THE INPUT BUFR FILE CONTAINS
89 C - PRODUCTS (REGARDLESS OF SOURCE) - IN THIS CASE ONE OR
90 C - MORE AVAILABLE PRODUCTS CAN BE PROCESSED AND RETURNED
91 C LBRIT - LOGICAL INDICATING IF THE INPUT BUFR FILE CONTAINS
92 C - BRIGHTNESS TEMPERATURES - IN THIS CASE B. TEMPS ARE
93 C - PROCESSED AND RETURNED ALONG WITH, IF REQUESTED, IN-
94 C - LINE GENERATED PRODUCTS FROM ONE OR BOTH ALGORITHMS
95 C - (SEE NEXT TWO SWITCHES)
96 C THE FOLLOWING TWO SWITCHES APPLY ONLY IF LBRIT IS TRUE -----
97 C NNALG - LOGICAL INDICATING IF THE SUBROUTINE SHOULD
98 C - CALCULATE AND RETURN SSM/I WIND SPEED AND TPW
99 C - VIA THE NEURAL NET 3 ALGORITHM (NOTE: B O T H
100 C - WIND SPEED AND TPW ARE RETURNED HERE)
101 C GBALG - LOGICAL INDICATING IF THE SUBROUTINE SHOULD
102 C - CALCULATE AND RETURN SSM/I WIND SPEED VIA THE
103 C - GOODBERLET ALGORITHM
104 C
105 C KDATE - REQUESTED EARLIEST YEAR(YYYY), MONTH, DAY, HOUR,
106 C - MIN FOR ACCEPTING SCANS
107 C LDATE - REQUESTED LATEST YEAR(YYYY), MONTH, DAY, HOUR,
108 C - MIN FOR ACCEPTING SCANS
109 C IGNRTM - SWITCH TO INDICATE WHETHER SCANS SHOULD BE TIME-
110 C - CHECKED (= 0) OR NOT TIME CHECKED (=1) {IF =1, ALL
111 C - SCANS READ IN ARE PROCESSED REGARDLESS OF THEIR TIME.
112 C - THE INPUT ARGUMENTS "KDATE" AND "LDATE" (EARLIEST AND
113 C - LATEST DATE FOR PROCESSING DATA) ARE IGNORED IN THE
114 C - TIME CHECKING FOR SCANS. (NOTE: THE EARLIEST AND
115 C - LATEST DATES SHOULD STILL BE SPECIFIED TO THE
116 C - "EXPECTED" TIME RANGE, BUT THEY WILL NOT BE USED FOR
117 C - TIME CHECKING IN THIS CASE)}
118 C
119 C OUTPUT ARGUMENT LIST:
120 C IBUFTN - OUTPUT BUFFER HOLDING DATA FOR A SCAN (1737 WORDS -
121 C - SEE REMARKS FOR FORMAT. SOME WORDS MAY BE MISSING
122 C - DEPENDING UPON LPROD, LBRIT, NNALG AND GBALG
123 C IBDATE - INPUT BUFR MESSAGE SECTION 1 DATE (YYYYMMDDHH)
124 C IER - ERROR RETURN CODE (SEE REMARKS)
125 C
126 C INPUT FILES:
127 C UNIT AA - (WHERE AA IS EQUAL TO INPUT ARGUMENT 'INDTA') NCEP
128 C - BUFR SSM/I DUMP DATA SET HOLDING SCANS (SEE REMARKS
129 C - REGARDING ASSIGN)
130 C UNIT BB - (WHERE BB IS EQUAL TO INPUT ARGUMENT 'INLSF')
131 C - DIRECT ACCESS NESDIS LAND/SEA FILE (SEE REMARKS
132 C - REGARDING ASSIGN) (VALID ONLY IF LBRIT AND EITHER
133 C - NNALG OR GBALG TRUE)
134 C UNIT CC - (WHERE CC IS EQUAL TO INPUT ARGUMENT 'INGBI') GRIB
135 C - INDEX FILE FOR GRIB FILE CONTAINING GLOBAL 1-DEGREE
136 C - SEA-SURFACE TEMPERATURE FIELD (SEE REMARKS
137 C - REGARDING CREATION AND ASSIGN) (VALID ONLY IF LBRIT
138 C - AND EITHER NNALG OR GBALG TRUE)
139 C UNIT DD - (WHERE DD IS EQUAL TO INPUT ARGUMENT 'INGBD')
140 C - UNBLOCKED GRIB FILE CONTAINING GLOBAL 1-DEGREE SEA-
141 C - SURFACE TEMPERATURE FIELD (SEE REMARKS REGARDING
142 C - ASSIGN) (VALID ONLY IF LBRIT AND EITHER NNALG OR
143 C - GBALG TRUE)
144 C
145 C OUTPUT FILES:
146 C UNIT 06 - PRINTOUT
147 C
148 C SUBPROGRAMS CALLED:
149 C UNIQUE: - MISC01 RISC02 RISC03 MISC04 MISC05
150 C - MISC06 MISC10
151 C LIBRARY:
152 C IBM - GETENV
153 C BALIB: - BAOPER BACLOSE
154 C W3LIB: - W3FI04 W3MOVDAT W3DIFDAT GBYTE GETGB
155 C BUFRLIB: - DATELEN DUMPBF OPENBF READMG READSB
156 C - UFBINT UFBREP
157 C
158 C REMARKS: RETURN CODE IER CAN HAVE THE FOLLOWING VALUES:
159 C IER = 0 SUCCESSFUL RETURN OF SCAN
160 C IER = 1 ALL SCANS HAVE BEEN READ, ALL DONE
161 C IER = 2 ABNORMAL RETURN - INPUT BUFR FILE IN UNIT
162 C 'INDTA' IS EITHER EMPTY (NULL) OR IS NOT BUFR
163 C IER = 3 ABNORMAL RETURN - REQUESTED EARLIEST AND
164 C LATEST DATES ARE BACKWARDS
165 C IER = 4 ABNORMAL RETURN - ERROR OPENING RANDOM
166 C ACCESS FILE HOLDING LAND/SEA TAGS
167 C IER = 5 ABNORMAL RETURN - THE NUMBER OF DECODED
168 C "LEVELS" IS NOT WHAT IS EXPECTED
169 C IER = 6 ABNORMAL RETURN - SEA-SURFACE TEMPERATURE
170 C NOT FOUND IN GRIB INDEX FILE - ERROR RETURNED
171 C FROM GRIB DECODER GETGB IS 96
172 C IER = 7 ABNORMAL RETURN - SEA-SURFACE TEMPERATURE
173 C GRIB MESSAGE HAS A DATE THAT IS EITHER:
174 C 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST
175 C REQUESTED DATE OR 2) MORE THAN 7-DAYS AFTER
176 C THE LATEST REQUESTED DATE
177 C IER = 8 ABNORMAL RETURN - BYTE-ADDRESSABLE READ ERROR
178 C FOR GRIB FILE CONTAINING SEA-SURFACE
179 C TEMPERATURE FIELD - ERROR RETURNED FROM GRIB
180 C DECODER GETGB IS 97-99
181 C IER = 9 ABNORMAL RETURN - ERROR RETURNED FROM GRIB
182 C DECODER - GETGB - FOR SEA-SURFACE
183 C TEMPERATURE FIELD - > 0 BUT NOT 96-99
184 CC
185 C INPUT ARGUMENT LSAT IS SET-UP AS FOLLOWS:
186 C
187 C LSAT(X) = TRUE -- PROCESS SCANS FROM SATELLITE ID X (WHERE X
188 C IS CODE FIGURE FROM BUFR CODE TABLE 0-01-007)
189 C LSAT(X) = FALSE - DO NOT PROCESS SCANS FROM SATELLITE ID X
190 C
191 C X = 240 IS F-7 DMSP SATELLITE (THIS SATELLITE IS
192 C NO LONGER AVAILABLE)
193 C X = 241 IS F-8 DMSP SATELLITE (THIS SATELLITE IS
194 C NO LONGER AVAILABLE)
195 C X = 242 IS F-9 DMSP SATELLITE (THIS SATELLITE IS
196 C NO LONGER AVAILABLE)
197 C X = 243 IS F-10 DMSP SATELLITE (THIS SATELLITE IS
198 C NO LONGER AVAILABLE)
199 C X = 244 IS F-11 DMSP SATELLITE (THIS IS AVAILABLE
200 C AS OF 8/96 BUT IS NOT CONSIDERED TO BE AN
201 C OPERATIONAL DMSP SSM/I SATELLITE)
202 C X = 245 IS F-12 DMSP SATELLITE (THIS SATELLITE IS
203 C NO LONGER AVAILABLE)
204 C X = 246 IS F-13 DMSP SATELLITE (THIS IS AVAILABLE
205 C AND IS CONSIDERED TO BE AN OPERATIONAL
206 C ODD DMSP SSM/I SATELLITE AS OF 8/1996)
207 C X = 247 IS F-14 DMSP SATELLITE (THIS IS AVAILABLE
208 C AS OF 5/97 BUT IS NOT CONSIDERED TO BE AN
209 C OPERATIONAL DMSP SSM/I SATELLITE)
210 C X = 248 IS F-15 DMSP SATELLITE (THIS IS AVAILABLE
211 C AS OF 2/2000 AND IS CONSIDERED TO BE AN
212 C OPERATIONAL ODD DMSP SSM/I SATELLITE AS OF
213 C 2/2000)
214 C X = 249 IS RESERVED FOR A FUTURE DMSP SATELLITE
215 C
216 C NOTE: HERE "EVEN" MEANS VALUE IN IBUFTN(1) IS AN ODD NUMBER
217 C WHILE "ODD" MEANS VALUE IN IBUFTN(1) IS AN EVEN NUMBER
218 CC
219 C
220 C CONTENTS OF ARRAY 'IBUFTN' HOLDING ONE COMPLETE SCAN (64 INDIVIDUAL
221 C RETRIEVLAS (1737 WORDS)
222 C
223 C =====> ALWAYS RETURNED:
224 C
225 C WORD CONTENTS
226 C ---- --------
227 C 1 SATELLITE ID (244 IS F-11; 246 IS F-13; 247 IS F-14;
228 C 248 IS F-15)
229 C 2 4-DIGIT YEAR FOR SCAN
230 C 3 2-DIGIT MONTH OF YEAR FOR SCAN
231 C 4 2-DIGIT DAY OF MONTH FOR SCAN
232 C 5 2-DIGIT HOUR OF DAY FOR SCAN
233 C 6 2-DIGIT MINUTE OF HOUR FOR SCAN
234 C 7 2-DIGIT SECOND OF MINUTE FOR SCAN
235 C 8 SCAN NUMBER IN ORBIT
236 C 9 ORBIT NUMBER FOR SCAN
237 C
238 C 10 RETRIEVAL #1 LATITUDE (*100 DEGREES: + N, - S)
239 C 11 RETRIEVAL #1 LONGITUDE (*100 DEGREES EAST)
240 C 12 RETRIEVAL #1 POSITION NUMBER
241 C 13 RETRIEVAL #1 SURFACE TAG (CODE FIGURE)
242 C
243 C =====> FOR LPROD = TRUE {INPUT PRODUCTS FILE: NOTE ALL PRODUCTS
244 C BELOW EXCEPT SEA-SURFACE TEMPERATURE ARE AVAILABLE IN THE
245 C FNOC "OPERATIONAL" PRODUCTS DATA DUMP; MOST NCEP PRODUCTS
246 C DATA DUMPS CONTAIN ONLY WIND SPEED, TOTAL PRECIPITABLE
247 C WATER, CLOUD WATER AND SEA-SURFACE TEMPERATURE (ALL OVER
248 C OCEAN ONLY)}:
249 C
250 C 14 RETRIEVAL #1 CLOUD WATER (*100 KILOGRAM/METER**2)
251 C 15 RETRIEVAL #1 RAIN RATE (*1000000 MILLIMETERS/SECOND)
252 C 16 RETRIEVAL #1 WIND SPEED (*10 METERS/SECOND)
253 C 17 RETRIEVAL #1 SOIL MOISTURE (MILLIMETERS)
254 C 18 RETRIEVAL #1 SEA-ICE CONCENTRATION (PER CENT)
255 C 19 RETRIEVAL #1 SEA-ICE AGE (CODE FIGURE)
256 C 20 RETRIEVAL #1 ICE EDGE (CODE FIGURE)
257 C 21 RETRIEVAL #1 TOTAL PRECIP. WATER (*10 MILLIMETERS)
258 C 22 RETRIEVAL #1 SURFACE TEMP (*100 K) IF NOT OVER OCEAN
259 C -- OR --
260 C 22 RETRIEVAL #1 SEA-SURFACE TEMP (*100 K) IF OVER OCEAN
261 C 23 RETRIEVAL #1 SNOW DEPTH (MILLIMETERS)
262 C 24 RETRIEVAL #1 RAIN FLAG (CODE FIGURE)
263 C 25 RETRIEVAL #1 CALCULATED SURFACE TYPE (CODE FIGURE)
264 C
265 C =====> FOR LBRIT = TRUE (INPUT BRIGHTNESS TEMPERATURE FILE):
266 C
267 C 26 RETRIEVAL #1 19 GHZ V BRIGHTNESS TEMP (*100 DEG. K)
268 C 27 RETRIEVAL #1 19 GHZ H BRIGHTNESS TEMP (*100 DEG. K)
269 C 28 RETRIEVAL #1 22 GHZ V BRIGHTNESS TEMP (*100 DEG. K)
270 C 29 RETRIEVAL #1 37 GHZ V BRIGHTNESS TEMP (*100 DEG. K)
271 C 30 RETRIEVAL #1 37 GHZ H BRIGHTNESS TEMP (*100 DEG. K)
272 C 31 RETRIEVAL #1 85 GHZ V BRIGHTNESS TEMP (*100 DEG. K)
273 C 32 RETRIEVAL #1 85 GHZ H BRIGHTNESS TEMP (*100 DEG. K)
274 C
275 C =====> FOR LBRIT = TRUE AND NNALG = TRUE (INPUT BRIGHTNESS
276 C TEMPERATURE FILE):
277 C
278 C 33 RETRIEVAL #1 NEURAL NET 3 ALGORITHM WIND SPEED
279 C (GENERATED IN-LINE) (*10 METERS/SECOND)
280 C 34 RETRIEVAL #1 NEURAL NET 3 ALGORITHM TOTAL PRECIP.
281 C WATER (GENERATED IN-LINE) (*10 MILLIMETERS)
282 C
283 C =====> FOR LBRIT = TRUE AND GBALG = TRUE (INPUT BRIGHTNESS
284 C TEMPERATURE FILE):
285 C
286 C 35 RETRIEVAL #1 GOODBERLET ALGORITHM WIND SPEED
287 C (GENERATED IN-LINE) (*10 METERS/SECOND)
288 C 36 RETRIEVAL #1 GOODBERLET ALGORITHM RAIN FLAG
289 C (CODE FIGURE)
290 C
291 C 37-1737 REPEAT 10-36 FOR 63 MORE RETRIEVALS
292 C
293 C (NOTE: ALL MISSING DATA OR DATA NOT SELECTED BY
294 C CALLING PROGRAM ARE SET TO 99999)
295 C
296 C
297 C ATTRIBUTES:
298 C LANGUAGE: FORTRAN 90
299 C MACHINE: IBM-SP
300 C
301 C$$$
302 
303  SUBROUTINE w3miscan(INDTA,INLSF,INGBI,INGBD,LSAT,LPROD,LBRIT,
304  $ NNALG,GBALG,KDATE,LDATE,IGNRTM,IBUFTN,IBDATE,IER)
305 
306  LOGICAL LPROD,LBRIT,NNALG,GBALG,LSAT(240:249)
307 
308  CHARACTER*1 CDUMMY
309  CHARACTER*2 ATXT(2)
310  CHARACTER*8 SUBSET
311  CHARACTER*20 RHDER,PROD2,BRITE
312  CHARACTER*46 SHDER,PROD1
313 
314  REAL SHDR(9),RHDR(4,64),PROD(13,64),BRIT(2,448),RINC(5),
315  $ metfet(64)
316 
317  REAL(8) SHDR_8(9),RHDR_8(4,64),PROD_8(13,64),BRIT_8(2,448),
318  $ ufbint_8(64)
319 
320  INTEGER IBUFTN(1737),KDATA(7),KDATE(5),LDATE(5),LBTER(7),
321  $ kspsat(239:249),kntsat(239:249),iflag(64),kdat(8),ldat(8),
322  $ mdat(8),icdate(5),iddate(5)
323 
324  common/misccc/sstdat(360,180)
325  common/miscee/lflag,licec
326 
327  SAVE
328 
329  DATA shder /'SAID YEAR MNTH DAYS HOUR MINU SECO SCNN ORBN '/
330  DATA rhder /'CLAT CLON POSN SFTG '/
331  DATA prod1 /'VILWC REQV WSPD SMOI ICON ICAG ICED TPWT TMSK '/
332  DATA prod2 /'TOSD RFLG SFTP SST1 '/
333  DATA brite /'CHNM TMBR '/
334  DATA atxt /'NN','GB'/
335  DATA imsg /99999/,kntscn/0/,knttim/0/,laerr/0/,
336  $ loerr/0/,lbter/7*0/,itimes/0/,nlr/0/,nir/0/,dmax/-99999./,
337  $ dmin/99999./,kspsat/11*0/,kntsat/11*0/,ilflg/0/,bmiss/10.0e10/
338 
339  IF(itimes.EQ.0) THEN
340 
341 C***********************************************************************
342 C FIRST CALL INTO SUBROUTINE DO A FEW THINGS .....
343  itimes = 1
344  lflag = 0
345  licec = 0
346  print 65, indta
347  65 FORMAT(//' ---> W3MISCAN: Y2K/F90 VERSION 08/04/2011: ',
348  $ 'PROCESSING SSM/I DATA FROM BUFR DATA SET READ FROM UNIT ',
349  $ i4/)
350  IF(lprod) print 66
351  66 FORMAT(//' ===> WILL READ FROM BUFR PRODUCTS DATA DUMP ',
352  $ 'FILE (EITHER FNOC OR NCEP) AND PROCESS ONE OR MORE SSM/I ',
353  $ 'PRODUCTS'//)
354  IF(lbrit) THEN
355  print 167
356  167 FORMAT(//' ===> WILL READ FROM BUFR BRIGHTNESS ',
357  $ 'TEMPERATURE DATA DUMP FILE AND PROCESS BRIGHTNESS ',
358  $ 'TEMPERATURES'//)
359  IF(nnalg) print 169
360  169 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ',
361  $ 'CALCULATION OF NEURAL NETWORK 3 WIND SPEED AND TOTAL ',
362  $ 'PRECIPITABLE WATER AND PROCESS THESE'/)
363  IF(gbalg) print 170
364  170 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ',
365  $ 'CALCULATION OF GOODBERLET WIND SPEED AND PROCESS THESE'/)
366  END IF
367  IF(ignrtm.EQ.1) print 704
368  704 FORMAT(' W3MISCAN: INPUT ARGUMENT "IGNRTM" IS SET TO 1 -- NO ',
369  $ 'TIME CHECKS WILL BE PERFORMED ON SCANS - ALL SCANS READ IN ',
370  $ 'ARE PROCESSED'/)
371 
372  print 104, kdate,ldate
373  104 FORMAT(' W3MISCAN: REQUESTED EARLIEST DATE:',i7,4i5/
374  $ ' REQUESTED LATEST DATE:',i7,4i5)
375 
376  kdat = 0
377  kdat(1:3) = kdate(1:3)
378  kdat(5:6) = kdate(4:5)
379  ldat = 0
380  ldat(1:3) = ldate(1:3)
381  ldat(5:6) = ldate(4:5)
382 
383 C DO REQUESTED EARLIEST AND LATEST DATES MAKE SENSE?
384 
385  CALL w3difdat(ldat,kdat,3,rinc)
386  IF(rinc(3).LT.0) THEN
387 C.......................................................................
388  print 103
389  103 FORMAT(' ##W3MISCAN: REQUESTED EARLIEST AND LATEST DATES ',
390  $ 'ARE BACKWARDS!! - IER = 3'/)
391  ier = 3
392  RETURN
393 C.......................................................................
394  END IF
395 
396 C DETERMINE MACHINE WORD LENGTH IN BYTES AND TYPE OF CHARACTER SET
397 C {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)}
398 
399  CALL w3fi04(iendn,ichtp,lw)
400  print 2213, lw, ichtp, iendn
401  2213 FORMAT(/' ---> W3MISCAN: CALL TO W3FI04 RETURNS: LW = ',i3,
402  $ ', ICHTP = ',i3,', IENDN = ',i3/)
403 
404  CALL datelen(10)
405 
406  CALL dumpbf(indta,icdate,iddate)
407 cppppp
408  print *,'CENTER DATE (ICDATE) = ',icdate
409  print *,'DUMP DATE (IDDATE) = ',iddate
410 cppppp
411 
412 C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
413 C - RETURN WITH IRET = 2
414 
415  IF(icdate(1).LE.0) GO TO 998
416 
417 C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
418 C - RETURN WITH IRET = 2
419 
420  IF(iddate(1).LE.0) GO TO 998
421  IF(icdate(1).LT.100) THEN
422 
423 C IF 2-DIGIT YEAR RETURNED IN ICDATE(1), MUST USE "WINDOWING" TECHNIQUE
424 C TO CREATE A 4-DIGIT YEAR
425 
426 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
427 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
428 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
429 
430  print *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ',
431  $ 'HAPPEN!!!!!'
432  print *, '##W3MISCAN - 2-DIGIT YEAR IN ICDATE(1) RETURNED ',
433  $ 'FROM DUMPBF (ICDATE IS: ',icdate,') - USE WINDOWING ',
434  $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
435  IF(icdate(1).GT.20) THEN
436  icdate(1) = 1900 + icdate(1)
437  ELSE
438  icdate(1) = 2000 + icdate(1)
439  ENDIF
440  print *, '##W3MISCAN - CORRECTED ICDATE(1) WITH 4-DIGIT ',
441  $ 'YEAR, ICDATE NOW IS: ',icdate
442  ENDIF
443 
444  IF(iddate(1).LT.100) THEN
445 
446 C IF 2-DIGIT YEAR RETURNED IN IDDATE(1), MUST USE "WINDOWING" TECHNIQUE
447 C TO CREATE A 4-DIGIT YEAR
448 
449 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
450 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
451 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
452 
453  print *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ',
454  $ 'HAPPEN!!!!!'
455  print *, '##W3MISCAN - 2-DIGIT YEAR IN IDDATE(1) RETURNED ',
456  $ 'FROM DUMPBF (IDDATE IS: ',iddate,') - USE WINDOWING ',
457  $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
458  IF(iddate(1).GT.20) THEN
459  iddate(1) = 1900 + iddate(1)
460  ELSE
461  iddate(1) = 2000 + iddate(1)
462  ENDIF
463  print *, '##W3MISCAN - CORRECTED IDDATE(1) WITH 4-DIGIT ',
464  $ 'YEAR, IDDATE NOW IS: ',iddate
465  END IF
466 
467 C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES)
468 
469  CALL openbf(indta,'IN',indta)
470 
471  print *, ' '
472  print *, 'OPEN NCEP BUFR SSM/I DUMP FILE'
473  print *, ' '
474 
475 C Check to see if the old (pre 9/2004) version of the mnemonic
476 C table is being used here (had "PH2O" instead of "TPWT",
477 C "SNDP" instead of "TOSD", "WSOS" instead of "WSPD")
478 C ------------------------------------------------------------
479 
480  CALL status(indta,lun,idummy1,idummy2)
481  CALL nemtab(lun,'PH2O',idummy1,cdummy,iret_ph2o)
482  CALL nemtab(lun,'SNDP',idummy1,cdummy,iret_sndp)
483  CALL nemtab(lun,'WSOS',idummy1,cdummy,iret_wsos)
484  CALL nemtab(lun,'CH2O',idummy1,cdummy,iret_ch2o)
485 
486  IF(lbrit.AND.(nnalg.OR.gbalg)) THEN
487 
488 C-----------------------------------------------------------------------
489 C IF IN-LINE CALC. OF WIND SPEED FROM GOODBERLET ALG. OR
490 C IN-LINE CALCULATION OF WIND SPEED AND TPW FROM NEURAL NET 3 ALG.
491 C FIRST CALL TO THIS SUBROUTINE WILL READ IN SEA-SURFACE TEMPERATURE
492 C FIELD AS A CHECK FOR ICE LIMITS
493 C WILL ALSO OPEN DIRECT ACCESS NESDIS LAND SEA FILE
494 C-----------------------------------------------------------------------
495 
496  CALL misc06(ingbi,ingbd,kdate,ldate,*993,*994,*995,*996)
497  print 67, inlsf
498  67 FORMAT(//4x,'** W3MISCAN: OPEN R. ACCESS NESDIS LAND/SEA ',
499  $ 'FILE IN UNIT ',i2/)
500  OPEN(unit=inlsf,err=997,access='DIRECT',iostat=ierr,recl=10980)
501  END IF
502 
503 C READ THE FIRST BUFR MESSAGE IN THE BUFR FILE
504 
505  CALL readmg(indta,subset,ibdate,iret)
506 
507  print *, 'READ FIRST BUFR MESSAGE: SUBSET = ',subset,
508  $ '; IBDATE = ',ibdate,'; IRET = ',iret
509 
510  IF(iret.NE.0) GO TO 998
511 
512 C***********************************************************************
513 
514  END IF
515 
516  30 CONTINUE
517 
518 C TIME TO DECODE NEXT SUBSET (SCAN) OUT OF BUFR MESSAGE
519 
520  ibuftn = imsg
521  CALL readsb(indta,iret)
522  IF(iret.NE.0) THEN
523 
524 C ALL SUBSETS OUT OF THIS MESSAGE READ, TIME TO MOVE ON TO NEXT MESSAGE
525 
526  CALL readmg(indta,subset,ibdate,iret)
527 
528  print *, 'READ NEXT BUFR MESSAGE: SUBSET = ',subset,
529  $ '; IBDATE = ',ibdate,'; IRET = ',iret
530 
531  IF(iret.NE.0) THEN
532 c.......................................................................
533 
534 C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ
535 C - ALL FINISHED, NO OTHER SCANS W/I DESIRED TIME RANGE -- SET IER TO 1
536 C AND RETURN TO CALLING PROGRAM
537 
538  print 124, kntscn
539  124 FORMAT(/' W3MISCAN: +++++ ALL VALID SCANS UNPACKED AND ',
540  $ 'RETURNED FROM THIS NCEP BUFR SSM/I DUMP FILE'//34x,
541  $ '** W3MISCAN: SUMMARY **'//35x,'TOTAL NUMBER OF SCANS ',
542  $ 'PROCESSED AND RETURNED',11x,i7)
543  DO jj = 239,249
544  IF(kntsat(jj).GT.0) THEN
545  print 294, jj,kntsat(jj)
546  294 FORMAT(35x,'......NO. OF SCANS PROCESSED AND ',
547  $ 'RETURNED FROM SAT',i4,':',i7)
548  END IF
549  END DO
550  DO jj = 239,249
551  IF(kspsat(jj).GT.0) THEN
552  ii = jj
553  IF(jj.EQ.239) ii = 1
554  print 224, ii,kspsat(jj)
555  224 FORMAT(35x,'NO. OF SCANS SKIPPED DUE TO BEING FROM ',
556  $ 'NON-REQ SAT',i4,':',i7)
557  END IF
558  END DO
559  print 194, knttim
560  194 FORMAT(35x,'NUMBER OF SCANS SKIPPED DUE TO BEING OUTSIDE ',
561  $ 'TIME INT.:',i7)
562  print 324, laerr,loerr
563  324 FORMAT(
564  $/35x,'NUMBER OF RETRIEVALS WITH LATITUDE OUT OF RANGE: ',i7/
565  $ 35x,'NUMBER OF RETRIEVALS WITH LONGITUDE OUT OF RANGE: ',i7)
566  IF(lbrit) THEN
567  IF(nnalg.OR.gbalg) print 780, lbter,nlr,nir
568  780 FORMAT(
569  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ V BRIGHT. TEMP:',i7/
570  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ H BRIGHT. TEMP:',i7/
571  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 22 GHZ V BRIGHT. TEMP:',i7/
572  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ V BRIGHT. TEMP:',i7/
573  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ H BRIGHT. TEMP:',i7/
574  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ V BRIGHT. TEMP:',i7/
575  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ H BRIGHT. TEMP:',i7/
576  $ 35x,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER LAND: ',i7/
577  $ 35x,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER ICE: ',i7)
578  IF(nnalg) print 781, lflag,licec
579  781 FORMAT(
580  $ 35x,'NUMBER OF NN3 RETR. REJECTED DUE TO FAILING RAIN FLAG: ',i7/
581  $ 35x,'NUMBER OF NN3 RETR. REJECTED DUE TO ICE CONTAMINATION: ',i7)
582  IF(nnalg.OR.gbalg) print 782, dmax,dmin
583  782 FORMAT(/' ** FOR SEA-SFC TEMP AT ALL RETRIEVAL LOCATIONS: FIELD',
584  $ ' MAX =',f8.3,' DEG K, FIELD MIN =',f8.3,' DEG K'/)
585  END IF
586  ier = 1
587  RETURN
588 C.......................................................................
589  END IF
590 
591  GO TO 30
592  END IF
593 
594 C***********************************************************************
595 C COME HERE FOR BOTH PRODUCTS AND BRIGHTNESS TEMPERATURES
596 C***********************************************************************
597  shdr = bmiss
598  CALL ufbint(indta,shdr_8,09,1,nlev,shder) ; shdr = shdr_8
599  ilflg = 1
600  IF(nlev.NE.1) GO TO 999
601 
602 C STORE THE SCAN'S SATELLITE ID IN WORD 1
603 C STORE SCAN'S YEAR (YYYY), MONTH, DAY, HOUR, MIN, SEC INTO WORDS 2-7
604 C STORE THE SCAN NUMBER IN WORD 8
605 C STORE THE SCAN'S ORBIT NUMBER IN WORD 9
606 
607  ibuftn(1:9) = min(imsg,nint(shdr(1:9)))
608 
609 C CHECK TO SEE IF SCAN IS FROM REQUESTED SATELLITE ID
610 
611  IF(ibuftn(1).LT.240.OR.ibuftn(1).GT.249) THEN
612  print 523, (ibuftn(ii),ii=1,9)
613  kspsat(239) = kspsat(239) + 1
614  GO TO 30
615  END IF
616  IF(.NOT.lsat(ibuftn(1))) THEN
617 CDAK PRINT 523, (IBUFTN(II),II=1,9)
618  523 FORMAT(' ##W3MISCAN: SCAN NOT FROM REQ. SAT. ID -SAT. ID',i4,
619  $ ', SCAN TIME:',6i4,', SCAN',i6,', ORBIT',i8,'-GO TO NEXT SCAN')
620  kspsat(ibuftn(1)) = kspsat(ibuftn(1)) + 1
621  GO TO 30
622  END IF
623 
624  IF(ignrtm.EQ.0) THEN
625 
626 C TIME CHECK THIS SCAN IF USER REQUESTS SUCH
627 
628  mdat = 0
629  mdat(1:3) = ibuftn(2:4)
630  mdat(5:7) = ibuftn(5:7)
631  CALL w3difdat(kdat,mdat,4,rinc)
632  ksec = rinc(4)
633  CALL w3difdat(ldat,mdat,4,rinc)
634  lsec = rinc(4)
635  IF(ksec.GT.0.OR.lsec.LT.0) THEN
636 
637 C TIME CHECK FOR SCAN FAILED: GO ON TO NEXT SCAN
638 
639 CDAK PRINT 123, (IBUFTN(II),II=2,9)
640  123 FORMAT(' ##W3MISCAN: SCAN NOT IN REQUESTED TIME WINDOW-',
641  $ 'SCAN TIME:',6i5,' SCAN',i6,', ORBIT',i8,' - GO TO NEXT SCAN')
642  knttim = knttim + 1
643  GO TO 30
644  END IF
645  END IF
646  rhdr = bmiss
647  CALL ufbint(indta,rhdr_8,04,64,nlev,rhder) ; rhdr = rhdr_8
648  ilflg = 2
649  IF(nlev.NE.64) GO TO 999
650  iflag = 0
651  DO irt = 1,64
652 
653 C THIS ROUTINE EXPECTS LONGITUDE TO BE 0-360 E; BUFR NOW RETURNS -180-0
654 C FOR WEST AND 0-180 FOR EAST
655 
656  IF(rhdr(2,irt).LT.0.0) rhdr(2,irt) = rhdr(2,irt) + 360.
657 C-----------------------------------------------------------------------
658 C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
659 C-----------------------------------------------------------------------
660 C STORE THE LATITUDE (*100 DEGREES; + : NORTH, - : SOUTH)
661  IF(nint(rhdr(1,irt)*100.).GE.-9000.AND.nint(rhdr(1,irt)*100.)
662  $ .LE.9000) THEN
663  ibuftn((27*irt)-17) = nint(rhdr(1,irt)*100.)
664  ELSE
665 
666 C.......................................................................
667 
668 C BAD LATITUDE
669 
670  laerr = laerr + 1
671  print 777, irt,ibuftn(8),ibuftn(9),nint(rhdr(1,irt)*100.)
672  777 FORMAT(' ##W3MISCAN: BAD LAT: RETR.',i3,', SCAN',i6,
673  $ ', ORBIT',i8,'; INPUT LAT=',i7,' - ALL DATA IN THIS ',
674  $ 'RETRIEVAL SET TO MISSING')
675  iflag(irt) = 1
676 C.......................................................................
677 
678  END IF
679 
680 C STORE THE LONGITUDE (*100 DEGREES EAST)
681 
682  IF(nint(rhdr(2,irt)*100.).GE.0.AND.nint(rhdr(2,irt)*100.).LE.
683  $ 36000) THEN
684  IF(iflag(irt).EQ.0)
685  $ ibuftn((27*irt)-16) = nint(rhdr(2,irt)*100.)
686  ELSE
687 
688 C.......................................................................
689 
690 C BAD LONGITUDE
691 
692  loerr = loerr + 1
693  print 778, irt,ibuftn(8),ibuftn(9),nint(rhdr(2,irt)*100.)
694  778 FORMAT(' ##W3MISCAN: BAD LON: RETR.',i3,', SCAN',i6,
695  $ ', ORBIT',i8,'; INPUT LON=',i7,' - ALL DATA IN THIS ',
696  $ 'RETRIEVAL SET TO MISSING')
697  iflag(irt) = 1
698 C.......................................................................
699 
700  END IF
701  IF(iflag(irt).NE.0) GO TO 110
702 
703 C STORE THE POSITION NUMBER
704 
705  ibuftn((27*irt)-15) = min(imsg,nint(rhdr(3,irt)))
706 
707 C STORE THE SURFACE TAG (0-6)
708 
709  ibuftn((27*irt)-14) = min(imsg,nint(rhdr(4,irt)))
710  110 CONTINUE
711 C-----------------------------------------------------------------------
712  END DO
713 
714  IF(lprod) THEN
715 C***********************************************************************
716 C COME HERE TO PROCESS PRODUCTS FROM INPUT SSM/I PRODUCTS FILE
717 C***********************************************************************
718 
719  prod = bmiss
720  CALL ufbint(indta,prod_8,13,64,nlev,prod1//prod2)
721  ufbint_8 = bmiss
722  IF(iret_ph2o.GT.0) THEN ! Prior to 9/2004
723  CALL ufbint(indta,ufbint_8,1,64,nlev,'PH2O')
724  prod_8(8,:) = ufbint_8(:)
725  END IF
726  ufbint_8 = bmiss
727  IF(iret_sndp.GT.0) THEN ! Prior to 9/2004
728  CALL ufbint(indta,ufbint_8,1,64,nlev,'SNDP')
729  prod_8(10,:) = ufbint_8(:)
730  END IF
731  ufbint_8 = bmiss
732  IF(iret_wsos.GT.0) THEN ! Prior to 9/2004
733  CALL ufbint(indta,ufbint_8,1,64,nlev,'WSOS')
734  prod_8(3,:) = ufbint_8(:)
735  END IF
736  ufbint_8 = bmiss
737  IF(iret_ch2o.GT.0) THEN ! Prior to 9/2004
738  CALL ufbint(indta,ufbint_8,1,64,nlev,'CH2O')
739  prod_8(1,:) = ufbint_8(:)
740  ELSE
741  CALL ufbint(indta,ufbint_8,1,64,nlev,'METFET')
742  metfet = ufbint_8
743  DO irt = 1,64
744  IF(nint(metfet(irt)).NE.12) prod_8(1,irt) = bmiss
745  END DO
746  END IF
747 
748  prod=prod_8
749  ilflg = 3
750  IF(nlev.EQ.0) THEN
751  print 797, ibuftn(8),ibuftn(9)
752  797 FORMAT(' ##W3MISCAN: PRODUCTS REQ. BUT SCAN',i6,', ORBIT',
753  $ i8,' DOES NOT CONTAIN PRODUCT DATA - CONTINUE PROCESSING ',
754  $ 'SCAN (B.TEMPS REQ.?)')
755  GO TO 900
756  ELSE IF(nlev.NE.64) THEN
757  GO TO 999
758  END IF
759  DO irt = 1,64
760 C-----------------------------------------------------------------------
761 C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
762 C-----------------------------------------------------------------------
763  IF(iflag(irt).NE.0) GO TO 111
764 
765 C STORE THE CLOUD WATER (*100 KG/M**2) IF AVAILABLE
766 
767  IF(nint(prod(01,irt)).LT.imsg)
768  $ ibuftn((27*irt)-13) = nint(prod(01,irt)*100.)
769 
770 C STORE THE RAIN RATE (*1000000 KG/((M**2)*SEC)) IF AVAILABLE
771 C (THIS IS ALSO RAIN RATE (*1000000 MM/SEC))
772 
773  IF(nint(prod(02,irt)).LT.imsg)
774  $ ibuftn((27*irt)-12) = nint(prod(02,irt)*1000000.)
775 
776 C STORE THE WIND SPEED (*10 M/SEC) IF AVAILABLE
777 
778  ibuftn((27*irt)-11) = min(imsg,nint(prod(03,irt)*10.))
779 
780 C STORE THE SOIL MOISTURE (MM) IF AVAILABLE
781 
782  IF(nint(prod(04,irt)).LT.imsg)
783  $ ibuftn((27*irt)-10) = nint(prod(04,irt)*1000.)
784 
785 C STORE THE SEA ICE CONCENTRATION (PERCENT) IF AVAILABLE
786 
787  ibuftn((27*irt)-09) = min(imsg,nint(prod(05,irt)))
788 
789 C STORE THE SEA ICE AGE (0,1) IF AVAILABLE
790 
791  ibuftn((27*irt)-08) = min(imsg,nint(prod(06,irt)))
792 
793 C STORE THE ICE EDGE (0,1) IF AVAILABLE
794 
795  ibuftn((27*irt)-07) = min(imsg,nint(prod(07,irt)))
796 
797 C STORE THE WATER VAPOR (*10 KG/M**2) IF AVAILABLE
798 C (THIS IS ALSO TOTAL PRECIPITABLE WATER SCALED AS *10 MM)
799 
800  ibuftn((27*irt)-06) = min(imsg,nint(prod(08,irt)*10.))
801 
802  IF(ibuftn((27*irt)-14).NE.5) THEN
803 
804 C STORE THE SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE
805 C (NOTE: SURFACE TAG MUST NOT BE 5)
806 
807  ibuftn((27*irt)-05) = min(imsg,nint(prod(09,irt)*100.))
808 
809  ELSE
810 
811 C STORE THE SEA-SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE
812 C (NOTE: SURFACE TAG MUST BE 5)
813 
814  ibuftn((27*irt)-05) = min(imsg,nint(prod(13,irt)*100.))
815 
816  END IF
817 
818 C STORE THE SNOW DEPTH (MM) IF AVAILABLE
819 
820  IF(nint(prod(10,irt)).LT.imsg)
821  $ ibuftn((27*irt)-04) = nint(prod(10,irt)*1000.)
822 
823 C STORE THE RAIN FLAG (0-3) IF AVAILABLE
824 
825  ibuftn((27*irt)-03) = min(imsg,nint(prod(11,irt)))
826 
827 C STORE THE CALCULATED SURFACE TYPE (1-20) IF AVAILABLE
828 
829  ibuftn((27*irt)-02) = min(imsg,nint(prod(12,irt)))
830  111 CONTINUE
831 C-----------------------------------------------------------------------
832  END DO
833  END IF
834  900 CONTINUE
835 
836  IF(lbrit) THEN
837 C***********************************************************************
838 C COME HERE TO PROCESS BRIGHTNESS TEMPERATURES FROM INPUT SSM/I
839 C BRIGHTNESS TEMPERATURE FILE
840 C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG.
841 C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA N. NET 3 ALG.
842 C***********************************************************************
843 
844  brit = bmiss
845  CALL ufbrep(indta,brit_8,2,448,nlev,brite) ; brit = brit_8
846  ilflg = 4
847  IF(nlev.EQ.0) THEN
848  print 798, ibuftn(8),ibuftn(9)
849  798 FORMAT(' ##W3MISCAN: B. TEMPS REQ. BUT SCAN',i6,', ORBIT',
850  $ i8,' DOES NOT CONTAIN B. TEMP DATA - DONE PROCESSING THIS',
851  $ ' SCAN')
852  GO TO 901
853  ELSE IF(nlev.NE.448) THEN
854  GO TO 999
855  END IF
856  DO irt = 1,64
857 C-----------------------------------------------------------------------
858 C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
859 C-----------------------------------------------------------------------
860  IF(iflag(irt).NE.0) GO TO 112
861 
862 C STORE THE 7 BRIGHTNESS TEMPS (*100 DEGREES KELVIN)
863 C -- CHANNELS ARE IN THIS ORDER FOR A PARTICULAR RETRIEVAL:
864 C 19 GHZ V, 19 GHZ H, 22 GHZ V, 37 GHZ V, 37 GHZ H, 85 GHZ V, 85 GHZ H
865 
866  igood = 0
867  mindx = (irt * 7) - 6
868  DO lch = mindx,mindx+6
869  ichnn = nint(brit(1,lch))
870  IF(ichnn.GT.7) GO TO 79
871  IF(nint(brit(2,lch)).LT.imsg) THEN
872  ibuftn((27*irt)-02+ichnn) = nint(brit(2,lch)*100.)
873  igood = 1
874  END IF
875  79 CONTINUE
876  END DO
877 
878  IF(nnalg.OR.gbalg) THEN
879  kdata = imsg
880  IF(igood.EQ.1) THEN
881 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
882 C COME HERE FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG. AND/OR
883 C FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA NEURAL NET 3 ALG.
884 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
885 
886 C GET LAND/SEA TAG AND CHECK FOR LAT/LON OVER LAND OR ICE
887 
888  balon=real(mod(ibuftn((27*irt)-16)+18000,36000)-18000)/100.
889  ialon = mod(36000-ibuftn((27*irt)-16),36000)
890  ix = 361. - real(ialon)/100.
891  jy = 91 - nint(real(ibuftn((27*irt)-17))/100. + 0.50)
892  dmin = min(dmin,sstdat(ix,jy))
893  dmax = max(dmax,sstdat(ix,jy))
894  CALL misc04(inlsf,real(ibuftn((27*irt)-17))/100.,balon,lstag)
895 
896 C ..... REJECT IF OVER LAND (USE LAND/SEA TAG HERE)
897 
898  IF(lstag.NE.0) THEN
899  nlr = nlr + 1
900  GO TO 112
901  END IF
902 
903 C ..... REJECT IF OVER ICE (USE SEA-SURFACE TEMPERATURE HERE)
904 
905  IF(sstdat(ix,jy).LE.272.96) THEN
906  nir = nir + 1
907  GO TO 112
908  END IF
909 
910  kdata = ibuftn((27*irt)-01:(27*irt)+05)
911  DO it = 1,7
912  IF((it.NE.2.AND.kdata(it).LT.10000).OR.
913  $ (it.EQ.2.AND.kdata(it).LT. 8000)) THEN
914  lbter(it) = lbter(it) + 1
915  print 779,it,ibuftn(8),ibuftn(9),kdata
916  779 FORMAT(' ##W3MISCAN: BT, CHN',i2,' BAD: SCAN',i6,', ORBIT',i8,
917  $ '; BT:',7i6,'-CANNOT CALC. PRODS VIA ALG.')
918  GO TO 112
919  END IF
920  END DO
921 
922 C CALL SUBR. MISC01 TO INITIATE IN-LINE PRODUCT CALCULATION
923 
924  CALL misc01(nnalg,gbalg,kdata,swnn,tpwnn,swgb,nrfgb)
925 
926  IF(nnalg) THEN
927 CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 6021, ATXT(1),SWNN,
928 CDAK $ TPWNN,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100.,
929 CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100.
930  6021 FORMAT(' W3MISCAN: ',a2,' SPD',f6.1,' TPW',f6.1,' TB19V',f6.1,
931  $ ' TB22V',f6.1,' TB37V',f6.1,' TB37H',f6.1,' TD37',f5.1)
932 
933 C STORE THE CALCULATED NEURAL NET 3 WIND SPEED (*10 M/SEC)
934 
935  ibuftn((27*irt)+6) = min(imsg,nint(swnn*10.))
936 
937 C STORE THE CALCULATED NEURAL NET 3 TPW (*10 MILLIMETERS)
938 
939  ibuftn((27*irt)+7) = min(imsg,nint(tpwnn*10.))
940  END IF
941 
942  IF(gbalg) THEN
943 CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 602, ATXT(2),NRFGB,
944 CDAK $ SWGB,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100.,
945 CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100.
946  602 FORMAT(' W3MISCAN: ',a2,' RF, SPD',i2,f6.1,' TB19V',f6.1,
947  $ ' TB22V',f6.1,' TB37V',f6.1,' TB37H',f6.1,' TD37',f5.1)
948 
949 C STORE THE CALCULATED GOODBERLET WIND SPEED (*10 M/SEC)
950 
951  ibuftn((27*irt)+8) = min(imsg,nint(swgb*10.))
952 
953 C STORE THE GOODBERLET RAIN FLAG (0-3)
954 
955  ibuftn((27*irt)+9) = min(imsg,nrfgb)
956  END IF
957 
958 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
959  ELSE
960 
961 C......................................................................
962 
963 C PROBLEM - CAN'T CALCULATE PRODUCTS VIA ANY ALG., ALL B.TEMPS MISSING
964 
965  print 879, ibuftn(8),ibuftn(9),kdata
966  879 FORMAT(' ##W3MISCAN: ALL B.TMPS MSSNG: SCAN',i6,', ',
967  $ 'ORBIT',i8,'; BT:',7i6,'-CANNOT CALC PRODS VIA ALG.')
968 C......................................................................
969 
970  END IF
971  END IF
972 
973  112 CONTINUE
974 C-----------------------------------------------------------------------
975  END DO
976  END IF
977 C***********************************************************************
978  901 CONTINUE
979 
980 C RETURN TO CALLING PROGRAM - IER = 0 SCAN SUCCESSFULLY READ
981 
982  kntscn = kntscn + 1
983  kntsat(ibuftn(1)) = kntsat(ibuftn(1)) + 1
984  ier = 0
985  RETURN
986 
987 C.......................................................................
988  993 CONTINUE
989 
990 C PROBLEM: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB INDEX FILE - ERROR
991 C RETURNED FROM GRIB DECODER GETGB IS 96 - SET IER = 6 & RETURN
992 
993  print 2008, ingbi
994  2008 FORMAT(/' ##W3MISCAN: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB ',
995  $ 'INDEX FILE IN UNIT ',i2,' - IER = 6'/)
996  ier = 6
997  RETURN
998 
999 C.......................................................................
1000  994 CONTINUE
1001 
1002 C PROBLEM: SEA-SURFACE TEMPERATURE GRIB MESSAGE HAS A DATE THAT IS
1003 C EITHER: 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST REQ. DATE
1004 C (INPUT ARG. "KDATE") OR 2) MORE THAN 7-DAYS AFTER THE LATEST
1005 C REQ. DATE (INPUT ARG. "LDATE") - SET IER = 7 AND RETURN
1006 
1007  print 2009
1008  2009 FORMAT(' SST GRIB MSG HAS DATE WHICH IS EITHER 7-DAYS',
1009  $ ' PRIOR TO EARLIEST REQ. DATE'/14x,'OR 7-DAYS LATER THAN LATEST',
1010  $ ' REQ. DATE - IER = 7'/)
1011  ier = 7
1012  RETURN
1013 
1014 C.......................................................................
1015  995 CONTINUE
1016 
1017 C PROBLEM: BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE CONTAINING SEA-
1018 C SURFACE TEMPERATURE FIELD - ERROR RETURNED FROM GRIB DECODER
1019 C GETGB IS 97-99 - SET IER = 8 AND RETURN
1020 
1021  print 2010
1022  2010 FORMAT(' BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE ',
1023  $ 'CONTAINING SEA-SURFACE TEMPERATURE FIELD - IER = 8'/)
1024  ier = 8
1025  RETURN
1026 
1027 C.......................................................................
1028  996 CONTINUE
1029 
1030 C PROBLEM: ERROR RETURNED FROM GRIB DECODER - GETGB - FOR SEA-SURFACE
1031 C TEMPERATURE FIELD - > 0 BUT NOT 96-99 - SET IER = 9 & RETURN
1032 
1033  print 2011
1034  2011 FORMAT(' - IER = 9'/)
1035  ier = 9
1036  RETURN
1037 
1038 C.......................................................................
1039  997 CONTINUE
1040 
1041 C PROBLEM: ERROR OPENING R. ACCESS FILE HOLDING LAND/SEA TAGS - SET IER
1042 C = 4 AND RETURN
1043 
1044  print 2012, ierr,inlsf
1045  2012 FORMAT(/' ##W3MISCAN: ERROR OPENING R. ACCESS LAND/SEA FILE IN ',
1046  $ 'UNIT ',i2,' -- IOSTAT =',i5,' -- NO SCANS PROCESSED - IER = 4'/)
1047  ier = 4
1048  RETURN
1049 
1050 C.......................................................................
1051  998 CONTINUE
1052 
1053 C PROBLEM: THE INPUT DATA SET IS EITHER EMPTY (NULL), NOT BUFR, OR
1054 C CONTAINS NO DATA MESSAGES - SET IER = 2 AND RETURN
1055 
1056  print 14, indta
1057  14 FORMAT(/' ##W3MISCAN: SSM-I DATA SET IN UNIT',i3,' IS EITHER ',
1058  $'EMPTY (NULL), NOT BUFR, OR CONTAINS NO DATA MESSAGES - IER = 2'/)
1059  ier = 2
1060  RETURN
1061 
1062 C.......................................................................
1063  999 CONTINUE
1064 
1065 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED - SET
1066 C IER = 5 AND RETURN
1067 
1068  print 217, nlev,ilflg
1069  217 FORMAT(/' ##W3MISCAN: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
1070  $ 'IS NOT WHAT IS EXPECTED (ILFLG=',i1,') - IER = 5'/)
1071  ier = 5
1072  RETURN
1073 
1074 C.......................................................................
1075  END
1076 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1077 C . . . .
1078 C SUBPROGRAM: MISC01 PREPARES FOR IN-LINE CALUCLATION OF PRODS
1079 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-01-28
1080 C
1081 C ABSTRACT: BASED ON INPUT 7-CHANNEL SSM/I BRIGHTNESS TEMPERATURES,
1082 C DETERMINES THE RAIN FLAG CATEGORY FOR WIND SPEED PRODUCT FOR THE
1083 C GOODBERLET ALGORITHM. THEN CALLS THE APPROPRIATE FUNCTION TO
1084 C CALCULATE EITHER THE WIND SPEED PRODUCT FOR THE GOODBERLET
1085 C ALGORITHM (IF REQUESTED) OR THE WIND SPEED AND TPW PRODUCTS FOR
1086 C THE NEURAL NET 3 ALGORITHM (IF REQUESTED).
1087 C
1088 C PROGRAM HISTORY LOG:
1089 C ????-??-?? W. GEMMILL (W/NMC21) -- ORIGINAL AUTHOR
1090 C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND
1091 C STREAMLINED CODE
1092 C 1996-05-07 D. A. KEYSER (NP22) -- IN-LINE NEURAL NETWORK 1 ALGORITM
1093 C REPLACED BY NEURAL NETWORK 2 ALGORITHM
1094 C 1996-07-30 D. A. KEYSER (NP22) -- CAN NOW PROCESS WIND SPEED FROM
1095 C BOTH ALGORITHMS IF DESIRED
1096 C 1998-01-28 D. A. KEYSER (NP22) -- REPLACED NEURAL NET 2 ALGORITHM
1097 C WHICH CALCULATED ONLY WIND SPEED PRODUCT WITH NEURAL NET 3
1098 C ALGORITHM WHICH CALCULATES BOTH WIND SPEED AND TOTAL
1099 C PRECIPITABLE WATER PRODUCTS (AMONG OTHERS) BUT, UNLIKE NN2,
1100 C DOES NOT RETURN A RAIN FLAG VALUE (IT DOES SET ALL RETRIEVALS
1101 C TO MISSING THAT FAIL RAIN FLAG AND ICE CONTAMINATION TESTS)
1102 C
1103 C USAGE: CALL MISC01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB)
1104 C INPUT ARGUMENT LIST:
1105 C NNALG - PROCESS WIND SPEED AND TPW VIA NEURAL NET 3 ALGORITHM
1106 C - IF TRUE
1107 C GBALG - PROCESS WIND SPEED VIA GOODBERLET ALGORITHM IF TRUE
1108 C KDATA - 7-WORD ARRAY CONTAINING 7 CHANNELS OF BRIGHTNESS
1109 C - TEMPERATURE (KELVIN X 100)
1110 C
1111 C OUTPUT ARGUMENT LIST:
1112 C SWNN - CALCULATED WIND SPEED BASED ON NEURAL NET 3 ALGORITHM
1113 C - (METERS/SECOND)
1114 C TPWNN - CALCULATED TOTAL COLUMN PRECIPITABLE WATER BASED ON
1115 C - NEURAL NET 3 ALGORITHM (MILLIMETERS)
1116 C SWGB - CALCULATED WIND SPEED BASED ON GOODBERLET ALGORITH
1117 C - (METERS/SECOND)
1118 C NRFGB - RAIN FLAG CATEGORY FOR CALCULATED WIND SPEED FROM
1119 C - GOODBERLET ALGORITHM
1120 C
1121 C REMARKS: IF AN ALGORITHM IS NOT CHOSEN, THE OUTPUT PRODUCTS ARE SET
1122 C TO VALUES OF 99999. FOR THAT ALGORITHM AND, FOR THE GOODBERLET
1123 C ALGORITHM ONLY, THE RAIN FLAG IS SET TO 99999. CALLED BY
1124 C SUBROUTINE W3MISCAN.
1125 C
1126 C ATTRIBUTES:
1127 C LANGUAGE: FORTRAN 90
1128 C MACHINE: IBM-SP
1129 C
1130 C$$$
1131  SUBROUTINE misc01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB)
1132  LOGICAL NNALG,GBALG
1133  REAL BTA(4),BTAA(7)
1134  INTEGER KDATA(7)
1135 
1136  common/miscee/lflag,licec
1137 
1138  SAVE
1139 
1140  swnn = 99999.
1141  tpwnn = 99999.
1142  swgb = 99999.
1143  nrfgb = 99999
1144 
1145  tb19v = real(kdata(1))/100.
1146  tb19h = real(kdata(2))/100.
1147  tb22v = real(kdata(3))/100.
1148  tb37v = real(kdata(4))/100.
1149  tb37h = real(kdata(5))/100.
1150  tb85v = real(kdata(6))/100.
1151  tb85h = real(kdata(7))/100.
1152  td37 = tb37v - tb37h
1153 
1154  IF(nnalg) THEN
1155 C COMPUTE WIND SPEED FROM NEURAL NET 2 ALGORITHM (1995)
1156 C (no longer a possibility - subr. expects dim. of 5 on BTAA)
1157 cdak NRFNN = 1
1158 cdak IF(TB19H.LE.185.0.AND.TB37H.LE.210.0.AND.TB19V.LT.TB37V)
1159 cdak $ NRFNN = 0
1160 cdak BTAA(1) = TB19V
1161 cdak BTAA(2) = TB22V
1162 cdak BTAA(3) = TB37V
1163 cdak BTAA(4) = TB37H
1164 cdak BTAA(5) = TB85V
1165 cdak SWNN = RISC02xx(BTAA)
1166 
1167 C COMPUTE WIND SPEED AND TPW FROM NEURAL NET 3 ALGORITHM (1997)
1168  btaa(1) = tb19v
1169  btaa(2) = tb19h
1170  btaa(3) = tb22v
1171  btaa(4) = tb37v
1172  btaa(5) = tb37h
1173  btaa(6) = tb85v
1174  btaa(7) = tb85h
1175  swnn = risc02(btaa,tpwnn,lqwnn,sstnn,jerr)
1176  IF(jerr.EQ.1) lflag = lflag + 1
1177  IF(jerr.EQ.2) licec = licec + 1
1178  END IF
1179 
1180  IF(gbalg) THEN
1181 C COMPUTE WIND SPEED FROM GOODBERLET ALGORITHM
1182  nrfgb = 0
1183  IF(td37.LE.50.0.OR.tb19h.GE.165.0) THEN
1184  IF(td37.LE.50.0.OR.tb19h.GE.165.0) nrfgb = 1
1185  IF(td37.LE.37.0) nrfgb = 2
1186  IF(td37.LE.30.0) nrfgb = 3
1187  END IF
1188  bta(1) = tb19v
1189  bta(2) = tb22v
1190  bta(3) = tb37v
1191  bta(4) = tb37h
1192  swgb = risc03(bta)
1193  END IF
1194 
1195  RETURN
1196  END
1197 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1198 C . . . .
1199 C SUBPROGRAM: RISC02 CALC. SSM/I PRODS FROM NEURAL NET 3 ALG.
1200 C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1997-02-02
1201 C
1202 C ABSTRACT: THIS RETRIEVAL ALGORITHM IS A NEURAL NETWORK IMPLEMENTATION
1203 C OF THE SSM/I TRANSFER FUNCTION. IT RETRIEVES THE WIND SPEED (W)
1204 C AT THE HEIGHT 20 METERS, COLUMNAR WATER VAPOR (V), COLUMNAR LIQUID
1205 C WATER (L) AND SST. THE NN WAS TRAINED USING BACK-PROPAGATION
1206 C ALGORITHM. TRANSFER FUNCTION IS DESCRIBED AND COMPARED WITH
1207 C CAL/VAL AND OTHER ALGORITHMS IN OMB TECHNICAL NOTE NO. 137. SEE
1208 C REMARKS FOR DETAILED INFO ON THIS ALGORITHM. THIS IS AN IMPROVED
1209 C VERSION OF THE EARLIER NEURAL NETWORK 2 ALGORITHM.
1210 C
1211 C PROGRAM HISTORY LOG:
1212 C 1997-02-02 V. KRASNOPOLSKY -- ORIGINAL AUTHOR
1213 C
1214 C USAGE: XX = RISC02(XT,V,L,SST,JERR)
1215 C INPUT ARGUMENT LIST:
1216 C XT - 7-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE
1217 C - ORDER: T19V (WORD 1), T19H (WORD 2), T22V (WORD 3),
1218 C - T37V (WORD 4), T37H (WORD 5), T85V (WORD 6), T85H
1219 C - (WORD 7) (ALL IN KELVIN)
1220 C
1221 C OUTPUT ARGUMENT LIST:
1222 C V - COLUMNAR WATER VAPOR (TOTAL PRECIP. WATER) (MM)
1223 C L - COLUMNAR LIQUID WATER (MM)
1224 C SST - SEA SURFACE TEMPERATURE (DEG. C)
1225 C XX - WIND SPEED (METERS/SECOND) AT THE HEIGHT OF 20 METERS
1226 C JERR - ERROR RETURN CODE:
1227 C = 0 -- GOOD RETRIEVALS
1228 C = 1 -- RETRIEVALS COULD NOT BE MADE DUE TO ONE OR
1229 C MORE BRIGHTNESS TEMPERATURES OUT OF RANGE
1230 C (I.E, FAILED THE RAIN FLAG TEST)
1231 C = 2 -- RETRIEVALS COULD NOT BE MADE DUE TO ICE
1232 C CONTAMINATION
1233 C {FOR EITHER 1 OR 2 ABOVE, ALL RETRIEVALS SET TO
1234 C 99999. (MISSING)}
1235 C
1236 C REMARKS: FUNCTION, CALLED BY SUBROUTINE MISC01.
1237 C
1238 C Description of training and test data set:
1239 C ------------------------------------------
1240 C The training set consists of 3460 matchups which were received
1241 C from two sources:
1242 C 1. 3187 F11/SSMI/buoy matchups were filtered out from a
1243 C preliminary version of the new NRL database which was
1244 C kindly provided by G. Poe (NRL). Maximum available wind
1245 C speed is 24 m/s.
1246 C 2. 273 F11/SSMI/OWS matchups were filtered out from two
1247 C datasets collected by high latitude OWS LIMA and MIKE.
1248 C These data sets were kindly provided by D. Kilham
1249 C (University of Bristol). Maximum available wind speed
1250 C is 26.4 m/s.
1251 C
1252 C Satellite data are collocated with both buoy and OWS data in
1253 C space within 15 km and in time within 15 min.
1254 C
1255 C The test data set has the same structure, the same number of
1256 C matchups and maximum buoy wind speed.
1257 C
1258 C Description of retrieval flags:
1259 C -------------------------------
1260 C Retrieval flags by Stogryn et al. are used. The algorithm
1261 C produces retrievals under CLEAR + CLOUDY conditions, that is
1262 C if:
1263 C
1264 C T37V - T37H > 50. => CLEAR condition
1265 C or
1266 C T37V - T37H =< 50.|
1267 C T19H =< 185. and |
1268 C T37H =< 210. and | => CLOUDY conditions
1269 C T19V < T37V |
1270 C
1271 C
1272 C ATTRIBUTES:
1273 C LANGUAGE: FORTRAN 90
1274 C MACHINE: IBM-SP
1275 C
1276 C$$$
1277  FUNCTION risc02(XT,V,L,SST,JERR)
1278  parameter(iout =4)
1279  LOGICAL LQ1,LQ2,LQ3,LQ4
1280  REAL XT(7),Y(IOUT),V,L,SST
1281  equivalence(y(1),spn)
1282 
1283  jerr = 0
1284 
1285 C -------- Retrieval flag (Stogryn) -------------------------
1286 
1287 C T19H =< 185
1288 
1289  lq1 = (xt(2).LE.185.)
1290 
1291 C T37H =< 210
1292 
1293  lq2 = (xt(5).LE.210.)
1294 
1295 C T19V < T37V
1296 
1297  lq3 = (xt(1).LT.xt(4))
1298 
1299 C T37V - T37H =< 50.
1300 
1301  lq4 = ((xt(4) - xt(5)).LE.50.)
1302  lq1 = (lq1.AND.lq2.AND.lq3)
1303  IF(.NOT.lq1.AND.lq4) THEN
1304  spn = 99999.
1305  v = 99999.
1306  l = 99999.
1307  sst = 99999.
1308  jerr = 1
1309  GO TO 111
1310  END IF
1311 
1312 C --------------- Call NN ----------------------
1313 
1314 C NN WIND SPEED
1315 
1316  CALL misc10(xt,y)
1317  v = y(2)
1318  l = y(3)
1319  sst = y(4)
1320 
1321 C --------- Remove negative values ----------------------------
1322 
1323  IF(spn.LT.0.0) spn = 0.0
1324  IF(sst.LT.0.0) sst = 0.0
1325  IF(v .LT.0.0) v = 0.0
1326 
1327 C ------ Remove ice contamination ------------------------------------
1328 
1329  ice = 0
1330  si85 = -174.4 + (0.715 * xt(1)) + (2.439 * xt(3)) - (0.00504 *
1331  $ xt(3) * xt(3)) - xt(6)
1332  tt = 44. + (0.85 * xt(1))
1333  IF(si85.GE.10.) THEN
1334  IF(xt(3).LE.tt) ice = 1
1335  IF((xt(3).GT.264.).AND.((xt(3)-xt(1)).LT.2.)) ice = 1
1336  END IF
1337  IF(ice.EQ.1) THEN
1338  spn = 99999.
1339  v = 99999.
1340  l = 99999.
1341  sst = 99999.
1342  jerr = 2
1343  END IF
1344 
1345  111 CONTINUE
1346 
1347  risc02 = spn
1348 
1349  RETURN
1350  END
1351 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1352 C . . . .
1353 C SUBPROGRAM: MISC10 CALC. SSM/I PRODS FROM NEURAL NET 3 ALG.
1354 C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1996-07-15
1355 C
1356 C ABSTRACT: THIS NN CALCULATES W (IN M/S), V (IN MM), L (IN MM), AND
1357 C SST (IN DEG C). THIS NN WAS TRAINED ON BLENDED F11 DATA SET
1358 C (SSMI/BUOY MATCHUPS PLUS SSMI/OWS MATCHUPS 15 KM X 15 MIN) UNDER
1359 C CLEAR + CLOUDY CONDITIONS.
1360 C
1361 C PROGRAM HISTORY LOG:
1362 C 1996-07-15 V. KRASNOPOLSKY -- ORIGINAL AUTHOR
1363 C
1364 C USAGE: CALL MISC10(X,Y)
1365 C INPUT ARGUMENT LIST:
1366 C X - 5-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE
1367 C - ORDER: T19V (WORD 1), T19H (WORD 2), T22V (WORD 3),
1368 C - T37V (WORD 4), T37H (WORD 5) (ALL IN KELVIN)
1369 C
1370 C OUTPUT ARGUMENT LIST:
1371 C Y - 4-WORD ARRAY CONTAINING CALCULATED PRODUCTS IN THE
1372 C - ORDER: WIND SPEED (M/S) (WORD 1), COLUMNAR WATER
1373 C - VAPOR (TOTAL PRECIP. WATER) (MM) (WORD 2), COLUMNAR
1374 C - LIQUID WATER (MM) (WORD 3), SEA SURFACE TEMPERATURE
1375 C - (DEG. C) (WORD 4)
1376 C
1377 C REMARKS: CALLED BY SUBROUTINE RISC02.
1378 C
1379 C ATTRIBUTES:
1380 C LANGUAGE: FORTRAN 90
1381 C MACHINE: IBM-SP
1382 C
1383 C$$$
1384  SUBROUTINE misc10(X,Y)
1385  INTEGER HID,OUT
1386 
1387 C IN IS THE NUMBER OF NN INPUTS, HID IS THE NUMBER OF HIDDEN NODES,
1388 C OUT IS THE NUMBER OF OUTPUTS
1389 
1390  parameter(in =5, hid =12, out =4)
1391  dimension x(in),y(out),w1(in,hid),w2(hid,out),b1(hid),b2(out),
1392  $ o1(in),x2(hid),o2(hid),x3(out),o3(out),a(out),b(out)
1393 
1394 C W1 HOLDS INPUT WEIGHTS
1395 
1396  DATA ((w1(i,j),j = 1,hid),i = 1,in)/
1397  $-0.0435901, 0.0614709,-0.0453639,-0.0161106,-0.0271382, 0.0229015,
1398  $-0.0650678, 0.0704302, 0.0383939, 0.0773921, 0.0661954,-0.0643473,
1399  $-0.0108528,-0.0283174,-0.0308437,-0.0199316,-0.0131226, 0.0107767,
1400  $ 0.0234265,-0.0291637, 0.0140943, .00567931,-.00931768,
1401  $-.00860661, 0.0159747,-0.0749903,-0.0503523, 0.0524172, 0.0195771,
1402  $ 0.0302056, 0.0331725, 0.0326714,-0.0291429, 0.0180438, 0.0281923,
1403  $-0.0269554, 0.102836, 0.0591511, 0.134313, -0.0109854,-0.0786303,
1404  $ 0.0117111, 0.0231543,-0.0205603,-0.0382944,-0.0342049,
1405  $ 0.00052407,0.110301, -0.0404777, 0.0428816, 0.0878070, 0.0168326,
1406  $ 0.0196183, 0.0293995, 0.00954805,-.00716287,0.0269475,
1407  $-0.0418217,-0.0165812, 0.0291809/
1408 
1409 C W2 HOLDS HIDDEN WEIGHTS
1410 
1411  DATA ((w2(i,j),j = 1,out),i = 1,hid)/
1412  $-0.827004, -0.169961,-0.230296, -0.311201, -0.243296, 0.00454425,
1413  $ 0.950679, 1.09296, 0.0842604, 0.0140775, 1.80508, -0.198263,
1414  $-0.0678487, 0.428192, 0.827626, 0.253772, 0.112026, 0.00563793,
1415  $-1.28161, -0.169509, 0.0019085,-0.137136, -0.334738, 0.224899,
1416  $-0.189678, 0.626459,-0.204658, -0.885417, -0.148720, 0.122903,
1417  $ 0.650024, 0.715758, 0.735026, -0.123308, -0.387411,-0.140137,
1418  $ 0.229058, 0.244314,-1.08613, -0.294565, -0.192568, 0.608760,
1419  $-0.753586, 0.897605, 0.0322991,-0.178470, 0.0807701,
1420  $-0.781417/
1421 
1422 C B1 HOLDS HIDDEN BIASES
1423 
1424  DATA (b1(i), i=1,hid)/
1425  $ -9.92116,-10.3103,-17.2536, -5.26287, 17.7729,-20.4812,
1426  $ -4.80869,-11.5222, 0.592880,-4.89773,-17.3294, -7.74136/
1427 
1428 C B2 HOLDS OUTPUT BIAS
1429 
1430  DATA (b2(i), i=1,out)/-0.882873,-0.0120802,-3.19400,1.00314/
1431 
1432 C A(OUT), B(OUT) HOLD TRANSFORMATION COEFFICIENTS
1433 
1434  DATA (a(i), i=1,out)/18.1286,31.8210,0.198863,37.1250/
1435  DATA (b(i), i=1,out)/13.7100,32.0980,0.198863,-5.82500/
1436 
1437 C INITIALIZE
1438 
1439  o1 = x
1440 
1441 C START NEURAL NETWORK
1442 
1443 C - INITIALIZE X2
1444 
1445  DO i = 1,hid
1446  x2(i) = 0.
1447  DO j = 1,in
1448  x2(i) = x2(i) + (o1(j) * w1(j,i))
1449  END DO
1450  x2(i) = x2(i) + b1(i)
1451  o2(i) = tanh(x2(i))
1452  END DO
1453 
1454 C - INITIALIZE X3
1455 
1456  DO k = 1,out
1457  x3(k) = 0.
1458  DO j = 1,hid
1459  x3(k) = x3(k) + (w2(j,k) * o2(j))
1460  END DO
1461 
1462  x3(k) = x3(k) + b2(k)
1463 
1464 C --- CALCULATE O3
1465 
1466  o3(k) = tanh(x3(k))
1467  y(k) = (a(k) * o3(k)) + b(k)
1468  END DO
1469 
1470  RETURN
1471  END
1472 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1473 C . . . .
1474 C SUBPROGRAM: RISC02xx CALC. WSPD FROM NEURAL NET 2 ALGORITHM
1475 C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1996-05-07
1476 C
1477 C ABSTRACT: CALCULATES A SINGLE NEURAL NETWORK OUTPUT FOR WIND SPEED.
1478 C THE NETWORK WAS TRAINED ON THE WHOLE DATA SET WITHOUT ANY
1479 C SEPARATION INTO SUBSETS. IT GIVES RMS = 1.64 M/S FOR TRAINING SET
1480 C AND 1.65 M/S FOR TESTING SET. THIS IS AN IMPROVED VERSION OF THE
1481 C EARLIER NEURAL NETWORK 1 ALGORITHM.
1482 C
1483 C PROGRAM HISTORY LOG:
1484 C 1994-03-20 V. KRASNOPOLSKY -- ORIGINAL AUTHOR
1485 C 1995-05-07 V. KRASNOPOLSKY -- REPLACED WITH NEURAL NET 2 ALGORITHM
1486 C
1487 C USAGE: XX = RISC02xx(X)
1488 C INPUT ARGUMENT LIST:
1489 C X - 5-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE
1490 C - ORDER: T19V (WORD 1), T22V (WORD 2), T37V (WORD 3),
1491 C - T37H (WORD 4), T85V (WORD 5) (ALL IN KELVIN)
1492 C
1493 C OUTPUT ARGUMENT LIST:
1494 C XX - WIND SPEED (METERS/SECOND)
1495 C
1496 C REMARKS: FUNCTION, NO LONGER CALLED BY THIS PROGRAM. IT IS HERE
1497 C SIMPLY TO SAVE NEURAL NET 2 ALGORITHM FOR POSSIBLE LATER USE
1498 C (HAS BEEN REPLACED BY NEURAL NET 3 ALGORITHM, SEE SUBR. RISC02
1499 C AND MISC10).
1500 C
1501 C ATTRIBUTES:
1502 C LANGUAGE: FORTRAN 90
1503 C MACHINE: IBM-SP
1504 C
1505 C$$$
1506  FUNCTION risc02xx(X)
1507  INTEGER HID
1508 C IN IS THE NUMBER OF B. TEMP. CHNLS, HID IS THE NUMBER OF HIDDEN NODES
1509  parameter(in =5, hid =2)
1510  dimension x(in),w1(in,hid),w2(hid),b1(hid),o1(in),x2(hid),o2(hid)
1511 
1512  SAVE
1513 
1514 C W1 HOLDS INPUT WEIGHTS
1515  DATA ((w1(i,j),j=1,hid),i=1,in)/
1516  $ 4.402388e-02, 2.648334e-02, 6.361322e-04,-1.766535e-02,
1517  $ 7.876555e-03,-7.387260e-02,-2.656543e-03, 2.957161e-02,
1518  $-1.181134e-02, 4.520317e-03/
1519 C W2 HOLDS HIDDEN WEIGHTS
1520  DATA (w2(i),i=1,hid)/8.705661e-01,1.430968/
1521 C B1 HOLDS HIDDEN BIASES
1522  DATA (b1(i),i=1,hid)/-6.436114,8.799655/
1523 C B2 HOLDS OUTPUT BIAS
1524 C AY AND BY HOLD OUTPUT TRANSFORMATION COEFFICIENTS
1525  DATA b2/-0.736255/,ay/16.7833/,by/11.08/
1526  o1 = x
1527 C INITIALIZE
1528  x3 = 0.
1529  DO i = 1, hid
1530  o2(i) = 0.
1531  x2(i) = 0.
1532  DO j = 1,in
1533  x2(i) = x2(i) + (o1(j) * w1(j,i))
1534  END DO
1535  x2(i) = x2(i) + b1(i)
1536  o2(i) = tanh(x2(i))
1537  x3 = x3 + (o2(i)* w2(i))
1538  END DO
1539  x3 = x3 + b2
1540  o3 = tanh(x3)
1541  risc02xx = (ay * o3) + by
1542  risc02xx = max(risc02xx,0.0)
1543 C BIAS CORRECTION
1544  bias = 0.5 + 0.004*((risc02xx-10.)**3)*(1.-exp(-0.5*risc02xx))
1545  risc02xx = risc02xx + bias
1546  RETURN
1547  END
1548 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1549 C . . . .
1550 C SUBPROGRAM: RISC03 CALC. W.SPD FROM B TEMP.- GOODBERLET ALG
1551 C PRGMMR: W. GEMMILL ORG: NP21 DATE: 1994-08-15
1552 C
1553 C ABSTRACT: CALCULATES A SINGLE GOODBERLET OUTPUT FOR WIND SPEED.
1554 C THIS IS A LINEAR REGRESSION ALGORITHM FROM 1989.
1555 C
1556 C PROGRAM HISTORY LOG:
1557 C 1994-08-15 W. GEMMILL -- ORIGINAL AUTHOR
1558 C
1559 C USAGE: XX = RISC03(X)
1560 C INPUT ARGUMENT LIST:
1561 C X - 4-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE
1562 C - ORDER: T19V (WORD 1), T22V (WORD 2), T37V (WORD 3),
1563 C - T37H (WORD 4) (ALL IN KELVIN)
1564 C
1565 C OUTPUT ARGUMENT LIST:
1566 C XX - WIND SPEED (METERS/SECOND)
1567 C
1568 C REMARKS: FUNCTION, CALLED BY SUBROUTINE MISC01.
1569 C
1570 C ATTRIBUTES:
1571 C LANGUAGE: FORTRAN 90
1572 C MACHINE: IBM-SP
1573 C
1574 C$$$
1575  FUNCTION risc03(X)
1576  dimension x(4)
1577 
1578  SAVE
1579 
1580  risc03 = 147.90 + (1.0969 * x(1)) - (0.4555 * x(2)) -
1581  $ (1.76 * x(3)) + (0.7860 * x(4))
1582  RETURN
1583  END
1584 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1585 C . . . .
1586 C SUBPROGRAM: MISC04 RETURNS LAND/SEA TAG FOR GIVEN LAT/LON
1587 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-01-04
1588 C
1589 C ABSTRACT: FINDS AND RETURNS THE LOW RESOLUTION LAND/SEA TAG NEAREST
1590 C TO THE REQUESTED LATITUDE AND LONGITUDE.
1591 C
1592 C PROGRAM HISTORY LOG:
1593 C 1978-01-20 J. K. KALINOWSKI (S11213) -- ORIGINAL AUTHOR
1594 C 1978-10-03 J. K. KALINOWSKI (S1214) -- CHANGES UNKNOWN
1595 C 1985-03-01 N. DIGIROLAMO (SSAI) -- CONVERSION TO VS FORTRAN
1596 C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND
1597 C STREAMLINED CODE
1598 C
1599 C USAGE: CALL MISC04(INLSF,BLAT,BLNG,LSTAG)
1600 C INPUT ARGUMENT LIST:
1601 C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE
1602 C BLAT - LATITUDE (WHOLE DEGREES: RANGE IS 0. TO +90. NORTH,
1603 C - 0. TO -90. SOUTH)
1604 C BLNG - LONGITUDE (WHOLE DEGREES: RANGE IS 0. TO +179.99 EAST,
1605 C - 0. TO -180. WEST)
1606 C
1607 C OUTPUT ARGUMENT LIST:
1608 C LSTAG - LAND/SEA TAG {=0 - SEA; =1 - LAND; =2 - COASTAL
1609 C - INTERFACE (HIGHER RESOLUTION TAGS ARE AVAILABLE);
1610 C - =3 - COASTAL INTERFACE (NO HIGHER RESOLUTION TAGS
1611 C - EXIST)}
1612 C
1613 C REMARKS: CALLED BY SUBROUTINE W3MISCAN.
1614 C
1615 C ATTRIBUTES:
1616 C LANGUAGE: FORTRAN 90
1617 C MACHINE: IBM-SP
1618 C
1619 C$$$
1620  SUBROUTINE misc04(INLSF,BLAT,BLNG,LSTAG)
1621  CHARACTER*1 LPUT
1622  REAL RGS(3)
1623 C LPUT CONTAINS A REGION OF LAND/SEA TAGS (RETURNED FROM CALL TO MISC05)
1624  common/miscdd/lput(21960)
1625 
1626  SAVE
1627 
1628 C RGS IS ARRAY HOLDING SOUTHERN BOUNDARIES OF EACH LAND/SEA TAG REGION
1629  DATA rgs/-85.,-30.,25./,numrgl/0/,iflag/0/
1630 C INITIALIZE LAND/SEA TAG AS 1 (OVER LAND)
1631  lstag = 1
1632 C FIND NEAREST POINT OF A HALF-DEGREE (LAT,LONG) GRID
1633 C ..ALAT IS LATITUDE TO THE NEAREST HALF-DEGREE
1634  alat = int((blat+sign(.25,blat))/.5) * .5
1635 C ..ALNG IS LONGITUDE TO THE NEAREST HALF-DEGREE
1636  alng = int((blng+sign(.25,blng))/.5) * .5
1637  IF(nint(alng*10.).EQ.1800) alng = -180.
1638 C IDENTIFY DATABASE REGION IN WHICH TO FIND CORRECT TAG
1639  numrgn = 1
1640  IF(iabs(nint(alat*10)).GT.850) THEN
1641  RETURN
1642  ELSE IF(nint(alat*10).GT.275) THEN
1643  numrgn = 3
1644  ELSE IF(nint(alat*10.).GE.-275) THEN
1645  numrgn = 2
1646  END IF
1647  IF(numrgn.NE.numrgl.OR.iflag.EQ.1) THEN
1648  numrgl = numrgn
1649  CALL misc05(inlsf,numrgn,*99)
1650  END IF
1651 C FIND THE BYTE & BIT PAIR W/I DATA BASE REGION CONTAINING DESIRED TAG
1652  trm1 = ((alat - rgs(numrgn)) * 1440.) + 360.
1653  lstpt = trm1 + (2. * alng)
1654 C ..NBYTE IS THE BYTE IN LPUT CONTAINING THE TAG
1655  nbyte = (180 * 8) + (lstpt/4 * 8)
1656  nshft = (2 * (mod(lstpt,4) + 1)) - 2
1657 C PULL OUT THE TAG
1658  CALL gbyte(lput,lstag,nbyte+nshft,2)
1659  iflag = 0
1660  RETURN
1661 C-----------------------------------------------------------------------
1662  99 CONTINUE
1663 C COME HERE IF LAND/SEA TAG COULD NOT BE RETURNED FROM SUBR. W3MISCAN
1664 C (IN THIS CASE IT WILL REMAIN SET TO 1 INDICATING OVER LAND)
1665  iflag = 1
1666  RETURN
1667 C-----------------------------------------------------------------------
1668  END
1669 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1670 C . . . .
1671 C SUBPROGRAM: MISC05 READS 2 RECORDS FROM LAND/SEA TAG DTABASE
1672 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-01-04
1673 C
1674 C ABSTRACT: READS TWO RECORDS FROM A LOW RESOLUTION LAND/SEA DATABASE
1675 C AND STORES INTO COMMON.
1676 C
1677 C PROGRAM HISTORY LOG:
1678 C 1978-01-20 J. K. KALINOWSKI (S11213) -- ORIGINAL AUTHOR
1679 C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND
1680 C STREAMLINED CODE; MODIFIED TO BE MACHINE INDEPENDENT THRU
1681 C USE OF STANDARD FORTRAN DIRECT ACCESS READ
1682 C
1683 C USAGE: CALL MISC05(INLSF,NUMRGN)
1684 C INPUT ARGUMENT LIST:
1685 C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE
1686 C NUMRGN - THE REGION (1,2 OR 3) OF THE DATABASE TO BE ACCESSED
1687 C - (DEPENDENT ON LATITUDE BAND)
1688 C
1689 C INPUT FILES:
1690 C UNIT AA - (WHERE AA IS EQUAL TO INPUT ARGUMENT 'INLSF')
1691 C - DIRECT ACCESS NESDIS LAND/SEA FILE
1692 C
1693 C OUTPUT FILES:
1694 C UNIT 06 - PRINTOUT
1695 C
1696 C REMARKS: CALLED BY SUBROUTNE MISC04.
1697 C
1698 C ATTRIBUTES:
1699 C LANGUAGE: FORTRAN 90
1700 C MACHINE: IBM-SP
1701 C
1702 C$$$
1703  SUBROUTINE misc05(INLSF,NUMRGN,*)
1704  CHARACTER*1 LPUT
1705 
1706 C LPUT CONTAINS A REGION OF LAND/SEA TAGS (COMPRISED OF 2 RECORDS FROM
1707 C LAND/SEA FILE) -- 180 BYTES OF DOCUMENTATION FOLLOWED BY 21780 BYTES
1708 C OF LAND/SEA TAGS
1709 
1710  common/miscdd/lput(21960)
1711 
1712  SAVE
1713 
1714  nrec = (2 * numrgn) - 1
1715  READ(inlsf,rec=nrec,err=10) (lput(ii),ii=1,10980)
1716  nrec = nrec + 1
1717  READ(inlsf,rec=nrec,err=10) (lput(ii),ii=10981,21960)
1718  RETURN
1719 C-----------------------------------------------------------------------
1720  10 CONTINUE
1721 C ERROR READING IN A RECORD FROM LAND-SEA FILE -- RETURN (TAG WILL BE
1722 C SET TO 1 MEANING OVER LAND IN THIS CASE)
1723  print 1000, nrec,inlsf
1724  1000 FORMAT(' ##W3MISCAN/MISC05: ERROR READING IN LAND-SEA DATA ',
1725  $ 'RECORD',i7,' IN UNIT ',i2,' -- SET TAG TO LAND'/)
1726  RETURN 1
1727 C-----------------------------------------------------------------------
1728  END
1729 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
1730 C . . . .
1731 C SUBPROGRAM: MISC06 READS IN NH AND SH 1-DEG. SEA-SFC TEMPS.
1732 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2000-02-18
1733 C
1734 C ABSTRACT: READS IN GLOBAL SEA-SURFACE TEMPERATURE FIELD ON A ONE-
1735 C DEGREE GRID FROM GRIB FILE.
1736 C
1737 C PROGRAM HISTORY LOG:
1738 C ????-??-?? W. GEMMILL (NP21) -- ORIGINAL AUTHOR
1739 C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND
1740 C STREAMLINED CODE; CONVERTED SST INPUT FILE FROM VSAM/ON84 TO
1741 C GRIB TO ALLOW CODE COMPILE AND RUN ON THE CRAY MACHINES.
1742 C 2000-02-18 D. A. KEYSER -- MODIFIED TO CALL W3LIB ROUTINE "GETGB",
1743 C THIS ALLOWS CODE TO COMPILE AND RUN PROPERLY ON IBM-SP
1744 C
1745 C USAGE: CALL MISC06(INGBI,INGBD,IDAT1,IDAT2,*,*,*,*)
1746 C INPUT ARGUMENT LIST:
1747 C INGBI - UNIT NUMBER OF GRIB INDEX FILE FOR GRIB FILE
1748 C - CONTAINING GLOBAL 1-DEGREE SEA-SURFACE TEMP FIELD
1749 C INGBD - UNIT NUMBER OF GRIB FILE CONTAINING GLOBAL 1-DEGREE
1750 C - SEA-SURFACE TEMP FIELD
1751 C IDAT1 - REQUESTED EARLIEST YEAR(YYYY), MONTH, DAY, HOUR, MIN
1752 C IDAT2 - REQUESTED LATEST YEAR(YYYY), MONTH, DAY, HOUR, MIN
1753 C
1754 C OUTPUT FILES:
1755 C UNIT 06 - PRINTOUT
1756 C
1757 C REMARKS: CALLED BY SUBROUTINE W3MISCAN.
1758 C
1759 C ATTRIBUTES:
1760 C LANGUAGE: FORTRAN 90
1761 C MACHINE: IBM-SP
1762 C
1763 C$$$
1764  SUBROUTINE misc06(INGBI,INGBD,IDAT1,IDAT2,*,*,*,*)
1765  parameter(maxpts=360*180)
1766  LOGICAL*1 LBMS(360,180)
1767  INTEGER KPDS(200),KGDS(200),LPDS(200),LGDS(200),IDAT1(5),
1768  $ idat2(5),jdat1(8),jdat2(8),kdat(8),ldat(8),mdate(8)
1769  REAL RINC(5)
1770  CHARACTER*11 ENVVAR
1771  CHARACTER*80 FILEB,FILEI
1772  common/misccc/sstdat(360,180)
1773 
1774  SAVE
1775 
1776  envvar='XLFUNIT_ '
1777  WRITE(envvar(9:10),fmt='(I2)') ingbd
1778  CALL getenv(envvar,fileb)
1779  envvar='XLFUNIT_ '
1780  WRITE(envvar(9:10),fmt='(I2)') ingbi
1781  CALL getenv(envvar,filei)
1782  CALL baopenr(ingbd,fileb,iret1)
1783 ccccc PRINT *,'SAGT: ',INGBD,FILEB,IRET1
1784  CALL baopenr(ingbi,filei,iret2)
1785 ccccc PRINT *,'SAGT: ',INGBI,FILEI,IRET2
1786 
1787  kpds = -1
1788  kgds = -1
1789  n = -1
1790  kpds(5) = 11
1791  kpds(6) = 1
1792  kpds(7) = 0
1793  kpds(8) = -1
1794  kpds(9) = -1
1795  kpds(10) = -1
1796  print 68, ingbd
1797  68 FORMAT(//4x,'** W3MISCAN/MISC06: READ IN "CURRENT" SEA-SURFACE ',
1798  $ 'TEMPERATURE DATA FROM GRIB MESSAGE IN UNIT',i3)
1799  CALL getgb(ingbd,ingbi,maxpts,0,kpds,kgds,kf,k,lpds,lgds,lbms,
1800  $ sstdat,iret)
1801 C.......................................................................
1802 C ABNORMAL RETURN IF PROBLEM WITH SST IN GRIB FILE
1803  IF(iret.NE.0) THEN
1804  WRITE(6,*)' ERROR READING SST USING GETGB. IRET = ',iret
1805  IF (iret.EQ.96) RETURN 1
1806  IF (iret.EQ.97) RETURN 3
1807  IF (iret.EQ.98) RETURN 3
1808  IF (iret.EQ.99) RETURN 3
1809  RETURN 4
1810  ENDIF
1811 C.......................................................................
1812 C READ SUCCESSFUL
1813  jdat1 = 0
1814  jdat2 = 0
1815  jdat1(1:3) = idat1(1:3)
1816  jdat1(5:6) = idat1(4:5)
1817  jdat2(1:3) = idat2(1:3)
1818  jdat2(5:6) = idat2(4:5)
1819  mdate = 0
1820  mdate(1) = ((lpds(21) - 1) * 100) + lpds(8)
1821  mdate(2:3) = lpds(9:10)
1822  mdate(5:6) = lpds(11:12)
1823  CALL w3movdat((/-7.,0.,0.,0.,0./),jdat1,kdat)
1824  CALL w3movdat((/ 7.,0.,0.,0.,0./),jdat2,ldat)
1825 cppppp
1826  print *, '** W3MISCAN/MISCO6: SST GRIB FILE MUST HAVE DATE ',
1827  $ 'BETWEEN ',(kdat(iii),iii=1,3),(kdat(iii),iii=5,6),' AND ',
1828  $ (ldat(iii),iii=1,3),(ldat(iii),iii=5,6)
1829  print *, ' RETURNED FROM GRIB FILE IS YEAR ',
1830  $ 'OF CENTURY = ',lpds(8),' AND CENTURY = ',lpds(21)
1831  print *, ' CALULATED 4-DIGIT YEAR IS = ',
1832  $ mdate(1)
1833 cppppp
1834  CALL w3difdat(kdat,mdate,3,rinc)
1835  kmin = rinc(3)
1836  CALL w3difdat(ldat,mdate,3,rinc)
1837  lmin = rinc(3)
1838  IF(kmin.GT.0.OR.lmin.LT.0) THEN
1839 C.......................................................................
1840 C COME HERE IF SST GRIB MSG HAS A DATE THAT IS EITHER: 1) MORE THAN 7-
1841 C DAYS PRIOR TO THE EARLIEST REQ. DATE (INPUT ARG. "IDAT1" TO W3MISCAN)
1842 C OR 2) MORE THAN 7-DAYS AFTER THE LATEST REQ. DATE (INPUT ARG.
1843 C "IDAT2" TO W3MISCAN)
1844  print 27, (mdate(iii),iii=1,3),(mdate(iii),iii=5,6)
1845  27 FORMAT(/' ##W3MISCAN/MISC06: SST GRIB MSG HAS DATE:',i5,4i3,
1846  $ ' - AS A RESULT......')
1847  RETURN 2
1848 C.......................................................................
1849  END IF
1850  print 60, (mdate(iii),iii=1,3),(mdate(iii),iii=5,6)
1851  60 FORMAT(/4x,'** W3MISCAN/MISC06: SEA-SFC TEMP SUCCESSFULLY READ ',
1852  $ 'IN FROM GRIB FILE, DATE IS: ',i5,4i3/)
1853  RETURN
1854 
1855  CALL baclose(ingbi,iret)
1856  CALL baclose(ingbd,iret)
1857 
1858  END
getgb
subroutine getgb(LUGB, LUGI, JF, J, JPDS, JGDS, KF, K, KPDS, KGDS, LB, F, IRET)
Find and unpack a grib message.
Definition: getgb.f:166
gbyte
subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
This is the fortran version of gbyte.
Definition: gbyte.f:27
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