C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: W3MISCAN READS 1 SSM/I SCAN LINE FROM BUFR D-SET C PRGMMR: KEYSER ORG: NP22 DATE: 2011-08-04 C C ABSTRACT: READS ONE SSM/I SCAN LINE (64 RETRIEVALS) FROM THE NCEP C BUFR SSM/I DUMP FILE. EACH SCAN IS TIME CHECKED AGAINST THE C USER-REQUESTED TIME WINDOW AND SATELLITE ID COMBINATIONS. WHEN A C VALID SCAN IS READ THE PROGRAM RETURNS TO THE CALLING PROGRAM. C THE USER MUST PASS IN THE TYPE OF THE INPUT SSM/I DUMP FILE, C EITHER DERIVED PRODUCTS (REGARDLESS OF SOURCE) OR BRIGHTNESS C TEMPERATURES (7-CHANNELS). IF THE LATTER IS CHOSEN, THE USER C HAS THE FURTHER OPTION OF PROCESSING, IN ADDITION TO THE C BRIGHTNESS TEMPERATURES, IN-LINE CALCULATION OF WIND SPEED C PRODUCT VIA THE GOODBERLET ALGORITHM, AND/OR IN-LINE CALCULATION C OF BOTH WIND SPEED AND TOTAL COLUMN PRECIPITABLE WATER (TPW) C PRODUCTS USING THE NEURAL NET 3 ALGORITHM. IF THE WIND SPEED C OR TPW IS CALCULATED HERE (EITHER ALGORITHM), THIS SUBROUTINE C WILL CHECK FOR BRIGHTNESS TEMPERATURES OUTSIDE OF A PRESET RANGE C AND WILL RETURN A MISSING WIND SPEED/TPW IF ANY B. TEMP IS C UNREASONABLE. ALSO, FOR CALCULATED WIND SPEEDS AND TPW, THIS C PROGRAM WILL CHECK TO SEE IF THE B. TEMPS ARE OVER LAND OR ICE, C AND IF THEY ARE IT WILL ALSO RETURN MISSING VALUES SINCE THESE C DATA ARE VALID ONLY OVER OCEAN. C C PROGRAM HISTORY LOG: C 1996-07-30 D. A. KEYSER -- ORIGINAL AUTHOR - SUBROUTINE IS A C MODIFIED VERSION OF W3LIB W3FI86 WHICH READ ONE SCAN C LINE FROM THE 30-ORBIT SHARED PROCESSING DATA SETS C 1997-05-22 D. A. KEYSER -- CRISIS FIX TO ACCOUNT FOR CLON NOW C RETURNED FROM BUFR AS -180 TO 0 (WEST) OR 0 TO 180 C (EAST), USED TO RETURN AS 0 TO 360 EAST WHICH WAS NOT C THE BUFR STANDARD C 1998-01-28 D. A. KEYSER -- REPLACED NEURAL NET 2 ALGORITHM WHICH C CALCULATED ONLY WIND SPEED PRODUCT WITH NEURAL NET 3 C ALGORITHM WHICH CALCULATES BOTH WIND SPEED AND TOTAL C PRECIPITABLE WATER PRODUCTS (AMONG OTHERS) BUT, UNLIKE C NN2, DOES NOT RETURN A RAIN FLAG VALUE (IT DOES SET C ALL RETRIEVALS TO MISSING THAT FAIL RAIN FLAG AND ICE C CONTAMINATION TESTS) C 1998-03-30 D. A. KEYSER -- MODIFIED TO HANDLE NEURAL NET 3 SSM/I C PRODUCTS INPUT IN A PRODUCTS BUFR DATA DUMP FILE; NOW C PRINTS OUT NUMBER OF SCANS PROCESSED BY SATELLITE C NUMBER IN FINAL SUMMARY C 1998-10-23 D. A. KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 C COMPLIANT C 1999-02-18 D. A. KEYSER -- MODIFIED TO COMPILE AND RUN PROPERLY C ON IBM-SP C 2000-06-08 D. A. KEYSER -- CORRECTED MNEMONIC FOR RAIN RATE TO C "REQV" (WAS "PRER" FOR SOME UNKNOWN REASON) C 2001-01-03 D. A. KEYSER -- CHANGED UNITS OF RETURNED RAIN RATE C FROM WHOLE MM/HR TO 10**6 MM/SEC, CHANGED UNITS OF C RETURNED SURFACE TEMP FROM WHOLE KELVIN TO 10**2 C KELVIN (TO INCR. PRECISION TO THAT ORIG. IN INPUT BUFR C FILE) C 2004-09-12 D. A. KEYSER -- NOW DECODES SEA-SURFACE TEMPERATURE IF C VALID INTO SAME LOCATION AS SURFACE TEMPERATURE, QUANTITY C IS SURFACE TEMPERATURE IF SURFACE TAG IS NOT 5, OTHERWISE C QUANTITY IS SEA-SURFACE TEMPERATURE (NCEP PRODUCTS DATA C DUMP FILE NOW CONTAINS SST); CHECKS TO SEE IF OLD OR NEW C VERSION OF MNEMONIC TABLE bufrtab.012 IS BEING USED HERE C (OLD VERSION HAD "PH2O" INSTEAD OF "TPWT", "SNDP" INSTEAD C OF "TOSD", "WSOS" INSTEAD OF "WSPD" AND "CH2O" INSTEAD OF C THE SEQUENCE "METFET VILWC METFET"), AND DECODES USING C WHICHEVER MNEMONICS ARE FOUND {NOTE: A FURTHER C REQUIREMENT FOR "VILWC" IS THAT THE FIRST "METFET" C (METEOROLOGICAL FEATURE) IN THE SEQUENCE MUST BE 12 C (=CLOUD), ELSE CLOUD WATER SET TO MISSING, REGARDLESS OF C "VILWC" VALUE} C 2011-08-04 D. A. KEYSER -- ADD IBDATE (INPUT BUFR MESSAGE DATE) TO C OUTPUT ARGUMENT LIST (NOW USED BY CALLING PROGRAM C PREPOBS_PREPSSMI) C C USAGE: CALL W3MISCAN(INDTA,INLSF,INGBI,INGBD,LSAT,LPROD,LBRIT, C $ NNALG,GBALG,KDATE,LDATE,IGNRTM,IBUFTN,IBDATE,IER) C INPUT ARGUMENT LIST: C INDTA - UNIT NUMBER OF NCEP BUFR SSM/I DUMP DATA SET C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE C - (VALID ONLY IF LBRIT AND EITHER NNALG OR GBALG TRUE) C INGBI - UNIT NUMBER OF GRIB INDEX FILE FOR GRIB FILE C - CONTAINING GLOBAL 1-DEGREE SEA-SURFACE TEMP FIELD C - (VALID ONLY IF LBRIT AND EITHER NNALG OR GBALG TRUE) C INGBD - UNIT NUMBER OF GRIB FILE CONTAINING GLOBAL 1-DEGREE C - SEA-SURFACE TEMP FIELD (VALID ONLY IF LBRIT AND EITHER C - NNALG OR GBALG TRUE) C LSAT - 10-WORD LOGICAL ARRAY (240:249) INDICATING WHICH C SATELLITE IDS SHOULD BE PROCESSED (SEE REMARKS) C LPROD - LOGICAL INDICATING IF THE INPUT BUFR FILE CONTAINS C - PRODUCTS (REGARDLESS OF SOURCE) - IN THIS CASE ONE OR C - MORE AVAILABLE PRODUCTS CAN BE PROCESSED AND RETURNED C LBRIT - LOGICAL INDICATING IF THE INPUT BUFR FILE CONTAINS C - BRIGHTNESS TEMPERATURES - IN THIS CASE B. TEMPS ARE C - PROCESSED AND RETURNED ALONG WITH, IF REQUESTED, IN- C - LINE GENERATED PRODUCTS FROM ONE OR BOTH ALGORITHMS C - (SEE NEXT TWO SWITCHES) C THE FOLLOWING TWO SWITCHES APPLY ONLY IF LBRIT IS TRUE ----- C NNALG - LOGICAL INDICATING IF THE SUBROUTINE SHOULD C - CALCULATE AND RETURN SSM/I WIND SPEED AND TPW C - VIA THE NEURAL NET 3 ALGORITHM (NOTE: B O T H C - WIND SPEED AND TPW ARE RETURNED HERE) C GBALG - LOGICAL INDICATING IF THE SUBROUTINE SHOULD C - CALCULATE AND RETURN SSM/I WIND SPEED VIA THE C - GOODBERLET ALGORITHM C C KDATE - REQUESTED EARLIEST YEAR(YYYY), MONTH, DAY, HOUR, C - MIN FOR ACCEPTING SCANS C LDATE - REQUESTED LATEST YEAR(YYYY), MONTH, DAY, HOUR, C - MIN FOR ACCEPTING SCANS C IGNRTM - SWITCH TO INDICATE WHETHER SCANS SHOULD BE TIME- C - CHECKED (= 0) OR NOT TIME CHECKED (=1) {IF =1, ALL C - SCANS READ IN ARE PROCESSED REGARDLESS OF THEIR TIME. C - THE INPUT ARGUMENTS "KDATE" AND "LDATE" (EARLIEST AND C - LATEST DATE FOR PROCESSING DATA) ARE IGNORED IN THE C - TIME CHECKING FOR SCANS. (NOTE: THE EARLIEST AND C - LATEST DATES SHOULD STILL BE SPECIFIED TO THE C - "EXPECTED" TIME RANGE, BUT THEY WILL NOT BE USED FOR C - TIME CHECKING IN THIS CASE)} C C OUTPUT ARGUMENT LIST: C IBUFTN - OUTPUT BUFFER HOLDING DATA FOR A SCAN (1737 WORDS - C - SEE REMARKS FOR FORMAT. SOME WORDS MAY BE MISSING C - DEPENDING UPON LPROD, LBRIT, NNALG AND GBALG C IBDATE - INPUT BUFR MESSAGE SECTION 1 DATE (YYYYMMDDHH) C IER - ERROR RETURN CODE (SEE REMARKS) C C INPUT FILES: C UNIT AA - (WHERE AA IS EQUAL TO INPUT ARGUMENT 'INDTA') NCEP C - BUFR SSM/I DUMP DATA SET HOLDING SCANS (SEE REMARKS C - REGARDING ASSIGN) C UNIT BB - (WHERE BB IS EQUAL TO INPUT ARGUMENT 'INLSF') C - DIRECT ACCESS NESDIS LAND/SEA FILE (SEE REMARKS C - REGARDING ASSIGN) (VALID ONLY IF LBRIT AND EITHER C - NNALG OR GBALG TRUE) C UNIT CC - (WHERE CC IS EQUAL TO INPUT ARGUMENT 'INGBI') GRIB C - INDEX FILE FOR GRIB FILE CONTAINING GLOBAL 1-DEGREE C - SEA-SURFACE TEMPERATURE FIELD (SEE REMARKS C - REGARDING CREATION AND ASSIGN) (VALID ONLY IF LBRIT C - AND EITHER NNALG OR GBALG TRUE) C UNIT DD - (WHERE DD IS EQUAL TO INPUT ARGUMENT 'INGBD') C - UNBLOCKED GRIB FILE CONTAINING GLOBAL 1-DEGREE SEA- C - SURFACE TEMPERATURE FIELD (SEE REMARKS REGARDING C - ASSIGN) (VALID ONLY IF LBRIT AND EITHER NNALG OR C - GBALG TRUE) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C SUBPROGRAMS CALLED: C UNIQUE: - MISC01 RISC02 RISC03 MISC04 MISC05 C - MISC06 MISC10 C LIBRARY: C IBM - GETENV C BALIB: - BAOPER BACLOSE C W3LIB: - W3FI04 W3MOVDAT W3DIFDAT GBYTE GETGB C BUFRLIB: - DATELEN DUMPBF OPENBF READMG READSB C - UFBINT UFBREP C C REMARKS: RETURN CODE IER CAN HAVE THE FOLLOWING VALUES: C IER = 0 SUCCESSFUL RETURN OF SCAN C IER = 1 ALL SCANS HAVE BEEN READ, ALL DONE C IER = 2 ABNORMAL RETURN - INPUT BUFR FILE IN UNIT C 'INDTA' IS EITHER EMPTY (NULL) OR IS NOT BUFR C IER = 3 ABNORMAL RETURN - REQUESTED EARLIEST AND C LATEST DATES ARE BACKWARDS C IER = 4 ABNORMAL RETURN - ERROR OPENING RANDOM C ACCESS FILE HOLDING LAND/SEA TAGS C IER = 5 ABNORMAL RETURN - THE NUMBER OF DECODED C "LEVELS" IS NOT WHAT IS EXPECTED C IER = 6 ABNORMAL RETURN - SEA-SURFACE TEMPERATURE C NOT FOUND IN GRIB INDEX FILE - ERROR RETURNED C FROM GRIB DECODER GETGB IS 96 C IER = 7 ABNORMAL RETURN - SEA-SURFACE TEMPERATURE C GRIB MESSAGE HAS A DATE THAT IS EITHER: C 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST C REQUESTED DATE OR 2) MORE THAN 7-DAYS AFTER C THE LATEST REQUESTED DATE C IER = 8 ABNORMAL RETURN - BYTE-ADDRESSABLE READ ERROR C FOR GRIB FILE CONTAINING SEA-SURFACE C TEMPERATURE FIELD - ERROR RETURNED FROM GRIB C DECODER GETGB IS 97-99 C IER = 9 ABNORMAL RETURN - ERROR RETURNED FROM GRIB C DECODER - GETGB - FOR SEA-SURFACE C TEMPERATURE FIELD - > 0 BUT NOT 96-99 CC C INPUT ARGUMENT LSAT IS SET-UP AS FOLLOWS: C C LSAT(X) = TRUE -- PROCESS SCANS FROM SATELLITE ID X (WHERE X C IS CODE FIGURE FROM BUFR CODE TABLE 0-01-007) C LSAT(X) = FALSE - DO NOT PROCESS SCANS FROM SATELLITE ID X C C X = 240 IS F-7 DMSP SATELLITE (THIS SATELLITE IS C NO LONGER AVAILABLE) C X = 241 IS F-8 DMSP SATELLITE (THIS SATELLITE IS C NO LONGER AVAILABLE) C X = 242 IS F-9 DMSP SATELLITE (THIS SATELLITE IS C NO LONGER AVAILABLE) C X = 243 IS F-10 DMSP SATELLITE (THIS SATELLITE IS C NO LONGER AVAILABLE) C X = 244 IS F-11 DMSP SATELLITE (THIS IS AVAILABLE C AS OF 8/96 BUT IS NOT CONSIDERED TO BE AN C OPERATIONAL DMSP SSM/I SATELLITE) C X = 245 IS F-12 DMSP SATELLITE (THIS SATELLITE IS C NO LONGER AVAILABLE) C X = 246 IS F-13 DMSP SATELLITE (THIS IS AVAILABLE C AND IS CONSIDERED TO BE AN OPERATIONAL C ODD DMSP SSM/I SATELLITE AS OF 8/1996) C X = 247 IS F-14 DMSP SATELLITE (THIS IS AVAILABLE C AS OF 5/97 BUT IS NOT CONSIDERED TO BE AN C OPERATIONAL DMSP SSM/I SATELLITE) C X = 248 IS F-15 DMSP SATELLITE (THIS IS AVAILABLE C AS OF 2/2000 AND IS CONSIDERED TO BE AN C OPERATIONAL ODD DMSP SSM/I SATELLITE AS OF C 2/2000) C X = 249 IS RESERVED FOR A FUTURE DMSP SATELLITE C C NOTE: HERE "EVEN" MEANS VALUE IN IBUFTN(1) IS AN ODD NUMBER C WHILE "ODD" MEANS VALUE IN IBUFTN(1) IS AN EVEN NUMBER CC C C CONTENTS OF ARRAY 'IBUFTN' HOLDING ONE COMPLETE SCAN (64 INDIVIDUAL C RETRIEVLAS (1737 WORDS) C C =====> ALWAYS RETURNED: C C WORD CONTENTS C ---- -------- C 1 SATELLITE ID (244 IS F-11; 246 IS F-13; 247 IS F-14; C 248 IS F-15) C 2 4-DIGIT YEAR FOR SCAN C 3 2-DIGIT MONTH OF YEAR FOR SCAN C 4 2-DIGIT DAY OF MONTH FOR SCAN C 5 2-DIGIT HOUR OF DAY FOR SCAN C 6 2-DIGIT MINUTE OF HOUR FOR SCAN C 7 2-DIGIT SECOND OF MINUTE FOR SCAN C 8 SCAN NUMBER IN ORBIT C 9 ORBIT NUMBER FOR SCAN C C 10 RETRIEVAL #1 LATITUDE (*100 DEGREES: + N, - S) C 11 RETRIEVAL #1 LONGITUDE (*100 DEGREES EAST) C 12 RETRIEVAL #1 POSITION NUMBER C 13 RETRIEVAL #1 SURFACE TAG (CODE FIGURE) C C =====> FOR LPROD = TRUE {INPUT PRODUCTS FILE: NOTE ALL PRODUCTS C BELOW EXCEPT SEA-SURFACE TEMPERATURE ARE AVAILABLE IN THE C FNOC "OPERATIONAL" PRODUCTS DATA DUMP; MOST NCEP PRODUCTS C DATA DUMPS CONTAIN ONLY WIND SPEED, TOTAL PRECIPITABLE C WATER, CLOUD WATER AND SEA-SURFACE TEMPERATURE (ALL OVER C OCEAN ONLY)}: C C 14 RETRIEVAL #1 CLOUD WATER (*100 KILOGRAM/METER**2) C 15 RETRIEVAL #1 RAIN RATE (*1000000 MILLIMETERS/SECOND) C 16 RETRIEVAL #1 WIND SPEED (*10 METERS/SECOND) C 17 RETRIEVAL #1 SOIL MOISTURE (MILLIMETERS) C 18 RETRIEVAL #1 SEA-ICE CONCENTRATION (PER CENT) C 19 RETRIEVAL #1 SEA-ICE AGE (CODE FIGURE) C 20 RETRIEVAL #1 ICE EDGE (CODE FIGURE) C 21 RETRIEVAL #1 TOTAL PRECIP. WATER (*10 MILLIMETERS) C 22 RETRIEVAL #1 SURFACE TEMP (*100 K) IF NOT OVER OCEAN C -- OR -- C 22 RETRIEVAL #1 SEA-SURFACE TEMP (*100 K) IF OVER OCEAN C 23 RETRIEVAL #1 SNOW DEPTH (MILLIMETERS) C 24 RETRIEVAL #1 RAIN FLAG (CODE FIGURE) C 25 RETRIEVAL #1 CALCULATED SURFACE TYPE (CODE FIGURE) C C =====> FOR LBRIT = TRUE (INPUT BRIGHTNESS TEMPERATURE FILE): C C 26 RETRIEVAL #1 19 GHZ V BRIGHTNESS TEMP (*100 DEG. K) C 27 RETRIEVAL #1 19 GHZ H BRIGHTNESS TEMP (*100 DEG. K) C 28 RETRIEVAL #1 22 GHZ V BRIGHTNESS TEMP (*100 DEG. K) C 29 RETRIEVAL #1 37 GHZ V BRIGHTNESS TEMP (*100 DEG. K) C 30 RETRIEVAL #1 37 GHZ H BRIGHTNESS TEMP (*100 DEG. K) C 31 RETRIEVAL #1 85 GHZ V BRIGHTNESS TEMP (*100 DEG. K) C 32 RETRIEVAL #1 85 GHZ H BRIGHTNESS TEMP (*100 DEG. K) C C =====> FOR LBRIT = TRUE AND NNALG = TRUE (INPUT BRIGHTNESS C TEMPERATURE FILE): C C 33 RETRIEVAL #1 NEURAL NET 3 ALGORITHM WIND SPEED C (GENERATED IN-LINE) (*10 METERS/SECOND) C 34 RETRIEVAL #1 NEURAL NET 3 ALGORITHM TOTAL PRECIP. C WATER (GENERATED IN-LINE) (*10 MILLIMETERS) C C =====> FOR LBRIT = TRUE AND GBALG = TRUE (INPUT BRIGHTNESS C TEMPERATURE FILE): C C 35 RETRIEVAL #1 GOODBERLET ALGORITHM WIND SPEED C (GENERATED IN-LINE) (*10 METERS/SECOND) C 36 RETRIEVAL #1 GOODBERLET ALGORITHM RAIN FLAG C (CODE FIGURE) C C 37-1737 REPEAT 10-36 FOR 63 MORE RETRIEVALS C C (NOTE: ALL MISSING DATA OR DATA NOT SELECTED BY C CALLING PROGRAM ARE SET TO 99999) C C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ SUBROUTINE W3MISCAN(INDTA,INLSF,INGBI,INGBD,LSAT,LPROD,LBRIT, $ NNALG,GBALG,KDATE,LDATE,IGNRTM,IBUFTN,IBDATE,IER) LOGICAL LPROD,LBRIT,NNALG,GBALG,LSAT(240:249) CHARACTER*1 CDUMMY CHARACTER*2 ATXT(2) CHARACTER*8 SUBSET CHARACTER*20 RHDER,PROD2,BRITE CHARACTER*46 SHDER,PROD1 REAL SHDR(9),RHDR(4,64),PROD(13,64),BRIT(2,448),RINC(5), $ METFET(64) REAL(8) SHDR_8(9),RHDR_8(4,64),PROD_8(13,64),BRIT_8(2,448), $ UFBINT_8(64) INTEGER IBUFTN(1737),KDATA(7),KDATE(5),LDATE(5),LBTER(7), $ KSPSAT(239:249),KNTSAT(239:249),IFLAG(64),KDAT(8),LDAT(8), $ MDAT(8),ICDATE(5),IDDATE(5) COMMON/MISCCC/SSTDAT(360,180) COMMON/MISCEE/LFLAG,LICEC SAVE DATA SHDER /'SAID YEAR MNTH DAYS HOUR MINU SECO SCNN ORBN '/ DATA RHDER /'CLAT CLON POSN SFTG '/ DATA PROD1 /'VILWC REQV WSPD SMOI ICON ICAG ICED TPWT TMSK '/ DATA PROD2 /'TOSD RFLG SFTP SST1 '/ DATA BRITE /'CHNM TMBR '/ DATA ATXT /'NN','GB'/ DATA IMSG /99999/,KNTSCN/0/,KNTTIM/0/,LAERR/0/, $ LOERR/0/,LBTER/7*0/,ITIMES/0/,NLR/0/,NIR/0/,DMAX/-99999./, $ DMIN/99999./,KSPSAT/11*0/,KNTSAT/11*0/,ILFLG/0/,BMISS/10.0E10/ IF(ITIMES.EQ.0) THEN C*********************************************************************** C FIRST CALL INTO SUBROUTINE DO A FEW THINGS ..... ITIMES = 1 LFLAG = 0 LICEC = 0 PRINT 65, INDTA 65 FORMAT(//' ---> W3MISCAN: Y2K/F90 VERSION 08/04/2011: ', $ 'PROCESSING SSM/I DATA FROM BUFR DATA SET READ FROM UNIT ', $ I4/) IF(LPROD) PRINT 66 66 FORMAT(//' ===> WILL READ FROM BUFR PRODUCTS DATA DUMP ', $ 'FILE (EITHER FNOC OR NCEP) AND PROCESS ONE OR MORE SSM/I ', $ 'PRODUCTS'//) IF(LBRIT) THEN PRINT 167 167 FORMAT(//' ===> WILL READ FROM BUFR BRIGHTNESS ', $ 'TEMPERATURE DATA DUMP FILE AND PROCESS BRIGHTNESS ', $ 'TEMPERATURES'//) IF(NNALG) PRINT 169 169 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ', $ 'CALCULATION OF NEURAL NETWORK 3 WIND SPEED AND TOTAL ', $ 'PRECIPITABLE WATER AND PROCESS THESE'/) IF(GBALG) PRINT 170 170 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ', $ 'CALCULATION OF GOODBERLET WIND SPEED AND PROCESS THESE'/) END IF IF(IGNRTM.EQ.1) PRINT 704 704 FORMAT(' W3MISCAN: INPUT ARGUMENT "IGNRTM" IS SET TO 1 -- NO ', $ 'TIME CHECKS WILL BE PERFORMED ON SCANS - ALL SCANS READ IN ', $ 'ARE PROCESSED'/) PRINT 104, KDATE,LDATE 104 FORMAT(' W3MISCAN: REQUESTED EARLIEST DATE:',I7,4I5/ $ ' REQUESTED LATEST DATE:',I7,4I5) KDAT = 0 KDAT(1:3) = KDATE(1:3) KDAT(5:6) = KDATE(4:5) LDAT = 0 LDAT(1:3) = LDATE(1:3) LDAT(5:6) = LDATE(4:5) C DO REQUESTED EARLIEST AND LATEST DATES MAKE SENSE? CALL W3DIFDAT(LDAT,KDAT,3,RINC) IF(RINC(3).LT.0) THEN C....................................................................... PRINT 103 103 FORMAT(' ##W3MISCAN: REQUESTED EARLIEST AND LATEST DATES ', $ 'ARE BACKWARDS!! - IER = 3'/) IER = 3 RETURN C....................................................................... END IF C DETERMINE MACHINE WORD LENGTH IN BYTES AND TYPE OF CHARACTER SET C {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)} CALL W3FI04(IENDN,ICHTP,LW) PRINT 2213, LW, ICHTP, IENDN 2213 FORMAT(/' ---> W3MISCAN: CALL TO W3FI04 RETURNS: LW = ',I3, $ ', ICHTP = ',I3,', IENDN = ',I3/) CALL DATELEN(10) CALL DUMPBF(INDTA,ICDATE,IDDATE) cppppp print *,'CENTER DATE (ICDATE) = ',icdate print *,'DUMP DATE (IDDATE) = ',iddate cppppp C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE C - RETURN WITH IRET = 2 IF(ICDATE(1).LE.0) GO TO 998 C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE C - RETURN WITH IRET = 2 IF(IDDATE(1).LE.0) GO TO 998 IF(ICDATE(1).LT.100) THEN C IF 2-DIGIT YEAR RETURNED IN ICDATE(1), MUST USE "WINDOWING" TECHNIQUE C TO CREATE A 4-DIGIT YEAR C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) PRINT *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ', $ 'HAPPEN!!!!!' PRINT *, '##W3MISCAN - 2-DIGIT YEAR IN ICDATE(1) RETURNED ', $ 'FROM DUMPBF (ICDATE IS: ',ICDATE,') - USE WINDOWING ', $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR' IF(ICDATE(1).GT.20) THEN ICDATE(1) = 1900 + ICDATE(1) ELSE ICDATE(1) = 2000 + ICDATE(1) ENDIF PRINT *, '##W3MISCAN - CORRECTED ICDATE(1) WITH 4-DIGIT ', $ 'YEAR, ICDATE NOW IS: ',ICDATE ENDIF IF(IDDATE(1).LT.100) THEN C IF 2-DIGIT YEAR RETURNED IN IDDATE(1), MUST USE "WINDOWING" TECHNIQUE C TO CREATE A 4-DIGIT YEAR C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) PRINT *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ', $ 'HAPPEN!!!!!' PRINT *, '##W3MISCAN - 2-DIGIT YEAR IN IDDATE(1) RETURNED ', $ 'FROM DUMPBF (IDDATE IS: ',IDDATE,') - USE WINDOWING ', $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR' IF(IDDATE(1).GT.20) THEN IDDATE(1) = 1900 + IDDATE(1) ELSE IDDATE(1) = 2000 + IDDATE(1) ENDIF PRINT *, '##W3MISCAN - CORRECTED IDDATE(1) WITH 4-DIGIT ', $ 'YEAR, IDDATE NOW IS: ',IDDATE END IF C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES) CALL OPENBF(INDTA,'IN',INDTA) print *, ' ' print *, 'OPEN NCEP BUFR SSM/I DUMP FILE' print *, ' ' C Check to see if the old (pre 9/2004) version of the mnemonic C table is being used here (had "PH2O" instead of "TPWT", C "SNDP" instead of "TOSD", "WSOS" instead of "WSPD") C ------------------------------------------------------------ CALL STATUS(INDTA,LUN,IDUMMY1,IDUMMY2) CALL NEMTAB(LUN,'PH2O',IDUMMY1,CDUMMY,IRET_PH2O) CALL NEMTAB(LUN,'SNDP',IDUMMY1,CDUMMY,IRET_SNDP) CALL NEMTAB(LUN,'WSOS',IDUMMY1,CDUMMY,IRET_WSOS) CALL NEMTAB(LUN,'CH2O',IDUMMY1,CDUMMY,IRET_CH2O) IF(LBRIT.AND.(NNALG.OR.GBALG)) THEN C----------------------------------------------------------------------- C IF IN-LINE CALC. OF WIND SPEED FROM GOODBERLET ALG. OR C IN-LINE CALCULATION OF WIND SPEED AND TPW FROM NEURAL NET 3 ALG. C FIRST CALL TO THIS SUBROUTINE WILL READ IN SEA-SURFACE TEMPERATURE C FIELD AS A CHECK FOR ICE LIMITS C WILL ALSO OPEN DIRECT ACCESS NESDIS LAND SEA FILE C----------------------------------------------------------------------- CALL MISC06(INGBI,INGBD,KDATE,LDATE,*993,*994,*995,*996) PRINT 67, INLSF 67 FORMAT(//4X,'** W3MISCAN: OPEN R. ACCESS NESDIS LAND/SEA ', $ 'FILE IN UNIT ',I2/) OPEN(UNIT=INLSF,ERR=997,ACCESS='DIRECT',IOSTAT=IERR,RECL=10980) END IF C READ THE FIRST BUFR MESSAGE IN THE BUFR FILE CALL READMG(INDTA,SUBSET,IBDATE,IRET) print *, 'READ FIRST BUFR MESSAGE: SUBSET = ',SUBSET, $ '; IBDATE = ',IBDATE,'; IRET = ',IRET IF(IRET.NE.0) GO TO 998 C*********************************************************************** END IF 30 CONTINUE C TIME TO DECODE NEXT SUBSET (SCAN) OUT OF BUFR MESSAGE IBUFTN = IMSG CALL READSB(INDTA,IRET) IF(IRET.NE.0) THEN C ALL SUBSETS OUT OF THIS MESSAGE READ, TIME TO MOVE ON TO NEXT MESSAGE CALL READMG(INDTA,SUBSET,IBDATE,IRET) print *, 'READ NEXT BUFR MESSAGE: SUBSET = ',SUBSET, $ '; IBDATE = ',IBDATE,'; IRET = ',IRET IF(IRET.NE.0) THEN c....................................................................... C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ C - ALL FINISHED, NO OTHER SCANS W/I DESIRED TIME RANGE -- SET IER TO 1 C AND RETURN TO CALLING PROGRAM PRINT 124, KNTSCN 124 FORMAT(/' W3MISCAN: +++++ ALL VALID SCANS UNPACKED AND ', $ 'RETURNED FROM THIS NCEP BUFR SSM/I DUMP FILE'//34X, $ '** W3MISCAN: SUMMARY **'//35X,'TOTAL NUMBER OF SCANS ', $ 'PROCESSED AND RETURNED',11X,I7) DO JJ = 239,249 IF(KNTSAT(JJ).GT.0) THEN PRINT 294, JJ,KNTSAT(JJ) 294 FORMAT(35X,'......NO. OF SCANS PROCESSED AND ', $ 'RETURNED FROM SAT',I4,':',I7) END IF END DO DO JJ = 239,249 IF(KSPSAT(JJ).GT.0) THEN II = JJ IF(JJ.EQ.239) II = 1 PRINT 224, II,KSPSAT(JJ) 224 FORMAT(35X,'NO. OF SCANS SKIPPED DUE TO BEING FROM ', $ 'NON-REQ SAT',I4,':',I7) END IF END DO PRINT 194, KNTTIM 194 FORMAT(35X,'NUMBER OF SCANS SKIPPED DUE TO BEING OUTSIDE ', $ 'TIME INT.:',I7) PRINT 324, LAERR,LOERR 324 FORMAT( $/35X,'NUMBER OF RETRIEVALS WITH LATITUDE OUT OF RANGE: ',I7/ $ 35X,'NUMBER OF RETRIEVALS WITH LONGITUDE OUT OF RANGE: ',I7) IF(LBRIT) THEN IF(NNALG.OR.GBALG) PRINT 780, LBTER,NLR,NIR 780 FORMAT( $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ V BRIGHT. TEMP:',I7/ $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ H BRIGHT. TEMP:',I7/ $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 22 GHZ V BRIGHT. TEMP:',I7/ $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ V BRIGHT. TEMP:',I7/ $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ H BRIGHT. TEMP:',I7/ $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ V BRIGHT. TEMP:',I7/ $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ H BRIGHT. TEMP:',I7/ $ 35X,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER LAND: ',I7/ $ 35X,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER ICE: ',I7) IF(NNALG) PRINT 781, LFLAG,LICEC 781 FORMAT( $ 35X,'NUMBER OF NN3 RETR. REJECTED DUE TO FAILING RAIN FLAG: ',I7/ $ 35X,'NUMBER OF NN3 RETR. REJECTED DUE TO ICE CONTAMINATION: ',I7) IF(NNALG.OR.GBALG) PRINT 782, DMAX,DMIN 782 FORMAT(/' ** FOR SEA-SFC TEMP AT ALL RETRIEVAL LOCATIONS: FIELD', $ ' MAX =',F8.3,' DEG K, FIELD MIN =',F8.3,' DEG K'/) END IF IER = 1 RETURN C....................................................................... END IF GO TO 30 END IF C*********************************************************************** C COME HERE FOR BOTH PRODUCTS AND BRIGHTNESS TEMPERATURES C*********************************************************************** SHDR = BMISS CALL UFBINT(INDTA,SHDR_8,09,1,NLEV,SHDER) ; SHDR = SHDR_8 ILFLG = 1 IF(NLEV.NE.1) GO TO 999 C STORE THE SCAN'S SATELLITE ID IN WORD 1 C STORE SCAN'S YEAR (YYYY), MONTH, DAY, HOUR, MIN, SEC INTO WORDS 2-7 C STORE THE SCAN NUMBER IN WORD 8 C STORE THE SCAN'S ORBIT NUMBER IN WORD 9 IBUFTN(1:9) = MIN(IMSG,NINT(SHDR(1:9))) C CHECK TO SEE IF SCAN IS FROM REQUESTED SATELLITE ID IF(IBUFTN(1).LT.240.OR.IBUFTN(1).GT.249) THEN PRINT 523, (IBUFTN(II),II=1,9) KSPSAT(239) = KSPSAT(239) + 1 GO TO 30 END IF IF(.NOT.LSAT(IBUFTN(1))) THEN CDAK PRINT 523, (IBUFTN(II),II=1,9) 523 FORMAT(' ##W3MISCAN: SCAN NOT FROM REQ. SAT. ID -SAT. ID',I4, $ ', SCAN TIME:',6I4,', SCAN',I6,', ORBIT',I8,'-GO TO NEXT SCAN') KSPSAT(IBUFTN(1)) = KSPSAT(IBUFTN(1)) + 1 GO TO 30 END IF IF(IGNRTM.EQ.0) THEN C TIME CHECK THIS SCAN IF USER REQUESTS SUCH MDAT = 0 MDAT(1:3) = IBUFTN(2:4) MDAT(5:7) = IBUFTN(5:7) CALL W3DIFDAT(KDAT,MDAT,4,RINC) KSEC = RINC(4) CALL W3DIFDAT(LDAT,MDAT,4,RINC) LSEC = RINC(4) IF(KSEC.GT.0.OR.LSEC.LT.0) THEN C TIME CHECK FOR SCAN FAILED: GO ON TO NEXT SCAN CDAK PRINT 123, (IBUFTN(II),II=2,9) 123 FORMAT(' ##W3MISCAN: SCAN NOT IN REQUESTED TIME WINDOW-', $ 'SCAN TIME:',6I5,' SCAN',I6,', ORBIT',I8,' - GO TO NEXT SCAN') KNTTIM = KNTTIM + 1 GO TO 30 END IF END IF RHDR = BMISS CALL UFBINT(INDTA,RHDR_8,04,64,NLEV,RHDER) ; RHDR = RHDR_8 ILFLG = 2 IF(NLEV.NE.64) GO TO 999 IFLAG = 0 DO IRT = 1,64 C THIS ROUTINE EXPECTS LONGITUDE TO BE 0-360 E; BUFR NOW RETURNS -180-0 C FOR WEST AND 0-180 FOR EAST IF(RHDR(2,IRT).LT.0.0) RHDR(2,IRT) = RHDR(2,IRT) + 360. C----------------------------------------------------------------------- C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN C----------------------------------------------------------------------- C STORE THE LATITUDE (*100 DEGREES; + : NORTH, - : SOUTH) IF(NINT(RHDR(1,IRT)*100.).GE.-9000.AND.NINT(RHDR(1,IRT)*100.) $ .LE.9000) THEN IBUFTN((27*IRT)-17) = NINT(RHDR(1,IRT)*100.) ELSE C....................................................................... C BAD LATITUDE LAERR = LAERR + 1 PRINT 777, IRT,IBUFTN(8),IBUFTN(9),NINT(RHDR(1,IRT)*100.) 777 FORMAT(' ##W3MISCAN: BAD LAT: RETR.',I3,', SCAN',I6, $ ', ORBIT',I8,'; INPUT LAT=',I7,' - ALL DATA IN THIS ', $ 'RETRIEVAL SET TO MISSING') IFLAG(IRT) = 1 C....................................................................... END IF C STORE THE LONGITUDE (*100 DEGREES EAST) IF(NINT(RHDR(2,IRT)*100.).GE.0.AND.NINT(RHDR(2,IRT)*100.).LE. $ 36000) THEN IF(IFLAG(IRT).EQ.0) $ IBUFTN((27*IRT)-16) = NINT(RHDR(2,IRT)*100.) ELSE C....................................................................... C BAD LONGITUDE LOERR = LOERR + 1 PRINT 778, IRT,IBUFTN(8),IBUFTN(9),NINT(RHDR(2,IRT)*100.) 778 FORMAT(' ##W3MISCAN: BAD LON: RETR.',I3,', SCAN',I6, $ ', ORBIT',I8,'; INPUT LON=',I7,' - ALL DATA IN THIS ', $ 'RETRIEVAL SET TO MISSING') IFLAG(IRT) = 1 C....................................................................... END IF IF(IFLAG(IRT).NE.0) GO TO 110 C STORE THE POSITION NUMBER IBUFTN((27*IRT)-15) = MIN(IMSG,NINT(RHDR(3,IRT))) C STORE THE SURFACE TAG (0-6) IBUFTN((27*IRT)-14) = MIN(IMSG,NINT(RHDR(4,IRT))) 110 CONTINUE C----------------------------------------------------------------------- END DO IF(LPROD) THEN C*********************************************************************** C COME HERE TO PROCESS PRODUCTS FROM INPUT SSM/I PRODUCTS FILE C*********************************************************************** PROD = BMISS CALL UFBINT(INDTA,PROD_8,13,64,NLEV,PROD1//PROD2) UFBINT_8 = BMISS IF(IRET_PH2O.GT.0) THEN ! Prior to 9/2004 CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'PH2O') PROD_8(8,:) = UFBINT_8(:) END IF UFBINT_8 = BMISS IF(IRET_SNDP.GT.0) THEN ! Prior to 9/2004 CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'SNDP') PROD_8(10,:) = UFBINT_8(:) END IF UFBINT_8 = BMISS IF(IRET_WSOS.GT.0) THEN ! Prior to 9/2004 CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'WSOS') PROD_8(3,:) = UFBINT_8(:) END IF UFBINT_8 = BMISS IF(IRET_CH2O.GT.0) THEN ! Prior to 9/2004 CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'CH2O') PROD_8(1,:) = UFBINT_8(:) ELSE CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'METFET') METFET = UFBINT_8 DO IRT = 1,64 IF(NINT(METFET(IRT)).NE.12) PROD_8(1,IRT) = BMISS END DO END IF PROD=PROD_8 ILFLG = 3 IF(NLEV.EQ.0) THEN PRINT 797, IBUFTN(8),IBUFTN(9) 797 FORMAT(' ##W3MISCAN: PRODUCTS REQ. BUT SCAN',I6,', ORBIT', $ I8,' DOES NOT CONTAIN PRODUCT DATA - CONTINUE PROCESSING ', $ 'SCAN (B.TEMPS REQ.?)') GO TO 900 ELSE IF(NLEV.NE.64) THEN GO TO 999 END IF DO IRT = 1,64 C----------------------------------------------------------------------- C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN C----------------------------------------------------------------------- IF(IFLAG(IRT).NE.0) GO TO 111 C STORE THE CLOUD WATER (*100 KG/M**2) IF AVAILABLE IF(NINT(PROD(01,IRT)).LT.IMSG) $ IBUFTN((27*IRT)-13) = NINT(PROD(01,IRT)*100.) C STORE THE RAIN RATE (*1000000 KG/((M**2)*SEC)) IF AVAILABLE C (THIS IS ALSO RAIN RATE (*1000000 MM/SEC)) IF(NINT(PROD(02,IRT)).LT.IMSG) $ IBUFTN((27*IRT)-12) = NINT(PROD(02,IRT)*1000000.) C STORE THE WIND SPEED (*10 M/SEC) IF AVAILABLE IBUFTN((27*IRT)-11) = MIN(IMSG,NINT(PROD(03,IRT)*10.)) C STORE THE SOIL MOISTURE (MM) IF AVAILABLE IF(NINT(PROD(04,IRT)).LT.IMSG) $ IBUFTN((27*IRT)-10) = NINT(PROD(04,IRT)*1000.) C STORE THE SEA ICE CONCENTRATION (PERCENT) IF AVAILABLE IBUFTN((27*IRT)-09) = MIN(IMSG,NINT(PROD(05,IRT))) C STORE THE SEA ICE AGE (0,1) IF AVAILABLE IBUFTN((27*IRT)-08) = MIN(IMSG,NINT(PROD(06,IRT))) C STORE THE ICE EDGE (0,1) IF AVAILABLE IBUFTN((27*IRT)-07) = MIN(IMSG,NINT(PROD(07,IRT))) C STORE THE WATER VAPOR (*10 KG/M**2) IF AVAILABLE C (THIS IS ALSO TOTAL PRECIPITABLE WATER SCALED AS *10 MM) IBUFTN((27*IRT)-06) = MIN(IMSG,NINT(PROD(08,IRT)*10.)) IF(IBUFTN((27*IRT)-14).NE.5) THEN C STORE THE SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE C (NOTE: SURFACE TAG MUST NOT BE 5) IBUFTN((27*IRT)-05) = MIN(IMSG,NINT(PROD(09,IRT)*100.)) ELSE C STORE THE SEA-SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE C (NOTE: SURFACE TAG MUST BE 5) IBUFTN((27*IRT)-05) = MIN(IMSG,NINT(PROD(13,IRT)*100.)) END IF C STORE THE SNOW DEPTH (MM) IF AVAILABLE IF(NINT(PROD(10,IRT)).LT.IMSG) $ IBUFTN((27*IRT)-04) = NINT(PROD(10,IRT)*1000.) C STORE THE RAIN FLAG (0-3) IF AVAILABLE IBUFTN((27*IRT)-03) = MIN(IMSG,NINT(PROD(11,IRT))) C STORE THE CALCULATED SURFACE TYPE (1-20) IF AVAILABLE IBUFTN((27*IRT)-02) = MIN(IMSG,NINT(PROD(12,IRT))) 111 CONTINUE C----------------------------------------------------------------------- END DO END IF 900 CONTINUE IF(LBRIT) THEN C*********************************************************************** C COME HERE TO PROCESS BRIGHTNESS TEMPERATURES FROM INPUT SSM/I C BRIGHTNESS TEMPERATURE FILE C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG. C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA N. NET 3 ALG. C*********************************************************************** BRIT = BMISS CALL UFBREP(INDTA,BRIT_8,2,448,NLEV,BRITE) ; BRIT = BRIT_8 ILFLG = 4 IF(NLEV.EQ.0) THEN PRINT 798, IBUFTN(8),IBUFTN(9) 798 FORMAT(' ##W3MISCAN: B. TEMPS REQ. BUT SCAN',I6,', ORBIT', $ I8,' DOES NOT CONTAIN B. TEMP DATA - DONE PROCESSING THIS', $ ' SCAN') GO TO 901 ELSE IF(NLEV.NE.448) THEN GO TO 999 END IF DO IRT = 1,64 C----------------------------------------------------------------------- C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN C----------------------------------------------------------------------- IF(IFLAG(IRT).NE.0) GO TO 112 C STORE THE 7 BRIGHTNESS TEMPS (*100 DEGREES KELVIN) C -- CHANNELS ARE IN THIS ORDER FOR A PARTICULAR RETRIEVAL: C 19 GHZ V, 19 GHZ H, 22 GHZ V, 37 GHZ V, 37 GHZ H, 85 GHZ V, 85 GHZ H IGOOD = 0 MINDX = (IRT * 7) - 6 DO LCH = MINDX,MINDX+6 ICHNN = NINT(BRIT(1,LCH)) IF(ICHNN.GT.7) GO TO 79 IF(NINT(BRIT(2,LCH)).LT.IMSG) THEN IBUFTN((27*IRT)-02+ICHNN) = NINT(BRIT(2,LCH)*100.) IGOOD = 1 END IF 79 CONTINUE END DO IF(NNALG.OR.GBALG) THEN KDATA = IMSG IF(IGOOD.EQ.1) THEN C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C COME HERE FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG. AND/OR C FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA NEURAL NET 3 ALG. C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C GET LAND/SEA TAG AND CHECK FOR LAT/LON OVER LAND OR ICE BALON=REAL(MOD(IBUFTN((27*IRT)-16)+18000,36000)-18000)/100. IALON = MOD(36000-IBUFTN((27*IRT)-16),36000) IX = 361. - REAL(IALON)/100. JY = 91 - NINT(REAL(IBUFTN((27*IRT)-17))/100. + 0.50) DMIN = MIN(DMIN,SSTDAT(IX,JY)) DMAX = MAX(DMAX,SSTDAT(IX,JY)) CALL MISC04(INLSF,REAL(IBUFTN((27*IRT)-17))/100.,BALON,LSTAG) C ..... REJECT IF OVER LAND (USE LAND/SEA TAG HERE) IF(LSTAG.NE.0) THEN NLR = NLR + 1 GO TO 112 END IF C ..... REJECT IF OVER ICE (USE SEA-SURFACE TEMPERATURE HERE) IF(SSTDAT(IX,JY).LE.272.96) THEN NIR = NIR + 1 GO TO 112 END IF KDATA = IBUFTN((27*IRT)-01:(27*IRT)+05) DO IT = 1,7 IF((IT.NE.2.AND.KDATA(IT).LT.10000).OR. $ (IT.EQ.2.AND.KDATA(IT).LT. 8000)) THEN LBTER(IT) = LBTER(IT) + 1 PRINT 779,IT,IBUFTN(8),IBUFTN(9),KDATA 779 FORMAT(' ##W3MISCAN: BT, CHN',I2,' BAD: SCAN',I6,', ORBIT',I8, $ '; BT:',7I6,'-CANNOT CALC. PRODS VIA ALG.') GO TO 112 END IF END DO C CALL SUBR. MISC01 TO INITIATE IN-LINE PRODUCT CALCULATION CALL MISC01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB) IF(NNALG) THEN CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 6021, ATXT(1),SWNN, CDAK $ TPWNN,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100., CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100. 6021 FORMAT(' W3MISCAN: ',A2,' SPD',F6.1,' TPW',F6.1,' TB19V',F6.1, $ ' TB22V',F6.1,' TB37V',F6.1,' TB37H',F6.1,' TD37',F5.1) C STORE THE CALCULATED NEURAL NET 3 WIND SPEED (*10 M/SEC) IBUFTN((27*IRT)+6) = MIN(IMSG,NINT(SWNN*10.)) C STORE THE CALCULATED NEURAL NET 3 TPW (*10 MILLIMETERS) IBUFTN((27*IRT)+7) = MIN(IMSG,NINT(TPWNN*10.)) END IF IF(GBALG) THEN CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 602, ATXT(2),NRFGB, CDAK $ SWGB,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100., CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100. 602 FORMAT(' W3MISCAN: ',A2,' RF, SPD',I2,F6.1,' TB19V',F6.1, $ ' TB22V',F6.1,' TB37V',F6.1,' TB37H',F6.1,' TD37',F5.1) C STORE THE CALCULATED GOODBERLET WIND SPEED (*10 M/SEC) IBUFTN((27*IRT)+8) = MIN(IMSG,NINT(SWGB*10.)) C STORE THE GOODBERLET RAIN FLAG (0-3) IBUFTN((27*IRT)+9) = MIN(IMSG,NRFGB) END IF C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ELSE C...................................................................... C PROBLEM - CAN'T CALCULATE PRODUCTS VIA ANY ALG., ALL B.TEMPS MISSING PRINT 879, IBUFTN(8),IBUFTN(9),KDATA 879 FORMAT(' ##W3MISCAN: ALL B.TMPS MSSNG: SCAN',I6,', ', $ 'ORBIT',I8,'; BT:',7I6,'-CANNOT CALC PRODS VIA ALG.') C...................................................................... END IF END IF 112 CONTINUE C----------------------------------------------------------------------- END DO END IF C*********************************************************************** 901 CONTINUE C RETURN TO CALLING PROGRAM - IER = 0 SCAN SUCCESSFULLY READ KNTSCN = KNTSCN + 1 KNTSAT(IBUFTN(1)) = KNTSAT(IBUFTN(1)) + 1 IER = 0 RETURN C....................................................................... 993 CONTINUE C PROBLEM: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB INDEX FILE - ERROR C RETURNED FROM GRIB DECODER GETGB IS 96 - SET IER = 6 & RETURN PRINT 2008, INGBI 2008 FORMAT(/' ##W3MISCAN: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB ', $ 'INDEX FILE IN UNIT ',I2,' - IER = 6'/) IER = 6 RETURN C....................................................................... 994 CONTINUE C PROBLEM: SEA-SURFACE TEMPERATURE GRIB MESSAGE HAS A DATE THAT IS C EITHER: 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST REQ. DATE C (INPUT ARG. "KDATE") OR 2) MORE THAN 7-DAYS AFTER THE LATEST C REQ. DATE (INPUT ARG. "LDATE") - SET IER = 7 AND RETURN PRINT 2009 2009 FORMAT(' SST GRIB MSG HAS DATE WHICH IS EITHER 7-DAYS', $ ' PRIOR TO EARLIEST REQ. DATE'/14X,'OR 7-DAYS LATER THAN LATEST', $ ' REQ. DATE - IER = 7'/) IER = 7 RETURN C....................................................................... 995 CONTINUE C PROBLEM: BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE CONTAINING SEA- C SURFACE TEMPERATURE FIELD - ERROR RETURNED FROM GRIB DECODER C GETGB IS 97-99 - SET IER = 8 AND RETURN PRINT 2010 2010 FORMAT(' BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE ', $ 'CONTAINING SEA-SURFACE TEMPERATURE FIELD - IER = 8'/) IER = 8 RETURN C....................................................................... 996 CONTINUE C PROBLEM: ERROR RETURNED FROM GRIB DECODER - GETGB - FOR SEA-SURFACE C TEMPERATURE FIELD - > 0 BUT NOT 96-99 - SET IER = 9 & RETURN PRINT 2011 2011 FORMAT(' - IER = 9'/) IER = 9 RETURN C....................................................................... 997 CONTINUE C PROBLEM: ERROR OPENING R. ACCESS FILE HOLDING LAND/SEA TAGS - SET IER C = 4 AND RETURN PRINT 2012, IERR,INLSF 2012 FORMAT(/' ##W3MISCAN: ERROR OPENING R. ACCESS LAND/SEA FILE IN ', $ 'UNIT ',I2,' -- IOSTAT =',I5,' -- NO SCANS PROCESSED - IER = 4'/) IER = 4 RETURN C....................................................................... 998 CONTINUE C PROBLEM: THE INPUT DATA SET IS EITHER EMPTY (NULL), NOT BUFR, OR C CONTAINS NO DATA MESSAGES - SET IER = 2 AND RETURN PRINT 14, INDTA 14 FORMAT(/' ##W3MISCAN: SSM-I DATA SET IN UNIT',I3,' IS EITHER ', $'EMPTY (NULL), NOT BUFR, OR CONTAINS NO DATA MESSAGES - IER = 2'/) IER = 2 RETURN C....................................................................... 999 CONTINUE C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED - SET C IER = 5 AND RETURN PRINT 217, NLEV,ILFLG 217 FORMAT(/' ##W3MISCAN: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (ILFLG=',I1,') - IER = 5'/) IER = 5 RETURN C....................................................................... END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MISC01 PREPARES FOR IN-LINE CALUCLATION OF PRODS C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-01-28 C C ABSTRACT: BASED ON INPUT 7-CHANNEL SSM/I BRIGHTNESS TEMPERATURES, C DETERMINES THE RAIN FLAG CATEGORY FOR WIND SPEED PRODUCT FOR THE C GOODBERLET ALGORITHM. THEN CALLS THE APPROPRIATE FUNCTION TO C CALCULATE EITHER THE WIND SPEED PRODUCT FOR THE GOODBERLET C ALGORITHM (IF REQUESTED) OR THE WIND SPEED AND TPW PRODUCTS FOR C THE NEURAL NET 3 ALGORITHM (IF REQUESTED). C C PROGRAM HISTORY LOG: C ????-??-?? W. GEMMILL (W/NMC21) -- ORIGINAL AUTHOR C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND C STREAMLINED CODE C 1996-05-07 D. A. KEYSER (NP22) -- IN-LINE NEURAL NETWORK 1 ALGORITM C REPLACED BY NEURAL NETWORK 2 ALGORITHM C 1996-07-30 D. A. KEYSER (NP22) -- CAN NOW PROCESS WIND SPEED FROM C BOTH ALGORITHMS IF DESIRED C 1998-01-28 D. A. KEYSER (NP22) -- REPLACED NEURAL NET 2 ALGORITHM C WHICH CALCULATED ONLY WIND SPEED PRODUCT WITH NEURAL NET 3 C ALGORITHM WHICH CALCULATES BOTH WIND SPEED AND TOTAL C PRECIPITABLE WATER PRODUCTS (AMONG OTHERS) BUT, UNLIKE NN2, C DOES NOT RETURN A RAIN FLAG VALUE (IT DOES SET ALL RETRIEVALS C TO MISSING THAT FAIL RAIN FLAG AND ICE CONTAMINATION TESTS) C C USAGE: CALL MISC01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB) C INPUT ARGUMENT LIST: C NNALG - PROCESS WIND SPEED AND TPW VIA NEURAL NET 3 ALGORITHM C - IF TRUE C GBALG - PROCESS WIND SPEED VIA GOODBERLET ALGORITHM IF TRUE C KDATA - 7-WORD ARRAY CONTAINING 7 CHANNELS OF BRIGHTNESS C - TEMPERATURE (KELVIN X 100) C C OUTPUT ARGUMENT LIST: C SWNN - CALCULATED WIND SPEED BASED ON NEURAL NET 3 ALGORITHM C - (METERS/SECOND) C TPWNN - CALCULATED TOTAL COLUMN PRECIPITABLE WATER BASED ON C - NEURAL NET 3 ALGORITHM (MILLIMETERS) C SWGB - CALCULATED WIND SPEED BASED ON GOODBERLET ALGORITH C - (METERS/SECOND) C NRFGB - RAIN FLAG CATEGORY FOR CALCULATED WIND SPEED FROM C - GOODBERLET ALGORITHM C C REMARKS: IF AN ALGORITHM IS NOT CHOSEN, THE OUTPUT PRODUCTS ARE SET C TO VALUES OF 99999. FOR THAT ALGORITHM AND, FOR THE GOODBERLET C ALGORITHM ONLY, THE RAIN FLAG IS SET TO 99999. CALLED BY C SUBROUTINE W3MISCAN. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ SUBROUTINE MISC01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB) LOGICAL NNALG,GBALG REAL BTA(4),BTAA(7) INTEGER KDATA(7) COMMON/MISCEE/LFLAG,LICEC SAVE SWNN = 99999. TPWNN = 99999. SWGB = 99999. NRFGB = 99999 TB19V = REAL(KDATA(1))/100. TB19H = REAL(KDATA(2))/100. TB22V = REAL(KDATA(3))/100. TB37V = REAL(KDATA(4))/100. TB37H = REAL(KDATA(5))/100. TB85V = REAL(KDATA(6))/100. TB85H = REAL(KDATA(7))/100. TD37 = TB37V - TB37H IF(NNALG) THEN C COMPUTE WIND SPEED FROM NEURAL NET 2 ALGORITHM (1995) C (no longer a possibility - subr. expects dim. of 5 on BTAA) cdak NRFNN = 1 cdak IF(TB19H.LE.185.0.AND.TB37H.LE.210.0.AND.TB19V.LT.TB37V) cdak $ NRFNN = 0 cdak BTAA(1) = TB19V cdak BTAA(2) = TB22V cdak BTAA(3) = TB37V cdak BTAA(4) = TB37H cdak BTAA(5) = TB85V cdak SWNN = RISC02xx(BTAA) C COMPUTE WIND SPEED AND TPW FROM NEURAL NET 3 ALGORITHM (1997) BTAA(1) = TB19V BTAA(2) = TB19H BTAA(3) = TB22V BTAA(4) = TB37V BTAA(5) = TB37H BTAA(6) = TB85V BTAA(7) = TB85H SWNN = RISC02(BTAA,TPWNN,LQWNN,SSTNN,JERR) IF(JERR.EQ.1) LFLAG = LFLAG + 1 IF(JERR.EQ.2) LICEC = LICEC + 1 END IF IF(GBALG) THEN C COMPUTE WIND SPEED FROM GOODBERLET ALGORITHM NRFGB = 0 IF(TD37.LE.50.0.OR.TB19H.GE.165.0) THEN IF(TD37.LE.50.0.OR.TB19H.GE.165.0) NRFGB = 1 IF(TD37.LE.37.0) NRFGB = 2 IF(TD37.LE.30.0) NRFGB = 3 END IF BTA(1) = TB19V BTA(2) = TB22V BTA(3) = TB37V BTA(4) = TB37H SWGB = RISC03(BTA) END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RISC02 CALC. SSM/I PRODS FROM NEURAL NET 3 ALG. C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1997-02-02 C C ABSTRACT: THIS RETRIEVAL ALGORITHM IS A NEURAL NETWORK IMPLEMENTATION C OF THE SSM/I TRANSFER FUNCTION. IT RETRIEVES THE WIND SPEED (W) C AT THE HEIGHT 20 METERS, COLUMNAR WATER VAPOR (V), COLUMNAR LIQUID C WATER (L) AND SST. THE NN WAS TRAINED USING BACK-PROPAGATION C ALGORITHM. TRANSFER FUNCTION IS DESCRIBED AND COMPARED WITH C CAL/VAL AND OTHER ALGORITHMS IN OMB TECHNICAL NOTE NO. 137. SEE C REMARKS FOR DETAILED INFO ON THIS ALGORITHM. THIS IS AN IMPROVED C VERSION OF THE EARLIER NEURAL NETWORK 2 ALGORITHM. C C PROGRAM HISTORY LOG: C 1997-02-02 V. KRASNOPOLSKY -- ORIGINAL AUTHOR C C USAGE: XX = RISC02(XT,V,L,SST,JERR) C INPUT ARGUMENT LIST: C XT - 7-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE C - ORDER: T19V (WORD 1), T19H (WORD 2), T22V (WORD 3), C - T37V (WORD 4), T37H (WORD 5), T85V (WORD 6), T85H C - (WORD 7) (ALL IN KELVIN) C C OUTPUT ARGUMENT LIST: C V - COLUMNAR WATER VAPOR (TOTAL PRECIP. WATER) (MM) C L - COLUMNAR LIQUID WATER (MM) C SST - SEA SURFACE TEMPERATURE (DEG. C) C XX - WIND SPEED (METERS/SECOND) AT THE HEIGHT OF 20 METERS C JERR - ERROR RETURN CODE: C = 0 -- GOOD RETRIEVALS C = 1 -- RETRIEVALS COULD NOT BE MADE DUE TO ONE OR C MORE BRIGHTNESS TEMPERATURES OUT OF RANGE C (I.E, FAILED THE RAIN FLAG TEST) C = 2 -- RETRIEVALS COULD NOT BE MADE DUE TO ICE C CONTAMINATION C {FOR EITHER 1 OR 2 ABOVE, ALL RETRIEVALS SET TO C 99999. (MISSING)} C C REMARKS: FUNCTION, CALLED BY SUBROUTINE MISC01. C C Description of training and test data set: C ------------------------------------------ C The training set consists of 3460 matchups which were received C from two sources: C 1. 3187 F11/SSMI/buoy matchups were filtered out from a C preliminary version of the new NRL database which was C kindly provided by G. Poe (NRL). Maximum available wind C speed is 24 m/s. C 2. 273 F11/SSMI/OWS matchups were filtered out from two C datasets collected by high latitude OWS LIMA and MIKE. C These data sets were kindly provided by D. Kilham C (University of Bristol). Maximum available wind speed C is 26.4 m/s. C C Satellite data are collocated with both buoy and OWS data in C space within 15 km and in time within 15 min. C C The test data set has the same structure, the same number of C matchups and maximum buoy wind speed. C C Description of retrieval flags: C ------------------------------- C Retrieval flags by Stogryn et al. are used. The algorithm C produces retrievals under CLEAR + CLOUDY conditions, that is C if: C C T37V - T37H > 50. => CLEAR condition C or C T37V - T37H =< 50.| C T19H =< 185. and | C T37H =< 210. and | => CLOUDY conditions C T19V < T37V | C C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ FUNCTION RISC02(XT,V,L,SST,JERR) PARAMETER (IOUT =4) LOGICAL LQ1,LQ2,LQ3,LQ4 REAL XT(7),Y(IOUT),V,L,SST EQUIVALENCE (Y(1),SPN) JERR = 0 C -------- Retrieval flag (Stogryn) ------------------------- C T19H =< 185 LQ1 = (XT(2).LE.185.) C T37H =< 210 LQ2 = (XT(5).LE.210.) C T19V < T37V LQ3 = (XT(1).LT.XT(4)) C T37V - T37H =< 50. LQ4 = ((XT(4) - XT(5)).LE.50.) LQ1 = (LQ1.AND.LQ2.AND.LQ3) IF(.NOT.LQ1.AND.LQ4) THEN SPN = 99999. V = 99999. L = 99999. SST = 99999. JERR = 1 GO TO 111 END IF C --------------- Call NN ---------------------- C NN WIND SPEED CALL MISC10(XT,Y) V = Y(2) L = Y(3) SST = Y(4) C --------- Remove negative values ---------------------------- IF(SPN.LT.0.0) SPN = 0.0 IF(SST.LT.0.0) SST = 0.0 IF(V .LT.0.0) V = 0.0 C ------ Remove ice contamination ------------------------------------ ICE = 0 SI85 = -174.4 + (0.715 * XT(1)) + (2.439 * XT(3)) - (0.00504 * $ XT(3) * XT(3)) - XT(6) TT = 44. + (0.85 * XT(1)) IF(SI85.GE.10.) THEN IF(XT(3).LE.TT) ICE = 1 IF((XT(3).GT.264.).AND.((XT(3)-XT(1)).LT.2.)) ICE = 1 END IF IF(ICE.EQ.1) THEN SPN = 99999. V = 99999. L = 99999. SST = 99999. JERR = 2 END IF 111 CONTINUE RISC02 = SPN RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MISC10 CALC. SSM/I PRODS FROM NEURAL NET 3 ALG. C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1996-07-15 C C ABSTRACT: THIS NN CALCULATES W (IN M/S), V (IN MM), L (IN MM), AND C SST (IN DEG C). THIS NN WAS TRAINED ON BLENDED F11 DATA SET C (SSMI/BUOY MATCHUPS PLUS SSMI/OWS MATCHUPS 15 KM X 15 MIN) UNDER C CLEAR + CLOUDY CONDITIONS. C C PROGRAM HISTORY LOG: C 1996-07-15 V. KRASNOPOLSKY -- ORIGINAL AUTHOR C C USAGE: CALL MISC10(X,Y) C INPUT ARGUMENT LIST: C X - 5-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE C - ORDER: T19V (WORD 1), T19H (WORD 2), T22V (WORD 3), C - T37V (WORD 4), T37H (WORD 5) (ALL IN KELVIN) C C OUTPUT ARGUMENT LIST: C Y - 4-WORD ARRAY CONTAINING CALCULATED PRODUCTS IN THE C - ORDER: WIND SPEED (M/S) (WORD 1), COLUMNAR WATER C - VAPOR (TOTAL PRECIP. WATER) (MM) (WORD 2), COLUMNAR C - LIQUID WATER (MM) (WORD 3), SEA SURFACE TEMPERATURE C - (DEG. C) (WORD 4) C C REMARKS: CALLED BY SUBROUTINE RISC02. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ SUBROUTINE MISC10(X,Y) INTEGER HID,OUT C IN IS THE NUMBER OF NN INPUTS, HID IS THE NUMBER OF HIDDEN NODES, C OUT IS THE NUMBER OF OUTPUTS PARAMETER (IN =5, HID =12, OUT =4) DIMENSION X(IN),Y(OUT),W1(IN,HID),W2(HID,OUT),B1(HID),B2(OUT), $ O1(IN),X2(HID),O2(HID),X3(OUT),O3(OUT),A(OUT),B(OUT) C W1 HOLDS INPUT WEIGHTS DATA ((W1(I,J),J = 1,HID),I = 1,IN)/ $-0.0435901, 0.0614709,-0.0453639,-0.0161106,-0.0271382, 0.0229015, $-0.0650678, 0.0704302, 0.0383939, 0.0773921, 0.0661954,-0.0643473, $-0.0108528,-0.0283174,-0.0308437,-0.0199316,-0.0131226, 0.0107767, $ 0.0234265,-0.0291637, 0.0140943, .00567931,-.00931768, $-.00860661, 0.0159747,-0.0749903,-0.0503523, 0.0524172, 0.0195771, $ 0.0302056, 0.0331725, 0.0326714,-0.0291429, 0.0180438, 0.0281923, $-0.0269554, 0.102836, 0.0591511, 0.134313, -0.0109854,-0.0786303, $ 0.0117111, 0.0231543,-0.0205603,-0.0382944,-0.0342049, $ 0.00052407,0.110301, -0.0404777, 0.0428816, 0.0878070, 0.0168326, $ 0.0196183, 0.0293995, 0.00954805,-.00716287,0.0269475, $-0.0418217,-0.0165812, 0.0291809/ C W2 HOLDS HIDDEN WEIGHTS DATA ((W2(I,J),J = 1,OUT),I = 1,HID)/ $-0.827004, -0.169961,-0.230296, -0.311201, -0.243296, 0.00454425, $ 0.950679, 1.09296, 0.0842604, 0.0140775, 1.80508, -0.198263, $-0.0678487, 0.428192, 0.827626, 0.253772, 0.112026, 0.00563793, $-1.28161, -0.169509, 0.0019085,-0.137136, -0.334738, 0.224899, $-0.189678, 0.626459,-0.204658, -0.885417, -0.148720, 0.122903, $ 0.650024, 0.715758, 0.735026, -0.123308, -0.387411,-0.140137, $ 0.229058, 0.244314,-1.08613, -0.294565, -0.192568, 0.608760, $-0.753586, 0.897605, 0.0322991,-0.178470, 0.0807701, $-0.781417/ C B1 HOLDS HIDDEN BIASES DATA (B1(I), I=1,HID)/ $ -9.92116,-10.3103,-17.2536, -5.26287, 17.7729,-20.4812, $ -4.80869,-11.5222, 0.592880,-4.89773,-17.3294, -7.74136/ C B2 HOLDS OUTPUT BIAS DATA (B2(I), I=1,OUT)/-0.882873,-0.0120802,-3.19400,1.00314/ C A(OUT), B(OUT) HOLD TRANSFORMATION COEFFICIENTS DATA (A(I), I=1,OUT)/18.1286,31.8210,0.198863,37.1250/ DATA (B(I), I=1,OUT)/13.7100,32.0980,0.198863,-5.82500/ C INITIALIZE O1 = X C START NEURAL NETWORK C - INITIALIZE X2 DO I = 1,HID X2(I) = 0. DO J = 1,IN X2(I) = X2(I) + (O1(J) * W1(J,I)) END DO X2(I) = X2(I) + B1(I) O2(I) = TANH(X2(I)) END DO C - INITIALIZE X3 DO K = 1,OUT X3(K) = 0. DO J = 1,HID X3(K) = X3(K) + (W2(J,K) * O2(J)) END DO X3(K) = X3(K) + B2(K) C --- CALCULATE O3 O3(K) = TANH(X3(K)) Y(K) = (A(K) * O3(K)) + B(K) END DO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RISC02xx CALC. WSPD FROM NEURAL NET 2 ALGORITHM C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1996-05-07 C C ABSTRACT: CALCULATES A SINGLE NEURAL NETWORK OUTPUT FOR WIND SPEED. C THE NETWORK WAS TRAINED ON THE WHOLE DATA SET WITHOUT ANY C SEPARATION INTO SUBSETS. IT GIVES RMS = 1.64 M/S FOR TRAINING SET C AND 1.65 M/S FOR TESTING SET. THIS IS AN IMPROVED VERSION OF THE C EARLIER NEURAL NETWORK 1 ALGORITHM. C C PROGRAM HISTORY LOG: C 1994-03-20 V. KRASNOPOLSKY -- ORIGINAL AUTHOR C 1995-05-07 V. KRASNOPOLSKY -- REPLACED WITH NEURAL NET 2 ALGORITHM C C USAGE: XX = RISC02xx(X) C INPUT ARGUMENT LIST: C X - 5-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE C - ORDER: T19V (WORD 1), T22V (WORD 2), T37V (WORD 3), C - T37H (WORD 4), T85V (WORD 5) (ALL IN KELVIN) C C OUTPUT ARGUMENT LIST: C XX - WIND SPEED (METERS/SECOND) C C REMARKS: FUNCTION, NO LONGER CALLED BY THIS PROGRAM. IT IS HERE C SIMPLY TO SAVE NEURAL NET 2 ALGORITHM FOR POSSIBLE LATER USE C (HAS BEEN REPLACED BY NEURAL NET 3 ALGORITHM, SEE SUBR. RISC02 C AND MISC10). C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ FUNCTION RISC02xx(X) INTEGER HID C IN IS THE NUMBER OF B. TEMP. CHNLS, HID IS THE NUMBER OF HIDDEN NODES PARAMETER (IN =5, HID =2) DIMENSION X(IN),W1(IN,HID),W2(HID),B1(HID),O1(IN),X2(HID),O2(HID) SAVE C W1 HOLDS INPUT WEIGHTS DATA ((W1(I,J),J=1,HID),I=1,IN)/ $ 4.402388E-02, 2.648334E-02, 6.361322E-04,-1.766535E-02, $ 7.876555E-03,-7.387260E-02,-2.656543E-03, 2.957161E-02, $-1.181134E-02, 4.520317E-03/ C W2 HOLDS HIDDEN WEIGHTS DATA (W2(I),I=1,HID)/8.705661E-01,1.430968/ C B1 HOLDS HIDDEN BIASES DATA (B1(I),I=1,HID)/-6.436114,8.799655/ C B2 HOLDS OUTPUT BIAS C AY AND BY HOLD OUTPUT TRANSFORMATION COEFFICIENTS DATA B2/-0.736255/,AY/16.7833/,BY/11.08/ O1 = X C INITIALIZE X3 = 0. DO I = 1, HID O2(I) = 0. X2(I) = 0. DO J = 1,IN X2(I) = X2(I) + (O1(J) * W1(J,I)) END DO X2(I) = X2(I) + B1(I) O2(I) = TANH(X2(I)) X3 = X3 + (O2(I)* W2(I)) END DO X3 = X3 + B2 O3 = TANH(X3) RISC02xx = (AY * O3) + BY RISC02xx = MAX(RISC02xx,0.0) C BIAS CORRECTION BIAS = 0.5 + 0.004*((RISC02xx-10.)**3)*(1.-EXP(-0.5*RISC02xx)) RISC02xx = RISC02xx + BIAS RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RISC03 CALC. W.SPD FROM B TEMP.- GOODBERLET ALG C PRGMMR: W. GEMMILL ORG: NP21 DATE: 1994-08-15 C C ABSTRACT: CALCULATES A SINGLE GOODBERLET OUTPUT FOR WIND SPEED. C THIS IS A LINEAR REGRESSION ALGORITHM FROM 1989. C C PROGRAM HISTORY LOG: C 1994-08-15 W. GEMMILL -- ORIGINAL AUTHOR C C USAGE: XX = RISC03(X) C INPUT ARGUMENT LIST: C X - 4-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE C - ORDER: T19V (WORD 1), T22V (WORD 2), T37V (WORD 3), C - T37H (WORD 4) (ALL IN KELVIN) C C OUTPUT ARGUMENT LIST: C XX - WIND SPEED (METERS/SECOND) C C REMARKS: FUNCTION, CALLED BY SUBROUTINE MISC01. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ FUNCTION RISC03(X) DIMENSION X(4) SAVE RISC03 = 147.90 + (1.0969 * X(1)) - (0.4555 * X(2)) - $ (1.76 * X(3)) + (0.7860 * X(4)) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MISC04 RETURNS LAND/SEA TAG FOR GIVEN LAT/LON C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-01-04 C C ABSTRACT: FINDS AND RETURNS THE LOW RESOLUTION LAND/SEA TAG NEAREST C TO THE REQUESTED LATITUDE AND LONGITUDE. C C PROGRAM HISTORY LOG: C 1978-01-20 J. K. KALINOWSKI (S11213) -- ORIGINAL AUTHOR C 1978-10-03 J. K. KALINOWSKI (S1214) -- CHANGES UNKNOWN C 1985-03-01 N. DIGIROLAMO (SSAI) -- CONVERSION TO VS FORTRAN C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND C STREAMLINED CODE C C USAGE: CALL MISC04(INLSF,BLAT,BLNG,LSTAG) C INPUT ARGUMENT LIST: C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE C BLAT - LATITUDE (WHOLE DEGREES: RANGE IS 0. TO +90. NORTH, C - 0. TO -90. SOUTH) C BLNG - LONGITUDE (WHOLE DEGREES: RANGE IS 0. TO +179.99 EAST, C - 0. TO -180. WEST) C C OUTPUT ARGUMENT LIST: C LSTAG - LAND/SEA TAG {=0 - SEA; =1 - LAND; =2 - COASTAL C - INTERFACE (HIGHER RESOLUTION TAGS ARE AVAILABLE); C - =3 - COASTAL INTERFACE (NO HIGHER RESOLUTION TAGS C - EXIST)} C C REMARKS: CALLED BY SUBROUTINE W3MISCAN. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ SUBROUTINE MISC04(INLSF,BLAT,BLNG,LSTAG) CHARACTER*1 LPUT REAL RGS(3) C LPUT CONTAINS A REGION OF LAND/SEA TAGS (RETURNED FROM CALL TO MISC05) COMMON/MISCDD/LPUT(21960) SAVE C RGS IS ARRAY HOLDING SOUTHERN BOUNDARIES OF EACH LAND/SEA TAG REGION DATA RGS/-85.,-30.,25./,NUMRGL/0/,IFLAG/0/ C INITIALIZE LAND/SEA TAG AS 1 (OVER LAND) LSTAG = 1 C FIND NEAREST POINT OF A HALF-DEGREE (LAT,LONG) GRID C ..ALAT IS LATITUDE TO THE NEAREST HALF-DEGREE ALAT = INT((BLAT+SIGN(.25,BLAT))/.5) * .5 C ..ALNG IS LONGITUDE TO THE NEAREST HALF-DEGREE ALNG = INT((BLNG+SIGN(.25,BLNG))/.5) * .5 IF(NINT(ALNG*10.).EQ.1800) ALNG = -180. C IDENTIFY DATABASE REGION IN WHICH TO FIND CORRECT TAG NUMRGN = 1 IF(IABS(NINT(ALAT*10)).GT.850) THEN RETURN ELSE IF(NINT(ALAT*10).GT.275) THEN NUMRGN = 3 ELSE IF(NINT(ALAT*10.).GE.-275) THEN NUMRGN = 2 END IF IF(NUMRGN.NE.NUMRGL.OR.IFLAG.EQ.1) THEN NUMRGL = NUMRGN CALL MISC05(INLSF,NUMRGN,*99) END IF C FIND THE BYTE & BIT PAIR W/I DATA BASE REGION CONTAINING DESIRED TAG TRM1 = ((ALAT - RGS(NUMRGN)) * 1440.) + 360. LSTPT = TRM1 + (2. * ALNG) C ..NBYTE IS THE BYTE IN LPUT CONTAINING THE TAG NBYTE = (180 * 8) + (LSTPT/4 * 8) NSHFT = (2 * (MOD(LSTPT,4) + 1)) - 2 C PULL OUT THE TAG CALL GBYTE(LPUT,LSTAG,NBYTE+NSHFT,2) IFLAG = 0 RETURN C----------------------------------------------------------------------- 99 CONTINUE C COME HERE IF LAND/SEA TAG COULD NOT BE RETURNED FROM SUBR. W3MISCAN C (IN THIS CASE IT WILL REMAIN SET TO 1 INDICATING OVER LAND) IFLAG = 1 RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MISC05 READS 2 RECORDS FROM LAND/SEA TAG DTABASE C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-01-04 C C ABSTRACT: READS TWO RECORDS FROM A LOW RESOLUTION LAND/SEA DATABASE C AND STORES INTO COMMON. C C PROGRAM HISTORY LOG: C 1978-01-20 J. K. KALINOWSKI (S11213) -- ORIGINAL AUTHOR C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND C STREAMLINED CODE; MODIFIED TO BE MACHINE INDEPENDENT THRU C USE OF STANDARD FORTRAN DIRECT ACCESS READ C C USAGE: CALL MISC05(INLSF,NUMRGN) C INPUT ARGUMENT LIST: C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE C NUMRGN - THE REGION (1,2 OR 3) OF THE DATABASE TO BE ACCESSED C - (DEPENDENT ON LATITUDE BAND) C C INPUT FILES: C UNIT AA - (WHERE AA IS EQUAL TO INPUT ARGUMENT 'INLSF') C - DIRECT ACCESS NESDIS LAND/SEA FILE C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTNE MISC04. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ SUBROUTINE MISC05(INLSF,NUMRGN,*) CHARACTER*1 LPUT C LPUT CONTAINS A REGION OF LAND/SEA TAGS (COMPRISED OF 2 RECORDS FROM C LAND/SEA FILE) -- 180 BYTES OF DOCUMENTATION FOLLOWED BY 21780 BYTES C OF LAND/SEA TAGS COMMON/MISCDD/LPUT(21960) SAVE NREC = (2 * NUMRGN) - 1 READ(INLSF,REC=NREC,ERR=10) (LPUT(II),II=1,10980) NREC = NREC + 1 READ(INLSF,REC=NREC,ERR=10) (LPUT(II),II=10981,21960) RETURN C----------------------------------------------------------------------- 10 CONTINUE C ERROR READING IN A RECORD FROM LAND-SEA FILE -- RETURN (TAG WILL BE C SET TO 1 MEANING OVER LAND IN THIS CASE) PRINT 1000, NREC,INLSF 1000 FORMAT(' ##W3MISCAN/MISC05: ERROR READING IN LAND-SEA DATA ', $ 'RECORD',I7,' IN UNIT ',I2,' -- SET TAG TO LAND'/) RETURN 1 C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MISC06 READS IN NH AND SH 1-DEG. SEA-SFC TEMPS. C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2000-02-18 C C ABSTRACT: READS IN GLOBAL SEA-SURFACE TEMPERATURE FIELD ON A ONE- C DEGREE GRID FROM GRIB FILE. C C PROGRAM HISTORY LOG: C ????-??-?? W. GEMMILL (NP21) -- ORIGINAL AUTHOR C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND C STREAMLINED CODE; CONVERTED SST INPUT FILE FROM VSAM/ON84 TO C GRIB TO ALLOW CODE COMPILE AND RUN ON THE CRAY MACHINES. C 2000-02-18 D. A. KEYSER -- MODIFIED TO CALL W3LIB ROUTINE "GETGB", C THIS ALLOWS CODE TO COMPILE AND RUN PROPERLY ON IBM-SP C C USAGE: CALL MISC06(INGBI,INGBD,IDAT1,IDAT2,*,*,*,*) C INPUT ARGUMENT LIST: C INGBI - UNIT NUMBER OF GRIB INDEX FILE FOR GRIB FILE C - CONTAINING GLOBAL 1-DEGREE SEA-SURFACE TEMP FIELD C INGBD - UNIT NUMBER OF GRIB FILE CONTAINING GLOBAL 1-DEGREE C - SEA-SURFACE TEMP FIELD C IDAT1 - REQUESTED EARLIEST YEAR(YYYY), MONTH, DAY, HOUR, MIN C IDAT2 - REQUESTED LATEST YEAR(YYYY), MONTH, DAY, HOUR, MIN C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3MISCAN. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP C C$$$ SUBROUTINE MISC06(INGBI,INGBD,IDAT1,IDAT2,*,*,*,*) PARAMETER (MAXPTS=360*180) LOGICAL*1 LBMS(360,180) INTEGER KPDS(200),KGDS(200),LPDS(200),LGDS(200),IDAT1(5), $ IDAT2(5),JDAT1(8),JDAT2(8),KDAT(8),LDAT(8),MDATE(8) REAL RINC(5) CHARACTER*11 ENVVAR CHARACTER*80 FILEB,FILEI COMMON/MISCCC/SSTDAT(360,180) SAVE ENVVAR='XLFUNIT_ ' WRITE(ENVVAR(9:10),FMT='(I2)') INGBD CALL GETENV(ENVVAR,FILEB) ENVVAR='XLFUNIT_ ' WRITE(ENVVAR(9:10),FMT='(I2)') INGBI CALL GETENV(ENVVAR,FILEI) CALL BAOPENR(INGBD,FILEB,IRET1) ccccc PRINT *,'SAGT: ',INGBD,FILEB,IRET1 CALL BAOPENR(INGBI,FILEI,IRET2) ccccc PRINT *,'SAGT: ',INGBI,FILEI,IRET2 KPDS = -1 KGDS = -1 N = -1 KPDS(5) = 11 KPDS(6) = 1 KPDS(7) = 0 KPDS(8) = -1 KPDS(9) = -1 KPDS(10) = -1 PRINT 68, INGBD 68 FORMAT(//4X,'** W3MISCAN/MISC06: READ IN "CURRENT" SEA-SURFACE ', $ 'TEMPERATURE DATA FROM GRIB MESSAGE IN UNIT',I3) CALL GETGB(INGBD,INGBI,MAXPTS,0,KPDS,KGDS,KF,K,LPDS,LGDS,LBMS, $ SSTDAT,IRET) C....................................................................... C ABNORMAL RETURN IF PROBLEM WITH SST IN GRIB FILE IF(IRET.NE.0) THEN WRITE(6,*)' ERROR READING SST USING GETGB. IRET = ',IRET IF (IRET.EQ.96) RETURN 1 IF (IRET.EQ.97) RETURN 3 IF (IRET.EQ.98) RETURN 3 IF (IRET.EQ.99) RETURN 3 RETURN 4 ENDIF C....................................................................... C READ SUCCESSFUL JDAT1 = 0 JDAT2 = 0 JDAT1(1:3) = IDAT1(1:3) JDAT1(5:6) = IDAT1(4:5) JDAT2(1:3) = IDAT2(1:3) JDAT2(5:6) = IDAT2(4:5) MDATE = 0 MDATE(1) = ((LPDS(21) - 1) * 100) + LPDS(8) MDATE(2:3) = LPDS(9:10) MDATE(5:6) = LPDS(11:12) CALL W3MOVDAT((/-7.,0.,0.,0.,0./),JDAT1,KDAT) CALL W3MOVDAT((/ 7.,0.,0.,0.,0./),JDAT2,LDAT) cppppp print *, '** W3MISCAN/MISCO6: SST GRIB FILE MUST HAVE DATE ', $ 'BETWEEN ',(kdat(iii),iii=1,3),(kdat(iii),iii=5,6),' AND ', $ (ldat(iii),iii=1,3),(ldat(iii),iii=5,6) print *, ' RETURNED FROM GRIB FILE IS YEAR ', $ 'OF CENTURY = ',lpds(8),' AND CENTURY = ',lpds(21) print *, ' CALULATED 4-DIGIT YEAR IS = ', $ mdate(1) cppppp CALL W3DIFDAT(KDAT,MDATE,3,RINC) KMIN = RINC(3) CALL W3DIFDAT(LDAT,MDATE,3,RINC) LMIN = RINC(3) IF(KMIN.GT.0.OR.LMIN.LT.0) THEN C....................................................................... C COME HERE IF SST GRIB MSG HAS A DATE THAT IS EITHER: 1) MORE THAN 7- C DAYS PRIOR TO THE EARLIEST REQ. DATE (INPUT ARG. "IDAT1" TO W3MISCAN) C OR 2) MORE THAN 7-DAYS AFTER THE LATEST REQ. DATE (INPUT ARG. C "IDAT2" TO W3MISCAN) PRINT 27, (MDATE(III),III=1,3),(MDATE(III),III=5,6) 27 FORMAT(/' ##W3MISCAN/MISC06: SST GRIB MSG HAS DATE:',I5,4I3, $ ' - AS A RESULT......') RETURN 2 C....................................................................... END IF PRINT 60, (MDATE(III),III=1,3),(MDATE(III),III=5,6) 60 FORMAT(/4X,'** W3MISCAN/MISC06: SEA-SFC TEMP SUCCESSFULLY READ ', $ 'IN FROM GRIB FILE, DATE IS: ',I5,4I3/) RETURN CALL BACLOSE(INGBI,IRET) CALL BACLOSE(INGBD,IRET) END