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