C$$$ MAIN PROGRAM DOCUMENTATION BLOCK
C
C MAIN PROGRAM: SYNDAT_QCTROPCY PERFORMS QC ON TROP. CYCLONE BULLETINS
C PRGMMR: KEYSER ORG: NP22 DATE: 2008-07-10
C
C ABSTRACT: PERFORMS QUALITY CONTROL ON TROPICAL CYCLONE POSITION
C AND INTENSITY INFORMATION (T. C. VITAL STATISTICS). CHECKS
C PERFORMED ARE: DUPLICATE RECORDS, APPROPRIATE DATE/TIME, PROPER
C RECORD STRUCTURE (BLANKS IN PROPER PLACE AND NO IMPROPER NON-
C INTEGER NUMBERS), STORM NAME/ID NUMBER, RECORDS FROM MULTIPLE
C INSTITUTIONS, SECONDARY VARIABLES (E.G. CENTRAL PRESSURE),
C STORM POSITION AND DIRECTION/SPEED. EMPHASIS IS ON INTERNAL
C CONSISTENCY BETWEEN REPORTED STORM LOCATION AND PRIOR MOTION.
C
C PROGRAM HISTORY LOG:
C 1991-03-27 S. J. LORD
C 1991-07-18 S. J. LORD ADDED ROUTINE FSTSTM, MODIFIED ADFSTF
C 1992-01-22 S. J. LORD CHANGED W3FS12,W3FS13 CALLS TO W3FS19, W3FS17
C 1992-02-19 S. J. LORD ADDED MULTIPLE RSMC CHECK
C 1992-04-09 S. J. LORD CHANGED SLMASK TO T126 FROM T80
C 1992-05-20 S. J. LORD CORRECTED BUG IN SELACK CALL
C 1992-06-09 J. JOHNSON CHANGED COND=10 TO COND=4 FOR SUCCESSFUL RUN
C BUT WITH EMPTY INPUT FILES
C 1992-07-01 S. J. LORD ADDED DATE CHECK AND REVISED RITCUR
C 1992-07-10 S. J. LORD REVISED STIDCK TO DISMANTLE CONSISTENCY
C CHECKS IN THE CASE OF NUMBERED DEPRESSIONS
C 1992-07-16 S. J. LORD FIXED SOME BUGS IN RSMCCK
C 1992-08-20 S. J. LORD ADDED THE JTWC MEMORIAL SWITCH CHECK
C 1992-08-20 S. J. LORD MODIFIED DUPCHK TO ADD A NEW INPUT UNIT
C 1992-09-04 S. J. LORD ADDED PRESSURE WIND RELATIONSHIP TO SECVCK
C 1992-09-09 S. J. LORD ADDED CENTRAL PACIFIC NAMES AND NAME CHECK
C 1992-09-18 S. J. LORD ADDED CHECK FOR CORRECT MISSING DATA IN READCK
C 1992-10-28 S. J. LORD ADDED GREEK ALPHABET STORM NAMES
C 1992-12-14 S. J. LORD MODIFIED CONSOLE MESSAGE FOR ISTOP=4
C 1993-03-05 S. J. LORD IMPLEMENTED STORM CATALOG (RCNCIL)
C 1993-03-31 S. J. LORD IMPLEMENTED READING STORM NAMES FROM EXTERNAL
C FILE IN STIDCK
C 1993-04-08 S. J. LORD IMPLEMENTED WEST PACIFIC CLIPER
C 1993-08-25 S. J. LORD ADDER RETURN CODE OF 10 FOR RCNCIL LOGICAL
C ERROR
C 1993-08-25 S. J. LORD UPGRADED STORM ID CHECKING FOR STORMS CHANGING
C 1994-06-20 S. J. LORD MODIFIED MAXCHK FOR THE GFDL FORMAT
C 1996-04-12 S. J. LORD REMOVED CALL TO DRSPCK
C 1997-06-24 S. J. LORD ADDED NEW UNIT FOR MANUALLY ENTERED MESSAGES
C 1998-03-24 S. J. LORD MODIFIED VITDATN.INC AND VITFMTN.INC TO
C RECOGNIZE RSMC ID "NWOC" (THIS HAD BEEN UNRECOGNIZED
C AND HAD CAUSED THE PROGRAM TO STOP 20); REMOVED
C UNINITIALIZED VARIABLES THAT WERE CAUSING COMPILER
C WARNINGS
C 1998-06-05 D.A. KEYSER - FORTRAN 90 AND Y2K COMPLIANT
C 1998-06-18 S.J. LORD - FORTRAN 90 AND Y2K COMPLIANT (vitfmt.inc)
C 1998-08-16 S.J. LORD - FORTRAN 90 AND Y2K COMPLIANT (completed)
C 1998-12-14 D. A. KEYSER - Y2K/F90 COMPLIANCE, STREAMLINED CODE;
C 2000-03-03 D. A. KEYSER - CONVERTED TO RUN ON IBM-SP MACHINE
C 2001-02-07 D. A. KEYSER - EXPANDED TEST STORM ID RANGE FROM 90-99
C TO 80-99 AT REQUEST FOR JIM GROSS AT TPC {NOTE: IF THIS
C EVER HAS TO BE DONE AGAIN, THE ONLY LINES THAT NEED TO
C BE CHANGED ARE COMMENTED AS "CHG. TESTID" - ALSO MUST
C CHANGE PROGRAM bulls_bufrcyc WHICH GENERATES GTS
C MESSAGES, CHANGE UTILITY PROGRAM trpsfcmv WHICH
C GENERATES CHARTS FOR THE TROPICS (although technically
C trpsfcmv reads in q-c'd tcvitals files output by this
C program and thus they should not have test storms in
C them), and changes scripts: util/ush/extrkr.sh and
C ush/relocate_extrkr.sh}
C 2004-06-08 D. A. KEYSER - WHEN INTEGER VALUES ARE DECODED FROM
C CHARACTER-BASED RECORD VIA INTERNAL READ IN SUBR. DECVAR,
C IF BYTE IN UNITS DIGIT LOCATION IS ERRONEOUSLY CODED AS
C BLANK (" "), IT IS REPLACED WITH A "5" IN ORDER TO
C PREVENT INVALID VALUE FROM BEING RETURNED (I.E., IF
C "022 " WAS READ, IT WAS DECODED AS "22", IT IS NOW
C DECODED AS "225" - THIS HAPPENED FOR VALUE OF RADIUS OF
C LAST CLOSED ISOBAR FOR JTWC RECORDS FROM 13 JULY 2000
C THROUGH FNMOC FIX ON 26 MAY 2004 - THE VALUE WAS REPLACED
C BY CLIMATOLOGY BECAUSE IT FAILED A GROSS CHECK, HAD THIS
C CHANGE BEEN IN PLACE THE DECODED VALUE WOULD HAVE BEEN
C W/I 0.5 KM OF THE ACTUAL VALUE)
C 2008-07-10 D. A. KEYSER - CORRECTED MEMORY CLOBBERING CONDITION
C IN SUBR. STIDCK RELATED TO ATTEMPTED STORAGE OF MORE WEST
C PACIFIC STORM NAMES FROM FILE syndat_stmnames (144) THAN
C ALLOCATED BY PROGRAM AND IN syndat_stmnames (140), THIS
C LED TO OVERWRITING OF FIRST FOUR syndat_stmnames STORM
C NAMES IN ATLANTIC BASIN FOR 2002, 2008, 2014 CYCLE -
C DISCOVERED BECAUSE 2008 STORM BERTHA (STORM #2 IN
C ATLANTIC BASIN LIST IN syndat_stmnames) WAS NOT BEING
C RECOGNIZED AND THUS NOT PROCESSED INTO OUTPUT TCVITALS
C FILE - CORRECTED BY LIMITING STORAGE OF WEST PACIFIC
C STORM NAMES TO EXACTLY THE MAXIMUM IN PROGRAM (AND NUMBER
C IN syndat_stmnames) (CURRENTLY 140), ALSO GENERALIZED
C CODE TO ENSURE THAT IS WILL NEVER CLOBBER MEMORY READING
C AND STORING STORM NAMES IN ANY OF THE BASINS EVEN IF THE
C NUMBER OF STORM NAMES IN syndat_stmnames INCREASE (AS
C LONG AS THE MAXIMUM VALUE IS .GE. TO THE NUMBER OF STORM
C NAMES FOR THE BASIN IN FILE syndat_stmnames)
C 2013-03-17 D. C. STOKES - CHANGED SOME LIST DIRECTED OUTPUT TO
C FORMATTED TO PREVENT UNNDECSSARY WRAPPING ON WCOSS.
C 2013-03-24 D. C. STOKES - INITIALIZE VARIABLES THAT WERE NOT GETTING
C SET WHEN THERE ARE NO RECORDS TO PROCESS.
C 2013-10-10 D. C. STOKES - ADDED NON-HYPHNATED CARDINAL NUMBERS IN
C ORDER TO RECOGNIZE SUCH NAMED STORMS IN BASINS L, E, C, W,
C AND TO RECOGNIZE NAME CHANGES OF SUCH IN THE OTHER BASINS.
C ALSO EXTENDED THAT LIST (FROM 36 TO 39).
C
C
C INPUT FILES:
C (Note: These need to be double checked)
C UNIT 03 - TEXT FILE ASSOCIATING UNIT NUMBERS WITH FILE NAMES
C UNIT 05 - NAMELIST: VARIABLES APPROPRIATE TO THIS Q/C PROGRAM:
C MAXUNT: NUMBER OF INPUT FILES
C FILES: LOGICAL VARIABLE CONTROLLING FINAL
C COPYING OF RECORDS AND FILE MANIPULATION.
C FOR NORMAL OPERATIONAL USAGE, SHOULD BE TRUE.
C WHEN TRUE, INPUT FILES (UNIT 30, UNIT 31,
C ETC) WILL ZEROED OUT. FOR MULTIPLE RUNS
C OVER THE SAME INPUT DATA SET, FILES MUST BE
C FALSE. FOR DEBUGGING, IT IS HIGHLY
C RECOMMENDED THAT FILES BE SET TO FALSE.
C LNDFIL: TRUE IF RECORDS OF STORMS OVER COASTAL
C POINTS ARE NOT COPIED TO THE FILE OF
C CURRENT QUALITY CONTROLLED RECORDS.
C RUNID: RUN IDENTIFIER (e.g., 'GDAS_TM00_00').
C WINCUR: TIME WINDOW FOR WRITING CURRENT FILE
C NVSBRS: NUMBER OF VARIABLES ALLOWED FOR SUBSTITUTION
C IVSBRS: INDICES OF VARIABLES ALLOW FOR SUBSTITUTION
C UNIT 11 - APPROPRIATE T126 32-BIT GLOBAL SEA/LAND MASK FILE ON
C GAUSSIAN GRID
C UNIT 12 - RUN DATE FILE ('YYYYMMDDHH')
C UNIT 14 - DATA FILE CONTAINING STORM NAMES
C UNIT 20 - SCRATCH FILE CONTAINING PRELIMINARY Q/C RECORDS
C UNIT 21 - ORIGINAL SHORT-TERM HISTORY, CONTAINS ORIGINAL RECORDS
C BACK A GIVEN NUMBER (WINMIN) DAYS FROM PRESENT
C UNIT 22 - ALIASED SHORT-TERM HISTORY, CONTAINS ALIAS RECORDS
C BACK A GIVEN NUMBER (WINMIN) DAYS FROM PRESENT
C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C NOTE: UCL SHOULD COPY THIS FILE TO UNIT 22 (THE OLD
C ALIAS FILE) AT THE END OF EXECUTION.
C UNIT 30 - STARTING POINT FOR FILES CONTAINING NEW RECORDS TO BE
C etc. QUALITY CONTROLLED. ADDITIONAL INPUT FILES ARE UNIT
C 31, UNIT 32 ETC. THE NUMBER OF THESE FILES IS
C CONTROLLED BY THE NAMELIST INPUT VARIABLE "MAXUNT"
C MENTIONED UNDER UNIT 05 ABOVE. AN EXAMPLE OF AN INPUT
C FILE IS: /tpcprd/atcf/ncep/tcvitals. THIS FILE IS
C WRITTEN BY A REMOTE JOB ENTRY (RJE) AT MIAMI AFTER ALL
C TROPICAL CYCLONE FIXES ARE ESTABLISHED FOR THE ATLANTIC
C AND EAST PACIFIC BY NHC(TPC). THIS FILE IS TYPICALLY
C UPDATED (cat'ed) AT 0230, 0830, 1430, AND 2030 UTC
C (I.E. 2.5 HOURS AFTER SYNOPTIC TIME), 4 TIMES DAILY.
C RECORDS APPROPRIATE TO A FUTURE CYCLE ARE WRITTEN BACK
C TO THE APPROPRIATE FILE.
C
C OUTPUT FILES:
C (Note: These need to be double checked)
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 20 - SCRATCH FILE CONTAINING PRELIMINARY Q/C RECORDS
C UNIT 21 - SHORT-TERM HISTORY, RECORDS BACK 4 DAYS FROM PRESENT
C UNIT 22 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C UNIT 27 - STORM CATALOG FILE CONTAINING STORM NAME, ALIAS INFO
C FIRST AND LAST DATA OBSERVED
C UNIT 28 - SCRATCH FILE CONTAINING TEMPORARY CATALOG
C UNIT 30 - SEE INPUT FILES ABOVE. RECORDS APPROPRIATE TO A FUTURE
C etc. CYCLE ARE WRITTEN BACK TO THE APPROPRIATE FILE
C UNIT 54 - RUN DATE FILE FOR DATE CHECK ('YYYYMMDDHH')
C UNIT 60 - FILE CONTAINING QUALITY CONTROLLED RECORDS
C UNIT 61 - CONTAINS HISTORY OF ALL RECORDS THAT ARE OPERATED ON BY
C THIS PROGRAM
C
C SUBPROGRAMS CALLED:
C UNIQUE: - RSMCCK BASNCK AKASUB TCCLIM RCNCIL
C MNMXDA SCLIST AKLIST STCATI STCATN
C ADFSTF FSTSTM RITCUR RITSTH RITHIS
C FNLCPY CPYREC DUPCHK BLNKCK READCK
C DTCHK SETMSK STIDCK FIXDUP FIXNAM
C SECVCK WRNING F1 F2 SLDATE
C FIXSLM GAULAT BSSLZ1 TRKSUB NEWVIT
C DECVAR TIMSUB YTIME SORTRL DS2UV
C ATAN2D SIND COSD DISTSP AVGSUB
C ABORT1 OFILE0
C LIBRARY:
C COMMON - IARGC GETARG INDEX
C W3LIB - W3TAGB W3TAGE W3DIFDAT W3MOVDAT W3UTCDAT
C - ERREXIT
C
C EXIT STATES:
C COND = 0 - SUCCESSFUL RUN. NO RECORDS WITH ERRORS
C = 1 - SUCCESSFUL RUN. FOUND RECORDS WITH STORM ID>=80
C CHG. TESTID
C = 2 - SUCCESSFUL RUN. FOUND RECORDS WITH ERRORS
C = 3 - BOTH 1 AND 2 ABOVE
C = 4 - SUCCESSFUL RUN, BUT NO INPUT RECORDS FOUND
C = 5 - PROGRAM HAS BEEN RUN PREVIOUSLY
C =10 - LOGICAL INCONSISTENCY IN SUBROUTINE RCNCIL (??)
C =20 - FATAL ERROR (SEE STDOUT PRINT FOR MORE DETAILS)
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
PROGRAM SYNDAT_QCTROPCY
PARAMETER (MAXCHR=95)
PARAMETER (MAXREC=1000)
PARAMETER (MAXCKS=8)
PARAMETER (MAXRC=MAXREC*(MAXCKS+1))
PARAMETER (MAXTBP=20)
PARAMETER (MAXFIL=99)
PARAMETER (IVSBMX=14,IVSBM1=IVSBMX+1)
CHARACTER FILNAM*128
DIMENSION FILNAM(0:MAXFIL)
CHARACTER TSTREC(0:MAXREC)*100,OKAREC(MAXREC)*100,
1 BADREC(MAXREC)*100,DUMREC*100,SCRREC(0:MAXREC)*9,
2 XXXREC*27,ZZZREC*100,NNNREC*100,TBPREC(MAXTBP)*100,
3 SCRATC(MAXREC)*100
DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMOKA(MAXREC),NUMBAD(MAXREC),
1 NUMTST(MAXREC),NUMTBP(MAXTBP),IDUPID(MAXREC),
2 IUNTIN(MAXREC)
C IUNTSL: UNIT NUMBER FOR READING T126 32-BIT SEA-LAND MASK
C ON GAUSSIAN GRID
C IUNTDT: UNIT NUMBER FOR READING RUN DATE ('YYYYMMDDHH')
C IUNTDC: UNIT NUMBER FOR RUN DATE ('YYYYMMDDHH') CHECK
C IUNTOK: UNIT NUMBER FOR PRELIMINARY QUALITY-CONTROLLED
C RECORDS. ***NOTE: AT THE END OF THIS PROGRAM,
C IUNTOK CONTAINS THE SHORT-TERM
C HISTORICAL RECORDS FOR THE NEXT
C INPUT TIME.
C IUNTAL: UNIT NUMBER FOR ALIAS FILE WHICH CONTAINS STORM IDS
C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C IUNTAN: UNIT NUMBER FOR NEW ALIAS FILE
C IUNTCA: UNIT NUMBER FOR STORM CATALOG FILE WHICH CONTAINS
C CURRENT LISTING OF ALL STORMS, THEIR NAMES, DATES
C IDS AND ALIASES
C IUNTCN: UNIT NUMBER FOR SCRATCH STORM CATALOG
C IUNTCU: UNIT NUMBER FOR FINAL QUALITY-CONTROLLED RECORDS
C (CURRENT FILE)
C IUNTHO: UNIT NUMBER FOR THE SHORT-TERM HISTORICAL (ORIGINAL)
C VITAL STATISTICS RECORDS. LENGTH OF HISTORY
C CONTROLLED BY WINMIN. THESE ARE ORIGINAL RECORDS AND
C NOT ALIASED RECORDS!
C IUNTHA: UNIT NUMBER FOR THE SHORT-TERM HISTORICAL (ALIAS)
C VITAL STATISTICS RECORDS. LENGTH OF HISTORY
C CONTROLLED BY WINMIN. THESE ARE ALIAS RECORDS IF
C MULTIPLE OBSERVERS FOR A GIVEN STORM ARE PRESENT!
C IUNTHL: UNIT NUMBER FOR THE LONG-TERM HISTORICAL (PREVIOUS)
C VITAL STATISTICS RECORDS. ALL RECORDS, AND QUALITY
C CONTROL FLAGS ARE PUT INTO THIS FILE.
C IUNTVI: UNIT NUMBER FOR RAW VITAL STATISTICS FILE (NEITHER
C QUALITY CONTROLLED NOR CHECKED FOR DUPLICATES)
C WINMIN: WINDOW FOR SHORT-TERM HISTORY FILE (FRACTIONAL DAYS)
C WINMX1: WINDOW FOR MAXIMUM ACCEPTABLE DATE (FRACTIONAL DAYS)
C FOR RECORD PROCESSING
C WINCUR: WINDOW FOR WRITING CURRENT FILE (FRACTIONAL DAYS)
C FILES: TRUE IF NEW SHORT-TERM HISTORY FILE IS CREATED AND
C ALL NEW RECORD FILES ARE ZEROED OUT
C LNDFIL: TRUE IF RECORDS OF STORMS OVER COASTAL POINTS ARE
C NOT COPIED TO THE FILE OF CURRENT QUALITY CONTROLLED
C RECORDS.
DIMENSION RINC(5)
DIMENSION IVSBRS(0:IVSBMX)
LOGICAL FILES,LNDFIL
CHARACTER RUNID*12
NAMELIST/INPUT/IDATEZ,IUTCZ,RUNID,FILES,LNDFIL,MAXUNT,WINMIN,
1 NVSBRS,IVSBRS,WINCUR
DATA IUNTSL/11/,IUNTDT/12/,IUNTDC/54/,IUNTOK/20/,IUNTHO/21/,
1 IUNTVI/30/,MAXUNT/2/,IUNTCU/60/,IUNTHL/61/,WINMIN/4./,
2 WINMX1/0.0833333/,IEFAIL/MAXRC*0/,LNDFIL/.TRUE./,IUNTOP/3/,
3 IUNTHA/22/,IUNTAL/25/,IUNTAN/26/,NVSBRS/0/,IVSBRS/IVSBM1*0/,
4 WINCUR/0.25/,FIVMIN/3.4722E-3/,FILES/.FALSE./,IUNTCA/27/,
5 IUNTCN/28/,IUNTSN/14/
DATA NNNREC/'12345678901234567890123456789012345678901234567890123
1456789012345678901234567890123456789012345*****'/
DATA ZZZREC/'RSMC#SID#NAMEZZZZZ#YYYYMMDD#HHMM#LATZ#LONGZ#DIR#SPD#P
1CEN#PENV#RMAX#VM#RMW#15NE#15SE#15SW#15NW#D*****'/
DATA
1 XXXREC/' FL BL RD DT LL ID MR SV DS'/
CALL W3TAGB('SYNDAT_QCTROPCY',2013,0053,0050,'NP22 ')
C INITIALIZE SOME VARIABLES THAT MIGHT GET USED BEFORE GETTING SET
C UNDER CERTAIN CONDITIONS
IERCHK=0
IERRCN=0
NTBP=0
C OPEN FILES
filnam(0)='fildef.vit'
CALL OFILE0(IUNTOP,MAXFIL,NFTOT,FILNAM)
C READ RUN DATE AND CONVERT TO FLOATING POINT DATE.
C THE RUN DATE ACCEPTANCE WINDOW IS NOT SYMMETRIC ABOUT
C THE CURRENT RUN DATE
READ(5,INPUT)
WRITE(6,INPUT)
C GET CURRENT RUN DATE AND OFFSET IN SJL FORMAT
C OFFSET ROUNDED TO THE NEAREST HOUR FROM W3 CALLS
IOFFTM = 0
IF(IDATEZ .LT. 0) THEN
CALL SLDATE(IUNTDC,IDATCK,IUTCCK,IOFFTM)
CALL SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM)
IF(FILES .AND. IDATCK .EQ. IDATEZ .AND. IUTCCK .EQ. IUTCZ) THEN
WRITE(6,1) FILES,IDATCK,IUTCCK
1 FORMAT(/'######WITH FILES=',L2,' THIS PROGRAM HAS RUN PREVIOUSLY',
1 ' FOR DATE,TIME=',I9,I5)
ISTOP=5
GO TO 1000
ENDIF
ENDIF
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAY0)
HROFF =IOFFTM*.01
CYCOFF=(1.0+HROFF)/24.
IF(HROFF .GT. 24.) HROFF=-99.99
WRITE(6,2) IOFFTM,CYCOFF
2 FORMAT(/'...OFFTIM,CYCOFF=',I12,F12.5)
C THE MINIMUM WINDOW DETERMINES THE OLDEST RECORD THAT CAN
C BE PROCESSED BY QUALITY CONTROL. IT IS ALSO THE TIME COVERED
C BY THE SHORT-TERM HISTORICAL STORMS IN THE WORKING FILE.
C THERE ARE TWO MAXIMUM WINDOWS: THE SHORT ONE (DAYMX1=2 HR) IS
C FOR PROCESSING RECORDS NO LATER THAN THE CYCLE TIME. THE
C LARGER ONE (DAYMX2) EXTENDS TO THE CURRENT TIME (THE TIME AT
C WHICH THIS PROGRAM IS RUN) PLUS 1 HOUR. RECORDS LATER THAN
C DAYMX1 BUT EARLIER THAN DAYMX2 WILL BE "THROWN BACK INTO
C THE POND" AND WILL BE PROCESSED AT THE NEXT CYCLE.
DAYMIN=DAY0-WINMIN
DAYMX1=DAY0+WINMX1
DAYMX2=DAY0+CYCOFF
DAYCUR=DAY0-WINCUR
DAYOFF=0.0
DAYMX1=DAYMX1+DAYOFF
WRITE(6,3) WINMIN,WINMX1,DAYMIN,DAYMX1,DAYMX2
3 FORMAT(/'...WINMIN,WINMX1,DAYMIN,DAYMX1,DAYMX2=',/,4X,5F12.3)
WRITE(6,5) IDATEZ,IUTCZ,DAY0,RUNID,LNDFIL,FILES
5 FORMAT(20X,'***********************************************'/
1 20X,'***********************************************'/
2 20X,'**** WELCOME TO SYNDAT_QCTROPCY ****'/
3 20X,'**** Y2K/F90 VERSION - 17 MARCH 2013 ****'/
4 20X,'**** ****'/
5 20X,'**** VITAL STATISTICS RECORD CHECKER ****'/
6 20X,'**** FOR DATE=',I8,' UTC=',I4.4,10X,'****'/
7 20X,'**** JULIAN DAY=',F10.3,16X,'****'/
8 20X,'**** RUNID=',A12,' LNDFIL=',L1,' FILES=',L1,4X,'****'/
9 20X,'**** 1) INPUT RECORDS ARE CHECKED FOR ****'/
O 20X,'**** EXACT DUPLICATES ****'/
1 20X,'**** 2) QUALITY CONTROL CHECKS. ****'/
2 20X,'**** FIRST: PRIMARY INFORMATION ****'/
3 20X,'**** (RECOVERY IS ESSENTIAL) ****'/
4 20X,'**** A) ALL COLUMNS ****'/
5 20X,'**** B) DATE/TIME ****'/
6 20X,'**** C) POSITION ****'/
7 20X,'**** SECOND: SECONDARY INFO. ****')
WRITE(6,6)
6 FORMAT(20X,'**** (RECOVERY FROM PERSIS.) ****'/
1 20X,'**** D) DIRECTION/SPEED ****'/
2 20X,'**** E) RMAX, PENV, PCEN, STM DEPTH ****'/
3 20X,'**** THIRD: TERTIARY INFORMATION ****'/
4 20X,'**** (RECOVERY DESIRABLE) ****'/
5 20X,'**** F) VMAX, RMW ****'/
6 20X,'**** G) R15 NE, SE, SW, NW ****'/
7 20X,'**** ****'/
8 20X,'***********************************************'/
9 20X,'***********************************************'/)
WRITE(6,7) IUNTSL,IUNTDT,IUNTSN,IUNTOK,IUNTCU,IUNTAL,IUNTAN,
1 IUNTCA,IUNTCN,IUNTHO,IUNTHA,IUNTHL,IUNTVI
7 FORMAT(20X,'I/O UNITS ARE:'/
1 22X,'SEA/LAND MASK =IUNTSL =',I3/
2 22X,'RUN DATE (YYYYMMDDHH) =IUNTDT =',I3/
3 22X,'STORM NAMES =IUNTSN =',I3/
4 22X,'PRELIMINARY Q/C RECORDS =IUNTOK =',I3/
5 22X,'FINAL Q/C RECORDS =IUNTCU =',I3/
6 22X,'STORM ID ALIAS =IUNTAL =',I3/
7 22X,'NEW STORM ID ALIAS =IUNTAN =',I3/
8 22X,'STORM CATALOG =IUNTCA =',I3/
9 22X,'SCRATCH STORM CATALOG =IUNTCN =',I3/
O 22X,'SHORT TERM HIST. (ORIG.)=IUNTHO =',I3/
1 22X,'SHORT TERM HIST. (ALIAS)=IUNTHA =',I3/
2 22X,'LONG TERM HIST. =IUNTHL =',I3/
3 22X,'NEW RECORDS =IUNTVI>=',I3)
C SET UP THE T126 32-BIT SEA-LAND MASK ON GAUSSIAN GRID
C NTEST,NOKAY,NBAD ARE ALL MEANINGLESS NUMBERS AT THIS POINT
NTEST=1
NOKAY=1
NBAD =1
CALL SETMSK(IUNTSL,NTEST,NOKAY,NBAD,IECOST,IEFAIL(1:MAXREC,4),
1 NUMTST,NUMOKA,NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,
2 OKAREC)
C INITIAL CHECKS ARE FOR EXACT DUPLICATES AND BLANKS IN THE
C CORRECT SPOT
NOKAY=0
NBAD=0
CALL DUPCHK(IUNTVI,MAXUNT,MAXREC,IERCHK,NTEST,IEFAIL(1:MAXREC,0),
1 NUMTST,DUMREC,TSTREC,BADREC,*500)
C SAVE THE INPUT UNIT NUMBERS FOR ALL RECORDS
IUNTIN(1:NTEST)=IEFAIL(1:NTEST,0)
C
CALL BLNKCK(NTEST,NOKAY,NBAD,IEFAIL(1:MAXREC,1),NUMTST,NUMOKA,
1 NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
C RELOAD THE TEST RECORDS
NTEST=NOKAY
NUMTST(1:NOKAY)=NUMOKA(1:NOKAY)
TSTREC(1:NOKAY)=OKAREC(1:NOKAY)
NOKAY=0
CALL READCK(NTEST,NOKAY,NBAD,IEFAIL(1:MAXREC,2),NUMTST,NUMOKA,
1 NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
C RELOAD THE TEST RECORDS AGAIN
NTEST=NOKAY
NUMTST(1:NOKAY)=NUMOKA(1:NOKAY)
TSTREC(1:NOKAY)=OKAREC(1:NOKAY)
NOKAY=0
NTBP=MAXTBP
C
CALL DTCHK(NTEST,NOKAY,NBAD,NTBP,IEFAIL(1:MAXREC,3),NUMTST,NUMOKA,
1 NUMBAD,NUMTBP,DAYMIN,DAYMX1,DAYMX2,DAYOFF,TSTREC,
2 BADREC,OKAREC,TBPREC)
C ENCORE, UNE FOIS
NTEST=NOKAY
NUMTST(1:NOKAY)=NUMOKA(1:NOKAY)
TSTREC(1:NOKAY)=OKAREC(1:NOKAY)
NOKAY=0
CALL LLCHK(IUNTSL,NTEST,NOKAY,NBAD,IEFAIL(1:MAXREC,4),NUMTST,
1 NUMOKA,NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
C ONE MORE TIME (POUR CEUX QUI NE PARLE PAS FRANCAIS)
NTEST=NOKAY
NUMTST(1:NOKAY)=NUMOKA(1:NOKAY)
TSTREC(1:NOKAY)=OKAREC(1:NOKAY)
NOKAY=0
CALL STIDCK(IUNTHO,IUNTSN,IUNTCA,NTEST,IYR,MAXREC,NOKAY,NBAD,
1 IEFAIL(1:MAXREC,5),IDUPID,NUMTST,NUMOKA,NUMBAD,ZZZREC,
2 NNNREC,TSTREC,BADREC,OKAREC,SCRATC)
C *****************************************************************
C *****************************************************************
C **** ****
C **** END OF THE FIRST PHASE OF ERROR CHECKING. FROM NOW ****
C **** ON, THE ORIGINAL RECORD SHORT-TERM HISTORY FILE IS ****
C **** CLOSED AND THE ALIAS SHORT-TERM HISTORY FILE IS OPEN. ****
C **** SOME INPUT RECORDS MAY BE CHANGED DUE TO SUBSTITUTION ****
C **** OF MISSING VALUES OR AVERAGING OF MULTIPLE STORM ****
C **** REPORTS. ****
C **** ****
C *****************************************************************
C *****************************************************************
C MULTIPLE RSMC CHECK: SAME STORM REPORTED BY MORE THAN ONE
C TROPICAL CYCLONE WARNING CENTER.
C CHECK FOR:
C 1) MULTIPLE STORM REPORTS BY DIFFERENT RSMC'S AT THE SAME TIME
C 2) TIME SERIES OF REPORTS ON THE SAME STORM BY DIFFERENT RSMC'S
C RECONCILE THE ABOVE:
C 1) ASSIGN A COMMON STORM ID
C 2) REMOVE MULTIPLE REPORTS IN FAVOR OF A SINGLE REPORT WITH THE
C COMMON STORM ID AND COMBINED (AVERAGED) PARAMETERS IF
C NECESSARY
CCCC NTEST=NOKAY
CCCC WRITE(6,61) XXXREC
CCC61 FORMAT(///'...THE FOLLOWING ACCEPTABLE RECORDS ARE ELIGIBLE FOR ',
CCCC 1 'THE MULTIPLE RSMC CHECK.'/4X,'ERROR CODES ARE:'/21X,
CCCC 2 '=0: NO ERRORS OCCURRED'/21X,'<0: SUCCESSFUL ERROR ',
CCCC 3 'RECOVERY',55X,A/)
CCCC DO NOK=1,NOKAY
CCCC NUMTST(NOK)=NUMOKA(NOK)
CCCC TSTREC(NOK)=OKAREC(NOK)
CCCC WRITE(6,67) NOK,OKAREC(NOK)(1:MAXCHR),(IEFAIL(NUMOKA(NOK),ICK),
CCCC 1 ICK=0,MAXCKS)
67 FORMAT('...',I3,'...',A,'...',I2,8I3)
CCCC ENDDO
CCCC NOKAY=0
CCCC REWIND IUNTOK
c Stopgap measure is to not allow records to be written into
c the alias short-term history file (17 Sept. 1998)
NRCOVR=0
CCCC CALL RSMCCK(IUNTHO,IUNTHA,IUNTAL,IUNTAN,IUNTCA,IUNTOK,NVSBRS,
CCCC 1 IVSBRS,MAXREC,NTEST,NOKAY,NBAD,NRCOVR,
CCCC 2 IEFAIL(1:MAXREC,6),NUMTST,NUMOKA,NUMBAD,IDUPID,TSTREC,
CCCC 3 BADREC,OKAREC,SCRATC)
C COPY ALIAS SHORT-TERM HISTORY RECORDS FROM THE PRELIMINARY
C (SCRATCH) FILE TO THE ALIAS SHORT-TERM HISTORY FILE ONLY
C WHEN WE WISH TO UPDATE THE SHORT-TERM HISTORY FILE.
IF(FILES) THEN
ICALL=1
REWIND IUNTHA
WRITE(6,93)
93 FORMAT(/'...THE FOLLOWING RECORDS WILL BE COPIED FROM THE ',
1 'PRELIMINARY QUALITY CONTROLLED FILE TO THE ALIAS ',
2 'SHORT-TERM HISTORICAL FILE:')
CALL CPYREC(ICALL,IUNTOK,IUNTHA,NOKAY,DAYMIN,DUMREC,OKAREC)
ENDIF
C BEGIN CHECKS FOR SECONDARY STORM INFORMATION WHICH INCLUDES:
C 1) DIRECTION, SPEED
C 2) PCEN, PENV, RMAX, STORM DEPTH
C THESE NUMBERS ARE NEEDED BY YOGI. IF MISSING, WE TRY TO
C FILL THEM IN BY PERSISTENCE.
C FIRST, COPY HISTORICAL RECORDS TO THE PRELIMINARY QUALITY
C CONTROLLED FILE AND THEN COPY THE RECORDS FROM THE CURRENT FILE.
C COPY HISTORICAL RECORDS TO PRELIMINARY FILE, CHECK FOR DUPLICATES
REWIND IUNTOK
IF(FILES) THEN
ICALL=3
WRITE(6,95) DAYMIN,ICALL
95 FORMAT(/'...THE FOLLOWING RECORDS, HAVING DATES GREATER THAN ',
1 'OR EQUAL TO DAY',F10.3,', WILL BE CHECKED FOR EXACT ',
2 'AND PARTIAL DUPLICATES '/4X,'(ICALL=',I2,')',
3 'AND COPIED FROM THE ALIAS SHORT-TERM HISTORICAL FILE ',
4 'TO THE PRELIMINARY QUALITY CONTROLLED FILE WHICH NOW ',
5 'WILL CONTAIN '/4X,'ALIAS RECORDS:'/)
CALL CPYREC(ICALL,IUNTHA,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC)
ELSE
WRITE(6,97)
97 FORMAT(/'...THE FOLLOWING RECORDS WILL BE COPIED FROM THE ',
1 'SCRATCH ARRAY TO THE PRELIMINARY QUALITY CONTROLLED ',
2 'FILE:')
DO NRC=1,NRCOVR
WRITE(6,105) SCRATC(NRC)
105 FORMAT(' ...',A,'...')
WRITE(IUNTOK,107) SCRATC(NRC)
107 FORMAT(A)
ENDDO
ENDIF
C OH NO, NOT AGAIN!!!
NTEST=NOKAY
write(6,1011) ntest
1011 format(/'***debug ntest=nokay=',i4/)
WRITE(6,111)
111 FORMAT(/'...IN PREPARATION FOR SECONDARY VARIABLE CHECKING, THE ',
1 'FOLLOWING ACCEPTABLE RECORDS WILL BE '/4X,'ADDED TO THE',
2 ' PRELIMINARY,QUALITY CONTROLLED FILE:'/)
DO NOK=1,NOKAY
NUMTST(NOK)=NUMOKA(NOK)
TSTREC(NOK)=OKAREC(NOK)
WRITE(6,113) NOK,NUMOKA(NOK),OKAREC(NOK)
113 FORMAT(' ...',I4,'...',I4,'...',A)
WRITE(IUNTOK,119) OKAREC(NOK)
119 FORMAT(A)
ENDDO
NOKAY=0
CALL SECVCK(IUNTOK,NTEST,NOKAY,NBAD,NUMTST,NUMOKA,NUMBAD,DAY0,
1 DAYMIN,DAYMX1,DAYOFF,IEFAIL(1:MAXREC,7),ZZZREC,NNNREC,
2 SCRREC,TSTREC,BADREC,OKAREC)
C COPY HISTORICAL RECORDS TO PRELIMINARY FILE, CHECK FOR DUPLICATES
REWIND IUNTOK
IF(FILES) THEN
ICALL=3
WRITE(6,95) DAYMIN,ICALL
CALL CPYREC(ICALL,IUNTHA,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC)
ELSE
WRITE(6,97)
DO NRC=1,NRCOVR
WRITE(6,105) SCRATC(NRC)
WRITE(IUNTOK,107) SCRATC(NRC)
ENDDO
ENDIF
NTEST=NOKAY
WRITE(6,201)
201 FORMAT(//'...THE FOLLOWING ACCEPTABLE RECORDS WILL BE ADDED TO ',
1 'THE PRELIMINARY QUALITY CONTROLLED FILE '/4X,'IN ',
2 'PREPARATION FOR DIRECTION/SPEED CHECKING.'/)
DO NOK=1,NOKAY
NUMTST(NOK)=NUMOKA(NOK)
TSTREC(NOK)=OKAREC(NOK)
WRITE(6,203) NOK,OKAREC(NOK)
203 FORMAT(' ...',I4,'...',A)
WRITE(IUNTOK,207) OKAREC(NOK)
207 FORMAT(A)
ENDDO
NOKAY=0
C SEA/LAND MASK CHECK
CALL SELACK(NTEST,NOKAY,NBAD,IECOST,IEFAIL(1:MAXREC,4),NUMTST,
1 NUMOKA,NUMBAD,LNDFIL,ZZZREC,NNNREC,TSTREC,BADREC,
2 OKAREC)
WRITE(6,301) XXXREC
301 FORMAT(/'...THE SECONDARY VARIABLE, DIR/SPD AND SEA/LAND ',
1 'CHECKING HAVE CONCLUDED. ERROR CHECKING HAS ENDED.'/4X,
2 'OKAY RECORDS AND ERROR CODES ARE:',69X,A/)
DO NOK=1,NOKAY
WRITE(6,67) NOK,OKAREC(NOK)(1:MAXCHR),IEFAIL(NUMOKA(NOK),0),
1 (-IABS(IEFAIL(NUMOKA(NOK),ICK)),
1 ICK=1,MAXCKS)
ENDDO
WRITE(6,311) XXXREC
311 FORMAT(/'...BAD RECORDS AND ERROR CODES ARE:',71X,A/)
DO NBA=1,NBAD
WRITE(6,67) NBA,BADREC(NBA)(1:MAXCHR),IEFAIL(NUMBAD(NBA),0),
1 (IEFAIL(NUMBAD(NBA),ICK),ICK=1,MAXCKS)
ENDDO
C RECONCILE THE STORM IDS WITH THE STORM CATALOG
C LET'S PRETEND WE'RE NOT GOING TO DO IT, BUT DO IT ANYWAY
NTEST=NOKAY+NBAD
WRITE(6,401) XXXREC
401 FORMAT(///'...THE FOLLOWING ACCEPTABLE RECORDS WILL BE ',
1 'RECONCILED WITH THE STORM CATALOG.'/4X,'ERROR CODES ',
2 'ARE:'/21X,'=0: NO ERRORS OCCURRED'/21X,'<0: ',
3 'SUCCESSFUL ERROR RECOVERY',56X,A/)
DO NOK=1,NOKAY
NUMTST(NOK)=NUMOKA(NOK)
TSTREC(NOK)=OKAREC(NOK)
WRITE(6,67) NOK,OKAREC(NOK)(1:MAXCHR),IEFAIL(NUMOKA(NOK),0),
1 (IEFAIL(NUMOKA(NOK),ICK),ICK=1,MAXCKS)
ENDDO
WRITE(6,411) XXXREC
411 FORMAT(//'...THE FOLLOWING BAD RECORDS WILL BE RECONCILED WITH ',
1 'THE STORM CATALOG FOR OVERLAND OR OVERLAPPING STORM ',
2 'CASES.'/4X,'ERROR CODES ARE:'/21X,'>0: ERROR FOUND',70X,
3 A/)
DO NBA=1,NBAD
NUMTST(NOKAY+NBA)=NUMBAD(NBA)
TSTREC(NOKAY+NBA)=BADREC(NBA)
IF(IEFAIL(NUMBAD(NBA),4) .EQ. 5 .OR.
1 IEFAIL(NUMBAD(NBA),4) .EQ. 6 .OR.
2 IEFAIL(NUMBAD(NBA),6) .EQ. 22) THEN
WRITE(6,67) NBA+NOKAY,BADREC(NBA)(1:MAXCHR),IEFAIL(NUMBAD(NBA),0),
1 (IEFAIL(NUMBAD(NBA),ICK),ICK=1,MAXCKS)
ENDIF
ENDDO
call rcncil(iuntca,iuntcn,iuntal,ntest,nokay,nbad,maxrec,maxcks,
1 iefail,ierrcn,idupid,numtst,numoka,numbad,tstrec,
2 badrec,okarec)
C CLEAR OUT THE TEMPORARY ALIAS FILE; AKAVIT IS IN ITS FINAL FORM.
REWIND IUNTAN
END FILE IUNTAN
C ERROR CHECKING HAS FINALLY ENDED
500 WRITE(6,501) XXXREC
501 FORMAT(//'...THE FINAL ERROR CHECKING HAS ENDED. BAD RECORDS ',
1 'AND ERROR CODES ARE:',36X,A/)
ISTP90=0
ISTPBR=0
DO NBA=1,NBAD
DO NCK=1,MAXCKS
C SELECT APPROPRIATE CONDITION CODE FOR STOP
IF(IEFAIL(NUMBAD(NBA),NCK) .EQ. 2 .AND. NCK .EQ. 5) THEN
ISTP90=1
ELSE IF(IEFAIL(NUMBAD(NBA),NCK) .NE. 0) THEN
ISTPBR=2
ENDIF
ENDDO
WRITE(6,543) NBA,BADREC(NBA)(1:MAXCHR),(IEFAIL(NUMBAD(NBA),ICK),
1 ICK=0,MAXCKS)
543 FORMAT(' ...',I3,'...',A,'...',I2,8I3)
ENDDO
ISTOP=ISTP90+ISTPBR
IF(IERCHK .EQ. 161) ISTOP=04
IF(IERRCN .NE. 0) ISTOP=10
WRITE(6,551) ISTP90,ISTPBR,IERRCN,ISTOP
551 FORMAT(/'...STOP CODES ARE: ISTP90,ISTPBR,IERRCN,ISTOP=',4I3)
C ADD FIRST OCCURRENCE FLAGS BY CHECKING THE SHORT-TERM HISTORY
C FILE
CALL ADFSTF(IUNTHA,NOKAY,NBAD,MAXREC,MAXCKS,IECOST,NUMBAD,IEFAIL,
1 DUMREC,OKAREC,BADREC)
C WRITE THE RESULTS OF THE Q/C PROGRAM TO A LONG-TERM HISTORICAL
C FILE
NRTOT=NOKAY+NBAD
CALL RITHIS(-IUNTHL,IEFAIL,NRTOT,IDATEZ,IUTCZ,NUMOKA,NOKAY,MAXREC,
1 MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES,OKAREC,ZZZREC,
2 XXXREC)
CALL RITHIS(IUNTHL,IEFAIL,NRTOT,IDATEZ,IUTCZ,NUMBAD,NBAD,MAXREC,
1 MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES,BADREC,ZZZREC,
2 ZZZREC)
C UPDATE THE SHORT-TERM HISTORY FILES.
C **** IMPORTANT NOTE: ALL INFORMATION FROM TSTREC,OKAREC,BADREC,
C NUMTST,NUMOKA,NUMBAD WILL BE LOST ****
C **** PRENEZ GARDE ****
IF(FILES) THEN
CALL RITSTH(IUNTHA,IUNTHO,IUNTOK,NOKAY,NBAD,DAYMIN,IECOST,MAXCKS,
1 MAXREC,NUMBAD,IEFAIL,DUMREC,OKAREC,BADREC)
CALL FNLCPY(IUNTVI,MAXUNT,IUNTOK,IUNTHA,MAXREC,NTBP,NUMTBP,IUNTIN,
1 TBPREC,DUMREC)
NTEST=0
NOKAY=0
IUNTRD=IUNTOK
C NOPE: SORRY, ONE LAST TIME, BUT ONLY FOR FILES=.FALSE.
ELSE
NTEST=NOKAY
IUNTRD=IUNTHA
NUMTST(1:NOKAY)=NUMOKA(1:NOKAY)
TSTREC(1:NOKAY)=OKAREC(1:NOKAY)
NOKAY=0
ENDIF
C WRITE THE FILE CONTAINING ALL CURRENT QUALITY CONTROLLED RECORDS
CALL YTIME(IYR,DAYCUR+FIVMIN,IDATCU,JUTCCU)
CALL RITCUR(IUNTRD,IUNTCU,NTEST,NOKAY,NBAD,IDATCU,JUTCCU,DAYCUR,
1 MAXREC,IEFAIL(1:MAXREC,4),NUMTST,NUMOKA,NUMBAD,FILES,
2 LNDFIL,ZZZREC,NNNREC,DUMREC,SCRREC,TSTREC,OKAREC,
3 BADREC)
C CLEAN OUT THE SCRATCH FILE
REWIND IUNTOK
END FILE IUNTOK
1000 CONTINUE
IF(FILES) CALL SLDTCK(IUNTDC)
WRITE(6,1115)
1115 FORMAT(////20X,'*******************************************'
1 /20X,'*******************************************'
2 /20X,'**** ****'
3 /20X,'**** SUCCESSFUL COMPLETION OF ****'
4 /20X,'**** SYNDAT_QCTROPCY ****'
5 /20X,'**** ****'
6 /20X,'*******************************************'
7 /20X,'*******************************************')
CALL W3TAGE('SYNDAT_QCTROPCY')
ccccc IF(ISTOP .EQ. 0) THEN
STOP
ccccc ELSE IF(ISTOP .EQ. 1) THEN
ccccc call ERREXIT (1)
ccccc ELSE IF(ISTOP .EQ. 2) THEN
ccccc call ERREXIT (2)
ccccc ELSE IF(ISTOP .EQ. 3) THEN
ccccc call ERREXIT (3)
ccccc ELSE IF(ISTOP .EQ. 04) THEN
ccccc call ERREXIT (4)
ccccc ELSE IF(ISTOP .EQ. 05) THEN
ccccc call ERREXIT (5)
ccccc ELSE IF(ISTOP .EQ. 10) THEN
ccccc call ERREXIT (10)
ccccc ENDIF
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: RSMCCK CHECKS FOR MULTIPLE STORM REPORTS
C PRGMMR: S. LORD ORG: NP22 DATE: 1992-02-19
C
C ABSTRACT: INPUT RECORDS ARE CHECKED FOR MULTIPLE REPORTS ON THE SAME
C STORM FROM DIFFERENT RSMC'S. THE FOLLOWING ACTIONS ARE
C TAKEN:
C 1) MULTIPLE STORM REPORTS BY DIFFERENT RSMC'S AT THE SAME
C TIME ARE REMOVED
C 2) TIME SERIES OF REPORTS ON THE SAME STORM BY DIFFERENT
C RSMC'S ARE DISCOVERED
C TO RECONCILE THE ABOVE:
C 1) A COMMON STORM ID IS ASSIGNED
C 2) MULTIPLE REPORTS ARE REMOVED IN FAVOR OF A SINGLE
C REPORT WITH THE COMMON STORM ID AND COMBINED
C (AVERAGED) PARAMETERS IF NECESSARY
C
C PROGRAM HISTORY LOG:
C 1992-02-19 S. LORD
C 1992-07-16 S. LORD FIXED SOME BUGS (390); ADDED RETURN CODE 2.
C 1993-03-09 S. LORD ADDED CODE FOR COMPATIBILITY WITH RCNCIL
C 2013-10-10 D. C. STOKES - ADDED NON-HYPHNATED CARDINAL NUMBER NAMES
C ALSO EXTENDED THAT LIST (FROM 36 TO 39).
C
C USAGE: CALL RSMCCK(IUNTHO,IUNTHA,IUNTAL,IUNTAN,IUNTOK,NVSBRS,IVSBRS,
C MAXOVR,NTEST,NOKAY,NBAD,NRCOVR,IFRSMC,NUMTST,
C NUMOKA,NUMBAD,IOVRLP,TSTREC,BADREC,OKAREC,OVRREC)
C INPUT ARGUMENT LIST:
C IUNTHO - UNIT NUMBER FOR SHORT-TERM HISTORY FILE OF ORIGINAL
C - RECORDS.
C IUNTHA - UNIT NUMBER FOR SHORT-TERM HISTORY FILE OF ALIASED
C - RECORDS.
C IUNTAL - UNIT NUMBER FOR ALIAS FILE.
C IUNTAN - UNIT NUMBER FOR NEW ALIAS FILE.
C IUNTOK - UNIT NUMBER FOR SCRATCH FILE.
C NVSBRS - NUMBER OF ALLOWABLE VARIABLES FOR SUBSTITUTION.
C IVSBRS - INDEX OF ALLOWABLE VARIABLES FOR SUBSTITUTION.
C MAXOVR - DIMENSION FOR SCRATCH SPACE.
C NTEST - NUMBER OF CURRENT RECORDS TO BE TESTED.
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C IOVRLP - SCRATCH ARRAY.
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE RSMC CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE RSMC CHECK.
C NRCOVR - NUBER OF RECORDS RETURNED IN OVRREC. THESE CONTAIN
C - UPDATED ALIAS SHORT-TERM HISTORY RECORDS FOR USE WHEN
C - FILES=F.
C IFRSMC - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE RSMC CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE RSMC CHECK.
C OVRREC - CHARACTER ARRAY CONTAINING UPDATED ALIAS SHORT-TERM
C - HISTORY RECORDS.
C
C INPUT FILES:
C UNIT 20 - SCRATCH FILE CONTAINING SHORT-TERM HISTORY RECORDS
C UNIT 21 - ORIGINAL SHORT-TERM HISTORY FILE CONTAINING RECORDS
C PROCESSED BY THIS PROGRAM FOR THE LAST SEVERAL DAYS.
C IN THIS FILE, THE ORIGINAL RSMC AND STORM ID ARE KEPT.
C UNIT 22 - ALIAS SHORT-TERM HISTORY FILE CONTAINING RECORDS
C PROCESSED BY THIS PROGRAM FOR THE LAST SEVERAL DAYS.
C IN THIS FILE, THE RSMC AND STORM ID HAVE BEEN UNIFIED.
C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB
C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 20 - SCRATCH FILE CONTAINING SHORT-TERM HISTORY RECORDS
C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB
C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C - NOTE: UCL SHOULD COPY THIS FILE TO FT22F001 (THE OLD
C - ALIAS FILE) AT THE END OF EXECUTION.
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE RSMCCK(IUNTHO,IUNTHA,IUNTAL,IUNTAN,IUNTCA,IUNTOK,
1 NVSBRS,IVSBRS,MAXOVR,NTEST,NOKAY,NBAD,NRCOVR,
2 IFRSMC,NUMTST,NUMOKA,NUMBAD,IOVRLP,TSTREC,
3 BADREC,OKAREC,OVRREC)
PARAMETER (NERCRS=10)
PARAMETER (MAXSTM=70)
PARAMETER (NOVRMX=MAXSTM)
PARAMETER (NADDMX=10)
PARAMETER (MAXREC=1000)
SAVE
CHARACTER*(*) TSTREC(0:NTEST),BADREC(MAXREC),OKAREC(NTEST),
1 ERCRS(NERCRS)*60,OVRREC(MAXOVR)
CHARACTER*100 DUMY2K
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (NBASIN=11)
PARAMETER (NRSMCX=4)
PARAMETER (NRSMCW=2)
PARAMETER (NCRDMX=57)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,NAMVAR*5,
2 IDBASN*1,NABASN*16,RSMCID*4,RSMCAP*1,CARDNM*9
DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT),
1 ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION NAMVAR(MAXVIT+1),IDBASN(NBASIN),NABASN(NBASIN),
1 BUFIN(MAXCHR),FMTVIT(MAXVIT),
2 RSMCID(NRSMCX),RSMCAP(NRSMCX),RSMCPR(NBASIN),
3 RSMCWT(NRSMCW),CARDNM(NCRDMX)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ),
1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ),
2 (VITVAR( 7),PCENZ), (VITVAR( 8),PENVZ),
3 (VITVAR( 9),RMAXZ)
CHARACTER STMNAM*9,STMID*3,RSMC*4
DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
1 IDATE(MAXSTM),IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),
2 PCEN(MAXSTM),RSMC(MAXSTM),STMID(MAXSTM)
DIMENSION IFRSMC(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC),
1 NUMTST(NTEST),IOVRLP(MAXOVR),IVSBRS(0:NVSBRS)
DIMENSION IVTVRX(MAXVIT),VITVRX(MAXVIT)
DIMENSION IPRIOR(NOVRMX),AVWT(NOVRMX),RSMCAL(NOVRMX),
1 STIDAL(NOVRMX),STNMAD(NOVRMX),IRSMC(4),SRTDAY(NOVRMX),
2 IDASRT(NOVRMX),INDSAM(NOVRMX),DAYZAD(NADDMX),
3 RSMCOV(NOVRMX),STIDOV(NOVRMX),
4 RSMCAD(NADDMX),STIDAD(NADDMX)
DIMENSION RINC(5)
CHARACTER BUFCK(MAXCHR)*1,RSMCX*4,RELOCX*1,STMIDX*3,BUFINX*100,
1 STMNMX*9,LATNSX*1,LONEWX*1,BSCOFL*2,RPCOFL*2,STNMAL*9,
2 RSMCAL*4,STIDAL*3,STNMAD*9,RSMCOV*4,STIDOV*3,STNMOV*9,
3 STIDAD*3,RSMCAD*4,STHCH*21
LOGICAL OSTHFL
EQUIVALENCE (BUFCK(1),RSMCX),(BUFCK(5),RELOCX),(BUFCK(6),STMIDX),
1 (BUFCK(1),BUFINX),(BUFCK(10),STMNMX),
2 (BUFCK(35),LATNSX),(BUFCK(41),LONEWX)
EQUIVALENCE (IVTVRX(1),IDATEX),(IVTVRX(2),IUTCX),
1 (VITVRX(3),STMLTX),(VITVRX(4),STMLNX),
2 (VITVRX(5),STMDRX),(VITVRX(6),STMSPX),
3 (VITVRX(7),PCENX), (VITVRX(8),PENVX),
4 (VITVRX(9),RMAXX)
DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/,
1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/
DATA NABASN/'ATLANTIC ','EAST PACIFIC ',
1 'CENTRAL PACIFIC ','WEST PACIFIC ',
2 'SOUTH CHINA SEA ','EAST CHINA SEA ',
3 'AUSTRALIA ','SOUTH PACIFIC ',
4 'SOUTH INDIAN OCN','BAY OF BENGAL ',
5 'NRTH ARABIAN SEA'/
DATA RSMCID/'NHC ','JTWC','ADRM','JMA '/,
1 RSMCAP/'N','W','A','J'/,RSMCPR/3*1,3*2,3,4*2/,
2 RSMCWT/1.0,0.25/
DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED',
1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE',
2 'R15SE','R15SW','R15NW','DEPTH'/
C CARDINAL NUMBER STORM NAMES FOR UNNAMED ATLANTIC AND EAST PACIFIC
C STORMS
DATA CARDNM/'ONE ','TWO ','THREE ',
1 'FOUR ','FIVE ','SIX ',
2 'SEVEN ','EIGHT ','NINE ',
3 'TEN ','ELEVEN ','TWELVE ',
4 'THIRTEEN ','FOURTEEN ','FIFTEEN ',
5 'SIXTEEN ','SEVENTEEN','EIGHTEEN ',
6 'NINETEEN ','TWENTY ','TWENTY-ON',
7 'TWENTY-TW','TWENTY-TH','TWENTY-FO',
8 'TWENTY-FI','TWENTY-SI','TWENTY-SE',
9 'TWENTY-EI','TWENTY-NI','THIRTY ',
O 'THIRTY-ON','THIRTY-TW','THIRTY-TH',
1 'THIRTY-FO','THIRTY-FI','THIRTY-SI',
2 'THIRTY-SE','THIRTY-EI','THIRTY-NI',
3 'TWENTYONE','TWENTYTWO','TWENTYTHR',
4 'TWENTYFOU','TWENTYFIV','TWENTYSIX',
5 'TWENTYSEV','TWENTYEIG','TWENTYNIN',
6 'THIRTYONE','THIRTYTWO','THIRTYTHR',
7 'THIRTYFOU','THIRTYFIV','THIRTYSIX',
8 'THIRTYSEV','THIRTYEIG','THIRTYNIN'/
C BUFZON: BUFFER ZONE REQUIRED BY SYNTHETIC DATA PROGRAM (SYNDATA)
C DEGLAT: ONE DEGREE LATITUDE IN KM
C RMAXMN: MINIMUM ALLOWABLE VALUE OF RMAX
C DTOVR : MINIMUM WINDOWN (FRACTIONAL DAYS) FOR OVERLAPPING STORMS
C EXTRAPOLATED TO A COMMON TIME.
C IPRT : CONTROLS PRINTOUT IN SUBROUTINE BASNCK
C FACSPD: CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)*
C FACSPD
DATA BUFZON/1.0/,DEGLAT/111.1775/,RMAXMN/100./,DTOVR/1.0/,
1 IPRT/0/,FIVMIN/3.4722E-3/,FACSPD/0.77719/
DATA ERCRS
1 /' 1: CANNOT RESOLVE: SAME RSMC REPORTED OVERLAPPING STORMS ',
2 '10: RESOLVED: SAME RSMC REPORTED OVERLAPPING STORMS ',
3 ' 2: CANNOT RESOLVE: DIFF. RSMCS REPORTED DIFF. OVERL. STMS.',
4 '21: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (CUR) ',
5 '22: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (OSTH)',
6 '30: UNIFIED RECORD CREATED FOR SINGLY OBSERVED STORM ',
7 ' 3: STORM IS NOT IN A BASIN DEFINED BY BASNCK ',
8 ' 4: RSMC IS NOT AMONG LISTED CENTERS (NO ERROR RECOVERY) ',
9 ' 5: DIFFERENT RSMCS REPORTED DIFFERENT OVERLAPPING STORMS ',
O ' 6: SINGLE RSMC HAS TWO STORM IDS FOR THE SAME STORM '/
C ERROR CODES FOR BAD RECORDS RETURNED IN IFRSMC ARE AS FOLLOWS:
C 1: CANNOT RESOLVE: SAME RSMC REPORTED OVERLAPPING STORMS
C 10: RESOLVED: SAME RSMC REPORTED OVERLAPPING STORMS
C 2: CANNOT RESOLVE: DIFF. RSMCS REPORTED DIFF. OVERL. STMS.
C 21: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (CUR)
C 22: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (OSTH)
C 30: UNIFIED RECORD CREATED FOR SINGLY OBSERVED STORM
C 3: STORM IS NOT IN A BASIN DEFINED BY BASNCK
C 4: RSMC IS NOT AMONG LISTED CENTERS (NO ERROR RECOVERY)
C 5: TWO DIFFERENT RSMCS REPORT DIFFERENT OVERLAPPING STORMS
C 6: SINGLE RSMC HAS TWO STORM IDS FOR THE SAME STORM
WRITE(6,1) NTEST,NOKAY,NBAD
1 FORMAT(//'...ENTERING RSMCCK, LOOKING FOR MULTIPLE STORM ',
1 'REPORTS. NTEST,NOKAY,NBAD=',3I5/)
CALL WRNING('RSMCCK')
WRITE(6,3) NVSBRS,(NAMVAR(IVSBRS(NV)),NV=1,NVSBRS)
3 FORMAT(/'...NUMBER OF ALLOWABLE VARIABLES FOR SUBSTITUTION ',
1 'IS:',I3,' VARIABLES ARE:'/4X,10(A,1X))
NADD=0
NSUBR=0
NUNIFY=0
NALADD=0
REWIND IUNTAN
OVRREC(1:NTEST)=' '
IOVRLP(1:NTEST)=0
IFRSMC(NUMTST(1:NTEST))=0
C FOR COMPLETE COTEMPORANEOUS CHECKS, WE MUST MAKE AVAILABLE THE
C ORIGINAL SHORT-TERM HISTORY RECORDS. WE STORE THEM AT THE END
C OF THE OVRREC ARRAY.
REWIND IUNTHO
NRECHO=0
WRITE(6,13) IUNTHO
13 FORMAT(/'...READING FROM ORIGINAL SHORT-TERM HISTORY FILE ',
1 '(UNIT',I3,') INTO SCRATCH SPACE: RECORD #, STORAGE ',
2 'INDEX, RECORD=')
20 CONTINUE
READ(IUNTHO,21,END=25) OVRREC(MAXOVR-NRECHO)
21 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
if(OVRREC(MAXOVR-NRECHO)(35:35).eq.'N' .or.
1 OVRREC(MAXOVR-NRECHO)(35:35).eq.'S') then
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',OVRREC(MAXOVR-NRECHO)(20:21),'"'
PRINT *, ' '
PRINT *, 'From unit ',iuntho,'; OVRREC(MAXOVR-NRECHO)-2: ',
$ OVRREC(MAXOVR-NRECHO)
PRINT *, ' '
DUMY2K(1:19) = OVRREC(MAXOVR-NRECHO)(1:19)
IF(OVRREC(MAXOVR-NRECHO)(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = OVRREC(MAXOVR-NRECHO)(20:100)
OVRREC(MAXOVR-NRECHO) = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ OVRREC(MAXOVR-NRECHO)(20:23),'" via windowing technique'
PRINT *, ' '
PRINT *, 'From unit ',iuntho,'; OVRREC(MAXOVR-NRECHO)-2: ',
$ OVRREC(MAXOVR-NRECHO)
PRINT *, ' '
ELSE IF(OVRREC(MAXOVR-NRECHO)(37:37).eq.'N' .OR.
1 OVRREC(MAXOVR-NRECHO)(37:37).eq.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT '(a,a,a)', '==> Read in RECORD from tcvitals file -- ',
$ ' contains a 4-digit year "',OVRREC(MAXOVR-NRECHO)(20:23),'"'
PRINT *, ' '
PRINT '(a,i,a,a)',
$ 'From unit ',iuntho,'; OVRREC(MAXOVR-NRECHO)-2: ',
$ OVRREC(MAXOVR-NRECHO)
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 20
END IF
WRITE(6,23) NTEST+NRECHO+1,MAXOVR-NRECHO,OVRREC(MAXOVR-NRECHO)
23 FORMAT(' ...',I4,'...',I4,'...',A)
NRECHO=NRECHO+1
IF(NRECHO .GE. MAXOVR-NTEST) THEN
WRITE(6,24) NRECHO,MAXOVR,NTEST
24 FORMAT(/'******INSUFFICIENT SCRATCH SPACE TO STORE ORIGINAL ',
1 'SHORT-TERM HISTORICAL RECORDS IN OVRREC. NRECHO,',
2 'MAXOVR,NTEST=',3I3)
CALL ABORT1(' RSMCCK',24)
ENDIF
GO TO 20
25 CONTINUE
WRITE(6,26) NRECHO
26 FORMAT(' ...',I3,' RECORDS READ FROM ORIGINAL SHORT-TERM ',
1 'HISTORY FILE.')
C PART I:
C CHECK COTEMPORANEOUS RECORDS FOR STORMS WITHIN EACH OTHER'S RMAX
WRITE(6,27)
27 FORMAT(//'...BEGINNING RSMCCK PART I: COTEMPORANEOUS CHECKS FOR ',
1 'OVERLAPPING STORMS.')
DO NREC=1,NTEST
IETYP=0
IEROVR=0
NOVRLP=1
NRECSV=NREC
C RECORDS THAT WERE PROCESSED AS COTEMPORANEOUS OVERLAPS PREVIOUSLY
C DO NOT GET FURTHER PROCESSING
IF(IFRSMC(NUMTST(NREC)) .NE. 0) GO TO 400
C RECOVER DATE, UTC, LAT/LON AND RMAX
BUFINZ=TSTREC(NREC)
DO IV=1,MAX(9,IVSBRS(NVSBRS))
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NREC))
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
ENDDO
VITVAR(3:MAX(9,IVSBRS(NVSBRS)))=
$ REAL(IVTVAR(3:MAX(9,IVSBRS(NVSBRS))))*
$ VITFAC(3:MAX(9,IVSBRS(NVSBRS)))
IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ
IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ
C STORE NEEDED VARIABLES FOR LATER REFERENCE
STMNAM(1)=STMNMZ
STMID (1)=STMIDZ
RSMC (1)=RSMCZ
STMLAT(1)=STMLTZ
STMLON(1)=STMLNZ
RMAX (1)=RMAXZ
PCEN (1)=PCENZ
PENV (1)=PENVZ
IOVRLP(1)=NREC
OVRREC(1)=BUFINZ
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
IF(RMAXZ .LT. 0.0) THEN
DO NBA=1,NBASIN
IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN
IBASN=NBA
GO TO 46
ENDIF
ENDDO
46 CONTINUE
RMAXZ=TCCLIM(9,IBASN)
WRITE(6,47) NREC,RMAXZ,NABASN(IBASN)
47 FORMAT(' ###RMAXZ MISSING FOR COTEMPORANEOUS CHECK ON RECORD',I3,
1 '.'/4X,'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL ',
2 'GUESS OF ',F6.1,' KM FOR BASIN ',A,'.')
ENDIF
C NOW COMPARE WITH ALL REMAINING STORM REPORTS THAT HAVE NOT BEEN
C MARKED OFF AS ERRONEOUS
NRECHZ=-1
DO NTST=NREC+1,NTEST+NRECHO
IF(NTST .LE. NTEST .AND. IFRSMC(NUMTST(NTST)) .NE. 0) GO TO 100
IF(NTST .LE. NTEST) THEN
INDTST=NTST
BUFINX=TSTREC(NTST)
OSTHFL=.FALSE.
ELSE
NRECHZ=NRECHZ+1
INDTST=MAXOVR-NRECHZ
BUFINX=OVRREC(INDTST)
OSTHFL=.TRUE.
ENDIF
DO IV=1,MAX(9,IVSBRS(NVSBRS))
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV),
1 BUFINX)
ENDDO
VITVRX(3:MAX(9,IVSBRS(NVSBRS)))=
$ REAL(IVTVRX(3:MAX(9,IVSBRS(NVSBRS))))*
$ VITFAC(3:MAX(9,IVSBRS(NVSBRS)))
IF(LATNSX .EQ. 'S') STMLTX=-STMLTX
IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX
C COTEMPORANEOUS CHECK
IF(IDATEX .EQ. IDATEZ .AND. IUTCX .EQ. IUTCZ) THEN
RMAXSV=RMAXX
IF(RMAXX .LT. 0.0) THEN
DO NBA=1,NBASIN
IF(STMIDX(3:3) .EQ. IDBASN(NBA)) THEN
IBASN=NBA
GO TO 66
ENDIF
ENDDO
66 CONTINUE
RMAXX=TCCLIM(9,IBASN)
WRITE(6,75) NTST,RMAXX,NABASN(IBASN)
75 FORMAT(' ###RMAXX MISSING FOR COTEMPORANEOUS CHECK ON RECORD',I3,
1 '.'/4X,'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL ',
2 'GUESS OF ',F6.1,' KM FOR BASIN ',A,'.')
ENDIF
DISTZ=DISTSP(STMLTZ,STMLNZ,STMLTX,STMLNX)*1.E-3
C OVERLAP CHECK. BUFFER ZONE CORRESPONDS TO SYNDATA CONDITION
IF(DISTZ .LE. RMAXZ+RMAXX+BUFZON*DEGLAT) THEN
C IF THE MATCHING RECORD IS FROM THE SAME RSMC AND THE STORM
C ID IS THE SAME AND THE RECORD WAS IN THE ORIGINAL SHORT-TERM
C HISTORY FILE, WE ASSUME THE RECORD (NREC) IS AN UPDATE TO THE
C EARLIER RECORD. THE ERROR FLAG IS RESET TO INDICATE NO ERROR.
IF(RSMCZ .EQ. RSMCX .AND.
1 STMIDZ .EQ. STMIDX .AND. OSTHFL) THEN
WRITE(6,76) NREC,INDTST,NREC,BUFINZ,INDTST,BUFINX
76 FORMAT(/'###RECORD IN ORIGINAL SHORT-TERM HISTORY FILE HAS ',
1 'PROBABLY BEEN UPDATED . NREC,INDTST=',2I4,
2 '. RECORDS ARE:'/2(4X,'...',I4,'...',A/))
GO TO 100
ELSE
C STORE NEEDED VARIABLES FOR LATER REFERENCE. DON'T USE THE
C CLIMATOLOGICAL VALUE!
NOVRLP=NOVRLP+1
IOVRLP(NOVRLP)=NTST
OVRREC(NOVRLP)=BUFINX
STMNAM(NOVRLP)=STMNMX
STMID (NOVRLP)=STMIDX
RSMC (NOVRLP)=RSMCX
STMLAT(NOVRLP)=STMLTX
STMLON(NOVRLP)=STMLNX
RMAX (NOVRLP)=RMAXSV
PCEN (NOVRLP)=PCENX
PENV (NOVRLP)=PENVX
WRITE(6,77) DISTZ,NREC,NTST,INDTST,BUFINZ,BUFINX
77 FORMAT(//'...TWO STORMS REPORTED AT THE SAME DATE/TIME WITHIN ',
1 'THE OTHERS CIRCULATION. DISTZ,NREC,NTST,INDTST=',F7.1,2
2 I4,I5/2(4X,'...',A,'...'/))
C SAME OR DIFFERENT RSMC?
IF(RSMCZ .EQ. RSMCX) THEN
IETYP=1
ELSE
IETYP=2
ENDIF
IF(NOVRLP .EQ. 2) THEN
IEROVR=IETYP
ELSE
IF(IETYP .NE. IEROVR) THEN
IOVRLP(NOVRLP)=-IABS(IOVRLP(NOVRLP))
WRITE(6,71) NREC,NTST
71 FORMAT(' ###WARNING: MULTIPLE OVERLAP TYPES FOR NREC=',I3/4X,
1 'ERROR RECOVERY CURRENTLY WORKS ON A SINGLE OVERLAP TYPE ',
2 'SO THIS RECORD=#',I3,' WILL BE AUTOMATICALLY DISCARDED.')
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
100 CONTINUE
ENDDO
IF(IETYP .EQ. 0) GO TO 390
C ERROR RECOVERY FOR PART I:
WRITE(6,103) NREC,IEROVR,NOVRLP-1,(IOVRLP(NOVR),NOVR=2,NOVRLP)
103 FORMAT(' ...SUMMARY OF OVERLAPS FOR NREC=',I3,'. OVERLAP ',
1 'TYPE=',I3,' AND NUMBER OF OVERLAPS=',I3,
2 ' OVERLAP INDICES ARE:'/4X,'(NEGATIVE OVERLAP ',
3 'INDICES MEAN THAT THE OVERLAP TYPE DIFFERS FROM ',
4 'THE PRIMARY ONE WHICH IS IEROVR)'/4X,10I3)
C ****************************************************
C ****************************************************
C **** ****
C **** MULTIPLE REPORTS BY THE SAME INSTITUTION ****
C **** ****
C ****************************************************
C ****************************************************
IF(IEROVR .EQ. 1) THEN
IVR=9
WRITE(6,107) IETYP
107 FORMAT(' ******STORMS ARE REPORTED BY THE SAME RSMC, WHICH ',
1 'IS A LOGICAL ERROR. IETYP=',I2/4X,'WE PROCEED TO ',
2 'RECOVER THIS ERROR BY REDUCING THE RMAX OF THE LARGEST ',
3 'STORM SO THAT OVERLAP WILL NOT OCCUR.')
IF(NOVRLP .GT. 2) WRITE(6,109)
109 FORMAT(' ###WARNING, NOVRLP > 2 SO THAT PROCESSING WILL ',
1 'OCCUR FOR ONLY THE LARGEST AND SMALLEST STORMS. ',
2 'OTHERS WILL BE AUTOMATICALLY MARKED ERRONEOUS.')
C PICK OUT THE LARGEST AND SMALLEST STORMS
INDXZ=1
INDXX=1
RMAXZ=RMAX(1)
RMAXX=RMAX(1)
DO NOVR=2,NOVRLP
IF(IOVRLP(NOVR) .GT. 0) THEN
IF(RMAX(NOVR) .GT. RMAXZ) THEN
RMAXZ=RMAX(NOVR)
INDXZ=NOVR
ENDIF
IF(RMAX(NOVR) .LT. RMAXX) THEN
RMAXX=RMAX(NOVR)
INDXX=NOVR
ENDIF
ENDIF
ENDDO
DISTZX=DISTSP(STMLAT(INDXZ),STMLON(INDXZ),
1 STMLAT(INDXX),STMLON(INDXX))*1.E-3
EXCESS=RMAXZ+RMAXX+BUFZON*DEGLAT-DISTZX
WRITE(6,121) INDXZ,INDXX,STMID(INDXZ),RMAXZ,STMID(INDXX),RMAXX,
1 DISTZX,EXCESS
121 FORMAT('...INDXZ,INDXX,STMID(INDXZ),RMAX(INDXZ),STMID(INDXX),',
1 'RMAX(INDXX)=',2I3,2(1X,A,F7.1),' DISTZX,EXCESS=',2F9.1)
RMAXZT=RMAXZ-EXCESS
C RECOVERY METHOD 1: SUBTRACT EXCESS FROM LARGEST RMAX BUT MAINTAIN
C RELATIVE SIZE
IF(RMAXZT .GT. RMAXX) THEN
WRITE(OVRREC(INDXZ)(ISTVAR(IVR):IENVAR(IVR)),FMTVIT(IVR))
1 NINT(RMAXZT)
OVRREC(INDXZ)(ISTVAR(IVR)-1:ISTVAR(IVR)-1)='O'
OVRREC(INDXX)=TSTREC(IOVRLP(INDXX))
WRITE(6,123) IOVRLP(INDXZ),RMAXZ,RMAXZT,INDXZ,OVRREC(INDXZ)
123 FORMAT(' ###IMPORTANT NOTE: FOR RECORD',I3,' RMAXZ=',F7.1,
1 ' WILL BE SUBSTITUTED BY RMAXZT=',F7.1,' FOR INDXZ=',I3,
2 '. AFTER SUBSTITUTION, OVRREC='/4X,A)
IETYP=-10
C RECOVERY METHOD 2: SUBTRACT HALF THE EXCESS FROM EACH RMAX
ELSE
WRITE(6,125)
125 FORMAT('...UNABLE TO MAINTAIN RMAXZ>RMAXX. HALF THE ',
1 'EXCESS WILL BE SUBTRACTED FROM EACH REPORT.')
RMAXZT=RMAXZ-0.5*EXCESS
RMAXXT=RMAXX-0.5*EXCESS
IF(RMAXZT .GE. RMAXMN .AND. RMAXXT .GE. RMAXMN) THEN
WRITE(OVRREC(INDXZ)(ISTVAR(IVR):IENVAR(IVR)),FMTVIT(IVR))
1 NINT(RMAXZT)
WRITE(OVRREC(INDXX)(ISTVAR(IVR):IENVAR(IVR)),FMTVIT(IVR))
1 NINT(RMAXXT)
OVRREC(INDXX)(ISTVAR(IVR)-1:ISTVAR(IVR)-1)='O'
WRITE(6,123) IOVRLP(INDXZ),RMAXZ,RMAXZT,INDXZ,OVRREC(INDXZ)
WRITE(6,127) IOVRLP(INDXX),RMAXX,RMAXXT,IOVRLP(INDXX),
1 OVRREC(INDXX)
127 FORMAT(' ###IMPORTANT NOTE: FOR RECORD',I3,' RMAXX=',F7.1,
1 ' WILL BE SUBSTITUTED BY RMAXXT=',F7.1,' FOR INDXX=',I3,
2 '. AFTER SUBSTITUTION, OVRREC='/4X,A)
IETYP=-10
ELSE
WRITE(6,129) RMAXZT,RMAXXT,RMAXMN
129 FORMAT(' ******RMAXZ AND RMAXX REDUCTION METHODS HAVE FAILED. ',
1 'RMAXZT,RMAXXT=',2F7.1,' < RMAXMN=',F7.1)
ENDIF
ENDIF
DO NOVR=1,NOVRLP
C ASSIGN ERROR FLAGS AND UPDATE RECORDS FOR THE TWO RECORDS
C THAT WE TRIED TO CORRECT
IF(NOVR .EQ. INDXZ .OR. NOVR .EQ. INDXX) THEN
IFRSMC(NUMTST(IOVRLP(NOVR)))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(IOVRLP(NOVR))
BADREC(NADD+NBAD)=TSTREC(IOVRLP(NOVR))
ELSE
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(IOVRLP(NOVR))
OKAREC(NOKAY)=OVRREC(NOVR)
ENDIF
C ASSIGN ERROR FLAGS TO ALL OTHER RECORDS
ELSE
IFRSMC(NUMTST(IOVRLP(NOVR)))=IETYP
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(IOVRLP(NOVR))
BADREC(NADD+NBAD)=TSTREC(IOVRLP(NOVR))
ENDIF
ENDDO
GO TO 400
C ***************************************************
C ***************************************************
C **** ****
C **** MULTIPLE REPORTS BY TWO DIFFERENT RSMCS ****
C **** ****
C ***************************************************
C ***************************************************
ELSE IF(IEROVR .EQ. 2) THEN
WRITE(6,201) IETYP
201 FORMAT('...STORMS ARE REPORTED BY DIFFERENT RSMCS. ',
1 'WE PROCEED TO SEE IF THEY ARE THE SAME STORM BY ',
2 'COMPARING NAMES.'/4X,'THEN WE CONSTRUCT A COMMON ',
3 'STORM ID. PRELIMINARY IETYP=',I2)
BUFINZ=OVRREC(1)
NERROR=0
DO NOVR=2,NOVRLP
IF(STMNAM(NOVR) .EQ. 'NAMELESS' .AND.
1 STMNMZ .EQ. 'NAMELESS') THEN
WRITE(6,202) STMIDZ,RSMCZ,STMID(NOVR),RSMC(NOVR)
202 FORMAT(' ###OVERLAPPING NAMELESS STORMS HAVE IDS AND RSMCS=',
1 2(2(A,1X),2X))
ELSE IF(STMNAM(NOVR) .EQ. STMNMZ) THEN
WRITE(6,203) STMNAM(NOVR),NOVR
203 FORMAT('...STORM NAME=',A,' FOR NOVR=',I3,' MATCHES FIRST ',
1 'REPORT. THE STORMS ARE THE SAME.')
ELSE
C IF ONE RSMC REPORTS A NAMELESS STORM AND THE OTHER RSMCS REPORT
C A NAME, TRANSFER THE STORM NAME TO THE NAMELESS RECORD.
IF(STMNMZ .EQ. 'NAMELESS') THEN
WRITE(6,205) STMNAM(NOVR),NOVR
205 FORMAT('...STMNMZ IS NAMELESS. COPYING STMNAM(NOVR)=',A,' TO ',
1 'STMNMZ. NOVR=',I3)
STMNAM(1)=STMNAM(NOVR)
STMNMZ=STMNAM(NOVR)
OVRREC(1)=BUFINZ
IF(IOVRLP(1) .LE. NTEST) TSTREC(IOVRLP(1))=BUFINZ
ELSE IF(STMNAM(NOVR) .EQ. 'NAMELESS') THEN
WRITE(6,207) STMNMZ,NOVR
207 FORMAT('...STMNAM(NOVR) IS NAMELESS. COPYING STMNMZ=',A,' TO ',
1 'STMNAM(NOVR). NOVR=',I3)
STMNAM(NOVR)=STMNMZ
BUFINX=OVRREC(NOVR)
STMNMX=STMNMZ
OVRREC(NOVR)=BUFINX
IF(IOVRLP(NOVR) .LE. NTEST) TSTREC(IOVRLP(NOVR))=BUFINX
C THERE ARE TWO NAMES, NEITHER OF WHICH IS NAMELESS. THUS THERE IS
C AN UNTREATABLE ERROR
ELSE
IETYP=5
NERROR=NERROR+1
IOVRLP(NOVR)=-IABS(IOVRLP(NOVR))
WRITE(6,209) NOVR,STMNAM(NOVR),STMNMZ,IETYP
209 FORMAT(/'******FOR NOVR=',I3,' STORM NAME=',A,' DOES NOT MATCH ',
1 'NAME FOR THE FIRST REPORT=',A,'.'/4X,' THERE IS NO ',
2 'ERROR RECOVERY AT THIS TIME. IETYP=',I3)
C ERROR MARKING OFF ON THE FLY HERE
IFRSMC(NUMTST(IABS(IOVRLP(NOVR))))=IETYP
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(IABS(IOVRLP(NOVR)))
BADREC(NADD+NBAD)=TSTREC(IABS(IOVRLP(NOVR)))
IETYP=IEROVR
ENDIF
ENDIF
ENDDO
C IF AN ERROR HAS OCCURRED IN THE PREVIOUS PROCESSING REMOVE
C THE ERRONEOUS RECORD FROM THE OVERLAP LIST AND CONTINUE
IF(NERROR .NE. 0) THEN
NOVRZ=0
WRITE(6,213) NERROR
213 FORMAT(' ******',I3,' ERRORS FOUND DURING STORM NAME MATCHING.')
DO NOVR=1,NOVRLP
IF(IOVRLP(NOVR) .GE. 0 .AND. IOVRLP(NOVR) .LE. NTEST) THEN
NOVRZ=NOVRZ+1
IOVRLP(NOVRZ)=IOVRLP(NOVR)
OVRREC(NOVRZ)=OVRREC(NOVR)
STMNAM(NOVRZ)=STMNAM(NOVR)
STMID (NOVRZ)=STMID(NOVR)
RSMC (NOVRZ)=RSMC(NOVR)
STMLAT(NOVRZ)=STMLAT(NOVR)
STMLON(NOVRZ)=STMLON(NOVR)
RMAX (NOVRZ)=RMAX(NOVR)
PCEN (NOVRZ)=PCEN(NOVR)
PENV (NOVRZ)=PENV(NOVR)
ENDIF
ENDDO
NOVRLP=NOVRZ
IF(NOVRLP .EQ. 1) GO TO 390
ENDIF
WRITE(6,221)
221 FORMAT(' ...THE OBSERVING RSMCS, THEIR ABBREVIATIONS, ',
1 'PRIORITIES, INDICES AND REPORTED BASINS ARE:'/11X,
2 'RSMC',3X,'RSMCAP',3X,'PRIORITY',3X,'INDEX',3X,'BASIN',3X,
3 'BSCOFL',3X,'RPCOFL')
NERROR=0
DO NOVR=1,NOVRLP
C WHICH BASIN ARE WE IN?
CALL BASNCK(STMID(NOVR),STMLAT(NOVR),STMLON(NOVR),NBA,IPRT,IER)
IF(IER .EQ. 11) THEN
BSCOFL='IB'
ELSE
BSCOFL='CB'
ENDIF
IF(IER .EQ. 3) THEN
IETYP=IER
NERROR=NERROR+1
IOVRLP(NOVR)=-IABS(IOVRLP(NOVR))
C AGAIN, ERROR MARKING OFF ON THE FLY
IFRSMC(NUMTST(IABS(IOVRLP(NOVR))))=IETYP
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(IABS(IOVRLP(NOVR)))
BADREC(NADD+NBAD)=TSTREC(IABS(IOVRLP(NOVR)))
IETYP=IEROVR
ENDIF
IF(NOVR .EQ. 1) THEN
NBASV=NBA
RPCOFL='CR'
ELSE
IF(NBA .NE. NBASV) THEN
RPCOFL='IR'
NBA=NBASV
ENDIF
ENDIF
C IS THIS A REPORT BY THE PRIORITY RSMC FOR THIS BASIN? THE
C PRIORITY FLAG IS TWO DIGITS. THE FIRST DIGIT IS PRIORITY
C (=1 IF THE RSMC IS THE PRIORITY RSMC, =2 OTHERWISE). THE
C SECOND DIGIT IS THE RSMC INDEX
NRSPRI=RSMCPR(NBA)
NRSMC=-1
DO NRSZ=1,NRSMCX
IF(RSMCID(NRSZ) .EQ. RSMC(NOVR)) THEN
NRSMC=NRSZ
IF(NRSMC .EQ. NRSPRI) THEN
IPRIOR(NOVR)=10+NRSMC
AVWT(NOVR)=RSMCWT(1)
BUFINZ=OVRREC(NOVR)
ELSE
IPRIOR(NOVR)=20+NRSMC
AVWT(NOVR)=RSMCWT(2)
ENDIF
GO TO 231
ENDIF
ENDDO
231 CONTINUE
IF(NRSMC .GE. 0) THEN
WRITE(6,233) NOVR,RSMC(NOVR),RSMCAP(NRSMC),IPRIOR(NOVR),NRSMC,
1 NBA,BSCOFL,RPCOFL
233 FORMAT(' ',5X,I3,2X,A,6X,A,8X,I2,5X,I4,5X,I3,2(7X,A))
ELSE
IETYP=4
NERROR=NERROR+1
IOVRLP(NOVR)=-IABS(IOVRLP(NOVR))
WRITE(6,235) RSMC(NOVR),NOVR,IETYP
235 FORMAT('0******RSMC=',A,' COULD NOT BE FOUND IN RSMCCK. THIS ',
1 'RECORD IS ERRONEOUS. NOVR=',I3,', IETYP=',I3)
C AGAIN, ERROR MARKING OFF ON THE FLY
IFRSMC(NUMTST(IABS(IOVRLP(NOVR))))=IETYP
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(IABS(IOVRLP(NOVR)))
BADREC(NADD+NBAD)=TSTREC(IABS(IOVRLP(NOVR)))
ENDIF
ENDDO
C IF AN ERROR HAS OCCURRED IN THE PREVIOUS PROCESSING REMOVE
C THE ERRONEOUS RECORD FROM THE OVERLAP LIST AND CONTINUE
IF(NERROR .NE. 0) THEN
WRITE(6,243) NERROR
243 FORMAT(' ******',I3,' ERRORS FOUND DURING RSMC VERIFICATION.')
NOVRZ=0
DO NOVR=1,NOVRLP
IF(IOVRLP(NOVR) .GE. 0 .AND. IOVRLP(NOVR) .LE. NTEST) THEN
NOVRZ=NOVRZ+1
IOVRLP(NOVRZ)=IOVRLP(NOVR)
IPRIOR(NOVRZ)=IPRIOR(NOVR)
OVRREC(NOVRZ)=OVRREC(NOVR)
STMNAM(NOVRZ)=STMNAM(NOVR)
STMID (NOVRZ)=STMID(NOVR)
RSMC (NOVRZ)=RSMC(NOVR)
STMLAT(NOVRZ)=STMLAT(NOVR)
STMLON(NOVRZ)=STMLON(NOVR)
RMAX (NOVRZ)=RMAX(NOVR)
PCEN (NOVRZ)=PCEN(NOVR)
PENV (NOVRZ)=PENV(NOVR)
AVWT (NOVRZ)=AVWT(NOVR)
ENDIF
ENDDO
NOVRLP=NOVRZ
IF(NOVRLP .EQ. 1) GO TO 390
ENDIF
WRITE(6,251) NOVRLP
251 FORMAT(6X,'KEY: BSCOFL=IB IF REPORTED LAT/LON AND BASIN ',
1 'ID FROM STORM ID ARE INCONSISTENT.'/18X,'=CB IF ',
2 'LAT/LON AND BASIN ID ARE CONSISTENT.'/12X,'RPCOFL=',
3 'CR IF REPORTED BASIN IS THE SAME AS THE FIRST RECORD.'
4 /18X,'=IR IF REPORTED BASIN IS DIFFERENT FROM THE FIRST ',
5 'RECORD.'/4X,I3,' OVERLAPPING STORMS HAVE BEEN FOUND.')
C CHECK THE ALIAS FILE FOR REPORTS UNDER OTHER NAMES
DO NOVR=1,NOVRLP
NALIAS=0
NALREC=0
REWIND IUNTAL
WRITE(6,257) STMNAM(NOVR),STMID(NOVR)
257 FORMAT(/'...CHECKING THE ALIAS FILE TRYING TO FIND STORM NAME ',
1 'ID AND RSMC THAT MATCH',3(1X,A))
260 READ(IUNTAL,261,END=300) NALMX,STMNMX,(RSMCAL(NAL),STIDAL(NAL),
1 NAL=1,MIN(NALMX,NOVRMX))
261 FORMAT(I1,1X,A9,10(1X,A4,1X,A3))
NALREC=NALREC+1
IF(NOVR .EQ. 1) WRITE(6,267) NALREC,RSMCAL(1),STIDAL(1),
1 NALMX-1,STMNMX,(RSMCAL(NAL),STIDAL(NAL),NAL=2,MIN(NALMX,NOVRMX))
267 FORMAT('...ALIAS RECORD',I3,'=',2(A,1X),' HAS ',I3,' OBSERVERS ',
1 'AND NAME=',A,' OBSERVERS ARE:'/(14X,2(A,1X)))
C WRITE(6,293) STMID(NOVR),STIDAL(NAL)
C 293 FORMAT('...CHECKING STORM IDS VERSUS ALIAS FILE. STMID(NOVR),',
C 1 'STIDAL(NAL)=',2(A,1X))
IFNDAL=0
IF(STMNMX .NE. 'NAMELESS' .AND. STMNAM(NOVR) .EQ. STMNMX .AND.
1 STMID(NOVR)(3:3) .EQ. STIDAL(1)(3:3)) THEN
IFNDAL=1
WRITE(6,294) STMNMX,STIDAL(1)(3:3)
294 FORMAT('...EXACT NAME AND BASIN MATCH FOR NAMED STORM=',A,' IN ',
1 'BASIN ',A,' IN THE ALIAS FILE.')
ELSE
DO NALZZ=2,MIN(NALMX,NOVRMX)
IF(STMID(NOVR) .EQ. STIDAL(NALZZ) .AND.
1 RSMC(NOVR) .EQ. RSMCAL(NALZZ)) THEN
IFNDAL=1
WRITE(6,295) STMNMX,STIDAL(NALZZ),RSMC(NALZZ)
295 FORMAT('...STORM ID AND RSMC MATCH FOR STORM=',A,' IN THE ',
1 'ALIAS FILE. ID,RSMC=',2(A,1X))
ENDIF
ENDDO
ENDIF
IF(IFNDAL .EQ. 1) THEN
NALIAS=NALMX-1
C CHECK THAT THE OBSERVING RSMCS IN THE ALIAS FILE ARE AT LEAST
C THOSE OBSERVING FOR THIS CASE
NOFIND=0
DO NOVRZ=1,NOVRLP
DO NALZ=2,MIN(NALMX,NOVRMX)
IF(RSMC(NOVRZ) .EQ. RSMCAL(NALZ)) THEN
NOFIND=0
GO TO 2294
ELSE
NOFIND=NOFIND+1
ENDIF
ENDDO
2294 CONTINUE
IF(NOFIND .GT. 0) GO TO 2298
ENDDO
2298 IF(NOFIND .EQ. 0) THEN
RSMCZ=RSMCAL(1)
STMIDZ=STIDAL(1)
C RESET NALIAS TO FORCE A NEW COMBINED RSMC IF THE OBSERVING
C RSMCS AREN'T ON THE ALIAS FILE
ELSE
WRITE(6,297)
297 FORMAT('...RESETTING NALIAS=0 TO FORCE NEW ALIAS RECORD ',
1 'BECAUSE A NEW RSMC HAS OBSERVED THIS STORM.')
NALIAS=0
ENDIF
GO TO 301
ENDIF
GO TO 260
300 CONTINUE
ENDDO
301 CONTINUE
C CONSTRUCT AND WRITE A NEW COMBINED RSMC IF NECESSARY
IF(NALIAS .EQ. 0) THEN
IF(NALREC .EQ. 0) WRITE(6,303)
303 FORMAT(/'...THE ALIAS FILE IS EMPTY. WE WILL ADD A NEW ALIAS.')
IF(IFNDAL .EQ. 0) THEN
RSMCZ='!'//RSMCAP(NRSPRI)
WRITE(6,343) NRSPRI,RSMCAP(NRSPRI),RSMCZ
343 FORMAT('...CONSTRUCTING NEW COMBINED RSMC FROM PRIORITY RSMC. ',
1 'NRSPRI,','RSMCAP(NRSPRI),RSMCZ=',I4,2(1X,'...',A,'...'))
NSUB=0
DO NOVZ=1,MIN0(NOVRLP,3)
IF(IPRIOR(NOVZ)/10 .NE. 1) THEN
NSUB=NSUB+1
RSMCZ(2+NSUB:2+NSUB)=RSMCAP(IPRIOR(NOVZ)-10*(IPRIOR(NOVZ)/10))
WRITE(6,349) RSMCZ(2+NSUB:2+NSUB),RSMCZ
349 FORMAT('...ADDING RSMCAP=',A,', RSMCZ=',A)
ENDIF
ENDDO
NSUB=1
DO NOVZ=1,MIN(NOVRLP,NOVRMX-1)
NSUB=NSUB+1
RSMCAL(NSUB)=RSMC(NOVZ)
STIDAL(NSUB)=STMID(NOVZ)
IF(IPRIOR(NOVZ)/10 .EQ. 1) THEN
RSMCAL(1)=RSMCZ
STIDAL(1)=STMIDZ
ENDIF
ENDDO
NOVRAD=NOVRLP+1
C CHECK THE CHOICE OF STORM ID VERSUS THE CATALOG. MAKE ANOTHER
C CHOICE IF THE FIRST CHOICE IS TAKEN.
WRITE(6,361) STIDAL(1),(STMID(NOVZ),RSMC(NOVZ),NOVZ=1,NOVRLP)
361 FORMAT('...CHECKING THE CATALOG TO SEE THE IF STORM IS IN ',
1 'THERE. FIRST CHOICE IS: ',A/4X,
2 'POSSIBLE IDS AND RSMCS ARE:'/(14X,2(A,2X)))
read(stidal(1)(1:2),3333) minid
3333 format(i2.2)
write(6,3334) minid
3334 FORMAT('...ID OF FIRST CHOICE STORM ID=',I3)
do novz=1,novrlp
call stcati(iuntca,stmid(novz),rsmc(novz),stmidx,ifnd)
if(ifnd .eq. 1) then
stidal(1)=stmidx
write(6,3335) stidal(1)
3335 format('...Eureka, this storm is in the catalog with id=',a)
go to 3341
else
c Pick out the maximum storm id from the priority basin
if(stmid(novz)(3:3) .eq. stidal(1)(3:3)) then
read(stmid(novz)(1:2),3333) minidz
minid=max0(minid,minidz)
endif
endif
enddo
3341 continue
if(ifnd .eq. 0) then
write(stidal(1)(1:2),3333) minid
write(6,3351) stidal(1)
3351 format('...This storm is not in the catalog. Assign a unique ',
1 'id that is the smallest for the overlapping storms=',a)
endif
stmidz=stidal(1)
ELSE
WRITE(6,3357) RSMCAL(1),STIDAL(1),NALMX,(RSMCAL(NN),
1 STIDAL(NN),NN=2,NALMX)
3357 FORMAT('...COPYING RSMC =(',A,') AND STORM ID =(',A,') FROM ',
1 'ALIAS FILE AND ADDING NEW RSMCS.'/4X,'NEW RSMCS AND ',
2 'STORM IDS WILL NOW BE ADDED. CURRENT NUMBER IS',I3,
3 ' OTHER RSMCS, STORM IDS ARE:'/(10X,2(A,1X)))
C ADD NEW RSMCS AND ALIASES AS APPROPRIATE
NADDRS=0
DO NOVR=1,NOVRLP
DO NRSZA=1,NRSMCX
IF(RSMCID(NRSZA) .EQ. RSMC(NOVR)) THEN
NRSAPA=NRSZA
WRITE(6,3359) NOVR,RSMC(NOVR),NRSAPA
3359 FORMAT('...FOR OVERLAP RECORD',I3,' RSMC AND INDEX ARE ',A,I4)
GO TO 3361
ENDIF
ENDDO
3361 CONTINUE
IADRMS=1
LNRSMC=INDEX(RSMCAL(1),' ')-1
DO LENG=2,LNRSMC
WRITE(6,3377) LENG,RSMCAL(1)(LENG:LENG),RSMCAP(NRSAPA)
3377 FORMAT('...TRYING TO MATCH RSMC ON ALIAS RECORD WITH OVERLAP ',
1 'RECORD, LENG,RSMCAL,RSMCAP=',I3,2(1X,A))
IF(RSMCAL(1)(LENG:LENG) .EQ. RSMCAP(NRSAPA)) THEN
IADRMS=0
ENDIF
ENDDO
IF(IADRMS .GT. 0) THEN
NADDRS=NADDRS+1
RSMCAL(1)(LNRSMC+NADDRS:LNRSMC+NADDRS)=RSMCAP(NRSAPA)
STIDAL(NALMX+NADDRS)=STMID(NOVR)
RSMCAL(NALMX+NADDRS)=RSMC(NOVR)
WRITE(6,3391) NADDRS,NALMX+NADDRS,RSMCAL(1)
3391 FORMAT('...ADDING RSMC, NADDRS,NALMX+NADDRS,RSMCAL(1)=',
1 2I4,1X,A)
ENDIF
ENDDO
NOVRAD=NALMX+NADDRS
STMIDZ=STIDAL(1)
RSMCZ=RSMCAL(1)
ENDIF
C WRITE A NEW RECORD TO THE ALIAS FILE IF THERE ISN'T AN EARLIER
C ONE IN THE NEW ALIAS FILE ALREADY
IFND=0
DO NADDZ=1,NALADD
IF(STNMAD(NADDZ) .EQ. STMNAM(NOVR) .OR.
1 (STIDAD(NADDZ) .EQ. STIDAL(1) .AND.
2 RSMCAD(NADDZ) .EQ. RSMCAL(1)) .AND.
3 DAYZ .GE. DAYZAD(NADDZ)) THEN
IFND=1
GO TO 3661
ENDIF
ENDDO
3661 CONTINUE
IF(IFND .EQ. 0) THEN
WRITE(6,3401) NOVRAD,NADDRS,RSMCAL(1),STIDAL(1),(RSMCAL(NN),
1 STIDAL(NN),NN=2,NOVRAD)
3401 FORMAT('...READY TO ADD MODIFIED ALIAS RECORD: NOVRAD,NADDRS,',
1 'PRIMARY RSMC,STORM ID=',2I4,2(1X,A),' SECONDARY ',
2 'RSMC, ID:'/(10X,2(A,1X)))
NALADD=NALADD+1
STNMAD(NALADD)=STMNAM(1)
STIDAD(NALADD)=STIDAL(1)
RSMCAD(NALADD)=RSMCAL(1)
DAYZAD(NALADD)=DAYZ
NAKA=MIN(NOVRAD,NOVRMX)
CALL AKASAV(NALADD,NAKA,DAYZ,STNMAD(NALADD),RSMCAL,STIDAL)
ENDIF
ENDIF
C CALCULATE AVERAGE LAT/LON, RMAX
C THEN SUBSTITUTE THE STORM ID, RSMC, LAT/LON, RMAX
WRITE(6,362) (NO,STMLAT(NO),STMLON(NO),RMAX(NO),PCEN(NO),
1 PENV(NO),NO=1,NOVRLP)
362 FORMAT(/'...READY FOR AVERAGING OVER COTEMPORANEOUS STORMS. ',
1 9X,'LAT',5X,'LON',4X,'RMAX',4X,'PCEN',4X,'PENV ARE:'
2 /(54X,I3,5F8.1))
CALL WTAVRG(STMLAT,AVWT,NOVRLP,STMLTZ)
CALL WTAVRG(STMLON,AVWT,NOVRLP,STMLNZ)
CALL WTAVGP(RMAX,AVWT,NOVRLP,RMAXZ)
CALL WTAVGP(PCEN,AVWT,NOVRLP,PCENZ)
CALL WTAVGP(PENV,AVWT,NOVRLP,PENVZ)
IF(STMLTZ .GE. 0) THEN
LATNS='N'
ELSE
LATNS='S'
STMLTZ=ABS(STMLTZ)
ENDIF
IF(STMLNZ .GT. 180.) THEN
LONEW='W'
ELSE
LONEW='E'
ENDIF
WRITE(6,363) LATNS,LONEW,STMLTZ,STMLNZ,RMAXZ,PCENZ,PENVZ
363 FORMAT('...AVERAGE STORM VALUES ARE:',2X,'(LATNS,LONEW=',2A2,')'
1 /57X,5F8.1)
IF(NVSBRS .NE. 0) THEN
DO IVR=1,NVSBRS
IVSB=IVSBRS(IVR)
IVTVAR(IVSB)=NINT(VITVAR(IVSB)/VITFAC(IVSB))
ENDDO
ELSE
WRITE(6,3364)
3364 FORMAT(' ###THESE AVERAGE VALUES WILL NOT BE SUBSTITUTED.')
ENDIF
WRITE(6,365) STMIDZ,RSMCZ
365 FORMAT(' ...SUBSTITUTING COMBINED STORM ID=',A,' AND RSMC=',A,
1 ' INTO OVERLAP RECORDS.',/,4X,'AFTER SUBSTITUTION, ',
2 'INDEX, INPUT RECORD#, RECORD ARE : (~~ INDICATES ',
3 'RECORD FROM ORIGINAL SHORT-TERM HISTORY FILE)')
ICURR=0
DO NOVR=1,NOVRLP
C WRITE(6,367) NOVR,STMIDZ,RSMCZ,OVRREC(NOVR)
C 367 FORMAT('...BEFORE SUBSTITUTION,NOVR,STMIDZ,RSMCZ,OVRREC=',
C 1 I3,2(1X,A)/4X,A,'...')
C COUNT THE NUMBER OF CURRENT OVERLAPPING RECORDS
IF(IOVRLP(NOVR) .LE. NTEST) THEN
ICURR=ICURR+1
STHCH=' '
ELSE
STHCH='~~'
ENDIF
BUFINX=OVRREC(NOVR)
STMIDX=STMIDZ
RSMCX=RSMCZ
LATNSX=LATNS
LONEWX=LONEW
OVRREC(NOVR)=BUFINX
DO IVR=1,NVSBRS
IVSB=IVSBRS(IVR)
WRITE(OVRREC(NOVR)(ISTVAR(IVSB):IENVAR(IVSB)),FMTVIT(IVSB))
1 IVTVAR(IVSB)
OVRREC(NOVR)(ISTVAR(IVSB)-1:ISTVAR(IVSB)-1)='A'
ENDDO
WRITE(6,369) NOVR,IOVRLP(NOVR),STHCH,OVRREC(NOVR)
369 FORMAT(' ...',2I3,'...',A,'...',A,'...')
ENDDO
C FINAL ASSIGNMENT OF ERROR CODE:
C =21 IF ALL OVERLAPPING RECORDS ARE CURRENT
C =22 IF ONE OF THE OVERLAPPING RECORDS WAS FROM THE ORIGINAL
C SHORT TERM HISTORY FILE. IN THIS CASE ITS TOO LATE TO USE
C THE CURRENT RECORD ANYWAY.
IF(ICURR .EQ. NOVRLP) THEN
IETYP=IETYP*10+1
ELSE
IETYP=IETYP*10+2
ENDIF
C ONLY RECORDS FROM THE CURRENT TEST ARRAY CAN BE SPLIT INTO OKAY
C AND BAD RECORDS.
DO NOVR=1,NOVRLP
IF(IOVRLP(NOVR) .LE. NTEST) THEN
IFRSMC(NUMTST(IOVRLP(NOVR)))=IETYP
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(IOVRLP(NOVR))
BADREC(NADD+NBAD)=TSTREC(IOVRLP(NOVR))
IF(IETYP .NE. 0 .AND. IPRIOR(NOVR)/10 .EQ. 1) THEN
NSUBR=NSUBR+1
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(IOVRLP(NOVR))
OKAREC(NOKAY)=OVRREC(NOVR)
ENDIF
ENDIF
ENDDO
GO TO 400
ENDIF
C OTHER ERROR PROCESSING
390 CONTINUE
IFRSMC(NUMTST(NRECSV))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(NRECSV)
BADREC(NADD+NBAD)=TSTREC(NRECSV)
ELSE
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NRECSV)
OKAREC(NOKAY)=TSTREC(NRECSV)
ENDIF
400 CONTINUE
ENDDO
C DUMP ALIAS RECORDS TO NEW ALIAS FILE
CALL AKADMP(IUNTAN)
WRITE(6,401)
401 FORMAT(//'...BEGINNING RSMCCK PART II: UNIFY STORM ID ACROSS ALL',
1 ' CURRENT AND HISTORICAL OCCURRENCES.')
C COPY ALIAS FILE (AKAVIT) TO NEW ALIAS FILE. DON'T COPY RECORDS
C THAT ALREADY EXIST IN NEW ALIAS FILE.
REWIND IUNTAL
CALL AKACPY(IUNTAL,IUNTAN)
C CHECK ALL RECORDS IN THE ALIAS SHORT-TERM HISTORY FILE VERSUS
C RECORDS THAT ARE OK SO FAR. FIRST, COPY ALL OKAY RECORDS
C INTO WORKING SPACE.
NCHECK=NOKAY+1
REWIND IUNTHA
WRITE(6,503)
503 FORMAT(/'...COPYING OKAY RECORDS TO OVRREC ARRAY: RECORD #, ',
1 'RECORD=')
DO NOK=1,NOKAY
IOVRLP(NOK)=0
OVRREC(NOK)=OKAREC(NOK)
WRITE(6,505) NOK,OVRREC(NOK)
505 FORMAT('...',I3,'...',A,'...')
ENDDO
WRITE(6,511) NOKAY
511 FORMAT('...',I3,' OKAY RECORDS HAVE BEEN COPIED.')
WRITE(6,513) IUNTHA
513 FORMAT(/'...READING FROM ALIAS SHORT-TERM HISTORY FILE (UNIT',I3,
1 ') INTO OVRREC ARRAY: RECORD #, RECORD='/4X,A)
520 CONTINUE
READ(IUNTHA,521,END=540) OVRREC(NCHECK)
521 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(OVRREC(NCHECK)(35:35).EQ.'N' .OR.
1 OVRREC(NCHECK)(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',OVRREC(NCHECK)(20:21),'"'
PRINT *, ' '
PRINT *, 'From unit ',iuntha,'; OVRREC(NCHECK)-3: ',
$ OVRREC(NCHECK)
PRINT *, ' '
DUMY2K(1:19) = OVRREC(NCHECK)(1:19)
IF(OVRREC(NCHECK)(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = OVRREC(NCHECK)(20:100)
OVRREC(NCHECK) = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ OVRREC(NCHECK)(20:23),'" via windowing technique'
PRINT *, ' '
PRINT *, 'From unit ',iuntha,'; OVRREC(NCHECK)-3: ',
$ OVRREC(NCHECK)
PRINT *, ' '
ELSE IF(OVRREC(NCHECK)(37:37).EQ.'N' .OR.
1 OVRREC(NCHECK)(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',OVRREC(NCHECK)(20:23),'"'
PRINT *, ' '
PRINT *, 'From unit ',iuntha,'; OVRREC(NCHECK)-3: ',
$ OVRREC(NCHECK)
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 520
END IF
IOVRLP(NCHECK)=0
WRITE(6,505) NCHECK,OVRREC(NCHECK)
NCHECK=NCHECK+1
GO TO 520
540 CONTINUE
NCHECK=NCHECK-1
WRITE(6,541) NCHECK-NOKAY
541 FORMAT('...',I3,' SHORT-TERM HISTORY RECORDS HAVE BEEN READ.')
REWIND IUNTAL
NALADD=0
DO NOK=1,NOKAY
C DO ONLY RECORDS THAT HAVE NOT BEEN PROCESSED PREVIOUSLY
IF(IOVRLP(NOK) .LT. 0) GO TO 700
BUFINZ=OKAREC(NOK)
WRITE(6,543) NOK,STMNMZ,STMIDZ,RSMCZ
543 FORMAT(//'...READY TO CHECK OKAY RECORD',I3,' WITH STMNAM,ID,',
1 'RSMC=',3(1X,A))
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
ENDDO
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
IBANG=0
NSAME=1
STMID(NSAME)=STMIDZ
STMNAM(NSAME)=STMNMZ
RSMC (NSAME)=RSMCZ
IOVRLP(NOK)=-NOK
INDSAM(NSAME)=NOK
IDATE(NSAME)=IDATEZ
IUTC(NSAME)=IUTCZ
IDASRT(NSAME)=NSAME
SRTDAY(NSAME)=DAYZ
IF(RSMC(NSAME)(1:1) .EQ. '!') IBANG=NSAME
C LOOK IN THE ALIAS FILE TO SEE IF THIS STORM HAS BEEN ALIASED
C BEFORE.
NALSAV=NOVRMX
CALL AKAFND(IUNTAN,STMNMZ,RSMCZ,STMIDZ,NALSAV,STNMAL,RSMCAL,
1 STIDAL,IFNDAL)
IF(IFNDAL .NE. 0) THEN
NALMX=NALSAV
WRITE(6,557) STMNMZ,STMIDZ,NALMX
557 FORMAT('...STORM NAME,ID=',2(1X,A),' HAS BEEN ASSIGNED AN ALIAS ',
1 'NAME PREVIOUSLY.',I3,' ALIASES EXIST.')
ELSE
NALMX=1
WRITE(6,559) STMNMZ
559 FORMAT('...STORM ',A,' CANNOT BE FOUND IN THE ALIAS FILE.')
ENDIF
C ACCUMULATE ALL OBSERVATIONAL REPORTS FOR THIS STORM.
DO NCK=NOK+1,NCHECK
IF(IOVRLP(NCK) .GE. 0) THEN
IFNDX=0
BUFINX=OVRREC(NCK)
C NO MATCH FOR BOTH STORMS THAT ARE NAMED.
IF(STMNMZ .NE. 'NAMELESS' .AND. STMNMX .NE. 'NAMELESS') THEN
IF(STMNMX .EQ. STMNMZ) then
if(STMIDX(3:3) .EQ. STMIDZ(3:3)) then
IFNDX=1
else
icmat=0
do nc=1,ncrdmx
if(stmnmx .eq. cardnm(nc)) icmat=1
enddo
if(icmat .eq. 0) ifndx=1
endif
endif
C POSSIBLE MATCH REMAINS: MATCH STORM ID FOR THE SAME RSMC. IF
C STORM WAS IN ALIAS FILE, TRY TO MATCH ANY OF ITS ALIASES. IF
C STORM WAS NOT IN ALIAS FILE, TRY TO MATCH STORM ID AND RSMC.
C WARNING: THIS IS NOT A COMPLETE TEST!!!
ELSE
IF(IFNDAL .NE. 0) THEN
DO NAL=1,NALMX
IF(RSMCX .EQ. RSMCAL(NAL) .AND. STMIDX .EQ. STIDAL(NAL)) THEN
IFNDX=1
GO TO 561
ENDIF
ENDDO
ELSE
IF(RSMCX .EQ. RSMCZ .AND. STMIDX .EQ. STMIDZ) THEN
IFNDX=1
GO TO 561
ENDIF
ENDIF
561 CONTINUE
ENDIF
C CONTINUE PROCESSING IF SAME STORM HAS BEEN FOUND.
IF(IFNDX .NE. 0) THEN
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV),
1 BUFINX)
ENDDO
CALL ZTIME(IDATEX,IUTCX,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYX)
C CHECK FOR RECORDS THAT HAVE THE SAME DATE/TIME
DO NSZ=1,NSAME
IF(ABS(DAYX-SRTDAY(NSZ)) .LT. FIVMIN) THEN
WRITE(6,567) NSZ,INDSAM(NSZ),BUFINX
567 FORMAT('###RECORD HAS SAME DATE/TIME AS RECORD #',I3,' WHICH ',
1 'IS INDEX#',I3,'. IT WILL NOT BE SAVED.',/,4X,A)
IOVRLP(NCK)=-999
GO TO 570
ENDIF
ENDDO
NSAME=NSAME+1
IDATE(NSAME)=IDATEX
IUTC(NSAME)=IUTCX
IOVRLP(NCK)=-NCK
INDSAM(NSAME)=NCK
STMID(NSAME)=STMIDX
STMNAM(NSAME)=STMNMX
RSMC (NSAME)=RSMCX
IDASRT(NSAME)=NSAME
SRTDAY(NSAME)=DAYX
IF(RSMC(NSAME)(1:1) .EQ. '!') IBANG=NSAME
ENDIF
ENDIF
570 CONTINUE
ENDDO
WRITE(6,571) NSAME-1,STMNMZ,STMIDZ,(INDSAM(NS),NS=2,NSAME)
571 FORMAT(/'...',I3,' MATCHING STORMS WERE FOUND FOR ',A,' WITH ',
1 'ID=',A,' BY NAME OR STORM ID MATCHING. INDICES OF ',
2 'MATCHING STORMS ARE:'/(4X,30I4))
C FINAL CHECK: FIND THE CLOSEST STORMS TO EACH OF THE STORMS
C THAT WERE DETERMINED TO BE THE SAME USING THE ABOVE PROCEDURE.
C COMPARE POSITIONS EXTRAPOLATED TO THE COMMON TIMES.
NSVSAM=NSAME
DO NS=1,NSVSAM
ISAME=0
DISTMN=1.E10
C RECOVER DATE, UTC, LAT/LON, STORM MOTION FOR SUBJECT STORM
BUFINZ=OVRREC(INDSAM(NS))
DO IV=1,9
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV)
ENDDO
IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ
IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ
DAYZ=SRTDAY(NS)
WRITE(6,1521) NS,NCHECK,STMNMZ,STMIDZ,IDATEZ,IUTCZ,STMLTZ,
1 STMLNZ,STMDRZ,STMSPZ,DAYZ,RMAXZ
1521 FORMAT(/'...BEGINNING PROXIMITY CHECK WITH INDEX=',I3,' AND ',
1 'NUMBER OF STORMS TO COMPARE=',I3/4X,'STORM=',A,'WITH ID',
2 '=',A,'. IDATEZ,IUTCZ,STMLTZ,STMLNZ,STMDRZ,STMSPZ,DAYZ,',
3 'RMAXZ='/3X,I9,I5,6F12.3)
DO 1580 NCK=1,NCHECK
C PICK ONLY STORMS THAT HAVEN'T YET BEEN RECOGNIZED AS BEING THE
C SAME AND THAT ARE NOT THEMSELVES.
IF(IOVRLP(NCK) .LT. 0 .OR. NCK .EQ. INDSAM(NS)) GO TO 1580
C RECOVER DATE, UTC, LAT/LON, STORM MOTION AND RMAX FOR COMPARISON
C STORM
BUFINX=OVRREC(NCK)
DO IV=1,9
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV),
1 BUFINX)
VITVRX(IV)=REAL(IVTVRX(IV))*VITFAC(IV)
ENDDO
IF(LATNSX .EQ. 'S') STMLTX=-STMLTX
IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX
CALL ZTIME(IDATEX,IUTCX,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYX)
C PICK ONLY STORMS THAT ARE NOT COTEMPORANEOUS.
IF(ABS(DAYX-SRTDAY(NS)) .LT. FIVMIN) THEN
C WRITE(6,1553) NCK,INDSAM(NS)
C1553 FORMAT('###RECORD ',I3,' HAS SAME DATE/TIME AS RECORD #',I3,'. ',
C 1 'IT SHOULD HAVE BEEN TREATED BY THE COTEMPORANEOUS CHECK.')
GO TO 1580
ENDIF
IF(STMNMZ .NE. 'NAMELESS' .AND. STMNMX .NE. 'NAMELESS') THEN
C WRITE(6,1557) NCK,INDSAM(NS)
C1557 FORMAT('###RECORDS ',I3,' AND',I3,' BOTH HAVE NAMES. THEY ',
C 1 'SHOULD HAVE BEEN TREATED BY THE PREVIOUS MATCHING CHECK.')
GO TO 1580
ENDIF
C CAN THEY CAN BE DEFINITIVELY PROVEN NOT TO BE THE SAME STORM?
C IF THEY ARE BOTH BANG STORMS OR BOTH NOT BANG STORMS, THE RSMCS
C AND STORMS IDS CAN BE COMPARED DIRECTLY. OTHERWISE, WE MUST LOOK
C IN THE ALIAS FILE TO SEE IF THE SAME RSMC HAS OBSERVED EACH.
IF(RSMCZ .EQ. RSMCX .AND. STMIDZ .NE. STMIDX) THEN
C WRITE(6,2551) RSMCZ,STMIDZ,STMIDX
C2551 FORMAT('...DIRECT COMPARISON OF STORM IDS FOR THE SAME RSMC ',
C 1 'GIVES UNAMBIGUOUSLY DIFFERENT STORMS, RSMC,STORM IDS=',
C 2 3(A,1X))
GO TO 1580
ENDIF
C LOOK IN THE ALIAS FILE
IFNDOV=0
IRECOV=0
REWIND IUNTAN
2552 READ(IUNTAN,261,END=2560) NALOV,STNMOV,(RSMCOV(NAL),STIDOV(NAL),
1 NAL=1,NALOV)
IRECOV=IRECOV+1
DO NALX=1,NALOV
IF((RSMCX(1:1) .EQ. '!' .AND. STMIDX .EQ. STIDOV(NALX)) .OR.
1 (RSMCX(1:1) .NE. '!' .AND.
2 RSMCX .EQ. RSMCOV(NALX) .AND. STMIDX .EQ. STIDOV(NALX))) THEN
IFNDOV=1
DO NALZ=2,NALOV
IF(RSMCZ .EQ. RSMCOV(NALZ) .AND. STMIDZ .NE. STIDOV(NALZ)) THEN
C WRITE(6,2553) IRECOV,RSMCX,STMIDX,NALZ,RSMCOV(NALZ),STIDOV(NALZ)
C 1 STMIDZ
C 2553 FORMAT('###ALIAS RECORD',I3,' MATCHES POTENTIAL OVERLAPPING ',
C 1 'STORM WITH RSMC,ID=',2(A,1X,)/4X,'BUT FOR ALIAS #',I3,
C 2 ' RSMC=',A,' IS THE SAME BUT STORM IDS=',2(A,1X),' ARE ',
C 3 'DIFFERENT.')
GO TO 1580
ENDIF
ENDDO
ENDIF
ENDDO
GO TO 2552
2560 CONTINUE
IF(IFNDOV .EQ. 0 .AND. RSMCX(1:1) .EQ. '!') THEN
WRITE(6,2561) STMNMX,RSMCX,STMIDX
2561 FORMAT('...STORM ',A,' WITH RSMC AND ID=',2(A,1X),' WAS NOT ',
1 'FOUND IN THE ALIAS FILE. ABORT1')
CALL ABORT1(' RSMCCK',2561)
ENDIF
ISAME=ISAME+1
DISTZX=DISTSP(STMLTZ,STMLNZ,STMLTX,STMLNX)*1.E-3
C WRITE(6,1571) STMNMX,STMIDX,NCK,IDATEX,IUTCX,STMLTX,STMLNX,
C 1 STMDRX,STMSPX,DAYX,DISTZX,RMAXX
C1571 FORMAT('...BEGINNING COMPARISON WITH STORM=',A,'WITH ID=',A,'. ',
C 1 'INDEX,IDATEX,IUTCX,STMLTX,STMLNX,STMDRX,STMSPX,DAYX,',
C 2 'DISTZX,RMAXX='/4X,I3,I10,I5,7F12.3)
IF(DISTZX .LT. DISTMN) THEN
DISTMN=DISTZX
NCLOSE=NCK
DAYSAV=DAYX
IUTCSV=IUTCX
IDATSV=IDATEX
STLTSV=STMLTX
STLNSV=STMLNX
STDRSV=STMDRX
STSPSV=STMSPX
RMAXSV=RMAXX
ENDIF
1580 CONTINUE
IF(ISAME .GT. 0) THEN
WRITE(6,1581) NS,NCLOSE,DISTMN,OVRREC(INDSAM(NS)),OVRREC(NCLOSE)
1581 FORMAT(/'...FOR NS=',I3,', CLOSEST STORM IS INDEX=',I3,' WITH ',
1 'DISTANCE=',F8.1,' KM. RECORDS ARE:'/4X,'Z...',A/4X,
2 'X...',A/)
BUFINX=OVRREC(NCLOSE)
IF(RMAXZ .LT. 0.0) THEN
DO NBA=1,NBASIN
IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN
IBASN=NBA
GO TO 1546
ENDIF
ENDDO
1546 CONTINUE
RMAXZ=TCCLIM(9,IBASN)
WRITE(6,1583) NREC,RMAXZ,NABASN(IBASN)
1583 FORMAT('###RMAXZ MISSING FOR PROXIMITY CHECK ON RECORD',I3,'.'/4X,
1 'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL GUESS OF ',
2 F6.1,' KM FOR BASIN ',A,'.')
ENDIF
IF(RMAXSV .LT. 0.0) THEN
DO NBA=1,NBASIN
IF(STMIDX(3:3) .EQ. IDBASN(NBA)) THEN
IBASN=NBA
GO TO 1556
ENDIF
ENDDO
1556 CONTINUE
RMAXSV=TCCLIM(9,IBASN)
WRITE(6,1584) NREC,RMAXSV,NABASN(IBASN)
1584 FORMAT('###RMAXSV MISSING FOR PROXIMITY CHECK ON RECORD',I3,'. ',
1 'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL GUESS '/4X,
2 'OF ',F6.1,' KM FOR BASIN ',A,'.')
ENDIF
DTXZ=DAYSAV-DAYZ
DSTFAC=DTXZ*FACSPD
CALL DS2UV(USTMZ,VSTMZ,STMDRZ,STMSPZ)
CALL DS2UV(USTMX,VSTMX,STDRSV,STSPSV)
EXTLTZ=STMLTZ+VSTMZ*DSTFAC
EXTLNZ=STMLNZ+USTMZ*DSTFAC/COSD(EXTLTZ)
EXTLTX=STLTSV-VSTMX*DSTFAC
EXTLNX=STLNSV-USTMX*DSTFAC/COSD(EXTLTX)
DSTX2Z=DISTSP(STMLTZ,STMLNZ,EXTLTX,EXTLNX)*1.E-3
DSTZ2X=DISTSP(STLTSV,STLNSV,EXTLTZ,EXTLNZ)*1.E-3
C LAST CRITERION FOR FINDING THE SAME STORM IS DISTANCE
DSTOLP=RMAXZ+RMAXSV
IF(DSTZ2X .GE. DSTOLP .OR. DSTX2Z .GE. DSTOLP) THEN
C WRITE(6,1585)
C1585 FORMAT(/'...STORMS ARE NOT CONSIDERED THE SAME SINCE NO ',
C 1 'OVERLAPPING IS PRESENT AT A COMMON EXTRAPOLATED TIME.')
ELSE
WRITE(6,1587) DAYZ,DAYX,DTXZ,DISTMN,STMNMZ,STMIDZ,STMLTZ,EXTLTZ,
1 STMLNZ,EXTLNZ,DSTZ2X,RMAXZ,STMNMX,STMIDX,STLTSV,
2 EXTLTX,STLNSV,EXTLNX,DSTX2Z,RMAXSV
1587 FORMAT(/'...EXTRAPOLATION TABLE TO COMMON TIMES: DAYX,DAYZ,DTXZ',
1 ',DISTMN=',4F12.3/20X,'SUBJECT (Z) STORM & ID',6X,
2 'T=0LAT',6X,'T=XLAT',6X,'T=0LON',6X,'T=XLON',2X,
3 'DISTANCE TO X',3X,'RMAXZ'/2(25X,A,2X,A,3X,6F12.3/),20X,
4 'COMPARISON (X) STORM & ID',3X,
5 'T=0LAT',6X,'T=ZLAT',6X,'T=0LON',6X,'T=ZLON',2X,
6 'DISTANCE TO Z',3X,'RMAXX')
WRITE(6,1589)
1589 FORMAT(/'###STORMS ARE OVERLAPPED AT A COMMON EXTRAPOLATED TIME.',
1 ' THEY ARE ASSUMED TO BE THE SAME.###')
BUFINX=OVRREC(NCLOSE)
NSAME=NSAME+1
IDATE(NSAME)=IDATSV
IUTC(NSAME)=IUTCSV
IOVRLP(NCLOSE)=-NCLOSE
INDSAM(NSAME)=NCLOSE
STMID(NSAME)=STMIDX
STMNAM(NSAME)=STMNMX
RSMC (NSAME)=RSMCX
IDASRT(NSAME)=NSAME
SRTDAY(NSAME)=DAYSAV
IF(RSMC(NSAME)(1:1) .EQ. '!') IBANG=NSAME
ENDIF
ENDIF
ENDDO
C PROCESS ALL RECORDS FOR THE SAME STORM
IF(NSAME .GT. 1) THEN
BUFINZ=OKAREC(NOK)
WRITE(6,577) NSAME,STMNMZ,STMIDZ,(NS,IDATE(NS),IUTC(NS),
1 RSMC(NS),STMID(NS),STMNAM(NS),NS=1,NSAME)
577 FORMAT('...',I3,' RECORDS APPEAR TO BE THE SAME STORM WITH NAME,',
1 ' ID=',2(1X,A),' AND MUST BE UNIFIED.'/10X,' DATE ',
2 'UTC RSMC STMID NAME ARE:'/(4X,I3,I10,2X,I5,2X,2(3X,
3 A),4X,A))
c Sort the records by time
CALL SORTRL(SRTDAY(1:NSAME),IDASRT(1:NSAME),NSAME)
C LOOK IN THE ALIAS FILE TO SEE WHICH STORM ALIASES CORRESPOND
C TO THE BANG STORM.
IF(IBANG .NE. 0) THEN
STMIDX=STMID(IBANG)
STMNMX=STMNAM(IBANG)
RSMCX=RSMC (IBANG)
REWIND IUNTAN
NRECAL=0
552 READ(IUNTAN,261,END=555) NALMX,STNMAL,(RSMCAL(NAL),STIDAL(NAL),
1 NAL=1,NALMX)
NRECAL=NRECAL+1
C NO MATCH FOR BOTH STORMS THAT ARE NAMED.
IF(STMNMX .NE. 'NAMELESS' .AND.
1 STNMAL .NE. 'NAMELESS' .AND.
2 STNMAL .NE. STMNMX) GO TO 552
C POSSIBLE MATCH REMAINS: MATCH STORM ID ONLY IN THIS CASE SINCE
C THEY ARE BOTH BANG STORMS.
DO NAL=1,NALMX
IF(STMIDX .EQ. STIDAL(NAL)) THEN
IFNDAL=NRECAL
GO TO 555
ENDIF
ENDDO
GO TO 552
555 CONTINUE
IF(IFNDAL .EQ. 0) THEN
WRITE(6,5571) IBANG,STMNMX,RSMCX,STMIDX
5571 FORMAT('******BANG STORM WITH INDEX=',I3,', NAME,RSMC,ID=',
1 3(A,1X),' CANNOT BE FOUND IN THE ALIAS FILE. ABORT1')
CALL ABORT1(' RSMCCK',5571)
ELSE
WRITE(6,5573) IBANG,STMNMX,RSMCX,STMIDX,IFNDAL
5573 FORMAT('...BANG STORM WITH INDEX=',I3,', NAME,RSMC,ID=',3(A,1X),
1 ' WAS FOUND AS RECORD#',I4,' IN THE ALIAS FILE. ')
ENDIF
ENDIF
C LOOK FOR ALL THE RSMCS THAT HAVE OBSERVED THIS STORM SO FAR
NRSMC=NALMX-1
NALMXZ=NALMX
C LOAD RSMCS FROM THE ALIAS FILE, IF ANY
DO NRS=2,NALMX
DO NRSZ=1,NRSMCX
IF(RSMCAL(NRS) .EQ. RSMCID(NRSZ)) THEN
NRSMCF=NRSZ
ENDIF
ENDDO
IRSMC(NRS-1)=NRSMCF
WRITE(6,6633) NRS-1,RSMCID(NRSMCF)
6633 FORMAT('...STORING ALIAS #',I3,' WHICH IS ',A)
ENDDO
DO NS=1,NSAME
IF(RSMC(NS) (1:1) .EQ. '!') THEN
NPS=2
NPE=4
ELSE
NPS=1
NPE=1
ENDIF
DO NP=NPS,NPE
C COMBINED RSMC CASE
IF(RSMC(NS) (1:1) .EQ. '!') THEN
DO NRSZ=1,NRSMCX
IF(RSMC(NS)(NP:NP) .EQ. RSMCAP(NRSZ)) THEN
NRSMCF=NRSZ
GO TO 591
ENDIF
ENDDO
C INDIVIDUAL RSMC CASE
ELSE
DO NRSZ=1,NRSMCX
IF(RSMC(NS) .EQ. RSMCID(NRSZ)) THEN
NRSMCF=NRSZ
GO TO 591
ENDIF
ENDDO
ENDIF
591 CONTINUE
ISAV=0
DO NRSMS=1,NRSMC
IF(IRSMC(NRSMS) .EQ. NRSMCF) ISAV=ISAV+1
ENDDO
IF(ISAV .EQ. 0) THEN
NRSMC=NRSMC+1
IRSMC(NRSMC)=NRSMCF
C STORE A NEW RSMC IF NECESSARY.
IADDAL=0
DO NAL=2,NALMXZ
IF(RSMCAL(NAL) .EQ. RSMCID(NRSMCF)) IADDAL=IADDAL+1
C WRITE(6,6441) NAL,RSMCAL(NAL),RSMCID(NRSMCF),IADDAL
C6441 FORMAT('...DEBUGGING, NAL,RSMCAL(NAL),RSMCID(NRSMCF),IADDAL=',
C 1 I3,2(1X,A),I3)
ENDDO
IF(IADDAL .EQ. 0) THEN
WRITE(6,641) RSMCID(NRSMCF),STMID(NS)
641 FORMAT('...THE LIST OF OBSERVERS WILL INCLUDE RSMC=',A,' FOR ',
1 'STORM ID=',A)
NALMXZ=NALMXZ+1
STIDAL(NALMXZ)=STMID(NS)
RSMCAL(NALMXZ)=RSMCID(NRSMCF)
ELSE
WRITE(6,643) RSMCID(NRSMCF),STMNMZ
643 FORMAT('...RSMC=',A,' IS ALREADY IN THE LIST OF OBSERVERS FOR ',A)
ENDIF
ENDIF
ENDDO
ENDDO
WRITE(6,651) STMNMZ,STMIDZ,NRSMC,(RSMCID(IRSMC(NRS)),NRS=1,NRSMC)
651 FORMAT(/'...SUMMARY OF ALL OBSERVING RSMCS FOR STORM WITH NAME,',
1 'ID=',2(1X,A),'. NUMBER OF RSMCS=',I3/4X,10(A,2X))
C IF MORE THAN ONE RSMC HAS OBSERVED STORM, UNIFY THE STORM ID
C AND RSMC IF ANY NEW RSMCS HAVE BEEN ADDED.
IF(NRSMC .GT. 1 .OR. IFNDAL .NE. 0) THEN
IF(NALMX .EQ. NALMXZ) THEN
C NO NEW RSMC NEED BE ADDED. COPY STORM ID AND RSMC FROM A BANG
C RECORD.
IRITAL=0
IF(IFNDAL .NE. 0) THEN
WRITE(6,6653) STMNMZ,STMIDZ,STNMAL,STIDAL(1),RSMCAL(1)
6653 FORMAT(/'...STORM WITH NAME, ID=',2(1X,A),' WAS FOUND IN ALIAS ',
1 'FILE WITH NAME=',A,'. ID,RSMC=',2(A,1X))
STMIDZ=STIDAL(1)
RSMCZ=RSMCAL(1)
STMNMZ=STNMAL
ELSE IF(IBANG .NE. 0) THEN
WRITE(6,653)
653 FORMAT('...STORM NOT FOUND IN ALIAS FILE AND NO NEW RSMC HAS ',
1 'BEEN ADDED. STORE RSMC AND STORM ID FROM A BANG RECORD.')
STMIDZ=STMID(IBANG)
RSMCZ=RSMC(IBANG)
ELSE
WRITE(6,655) STMNMZ,STMIDZ
655 FORMAT(/'******STORM WITH NAME, ID=',2(1X,A),' IS NOT LISTED AS ',
1 'A BANG STORM, CANNOT BE FOUND IN THE ALIAS FILE,'/7X,
2 'HAS MORE THAN ONE RSMC BUT NONE ARE TO BE ADDED. ABORT1')
CALL ABORT1(' RSMCCK',655)
ENDIF
ELSE
C ADD A NEW RSMC. COPY RSMC FROM THE BANG STORM RECORD. THEN ADD
C NEW RSMCS. IF THERE IS NO BANG RECORD, MAKE UP A NEW RSMC
C AND STORM ID BASED ON THE EARLIEST RECORD.
IRITAL=1
NWRSMC=NALMXZ-NALMX
WRITE(6,6657) NWRSMC
6657 FORMAT('...',I3,' NEW RSMCS WILL BE ADDED.')
c Mark a relocation flag for the record in which a new
c rsmc has observed storm
do ns=2,nsame
if(rsmc(idasrt(ns)) .ne. rsmc(idasrt(1))) then
write(6,6679) ns,idasrt(1),rsmc(idasrt(1)),idasrt(ns),
1 rsmc(idasrt(ns)),nsame
6679 format('...For ns=',i3,' a new observing rsmc has been detected.',
1 ' Index,rsmc (first,new)=',2(i3,1x,a)/4x,'Total number ',
2 'of observed records=',i3,' We insert a relocation flag ',
3 'in the new record.')
bufinx=ovrrec(indsam(idasrt(ns)))
relocx='R'
ovrrec(indsam(idasrt(ns)))=bufinx
write(6,5509) indsam(idasrt(ns)),bufinx
5509 format('...Record index and corrected record are:',i3/4x,a)
endif
enddo
IF(IBANG .NE. 0) THEN
STMIDZ=STMID(IBANG)
RSMCZ=RSMC(IBANG)
LNRSMC=INDEX(RSMCZ,' ')-1
WRITE(6,657) LNRSMC
657 FORMAT('...BANG STORM EXISTS: STORE RSMC AND STORM ID FROM A ',
1 'BANG RECORD, LENGTH IS:',I2)
NWSLOT=0
DO NAD=1,NWRSMC
NWSLOT=NWSLOT+1
IF(LNRSMC+NWSLOT .LE. 4) THEN
DO NRSZ=1,NRSMCX
IF(RSMCAL(NALMX+NAD) .EQ. RSMCID(NRSZ)) THEN
c write(6,6541) nad,nalmx,nwslot,lnrsmc+nwslot,nrsz,
c 1 rsmcal(nalmx+nad),rsmcid(nrsz)
c6541 format('...debugging, nad,nalmx,nwslot,lnrsmc+nwslot,nrsz,',
c 1 'rsmcal(nalmx+nad),rsmcid(nrsz)'/4x,5i4,2(1x,a))
NRSMCF=NRSZ
GO TO 6561
ENDIF
ENDDO
6561 CONTINUE
RSMCZ(LNRSMC+NWSLOT:LNRSMC+NWSLOT)=RSMCAP(NRSMCF)
WRITE(6,6563) RSMCAP(NRSMCF),RSMCZ
6563 FORMAT('...ADDING RSMC=',A,' TO AN ALREADY DEFINED BANG STORM ',
1 'RSMC. UPDATED RSMC=',A)
ELSE
WRITE(6,6567) NWSLOT,LNRSMC,NWRSMC
6567 FORMAT('###INSUFFICIENT SPACE TO ADD NEW RSMC, NWSLOT,LNRSMC,',
1 'NWRSMC=',3I3)
ENDIF
ENDDO
ELSE
C IN THIS CASE, NO OBSERVERS ARE BANG RECORDS AND THE STORM IS
C NOT IN THE ALIAS FILE. AN ALIAS RECORD MUST BE CREATED AND
C WRITTEN TO THE ALIAS FILE
WRITE(6,659) IDASRT(1),STMID(IDASRT(1)),STMNAM(IDASRT(1))
659 FORMAT(/'...NO BANG STORMS EXIST. EARLIEST RECORD IS:',I3,
1 '. STORM ID IS: ',A,' STORM NAME IS: ',A)
C SUBSTITUTE THE ID OF THE FIRST OBSERVING RSMC AND CONSTRUCT
C A UNIFIED RSMC. SUBSTITUTE STORM NAME IF FIRST OBSERVATION
C DOES NOT HAVE NAMELESS AS A STORM NAME.
RSMCZ=RSMC(IDASRT(1))
STMIDZ=STMID(IDASRT(1))
STMNMZ=STMNAM(IDASRT(1))
C FIRST TWO RSMC SLOTS
IF(RSMCZ(1:1) .EQ. '!') THEN
WRITE(6,663) RSMC(IDASRT(1))(1:2)
663 FORMAT('...THIS RECORD IS A MULTIPLY OBSERVED STORM. COPY THE ',
1 'RSMCAP AND BANG FROM THIS RECORD=',A)
RSMCZ(1:2)=RSMC(IDASRT(1))(1:2)
DO NRSZ=1,NRSMCX
IF(RSMC(IDASRT(1))(2:2) .EQ. RSMCAP(NRSZ)) THEN
NRSST=NRSZ
GO TO 661
ENDIF
ENDDO
661 CONTINUE
ELSE
WRITE(6,667)
667 FORMAT('...THIS RECORD IS A SINGLY OBSERVED STORM. COPY THE ',
1 'RSMC FROM THIS RECORD.')
RSMCZ(1:1)='!'
DO NRSZ=1,NRSMCX
IF(RSMC(IDASRT(1)) .EQ. RSMCID(NRSZ)) THEN
NRSST=NRSZ
GO TO 671
ENDIF
ENDDO
671 CONTINUE
RSMCZ(2:2)=RSMCAP(NRSST)
ENDIF
C REMAINING RSMC SLOTS
NID=2
RSMCZ(3:4)=' '
DO NRS=1,NRSMC
IF(RSMCID(IRSMC(NRS)) .NE. RSMCID(NRSST)) THEN
NID=NID+1
IF(NID .GT. 4) GO TO 680
RSMCZ(NID:NID)=RSMCAP(IRSMC(NRS))
WRITE(6,679) RSMCAP(IRSMC(NRS)),IRSMC(NRS),NID,RSMCZ
679 FORMAT('...ADDING RSMCAP ',A,' FOR RSMC ',I2,' IN SLOT ',I3,
1 ' RSMCZ=',A)
ENDIF
680 CONTINUE
ENDDO
ENDIF
ENDIF
C HAS THE STORM BEEN NAMED BY SOMEONE OVER ITS HISTORY? IF SO,
C SUBSTITUTE THE NAME FOR THE ALIAS FILE.
IF(STMNMZ .EQ. 'NAMELESS') THEN
DO NS=1,NSAME
IF(STMNAM(NS) .NE. 'NAMELESS') THEN
STMNMZ=STMNAM(NS)
WRITE(6,6689) STMNAM(NS),NS
6689 FORMAT('###STORM NAMELESS WILL BE RENAMED ',A,' IN THE ALIAS ',
1 'FILE. INDEX OF NAMED STORM=',I3)
IRITAL=1
GO TO 6691
ENDIF
ENDDO
6691 CONTINUE
ENDIF
C IF NECESSARY, WRITE ALIAS RECORD AND SUBSTITUTE UNIFIED RSMC AND
C STORM ID.
IF(IRITAL .EQ. 1) THEN
WRITE(6,681) STMNMZ,STMIDZ,RSMCZ
681 FORMAT(/'...WRITING A UNIFIED ALIAS RECORD FOR STORM NAME=',A,
1 '. STORM ID AND UNIFIED RSMC ARE:',2(1X,A))
NALADD=NALADD+1
STIDAL(1)=STMIDZ
RSMCAL(1)=RSMCZ
DAYZ=-999.0
CALL AKASAV(NALADD,NALMXZ,DAYZ,STMNMZ,RSMCAL,STIDAL)
ENDIF
DO NS=1,NSAME
BUFINX=OVRREC(INDSAM(NS))
C WRITE(6,683) NS,INDSAM(NS),BUFINX
C 683 FORMAT('...SUBSTITUTING UNIFIED RSMC AND STMID. NS,INDSAM,RECORD',
C 1 ' ARE:',2I3/' ...',A)
STMIDX=STMIDZ
RSMCX=RSMCZ
OVRREC(INDSAM(NS))=BUFINX
C WRITE(6,683) NS,INDSAM(NS),BUFINX
ENDDO
ELSE
WRITE(6,693)
693 FORMAT(/'...ONLY 1 RSMC HAS OBSERVED STORM. THERE IS NO NEED TO',
1 ' UNIFY THE RSMC AND STORM ID IF STORM IDS ARE THE SAME.'
2 /4X,'WE PROCEED TO CHECK STORM ID CONSISTENCY.')
ISAME=0
DO NS=2,NSAME
IF(STMID(NS) .NE. STMIDZ) THEN
IF(ABS(SRTDAY(NS)-SRTDAY(1)) .LE. DTOVR) THEN
ISAME=ISAME+1
IETYP=6
WRITE(6,1683) DTOVR,INDSAM(NS),INDSAM(1),STMID(NS),STMIDZ,
1 STMNAM(NS),STMNMZ,SRTDAY(NS),SRTDAY(1),
2 OVRREC(INDSAM(NS)),OVRREC(INDSAM(1))
1683 FORMAT(/'###TWO STORMS OBSERVED BY THE SAME RSMC WITH TIMES ',
1 'DIFFERING BY LESS THAN ',F5.1,' DAYS AND DIFFERENT ',
2 'STORM ID.'/4X,'THESE ARE PROBABLY THE SAME STORM. IN ',
3 'ORDER (NS,1), INDEX, STORM ID, STORM NAME, DAY AND ',
4 'RECORD ARE:'/10X,2I5,4(2X,A),2F12.3/2(4X,A/))
ELSE
WRITE(6,1687) DTOVR,INDSAM(NS),INDSAM(1),STMID(NS),STMIDZ,
1 STMNAM(NS),STMNMZ,SRTDAY(NS),SRTDAY(1),
2 OVRREC(INDSAM(NS)),OVRREC(INDSAM(1))
1687 FORMAT(/'###TWO STORMS OBSERVED BY THE SAME RSMC WITH TIMES ',
1 'DIFFERING BY MORE THAN ',F5.1,' DAYS AND DIFFERENT ',
2 'STORM ID.'/4X,'THESE ARE PROBABLY NOT THE SAME STORM.',
3 ' IN ORDER (NS,1), INDEX, STORM ID, STORM NAME, DAY ',
4 'AND RECORD ARE:'/10X,2I5,4(2X,A),2F12.3/2(4X,A/))
ENDIF
ENDIF
ENDDO
C STORMS HAVE ALREADY BEEN SORTED IN CHRONOLOGICAL ORDER SO
C SUBSTITUTE THE STORM ID OF THE EARLIEST STORM.
IF(ISAME .NE. 0) THEN
WRITE(6,1695) IDASRT(1),STMID(IDASRT(1)),STMNAM(IDASRT(1))
1695 FORMAT(/'...EARLIEST RECORD IS:',I3,'. STORM ID IS: ',A,' STORM ',
1 'NAME IS: ',A/4X,'THIS STORM ID AND RSMC WILL BE COPIED ',
2 'TO THE FOLLOWING STORMS:')
DO NS=1,NSAME
BUFINX=OVRREC(INDSAM(NS))
STMIDX=STMID(IDASRT(1))
RSMCX =RSMC (IDASRT(1))
OVRREC(INDSAM(NS))=BUFINX
IF(INDSAM(NS) .LE. NOKAY) IFRSMC(NUMOKA(INDSAM(NS)))=-IETYP
WRITE(6,1697) NS,INDSAM(NS),OVRREC(INDSAM(NS))
1697 FORMAT('...',I3,'...',I3,'...',A)
ENDDO
ENDIF
ENDIF
ELSE
WRITE(6,697) NOK,OKAREC(NOK)
697 FORMAT('...OKAY RECORD ',I3,' IS UNIQUE AMONG OKAY AND SHORT-',
1 'TERM HISTORY RECORDS. NO FURTHER PROCESSING WILL BE ',
2 'DONE. RECORD IS:'/4X,'...',A,'...')
ENDIF
700 CONTINUE
ENDDO
CALL AKADMP(IUNTAL)
C SAVE AS BAD RECORDS THOSE ORIGINAL RECORDS THAT HAVE BEEN
C UNIFIED, BUT NOT MULTIPLY OBSERVED, SO THAT THEY CAN BE
C COPIED TO THE ORIGINAL SHORT-TERM HISTORY FILE LATER BY RITSTH.
DO NOK=1,NOKAY
IF(OKAREC(NOK)(1:1) .NE. '!' .AND.
1 OVRREC(NOK)(1:1) .EQ. '!') THEN
IETYP=30
IFRSMC(NUMOKA(NOK))=IETYP
NADD=NADD+1
NUNIFY=NUNIFY+1
NUMBAD(NADD+NBAD)=NUMOKA(NOK)
BADREC(NADD+NBAD)=OKAREC(NOK)
ENDIF
OKAREC(NOK)=OVRREC(NOK)
ENDDO
WRITE(6,711) IUNTOK
711 FORMAT(/'...WE HAVE UNIFIED ALL RECORDS AND ARE WRITING THEM TO ',
1 'THE SCRATCH FILE.'/4X,'THEY WILL BE WRITTEN TO THE ',
2 'ALIAS SHORT-TERM HISTORY FILE IF UPDATING IS REQUIRED.'/
3 4X,'OLD ALIAS SHORT-TERM HISTORY RECORDS WRITTEN TO ',
4 'IUNTOK=',I3,' ARE:')
NRCOVR=0
DO NHA=NOKAY+1,NCHECK
IF(IOVRLP(NHA) .NE. -999) THEN
NRCOVR=NRCOVR+1
WRITE(IUNTOK,521) OVRREC(NHA)
WRITE(6,719) NRCOVR,OVRREC(NHA)
719 FORMAT('...',I3,'...',A,'...')
OVRREC(NRCOVR)=OVRREC(NHA)
ENDIF
ENDDO
WRITE(6,721) NRCOVR
721 FORMAT(/'...IMPORTANT NOTE: THE UPDATED OLD ALIAS SHORT-TERM ',
1 'HISTORY RECORDS ARE RETURNED TO THE MAIN PROGRAM IN ',
2 'OVRREC.'/4X,'THEY WILL BE COPIED INTO THE SCRATCH FILE ',
3 '(INSTEAD OF USING CPYREC) WHEN FILES=F.'/4X,'THE NUMBER',
4 ' OF RECORDS RETURNED IS:',I4)
C COPY NEW ALIAS FILE TO AKAVIT. DON'T COPY RECORDS
C THAT ALREADY EXIST IN AKAVIT.
REWIND IUNTAN
CALL AKACPY(IUNTAN,IUNTAL)
C DO NOT CLEAR OUT THE NEW ALIAS FILE; AKAVIT MAY BE CHANGED BY
C RCNCIL LATER
WRITE(6,1001) NOKAY,-NSUBR,-NUNIFY,NADD,NTEST,
1 (ERCRS(NER),NER=1,NERCRS)
1001 FORMAT(//'...RESULTS OF THE MULTIPLE RSMC CHECK ARE: NOKAY=',I4,
1 ' NSUBR=',I4,' NUNIFY=',I4,' AND NADD=',I4,' FOR A ',
2 'TOTAL OF ',I4,' RECORDS.'//4X,'ERROR CODES ARE:'/(6X,A))
WRITE(6,1003)
1003 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,1009) NOK,NUMOKA(NOK),OKAREC(NOK),-IFRSMC(NUMOKA(NOK))
1009 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
IF(NADD .GT. 0) WRITE(6,1011) (NBAD+NBA,NUMBAD(NBAD+NBA),
1 BADREC(NBAD+NBA),
2 IFRSMC(NUMBAD(NBAD+NBA)),
3 NBA=1,NADD)
1011 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4,
1 '...',A,'...',I3))
NBAD=NBAD+NADD
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: BASNCK CHECKS FOR PROPERLY IDENTIFIED BASINS
C PRGMMR: S. LORD ORG: NP22 DATE: 1992-02-24
C
C ABSTRACT: INPUT RECORDS ARE CHECKED FOR PROPERLY IDENTIFIED BASINS.
C THE INPUT LATIDUDE AND LONGITUDE ARE CHECKED AGAINST
C TABULATED MIN AND MAX LATITUDES AND LONGITUDES FOR THE
C SPECIFIED BASIN. INCONSISTENCIES ARE FLAGGED.
C
C PROGRAM HISTORY LOG:
C 1992-02-19 S. LORD
C
C USAGE: CALL BASNCK(STMIDX,RLTSTM,RLNSTM,NBA,IPRT,IER)
C INPUT ARGUMENT LIST:
C STMIDX - 3 CHARACTER STORM ID. THIRD CHARACTER CARRIES BASIN
C IDENTIFIER
C IPRT - PRINT LEVEL. =1 FOR PRINTOUT; =0 FOR NO PRINTOUT
C
C OUTPUT ARGUMENT LIST:
C NBA - BASIN NUMBER CORRESPONDING TO THE INPUT LAT/LON
C IER - ERROR RETURN CODE:
C 3: STORM IS NOT IN A BASIN DEFINED BY THE TABULATED
C MINIMUM AND MAXIMUM LAT/LON
C 11: BASIN AND BASIN BOUNDARIES DO NOT MATCH. THIS DOES
C NOT NECESSARILY MEAN THERE IS AN ERROR SINCE THE
C STORM COULD HAVE ORIGINATED IN THAT BASIN AND MOVED
C TO ANOTHER
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE BASNCK(STMIDX,RLTSTM,RLNSTM,NBA,IPRT,IER)
SAVE
CHARACTER*(*) STMIDX
PARAMETER (NBASIN=11)
CHARACTER IDBASN*1
DIMENSION IDBASN(NBASIN),BSLTMN(NBASIN),BSLTMX(NBASIN),
1 BSLNMN(NBASIN),BSLNMX(NBASIN)
DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/
C BASIN BOUNDARIES: MIN AND MAX LATITUDES; MIN AND MAX LONGITUDES
C NOTE: SOME BOUNDARIES MAY OVERLAP, BUT SCANNING IS IN ORDER OF
C DECREASING PRIORITY SO BASINS SHOULD BE CAPTURED PROPERLY
DATA BSLTMN/3*-20.,2*0.0,20.,3*-50.,2*0.0/,
1 BSLTMX/4*60.,25.,40.,3*0.0,2*30./,
2 BSLNMN/260.,220.,180.,2*100.,110.,90.,160.,40.,75.,40./,
3 BSLNMX/350.,260.,220.,180.,125.,140.,160.,290.,90.,100.,75./
IER=0
C RECOVER BASIN NUMBER FROM STORM ID
C WE ASSUME ALL BASIN IDS ARE VALID HERE
DO NB=1,NBASIN
IF(STMIDX(3:3) .EQ. IDBASN(NB)) THEN
NBA=NB
GO TO 11
ENDIF
ENDDO
11 CONTINUE
IF(RLTSTM .LT. BSLTMN(NBA) .OR. RLTSTM .GT. BSLTMX(NBA) .OR.
1 RLNSTM .LT. BSLNMN(NBA) .OR. RLNSTM .GT. BSLNMX(NBA)) THEN
IF(IPRT .EQ. 1) WRITE(6,21) STMIDX,NBA,RLTSTM,RLNSTM,BSLTMN(NBA),
1 BSLTMX(NBA),BSLNMN(NBA),BSLNMX(NBA)
21 FORMAT(/'******BASIN IDENTIFIER AND LAT/LON ARE INCONSISTENT. A ',
1 'POSSIBLE ERROR EXISTS OR THE STORM ORIGINATED IN A ',
2 'DIFFERENT BASIN.'/4X,'STMIDX,NBA,RLTSTM,RLNSTM,BSLTMN(',
3 'NBA),BSLTMX(NBA),BSLNMN(NBA),BSLNMX(NBA)='/4X,A,I3,6F8.1)
IER=11
C IN WHICH BASIN IS THE STORM REALLY LOCATED?
DO NB=1,NBASIN
IF(RLTSTM .GE. BSLTMN(NB) .AND. RLTSTM .LE. BSLTMX(NB) .AND.
1 RLNSTM .GE. BSLNMN(NB) .AND. RLNSTM .LE. BSLNMX(NB)) THEN
NBA=NB
RETURN
ENDIF
ENDDO
IER=3
WRITE(6,51) STMIDX,NBA,RLTSTM,RLNSTM,BSLTMN(NBA),
1 BSLTMX(NBA),BSLNMN(NBA),BSLNMX(NBA)
51 FORMAT(/'******STORM=',A,' IS NOT IN A DEFINED BASIN. NBA,',
1 'RLTSTM,RLNSTM,BSLTMN(NBA),BSLTMX(NBA),BSLNMN(NBA),',
2 'BSLNMX(NBA)='/I3,6F8.1)
ENDIF
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AKASUB HANDLES STORAGE AND WRITING ALIAS RECORDS
C PRGMMR: S. LORD ORG: NP22 DATE: 1992-03-05
C
C ABSTRACT: STORES ALIAS RECORDS UNTIL THEY ARE READY TO BE DUMPED TO
C DISK. DUMPING TO DISK INVOLVES FINDING THE ONE RECORD FOR
C EACH STORM THAT HAS THE EARLIEST DATE. COPYING FROM ONE
C UNIT TO ANOTHER ALSO INVOLVES FINDING THE EARLIEST DATE.
C FUNCTIONS ARE PERFORMED BY 3 SEPARATE ENTRIES AS SHOWN
C BELOW. AKASUB IS JUST A DUMMY HEADING.
C
C PROGRAM HISTORY LOG:
C 1992-03-05 S. LORD
C
C USAGE: CALL AKASUB(IUNITI,IUNITO,NAKREC,NAKA,DAYZ,AKANAM,AKRSMC,
C AKSTID)
C CALL AKASAV(NAKREC,NAKA,DAYZ,AKANAM,AKRSMC,AKSTID): STORES
C RECORDS
C CALL AKADMP(IUNITO): DUMPS RECORDS TO DISK
C CALL AKACPY(IUNITI,IUNITO): COPIES RECORDS FROM IUNITI TO
C IUNITO
C INPUT ARGUMENT LIST:
C IUNITI - INPUT UNIT NUMBER. FILE POSITIONING MUST BE HANDLED
C - OUTSIDE THIS ROUTINE.
C IUNITO - OUTPUT UNIT NUMBER. FILE POSITIONING MUST BE HANDLED
C - OUTSIDE THIS ROUTINE.
C NAKREC - RECORD NUMBER, FIRST RECORD IS 1 AND SO ON.
C NAKA - NUMBER OF ALIASES IN EACH RECORD. FIRST ALIAS IS
C - USUALLY A COMBINED OR UNIFIED ALIAS BEGINNING WITH A !.
C DAYZ - FRACTIONAL DAY FOR EACH RECORD
C AKANAM - STORM NAME (CHARACTER*9)
C AKRSMC - ARRAY CONTAINING ALL RSMCS (CHARACTER*4)
C AKSTID - ARRAY CONTAINING ALL STORM IDS (CHARACTER*3)
C
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE AKASUB(IUNITI,IUNITO,NAKREC,NAKA,DAYZ,AKANAM,AKRSMC,
1 AKSTID,ICSTNM,ICRSMC,ICSTID,IFAKA)
PARAMETER (MAXSTM=70)
PARAMETER (NOVRMX=MAXSTM)
PARAMETER (MAXAKA=10)
SAVE
DIMENSION NUMSAV(MAXSTM),SAVNAM(MAXSTM),SAVRSM(MAXSTM,MAXAKA),
1 SAVID(MAXSTM,MAXAKA),SAVDAY(MAXSTM),INDSAM(MAXSTM)
DIMENSION AKRSMC(NOVRMX),AKSTID(NOVRMX),RSMCCP(MAXAKA),
1 STIDCP(MAXAKA)
CHARACTER SAVNAM*9,SAVRSM*4,SAVID*3,STMNMX*9,RSMCCP*4,STIDCP*3
CHARACTER*(*) AKANAM,AKRSMC,AKSTID,ICSTNM,ICRSMC,ICSTID
LOGICAL FOUND
C-----------------------------------------------------------------------
C THIS ENTRY STORES ALIAS ENTRIES
ENTRY AKASAV(NAKREC,NAKA,DAYZ,AKANAM,AKRSMC,AKSTID)
WRITE(6,1) NAKREC
1 FORMAT(/'...ENTERING AKASAV TO STORE RECORD #',I3,'. RECORD IS:')
NAKSAV=NAKREC
NUMSAV(NAKSAV)=NAKA
SAVNAM(NAKSAV)=AKANAM
SAVDAY(NAKSAV)=DAYZ
SAVRSM(NAKSAV,1:NAKA)=AKRSMC(1:NAKA)
SAVID (NAKSAV,1:NAKA)=AKSTID(1:NAKA)
WRITE(6,11) NAKA,AKANAM,(AKRSMC(NAL),AKSTID(NAL),NAL=1,NAKA)
11 FORMAT('...',I1,1X,A9,10(1X,A4,1X,A3))
RETURN
C-----------------------------------------------------------------------
C THIS ENTRY DUMPS ALIAS ENTRIES. ONLY THE EARLIEST ENTRY FOR
C EACH STORM IS SAVED.
ENTRY AKADMP(IUNITO)
WRITE(6,21) IUNITO
21 FORMAT(/'...ENTERING AKADMP TO WRITE EARLIEST UNIQUE ALIAS ',
1 'RECORDS TO UNIT',I3,'. STORED RECORDS ARE:'/10X,'NAL',
2 4X,'NAME',12X,'JDAY',5X,'RSMC',2X,'STMID')
DO NAK=1,NAKSAV
WRITE(6,23) NAK,NUMSAV(NAK),SAVNAM(NAK),SAVDAY(NAK),
1 (SAVRSM(NAK,NS),SAVID(NAK,NS),NS=1,NUMSAV(NAK))
23 FORMAT(3X,I3,2X,I3,4X,A,3X,F12.3,10(3X,A))
ENDDO
NREC=0
DO NAK=1,NAKSAV
IF(NUMSAV(NAK) .GT. 0) THEN
IFND=1
INDSAM(IFND)=NAK
WRITE(6,27) NAK,IFND,SAVNAM(NAK),SAVDAY(NAK),(SAVRSM(NAK,NSAV),
1 SAVID(NAK,NSAV),NSAV=1,NUMSAV(NAK))
27 FORMAT(/'...LOOKING FOR MATCHING STORM NAMES FOR INDEX=',I3,
1 ', IFND=',I3,' STORM NAME= ',A,' WITH DAY=',F12.3/4X,
2 'ALIASES ARE: ',10(A,1X,A,'; '))
WRITE(6,29)
29 FORMAT('...IMPORTANT NOTE: ALIAS RECORDS WITH DATE=-999.0 WILL ',
1 'ALWAYS BE COPIED.')
DO NSAME=NAK+1,NAKSAV
IF(NUMSAV(NSAME) .GT. 0) THEN
FOUND=.FALSE.
C SAME STORM NAME IF NOT NAMELESS
IF(SAVNAM(NAK) .NE. 'NAMELESS' .AND.
1 SAVNAM(NSAME) .NE. 'NAMELESS' .AND.
2 SAVNAM(NAK) .EQ. SAVNAM(NSAME)) THEN
FOUND=.TRUE.
C DIRECT COMPARISON OF STORM IDS FOR THE SAME RSMC
ELSE
DO NAL2=1,NUMSAV(NAK)
DO NAL1=1,NUMSAV(NSAME)
IF(SAVRSM(NSAME,NAL1) .EQ. SAVRSM(NAK,NAL2) .AND.
1 SAVID (NSAME,NAL1) .EQ. SAVID (NAK,NAL2)) FOUND=.TRUE.
ENDDO
ENDDO
ENDIF
IF(FOUND) THEN
NUMSAV(NSAME)=-IABS(NUMSAV(NSAME))
IFND=IFND+1
INDSAM(IFND)=NSAME
WRITE(6,59) NSAME,IFND,SAVDAY(NSAME)
59 FORMAT(/'...STORM NAME FOR INDEX=',I3,' MATCHES. IFND=',I3,' AND',
1 ' DAY=',F12.3)
ENDIF
ENDIF
ENDDO
C SINGLE OCCURRENCE
IF(IFND .EQ. 1) THEN
NW=NAK
DAYMNZ=SAVDAY(NAK)
STMNMX=SAVNAM(NAK)
WRITE(6,61) NW,SAVNAM(NAK),SAVID(NAK,1)
61 FORMAT('...INDEX',I3,' WITH NAME=',A,' AND ID=',A,' HAS ONLY A ',
1 'SINGLE OCCURRENCE.')
C IF THERE ARE MULTIPLE OCCURRENCES, WRITE ONLY THE EARLIEST RECORD,
C BUT SUBSTITUTE IN THE STORM NAME IF IT IS NOT NAMELESS.
ELSE
WRITE(6,63) SAVNAM(NAK),SAVID(NAK,1)
63 FORMAT('...STORM NAME=',A,' AND ID=',A,' HAS MULTIPLE ',
1 'OCCURRENCES. WE LOOK FOR THE FIRST OCCURRENCE.')
DAYMNZ=1.E10
STMNMX='NAMELESS'
DO IF=1,IFND
IF(STMNMX .EQ. 'NAMELESS' .AND.
1 SAVNAM(INDSAM(IF)) .NE. 'NAMELESS')
1 STMNMX=SAVNAM(INDSAM(IF))
IF(SAVDAY(INDSAM(IF)) .LT. DAYMNZ) THEN
DAYMNZ=SAVDAY(INDSAM(IF))
NW=INDSAM(IF)
ENDIF
ENDDO
ENDIF
C WRITE THE RECORD
NREC=NREC+1
WRITE(IUNITO,81) IABS(NUMSAV(NW)),STMNMX,(SAVRSM(NW,NAL),
1 SAVID(NW,NAL),NAL=1,IABS(NUMSAV(NW)))
81 FORMAT(I1,1X,A9,10(1X,A4,1X,A3))
WRITE(6,83) NREC,DAYMNZ,NW,IUNITO,STMNMX,
1 IABS(NUMSAV(NW))-1,(SAVRSM(NW,NAL),SAVID(NW,NAL),
2 NAL=1,IABS(NUMSAV(NW)))
83 FORMAT('...ADDING NEW ALIAS RECORD ',I3,' WITH DATE=',F12.3,
1 ' AND INDEX',I3,' TO UNIT ',I3,' FOR STORM NAME=',A,'.'/4X,
2 'NUMBER OF OBSERVERS IS:',I2,' RSMC, STORM IDS ARE:'/10X,
3 10(1X,A4,1X,A3))
ENDIF
ENDDO
WRITE(6,91) NREC,IUNITO
91 FORMAT(/'...',I3,' RECORDS HAVE BEEN WRITTEN TO UNIT',I3)
RETURN
C-----------------------------------------------------------------------
ENTRY AKACPY(IUNITI,IUNITO)
NCPYAL=0
WRITE(6,101) IUNITI,IUNITO
101 FORMAT(/'...ENTERING AKACPY TO COPY ALIAS RECORDS FROM IUNITI=',
1 I3,' TO IUNITO=',I3,':')
110 READ(IUNITI,81,END=180) NALMX,STMNMX,(RSMCCP(NAL),STIDCP(NAL),
1 NAL=1,NALMX)
DO NALZ=1,NAKSAV
FOUND=.FALSE.
C SAME STORM NAME IF NOT NAMELESS
IF(STMNMX .NE. 'NAMELESS' .AND.
1 SAVNAM(NALZ) .NE. 'NAMELESS' .AND.
2 STMNMX .EQ. SAVNAM(NALZ)) THEN
FOUND=.TRUE.
GO TO 171
C DIRECT COMPARISON OF STORM IDS FOR THE SAME RSMC
ELSE
DO NAL2=1,NALMX
DO NAL1=1,NUMSAV(NALZ)
IF(SAVRSM(NALZ,NAL1) .EQ. RSMCCP(NAL2) .AND.
1 SAVID (NALZ,NAL1) .EQ. STIDCP(NAL2)) FOUND=.TRUE.
ENDDO
ENDDO
ENDIF
ENDDO
171 CONTINUE
IF(.NOT. FOUND) THEN
NCPYAL=NCPYAL+1
WRITE(IUNITO,81) NALMX,STMNMX,(RSMCCP(NAL),STIDCP(NAL),
1 NAL=1,NALMX)
WRITE(6,175) NALMX,STMNMX,(RSMCCP(NAL),STIDCP(NAL),
1 NAL=1,NALMX)
175 FORMAT('...',I1,1X,A9,10(1X,A4,1X,A3))
ELSE
WRITE(6,177) STMNMX
177 FORMAT('...STORM ',A,' IS ALREADY IN OUTPUT ALIAS FILE. IT WILL ',
1 'NOT BE COPIED.')
ENDIF
GO TO 110
180 CONTINUE
WRITE(6,181) NCPYAL,IUNITI,IUNITO
181 FORMAT('...',I3,' RECORDS COPIED FROM UNIT',I3,' TO UNIT ',I3,'.')
RETURN
C-----------------------------------------------------------------------
ENTRY AKAFND(IUNITI,ICSTNM,ICRSMC,ICSTID,NAKA,AKANAM,AKRSMC,
1 AKSTID,IFAKA)
ifaka=0
irec=0
rewind iuniti
210 read(iuniti,81,end=240) nalmx,stmnmx,(rsmccp(nal),stidcp(nal),
1 nal=1,min(nalmx,maxaka))
irec=irec+1
do nal=1,nalmx
if(icrsmc .eq. rsmccp(nal) .and.
1 icstid .eq. stidcp(nal)) then
ifaka=irec
go to 240
endif
enddo
go to 210
240 continue
if(ifaka .gt. 0) then
if(nalmx .gt. naka) then
write(6,241) nalmx,naka
241 format('******Insufficient storage to return aliases. nalmx,',
1 'naka=',2i5,' Abort.')
call abort1(' AKAFND',241)
endif
naka=nalmx
akanam=stmnmx
akrsmc(1:nalmx)=rsmccp(1:nalmx)
akstid(1:nalmx)=stidcp(1:nalmx)
c write(6,251) naka,ifaka,icstnm,icrsmc,icstid,akanam,
c 1 (akrsmc(nal),akstid(nal),nal=1,naka)
c 251 format('...akafnd results: # of aliases=',i4,' matching alias ',
c 1 'record #=',i4,' input storm name,rsmc,id=',3(a,1x)/4x,
c 2 'matched name,rsmc,id=',a/(4x,10(1x,a4,1x,a3)))
else
c write(6,271) icstnm,icrsmc,icstid
c 271 format('###Storm not found in akavit file, storm name,rsmc,',
c 1 'id are:',3(a,1x))
endif
return
C-----------------------------------------------------------------------
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: TCCLIM TROPICAL CYCLONE CLIMATOLOGICAL VALUES
C PRGMMR: S. LORD ORG: NP22 DATE: 1992-04-07
C
C ABSTRACT: RETURNS CLIMATOLOGICAL VALUES FOR SOME TROPICAL CYCLONE
C PROPERTIES. PROPERTIES ARE: CENTRAL PRESSURE OF STORM;
C ENVIRONMENTAL PRESSURE ON THAT ISOBAR RADIUS OF THE OUTERMOST
C CLOSED ISOBAR A SECOND ENTRY CONTAINS PRESSURE-WIND TABLES FOR
C THE ATLANTIC, EAST AND CENTRAL PACIFIC AND WEST PACIFIC BASINS.
C
C PROGRAM HISTORY LOG:
C 1992-04-07 S. LORD
C 1992-09-04 S. LORD ADDED PRESSURE WIND RELATIONSHIP
C
C USAGE: VALUE=TCCLIM(IVAR,IBASN) OR VALUE=TCPWTB(PRES,IBASN)
C INPUT ARGUMENT LIST:
C IVAR - VARIABLE NUMBER (7: CENTRAL PRESSURE)
C - (8: ENVIRONMENTAL PRESSURE)
C - (9: RADIUS OF OUTERMOST CLOSED ISOBAR)
C IBASN - BASIN NUMBER
C PRES - PRESSURE IN MB
C
C
C REMARKS: IVAR VALUES OF 7,8,9 ONLY ARE ALLOWED.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
FUNCTION TCCLIM(IVAR,IBASN)
PARAMETER (NPRMAX=9)
PARAMETER (NBASIN=11)
PARAMETER (ISECVR= 5,ITERVR=10)
PARAMETER (NSECVR=ITERVR-ISECVR)
DIMENSION SECVCL(NBASIN,NSECVR-2),PRTABL(NBASIN,0:NPRMAX+1),
1 VMTABL(NBASIN,0:NPRMAX+1)
DATA SECVCL/3*940.0,3*930.0,2*970.0,3*960.0,
1 3*1010.0,5*1008.0,3*1010.0,
2 6*400.0,5*300.0/
DATA PRTABL/2*1020.,9*1020., 2*987.,9*976.,
2 2*979.,9*966., 2*970.,9*954.,
2 2*960.,9*941., 2*948.,9*927.,
3 2*935.,9*914., 2*921.,9*898.,
4 2*906.,9*879., 2*890.,9*858.,
5 2*850.,9*850./
DATA VMTABL/11*12.5,11*33.5,11*39.7,11*46.4,11*52.6,11*59.3,
1 11*65.5,11*72.2,11*80.0,11*87.6,11*110./
ITABL=IVAR-(ISECVR+2)+1
TCCLIM=SECVCL(IBASN,ITABL)
RETURN
C-----------------------------------------------------------------------
ENTRY TCPWTB(PRESR,IBASN)
DO IPR=1,NPRMAX
IF(PRESR .LE. PRTABL(IBASN,IPR-1) .AND.
1 PRESR .GT. PRTABL(IBASN,IPR)) THEN
IPRZ=IPR
GO TO 11
ENDIF
ENDDO
IPRZ=NPRMAX+1
11 CONTINUE
TCPWTB=VMTABL(IBASN,IPRZ-1)+
1 (VMTABL(IBASN,IPRZ)-VMTABL(IBASN,IPRZ-1))*
2 (PRESR-PRTABL(IBASN,IPRZ-1))/
3 (PRTABL(IBASN,IPRZ)-PRTABL(IBASN,IPRZ-1))
RETURN
C-----------------------------------------------------------------------
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: RCNCIL MANAGES STORM CATALOG
C PRGMMR: S. LORD ORG: NP22 DATE: 1993-03-05
C
C ABSTRACT: STORM RECORDS ARE CHECKED FOR PRESENCE IN THE STORM
C CATALOG UPDATED AND ADDED IF NECESSARY.
C
C PROGRAM HISTORY LOG:
C 1992-03-25 S. LORD
C 1992-08-25 S. LORD ADDED IER RETURN CODE
C
C USAGE: CALL RCNCIL(IUNTCA,IUNTCN,IUNTAL,NTEST,NOKAY,NBAD,MAXREC,
C MAXCKS,IEFAIL,IER,IECAT,NUMTST,NUMOKA,NUMBAD,
C TSTREC,BADREC,OKAREC)
C INPUT ARGUMENT LIST:
C IUNTCA - UNIT NUMBER FOR THE STORM CATALOG.
C
C IUNTCN - UNIT NUMBER FOR THE TEMPORARY CATALOG
C
C IUNTAL - UNIT NUMBER FOR ALIAS FILE.
C NTEST - NUMBER OF CURRENT RECORDS TO BE TESTED.
C MAXREC - MAXIMUM NUMBER OF RECORDS (STORAGE FOR ARRAYS)
C MAXCKS - MAXIMUM NUMBER OF ERROR CHECKS (STORAGE FOR ARRAYS)
C IEFAIL - ARRAY CONTAINING ERROR CODES FOR ERROR CHECKS
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C IOVRLP - SCRATCH ARRAY.
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE RSMC CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE RSMC CHECK.
C IER - ERROR RETURN CODE. 0 EXCEPT IF LOGICAL INCONSISTENCY
C FOUND.
C IECAT - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE RSMC CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE RSMC CHECK.
C
C INPUT FILES:
C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB
C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS
C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S
C UNIT 27 - STORM CATALOG FILE
C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB
C UNIT 28 - SCRATCH STORM CATALOG FILE
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 27 - SAME AS ABOVE
C UNIT 28 - SAME AS ABOVE
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE RCNCIL(IUNTCA,IUNTCN,IUNTAL,NTEST,NOKAY,NBAD,MAXREC,
1 MAXCKS,IEFAIL,IER,IECAT,NUMTST,NUMOKA,NUMBAD,
2 TSTREC,BADREC,OKAREC)
PARAMETER (NERCRC=3)
PARAMETER (MAXSTM=70)
PARAMETER (NOVRMX=MAXSTM)
PARAMETER (NADDMX=10)
CHARACTER*(*) TSTREC(0:NTEST),BADREC(MAXREC),OKAREC(NOKAY),
1 ERCRCN(NERCRC)*60
character stnmal*9,stidal*3,rsmcal*4,stnmca*9,stidca*3,rsmcca*4,
1 stidad*3,rsmcad*4
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (NBASIN=11)
PARAMETER (NRSMCX=4)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,IDBASN*1,
2 RSMCID*4,RSMCAP*1
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION BUFIN(MAXCHR),IDBASN(NBASIN),
1 FMTVIT(MAXVIT),RSMCID(NRSMCX),RSMCAP(NRSMCX)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
DIMENSION IVTVRX(MAXVIT)
DIMENSION RINC(5)
CHARACTER BUFCK(MAXCHR)*1,RSMCX*4,RELOCX*1,STMIDX*3,BUFINX*100,
1 STMNMX*9,LATNSX*1,LONEWX*1
DIMENSION IEFAIL(MAXREC,0:MAXCKS),IECAT(MAXREC),NUMOKA(NOKAY),
1 NUMBAD(MAXREC),NUMTST(NTEST),MAXNO(NBASIN)
dimension rsmcal(novrmx),stidal(novrmx),
1 rsmcca(novrmx),stidca(novrmx),
2 rsmcad(naddmx),stidad(naddmx)
EQUIVALENCE (BUFCK(1),RSMCX),(BUFCK(5),RELOCX),(BUFCK(6),STMIDX),
1 (BUFCK(1),BUFINX),(BUFCK(10),STMNMX),
2 (BUFCK(35),LATNSX),(BUFCK(41),LONEWX)
EQUIVALENCE (IVTVRX(1),IDATEX),(IVTVRX(2),IUTCX)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/
DATA RSMCID/'NHC ','JTWC','ADRM','JMA '/,
1 RSMCAP/'N','W','A','J'/
data maxno/nbasin*0/,minday/-1/,maxday/1/
DATA ERCRCN
1 /'10: NEW STORM, ADD TO CATALOG ',
2 '20: DUP. STORM ID IN CATALOG. CREATE NEW ID, APPEND CATALOG ',
3 '30: STORM FOUND IN CATALOG, UPDATE CATALOG ENTRY '/
write(6,1) nokay
1 format(//'...Entering rcncil to reconcile catalog, alias file ',
1 'and new records. Number of okay records=',i4/4x,'Codes',
2 ' are:'/10x,'1: No catalog entry'/13x,'Action: Append ',
3 'catalog (first time appearance), record unchanged'/10x,
4 '2: Duplicate storm id to primary catalog id'/13x,
5 'Action: Find new, unique id which is one more than the',
6 'largest id for that basin, modify record, append to ',
7 'catalog'/10x,'3: Storm found in catalog,'/13x,'Action:',
8 'update catalog entry')
rewind iuntca
rewind iuntcn
ncat=0
ipack=10*maxrec
nadd=0
ier=0
write(6,3)
3 format(/'...Input records are:')
do iec=1,ntest
iecat(iec)=ipack
write(6,5) iec,numtst(iec),tstrec(iec)
5 format('...',i4,'...',i5,'...',a)
enddo
call sclist(iuntca)
call aklist(iuntal)
c First pass through catalog to determine what should be done
20 continue
READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3))
ncat=ncat+1
c Determine maximum storm id in each basin from the catalog
read(stidca(1)(1:2),23) idno
23 format(i2)
do nb=1,nbasin
if(stidca(1)(3:3) .eq. idbasn(nb)) then
maxno(nb)=max0(maxno(nb),idno)
go to 31
endif
enddo
31 continue
c Determine the catalog code for each record
c Codes and actions are:
c Code 1: No catalog entry
c Action: Append catalog (first time appearance), record unchanged
c Code 2: Duplicate storm id to primary catalog id, storm not
c found in catalog
c Action: Find new, unique id which is one more than the largest
c id for that basin, modify record, append to catalog
c Code 3: Storm found in catalog
c Action: Update catalog date and other entries if necessary
c Notes: codes from 1-3 are in order of increasing priority so that
c a code of 2 can be overridden by a code of 3
c A final check on the consistency between the catalog and the alias
c (akavit) file is made. Any inconsistency is resolved in favor of t
c catalog but is flagged by a positive error code even though the
c record is retained.
c Codes are packed so that the appropriate record number in the
c catalog is recoverable. Packing depends on maxrec, which
c should be a 4 digit number (1000 should work fine).
do 80 nrec=1,ntest
c Look at okay records and bad records with overland error codes.
c An error code for the rsmcck of 22 forces a look at the
c alias file since an entry has been made already.
if(nrec .le. nokay .or.
1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or.
2 iefail(numtst(nrec),4) .eq. 6 .or.
3 iefail(numtst(nrec),6) .eq. 22))) then
bufinz=tstrec(nrec)
if(rsmcz(1:1) .ne. '!' .and. iefail(numtst(nrec),6) .ne. 22)
1 then
nalsav=1
stnmal=stmnmz
rsmcal(1)=rsmcz
stidal(1)=stmidz
else
c write(6,35) nrec,stmnmz,rsmcz,stmidz
c 35 format('...Calling akafnd for record',i4,' with storm name,',
c 1 'rsmc,id=',3(a,1x),' to find all aliases.')
nalsav=novrmx
call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmal,rsmcal,
1 stidal,ifnd)
if(ifnd .eq. 0) then
write(6,37) stmnmz,stmidz,rsmcz
37 format('******Bang or overlapped storm not found in akavit file ',
1 'when finding aliases. stmnmz,stmidz,rsmcz=',3(1x,a),
2 ' abort')
c call abort1(' RCNCIL',37)
endif
endif
do nal=1,nalsav
c Code 3:
c if the record is nameless the entire storm id and rsmc
c must match
IF(STMNMZ .NE. 'NAMELESS') THEN
if(stnmca .eq. stnmal .and.
1 stidca(1)(3:3) .eq. stidal(nal)(3:3)) then
iecat(nrec)=3*ipack+ncat
write(6,43) nrec,stnmal,stidal(nal),rsmcal(nal),iecat(nrec)
43 format('...For nrec=',i5,' storm named=',a,' with id,rsmc=',
1 2(a,1x),' is in catalog, iecat=',i6)
go to 80
endif
ENDIF
do nca=1,nalca
if(rsmcal(nal) .eq. rsmcca(nca) .and.
1 stidal(nal) .eq. stidca(nca)) then
iecat(nrec)=3*ipack+ncat
write(6,47) nrec,nca,stnmal,stidal(nal),rsmcal(nal),iecat(nrec)
47 format('...For nrec,nca=',2i5,' storm named=',a,' with id,rsmc=',
1 2(a,1x),' is in catalog, iecat=',i6)
go to 80
endif
enddo
enddo
c Code 2: now there is no exact match to the catalog - make sure the
c won't be a duplicate storm id
c Possibilities are:
c 1) If both record and catalog are bang, RSMCCK may have changed th
c rsmc (e.g. added a new observing rsmc). We assume the storm is
c in the catalog (code 3).
c 2) If the catalog is a bang, and the record is not, the record is
c new storm (code 2) or the records has been processed by rsmcc
c but not yet by rcncil. Check the AKAVIT file and adjust the
c code accordingly.
c 3) Neither record or catalog entry is a bang (code 2).
if(stmidz .eq. stidca(1)) then
if(rsmcz(1:1) .eq. '!' .and.
1 rsmcca(1)(1:1) .eq. '!') then
iecatz=3
write(6,71) nrec,stmidz,ncat,rsmcz,rsmcca(1)
71 format(/'...For nrec=',i5,' only storm id=',a,' matches catalog ',
1 'entry',i5,'. Record and catalog rsmcs are both bang:',
2 2(1x,a)/4x,'###This case should never happen!')
else if(rsmcz(1:1) .ne. '!' .and.
1 rsmcca(1)(1:1) .eq. '!') then
write(6,73) nrec,stmidz,rsmcz,rsmcca(1),stmnmz,rsmcz,stmidz
73 format('...For nrec=',i5,' only storm id=',a,' matches catalog ',
1 'entry.'/4x,'...Record rsmc (',a,') is not bang but ',
2 'catalog rsmc is (',a,').'/4x,'...Calling akafnd with ',
3 'storm name, rsmc, id=',3(a,1x),' to find all aliases.')
nalsav=novrmx
call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmal,rsmcal,
1 stidal,ifnd)
if(ifnd .eq. 1) then
write(6,75)
75 format(3x,'...Record found in alias file. Code 3 assigned.')
iecatz=3
else
write(6,77)
77 format(3x,'...Record not found in alias file. Code 2 retained.')
iecatz=2
endif
else
iecatz=2
write(6,79) nrec,stmidz,ncat,rsmcz,rsmcca(1)
79 format(/'...For nrec=',i5,' only storm id=',a,' matches catalog ',
1 'entry',i5,'. Rsmcs are:',2(1x,a)/4x,' ###Probable new ',
2 'storm with a duplicate storm id')
endif
iecat(nrec)=max0(iecat(nrec)/ipack,iecatz)*ipack+ncat
endif
endif
80 continue
c Write to the scratch catalog
WRITE(IUNTCN,21) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
go to 20
90 continue
if(ncat .eq. 0) then
write(6,91)
91 format(/'...There are no catalog entries. All input records will',
1 ' be assigned code 1.')
iecat(1:ntest)=ipack
endif
write(6,131)
131 format('...Summary of catalog codes for first scan:')
do nrec=1,ntest
if(nrec .le. nokay .or.
1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or.
2 iefail(numtst(nrec),4) .eq. 6 .or.
3 iefail(numtst(nrec),6) .eq. 22))) then
write(6,133) nrec,iecat(nrec),tstrec(nrec)
133 format(4x,2i6,1x,'...',a,'...')
if(iabs(iefail(numtst(nrec),5)) .le. 9) then
iefail(numtst(nrec),5)=-(iabs(iefail(numtst(nrec),5))+
1 iabs(iecat(nrec))/ipack*10)
endif
endif
enddo
write(6,143) (nb,idbasn(nb),maxno(nb),nb=1,nbasin)
143 format('...Summary of maximum storm ids for each basin:'/(4x,i3,
1 1x,a,i4))
c Second pass: copy back from the scratch catalog and update
c each entry as needed
rewind iuntca
rewind iuntcn
ncat=0
201 continue
READ(IUNTCN,21,END=300) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
ncat=ncat+1
c ***********************
c **** Code 3 errors ****
c ***********************
do nrec=1,ntest
if(nrec .le. nokay .or.
1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or.
2 iefail(numtst(nrec),4) .eq. 6 .or.
3 iefail(numtst(nrec),6) .eq. 22))) then
bufinz=tstrec(nrec)
ietyp=iecat(nrec)/ipack
ircat=iecat(nrec)-ietyp*ipack
if(ircat .eq. ncat .and. ietyp .eq. 3) then
write(6,213) nrec,bufinz,NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
213 format(/'...Preparing to reconcile code 3 errors for nrec=',i3,
1 ' record, catalog entry are:'/4x,a,'...'/4x,i1,1x,a9,2(1x,
2 i8,1x,i4.4),10(1x,a4,1x,a3))
IF(STMNMZ .NE. 'NAMELESS' .AND. STNMCA .EQ. 'NAMELESS') THEN
write(6,217) stnmca,ncat,stmnmz,nrec
217 format('...',a,' storm with catalog entry=',i4,' will have name=',
1 a,' assigned, nrec=',i4)
STNMCA=STMNMZ
ENDIF
do iv=1,2
call decvar(istvar(iv),ienvar(iv),ivtvar(iv),ierdec,fmtvit(iv),
1 bufinz)
enddo
call mnmxda(iymdmn,iutcmn,idatez,iutcz,dayz,minday)
call mnmxda(iymdmx,iutcmx,idatez,iutcz,dayz,maxday)
daysav=dayz
ilate=nrec
c Do all records identified as the same storm
do nchk=nrec+1,ntest
if(nchk .le. nokay .or.
1 (nchk .gt. nokay .and. (iefail(numtst(nchk),4) .eq. 5 .or.
2 iefail(numtst(nchk),4) .eq. 6 .or.
3 iefail(numtst(nchk),6) .eq. 22))) then
bufinx=tstrec(nchk)
ietypx=iecat(nchk)/ipack
ircatx=iecat(nchk)-ietyp*ipack
if(ircatx .eq. ncat .and. ietypx .eq. 3) then
IF(STMNMX .NE. 'NAMELESS' .AND. STNMCA .EQ. 'NAMELESS') THEN
write(6,227) stnmca,ncat,stmnmx,nchk
227 format('...',a,' storm with catalog entry=',i4,' will have name=',
1 a,' assigned, nchk=',i4)
STNMCA=STMNMX
ENDIF
do iv=1,2
call decvar(istvar(iv),ienvar(iv),ivtvrx(iv),ierdec,fmtvit(iv),
1 bufinx)
enddo
c write(6,231) nchk,iymdmn,iutcmn,idatex,iutcx,bufinx
c 231 format('...calling mnmxda with nchk,iymdmn,iutcmn,idatex,iutcx,'
c 1 'bufinx=',i4,i9,i6,i7,i6/4x,a)
call mnmxda(iymdmn,iutcmn,idatex,iutcx,dayz,minday)
call mnmxda(iymdmx,iutcmx,idatex,iutcx,dayz,maxday)
if(dayz .gt. daysav) then
daysav=dayz
ilate=nchk
endif
iecat(nchk)=-iabs(iecat(nchk))
endif
endif
enddo
c Look in akavit for the storm. If it is there, extract
c latest pertinent information that will be transferred to the
c storm catalog
write(6,243) ilate,stmnmz,rsmcz,stmidz
243 format('...Look in akavit for appropriate information. Latest ',
1 'record has index=',i5,' storm name,rsmc,id=',3(a,1x))
nalsav=novrmx
call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmca,rsmcal,
1 stidal,ifnd)
if(ifnd .eq. 0) then
if(rsmcz(1:1) .eq. '!') then
write(6,271) stmnmz,stmidz,rsmcz
271 format('******Storm not found in akavit file. stmnmz,stmidz,',
1 'rsmcz=',3(1x,a),' abort')
call abort1(' RCNCIL',271)
else
write(6,273) ilate
273 format('...Storm is not multiply observed. We copy the latest ',
1 'record (#',i5,') to get the latest information.')
bufinx=tstrec(ilate)
nalca=1
rsmcca(1)=rsmcx
stidca(1)=stmidx
if(stmnmx .ne. 'NAMELESS') stnmca=stmnmx
endif
else
write(6,277)
277 format('...Storm is multiply observed. We copy the alias record ',
1 'to get the latest information.')
c Do not copy the storm id if there is already a catalog entry
nalca=nalsav
rsmcca(1)=rsmcal(1)
rsmcca(2:nalca)=rsmcal(2:nalca)
stidca(2:nalca)=stidal(2:nalca)
endif
iecat(nrec)=-iabs(iecat(nrec))
endif
endif
enddo
c write to the updated catalog
WRITE(IUNTCA,21) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
WRITE(6,293) NCAT,NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
293 format(/'...CATALOG RECORD ',I3,' WRITTEN. RECORD IS:',I1,1X,A9,
1 2(1X,I8,1X,I4.4),10(1X,A4,1X,A3))
go to 201
300 continue
c ****************************
c **** Code 1 or 2 errors ****
c ****************************
c Add new storms to the catalog or storms that have duplicate
c ids
nadcat=0
c** naladd=0
do nrec=1,ntest
if(nrec .le. nokay .or.
1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or.
2 iefail(numtst(nrec),4) .eq. 6 .or.
3 iefail(numtst(nrec),6) .eq. 22))) then
bufinz=tstrec(nrec)
ietyp=iecat(nrec)/ipack
if(ietyp .eq. 1 .or. ietyp .eq. 2) then
write(6,303) nrec,ietyp,bufinz
303 format(//'...Ready to add new storm to catalog. nrec,ietyp,',
1 'record are:',2i4/4x,a)
c Default entry for catalog is a copy of the candidate record or the
c entry from the alias (akavit) file. These entries may be
c updated by records with a later date, entries from the
c alias file, and the need to create a new, unique storm id.
if(rsmcz(1:1) .ne. '!') then
nalca=1
stnmca=stmnmz
rsmcca(1)=rsmcz
stidca(1)=stmidz
else
write(6,305) nrec,stmnmz,rsmcz,stmidz
305 format('...Calling akafnd for record',i4,' with storm name,',
1 'rsmc,id=',3(a,1x),' to produce default catalog entries.')
nalsav=novrmx
call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmca,rsmcca,
1 stidca,ifnd)
nalca=nalsav
if(ifnd .eq. 0) then
write(6,307) stmnmz,stmidz,rsmcz
307 format('******Storm not found in akavit file. stmnmz,stmidz,',
1 'rsmcz=',3(1x,a),' abort')
call abort1(' RCNCIL',307)
endif
endif
read(stmidz(1:2),23) idno
do nb=1,nbasin
if(stmidz(3:3) .eq. idbasn(nb)) then
nbasav=nb
go to 311
endif
enddo
311 continue
istidn=0
if(idno .le. maxno(nbasav)) then
istidn=1
write(6,313) idno,maxno(nbasav)
313 format('###Storm id number=',i3,' is not larger than catalog ',
1 'maximum. A new number and storm id must be created=',i4)
endif
do naddc=1,nadcat
if(stmidz .eq. stidad(naddc)) then
istidn=1
write(6,315) stmidz
315 format('...Current storm id has already been added to catalog. A',
1 ' unique one must be created.')
endif
enddo
c Create added storm id and rsmc in advance to guarantee uniqueness
c or transfer new storm id to the catalog record.
c istidn=0 : no uniqueness problem has been detected
c istidn=1 : uniqueness problem detected and new id will
c be created
c The new id will be transferred to all records. It must be a bang
c record with only one observing rsmc. It must also be entered int
c the alias file.
istidn=0 ! Qingfu added to skip the changes of storm ID number
if(istidn .eq. 1) then
if(rsmcz(1:1) .eq. '!') then
write(6,331) stmidz,rsmcz,bufinz
331 format('###Storm with id, rsmc=',2(a,1x),'is a duplicate to a ',
1 'catalog entry as well as being a bang storm. Record is:'/
2 4x,a)
write(6,333)
333 format('******This problem is not yet coded. Abort')
call abort1(' rcncil',333)
else
idnomx=-1
do naddc=1,nadcat
read(stidad(naddc)(1:2),23) idno
if(stidad(naddc)(3:3) .eq. idbasn(nbasav))
1 idnomx=max0(idnomx,idno)
enddo
stidad(nadcat+1)(3:3)=idbasn(nbasav)
if(idnomx .ge. 0) then
write(stidad(nadcat+1)(1:2),3401) idnomx+1
3401 format(i2.2)
write(6,341) idbasn(nbasav),stidad(nadcat+1)
341 format('...Previous storms have been added for basin ',a,' storm',
1 ' id set to one more than the maximum already added to ',
2 'the catalog=',a)
else
write(stidad(nadcat+1)(1:2),3401) maxno(nbasav)+1
write(6,343) idbasn(nbasav),stidad(nadcat+1)
343 format('...No previous storms added for basin ',a,'. Storm id ',
1 'set to one more than the maximum already in the catalog=',
2 a)
endif
c Create a bang record with one observing rsmc
c** naladd=naladd+1
do nrsz=1,nrsmcx
if(rsmcid(nrsz) .eq. rsmcz) then
nrsmc=nrsz
go to 351
endif
enddo
351 continue
nalca=2
rsmcad(nadcat+1)='!'//rsmcap(nrsmc)
stidca(1)=stidad(nadcat+1)
rsmcca(1)=rsmcad(nadcat+1)
stidca(2)=stmidz
rsmcca(2)=rsmcz
c** write(6,355) naladd,(stidca(nca),rsmcca(nca),nca=1,nalca)
write(6,355) nadcat+1,(stidca(nca),rsmcca(nca),nca=1,nalca)
355 format('...New bang storm (#',i2,') created with unique id. Id, ',
1 'rsmc are:'/(4x,2(a,3x)))
c** call akasav(naladd,nalca,dayz,stmnmz,rsmcca,stidca)
endif
endif
do iv=1,2
call decvar(istvar(iv),ienvar(iv),ivtvar(iv),ierdec,fmtvit(iv),
1 bufinz)
enddo
idatmn=idatez
iutcmn=iutcz
idatmx=idatez
iutcmx=iutcz
call ztime(idatez,iutcz,iyr,imo,ida,ihr,imin)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
call flday(jdy,ihr,imin,daysav)
ilate=nrec
C#######################################################################
c Do all records identified as the same storm
do nchk=nrec+1,ntest
C-----------------------------------------------------------------------
if(nchk .le. nokay .or.
1 (nchk .gt. nokay .and. (iefail(numtst(nchk),4) .eq. 5 .or.
2 iefail(numtst(nchk),4) .eq. 6 .or.
3 iefail(numtst(nchk),6) .eq. 22))) then
imatch=0
bufinx=tstrec(nchk)
ietypx=iecat(nchk)/ipack
C.......................................................................
if(ietypx .eq. 1 .or. ietypx .eq. 2) then
ifnd=0
c Storms are obviously the same
if(stmidz .eq. stmidx .and. rsmcz .eq. rsmcx) then
write(6,371) nchk,nrec,nrec,bufinz,nchk,bufinx
371 format('...Record',i5,' has the same storm id and rsmc as the ',
1 'candidate record (#',i5,'). Records are:'/4x,i4,1x,a/4x,
2 i4,1x,a)
ifnd=-1
c Last resort: look in akavit for the storm
else
write(6,373) nchk,stmnmx,rsmcx,stmidx
373 format('...calling akafnd for record',i4,' with storm name,rsmc,',
1 'id=',3(a,1x))
nalsav=novrmx
call akafnd(iuntal,stmnmx,rsmcx,stmidx,nalsav,stnmal,
1 rsmcal,stidal,ifnd)
if(ifnd .eq. 0) then
if(rsmcx(1:1) .eq. '!') then
write(6,381) stmnmx,stmidx,rsmcx
381 format('******Storm not found in akavit file. stmnmx,stmidx,',
1 'rsmcx=',3(1x,a),' abort')
call abort1(' RCNCIL',381)
else
c write(6,383)
c 383 format('...Storm does not have a bang rsmc. It is therefore not ',
c 1 'required to find a match.')
endif
else
write(6,405) ifnd
405 format('...Storm found in akavit file at record #',i3)
do nal=1,nalsav
if(rsmcz .eq. rsmcal(nal) .and.
1 stmidz .eq. stidal(nal)) then
imatch=1
go to 411
endif
enddo
411 continue
endif
endif
if(imatch .eq. 1 .or. ifnd .eq. -1) then
write(6,413) ifnd,imatch
413 format('...Storm matches exactly or by catalog association, ',
1 'ifnd,imatch=',2i3)
do iv=1,2
call decvar(istvar(iv),ienvar(iv),ivtvrx(iv),ierdec,
1 fmtvit(iv),bufinx)
enddo
c write(6,231) nchk,idatmn,iutcmn,idatex,iutcx,bufinx
call mnmxda(idatmn,iutcmn,idatex,iutcx,dayz,minday)
call mnmxda(idatmx,iutcmx,idatex,iutcx,dayz,maxday)
if(dayz .gt. daysav) then
daysav=dayz
ilate=nchk
endif
if(istidn .eq. 1) then
tstrec(nchk)=bufinx
nadd=nadd+1
badrec(nbad+nadd)=bufinx
numbad(nbad+nadd)=numtst(nchk)
iefail(numbad(nbad+nadd),5)=
1 -iabs(iefail(numtst(nchk),5))
stmidx=stidad(nadcat+1)
rsmcx =rsmcad(nadcat+1)
write(6,473) stmidx,bufinx,nadd,badrec(nbad+nadd)
473 format('...Record same as candidate record to be added to ',
1 'catalog. New storm id=',a,' is assigned. Modified ',
2 'record is:'/4x,a/4x,'Bad record #',i3,' added is:'/4x,a)
endif
iecat(nchk)=-iabs(iecat(nchk))
if(nchk .le. nokay) then
okarec(nchk)=bufinx
else
badrec(nchk-nokay)=bufinx
endif
endif
C.......................................................................
c Exact match: substitute storm name if it is not nameless
if(ifnd .eq. -1) then
if(stmnmx.ne.'NAMELESS' .and. stmnmz.eq.'NAMELESS') then
stnmca=stmnmx
write(6,475) stnmca
475 format('...NAMELESS candidate record is renamed to ',a,'from a ',
1 'matching record.')
endif
c Match through the alias file: copy alias information for the
c catalog entry
else if(imatch .eq. 1) then
if(stmnmz.eq.'NAMELESS' .and. stnmal.ne.'NAMELESS') then
stnmca=stnmal
write(6,477) stnmca
477 format('...NAMELESS candidate record is renamed to ',a,'from a ',
1 'matching alias record.')
endif
nalca=nalsav
rsmcca(1:nalca)=rsmcal(1:nalca)
stidca(1:nalca)=stidal(1:nalca)
else
write(6,491) ifnd,imatch
491 format('...Storm does not match exactly or by catalog ',
1 'association, ifnd,imatch=',2i3)
endif
endif
endif
C-----------------------------------------------------------------------
enddo
C#######################################################################
if(iecat(nrec) .gt. 0) then
nadcat=nadcat+1
if(nadcat .gt. naddmx) then
write(6,505) nadcat,naddmx
505 format('******Trying to add too many storms to the catalog,',
1 ' nadcat,naddmx=',2i3)
call abort1(' RCNCIL',505)
endif
if(istidn .eq. 1) then
nadd=nadd+1
badrec(nbad+nadd)=bufinz
numbad(nbad+nadd)=numtst(nrec)
iefail(numbad(nbad+nadd),5)=-iabs(iefail(numtst(nrec),5))
write(6,511) nadd,nrec,nbad+nadd,numtst(nrec)
511 format(/'...Adding a new bad record due to duplicate storm id, ',
1 'nadd,nrec,nbad+nadd,numtst=',4i4)
stmidz=stidad(nadcat)
rsmcz =rsmcad(nadcat)
write(6,513) stidca(1),nalca,bufinz
513 format('...Id for storm added to catalog =',a,' is new and ',
1 'unique. nalca=',i3,' Record is:'/4x,a)
else
stidad(nadcat)=stidca(1)
write(6,515) stidad(nadcat)
515 format('...Id for storm added to catalog =',a,' has been ',
1 'recorded to prevent duplication.')
endif
WRITE(IUNTCA,21) NALCA,STNMCA,IDATMN,IUTCMN,IDATMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
WRITE(6,293) NCAT+NADCAT,NALCA,STNMCA,IDATMN,IUTCMN,IDATMX,
1 IUTCMX,(RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
endif
if(nrec .le. nokay) then
okarec(nrec)=bufinz
else
badrec(nrec-nokay)=bufinz
endif
iecat(nrec)=-iabs(iecat(nrec))
endif
endif
enddo
c** write(6,601) nadcat,naladd
c 601 format('...',i3,' new storms added to catalog. ',i3,' bang ',
c 1 'storms added to temporary alias file.'/4x,'Dump alias '
c 2 'records to temporary alias file if necessary (naladd>0).'
write(6,601) nadcat
601 format('...',i3,' new storms added to catalog.')
c Finally, storm catalog and alias file (akavit) reconciliation.
c We force the alias file to be a direct subset of the storm
c catalog.
c write(6,703)
c 703 format(/'...Storm catalog and alias file reconciliation. '/4x,
c 1 'Copy temporary alias file records to the new alias file',
c 2 ' if necessary.')
iuntaw=iuntal
rewind iuntca
rewind iuntaw
720 read(iuntca,21,end=830) nalca,stmnmz,iymdmn,iutcmn,iymdca,iutcca,
1 (rsmcca(nca),stidca(nca),
2 nca=1,min(nalca,novrmx))
if(rsmcca(1)(1:1) .eq. '!') write(iuntaw,711) nalca,stmnmz,
1 (rsmcca(nca),stidca(nca),
2 nca=1,min(nalca,novrmx))
711 format(i1,1x,a9,10(1x,a4,1x,a3))
c** ifndca=0
c if(stmnmz .eq. stnmal .and.
c 1 stidca(1) .eq. stidal(1)) then
c ifndz=0
c write(6,801) stmnmz,stidca(1)
c 801 format('...Alias file and catalog have the same storm and basin ',
c 1 'id=',a,1x,a)
c do nc=1,nalca
c if(rsmcal(nc) .eq. rsmcca(nc) .and.
c 1 stidal(nc) .eq. stidca(nc)) then
c ifndz=ifndz+1
c endif
c enddo
c if(ifndz .eq. nalca) then
c ifndca=1
c go to 831
c endif
c** endif
go to 720
830 continue
cc831 continue
c** if(ifndca .eq. 0) then
c write(6,833) nalca,stmnmz,(rsmcca(nca),stidca(nca),
c 1 nca=1,min(nalca,novrmx))
c write(6,835) nalmx,stnmal,(rsmcal(nal),stidal(nal),
c 3 nal=1,min(nalmx,novrmx))
c 833 format('******Storm in alias file but different or not in ',
c 1 'catalog. Catalog entry is:'/4x,i1,1x,a9,10(1x,a4,1x,a3)
c 835 format('Alias entry is:'/4x,i1,1x,a9,10(1x,a4,1x,a3))
c call abort1(' RCNCIL',835)
c else
c write(6,841) nalmx,stnmal,(rsmcal(nal),stidal(nal),
c 1 nal=1,min(nalmx,novrmx))
c 841 format('...Alias file entry is identical to catalog. Entry is:'/
c 1 4x,i1,1x,a9,10(1x,a4,1x,a3))
c endif
c** go to 710
c Error summary
write(6,901) nokay,ntest,nadd,(ercrcn(ner),ner=1,nercrc)
901 format(//'...Results of the catalog reconciliation check are: ',
1 'nokay=',i4,', ntest=',i4,', nadd=',i3//4x,'Error codes ',
2 'are:'/(6x,a))
write(6,903)
903 format(/'...Okay records are:',100x,'erc'/)
do nok=1,nokay
write(6,909) nok,numoka(nok),okarec(nok),iefail(numoka(nok),5)
909 format(3x,i4,'...',i4,'...',a,'...',i3)
enddo
write(6,913)
913 format(/'...Updated overland or overlapped (bad) records are:',
1 68x,'erc')
do nba=1,nbad
if(iefail(numbad(nba),4) .eq. 5 .or.
1 iefail(numbad(nba),4) .eq. 6 .or.
2 iefail(numbad(nba),6) .eq. 22) then
write(6,919) nba,numbad(nba),badrec(nba),iefail(numbad(nba),5)
919 format(3x,i4,'...',i4,'...',a,'...',i3)
endif
enddo
write(6,923)
923 format(/'...Added records due to duplicate storm id are:',73x,
1 'erc'/)
do nad=1,nadd
write(6,929) nad,numbad(nbad+nad),badrec(nbad+nad),
1 iabs(iefail(numbad(nbad+nad),5))
929 format(3x,i4,'...',i4,'...',a,'...',i3)
enddo
nbad=nbad+nadd
return
end
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: MNMXDA SUBSTITUTES MIN OR MAX DATE
C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01
C
C ABSTRACT: SUBSTITUTES MIN OR MAX DATE
C
C PROGRAM HISTORY LOG:
C 1993-06-01 S. LORD
C
C USAGE: CALL MNMXDA(IYMDNX,IUTCNX,IYMDZ,IUTCZ,DAYZ,MINMAX)
C INPUT ARGUMENT LIST:
C IYMDNX - MINIMUM YEAR,MONTH,DAY.
C
C IUTCNX - MINIMUM HOUR (UTC).
C IYMDZ - INPUT YEAR,MONTH,DAY.
C
C IUTCZ - INPUT HOUR (UTC).
C
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
subroutine mnmxda(iymdnx,iutcnx,iymdz,iutcz,dayz,minmax)
DIMENSION RINC(5)
c in minmax<0, minimum is returned
c in minmax>0, minimum is returned
call ztime(iymdnx,iutcnx,iyr,imo,ida,ihr,imin)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
call flday(jdy,ihr,imin,daynx)
call ztime(iymdz,iutcz,iyr,imo,ida,ihr,imin)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
call flday(jdy,ihr,imin,dayz)
if(minmax .gt. 0) then
if(dayz .gt. daynx) then
write(6,11) iymdnx,iutcnx,iymdz,iutcz
11 format('...Substituting maximum date. iymdnx,iutcnx,iymdz,iutcz=',
1 2(i9,i6.4))
iymdnx=iymdz
iutcnx=iutcz
else
c write(6,13) iymdnx,iutcnx,iymdz,iutcz
c 13 format('...No substitution of maximum date. iymdnx,iutcnx,iymdz,',
c 1 'iutcz=',2(i9,i6.4))
endif
else if(minmax .lt. 0) then
if(dayz .lt. daynx) then
write(6,21) iymdnx,iutcnx,iymdz,iutcz
21 format('...Substituting minimum date. iymdnx,iutcnx,iymdz,iutcz=',
1 2(i9,i6.4))
iymdnx=iymdz
iutcnx=iutcz
else
c write(6,23) iymdnx,iutcnx,iymdz,iutcz
c 23 format('...No substitution of minimum date. iymdnx,iutcnx,iymdz,',
c 1 'iutcz=',2(i9,i6.4))
endif
else
write(6,31) minmax
31 format('******minmax value=',i5,' is improper. abort.')
CALL ABORT1(' MNMXDA',31)
endif
return
end
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: SCLIST LISTS STORM CATALOG
C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01
C
C ABSTRACT: LISTS STORM CATALOG
C
C PROGRAM HISTORY LOG:
C 1993-06-01 S. LORD
C
C USAGE: CALL SCLIST(IUNTCA)
C INPUT ARGUMENT LIST:
C IUNTCA - UNIT NUMBER FOR CATALOG.
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
subroutine sclist(iuntca)
parameter (novrmx=70)
character stnmca*9,stidca*3,rsmcca*4
dimension stidca(novrmx),rsmcca(novrmx)
rewind iuntca
nrec=0
write(6,1) iuntca
1 format(/'...Storm catalog list for unit ',i3)
10 continue
READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
nrec=nrec+1
21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3))
write(6,23) nrec,NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NAL),STIDCA(NAL),
2 NAL=1,MIN(NALCA,NOVRMX))
23 FORMAT(3x,i4,2x,I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3))
go to 10
90 continue
write(6,91)
91 format('...End of storm catalog list.'/)
rewind iuntca
return
end
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AKLIST LISTS ALIAS FILE
C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01
C
C ABSTRACT: LISTS ALIAS FILE
C
C PROGRAM HISTORY LOG:
C 1993-06-01 S. LORD
C
C USAGE: CALL AKLIST(IUNTAL)
C INPUT ARGUMENT LIST:
C IUNTAL - UNIT NUMBER FOR ALIAS FILE.
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
subroutine aklist(iuntal)
parameter (novrmx=70)
character stnmal*9,stidal*3,rsmcal*4
dimension stidal(novrmx),rsmcal(novrmx)
rewind iuntal
nrec=0
write(6,1) iuntal
1 format(/'...Storm alias list for unit ',i3)
10 continue
READ(IUNTAL,21,END=90) NALAL,STNMAL,(RSMCAL(NAL),STIDAL(NAL),
1 NAL=1,MIN(NALAL,NOVRMX))
nrec=nrec+1
21 FORMAT(I1,1X,A9,10(1X,A4,1X,A3))
write(6,23) nrec,NALAL,STNMAL,(RSMCAL(NAL),STIDAL(NAL),
1 NAL=1,MIN(NALAL,NOVRMX))
23 FORMAT(3x,i4,2x,I1,1X,A9,10(1X,A4,1X,A3))
go to 10
90 continue
write(6,91)
91 format('...End of storm alias list.'/)
rewind iuntal
return
end
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: STCATI GETS STORM ID FROM CATALOG
C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01
C
C ABSTRACT: LOOKS FOR GIVEN STORM ID AND RSMC IN CATALOG
C
C PROGRAM HISTORY LOG:
C 1993-06-01 S. LORD
C
C USAGE: CALL STCATI(IUNTCA,STMIDZ,RSMCZ,STMIDX,IFND)
C INPUT ARGUMENT LIST:
C IUNTCA - UNIT NUMBER FOR STORM CATALOG.
C
C STMIDZ - REQUESTED STORM ID.
C RSMCZ - REQUESTED RSMC.
C
C OUTPUT ARGUMENT LIST:
C STMIDX - CATALOGED STORM ID.
C IFND - 1 IF FOUND.
C - THE RSMC CHECK.
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
subroutine stcati(iuntca,stmidz,rsmcz,stmidx,ifnd)
parameter (novrmx=70)
dimension rsmcca(novrmx),stidca(novrmx)
character stmidz*(*),stmidx*(*),rsmcz*(*)
character stnmca*9,stidca*3,rsmcca*4
ifnd=0
rewind iuntca
write(6,1) stmidz,rsmcz
1 format('...Entering stcati looking for storm id,rsmc=',2(a,2x))
10 continue
READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX,
1 (RSMCCA(NCA),STIDCA(NCA),
2 NCA=1,MIN(NALCA,NOVRMX))
21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3))
do nca=1,min(nalca,novrmx)
if(stmidz .eq. stidca(nca) .and. rsmcz .eq. rsmcca(nca)) then
ifnd=1
stmidx=stidca(1)
rewind iuntca
return
endif
enddo
go to 10
90 continue
rewind iuntca
return
end
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: STCATN GETS STORM NAME AND LAST DATE FROM CATLG
C PRGMMR: S. LORD ORG: NP22 DATE: 1993-08-25
C
C ABSTRACT: LOOKS FOR GIVEN STORM ID AND RSMC IN CATALOG
C
C PROGRAM HISTORY LOG:
C 1993-08-25 S. LORD
C
C USAGE: CALL STCATN(IUNTCA,STMNMZ,IDATEZ,IUTCZ,IFND)
C INPUT ARGUMENT LIST:
C IUNTCA - UNIT NUMBER FOR STORM CATALOG.
C STMNMZ - REQUESTED STORM NAME.
C
C OUTPUT ARGUMENT LIST:
C IDATEZ - LATEST DATE FOUND FOR NAMED STORM.
C IUTCZ - LATEST HHMM FOUND FOR NAMED STORM.
C IFND - 1 IF FOUND.
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE STCATN(IUNTCA,STMNMZ,IDATEZ,IUTCZ,IFND)
character STMNMZ*(*)
character stnmca*9
ifnd=0
IDATEZ=-999999
IUTCZ=-999
rewind iuntca
write(6,1) STMNMZ
1 format('...Entering stcatn looking for storm name=',a)
10 continue
READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX
21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4))
if(STNMCA .eq. STMNMZ) then
ifnd=1
IDATEZ=IYMDMX
IUTCZ=IUTCMX
endif
go to 10
90 continue
rewind iuntca
return
end
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: ADFSTF ADDS FIRST OCCURRENCE FLAGS TO RECORDS
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-07
C
C ABSTRACT: ADDS FIRST OCCURRENCE FLAGS TO RECORDS AS APPROPRIATE,
C EVEN IF A FLAG HAS BEEN CLASSIFIED AS A BAD RECORD.
C
C PROGRAM HISTORY LOG:
C 1991-06-07 S. J. LORD
C 1991-06-07 S. J. LORD DISABLED FIRST FLAGS FOR RELOCATED STORMS
C
C USAGE: CALL ADFSTF(IUNTHA,NOKAY,NBAD,MAXREC,MAXCKS,IECOST,NUMBAD,
c IEFAIL,DUMREC,OKAREC,BADREC)
C INPUT ARGUMENT LIST:
C IUNTHA - UNIT NUMBER FOR THE ALIAS SHORT-TERM HISTORY FILE
C NOKAY - LENGTH OF ARRAY OKAREC
C NBAD - LENGTH OF ARRAY BADREC AND NUMBAD
C MAXREC - LENGTH OF FIRST DIMENSION OF ARRAY IEFAIL
C MAXCKS - LENGTH OF SECOND DIMENSION OF ARRAY IEFAIL
C IECOST - ERROR CODE FOR OVERLAND (COASTAL) TROPICAL CYCLONE
C - POSITIONS
C NUMBAD - ARRAY CONTAINING INDEX NUMBER OF EACH BAD RECORD
C IEFAIL - 2-D ARRAY OF ERROR CODES FOR ALL RECORDS
C DUMREC - DUMMY CHARACTER VARIABLE FOR READING SHORT-TERM
C - HISTORY RECORDS
C OKAREC - CHARACTER ARRAY OF OK RECORDS, RECORDS THAT HAVE
C - PASSES ALL Q/C CHECKS SO FAR
C BADREC - CHARACTER ARRAY OF BAD RECORDS, RECORDS THAT HAVE
C - FAILED AT LEAST ONE Q/C CHECK SO FAR
C
C OUTPUT ARGUMENT LIST:
C DUMREC - DESCRIPTION AS ABOVE
C OKAREC - SAME AS INPUT, EXCEPT FIRST OCCURENCE FLAG MAY HAVE
C - BEEN ADDED
C BADREC - SAME AS INPUT, EXCEPT FIRST OCCURENCE FLAG MAY HAVE
C - BEEN ADDED IN THE CASE OF OVER-LAND (COASTAL) STORMS
C
C INPUT FILES:
C UNIT "IUNTHA" - SHORT-TERM HISTORY FILE
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE ADFSTF(IUNTHA,NOKAY,NBAD,MAXREC,MAXCKS,IECOST,NUMBAD,
1 IEFAIL,DUMREC,OKAREC,BADREC)
SAVE
LOGICAL FOUNDO,FOUNDB
CHARACTER*(*) DUMREC,OKAREC(NOKAY),BADREC(NBAD)
CHARACTER*100 DUMY2K
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION BUFIN(MAXCHR),FMTVIT(MAXVIT)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMBAD(NBAD)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/,
4 IFSTFL/19/,ISTID/6/,IENID/8/
DATA NUM/1/
WRITE(6,1) NOKAY,NBAD,IECOST
1 FORMAT(/'...ENTERING ADFSTF WITH NOKAY,NBAD,IECOST=',3I4/4X,
1 'WARNING: FIRST OCCURRENCE FLAGS (FOF) MAY OR MAY NOT BE',
2 ' PRESENT IN THE ORIGINAL SHORT-TERM ALIAS FILE DUE TO ',
3 'THIS ROUTINE.'/4X,'RELIABLE FOFS ARE PRESENT ONLY IN ',
4 'THE ALIAS SHORT-TERM HISTORY FILE.')
C CHECK EACH ALIAS SHORT-TERM HISTORY RECORD FIRST VERSUS THE
C "OKAY" RECORDS AND SECOND VERSUS THE "BAD" RECORDS THAT
C HAVE ONLY AN OVER COAST ERROR
DO NOK=1,NOKAY
BUFINZ=OKAREC(NOK)
FOUNDO=.FALSE.
REWIND IUNTHA
NREC=0
10 CONTINUE
READ(IUNTHA,11,END=90) DUMREC
11 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',DUMREC(20:21),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-4: ',dumrec
PRINT *, ' '
DUMY2K(1:19) = DUMREC(1:19)
IF(DUMREC(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = DUMREC(20:100)
DUMREC = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ DUMREC(20:23),'" via windowing technique'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-4: ',dumrec
PRINT *, ' '
ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',DUMREC(20:23),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-4: ',dumrec
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 10
END IF
NREC=NREC+1
IF(STMIDZ .EQ. DUMREC(ISTID:IENID) .AND.
1 DUMREC(IFSTFL:IFSTFL) .NE. '*') THEN
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 DUMREC)
ENDDO
IDTDUM=IDATEZ
IUTDUM=IUTCZ
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 OKAREC(NOK))
ENDDO
C IF THERE ARE DUPLICATE DATES, THEN WE ASSUME THE OKAY RECORD
C IS AN UPDATED RECORD AND WE TRANSFER THE FIRST OCCURRENCE
C FLAG TO THE UPDATED RECORD. THIS CREATES A PARTIAL
C DUPLICATE RECORD THAT WILL BE DEALT WITH IN RITSTH.
IF(IDATEZ .EQ. IDTDUM .AND. IUTCZ .EQ. IUTDUM) THEN
OKAREC(NOK)(IFSTFL:IFSTFL)=DUMREC(IFSTFL:IFSTFL)
ELSE
FOUNDO=.TRUE.
ENDIF
ENDIF
C WRITE(6,87) NOK,FOUNDO,DUMREC,OKAREC(NOK)
C 87 FORMAT('...CHECKING FOR FIRST OCCURRENCE, NOK,FOUNDO,DUMREC,',
C 1 'OKAREC=',I3,1X,L1/4X,A/4X,A)
GO TO 10
90 CONTINUE
C IF THERE ARE NO MATCHING STORMS IN THE SHORT-TERM HISTORY FILE,
C FIND THE EARLIEST STORM IN THE OKAY RECORDS
IF(.NOT. FOUNDO) THEN
CALL FSTSTM(NOKAY,NOK,NFIRST,OKAREC)
OKAREC(NFIRST)(IFSTFL:IFSTFL)=':'
ENDIF
ENDDO
DO NBA=1,NBAD
IF(IEFAIL(NUMBAD(NBA),4) .EQ. IECOST) THEN
DO NCK=1,MAXCKS
IF(NCK .NE. 4 .AND. IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 200
ENDDO
BUFINZ=BADREC(NBA)
REWIND IUNTHA
FOUNDB=.FALSE.
NREC=0
160 CONTINUE
READ(IUNTHA,11,END=190) DUMREC
NREC=NREC+1
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',DUMREC(20:21),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-5: ',dumrec
PRINT *, ' '
DUMY2K(1:19) = DUMREC(1:19)
IF(DUMREC(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = DUMREC(20:100)
DUMREC = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ DUMREC(20:23),'" via windowing technique'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-5: ',dumrec
PRINT *, ' '
ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',DUMREC(20:23),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-5: ',dumrec
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 160
END IF
IF(STMIDZ .EQ. DUMREC(ISTID:IENID) .AND.
1 DUMREC(IFSTFL:IFSTFL) .NE. '*') THEN
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 DUMREC)
ENDDO
IDTDUM=IDATEZ
IUTDUM=IUTCZ
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BADREC(NBA))
ENDDO
C IF THERE ARE DUPLICATE DATES, THEN WE ASSUME THE BAD RECORD
C IS AN UPDATED RECORD AND WE TRANSFER THE FIRST OCCURRENCE
C FLAG TO THE UPDATED RECORD. THIS CREATES A PARTIAL
C DUPLICATE RECORD THAT WILL BE DEALT WITH IN RITSTH.
IF(IDATEZ .EQ. IDTDUM .AND. IUTCZ .EQ. IUTDUM) THEN
BADREC(NBA)(IFSTFL:IFSTFL)=DUMREC(IFSTFL:IFSTFL)
ELSE
FOUNDB=.TRUE.
ENDIF
ENDIF
C WRITE(6,187) NBA,DUMREC,BADREC(NBA)
C 187 FORMAT('...CHECKING FOR FIRST OCCURRENCE, NBA,DUMREC,BADREC=',I3/
C 1 4X,A/4X,A)
GO TO 160
190 CONTINUE
C IF THERE ARE NO MATCHING STORMS IN THE SHORT-TERM HISTORY FILE,
C FIND THE EARLIEST STORM IN THE BAD RECORDS
IF(.NOT. FOUNDB) THEN
CALL FSTSTM(NBAD,NBA,NFIRST,BADREC)
BADREC(NFIRST)(IFSTFL:IFSTFL)='*'
ENDIF
ENDIF
200 CONTINUE
ENDDO
C IF THERE ARE NO RECORDS IN THE SHORT-TERM HISTORY FILE,
C WE MUST ASSIGN A FIRST OCCURRENCE FLAG TO EACH STORM
IF(NREC .EQ. 0) THEN
DO NOK=1,NOKAY
CALL FSTSTM(NOKAY,NOK,NFIRST,OKAREC)
OKAREC(NFIRST)(IFSTFL:IFSTFL)=':'
ENDDO
ENDIF
C ADD FIRST OCCURRENCE FLAGS FOR RELOCATED STORMS
C DISABLED 4-9-93
C DO NOK=1,NOKAY
C BUFINZ=OKAREC(NOK)
C IF(RELOCZ .EQ. 'R') OKAREC(NOK)(IFSTFL:IFSTFL)=':'
C ENDDO
C VERY SPECIAL CASE: NO RECORDS IN THE SHORT-TERM HISTORY FILE
C AND A RECORD HAS AN OVER LAND ERROR
IF(NREC .EQ. 0) THEN
DO NBA=1,NBAD
IF(IEFAIL(NUMBAD(NBA),4) .EQ. IECOST) THEN
DO NCK=1,MAXCKS
IF(NCK .NE. 4 .AND. IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 400
ENDDO
BADREC(NBA)(IFSTFL:IFSTFL)='*'
ENDIF
400 CONTINUE
ENDDO
ENDIF
WRITE(6,401) NOKAY,NBAD,NREC
401 FORMAT(/'...LEAVING ADFSTF, NOKAY, NBAD=',2I4/4X,I3,' RECORDS ',
1 'READ FROM ALIAS SHORT-TERM HISTORY FILE.')
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FSTSTM FINDS FIRST OCCURRENCE FOR A STORM
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-07-18
C
C ABSTRACT: FINDS FIRST OCCURRENCE OF A PARTICULAR STORM BY PICKING
C OUT THE MINIMUM TIME.
C
C PROGRAM HISTORY LOG:
C 1991-07-18 S. J. LORD
C
C USAGE: CALL FSTSTM(NRCMX,NRCSTM,NFIRST,DUMREC)
C INPUT ARGUMENT LIST:
C NRCMX - LENGTH OF ARRAY DUMREC
C NRCSTM - INDEX OF THE RECORD CONTAINING THE DESIRED STORM
C DUMREC - ARRAY OF INPUT RECORDS
C
C OUTPUT ARGUMENT LIST:
C NFIRST - INDEX OF THE FIRST RECORD FOR THE DESIRED STORM
C DUMREC - DESCRIPTION AS ABOVE
C
C REMARKS: NONE
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE FSTSTM(NRCMX,NRCSTM,NFIRST,DUMREC)
CHARACTER*(*) DUMREC(NRCMX)
DIMENSION RINC(5)
SAVE
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION BUFIN(MAXCHR),FMTVIT(MAXVIT)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/,
4 ISTID/6/,IENID/8/
DATA NUM/1/
C WRITE(6,1) NRCMX,NRCSTM
C 1 FORMAT(/'...ENTERING FSTSTM WITH NRCMX,NRCSTM=',2I4)
DAYFST=1.0E10
C PICK OUT THE RECORD WITH THE MINIMUM DATE FOR THE CHOSEN STORM
DO NCOM=1,NRCMX
BUFINZ=DUMREC(NCOM)
IF(STMIDZ .EQ. DUMREC(NRCSTM)(ISTID:IENID)) THEN
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
ENDDO
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
IF(DAYZ .LE. DAYFST) THEN
NFIRST=NCOM
DAYFST=DAYZ
ENDIF
ENDIF
ENDDO
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: RITCUR WRITES Q/C RECORDS TO CURRENT DATA FILE
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: WRITES CURRENT QUALITY CONTROLLED RECORDS TO THE CURRENT
C FILE (UNIT 60).
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1991-07-22 S. LORD ADDED IDATEZ,IUTCZ TO ARGUMENT LIST
C 1992-07-01 S. LORD REVISION FOR TIME WINDOW
C
C USAGE: CALL RITCUR(IUNTRD,IUNTCU,NTEST,NOKAY,NBAD,IDATCU,JUTCCU,DAY0,
C MAXREC,IFLLCK,NUMTST,NUMOKA,NUMBAD,FILES,LNDFIL,
C ZZZREC,NNNREC,DUMREC,SCRREC,TSTREC,OKAREC,BADREC)
C INPUT ARGUMENT LIST:
C IUNTRD - UNIT NUMBER FOR READING RECORDS
C IUNTCU - UNIT NUMBER FOR CURRENT DATA FILE
C NTEST - NUMBER OF INPUT RECORDS (>0 FOR FILES=FALSE OPTION,
C - =0 FOR FILES=TRUE OPTION)
C IDATCU - DATE (YYYYMMDD) FOR ACCEPTANCE WINDOW
C JUTCCU - UTC (HHMMSS) FOR ACCEPTANCE WINDOW
C DAY0 - DATE OF ACCEPTANCE WINDOW
C MAXREC - DIMENSION OF INPUT ARRAYS
C FILES - LOGICAL VARIABLE, TRUE IF UPDATED SHORT-TERM HISTORY
C FILE HAS BEEN CREATED
C LNDFIL - LOGICAL VARIABLE, TRUE IF OVER-LAND FILTER SHOULD BE
C APPLIED TO CURRENT RECORDS.
C RECORDS TO THE CURRENT FILE
C DUMREC - CHARACTER VARIABLE
C TSTREC - CHARACTER ARRAY (LENGTH MAXREC) OF INPUT RECORDS. ONLY
C - THE FIRST NTEST ARE VALID IN THE CASE OF FILES=.FALSE.
C NUMTST - INDEX FOR ARRAY TSTREC
C ZZZREC - CHARACTER VARIABLE CONTAINING HEADER INFO
C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN INFO
C
C OUTPUT ARGUMENT LIST:
C OKAREC - CONTAINS CANDIDATE QUALITY CONTROLLED RECORDS COPIED
C - TO THE CURRENT FILE
C NOKAY - NUMBER OF OKAY RECORDS
C NBAD - NUMBER OF RECORDS THAT FAILED THE OVERLAND CHECK
C IFLLCK - CONTAINS FAILURE CODE OF BAD RECORDS
C BADREC - ARRAY CONTAINING BAD RECORDS
C SCRREC - SCRATCH ARRAY CONTAINING STORM IDS AND NAMES
C NUMOKA - ARRAY CONTAINING INDICES OF OKAY RECORDS
C NUMBAD - ARRAY CONTAINING INDICES OF BAD RECORDS
C
C INPUT FILES:
C UNIT 20 - SCRATCH FILE CONTAINING QUALITY CONTROLLED RECORDS
C - IUNTRD POINTS TO THIS FILE WHEN FILES=.TRUE.
C UNIT 22 - ALIAS SHORT-TERM HISTORY FILE CONTAINING RECORDS
C - PROCESSED BY THIS PROGRAM FOR THE LAST SEVERAL DAYS.
C - IUNTRD POINTS TO THIS FILE WHEN FILES=.FALSE.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 60 - QUALITY CONTROLLED RECORDS (IUNTCU)
C
C REMARKS: IF LENGTH OF OUTPUT RECORDS (MAXCHR) EXCEEDS THE DESIGNATED
C RECORD LENGTH FOR THE FILE (MAXSPC), THIS SUBROUTINE WILL
C PRINT A NASTY MESSAGE AND CALL AN ABORT1 PROGRAM THAT GIVES
C A RETURN CODE OF 20 FOR THIS PROGRAM EXECUTION. UNDER
C THE FILES=TRUE OPTION, RECORDS ARE READ FROM THE SCRATCH
C FILE, DATE CHECKED, CHECKED FOR OVERLAND POSITIONS IF NEED
C BE, AND THEN WRITTEN TO THE CURRENT FILE. UNDER THE FILES=
C FALSE OPTION, ALL RECORDS PROCESSED BY THE PRESENT RUN OF
C THIS PROGRAM MAY BE WRITTEN IN ADDITION TO SOME RECORDS FROM
C THE ALIAS SHORT-TERM HISTORY FILE. IN BOTH OPTIONS, ONLY THE
C LATEST STORM RECORD IS WRITTEN. ALL RECORDS LIE IN A TIME
C WINDOW GIVEN BY DAY0.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE RITCUR(IUNTRD,IUNTCU,NTEST,NOKAY,NBAD,IDATCU,JUTCCU,
1 DAY0,MAXREC,IFLLCK,NUMTST,NUMOKA,NUMBAD,FILES,
2 LNDFIL,ZZZREC,NNNREC,DUMREC,SCRREC,TSTREC,
3 OKAREC,BADREC)
PARAMETER (MAXSPC=100)
SAVE
LOGICAL FIRST,FILES,LNDFIL,FOUND
CHARACTER*(*) TSTREC(0:MAXREC),OKAREC(MAXREC),BADREC(MAXREC),
1 ZZZREC,NNNREC,DUMREC,SCRREC(0:MAXREC)
CHARACTER*100 DUMY2K
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
CHARACTER FMTVIT*6
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION FMTVIT(MAXVIT)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
DIMENSION IFLLCK(MAXREC),NUMTST(MAXREC),NUMOKA(MAXREC),
1 NUMBAD(MAXREC)
DIMENSION RINC(5)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/,
5 ISTID/6/,IENID/8/
DATA FIRST/.TRUE./,NUM/1/,FIVMIN/3.4722E-3/
WRITE(6,1) IUNTRD,IUNTCU,FILES,LNDFIL,IDATCU,JUTCCU,DAY0
1 FORMAT(/'...ENTERING RITCUR WITH IUNTRD,IUNTCU,FILES,LNDFIL,',
1 'IDATCU,JUTCCU,DAY0',2I3,2L2,I9,I7,F10.3)
IF(FIRST) THEN
FIRST=.FALSE.
IF(MAXCHR .GT. MAXSPC) THEN
WRITE(6,5) MAXCHR,MAXSPC
5 FORMAT(/'******INSUFFICIENT SPACE ALLOCATED FOR CURRENT HISTORY ',
1 'FILE.'/7X,'MAXCHR, AVAILABLE SPACE ARE:',2I4)
CALL ABORT1(' RITCUR',1)
ENDIF
ENDIF
C RITCUR USES EITHER OF TWO POSSIBLE SOURCES FOR CURRENT RECORDS:
C 1) IF FILES=.TRUE., THE SCRATCH FILE (IUNTOK) CONTAINS
C ALL THE CURRENT RECORDS, INCLUDING THOSE PROCESSED BY A
C PREVIOUS RUN OF THIS PROGRAM. HOWEVER, A POSSIBILITY
C EXISTS THAT A CURRENT COASTAL RECORD MAY BE IN THE
C SCRATCH FILE. THEREFORE, THERE IS AN OPTIONAL FILTER
C (LNDFIL) BY USING A CALL TO SELACK TO WEED OUT THESE
C RECORDS.
C 2) IF FILES=.FALSE., THE CURRENT RECORDS ARE THOSE
C PROCESSED BY THE PRESENT RUN OF THIS PROGRAM (OKAREC)
C AND CANDIDATES FROM THE ALIAS SHORT-TERM HISTORY FILE.
C IN EITHER CASE, ONLY THE LATEST RECORD FOR EACH STORM IS
C WRITTEN.
REWIND IUNTCU
REWIND IUNTRD
NUNIQ=0
SCRREC(NUNIQ)='ZZZ'
print *, ' '
print *, ' '
10 CONTINUE
READ(IUNTRD,11,END=100) DUMREC
11 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',DUMREC(20:21),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-6: ',dumrec
PRINT *, ' '
DUMY2K(1:19) = DUMREC(1:19)
IF(DUMREC(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = DUMREC(20:100)
DUMREC = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ DUMREC(20:23),'" via windowing technique'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-6: ',dumrec
PRINT *, ' '
ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',DUMREC(20:23),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-6: ',dumrec
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 10
END IF
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 DUMREC)
ENDDO
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
IF(DAYZ .GE. DAY0-FIVMIN) THEN
NTEST=NTEST+1
TSTREC(NTEST)=DUMREC
NUMTST(NTEST)=NTEST
C WRITE(6,33) NTEST,DUMREC
C 33 FORMAT('...READING FROM SCRATCH FILE'/4X,I4,'...',A,'...')
ENDIF
GO TO 10
100 CONTINUE
IF(NTEST .GT. 0) THEN
IF(LNDFIL .AND. FILES) THEN
WRITE(6,103) NTEST,NOKAY,NBAD
103 FORMAT(/'...IN RITCUR, CALLING SELACK IN RITCUR TO CHECK FOR ',
1 'OVERLAND POSITIONS.'/4X,'NTEST,NOKAY,NBAD=',3I4)
CALL SELACK(NTEST,NOKAY,NBAD,IECOST,IFLLCK,NUMTST,NUMOKA,NUMBAD,
1 LNDFIL,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
ELSE
DO NOK=1,NTEST
OKAREC(NOK)=TSTREC(NOK)
NUMOKA(NOK)=NOK
ENDDO
NOKAY=NTEST
ENDIF
C PICK OUT THE UNIQUE STORMS
DO NOK=1,NOKAY
FOUND=.FALSE.
DO NUNI=1,NUNIQ
IF(OKAREC(NOK)(ISTID:IENID) .EQ. SCRREC(NUNI)(1:IENID-ISTID+1))
1 FOUND=.TRUE.
ENDDO
IF(.NOT. FOUND) THEN
NUNIQ=NUNIQ+1
SCRREC(NUNIQ)(1:IENID-ISTID+1)=OKAREC(NOK)(ISTID:IENID)
ENDIF
ENDDO
WRITE(6,151) NUNIQ
151 FORMAT(/'...THE NUMBER OF UNIQUE STORMS IS',I4)
C SCAN THROUGH RECORDS AND PICK OUT THE LATEST STORM RECORD FOR
C EACH UNIQUE STORM.
WRITE(6,157)
157 FORMAT(/'...THE FOLLOWING LATEST RECORDS FOR EACH STORM ARE ',
1 'BEING WRITTEN TO THE CURRENT FILE:')
DO NUNI=1,NUNIQ
DAYCHK=-1.E10
INDXZ=-99
DO NOK=1,NOKAY
IF(OKAREC(NOK)(ISTID:IENID) .EQ. SCRREC(NUNI)(1:IENID-ISTID+1))
1 THEN
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 OKAREC(NOK))
ENDDO
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
IF(DAYZ .GT. DAYCHK) THEN
INDXZ=NOK
DAYCHK=DAYZ
ENDIF
ENDIF
ENDDO
IF(INDXZ .GT. 0) THEN
WRITE(6,173) INDXZ,OKAREC(INDXZ)(1:MAXCHR)
WRITE(IUNTCU,177) OKAREC(INDXZ)(1:MAXCHR)
173 FORMAT('...',I3,'...',A,'...')
177 FORMAT(A)
ELSE
WRITE(6,181) SCRREC(NUNI)(1:IENID-ISTID+1)
181 FORMAT(/'###STORM ID=',A,' CANNOT BE FOUND. ABORT1')
CALL ABORT1(' RITCUR',181)
ENDIF
ENDDO
WRITE(6,221) NUNIQ,IUNTCU
221 FORMAT(/'...',I4,' RECORDS HAVE BEEN COPIED TO THE CURRENT FILE ',
1 '(UNIT',I3,').')
ELSE
WRITE(6,231)
231 FORMAT(/'...NO CURRENT RECORDS WILL BE WRITTEN.')
END FILE IUNTCU
ENDIF
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: RITSTH WRITES SHORT-TERM HISTORY FILE
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: WRITES ALL INPUT RECORDS AND QUALITY CONTROL MARKS
C ASSIGNED BY THIS PROGRAM TO A SCRATCH FILE THAT
C CONTAINS ALL RECENT HISTORICAL RECORDS FOR EACH STORM.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C
C USAGE: CALL RITSTH(IUNTHA,IUNTHO,IUNTOK,NOKAY,NBAD,DAYMIN,IECOST,
C MAXCKS,MAXREC,NUMBAD,IEFAIL,DUMREC,OKAREC,BADREC)
C INPUT ARGUMENT LIST:
C IUNTHA - UNIT NUMBER FOR THE ALIAS SHORT-TERM HISTORY FILE.
C IUNTHO - UNIT NUMBER FOR THE ORIGINAL SHORT-TERM HISTORY FILE.
C IUNTOK - UNIT NUMBER FOR THE SCRATCH FILE CONTAINING RECORDS
C - WRITTEN TO THE SHORT-TERM HISTORY FILE.
C NOKAY - NUMBER OF RECORDS THAT PASSED ALL Q/C CHECKS.
C NBAD - NUMBER OF RECORDS THAT HAVE AT LEAST ONE ERROR.
C DAYMIN - EARLIEST (MINIMUM) DATE FOR RECORDS THAT WILL BE
C - COPIED TO THE SHORT-TERM HISTORICAL FILE.
C - UNITS ARE DDD.FFF, WHERE DDD=JULIAN DAY, FFF=FRAC-
C - TIONAL DAY (E.G. .5=1200 UTC).
C IECOST - ERROR CODE FOR AN OVERLAND (COASTAL) RECORD.
C MAXCKS - NUMBER OF QUALITY CONTROL CHECKS. SECOND DIMENSION OF
C - ARRAY IEFAIL IS (0:MAXCKS).
C MAXREC - FIRST DIMENSION OF ARRAY IEFAIL.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C IEFAIL - INTEGER ARRAY CONTAINING QUALITY MARKS. INDEXING
C - IS ACCORDING TO ARRAY NUMBAD.
C DUMREC - CHARACTER VARIABLE LONG ENOUGH TO HOLD VITAL
C - STATISTICS RECORD.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT HAVE
C - PASSED ALL Q/C CHECKS
C BADREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT HAVE
C - FAILED AT LEAST ONE Q/C CHECK
C
C INPUT FILES:
C UNIT 22 - ALIAS SHORT=TERM HISTORY FILE
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 20 - SCRATCH FILE
C UNIT 21 - ORIGINAL SHORT-TERM HISTORY FILE
C
C REMARKS: RECORDS ARE COPIED FROM THE CURRENT ALIAS SHORT-TERM HISTORY
C FILE TO THE SCRATCH FILE IUNTOK. THE CONTENTS OF IUNTOK
C WILL BE FINALLY BE COPIED TO THE SHORT-TERM HISTORY FILE
C BY ROUTINE FNLCPY. ORIGINAL RECORDS THAT CONTRIBUTED TO
C MAKING ALIAS RECORDS ARE COPIED TO THE ORIGINAL SHORT-TERM
C SHORT-TERM HISTORY FILE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE RITSTH(IUNTHA,IUNTHO,IUNTOK,NOKAY,NBAD,DAYMIN,IECOST,
1 MAXCKS,MAXREC,NUMBAD,IEFAIL,DUMREC,OKAREC,BADREC)
SAVE
CHARACTER*(*) DUMREC,OKAREC(NOKAY),BADREC(NBAD)
DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMBAD(NBAD)
ICALL=2
REWIND IUNTOK
C COPY ALL RECORDS FROM THE CURRENT ORIGINAL SHORT-TERM HISTORY
C FILE TO A SCRATCH FILE (IUNTOK) FOR TEMPORARY STORAGE.
WRITE(6,1) DAYMIN,ICALL
1 FORMAT(/'...THE FOLLOWING RECORDS, HAVING DATES GREATER THAN OR ',
1 'EQUAL TO DAY',F10.3,', WILL BE CHECKED FOR EXACT AND ',
2 'PARTIAL DUPLICATES '/4X,'(ICALL=',I2,') AND WILL BE ',
3 'COPIED FROM THE ORIGINAL SHORT-TERM HISTORICAL FILE TO ',
4 'THE PRELIMINARY QUALITY CONTROLLED FILE'/4X,'(SCRATCH ',
5 'FILE) FOR TEMPORARY STORAGE:')
CALL CPYREC(ICALL,IUNTHO,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC)
C NOW ADD THE CURRENT RECORDS.
WRITE(6,21)
21 FORMAT(//'...THE FOLLOWING ACCEPTABLE ORIGINAL RECORDS WILL BE ',
1 'ADDED TO THE NEW ORIGINAL SHORT-TERM HISTORY FILE:'/)
DO NOK=1,NOKAY
IF(OKAREC(NOK)(1:1) .NE. '!') THEN
WRITE(6,23) NOK,OKAREC(NOK)
23 FORMAT('...',I4,'...',A)
WRITE(IUNTOK,27) OKAREC(NOK)
27 FORMAT(A)
ENDIF
ENDDO
C NOW WE APPEND THE SCRATCH FILE WITH RECORDS THAT CONTRIBUTED
C TO ALIAS RECORDS.
WRITE(6,101)
101 FORMAT(/'...THE FOLLOWING (BAD) RECORDS WITH RSMCCK OR RCNCIL ',
1 'ERRORS WILL BE ADDED TO THE SHORT-TERM ORIGINAL'/4X,
2 'HISTORY FILE:'/)
DO NBA=1,NBAD
IF(IEFAIL(NUMBAD(NBA),6) .EQ. 10 .OR.
1 IEFAIL(NUMBAD(NBA),6) .GE. 21 .OR.
1 IABS(IEFAIL(NUMBAD(NBA),5)) .EQ. 20) THEN
DO NCK=1,MAXCKS
IF(NCK .NE. 6 .AND. NCK .NE. 5 .AND.
1 IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 150
ENDDO
WRITE(6,131) NBA,BADREC(NBA)
131 FORMAT('...',I4,'...',A)
WRITE(IUNTOK,133) BADREC(NBA)
133 FORMAT(A)
ENDIF
150 CONTINUE
ENDDO
C COPY RECORDS THAT ARE MORE RECENT THAN DAYMIN FROM THE
C SCRATCH FILE (IUNTOK) TO THE ORIGINAL SHORT-TERM
C HISTORY FILE
ICALL=1
REWIND IUNTOK
REWIND IUNTHO
WRITE(6,151)
151 FORMAT(/'...THE FOLLOWING RECORDS WILL BE COPIED FROM THE ',
1 'SCRATCH FILE TO THE NEW ORIGINAL SHORT-TERM HISTORICAL ',
2 'FILE:')
CALL CPYREC(ICALL,IUNTOK,IUNTHO,NOKAY,DAYMIN,DUMREC,OKAREC)
ICALL=3
REWIND IUNTOK
C COPY RECORDS THAT ARE MORE RECENT THAN DAYMIN FROM THE
C CURRENT ALIAS SHORT-TERM HISTORY FILE TO A SCRATCH FILE
C (IUNTOK). THEN ADD THE CURRENT RECORDS.
CALL CPYREC(ICALL,IUNTHA,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC)
WRITE(6,211)
211 FORMAT(//'...THE FOLLOWING ACCEPTABLE RECORDS WILL BE ADDED TO ',
1 'THE NEW ALIAS SHORT-TERM HISTORY FILE:'/)
DO NOK=1,NOKAY
WRITE(6,213) NOK,OKAREC(NOK)
213 FORMAT('...',I4,'...',A)
WRITE(IUNTOK,217) OKAREC(NOK)
217 FORMAT(A)
ENDDO
C ADD RECORDS THAT HAVE OVERLAND POSITIONS TO THE SHORT-TERM
C HISTORY FILE, PROVIDED THEY HAVE NO OTHER ERRORS
WRITE(6,41)
41 FORMAT(/'...THE FOLLOWING (BAD) RECORDS WITH COASTAL OVERLAND ',
1 'POSITIONS WILL BE ADDED TO THE NEW ALIAS SHORT-TERM '/4X,
2 'HISTORY FILE FOR FUTURE TRACK CHECKS:'/)
DO NBA=1,NBAD
IF(IEFAIL(NUMBAD(NBA),4) .EQ. IECOST) THEN
DO NCK=1,MAXCKS
IF(NCK .NE. 4 .AND. IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 300
ENDDO
WRITE(6,261) NBA,BADREC(NBA)
261 FORMAT('...',I4,'...',A)
WRITE(IUNTOK,263) BADREC(NBA)
263 FORMAT(A)
ENDIF
300 CONTINUE
ENDDO
C THE SCRATCH FILE (IUNTOK) NOW CONTAINS ALL RECORDS THAT WILL
C BE IN THE NEW ALIAS SHORT-TERM HISTORY FILE. SUBROUTINE FNLCPY
C WILL COPY THIS SCRATCH FILE TO THE NEW ALIAS SHORT-TERM HISTORY
C FILE.
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: RITHIS WRITES RECORDS AND Q/C MARKS TO FILE
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: WRITES ALL INPUT RECORDS AND QUALITY CONTROL MARKS
C ASSIGNED BY THIS PROGRAM TO A LONG-TERM HISTORY FILE.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C
C USAGE: CALL RITHIS(IUNTHI,IEFAIL,NRTOT,IDATE,IUTC,NUMREC,NREC,
C MAXREC,MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES,
C RECORD,ZZZREC,XXXREC)
C INPUT ARGUMENT LIST:
C IUNTHI - UNIT NUMBER FOR THE OUTPUT FILE. NOTE: SIGN OF THE
C - QUALITY MARKS IS ATTACHED TO THIS NUMBER!
C IEFAIL - INTEGER ARRAY CONTAINING QUALITY MARKS. INDEXING
C - IS ACCORDING TO ARRAY NUMREC. SIGN OF THIS NUMBER IS
C - ATTACHED TO IUNTHI!
C NRTOT - TOTAL NUMBER OF RECORDS WRITTEN INTO THE FILE. NREC
C - IS THE NUMBER WRITTEN FOR EACH CALL OF THE ROUTINE.
C IDATE - YYYYMMDD FOR WHICH THE PROGRAM IS BEING RUN.
C IUTC - HHMM FOR WHICH THE PROGRAM IS BEING RUN.
C NUMREC - ARRAY OF RECORD NUMBERS CORRESPONDING TO THE QUALITY
C - MARKS STORED IN ARRAY IEFAIL.
C NREC - NUMBER OF RECORDS TO BE WRITTEN TO THE OUTPUT FILE.
C MAXREC - FIRST DIMENSION OF ARRAY IEFAIL.
C MAXCKS - NUMBER OF QUALITY CONTROL CHECKS. SECOND DIMENSION OF
C - ARRAY IEFAIL IS (0:MAXCKS).
C HROFF - OFFSET (FRACTIONAL HOURS) BETWEEN TIME PROGRAM IS
C - RUN AND THE VALID CYCLE TIME
C WINCUR - TIME WINDOW FOR ADDING RECORDS TO CURRENT FILE
C RUNID - CHARACTER VARIABLE IDENTIFYING RUN
C LNDFIL - LOGICAL VARIABLE, TRUE IF OVER LAND POSITIONS ARE
C - NOT WRITTEN TO CURRENT FILE
C FILES - LOGICAL VARIABLE: TRUE IF SHORT-TERM HISTORY FILES ARE
C - UPDATED.
C RECORD - CHARACTER ARRAY CONTAINING OUTPUT RECORDS.
C ZZZREC - COLUMN HEADER RECORD.
C XXXREC - COLUMN HEADER RECORD.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 61 - CONTAINS HISTORY OF ALL RECORDS THAT ARE OPERATED ON
C - BY THIS PROGRAM
C
C REMARKS: THE HEADER RECORD IS WRITTEN ON THE FIRST CALL OF THIS
C ROUTINE. IT CONSISTS OF IDATE,IUTC,NRTOT,NREC,ZZZREC
C AND XXXREC. FOR THE FIRST CALL, NREC CORRESPONDS TO THE
C NUMBER OF RECORDS THAT PASSED THE Q/C CHECKS.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE RITHIS(IUNTHI,IEFAIL,NRTOT,IDATE,IUTC,NUMREC,NREC,
1 MAXREC,MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES,
2 RECORD,ZZZREC,XXXREC)
PARAMETER (MAXSPH=131)
SAVE
LOGICAL FIRST,LNDFIL,FILES
CHARACTER*(*) RUNID,RECORD(NREC),ZZZREC,XXXREC
PARAMETER (MAXCHR=95)
DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMREC(NREC)
DATA FIRST/.TRUE./
IF(FIRST) THEN
FIRST=.FALSE.
IF(MAXCHR+1+3*(MAXCKS+1) .GT. MAXSPH) THEN
WRITE(6,1) MAXCHR,MAXCKS,MAXCHR+1+3*(MAXCKS+1),MAXSPH
1 FORMAT(/'******INSUFFICIENT SPACE ALLOCATED FOR LONG-TERM ',
1 'HISTORY FILE.'/7X,'MAXCHR,MAXCK,(REQUIRED,AVAILABLE) ',
2 ' SPACE ARE:',4I4)
CALL ABORT1(' RITHIS',1)
ENDIF
NROKAY=NREC
WRITE(IABS(IUNTHI),3) IDATE,IUTC,NRTOT,NROKAY,HROFF,RUNID,LNDFIL,
1 FILES,WINCUR,ZZZREC(1:MAXCHR),XXXREC
3 FORMAT('IDATE=',I8,' IUTC=',I4,' NRTOT=',I4,' NROKAY=',I4,
1 ' HROFF=',F6.2,' RUNID=',A12,' LNDFIL=',L1,' FILES=',L1,
2 ' WINCUR=',F6.3/A,1X,A)
ENDIF
C OUTPUT UNIT NUMBER IS NEGATIVE FOR OKAY RECORDS (ERROR CODES ARE
C ALWAYS NEGATIVE). OUTPUT UNIT NUMBER IS POSITIVE FOR BAD
C RECORDS, WHICH MAY HAVE A MIXTURE OF POSITIVE AND NEGATIVE
C ERROR CODES.
IF(IUNTHI .LT. 0) THEN
DO NR=1,NREC
WRITE(IABS(IUNTHI),5) RECORD(NR)(1:MAXCHR),IEFAIL(NUMREC(NR),0),
1 (-IABS(IEFAIL(NUMREC(NR),ICK)),ICK=1,MAXCKS)
5 FORMAT(A,1X,I3,8I3)
ENDDO
ELSE
DO NR=1,NREC
WRITE(IABS(IUNTHI),5) RECORD(NR)(1:MAXCHR),IEFAIL(NUMREC(NR),0),
1 (IEFAIL(NUMREC(NR),ICK),ICK=1,MAXCKS)
ENDDO
ENDIF
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FNLCPY RESETS FILES FOR THE NEXT INPUT CYCLE
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: RESETS THE FILES CONTAINING THE INPUT RECORDS FOR THE
C NEXT RUN OF THE PROGRAM. THE SHORT-TERM HISTORY FILE IS UPDATED
C AND ALL INPUT FILES ARE FLUSHED, RECORDS THAT BELONG TO A FUTURE
C CYCLE ARE REINSERTED INTO THE INPUT FILES.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C
C USAGE: CALL FNLCPY(IUNTVZ,MAXUNT,IUNTOK,IUNTHA,MAXREC,NTBP,NUMTBP,
C IUNTIN,TBPREC,DUMREC)
C INPUT ARGUMENT LIST:
C IUNTVZ - UNIT NUMBER FOR FIRST INPUT FILE
C MAXUNT - NUMBER OF INPUT FILES TO BE RESET
C IUNTOK - UNIT NUMBER FOR TEMPORARY HISTORY FILE, WHICH CONTAINS
C - QUALITY CONTROLLED RECORDS, INCLUDING THOSE JUST
C - PROCESSED.
C IUNTHA - UNIT NUMBER FOR THE ALIAS SHORT TERM HISTORY FILE.
C RECORDS ARE COPIED FROM IUNTOK TO IUNTHA.
C MAXREC - MAXIMUM NUMBER OF RECORDS, DIMENSION OF IUNTIN.
C NTBP - NUMBER OF RECORDS FOR THE NEXT CYCLE THAT WILL BE
C - PUT BACK INTO THE INPUT FILES (THROWN BACK INTO THE
C - POND).
C NUMTBP - INTEGER ARRAY CONTAINING INDICES OF RECORDS THAT WILL
C - THROWN BACK INTO THE POND. INDICES REFER TO POSITION
C - IN ARRAY IUNTIN.
C IUNTIN - INTEGER ARRAY CONTAINING UNIT NUMBERS FOR RECORDS
C - THAT WILL BE THROWN BACK INTO THE POND.
C TBPREC - CHARACTER ARRAY CONTAINING RECORDS THAT WILL BE
C - THROWN BACK INTO THE POND.
C DUMREC - CHARACTER VARIABLE FOR COPYING RECORDS TO THE
C - SHORT-TERM HISTORY FILE.
C
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 10 - SCRATCH FILE
C UNIT 22 - SHORT-TERM HISTORY, RECORDS BACK 4 DAYS FROM PRESENT
C UNIT 30 - FILE(S) CONTAINING NEW RECORDS TO BE QUALITY
C - CONTROLLED. RECORDS APPROPRIATE TO A FUTURE CYCLE ARE
C - WRITTEN BACK TO THIS FILE
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE FNLCPY(IUNTVZ,MAXUNT,IUNTOK,IUNTHA,MAXREC,NTBP,NUMTBP,
1 IUNTIN,TBPREC,DUMREC)
SAVE
CHARACTER DUMREC*(*),TBPREC(NTBP)*(*)
CHARACTER*100 DUMY2K
DIMENSION NUMTBP(NTBP),IUNTIN(MAXREC)
C FINAL COPYING BACK TO SHORT TERM HISTORY FILE AND ZEROING ALL
C FILES THAT WILL CONTAIN NEW RECORDS FOR THE NEXT CYCLE
NREC=0
REWIND IUNTOK
REWIND IUNTHA
10 CONTINUE
READ(IUNTOK,11,END=20) DUMREC
11 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',DUMREC(20:21),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntok,'; DUMREC-7: ',dumrec
PRINT *, ' '
DUMY2K(1:19) = DUMREC(1:19)
IF(DUMREC(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = DUMREC(20:100)
DUMREC = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ DUMREC(20:23),'" via windowing technique'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntok,'; DUMREC-7: ',dumrec
PRINT *, ' '
ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',DUMREC(20:23),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntok,'; DUMREC-7: ',dumrec
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 10
END IF
NREC=NREC+1
WRITE(IUNTHA,11) DUMREC
GO TO 10
20 CONTINUE
WRITE(6,21) NREC,IUNTHA
21 FORMAT(/'...',I3,' RECORDS HAVE BEEN COPIED TO THE FUTURE ALIAS ',
1 'SHORT-TERM HISTORY FILE, UNIT=',I3)
IUNTVI=IUNTVZ
DO NFILE=1,MAXUNT
REWIND IUNTVI
IF(NTBP .EQ. 0) THEN
END FILE IUNTVI
WRITE(6,23) IUNTVI
23 FORMAT(/'...UNIT',I3,' HAS BEEN ZEROED FOR THE NEXT CYCLE.')
C THROW RECORDS FOR THE NEXT CYCLE BACK INTO THE POND
ELSE
WRITE(6,27) IUNTVI
27 FORMAT(/'...THE FOLLOWING RECORDS WILL BE THROWN BACK INTO THE ',
1 'POND = UNIT',I3,':')
DO NTB=1,NTBP
IF(IUNTIN(NUMTBP(NTB)) .EQ. IUNTVI) THEN
WRITE(IUNTVI,11) TBPREC(NTB)
WRITE(6,29) NTB,NUMTBP(NTB),TBPREC(NTB)
29 FORMAT(3X,I4,'...',I4,'...',A,'...')
ENDIF
ENDDO
ENDIF
IUNTVI=IUNTVI+1
ENDDO
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: CPYREC COPIES RECORDS CHECKS DATES & DUPLICATES
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: RECORDS ARE CHECKED FOR DATE AND EXACT AND PARTIAL
C DUPLICATES AND COPIED FROM ONE FILE TO A SECOND FILE.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1992-03-10 S. LORD - ADDED FILTERS.
C
C USAGE: CALL CPYREC(ICALL,IUNTRD,IUNTWT,NOKAY,DAYMN,DUMREC,OKAREC)
C INPUT ARGUMENT LIST:
C ICALL - TOGGLE FOR FILTER. 1: NO FILTER (STRAIGHT COPY)
C 2: DATE/TIME, STORM ID & NAME
C 3: #2 ABOVE PLUS RSMC (PARTIAL
C DUPLICATE)
C IUNTRD - UNIT NUMBER FOR RECORDS TO BE COPIED
C IUNTWT - RECORDS COPIED TO THIS UNIT NUMBER
C NOKAY - LENGTH OF ARRAY OKAREC
C DAYMN - RECORDS WITH DATES PRIOR TO THIS DAY WILL NOT BE
C - COPIED. DAYMN HAS UNITS OF DDD.FFF, WHERE DDD=
C - JULIAN DAY, FFF=FRACTIONAL DAY (E.G. .5 IS 1200 UTC.)
C DUMREC - CHARACTER VARIABLE LONG ENOUGH TO HOLD COPIED RECORD.
C OKAREC - CHARACTER ARRAY CONTAINING RECORDS AGAINST WHICH
C - EACH COPIED RECORD WILL BE CHECKED FOR EXACT OR
C - PARTIAL DUPLICATES. A PARTIAL DUPLICATE IS ONE WITH
C - THE SAME RSMC, DATE/TIME AND STORM NAME/ID.
C
C INPUT FILES:
C UNIT 20 - SHORT TERM HISTORY
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 22 - PRELIMINARY QUALITY CONTROLLED FILE
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE CPYREC(ICALL,IUNTRD,IUNTWT,NOKAY,DAYMN,DUMREC,OKAREC)
SAVE
CHARACTER*(*) DUMREC,OKAREC(NOKAY)
CHARACTER*100 DUMY2K
DIMENSION RINC(5)
PARAMETER (MAXVIT=15)
CHARACTER FMTVIT*6
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION FMTVIT(MAXVIT)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA NUM/1/,FIVMIN/3.4722E-3/
NREC=0
REWIND IUNTRD
10 CONTINUE
READ(IUNTRD,11,END=100) DUMREC
11 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',DUMREC(20:21),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-8: ',dumrec
PRINT *, ' '
DUMY2K(1:19) = DUMREC(1:19)
IF(DUMREC(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = DUMREC(20:100)
DUMREC = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ DUMREC(20:23),'" via windowing technique'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-8: ',dumrec
PRINT *, ' '
ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',DUMREC(20:23),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-8: ',dumrec
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 10
END IF
IF(ICALL .GT. 1) THEN
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 DUMREC)
ENDDO
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
C WRITE(6,21) IDATEZ,IUTCZ,DAYZ,DAYMN
C 21 FORMAT(/'...CHECKING DATE,TIME FOR COPYING HISTORICAL RECORDS',I9,
C I5,2F10.2)
IF(DAYZ .GE. DAYMN-FIVMIN) THEN
DO NOK=1,NOKAY
IF(DUMREC .EQ. OKAREC(NOK)) THEN
WRITE(6,27) DUMREC
27 FORMAT(/'...EXACT DUPLICATE FOUND IN THE NEW AND HISTORICAL ',
1 'FILES. THE HISTORICAL RECORD WILL NOT BE COPIED.'/8X,
2 '...',A/)
GO TO 10
ENDIF
C CHECK FOR VARIOUS PARTIAL DUPLICATES:
C ICALL = 2: DATE/TIME, STORM ID, STORM NAME FILTER
C ICALL = 3: #2 ABOVE PLUS RSMC, I.E. A PARTIAL DUPLICATE
IF(ICALL .EQ. 2 .AND. DUMREC(6:ISTVAR(3)-1) .EQ.
1 OKAREC(NOK)(6:ISTVAR(3)-1)) THEN
WRITE(6,59) DUMREC,OKAREC(NOK)
59 FORMAT(/'...PARTIAL DUPLICATE IN STORM ID & NAME, DATE AND TIME ',
1 'FOUND IN THE NEW AND HISTORICAL FILES.'/4X,'THE ',
2 'HISTORICAL RECORD WILL NOT BE COPIED.'/5X,'HIS...',A/5X,
3 'NEW...',A/)
GO TO 10
ENDIF
IF(ICALL .GE. 3 .AND. DUMREC(1:ISTVAR(3)-1) .EQ.
1 OKAREC(NOK)(1:ISTVAR(3)-1)) THEN
WRITE(6,69) DUMREC,OKAREC(NOK)
69 FORMAT(/'...PARTIAL DUPLICATE IN RSMC, STORM ID & NAME, DATE AND',
1 ' TIME FOUND IN THE NEW AND HISTORICAL FILES.'/4X,'THE ',
2 'HISTORICAL RECORD WILL NOT BE COPIED.'/5X,'HIS...',A/5X,
3 'NEW...',A/)
GO TO 10
ENDIF
ENDDO
NREC=NREC+1
WRITE(6,83) NREC,DUMREC
83 FORMAT(3X,I4,'...',A,'...')
WRITE(IUNTWT,11) DUMREC
ENDIF
ELSE
NREC=NREC+1
WRITE(6,83) NREC,DUMREC
WRITE(IUNTWT,11) DUMREC
ENDIF
GO TO 10
100 WRITE(6,101) NREC,IUNTRD,IUNTWT
101 FORMAT(/'...',I4,' RECORDS HAVE BEEN COPIED FROM UNIT',I3,' TO ',
1 'UNIT',I3,'.')
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: DUPCHK READS INPUT RECORDS, DUPLICATE CHECKS
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: READS INPUT RECORDS FROM ALL SPECIFIED FILES. CHECKS FOR
C EXACT DUPLICATES. RETURNS ALL RECORDS TO BE QUALITY CONTROLLED.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1992-08-20 S. LORD ADDED NEW UNIT FOR GTS BUFR MESSAGES
C 1997-06-24 S. LORD ADDED NEW UNIT FOR MANUALLY ENTERED MESSAGES
C
C USAGE: CALL DUPCHK(IUNTIN,MAXUNT,MAXREC,IERCHK,NUNI,IFILE,
C NUMOKA,DUMREC,UNIREC,DUPREC,*)
C INPUT ARGUMENT LIST:
C IUNTIN - THE INPUT UNIT NUMBER FOR THE FIRST FILE TO BE READ.
C MAXUNT - NUMBER OF INPUT FILES.
C MAXREC - MAXIMUM NUMBER OF INPUT RECORDS. SUBROUTINE
C - RETURNS WITH CONDITION CODE=51 OR 53 WHEN NUMBER OF
C - UNIQUE OR DUPLICATE RECORDS EXCEEDS MAXREC.
C
C OUTPUT ARGUMENT LIST:
C IERCHK - ERROR INDICATOR.
C NUNI - NUMBER OF UNIQUE RECORDS TO BE QUALITY CONTROLLED
C IFILE - INTEGER ARRAY CONTAINING THE UNIT NUMBER FROM WHICH
C - EACH INPUT RECORD WAS READ.
C NUMOKA - INDEX NUMBER FOR EACH UNIQUE RECORD. INDEX NUMBER
C - IS SIMPLY THE ORDINAL NUMBER OF EACH RECORD READ
C - THAT IS UNIQUE, I.E. NOT A DUPLICATE.
C DUMREC - DUMMY CHARACTER VARIABLE LARGE ENOUGH TO READ A RECORD.
C UNIREC - CHARACTER ARRAY HOLDING ALL INPUT RECORDS.
C DUPREC - CHARACTER ARRAY HOLDING ALL DUPLICATE RECORDS.
C * - ALTERNATE RETURN IF NO INPUT RECORDS ARE FOUND.
C - SUBROUTINE RETURNS WITH IERCHK=161.
C
C INPUT FILES:
C UNIT 30 - FILES CONTAINING NEW RECORDS TO BE QUALITY CONTROLLED.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE DUPCHK(IUNTIN,MAXUNT,MAXREC,IERCHK,NUNI,IFILE,NUMOKA,
1 DUMREC,UNIREC,DUPREC,*)
PARAMETER (MAXFIL=5)
SAVE
LOGICAL UNIQUE
CHARACTER*(*) DUMREC,UNIREC(0:MAXREC),DUPREC(MAXREC)
CHARACTER INPFIL(MAXFIL)*4
CHARACTER*100 DUMY2K
DIMENSION NUMOKA(MAXREC),IFILE(MAXREC)
DATA INPFIL/'NHC ','FNOC','GBTB','GBFR','HBTB'/
IF(MAXUNT .GT. MAXFIL) THEN
WRITE(6,1) MAXUNT,MAXFIL
1 FORMAT(/'******MAXIMUM NUMBER OF UNITS TO BE READ=',I3,' EXCEEDS',
1 ' EXPECTATIONS. NUMBER WILL BE REDUCED TO',I3)
MAXUNT=MAXFIL
ENDIF
IUNTVI=IUNTIN
IERCHK=0
NUNI=0
NDUP=0
NSTART=0
NALREC=0
NRFILE=0
UNIREC(0)='ZZZZZZZ'
WRITE(6,3) MAXREC,IUNTVI,MAXUNT,(INPFIL(IFFF),
1 IUNTIN+IFFF-1,IFFF=1,MAXUNT)
3 FORMAT(//'...ENTERING DUPCHK: READING FILE AND LOOKING FOR EXACT',
1 ' DUPLICATES. MAXREC=',I4,'.'/4X,'INITIAL UNIT NUMBER=',
2 I4,' AND',I3,' UNITS WILL BE READ'/4X,'FILES AND UNIT ',
3 'NUMBERS ARE:'/(6X,A,':',I3))
10 CONTINUE
DO NREC=1,MAXREC
READ(IUNTVI,11,END=130) DUMREC
11 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C FOR EXAMPLE:
C NHC 13L MITCH 981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123
C 1 2 3 4 5 6 7 8 9
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - FOR
C EXAMPLE, THE ABOVE RECORD IS CONVERTED TO:
C NHC 13L MITCH 19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345
C 1 2 3 4 5 6 7 8 9
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',DUMREC(20:21),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntvi,'; DUMREC-1: ',dumrec
PRINT *, ' '
DUMY2K(1:19) = DUMREC(1:19)
IF(DUMREC(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = DUMREC(20:100)
DUMREC = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ DUMREC(20:23),'" via windowing technique'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntvi,'; DUMREC-1: ',dumrec
PRINT *, ' '
ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -
C FOR EXAMPLE:
C NHC 13L MITCH 19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345
C 1 2 3 4 5 6 7 8 9
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',DUMREC(20:23),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iuntvi,'; DUMREC-1: ',dumrec
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT '(a,a,a)', '***** Cannot determine if this record ',
$ 'contains a 2-digit year or a 4-digit year - skip it and ',
$ 'try reading the next record'
PRINT *, ' '
GO TO 100
END IF
NALREC=NALREC+1
NRFILE=NRFILE+1
UNIQUE=.TRUE.
DO NR=NSTART,NUNI
IF(DUMREC .EQ. UNIREC(NR)) UNIQUE=.FALSE.
ENDDO
IF(UNIQUE) THEN
IF(NUNI .EQ. MAXREC) THEN
WRITE(6,51) MAXREC
51 FORMAT('******INSUFFICIENT STORAGE FOR ALL VITAL ',
1 'STATISTICS RECORDS, MAXREC=',I5)
IERCHK=51
RETURN
ELSE
NUNI=NUNI+1
NUMOKA(NUNI)=NUNI
UNIREC(NUNI)=DUMREC
IFILE(NUNI)=IUNTVI
ENDIF
ELSE
IF(NDUP .EQ. MAXREC) THEN
WRITE(6,51) MAXREC
IERCHK=53
RETURN
ELSE
NDUP=NDUP+1
DUPREC(NDUP)=DUMREC
ENDIF
ENDIF
NSTART=1
100 continue
ENDDO
130 CONTINUE
C LOOP FOR MORE FILES IF REQUESTED
IF(NRFILE .EQ. 0) WRITE(6,133) INPFIL(IUNTVI-29)
133 FORMAT(/'###',A,' FILE IS EMPTY.')
IUNTVI=IUNTVI+1
IF(IUNTVI-IUNTIN .LT. MAXUNT) THEN
NRFILE=0
WRITE(6,141) IUNTVI,MAXUNT
141 FORMAT(/'...LOOPING TO READ UNIT NUMBER',I3,'. MAXUNT=',I3)
GO TO 10
ENDIF
WRITE(6,151) NALREC
151 FORMAT(//'...TOTAL NUMBER OF RECORDS=',I4)
WRITE(6,153) NUNI,(NUMOKA(NR),UNIREC(NR),NR=1,NUNI)
153 FORMAT(/'...',I4,' RECORDS ARE UNIQUE, BUT NOT ERROR CHECKED.'//
1 (' ...',I4,'...',A))
WRITE(6,157) NDUP,(NR,DUPREC(NR),NR=1,NDUP)
157 FORMAT(/'...',I4,' RECORDS ARE EXACT DUPLICATES:'//(' ...',I4,
1 '...',A))
IF(NUNI .EQ. 0) THEN
WRITE(6,161)
161 FORMAT(/'###THERE ARE NO RECORDS TO BE READ. THIS PROGRAM ',
1 'WILL COMPLETE FILE PROCESSING AND LEAVE AN EMPTY ',
2 ' "CURRENT" FILE!!')
IERCHK=161
RETURN 1
ENDIF
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: BLNKCK CHECKS FOR PROPER COLUMNAR FORMAT
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: CHECKS ALL INPUT RECORDS FOR PROPER COLUMNAR FORMAT.
C THE TABULAR INPUT RECORD HAS SPECIFIED BLANK COLUMNS. IF
C NONBLANK CHARACTERS ARE FOUND IN SPECIFIED BLANK COLUMNS,
C AN OBVIOUS ERROR HAS OCCURRED. THE RECORD IS REJECTED IN THIS
C CASE.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1994-06-20 S. LORD MODIFIED MAXCHK FOR THE GFDL FORMAT
C
C USAGE: CALL BLNKCK(NTEST,NOKAY,NBAD,IFBLNK,NUMTST,NUMOKA,NUMBAD,
C ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
C INPUT ARGUMENT LIST:
C NTEST - NUMBER OF RECORDS TO BE TESTED.
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES.
C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS.
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK.
C IFBLNK - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE BLANK CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE BLANK CHECK.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE BLNKCK(NTEST,NOKAY,NBAD,IFBLNK,NUMTST,NUMOKA,NUMBAD,
1 ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
PARAMETER (MAXCHK=95)
PARAMETER (NERCBL=3)
PARAMETER (MAXREC=1000)
SAVE
CHARACTER*(*) ZZZREC,NNNREC,TSTREC(0:NTEST),BADREC(MAXREC),
1 OKAREC(NTEST)
CHARACTER ERCBL(NERCBL)*60
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
CHARACTER NAMVAR*5
DIMENSION ISTVAR(MAXVIT)
DIMENSION NAMVAR(MAXVIT+1)
DIMENSION IFBLNK(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC),
1 NUMTST(NTEST)
DATA ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
1 LENHED/18/
DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED',
1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE',
2 'R15SE','R15SW','R15NW','DEPTH'/
DATA ERCBL
1 /'1 : LAST NON-BLANK CHARACTER IS IN THE WRONG COLUMN ',
2 '18 : FIRST 18 COLUMNS ARE BLANK ',
3 '19-87: FIRST NON-BLANK CHARACTER FOUND IN THIS COLUMN '/
C ERROR CODES FOR BAD RECORDS RETURNED IN IFBLNK ARE AS FOLLOWS:
C 1: LAST NON-BLANK CHARACTER IS IN THE WRONG COLUMN
C 18 : FIRST 18 COLUMNS ARE BLANK
C 19-87: NON-BLANK CHARACTER FOUND IN A BLANK COLUMN. ERROR
C CODE GIVES COLUMN OF LEFT-MOST OCCURRENCE
C SET COUNTERS FOR INITIAL SORTING OF ALL RECORDS. ALL SUBSEQUENT
C CALLS TO THIS ROUTINE SHOULD BE FOR SINGLE RECORDS
WRITE(6,1) NTEST
1 FORMAT(//'...ENTERING BLNKCK, LOOKING FOR WRONGLY POSITIONED ',
1 ' BLANKS. NTEST=',I4//)
NADD=0
IF(NREC .GT. 0) THEN
NOKAY=0
NBAD =0
ENDIF
C DO ALL RECORDS
DO NREC=1,NTEST
IETYP=0
C FIND THE RIGHT-MOST NON-BLANK CHARACTER: IT SHOULD CORRESPOND
C TO THE MAXIMUM NUMBER OF CHARACTERS IN THE MESSAGE (MAXCHR)
DO ICH=MAXCHK,1,-1
IF(TSTREC(NREC)(ICH:ICH) .NE. ' ') THEN
IBLANK=ICH
GO TO 31
ENDIF
ENDDO
31 CONTINUE
C WRITE(6,3311) IBLANK,TSTREC(NREC)(1:IBLANK)
C3311 FORMAT(/'...TESTING LENGTH OF RECORD, IBLANK,TSTREC=',I4/4X,'...',
C 1 A,'...')
C
IF(IBLANK .NE. MAXCHR) THEN
IETYP=1
WRITE(6,33) NREC,IBLANK,NNNREC,ZZZREC,TSTREC(NREC)
33 FORMAT(/'...RECORD #',I3,' HAS RIGHT-MOST NON-BLANK CHARACTER ',
1 'AT POSITION',I4/2(1X,'@@@',A,'@@@'/),4X,A)
GO TO 41
ENDIF
C CHECK FOR BLANKS IN THE HEADER SECTION (THE FIRST 18 COLUMNS)
IF(TSTREC(NREC)(1:LENHED) .EQ. ' ') THEN
IETYP=LENHED
WRITE(6,35) NREC,NNNREC,ZZZREC,TSTREC(NREC)
35 FORMAT(/'...RECORD #',I3,' HAS BLANK HEADER SECTION.'/2(1X,'@@@',
1 A,'@@@'/),4X,A)
ENDIF
C CHECK COLUMN BLANKS STARTING TO THE LEFT OF THE YYMMDD GROUP
DO IBL=1,MAXVIT
IF(TSTREC(NREC)(ISTVAR(IBL)-1:ISTVAR(IBL)-1) .NE. ' ') THEN
IETYP=ISTVAR(IBL)-1
WRITE(6,39) TSTREC(NREC)(ISTVAR(IBL)-1:ISTVAR(IBL)-1),
1 ISTVAR(IBL)-1,NAMVAR(IBL),NNNREC,ZZZREC,TSTREC(NREC)
39 FORMAT(/'...NONBLANK CHARACTER ',A1,' AT POSITION ',I3,
1 ' PRECEEDING VARIABLE',1X,A/2(1X,'@@@',A,'@@@'/),4X,A)
GO TO 41
ENDIF
ENDDO
41 IFBLNK(NUMTST(NREC))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(NREC)
BADREC(NADD+NBAD)=TSTREC(NREC)
ELSE
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NREC)
OKAREC(NOKAY)=TSTREC(NREC)
ENDIF
ENDDO
print *, ' '
IF(NTEST .GT. 1) THEN
WRITE(6,101) NOKAY,NADD,NTEST,(ERCBL(NER),NER=1,NERCBL)
101 FORMAT(/'...RESULTS OF THE GLOBAL BLANK CHECK ARE: NOKAY=',I4,
1 ' AND NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS.'//4X,
2 'ERROR CODES ARE:'/(6X,A))
WRITE(6,103)
103 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,109) NOK,NUMOKA(NOK),OKAREC(NOK),IFBLNK(NUMOKA(NOK))
109 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
IF(NADD .GT. 0) WRITE(6,111) (NBAD+NBA,NUMBAD(NBAD+NBA),
1 BADREC(NBAD+NBA),
2 IFBLNK(NUMBAD(NBAD+NBA)),
3 NBA=1,NADD)
111 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4,
1 '...',A,'...',I3))
NBAD=NBAD+NADD
ELSE
WRITE(6,113) IETYP,TSTREC(NTEST),NOKAY
113 FORMAT(/'...BLANK TEST FOR SINGLE RECORD, BLANK ERROR CODE=',I2,
1 ' RECORD IS:'/4X,'...',A/4X,'NOKAY=',I2)
ENDIF
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: READCK CHECKS READABILITY OF EACH RECORD
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: CHECKS READABILITY OF EACH RECORD. SINCE THE INPUT
C RECORD FORMAT CONTAINS ONLY NUMBERS AND LETTERS,
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1992-09-18 S. J. LORD ADDED CHECK FOR CORRECT MISSING DATA IN READCK
C
C USAGE: CALL READCK(NTEST,NOKAY,NBAD,IFREAD,NUMTST,NUMOKA,NUMBAD,
C ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
C INPUT ARGUMENT LIST:
C NTEST - NUMBER OF RECORDS TO BE TESTED.
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES.
C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS.
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK.
C IFREAD - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE BLANK CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE BLANK CHECK.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE READCK(NTEST,NOKAY,NBAD,IFREAD,NUMTST,NUMOKA,NUMBAD,
1 ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
PARAMETER (NERCRD=2)
PARAMETER (MAXREC=1000)
SAVE
CHARACTER*(*) ZZZREC,NNNREC,TSTREC(0:NTEST),BADREC(MAXREC),
1 OKAREC(NTEST),ERCRD(NERCRD)*60
PARAMETER (MAXVIT=15)
PARAMETER (ITERVR=10)
CHARACTER FMTVIT*6,NAMVAR*5
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION NAMVAR(MAXVIT+1),FMTVIT(MAXVIT),MISSNG(MAXVIT)
DIMENSION IFREAD(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC),
1 NUMTST(NTEST)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
2 MISSNG/-9999999,-999,-99,-999,2*-99,3*-999,-9,-99,4*-999/,
3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED',
1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE',
2 'R15SE','R15SW','R15NW','DEPTH'/
DATA NUM/1/
DATA ERCRD
1 /'N: INDEX OF THE FIRST UNREADABLE RECORD ',
2 '20-N: WRONG MISSING CODE '/
C ERROR CODE FOR UNREADABLE RECORD IS THE INDEX OF THE FIRST
C UNREADABLE RECORD.
C ***NOTE: THERE MAY BE ADDITIONAL UNREADABLE RECORDS TO THE
C RIGHT.
WRITE(6,1) NTEST
1 FORMAT(//'...ENTERING READCK, LOOKING FOR UNREADABLE (NOT ',
1 ' CONTAINING INTEGERS) PRIMARY AND SECONDARY VARIABLES,',
2 ' NTEST=',I4//)
NADD=0
C DO ALL RECORDS
DO NREC=1,NTEST
IETYP=0
DO IV=1,ITERVR
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NREC))
IF(IERDEC .NE. 0) THEN
IETYP=IV
WRITE(6,7) NREC,ISTVAR(IV),NAMVAR(IV),NNNREC,ZZZREC,TSTREC(NREC)
7 FORMAT(/'...RECORD #',I3,' IS UNREADABLE AT POSITION',I3,
1 ' FOR VARIABLE ',A,'.'/2(1X,'@@@',A,'@@@'/),4X,A)
GO TO 11
ENDIF
ENDDO
11 CONTINUE
DO IV=1,ITERVR
IF(IVTVAR(IV) .LT. 0 .AND. IVTVAR(IV) .NE. MISSNG(IV)) THEN
IETYP=20-IV
WRITE(TSTREC(NREC) (ISTVAR(IV):IENVAR(IV)),FMTVIT(IV))MISSNG(IV)
ENDIF
ENDDO
IFREAD(NUMTST(NREC))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(NREC)
BADREC(NADD+NBAD)=TSTREC(NREC)
ELSE
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NREC)
OKAREC(NOKAY)=TSTREC(NREC)
ENDIF
ENDDO
WRITE(6,101) NOKAY,NADD,NTEST,(ERCRD(NER),NER=1,NERCRD)
101 FORMAT(//'...RESULTS OF THE READABILITY CHECK ARE: NOKAY=',I4,
1 ' AND NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS.'//4X,
2 'ERROR CODES ARE:'/(6X,A))
WRITE(6,103)
103 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,109) NOK,NUMOKA(NOK),OKAREC(NOK),IFREAD(NUMOKA(NOK))
109 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
IF(NADD .GT. 0) WRITE(6,111) (NBAD+NBA,NUMBAD(NBAD+NBA),
1 BADREC(NBAD+NBA),
2 IFREAD(NUMBAD(NBAD+NBA)),
3 NBA=1,NADD)
111 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4,
1 '...',A,'...',I3))
NBAD=NBAD+NADD
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: DTCHK CHECK FOR VALID DATE FOR ALL RECORDS
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: CHECKS FOR VALID DATE IN ALL RECORDS.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C
C USAGE: CALL DTCHK(NTEST,NOKAY,NBAD,NTBP,IFDTCK,NUMTST,NUMOKA,
C NUMBAD,NUMTBP,DAYMN,DAYMX1,DAYMX2,DAYOFF,TSTREC,
C BADREC,OKAREC,TBPREC)
C INPUT ARGUMENT LIST:
C NTEST - NUMBER OF RECORDS TO BE TESTED.
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C DAYMN - EARLIEST (MINIMUM) DATE FOR ACCEPTANCE OF A RECORD.
C - UNITS ARE DDD.FFF, WHERE DDD=JULIAN DAY, FFF=FRAC-
C - TIONAL DAY (E.G. .5=1200 UTC).
C DAYMX1 - LATEST (MAXIMUM) DATE FOR ACCEPTANCE OF A RECORD.
C - UNITS ARE FRACTIONAL JULIAN DAYS AS IN DAYMN ABOVE.
C DAYMX2 - EARLIEST (MINIMUM) DATE FOR REJECTION OF A RECORD.
C - RECORDS WITH DATES BETWEEN DAYMX1 AND DAYMX2 ARE
C - ASSUMED TO BELONG TO A FUTURE CYCLE AND ARE THROWN
C - BACK INTO THE POND, I.E. NEITHER REJECTED OR ACCEPTED.
C - UNITS ARE FRACTIONAL JULIAN DAYS AS IN DAYMN ABOVE.
C DAYOFF - OFFSET DAYS WHEN ACCEPTANCE WINDOW CROSSES YEAR
C BOUNDARY
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK.
C NTBP - NUMBER OF RECORDS THAT ARE TO BE RESTORED TO THE
C - INPUT FILES (THROWN BACK INTO THE POND).
C IFDTCK - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C NUMTBP - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE THROWN BACK INTO THE POND.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE BLANK CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE BLANK CHECK.
C TBPREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT ARE TO
C - BE THROWN BACK INTO THE POND.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE DTCHK(NTEST,NOKAY,NBAD,NTBP,IFDTCK,NUMTST,NUMOKA,
1 NUMBAD,NUMTBP,DAYMN,DAYMX1,DAYMX2,DAYOFF,TSTREC,
2 BADREC,OKAREC,TBPREC)
PARAMETER (NERCDT=8)
PARAMETER (MAXREC=1000)
PARAMETER (MAXTBP=20)
SAVE
CHARACTER*(*) TSTREC(0:NTEST),BADREC(MAXREC),OKAREC(NTEST),
1 TBPREC(MAXTBP),ERCDT(NERCDT)*60
PARAMETER (MAXVIT=15)
CHARACTER FMTVIT*6
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION FMTVIT(MAXVIT)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
DIMENSION RINC(5)
DIMENSION IFDTCK(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC),
1 NUMTST(NTEST),NUMTBP(MAXTBP),IDAMX(12)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA NUM/1/,IYRMN/0/,IYRMX/9999/,IMOMN/1/,IMOMX/12/,IDAMN/1/,
1 IDAMX/31,29,31,30,31,30,31,31,30,31,30,31/,IHRMN/0/,
2 IHRMX/23/,IMINMN/0/,IMINMX/59/
DATA ERCDT
1 /' 1: YEAR OUT OF RANGE ',
2 ' 2: MONTH OUT OF RANGE ',
3 ' 3: DAY OUT OF RANGE ',
4 ' 4: HOUR OUT OF RANGE ',
5 ' 5: MINUTE OUT OF RANGE ',
6 ' 6: DATE/TIME LESS THAN ALLOWED WINDOW ',
7 ' 7: DATE/TIME GREATER THAN ALLOWED MAXIMUM WINDOW ',
8 '-8: DATE/TIME PROBABLY VALID AT LATER CYCLE TIME (TBIP) '/
C ERROR CODES FOR BAD RECORDS RETURNED IN IFDTCK ARE AS FOLLOWS:
C 1: YEAR OUT OF RANGE
C 2: MONTH OUT OF RANGE
C 3: DAY OUT OF RANGE
C 4: HOUR OUT OF RANGE
C 5: MINUTE OUT OF RANGE
C 6: DATE/TIME LESS THAN ALLOWED WINDOW
C 7: DATE/TIME GREATER THAN ALLOWED WINDOW
C -8: DATE/TIME PROBABLY VALID AT LATER CYCLE TIME (THROWN BACK
C INTO THE POND)
WRITE(6,1) NTEST,NOKAY,NBAD,DAYMN,DAYMX1,DAYMX2
1 FORMAT(//'...ENTERING DTCHK, LOOKING FOR BAD DATE/TIME GROUPS. ',
1 'NTEST,NOKAY,NBAD=',3I4,'.'/4X,'DAYMN,DAYMX1,DAYMX2=',
2 3F12.4//)
NADD=0
NTBPZ=0
DO NREC=1,NTEST
IETYP=0
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NREC))
ENDDO
C CONVERT DATE/TIME TO FLOATING POINT DATE
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
IF(IYR .LT. IYRMN .OR. IYR .GT. IYRMX) THEN
IETYP=1
WRITE(6,21) IYR,IYRMN,IYRMX,TSTREC(NREC)
21 FORMAT(/'******DECODED YEAR OUT OF ALLOWED BOUNDS, IYR,IYRMN,',
1 'IYRMX,RECORD=',3I9/8X,A)
ENDIF
IF(IMO .LT. IMOMN .OR. IMO .GT. IMOMX) THEN
IETYP=2
WRITE(6,31) IMO,IMOMN,IMOMX,TSTREC(NREC)
31 FORMAT(/'******DECODED MONTH OUT OF ALLOWED BOUNDS, IMO,IMOMN,',
1 'IMOMX,RECORD=',3I9/8X,A/5X,'...(DAY WILL NOT BE CHECKED)')
ELSE
IF(IDA .LT. IDAMN .OR. IDA .GT. IDAMX(IMO)) THEN
IETYP=3
WRITE(6,41) IDA,IDAMN,IDAMX,TSTREC(NREC)
41 FORMAT(/'******DECODED DAY OUT OF ALLOWED BOUNDS, IDA,IDAMN,',
1 'IDAMX,RECORD=',3I9/8X,A)
ENDIF
ENDIF
IF(IHR .LT. IHRMN .OR. IHR .GT. IHRMX) THEN
IETYP=4
WRITE(6,51) IHR,IHRMN,IHRMX,TSTREC(NREC)
51 FORMAT(/'******DECODED HOUR OUT OF ALLOWED BOUNDS, IHR,IHRMN,',
1 'IHRMX,RECORD=',3I9/8X,A)
ENDIF
IF(IMIN .LT. IMINMN .OR. IMIN .GT. IMINMX) THEN
IETYP=5
WRITE(6,61) IMIN,IMINMN,IMINMX,TSTREC(NREC)
61 FORMAT(/'******DECODED MINUTE OUT OF ALLOWED BOUNDS, IMIN,',
1 'IMINMN,IMINMX,RECORD=',3I9/8X,A)
ENDIF
IF(IETYP .EQ. 0 .AND. DAYZ+DAYOFF .LT. DAYMN) THEN
IETYP=6
WRITE(6,71) DAYZ,DAYMN,TSTREC(NREC)
71 FORMAT(/'******DECODED DAY LESS THAN MINIMUM WINDOW, DAYZ,DAYMN,',
1 'RECORD=',2F12.4/8X,A)
ENDIF
IF(IETYP .EQ. 0 .AND. DAYZ+DAYOFF .GT. DAYMX2) THEN
IETYP=7
WRITE(6,73) DAYZ,DAYMX2,TSTREC(NREC)
73 FORMAT(/'******DECODED DAY EXCEEDS MAXIMUM WINDOW, DAYZ,DAYMX2,',
1 'RECORD=',2F12.4/8X,A)
ENDIF
IF(IETYP .EQ. 0 .AND. DAYZ .GT. DAYMX1) THEN
IETYP=-8
WRITE(6,77) DAYZ,DAYMX1,TSTREC(NREC)
77 FORMAT(/'###DECODED DAY PROBABLY VALID AT FUTURE CYCLE TIME. ',
1 'DAYZ,DAYMX1,RECORD=',2F12.4/8X,A/4X, 'THIS RECORD WILL ',
2 'BE THROWN BACK IN THE POND.')
ENDIF
IFDTCK(NUMTST(NREC))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(NREC)
BADREC(NADD+NBAD)=TSTREC(NREC)
ELSE IF(IETYP .EQ. 0) THEN
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NREC)
OKAREC(NOKAY)=TSTREC(NREC)
ELSE
NTBPZ=NTBPZ+1
NUMTBP(NTBPZ)=NUMTST(NREC)
TBPREC(NTBPZ)=TSTREC(NREC)
ENDIF
ENDDO
NTBP=NTBPZ
WRITE(6,101) NOKAY,NADD,NTBP,NTEST,(ERCDT(NER),NER=1,NERCDT)
101 FORMAT(//'...RESULTS OF THE DATE/TIME CHECK ARE: NOKAY=',I4,
1 ' ,NADD=',I4,' AND NTBP=',I4,' FOR A TOTAL OF',I4,
2 ' RECORDS.'//4X,'ERROR CODES ARE:'/(6X,A))
WRITE(6,103)
103 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,109) NOK,NUMOKA(NOK),OKAREC(NOK),IFDTCK(NUMOKA(NOK))
109 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
WRITE(6,113)
113 FORMAT(/'...RECORDS THAT WILL BE RETURNED TO THE INPUT FILES ',
1 '(THROWN BACK INTO THE POND) ARE:',36X,'ERC'/)
DO NTB=1,NTBP
WRITE(6,119) NTB,NUMTBP(NTB),TBPREC(NTB),
1 IFDTCK(NUMTBP(NTB))
119 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
IF(NADD .GT. 0) WRITE(6,131) (NBAD+NBA,NUMBAD(NBAD+NBA),
1 BADREC(NBAD+NBA),
2 IFDTCK(NUMBAD(NBAD+NBA)),
3 NBA=1,NADD)
131 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4,
1 '...',A,'...',I3))
NBAD=NBAD+NADD
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: SETMSK CHECKS ALL RECORDS FOR CORRECT LAT/LON
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: INPUT RECORDS ARE CHECKED FOR PHYSICALLY REALISTIC
C LATITUDE AND LONGITUDE (-70<LAT<70, -180<LONG<180). LONGITUDES
C EAST AND WEST ARE CHECKED BY MAKING SURE CHARACTERS "E" OR "W" ARE
C IN THE APPROPRIATE SLOTS. LATITUDES NORTH AND SOUTH ARE CHECKED
C BY MAKING SURE CHARACTERS "N" OR "S" ARE IN THE APPROPRIATE SLOTS.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1992-04-09 S. LORD CHANGED SLMASK TO T126 FROM T80
C
C USAGE: CALL SETMSK(IUNTSL,NTEST,NOKAY,NBAD,IECOST,IFLLCK,NUMTST,
C NUMOKA,NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,
C OKAREC)
C INPUT ARGUMENT LIST:
C IUNTSL - UNIT NUMBER FOR T126 32-BIT SEA-LAND MASK ON
C - GAUSSIAN GRID.
C NTEST - NUMBER OF RECORDS TO BE TESTED.
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES.
C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS.
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK.
C IECOST - ERROR CODE FOR OVER COASTAL STORM POSITIONS.
C IFLLCK - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE BLANK CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE BLANK CHECK.
C
C INPUT FILES:
C UNIT "IUNTSL" - GLOBAL T126 32-BIT SEA/LAND MASK FILE ON
C - GAUSSIAN GRID
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE SETMSK(IUNTSL,NTEST,NOKAY,NBAD,IECOST,IFLLCK,NUMTST,
1 NUMOKA,NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
PARAMETER (LATG2=190,LONF=384)
PARAMETER (NERCLL=6)
PARAMETER (MAXREC=1000)
SAVE
LOGICAL LNDFIL
CHARACTER*(*) ZZZREC,NNNREC,TSTREC(0:NTEST),BADREC(MAXREC),
1 OKAREC(NTEST),ERCLL(NERCLL)*60
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (ITERVR=10)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1
DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT),
1 ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION BUFIN(MAXCHR),FMTVIT(MAXVIT)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ),
1 (VITVAR( 9),RMAXZ)
DIMENSION IFLLCK(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC),
1 NUMTST(NTEST)
DIMENSION RLAT(LATG2),RLON(LONF),SLMASK(LONF,LATG2)
REAL(4) SLMASK_4(LONF,LATG2)
DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/,
1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
C DEGLAT: CONVERSION OF DEGREES LATITUDE TO KM
DATA NUM/1/,EPSSL/1.E-1/,DEGLAT/111.1775/,RLATMN/0.0/,RLATMX/70./,
1 RLONMN/0.0/,RLONMX/180./
DATA ERCLL
1 /'1: LATITUDE OUT OF RANGE ',
2 '2: LONGITUDE OUT OF RANGE ',
3 '3: BAD CHARACTER IN LATNS ',
4 '4: BAD CHARACTER IN LONEW ',
5 '5: STORM CIRCULATION OVER LAND: LANDLOCKED POINT ',
6 '6: STORM CIRCULATION OVER LAND: COASTAL POINT '/
C ERROR CODES FOR BAD RECORDS RETURNED IN IFLLCK ARE AS FOLLOWS:
C 1: LATITUDE OUT OF RANGE
C 2: LONGITUDE OUT OF RANGE
C 3: BAD CHARACTER IN LATNS
C 4: BAD CHARACTER IN LONEW
C 5: STORM POSITION OVER LAND: LANDLOCKED POINT
C 6: STORM POSITION OVER LAND: COASTAL POINT
DLON=360./REAL(LONF)
DO ILON=1,LONF
RLON(ILON)=REAL(ILON-1)*DLON
ENDDO
JDIM=LATG2
CALL GAULAT(RLAT,JDIM)
RLAT(1:JDIM)=90.-RLAT(1:JDIM)
C
C WRITE(6,21) (RLON(ILON),ILON=1,LONF)
C 21 FORMAT(//'...IN LLCHK, LONGITUDES ARE:'/(3X,10F10.3))
C WRITE(6,23) (RLAT(ILAT),ILAT=1,LATG2)
C 23 FORMAT(/'...IN LLCHK, LATITUDES ARE:'/(3X,10F10.3))
C Read in the Land/Sea mask (NOTE: Must return array as 32-bit
C reals, then transfer to array with default machine length)
READ(IUNTSL) SLMASK_4
SLMASK = SLMASK_4
C MAKE SOME ISLAND POINTS OCEAN SO THAT BOGUSING IS CONTINUOUS
C AS CYCLONE PASSES OVER IT
CALL FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK)
C WRITE(6,28)
C WRITE(6,27) (J,(IFIX(SLMASK(I,J)),I=1,100),J=1,190)
C 27 FORMAT(/'...SLMASK(1-100,1-190)=:'/(1X,I3,1X,100I1))
C WRITE(6,28)
C 28 FORMAT(//)
C WRITE(6,29) (J,(IFIX(SLMASK(I,J)),I=101,200),J=1,190)
C 29 FORMAT(/'...SLMASK(101-200,1-190)=:'/(1X,I3,1X,100I1))
C WRITE(6,28)
C WRITE(6,31) (J,(IFIX(SLMASK(I,J)),I=201,300),J=1,190)
C 31 FORMAT(/'...SLMASK(201-300,1-190)=:',/,(1X,I3,1X,100I1))
C WRITE(6,28)
C WRITE(6,33) (J,(IFIX(SLMASK(I,J)),I=301,384),J=1,190)
C 33 FORMAT(/'...SLMASK(301-384,1-190)=:',/,(1X,I3,1X,84I1))
C SET THE COASTAL ERROR FLAG HERE
IECOST=6
RETURN
C-----------------------------------------------------------------------
ENTRY LLCHK(IUNTSL,NTEST,NOKAY,NBAD,IFLLCK,NUMTST,NUMOKA,NUMBAD,
1 ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
WRITE(6,37) NTEST,NOKAY,NBAD
37 FORMAT(//'...ENTERING LLCHK, LOOKING FOR BAD LAT/LON GROUPS. ',
1 'NTEST,NOKAY,NBAD=',3I4/4X,'RECORDS ARE NOT REJECTED ',
2 'HERE AS ERROR RECOVERY IS DONE.'/)
NADD=0
C CHECK ALL RECORDS
DO NREC=1,NTEST
IETYP=0
DO IV=3,4
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NREC))
VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV)
ENDDO
BUFINZ=TSTREC(NREC)
IF(ABS(STMLTZ) .GT. RLATMX .OR. STMLTZ .LT. RLATMN) THEN
IETYP=1
WRITE(6,41) NREC,STMLTZ,NNNREC,ZZZREC,TSTREC(NREC)
41 FORMAT(/'******RECORD #',I3,' HAS LATITUDE OUT OF RANGE, ',
1 'ENCODED LATITUDE IS',F10.2/2(1X,'@@@',A,'@@@'/),4X,A)
ENDIF
IF(ABS(STMLNZ) .GT. RLONMX .OR. STMLNZ .LT. RLONMN) THEN
IETYP=2
WRITE(6,43) NREC,STMLNZ,NNNREC,ZZZREC,TSTREC(NREC)
43 FORMAT(/'******RECORD #',I3,' HAS LONGITUDE OUT OF RANGE, ',
1 'ENCODED LONGITUDE IS',F10.2/2(1X,'@@@',A,'@@@'/),4X,A)
ENDIF
IF(LATNS .EQ. 'S') THEN
STMLTZ=-STMLTZ
ELSE IF(LATNS .NE. 'N') THEN
IETYP=3
IF(STMIDZ(3:3) .EQ. 'L' .OR. STMIDZ (3:3) .EQ. 'E' .OR.
1 STMIDZ(3:3) .EQ. 'C' .OR. STMIDZ (3:3) .EQ. 'W' .OR.
2 STMIDZ(3:3) .EQ. 'O' .OR. STMIDZ (3:3) .EQ. 'T' .OR.
3 STMIDZ(3:3) .EQ. 'B' .OR. STMIDZ (3:3) .EQ. 'A') THEN
LATNS='N'
ELSE
LATNS='S'
ENDIF
WRITE(6,45) NREC,LATNS,NNNREC,ZZZREC,TSTREC(NREC),LATNS,
1 STMIDZ(3:3)
45 FORMAT(/'******RECORD #',I3,' HAS BAD CHARACTER IN LATNS, ',
1 'CHARACTER IS',A1/2(1X,'@@@',A,'@@@')/4X,A/4X,'TEMPORARY',
2 ' ERROR RECOVERY HERE SUBSTITUTES ',A,'DUE TO STORM ',
3 'BASIN=',A)
ENDIF
IF(LONEW .EQ. 'W') THEN
STMLNZ=360.-STMLNZ
ELSE IF(LONEW .NE. 'E') THEN
IETYP=4
IF(STMIDZ(3:3) .EQ. 'W' .OR. STMIDZ (3:3) .EQ. 'O' .OR.
1 STMIDZ(3:3) .EQ. 'T' .OR. STMIDZ (3:3) .EQ. 'U' .OR.
2 STMIDZ(3:3) .EQ. 'S' .OR. STMIDZ (3:3) .EQ. 'B' .OR.
3 STMIDZ(3:3) .EQ. 'A') THEN
LONEW='E'
ELSE
LONEW='W'
ENDIF
WRITE(6,47)NREC,LONEW,NNNREC,ZZZREC,TSTREC(NREC),LONEW,STMIDZ(3:3)
47 FORMAT(/'******RECORD #',I3,' HAS BAD CHARACTER IN LONEW, ',
1 'CHARACTER IS',A1/2(1X,'@@@',A,'@@@')/4X,A/4X,'TEMPORARY ',
2 'ERROR RECOVERY HERE SUBSTITUTES ',A,'DUE TO STORM BASIN=',
3 A)
ENDIF
IFLLCK(NUMTST(NREC))=IETYP
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NREC)
OKAREC(NOKAY)=TSTREC(NREC)
ENDDO
WRITE(6,51) NOKAY,NADD,NTEST,(ERCLL(NER),NER=1,NERCLL)
51 FORMAT(/'...RESULTS OF THE FIRST LAT/LON CHECK ARE: NOKAY=',I4,
1 ' AND NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS. NO ',
2 'RECORDS ARE REJECTED HERE.'//4X,'ERROR CODES ARE:'/(6X,A))
WRITE(6,53)
53 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,59) NOK,NUMOKA(NOK),OKAREC(NOK),IFLLCK(NUMOKA(NOK))
59 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
RETURN
C-----------------------------------------------------------------------
ENTRY SELACK(NTEST,NOKAY,NBAD,IECOST,IFLLCK,NUMTST,NUMOKA,NUMBAD,
1 LNDFIL,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC)
IF(LNDFIL) THEN
WRITE(6,101)
101 FORMAT(///'...ENTERING SELACK. ALL STORMS WITH CIRCULATIONS ',
1 'OVER A GAUSSIAN GRID LAND POINT WILL BE EXCLUDED FROM',
2 ' THE QUALITY '/4X,'CONTROLLED FILE, BUT WILL BE ',
3 'COPIED TO THE SHORT-TERM HISTORY FILE FOR SUBSEQUENT ',
4 'QUALITY CONTROL CHECKS.')
ELSE
WRITE(6,103)
103 FORMAT(///'...ENTERING SELACK. ALL STORMS WITH CIRCULATIONS ',
1 'OVER A LAND-LOCKED GAUSSIAN GRID LAND POINT WILL BE ',
2 'EXCLUDED FROM THE QUALITY '/4X,'CONTROLLED FILE. ALL ',
3 'STORMS OVERLYING COASTAL POINTS WILL BE ACCEPTED.')
END IF
NADD=0
DO NREC=1,NTEST
IETYP=0
DO IV=3,ITERVR
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NREC))
VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV)
ENDDO
BUFINZ=TSTREC(NREC)
IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ
IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ
C CALCULATE MINIMUM/MAXIMUM LAT/LON FOR CIRCLE SURROUNDING
C STORM CENTER. THEN FIND ALL GAUSSIAN GRID POINTS INSIDE
C A BOX. FINALLY TEST ALL THESE POINTS FOR LAND VALUE.
C IF THERE IS A LAND POINT, ELIMINATE THE STORM.
RLTMXZ=STMLTZ+RMAXZ/DEGLAT
RLTMNZ=STMLTZ-RMAXZ/DEGLAT
RLNMXZ=STMLNZ+RMAXZ/(DEGLAT*COSD(STMLTZ))
RLNMNZ=STMLNZ-RMAXZ/(DEGLAT*COSD(STMLTZ))
DO JLAT=1,LATG2
IF(RLAT(JLAT) .LE. RLTMXZ .AND. RLAT(JLAT) .GE. RLTMNZ) THEN
DO ILON=1,LONF
IF(RLON(ILON) .LE. RLNMXZ .AND. RLON(ILON) .GE. RLNMNZ) THEN
DISTZ=DISTSP(STMLTZ,STMLNZ,RLAT(JLAT),RLON(ILON))*1.E-3
IF(DISTZ .LE. RMAXZ .AND. SLMASK(ILON,JLAT) .GT. EPSSL) THEN
C DISTINGUISH BETWEEN LANDLOCKED AND COASTAL POINTS. RECORDS WITH
C LANDLOCKED POINTS WILL BE DISCARDED AND NOT CONSIDERED FURTHER.
C RECORDS WITH COASTAL POINTS WILL EVENTUALLY BE COPIED TO THE
C SHORT-TERM HISTORY FILE FOR FUTURE CHECKS ON THE REPORTED TRACK.
IF(LNDFIL) IETYP=IECOST-1
IF(.NOT. LNDFIL) IETYP=-(IECOST-1)
IF(SLMASK(ILON-1,JLAT ) .LE. EPSSL .OR.
1 SLMASK(ILON+1,JLAT ) .LE. EPSSL .OR.
2 SLMASK(ILON ,JLAT-1) .LE. EPSSL .OR.
3 SLMASK(ILON ,JLAT+1) .LE. EPSSL) THEN
IF(LNDFIL) IETYP=IECOST
IF(.NOT. LNDFIL) IETYP=-IECOST
ENDIF
WRITE(6,127) NREC,RLAT(JLAT),RLON(ILON),STMLTZ,STMLNZ,DISTZ,RMAXZ,
1 IETYP,NNNREC,ZZZREC,TSTREC(NREC)
127 FORMAT(/'******RECORD #',I3,' HAS LAND POINT WITHIN REPORTED ',
1 'STORM CIRCULATION. THE GAUSSIAN LAT, LON=',2F12.4/7X,
2 'ENCODED STORM LAT,LON=',2F12.4,', DISTANCE, RMAXZ, ',
3 'ERROR=',2F8.2,1X,I2/2(1X,'@@@',A,'@@@'/),4X,A)
GO TO 190
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
190 IFLLCK(NUMTST(NREC))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(NREC)
BADREC(NADD+NBAD)=TSTREC(NREC)
ELSE
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NREC)
OKAREC(NOKAY)=TSTREC(NREC)
ENDIF
ENDDO
WRITE(6,201) NOKAY,NADD,NTEST,(ERCLL(NER),NER=1,NERCLL)
201 FORMAT(//'...RESULTS OF THE SEA/LAND CHECK ARE: NOKAY=',I4,' AND',
1 ' NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS.'//4X,
2 'ERROR CODES ARE:'/(6X,A))
WRITE(6,203)
203 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,209) NOK,NUMOKA(NOK),OKAREC(NOK),IFLLCK(NUMOKA(NOK))
209 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
IF(NADD .GT. 0) WRITE(6,211) (NBAD+NBA,NUMBAD(NBAD+NBA),
1 BADREC(NBAD+NBA),
2 IFLLCK(NUMBAD(NBAD+NBA)),
3 NBA=1,NADD)
211 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4,
1 '...',A,'...',I3))
NBAD=NBAD+NADD
RETURN
C-----------------------------------------------------------------------
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: STIDCK CHECKS STORM ID/NAME FOR ALL RECORDS
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2008-07-10
C
C ABSTRACT: CHECKS FOR PROPER STORM ID AND NAME FOR ALL RECORDS.
C AN IMPROPER STORM ID IS GROUNDS FOR REJECTION FOR ALL RECORDS.
C NAME CHECKING IS DONE FOR THE ATLANTIC AND EAST PACIFIC ONLY.
C AN IMPROPER BASIN CODE IS ALSO GROUNDS FOR OUTRIGHT REJECTION.
C AN ATTEMPT AT NAME RECOVERY IS MADE FOR HISTORICAL CASES THAT
C HAVE BEEN RETIRED, E.G. GILBERT (1988) IN THE ATLANTIC.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1992-03-06 S. LORD REVISED TO INCLUDE STMID/STMNAM CHECK
C 1992-07-10 S. LORD REVISED TO DISMANTLE CONSISTENCY CHECKS IN THE
C CASE OF NUMBERED DEPRESSIONS
C 1992-09-09 S. LORD ADDED CENTRAL PACIFIC NAMES AND NAME CHECK
C 1992-10-28 S. J. LORD ADDED GREEK ALPHABET STORM NAMES
C 1993-03-31 S. J. LORD IMPLEMENTED READING STORM NAMES FROM EXTERNAL
C FILE IN STIDCK
C 1993-08-25 S. J. LORD ADDED IUNTCA TO ARGUMENT LIST AND ADDED
C JTWC STORM ID CHECK (NUMBER SAME, DIFFERENT BASIN)
C 2001-02-07 D. A. KEYSER - EXPANDED TEST STORM ID RANGE FROM 90-99
C TO 80-99 AT REQUEST FOR JIM GROSS AT TPC
C 2008-07-10 D. A. KEYSER - CORRECTED MEMORY CLOBBERING CONDITION
C RELATED TO ATTEMPTED STORAGE OF MORE WEST PACIFIC STORM
C NAMES FROM FILE syndat_stmnames (144) THAN ALLOCATED
C BY PROGRAM AND IN syndat_stmnames (140), THIS LED TO
C OVERWRITING OF FIRST FOUR syndat_stmnames STORM NAMES IN
C ATLANTIC BASIN FOR 2002, 2008, 2014 CYCLE - DISCOVERED
C BECAUSE 2008 STORM BERTHA (STORM #2 IN ATLANTIC BASIN
C LIST IN syndat_stmnames) WAS NOT BEING RECOGNIZED AND
C THUS NOT PROCESSED INTO OUTPUT TCVITALS FILE - CORRECTED
C BY LIMITING STORAGE OF WEST PACIFIC STORM NAMES TO
C EXACTLY THE MAXIMUM IN PROGRAM (AND NUMBER IN
C syndat_stmnames) (CURRENTLY 140), ALSO GENERALIZED CODE
C TO ENSURE THAT IS WILL NEVER CLOBBER MEMORY READING AND
C STORING STORM NAMES IN ANY OF THE BASINS EVEN IF THE
C NUMBER OF STORM NAMES IN syndat_stmnames INCREASE (AS
C LONG AS THE MAXIMUM VALUE IS .GE. TO THE NUMBER OF STORM
C NAMES FOR THE BASIN IN FILE syndat_stmnames)
C 2013-10-10 D. C. STOKES - ADDED NON-HYPHNATED CARDINAL NUMBER NAMES
C ALSO EXTENDED THAT LIST (FROM 36 TO 39).
C
C USAGE: CALL STIDCK(IUNTHO,IUNTSN,IUNTCA,NTEST,IYR,MAXREC,NOKAY,
C NBAD,IFSTCK,IDUPID,NUMTST,NUMOKA,NUMBAD,ZZZREC,
C NNNREC,TSTREC,BADREC,OKAREC,SCRATC)
C INPUT ARGUMENT LIST:
C IUNTHO - UNIT NUMBER FOR ORIGINAL SHORT-TERM HISTORY FILE.
C IUNTSN - UNIT NUMBER FOR FILE CONTAINING STORM NAMES
C IUNTCA - UNIT NUMBER FOR STORM CATALOG
C NTEST - NUMBER OF RECORDS TO BE TESTED.
C IYR - CURRENT YEAR (YYYY)
C MAXREC - DIMENSION OF SCRATCH CHARACTER ARRAY
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES.
C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS.
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK.
C IFSTCK - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C IDUPID - SCRATCH ARRAY
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE BLANK CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE BLANK CHECK.
C SCRATC - WORKING CHARACTER ARRAY (DIMENSION MAXREC)
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE STIDCK(IUNTHO,IUNTSN,IUNTCA,NTEST,IYR,MAXREC,NOKAY,
1 NBAD,IFSTCK,IDUPID,NUMTST,NUMOKA,NUMBAD,ZZZREC,
2 NNNREC,TSTREC,BADREC,OKAREC,SCRATC)
PARAMETER (NYEARS=6,NSTMAX=24)
PARAMETER (NNABSN=2)
PARAMETER (NERCID=9)
PARAMETER (NDUPMX=5)
PARAMETER (NSMXCP=48)
PARAMETER (NSMXWP=140)
SAVE
CHARACTER*(*) ZZZREC,NNNREC,TSTREC(0:NTEST),BADREC(MAXREC),
1 OKAREC(NTEST),SCRATC(MAXREC),ERCID(NERCID)*60
CHARACTER*100 DUMY2K
DIMENSION IFSTCK(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC),
1 NUMTST(NTEST),IDUPID(NTEST)
CHARACTER STBASN(NSTMAX,NNABSN,NYEARS)*9,
1 STBAS1(NSTMAX,NNABSN)*9,STBAS2(NSTMAX,NNABSN)*9,
2 STBAS3(NSTMAX,NNABSN)*9,STBAS4(NSTMAX,NNABSN)*9,
3 STBAS5(NSTMAX,NNABSN)*9,STBAS6(NSTMAX,NNABSN)*9,
4 STBACP(NSMXCP)*9,STBAWP(NSMXWP)*9,STNALN*72
INTEGER INDXDP(NDUPMX)
EQUIVALENCE
1 (STBASN(1,1,1),STBAS1(1,1)),(STBASN(1,1,2),STBAS2(1,1)),
2 (STBASN(1,1,3),STBAS3(1,1)),(STBASN(1,1,4),STBAS4(1,1)),
3 (STBASN(1,1,5),STBAS5(1,1)),(STBASN(1,1,6),STBAS6(1,1))
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (NBASIN=11)
PARAMETER (NCRDMX=57)
PARAMETER (NGRKMX=24)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,IDBASN*1,
2 CARDNM*9,GREKNM*9
DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT),
1 ISTVAR(MAXVIT),IENVAR(MAXVIT),ICRDCH(NCRDMX),
2 IGRKCH(NGRKMX)
DIMENSION IDBASN(NBASIN),BUFIN(MAXCHR),FMTVIT(MAXVIT),
1 CARDNM(NCRDMX),GREKNM(NGRKMX)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ)
DIMENSION IVTVRX(MAXVIT)
CHARACTER BUFCK(MAXCHR)*1,RSMCX*4,RELOCX*1,STMIDX*3,STMNMX*9,
1 BUFINX*100
EQUIVALENCE (BUFCK(1),RSMCX),(BUFCK(5),RELOCX),(BUFCK(6),STMIDX),
1 (BUFCK(1),BUFINX),(BUFCK(10),STMNMX)
EQUIVALENCE (IVTVRX(1),IDATEX),(IVTVRX(2),IUTCX)
DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/,
1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/,
5 IFSTFL/19/
DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/
C CARDINAL NUMBER STORM NAMES FOR UNNAMED ATLANTIC AND EAST PACIFIC
C STORMS
DATA CARDNM/'ONE ','TWO ','THREE ',
1 'FOUR ','FIVE ','SIX ',
2 'SEVEN ','EIGHT ','NINE ',
3 'TEN ','ELEVEN ','TWELVE ',
4 'THIRTEEN ','FOURTEEN ','FIFTEEN ',
5 'SIXTEEN ','SEVENTEEN','EIGHTEEN ',
6 'NINETEEN ','TWENTY ','TWENTY-ON',
7 'TWENTY-TW','TWENTY-TH','TWENTY-FO',
8 'TWENTY-FI','TWENTY-SI','TWENTY-SE',
9 'TWENTY-EI','TWENTY-NI','THIRTY ',
O 'THIRTY-ON','THIRTY-TW','THIRTY-TH',
1 'THIRTY-FO','THIRTY-FI','THIRTY-SI',
2 'THIRTY-SE','THIRTY-EI','THIRTY-NI',
3 'TWENTYONE','TWENTYTWO','TWENTYTHR',
4 'TWENTYFOU','TWENTYFIV','TWENTYSIX',
5 'TWENTYSEV','TWENTYEIG','TWENTYNIN',
6 'THIRTYONE','THIRTYTWO','THIRTYTHR',
7 'THIRTYFOU','THIRTYFIV','THIRTYSIX',
8 'THIRTYSEV','THIRTYEIG','THIRTYNIN'/
C GREEK STORM NAMES FOR ATLANTIC AND EAST PACIFIC
C STORMS
DATA GREKNM/'ALPHA ','BETA ','GAMMA ',
1 'DELTA ','EPSILON ','ZETA ',
2 'ETA ','THETA ','IOTA ',
3 'KAPPA ','LAMBDA ','MU ',
4 'NU ','XI ','OMICRON ',
5 'PI ','RHO ','SIGMA ',
6 'TAU ','UPSILON ','PHI ',
7 'CHI ','PSI ','OMEGA '/
DATA ICRDCH/3,3,5,4,4,3,5,5,4,3,6,6,8,8,7,7,9,8,8,10*9,10*9,18*9/
DATA IGRKCH/5,4,5,5,7,4,3,5,4,5,6,2,2,2,7,2,3,5,3,7,3,3,3,5/
DATA NUM/1/,ITWO/2/,ISTIDC/1/,ISTMAX/80/,IPRT/0/ ! CHG. TESTID
DATA ERCID
1 /'1: BAD BASIN CODE ',
2 '2: BAD STORM NUMBER (INCLUDING TEST STORMS WITH NO. 80-99) ',
3 '3: RECORD SUPERCEDED BY LATER ONE (SAME RSMC,D/T,STM ID) ',
4 '4: PROBABLE BAD DATE/TIME CAUSED DUPLICATE RECORD ',
5 '5: BAD STORM NAME (ATL, EPAC, CPAC,WPAC BASINS ONLY) ',
6 '6: STORM IS NOT IN A BASIN DEFINED BY BASNCK ',
7 '7: STORM HAS SAME NAME BUT INCONSISTENT ID ',
8 '8: STORM HAS SAME ID BUT INCONSISTENT NAME ',
9 '9: DUPLICATE RECORD IN ORIGINAL SHORT-TERM HISTORY FILE '/
C ERROR CODES FOR BAD RECORDS RETURNED IN IFSTCK ARE AS FOLLOWS:
C 1: BAD BASIN CODE
C 2: BAD STORM NUMBER (INCLUDING TEST STORMS WITH NO. 80-99)
C 3: RECORD SUPERCEDED BY LATER ONE WITH IDENTICAL RSMC, DATE/TIME
C AND STORM ID
C 4: PROBABLE BAD DATE/TIME CAUSED DUPLICATE RECORD
C 5: BAD STORM NAME (ATL, EPAC BASINS ONLY)
C 6: STORM IS NOT IN A BASIN DEFINED BY BASNCK
C 7: STORM HAS SAME NAME BUT INCONSISTENT ID
C 8: STORM HAS SAME ID BUT INCONSISTENT NAME
C 9: DUPLICATE RECORD IN ORIGINAL SHORT-TERM HISTORY FILE
C STORM TABLES FOR ATLANTIC AND EAST PACIFIC GO ON A SIX-YEAR CYCLE
C STORM NAMES ARE NOW READ IN FROM AN EXTERNAL FILE
WRITE(6,1) NTEST,NOKAY,NBAD
1 FORMAT(//'...ENTERING STIDCK, LOOKING FOR STORM NAMES AND IDS. ',
1 'NTEST,NOKAY,NBAD=',3I4//)
C READ IN STORM NAMES: ATLANTIC AND EAST PACIFIC
WRITE(6,2005)
2005 FORMAT(/'...READING IN STORM NAMES: ATLANTIC AND EAST PACIFIC ')
NSTGRP=NSTMAX/8
IF(MOD(NSTMAX,8).NE.0) NSTGRP = NSTGRP + 1
DO NYR=1,NYEARS
DO NNBA=1,NNABSN
READ(IUNTSN,2007) STNALN
WRITE(6,2007) STNALN
2007 FORMAT(A)
DO NGR=1,NSTGRP
NSTBEG=1+8*(NGR-1)
NSTEND=MIN(8*NGR,NSTMAX)
READ(IUNTSN,2009) (STBASN(NST,NNBA,NYR),NST=NSTBEG,NSTEND)
WRITE(6,2009) (STBASN(NST,NNBA,NYR),NST=NSTBEG,NSTEND)
2009 FORMAT(8A9)
ENDDO
ENDDO
ENDDO
WRITE(6,2105)
2105 FORMAT(/'...READING IN STORM NAMES: CENTRAL PACIFIC ')
NSTGRP=NSMXCP/8
IF(MOD(NSMXCP,8).NE.0) NSTGRP = NSTGRP + 1
READ(IUNTSN,2007) STNALN
WRITE(6,2007) STNALN
DO NGR=1,NSTGRP
NSTBEG=1+8*(NGR-1)
NSTEND=MIN(8*NGR,NSMXCP)
READ(IUNTSN,2009) (STBACP(NST),NST=NSTBEG,NSTEND)
WRITE(6,2009) (STBACP(NST),NST=NSTBEG,NSTEND)
ENDDO
WRITE(6,2205)
2205 FORMAT(/'...READING IN STORM NAMES: WEST PACIFIC ')
NSTGRP=NSMXWP/8
IF(MOD(NSMXWP,8).NE.0) NSTGRP = NSTGRP + 1
READ(IUNTSN,2007) STNALN
WRITE(6,2007) STNALN
DO NGR=1,NSTGRP
NSTBEG=1+8*(NGR-1)
NSTEND=MIN(8*NGR,NSMXWP)
READ(IUNTSN,2009) (STBAWP(NST),NST=NSTBEG,NSTEND)
WRITE(6,2009) (STBAWP(NST),NST=NSTBEG,NSTEND)
ENDDO
C **** IMPORTANT NOTE: THIS SUBROUTINE CURRENTLY CAPTURES STORM
C STORM NAMES FOR THE ATLANTIC AND EAST
C PACIFIC BASINS ONLY.
IF(IYR .GT. 1983) THEN
IYRNAM=MOD(IYR-1983,6)
IF(IYRNAM .EQ. 0) IYRNAM=6
WRITE(6,6) IYRNAM,IYR
6 FORMAT('...INDEX FOR STORM NAME IS:',I4,' IYR=',I6)
ELSE
WRITE(6,7) IYR
7 FORMAT(/'######YEAR=',I5,' IS PRIOR TO 1983. STORM ID CHECK ',
$ 'IS NOT APPLIED')
OKAREC(1:NTEST)=TSTREC(1:NTEST)
NOKAY=NREC
RETURN
ENDIF
WRITE(6,17)
17 FORMAT(/'...THE FOLLOWING RECORDS WILL BE COPIED TO THE SCRATCH ',
1 'ARRAY FOR CHECKING STORM NAME AND ID CONSISTENCY:')
DO NREC=1,NTEST
IDUPID(NREC)=0
SCRATC(NREC)=TSTREC(NREC)
WRITE(6,19) NREC,SCRATC(NREC)
19 FORMAT('...',I3,'...',A)
ENDDO
WRITE(6,21) NTEST
21 FORMAT(/'...',I3,' RECORDS COPIED FROM TSTREC TO THE SCRATCH ',
1 'ARRAY.'/4X,'THE FOLLOWING ORIGINAL SHORT-TERM HISTORY ',
2 'RECORDS WILL BE COPIED TO THE SCRATCH ARRAY:')
C COPY ORIGINAL SHORT-TERM HISTORY RECORDS TO SCRATCH ARRAY.
NCPY=0
REWIND IUNTHO
NCHECK=NTEST+1
30 CONTINUE
READ(IUNTHO,31,END=40) SCRATC(NCHECK)
31 FORMAT(A)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(SCRATC(NCHECK)(35:35).EQ.'N' .OR.
1 SCRATC(NCHECK)(35:35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',SCRATC(NCHECK)(20:21),'"'
PRINT *, ' '
PRINT *, 'From unit ',iuntho,'; SCRATC(NCHECK)-9: ',
$ scratc(ncheck)
PRINT *, ' '
DUMY2K(1:19) = SCRATC(NCHECK)(1:19)
IF(SCRATC(NCHECK)(20:21).GT.'20') THEN
DUMY2K(20:21) = '19'
ELSE
DUMY2K(20:21) = '20'
ENDIF
DUMY2K(22:100) = SCRATC(NCHECK)(20:100)
SCRATC(NCHECK) = DUMY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ SCRATC(NCHECK)(20:23),'" via windowing technique'
PRINT *, ' '
PRINT *, 'From unit ',IUNTHo,'; SCRATC(NCHECK)-9: ',
$ scratc(ncheck)
PRINT *, ' '
ELSE IF(SCRATC(NCHECK)(37:37).EQ.'N' .OR.
1 SCRATC(NCHECK)(37:37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',SCRATC(NCHECK)(20:23),'"'
PRINT *, ' '
PRINT *, 'From unit ',iuntho,'; SCRATC(NCHECK)-9: ',
$ SCRATC(NCHECK)
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 30
END IF
WRITE(6,19) NCHECK,SCRATC(NCHECK)
NCPY=NCPY+1
NCHECK=NCHECK+1
GO TO 30
40 CONTINUE
NCHECK=NCHECK-1
WRITE(6,41) NCPY,NCHECK
41 FORMAT('...',I3,' RECORDS COPIED FOR A TOTAL OF ',I4,' TO BE ',
1 'CHECKED.')
NADD=0
DO NREC=1,NTEST
C INITIALIZE THE CHARACTER STRING AND ERROR CODE
BUFINZ=TSTREC(NREC)
IETYP=0
NDUP =0
C SET THE FLAG FOR ERROR TYPE=4 (PREVIOUS RECORD WITH DUPLICATE
C RSMC, DATE/TIME AND STORM ID APPEARS TO BE VALID)
C RECORDS THAT WERE MARKED ERRONEOUS EARLIER DO NOT RECEIVE
C FURTHER PROCESSING WITH THIS VERSION OF THE CODE.
IF(IDUPID(NREC) .GT. 0) THEN
IETYP=IDUPID(NREC)
GO TO 190
ENDIF
C BASIN CHECK
NIDBSN=999
DO NBA=1,NBASIN
IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN
NIDBSN=NBA
ENDIF
ENDDO
IF(NIDBSN .GT. 130) THEN
IETYP=1
WRITE(6,51) NREC,STMIDZ(3:3),(IDBASN(NBA),NBA=1,NBASIN),NNNREC,
1 ZZZREC,TSTREC(NREC)
51 FORMAT(/'******RECORD #',I3,' HAS BAD BASIN CODE=',A1,'. ALLOWED',
2 ' CODES ARE:',1X,11(A1,1X)/2(1X,'@@@',A,'@@@'/),4X,A)
C CHECK THAT THE LAT/LON CORRESPONDS TO A VALID BASIN
ELSE
DO IV=3,4
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NREC))
VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV)
ENDDO
IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ
IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ
CALL BASNCK(STMIDZ,STMLTZ,STMLNZ,NBAZ,IPRT,IER)
IF(IER .EQ. 3) THEN
IETYP=6
WRITE(6,61) NREC,STMIDZ,STMLTZ,STMLNZ,IETYP,NNNREC,ZZZREC,
1 TSTREC(NREC)
61 FORMAT(/'******RECORD #',I3,' WITH STMID=',A,' HAS LAT/LON ',
1 'OUTSIDE BASIN LIMITS. LAT/LON=',2F9.1,' IETYP=',I3/
2 2(1X,'@@@',A,'@@@'/),4X,A)
ENDIF
ENDIF
IF(IETYP .EQ. 0) THEN
C CHECK CODED STORM ID NUMBER: ID NUMBERS GREATER >= 80 ARE
C CONSIDERED ERRONEOUS. ! CHG. TESTID
CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTORM,IERDEC,'(I2.2)',
1 STMIDZ)
IF(KSTORM .LT. 1 .OR. KSTORM .GE. ISTMAX .OR. IERDEC .NE. 0) THEN
IETYP=2
IF(KSTORM .GE. ISTMAX .AND. KSTORM .LT. 100) THEN
WRITE(6,94) NREC,STMIDZ(ISTIDC:ISTIDC+ITWO-1),NNNREC,ZZZREC,
1 TSTREC(NREC)
94 FORMAT(/'******RECORD #',I3,' HAS TEST STORM NUMBER=',A2,
1 ' -- CONSIDER IT BAD'/2(1X,'@@@',A,'@@@'/),4X,A)
ELSE
WRITE(6,63) NREC,STMIDZ(ISTIDC:ISTIDC+ITWO-1),NNNREC,ZZZREC,
1 TSTREC(NREC)
63 FORMAT(/'******RECORD #',I3,' HAS BAD STORM NUMBER=',A2/
1 2(1X,'@@@',A,'@@@'/),4X,A)
END IF
ENDIF
C CHECK CONSISTENCY BETWEEN STORM NAME AND STORM ID, PRESENT AND
C PAST. FIRST, CHECK FOR EXACT DUPLICATES IN THE INPUT AND
C SHORT-TERM HISTORY FILES.
IF(IETYP .EQ. 0) THEN
DO NCK=NCHECK,NREC+1,-1
BUFINX=SCRATC(NCK)
IF(NCK .GT. NTEST .AND. BUFINZ(1:IFSTFL-1) .EQ.
1 BUFINX(1:IFSTFL-1) .AND.
2 BUFINZ(IFSTFL+1:MAXCHR) .EQ.
3 BUFINX(IFSTFL+1:MAXCHR)) THEN
IETYP=9
WRITE(6,64) NREC,NCK,NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK)
64 FORMAT(/'******RECORD #',I3,' IS IDENTICAL TO RECORD #',I3,
1 ' WHICH IS FROM THE ORIGINAL SHORT-TERM HISTORY FILE.'/4X,
2 'RECORDS ARE:'/2(1X,'@@@',A,'@@@'/),2(4X,A/))
GO TO 71
ENDIF
IF(RSMCX .EQ. RSMCZ) THEN
C DISABLE THE FOLLOWING TWO CHECKS IN THE CASE OF A CARDINAL
C TROPICAL STORM IDENTIFIER
DO NCARD=1,NCRDMX
IF(STMNMZ(1:ICRDCH(NCARD)) .EQ. CARDNM(NCARD)(1:ICRDCH(NCARD))
1 .OR.
2 STMNMX(1:ICRDCH(NCARD)) .EQ. CARDNM(NCARD)(1:ICRDCH(NCARD)))
3 THEN
WRITE(6,1147) STMNMZ(1:ICRDCH(NCARD)),
1 STMNMX(1:ICRDCH(NCARD)),NCARD,ICRDCH(NCARD)
1147 FORMAT(/'...WE HAVE FOUND A MATCHING NAME FOR "',A,'" OR "',A,
1 '" AT CARDINAL INDEX',I3,', FOR CHARACTERS 1-',I2,'.'/4X,
2 'NAME CHECKING IS HEREBY DISABLED.')
GO TO 71
ENDIF
ENDDO
C SAME NAME BUT DIFFERENT ID
IF(STMNMZ .NE. 'NAMELESS' .AND.
1 STMNMZ .EQ. STMNMX .AND. STMIDZ .NE. STMIDX) THEN
IETYP=7
IF(NCK .GT. NTEST) WRITE(6,65) NREC,STMNMZ,STMIDZ,NCK,STMIDX,
1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK)
65 FORMAT(/'******RECORD #',I3,' HAS NAME=',A,' AND ID=',A,', BUT ',
1 'ID IS DIFFERENT FROM VALIDATED ORIGINAL SHORT-TERM ',
2 'HISTORY RECORD',I3/4X,' WHICH IS ',A,'. RECORDS ARE:'/
3 2(1X,'@@@',A,'@@@'/),2(4X,A/))
IF(NCK .LE. NTEST) WRITE(6,66) NREC,STMNMZ,STMIDZ,NCK,STMIDX,
1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK)
66 FORMAT(/'******RECORD #',I3,' HAS NAME=',A,' AND ID=',A,', BUT ',
1 'ID IS DIFFERENT FROM TEST RECORD WITH LARGER INDEX',I3,
2 ' WHICH IS ',A,'.'/4X,'RECORDS ARE:'/2(1X,'@@@',A,'@@@'/),
3 2(4X,A/))
IF(RSMCZ .EQ. 'JTWC' .AND. STMIDZ(1:2) .EQ. STMIDX(1:2)) THEN
IETYP=-7
WRITE(6,165)
165 FORMAT('###OBSERVER IS JTWC. BASIN NOT GUARANTEED TO BE ',
1 'CONSISTENT. IETYP=-7.')
ENDIF
IF(IETYP .GT. 0) GO TO 71
ENDIF
C SAME ID BUT DIFFERENT NAME: NEITHER IS NAMELESS
IF(STMNMZ .NE. 'NAMELESS' .AND. STMNMX .NE. 'NAMELESS') THEN
IF(STMIDZ .EQ. STMIDX .AND. STMNMZ .NE. STMNMX .AND.
1 RELOCZ .EQ. ' ' .AND. RELOCX .EQ. ' ') THEN
IETYP=8
IF(NCK .GT. NTEST) WRITE(6,67) NREC,STMIDZ,STMNMZ,NCK,STMIDX,
1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK)
67 FORMAT(/'******RECORD #',I3,' HAS ID=',A,' AND NAME=',A,', BUT ',
1 'NAME IS DIFFERENT FROM VALIDATED ORIGINAL'/7X,'SHORT-',
2 'TERM HISTORY RECORD',I3,' WHICH IS ',A,'.'/7X,'RECORDS ',
3 'ARE:'/2(1X,'@@@',A,'@@@'/),2(4X,A/))
IF(NCK .LE. NTEST) WRITE(6,68) NREC,STMIDZ,STMNMZ,NCK,STMIDX,
1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK)
68 FORMAT(/'******RECORD #',I3,' HAS ID=',A,' AND NAME=',A,', BUT ',
1 'NAME IS DIFFERENT FROM TEST RECORD WITH LARGER INDEX',I3,
2 ' WHICH IS ',A,'.'/4X,'RECORDS ARE:'/2(1X,'@@@',A,'@@@'/),
3 2(4X,A/))
GO TO 71
ENDIF
ENDIF
ENDIF
ENDDO
71 CONTINUE
ENDIF
C CHECK FOR RECORDS WITH IDENTICAL RSMC, DATE/TIME GROUP AND
C STORM ID. SINCE THE CURRENT RECORD IS FIRST, WE WILL SUPERCEDE
C IT WITH THE LATER RECORD
IF(IETYP .EQ. 0) THEN
DO NCK=NREC+1,NTEST
BUFINX=TSTREC(NCK)
CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTMX,IERDEC,'(I2.2)',
1 STMIDX)
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NREC))
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NCK ))
ENDDO
DO NBA=1,NBASIN
IF(STMIDX(3:3) .EQ. IDBASN(NBA)) THEN
NIDBSX=NBA
GO TO 91
ENDIF
ENDDO
91 IF(RSMCX .EQ. RSMCZ .AND.
1 IDATEX .EQ. IDATEZ .AND.
2 IUTCX .EQ. IUTCZ .AND.
3 NIDBSX .EQ. NIDBSN .AND.
4 KSTMX .EQ. KSTORM) THEN
C ACCUMULATE ALL RECORDS THAT HAVE THE SAME RSMC, DATE/TIME AND
C STORM ID FOR PROCESSING
IF(NDUP .LT. NDUPMX) THEN
NDUP=NDUP+1
INDXDP(NDUP)=NCK
ELSE
WRITE(6,93) RSMCZ,IDATEZ,IUTCZ,STMIDZ,NDUPMX
93 FORMAT(/'******NUMBER OF RECORDS WITH SAME RSMC=',A,', DATE=',I9,
1 ', TIME=',I5,' AND STORM ID=',A/7X,'EXCEEDS THE MAXIMUM=',
2 I3,'. THE PROGRAM WILL TERMINATE!!')
CALL ABORT1('STIDCK ',53)
ENDIF
ENDIF
ENDDO
IF(NDUP .GT. 0) THEN
CALL FIXDUP(IUNTHO,NTEST,NREC,NDUP,INDXDP,TSTREC,ZZZREC,NNNREC,
1 IETYP)
IF(IETYP .EQ. 4) THEN
DO NDU=1,NDUP
WRITE(6,109) NDU,IABS(INDXDP(NDU)),IETYP
109 FORMAT(/'...DUPLICATE RECORD',I3,' WITH INDEX=',I3,' HAS ',
1 'PROBABLE DATE/TIME ERROR=',I3)
IF(INDXDP(NDU) .LT. 0) IDUPID(IABS(INDXDP(NDU)))=IETYP
ENDDO
C CLEAR THE ERROR FLAG FOR THE CURRENT RECORD!!!
IETYP=0
ENDIF
ENDIF
ENDIF
IF(IETYP .EQ. 0) THEN
C SKIP STORM NAME CHECK IF STORM NAME='NAMELESS' OR BASIN IS
C NEITHER ATLANTIC OR EAST PACIFIC
IF(STMNMZ .EQ. 'NAMELESS') THEN
WRITE(6,113) STMNMZ
113 FORMAT(/'...STORM NAME IS ',A9,' SO NO NAME CHECKING WILL BE ',
1 'DONE')
GO TO 190
ENDIF
IF(NIDBSN .LE. 4) THEN
IF(NIDBSN .LE. 2) THEN
NSTBSN=-1
DO NST=1,NSTMAX
IF(STMNMZ .EQ. STBASN(NST,NIDBSN,IYRNAM)) THEN
C WRITE(6,117) STMNMZ,NST,NIDBSN,IYRNAM
C 117 FORMAT(/'...WE HAVE FOUND MATCHING NAME FOR ',A,' AT INDEX=',I4,
C 1 ', FOR NIDBSN,IYRNAM=',2I4)
NSTBSN=NST
GO TO 171
ENDIF
ENDDO
C FOR EAST PACIFIC STORM IDS, CHECK THAT THEY MAY HAVE BEEN NAMED
C IN THE CENTRAL PACIFIC
IF(NIDBSN .EQ. 2) THEN
NSTBSN=-1
DO NST=1,NSMXCP
IF(STMNMZ .EQ. STBACP(NST)) THEN
NSTBSN=NST
GO TO 171
ENDIF
ENDDO
ENDIF
ELSE IF(NIDBSN .EQ. 3) THEN
NSTBSN=-1
DO NST=1,NSMXCP
IF(STMNMZ .EQ. STBACP(NST)) THEN
NSTBSN=NST
GO TO 171
ENDIF
ENDDO
ELSE IF(NIDBSN .EQ. 4) THEN
NSTBSN=-1
DO NST=1,NSMXWP
IF(STMNMZ .EQ. STBAWP(NST)) THEN
NSTBSN=NST
GO TO 171
ENDIF
ENDDO
ENDIF
C CHECK FOR CARDINAL NUMBER IDENTIFIER FOR AS YET UNNAMED STORMS
DO NCARD=1,NCRDMX
IF(STMNMZ(1:ICRDCH(NCARD)) .EQ. CARDNM(NCARD)(1:ICRDCH(NCARD)))
1 THEN
WRITE(6,147) STMNMZ(1:ICRDCH(NCARD)),NCARD,ICRDCH(NCARD)
147 FORMAT(/'...WE HAVE FOUND MATCHING NAME FOR "',A,'" AT CARDINAL ',
1 'INDEX',I3,', FOR CHARACTERS 1-',I2,'.')
NSTBSN=NCARD
GO TO 171
ENDIF
ENDDO
C CHECK FOR GREEK NAMES
DO NGRK=1,NGRKMX
IF(STMNMZ(1:IGRKCH(NGRK)) .EQ. GREKNM(NGRK)(1:IGRKCH(NGRK)))
1 THEN
WRITE(6,157) STMNMZ(1:IGRKCH(NGRK)),NGRK,IGRKCH(NGRK)
157 FORMAT(/'...WE HAVE FOUND MATCHING GREEK NAME FOR "',A,'" AT ',
1 'GREEK INDEX',I3,', FOR CHARACTERS 1-',I2,'.')
NSTBSN=NGRK
GO TO 171
ENDIF
ENDDO
171 IF(NSTBSN .LT. 0) THEN
IETYP=5
WRITE(6,173) NREC,STMNMZ,NIDBSN,IYRNAM,NNNREC,ZZZREC,TSTREC(NREC)
173 FORMAT(/'+++RECORD #',I3,' HAS BAD STORM NAME=',A9,'. NIDBSN,',
1 'IYRNAM=',2I4/4X,'ERROR RECOVERY WILL BE CALLED FOR THIS',
2 ' RECORD:'/2(1X,'@@@',A,'@@@'/),4X,A)
CALL FIXNAM(IUNTCA,NIDBSN,IYR,IETYP,STMNMZ,TSTREC(NREC))
ENDIF
ELSE
WRITE(6,181) IDBASN(NIDBSN),STMNMZ
181 FORMAT('...VALID BASIN ID=',A1,' DOES NOT ALLOW STORM NAME CHECK',
1 ' AT THIS TIME. NAME=',A9)
ENDIF
ENDIF
ENDIF
190 IFSTCK(NUMTST(NREC))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(NREC)
BADREC(NADD+NBAD)=TSTREC(NREC)
ELSE
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NREC)
OKAREC(NOKAY)=TSTREC(NREC)
ENDIF
ENDDO
WRITE(6,201) NOKAY,NADD,NTEST,(ERCID(NER),NER=1,NERCID)
201 FORMAT(//'...RESULTS OF THE STORM ID CHECK ARE: NOKAY=',I4,' AND',
1 ' NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS.'//4X,
2 'ERROR CODES ARE:'/(6X,A))
WRITE(6,203)
203 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,209) NOK,NUMOKA(NOK),OKAREC(NOK),IFSTCK(NUMOKA(NOK))
209 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
IF(NADD .GT. 0) WRITE(6,211) (NBAD+NBA,NUMBAD(NBAD+NBA),
1 BADREC(NBAD+NBA),
2 IFSTCK(NUMBAD(NBAD+NBA)),
3 NBA=1,NADD)
211 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4,
1 '...',A,'...',I3))
NBAD=NBAD+NADD
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FIXDUP ERROR RECOVERY FOR PARTIAL DUPLICATE RECS
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: ERROR RECOVERY FOR PARTIAL DUPLICATE RECORDS. PARTIAL
C DUPLICATE RECORDS ARE DEFINED AS THOSE WITH IDENTICAL RSMC, STORM
C ID & NAME, AND DATE/TIME. THE ERROR RECOVERY PROCEDURE BEGINS BY
C TRYING TO FIND A PREVIOUS RECORD FOR THE TARGET RECORD, WHICH IS
C DEFINED AS THE FIRST OF THE DUPLICATE RECORDS (ALL SUBSEQUENT
C RECORDS ARE DEFINED AS "DUPLICATES"). THE CURRENT RECORDS ARE
C SEARCHED FIRST, THEN THE SHORT-TERM HISTORY FILE IS SEARCHED.
C IF NO PREVIOUS RECORDS ARE FOUND ANYWHERE, THE DEFAULT DECISION IS
C TO KEEP THE LAST OF THE DUPLICATES, UNDER THE ASSSUMPTION THAT
C THE DUPLICATE RECORDS ARE UPDATE RECORDS FOR THE SAME STORM.
C IF A PREVIOUS RECORD IS FOUND, ITS EXTRAPOLATED POSITION IS COMPARED
C WITH THE TARGET RECORD AND THE DUPLICATE RECORDS. IF THE TARGET
C POSITION ERROR IS GREATER THAN THE DUPLICATE POSITION, THE
C TARGET RECORD IS CONSIDERED ERROREOUS. IF THE TARGET POSITION ERROR
C IS LESS THAN THE DUPLICATE POSITION ERROR, THE DUPLICATE POSITION
C IS CHECKED AGAINST AN EXTRAPOLATED FUTURE POSITION. IF THAT ERROR
C IS LESS THAN FOR THE CURRENT POSITION, IT IS ASSUMED THAT THE
C DUPLICATE RECORD HAS A DATE/TIME ERROR. IF THE DUPLICATE POSITION
C ERROR IS LARGER FOR THE FUTURE TIME, IT IS ASSUMED THAT THE
C DUPLICATE RECORD IS AN UPDATE RECORD WHICH SUPERCEDES THE TARGET.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C
C USAGE: CALL FIXDUP(IUNTHO,NTEST,NREC,NDUP,INDXDP,TSTREC,ZZZREC,
C NNNREC,IETYP)
C INPUT ARGUMENT LIST:
C IUNTHO - UNIT NUMBER FOR SHORT-TERM HISTORY FILE.
C NTEST - TOTAL NUMBER OF RECORDS AVAILABLE (DIMENSION OF TSTREC)
C NREC - INDEX NUMBER OF TARGET RECORD
C NDUP - NUMBER OF DUPLICATE RECORDS
C INDXDP - INTEGER ARRAY CONTAINING INDEX NUMBERS OF
C - DUPLICATE RECORDS
C TSTREC - CHARACTER ARRAY OF INPUT RECORDS.
C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES.
C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS.
C
C OUTPUT ARGUMENT LIST:
C IETYP - ERROR CODE
C
C INPUT FILES:
C UNIT 21 - SHORT-TERM HISTORY FILE
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE FIXDUP(IUNTHO,NTEST,NREC,NDUP,INDXDP,TSTREC,ZZZREC,
1 NNNREC,IETYP)
PARAMETER (MAXSTM=70)
SAVE
CHARACTER*(*) TSTREC(0:NTEST),ZZZREC,NNNREC
DIMENSION INDXDP(NDUP)
DIMENSION RINC(5)
CHARACTER STMNAM*9,STMID*3,RSMC*4
LOGICAL FSTFLG
DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
1 STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
2 IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
3 PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
4 R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
5 STMID(MAXSTM),FSTFLG(MAXSTM)
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (NBASIN=11)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,IDBASN*1
DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT),
1 ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION IDBASN(NBASIN),BUFIN(MAXCHR),FMTVIT(MAXVIT)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ),
1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ)
DIMENSION IVTVRX(MAXVIT),VITVRX(MAXVIT)
CHARACTER BUFCK(MAXCHR)*1,RSMCX*4,RELOCX*1,STMIDX*3,LATNSX*1,
1 LONEWX*1,BUFINX*100
EQUIVALENCE (BUFCK(1),RSMCX),(BUFCK(5),RELOCX),(BUFCK(6),STMIDX),
1 (BUFCK(35),LATNSX),(BUFCK(41),LONEWX),
2 (BUFCK(1),BUFINX)
EQUIVALENCE (IVTVRX(1),IDATEX),(IVTVRX(2),IUTCX),
1 (VITVRX(3),STMLTX),(VITVRX(4),STMLNX),
2 (VITVRX(5),STMDRX),(VITVRX(6),STMSPX)
DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/,
1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/
C IPRNT : CONTROLS PRINTING IN SUBROUTINE NEWVIT
C FACSPD: CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)*
C FACSPD
DATA NUM/1/,ITWO/2/,ISTIDC/1/,IPRNT/0/,FACSPD/0.77719/,
1 IHRWIN/0/
WRITE(6,1) NDUP,NTEST,NREC
1 FORMAT(/'...ENTERING FIXDUP WITH ',I3,' DUPLICATE RECORDS AND',I4,
1 ' TOTAL RECORDS. TARGET RECORD TO BE CHECKED HAS INDEX=',
2 I3)
C RECOVER STORM ID, DATE,TIME ETC FROM THE TARGET RECORD
BUFINZ=TSTREC(NREC)
CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTORM,IERDEC,'(I2.2)',
1 STMIDZ)
DO IV=1,6
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
VITVAR(IV)=IVTVAR(IV)*VITFAC(IV)
ENDDO
IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ
IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
WRITE(6,7) BUFINZ,(INDXDP(ND),TSTREC(INDXDP(ND)),ND=1,NDUP)
7 FORMAT('...TARGET RECORD FOR COMPARISON IS:'/10X,A/4X,
1 'DUPLICATE RECORDS ARE:'/(4X,I4,2X,A))
C WRITE(6,9) STMLTZ,STMLNZ,STMDRZ,STMSPZ
C 9 FORMAT('...LAT/LON, DIR/SPD OF TARGET RECORD ARE ',4F10.3)
C CHECK IF THERE ARE ANY PREVIOUS RECORDS IN TSTREC
INDCLO=-99
DTCLO=1.E10
DO NCK=1,NTEST
BUFINX=TSTREC(NCK)
CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTMX,IERDEC,'(I2.2)',
1 STMIDX)
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV),
1 TSTREC(NCK))
ENDDO
DO NBA=1,NBASIN
IF(STMIDX(3:3) .EQ. IDBASN(NBA)) NIDBSX=NBA
IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) NIDBSN=NBA
ENDDO
IF(RSMCX .EQ. RSMCZ .AND.
1 NIDBSX .EQ. NIDBSN .AND.
2 KSTMX .EQ. KSTORM .AND.
3 NCK .NE. NREC ) THEN
CALL ZTIME(IDATEX,IUTCX,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYX)
C WRITE(6,53) NCK,IDATEX,IUTCX,DAYX
C 53 FORMAT('...INDEX,DATE,TIME OF SAME STORM ARE:',I3,I9,I5,F10.3)
IF(DAYX .LT. DAYZ .AND. DAYZ-DAYX .LT. DTCLO) THEN
INDCLO=NCK
DTCLO=DAYZ-DAYX
ENDIF
ENDIF
ENDDO
IF(INDCLO .GT. 0) THEN
BUFINX=TSTREC(INDCLO)
DO IV=3,6
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV),
1 BUFINX)
VITVRX(IV)=IVTVRX(IV)*VITFAC(IV)
ENDDO
IF(LATNSX .EQ. 'S') STMLTX=-STMLTX
IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX
CALL DS2UV(USTM,VSTM,STMDRX,STMSPX)
ELSE
WRITE(6,77) IUNTHO
77 FORMAT(/'...PREVIOUS STORM RECORD COULD NOT BE FOUND IN CURRENT ',
1 'RECORDS. WE WILL LOOK IN THE SHORT-TERM HISTORY FILE, ',
2 'UNIT=',I3)
C SCAN HISTORICAL FILE FOR ALL OCCURRENCES OF EACH STORM.
C SAVE THE LATEST TIME FOR USE LATER.
IOPT=5
IDTREQ=IDATEZ
STMID(1)=STMIDZ
CALL NEWVIT(IUNTHO,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ,
1 IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,
2 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,
3 PTOP,FSTFLG,STMNAM,STMID,RSMC)
IF(KSTORM .GT. 0) THEN
DO KST=1,KSTORM
CALL ZTIME(IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYX)
C WRITE(6,79) KST,DAYX,DAYZ
C 79 FORMAT('...INDEX,DAYX, DAYZ FROM ST. TERM HIST. FILE=',I3,2F10.3)
IF(DAYZ-DAYX .LT. DTCLO) THEN
INDCLO=KST
DTCLO=DAYZ-DAYX
ENDIF
ENDDO
CALL DS2UV(USTM,VSTM,STMDIR(INDCLO),STMSPD(INDCLO))
STMLTX=STMLAT(INDCLO)
STMLNX=STMLON(INDCLO)
ELSE
WRITE(6,97)
97 FORMAT('###PREVIOUS RECORD COULD NOT BE FOUND ANYWHERE. ',
1 'THEREFORE, WE MAKE THE ARBITRARY, BUT NECESSARY DECISION'/
2 4X,'TO RETAIN THE LAST DUPLICATE RECORD.')
IETYP=3
WRITE(6,99) NREC,INDXDP(NDUP),NNNREC,ZZZREC,TSTREC(NREC),
1 TSTREC(INDXDP(NDUP))
99 FORMAT(/'******RECORD #',I3,' WILL BE SUPERCEDED BY RECORD #',I3,
1 ', WHICH ARRIVED LATER AND HAS IDENTICAL RSMC, DATE/TIME',
2 ' AND STORM ID'/2(1X,'@@@',A,'@@@'/),2(4X,A/))
RETURN
ENDIF
ENDIF
C SAVE THE PREVIOUS FIX POSITION AND EXTRAPOLATE IT
C TO THE CURRENT TIME
PRVLAT=STMLTX
PRVLON=STMLNX
EXTLAT=PRVLAT+VSTM*DTCLO*FACSPD
EXTLON=PRVLON+USTM*DTCLO*FACSPD
EXTERZ=DISTSP(STMLTZ,STMLNZ,EXTLAT,EXTLON)*1.E-3
WRITE(6,95) STMLTZ,STMLNZ,EXTERZ
95 FORMAT(/'...LAT/LON,EXTRAPOLATION ERROR FOR RECORDS ARE:'/4X,
1 'TARGET:',9X,3F10.3)
DO NDU=1,NDUP
BUFINX=TSTREC(INDXDP(NDU))
DO IV=3,4
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV),
1 BUFINX)
VITVRX(IV)=IVTVRX(IV)*VITFAC(IV)
ENDDO
IF(LATNSX .EQ. 'S') STMLTX=-STMLTX
IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX
EXTERD=DISTSP(STMLTX,STMLNX,EXTLAT,EXTLON)*1.E-3
WRITE(6,111) NDU,STMLTX,STMLNX,EXTERD
111 FORMAT('...DUP. RECORD:',I4,3F10.3)
IF(EXTERD .GT. EXTERZ) THEN
EXTLT2=PRVLAT+VSTM*DTCLO*FACSPD*2.0
EXTLN2=PRVLON+USTM*DTCLO*FACSPD*2.0
EXTER2=DISTSP(STMLTX,STMLNX,EXTLT2,EXTLN2)*1.E-3
WRITE(6,113) NDU,EXTLT2,EXTLN2,EXTER2
113 FORMAT('...2XDT EXTRAP:',I4,3F10.3)
C IF THE DIFFERENCE BETWEEN THE DUPLICATE POSITION AND
C AN EXTRAPOLATED POSITION TO A FUTURE CYCLE IS LESS
C THAN THE DIFFERENCE AT THE CURRENT TIME, WE ASSUME
C THAT THE DUPLICATE HAS A BAD DATE/TIME, I.E. THAT IT
C IS VALID A A LATER TIME. CURRENTLY THERE IS NO ERROR
C RETRIEVAL FOR THE DATE/TIME GROUP SO THAT THIS RECORD
C IS MARKED TO BE IN ERROR BY MAKING THE INDEX NEGATIVE.
IF(EXTER2 .LT. EXTERD) THEN
IETYP=4
INDXDP(NDU)=-INDXDP(NDU)
WRITE(6,117) IETYP,INDXDP(NDU)
117 FORMAT(/'...DUPLICATE HAS DIFFERENCE WITH EXTRAPOLATED POSITION ',
1 'TO FUTURE TIME THAT IS LESS THAN FOR CURRENT TIME.'/4X,
2 'THEREFORE, WE CONCLUDE THAT THERE IS A DATE/TIME ERROR ',
3 'IN THE DUPLICATE RECORD (IETYP=',I3,').'/4X,'THE INDEX=',
4 I3,' IS MARKED NEGATIVE TO INDICATE AN ERROR.')
ELSE
IETYP=3
WRITE(6,119) NREC,INDXDP(NDUP),NNNREC,ZZZREC,TSTREC(NREC),
1 TSTREC(INDXDP(NDUP))
119 FORMAT(/'...DUPLICATE HAS DIFFERENCE WITH EXTRAPOLATED FUTURE ',
1 'POSITION GREATER THAN THAT FOR CURRENT POSITION.'/
2 ' ******RECORD #',I3,' WILL BE SUPERCEDED BY RECORD #',I3,
3 ', WHICH ARRIVED LATER AND HAS IDENTICAL RSMC, DATE/TIME',
4 ' AND STORM ID'/2(1X,'@@@',A,'@@@'/),2(4X,A/))
ENDIF
ELSE
IETYP=3
WRITE(6,121) NREC,INDXDP(NDUP),NNNREC,ZZZREC,TSTREC(NREC),
1 TSTREC(INDXDP(NDUP))
121 FORMAT(/'...DUPLICATE HAS DIFFERENCE WITH EXTRAPOLATED PAST ',
1 'POSITION LESS THAN OR EQUAL TO THAT FOR TARGET.'/
2 ' ******RECORD #',I3,' WILL BE SUPERCEDED BY RECORD #',I3,
3 ', WHICH ARRIVED LATER AND HAS IDENTICAL RSMC, DATE/TIME',
4 ' AND STORM ID'/2(1X,'@@@',A,'@@@'/),2(4X,A/))
ENDIF
ENDDO
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FIXNAM NAME RECOVERY FOR SYNDAT_QCTROPCY
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: ERRONEOUS STORM NAMES ARE CHECKED FOR OLD (RETIRED) STORM
C NAMES (ATLANTIC BASIN ONLY). IF A RETIRED NAME MATCHES THE
C INPUT STORM NAME, ERROR RECOVERY IS SUCCESSFUL. SEE REMARKS BELOW.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1993-08-25 S. LORD ADDED CATALOG CHECKING FOR STORM IDS
C
C USAGE: CALL FIXNAM(IUNTCA,NIDBSN,IYRN,IETYP,STMNAM,DUMREC)
C INPUT ARGUMENT LIST:
C IUNTCA - STORM CATALOG UNIT NUMBER
C NIDBSN - BASIN INDEX
C IYRN - 4 DIGIT YEAR OF STORM (YYYY)
C IETYP - INPUT ERROR CODE (SHOULD BE POSITIVE)
C STMNAM - CHARACTER VARIABLE CONTAINING ERRONEOUS STORM NAME
C
C OUTPUT ARGUMENT LIST:
C IETYP - SIGN OF INPUT IETYP IS CHANGED TO NEGATIVE IF
C - RECOVERY IS SUCCESSFUL
C DUMREC - CHARACTER VARIABLE CONTAINING ENTIRE INPUT DATA RECORD
C - WITH CORRECTED NAME.
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE FIXNAM(IUNTCA,NIDBSN,IYRN,IETYP,STMNAM,DUMREC)
PARAMETER (NRETIR= 7)
SAVE
CHARACTER*(*) STMNAM,DUMREC
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (NBASIN=11)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,NABASN*16
DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION NABASN(NBASIN),BUFIN(MAXCHR),FMTVIT(MAXVIT)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
CHARACTER RETNAM(NRETIR,NBASIN)*9
DIMENSION IRETYR(NRETIR,NBASIN),NUMRET(NBASIN)
DIMENSION RINC(5)
DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA NABASN/'ATLANTIC ','EAST PACIFIC ',
1 'CENTRAL PACIFIC ','WEST PACIFIC ',
2 'SOUTH CHINA SEA ','EAST CHINA SEA ',
3 'AUSTRALIA ','SOUTH PACIFIC ',
4 'SOUTH INDIAN OCN','BAY OF BENGAL ',
5 'NRTH ARABIAN SEA'/
DATA RETNAM/'GILBERT ','JOAN ','HUGO ','GLORIA ',
1 'DIANA ','BOB ','ANDREW ',70*' '/
DATA IRETYR/1988,1988,1989,1985,1990,1991,1992,
1 70*00/
DATA NUMRET/7,1,9*0/,DYSPMX/2.0/
RETNAM(1,2)='INIKI'
IRETYR(1,2)=1992
BUFINZ=DUMREC
DO INUM=1,NUMRET(NIDBSN)
IF(STMNAM .EQ. RETNAM(INUM,NIDBSN) .AND.
1 IYRN .EQ. IRETYR(INUM,NIDBSN)) THEN
WRITE(6,3) NABASN(NIDBSN),STMNAM,IYRN
3 FORMAT(/'...SUCESSFUL RECOVERY OF STORM NAME FROM RETIRED STORM ',
1 'NAMES OF THE ',A,'. NAME, YEAR=',A,1X,I5)
STMNMZ=STMNAM
DUMREC=BUFINZ
IETYP=-IETYP
RETURN
ENDIF
ENDDO
C LOOK FOR NAME IN STORM CATALOG. IF THERE, CHECK THAT IT IS A
C RECENT STORM. IF SO, ASSUME THAT THE STORM ID IS OK.
CALL STCATN(IUNTCA,STMNAM,IDATCA,IUTCCA,IFND)
IF(IFND .EQ. 0) THEN
WRITE(6,101) STMNAM
101 FORMAT(/'...UNSUCESSFUL ATTEMPT TO RECOVER STORM NAME ...',A,
1 '... HAS OCCURRED.')
ELSE
C NOW CHECK DATE VERSUS SUBJECT RECORD
do iv=1,2
call decvar(istvar(iv),ienvar(iv),ivtvar(iv),ierdec,fmtvit(iv),
1 bufinz)
enddo
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
CALL ZTIME(IDATCA,IUTCCA,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYCA)
WRITE(6,133) IDATEZ,IUTCZ,IDATCA,IUTCCA,DAYZ,DAYCA
133 FORMAT('...COMPARING DATES BETWEEN RECORD AND CATALOG. IDATEZ, ',
1 'IUTCZ=',I9,I5,' IDATCA,IUTCCA=',I9,I5/4X,'DAYZ,DAYCA=',
2 2F12.3)
IF(ABS(DAYZ-DAYCA) .GT. DYSPMX) RETURN
IETYP=-IETYP
WRITE(6,201) STMNAM
201 FORMAT(/'...SUCESSFUL ATTEMPT TO RECOVER STORM NAME ...',A,
1 '... HAS OCCURRED.')
ENDIF
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: SECVCK SECONDARY VARIABLE Q/C CHECKING
C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01
C
C ABSTRACT: SECONDARY VARIABLES ARE: STORM DIRECTION AND SPEED,
C PCEN (CENTRAL PRESSURE), RMAX (RADIUS OF THE OUTERMOST CLOSED
C ISOBAR), PENV (PRESSURE AT RMAX), AND VMAX (MAXIMUM WIND SPEED).
C THIS ROUTINE CHECKS FOR MISSING AND OUT OF BOUNDS VALUES.
C FOR RMAX, PENV, AND VMAX, VALUES ARE SUBSTITUTED FROM THE LATEST
C HISTORICAL Q/C CHECKED RECORD IF THAT RECORD IS NO MORE THAN 12
C HOURS OLD.
C
C PROGRAM HISTORY LOG:
C 1990-11-01 S. LORD
C 1991-11-17 S. LORD REVISED FOR MULTIPLE ERRORS
C 1992-08-20 S. LORD ADDED THE JTWC MEMORIAL SWITCH CHECK
C 1992-09-04 S. LORD ADDED PRESSURE WIND RELATIONSHIP
C
C USAGE: CALL SECVCK(IUNTOK,NTEST,NOKAY,NBAD,NUMTST,NUMOKA,NUMBAD,
C DAY0,DAYMIN,DAYMX1,DAYOFF,IFSECV,ZZZREC,NNNREC,
C SCRREC,TSTREC,BADREC,OKAREC)
C INPUT ARGUMENT LIST:
C IUNTOK - UNIT NUMBER FOR PRELIMINARY QUALITY CONTROLLED FILE.
C NTEST - NUMBER OF RECORDS TO BE TESTED.
C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD
C - TO BE TESTED.
C DAY0 - DATE AT WHICH THIS Q/C CHECK IS BEING MADE.
C - UNITS ARE DDD.FFF, WHERE DDD=JULIAN DAY, FFF=FRAC-
C - TIONAL DAY (E.G. .5=1200 UTC).
C DAYMIN - EARLIEST (MINIMUM) DATE FOR CONSTRUCTION OF A
C - HISTORICAL TRACK FOR EACH STORM.
C - UNITS SAME AS DAY0 ABOVE.
C DAYMX1 - LATEST (MAXIMUM) DATE FOR CONSTRUCTION OF HISTORICAL
C - TRACK FOR EACH STORM. UNITS ARE SAME AS DAY0 ABOVE.
C DAYOFF - OFFSET ADDED TO DAYMX1 IF DAYMIN REFERS TO THE YEAR
C - BEFORE DAYMX1.
C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES.
C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS.
C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED.
C
C OUTPUT ARGUMENT LIST:
C NOKAY - NUMBER OF RECORDS THAT PASSED THE SEC. VAR. CHECK.
C NBAD - NUMBER OF RECORDS THAT FAILED THE SEC. VAR. CHECK.
C IFSECV - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT
C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES.
C SCRREC - SCRATCH CHARACTER*9 ARRAY
C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD
C - RECORD.
C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD
C - RECORD.
C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED
C - THE SEC. VAR. CHECK.
C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED
C - THE SEC. VAR. CHECK.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: WARNING: RECORDS WITH CORRECT FORMAT BUT MISSING OR
C ERRONEOUS DATA MAY BE MODIFIED BY THIS ROUTINE!!
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE SECVCK(IUNTOK,NTEST,NOKAY,NBAD,NUMTST,NUMOKA,NUMBAD,
1 DAY0,DAYMIN,DAYMX1,DAYOFF,IFSECV,ZZZREC,NNNREC,
2 SCRREC,TSTREC,BADREC,OKAREC)
PARAMETER (NPRVMX=61)
PARAMETER (MAXSTM=70)
PARAMETER (NERCSV=9)
PARAMETER (MAXREC=1000)
SAVE
CHARACTER*(*) ZZZREC,NNNREC,SCRREC(0:NTEST),TSTREC(0:NTEST),
1 BADREC(MAXREC),OKAREC(NTEST),ERCSV(NERCSV)*60,
2 STDPTP(-NPRVMX:-1)*1,SUBTOP*1,SUBFLG*1
LOGICAL NEWSTM
DIMENSION NUMOKA(NTEST),IFSECV(MAXREC),NUMBAD(MAXREC),
1 NUMTST(NTEST)
DIMENSION NUMSTM(MAXSTM),INDXST(MAXSTM,MAXSTM),IOPSTM(MAXSTM),
1 SRTDAY(MAXSTM,MAXSTM),IDASRT(MAXSTM)
DIMENSION STLATP(-NPRVMX:-1),STLONP(-NPRVMX:-1),
1 STDAYP(-NPRVMX: 0),STVMXP(-NPRVMX:-1),
2 STDIRP(-NPRVMX:-1),STSPDP(-NPRVMX:-1),
3 STPCNP(-NPRVMX:-1),STPENP(-NPRVMX:-1),
4 STRMXP(-NPRVMX:-1)
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (MAXTPC= 3)
PARAMETER (NBASIN=11)
PARAMETER (ISECVR= 5,ITERVR=10)
PARAMETER (NSECVR=ITERVR-ISECVR)
PARAMETER (NTERVR=MAXVIT-ITERVR+1)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 SHALO*1,MEDIUM*1,DEEP*1,LATNS*1,LONEW*1,FMTVIT*6,
2 BUFINZ*100,STMREQ*9,RELOCZ*1,STMTPC*1,EXE*1,NAMVAR*5,
3 IDBASN*1,NABASN*16
DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT),
1 ISTVAR(MAXVIT),IENVAR(MAXVIT)
DIMENSION NAMVAR(MAXVIT+1),IDBASN(NBASIN),NABASN(NBASIN),
1 BUFIN(MAXCHR),STMTPC(0:MAXTPC),FMTVIT(MAXVIT)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ),
1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ),
2 (VITVAR( 7),PCENZ)
EQUIVALENCE (STMTPC(0), EXE),(STMTPC(1),SHALO),(STMTPC(2),MEDIUM),
1 (STMTPC(3),DEEP)
C **** NOTE: SECBND AND PRVSVR ARE DIMENSIONED NSECVR+1 TO CARRY
C SPACE FOR VMAX, WHICH IS NOT STRICTLY A SECONDARY VARIABLE.
C THEREFORE, WE DO NOT ALLOW MISSING OR ERRONEOUS VALUES
C OF VMAX TO CAUSE RECORDS TO BE REJECTED.
C ****NOTE: DEPTH OF CYCLONIC CIRCULATION IS CLASSIFIED AS A
C SECONDARY VARIABLE
DIMENSION RINC(5)
DIMENSION SECBND(NSECVR+1,2),PRVSVR(NSECVR+1,-NPRVMX:-1),
1 TERBND(NTERVR,2),IERROR(NSECVR+2)
EQUIVALENCE (DIRMN ,SECBND(1,1)),(DIRMX ,SECBND(1,2)),
1 (SPDMN ,SECBND(2,1)),(SPDMX ,SECBND(2,2)),
2 (PCENMN,SECBND(3,1)),(PCENMX,SECBND(3,2)),
3 (PENVMN,SECBND(4,1)),(PENVMX,SECBND(4,2)),
4 (RMAXMN,SECBND(5,1)),(RMAXMX,SECBND(5,2)),
5 (VMAXMN,TERBND(1,1)),(VMAXMX,TERBND(1,2))
DATA SHALO/'S'/,MEDIUM/'M'/,DEEP/'D'/,EXE/'X'/,
1 VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/,
2 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
3 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
4 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
5 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/
DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/
DATA NABASN/'ATLANTIC ','EAST PACIFIC ',
1 'CENTRAL PACIFIC ','WEST PACIFIC ',
2 'SOUTH CHINA SEA ','EAST CHINA SEA ',
3 'AUSTRALIA ','SOUTH PACIFIC ',
4 'SOUTH INDIAN OCN','BAY OF BENGAL ',
5 'NRTH ARABIAN SEA'/
DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED',
1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE',
2 'R15SE','R15SW','R15NW','DEPTH'/
C RMISPR: MISSING CODE FOR RMAX, PCEN AND PENV
C RMISV: MISSING CODE FOR MAX. TANGENTIAL WIND (VMAX)
C EPSMIS: TOLERANCE FOR MISSING VMAX
C FIVMIN: FIVE MINUTES IN UNITS OF FRACTIONAL DAYS
C DTPERS: MAXIMUM TIME SEPARATION FOR SUBSTITUTION OF MISSING
C SECONDARY INFORMATION USING PERSISTENCE (12 HOURS)
C BOUNDS FOR SECONDARY VARIABLES:
C DIRMN =0.0 DEG DIRMX =360 DEG
C SPDMN =0.0 M/S SPDMX =30 M/S
C PCENMN=880 MB PCENMX=1020 MB
C PENVMN=970 MB PENVMX=1050 MB
C RMAXMN=100 KM RMAXMX=999 KM
C VMAXMN=7.7 M/S VMAXMX=100 M/S
DATA RMISV/-9.0/,RMISPR/-999.0/,EPSMIS/1.E-1/,NUM/1/,
1 FIVMIN/3.4722E-3/,DTPERS/0.5/
DATA DIRMN/0.0/,DIRMX/360./,SPDMN/0.0/,SPDMX/30./,
1 PCENMN/880./,PCENMX/1020./,PENVMN/970./,PENVMX/1050./,
2 RMAXMN/100./,RMAXMX/999.0/,VMAXMN/7.7 /,VMAXMX/100./
DATA ERCSV
1 /'1: UNPHYSICAL OR MISSING DIRECTION (OUTSIDE BOUNDS) ',
2 '2: UNPHYSICAL OR MISSING SPEED (OUTSIDE BOUNDS) ',
3 '3: UNPHYSICAL OR MISSING CENTRAL PRESSURE (OUTSIDE BOUNDS) ',
4 '4: UNPHYSICAL OR MISSING ENV. PRESSURE (OUTSIDE BOUNDS) ',
5 '5: UNPHYSICAL OR MISSING RMAX (OUTSIDE BOUNDS) ',
6 '6: UNPHYSICAL OR MISSING VMAX (OUTSIDE BOUNDS) ',
7 '7: MISSING OR UNINTERPRETABLE DEPTH OF CYCLONE CIRCULATION ',
8 '8: COMBINATION OF TWO OF THE ERROR TYPES 1-6 ',
9 '9: COMBINATION OF THREE OR MORE OF THE ERROR TYPES 1-6 '/
C ERROR CODES FOR DIRECTION/SPEED GROUP CHECK ARE AS FOLLOWS:
C NEGATIVE NUMBERS INDICATE THAT AN ERRONEOUS OR MISSING VALUE
C WAS SUBSTITUTED USING PERSISTENCE OVER THE TIME DTPERS (12 H)
C MULTIPLE ERRORS ARE HANDLED AS FOLLOWS:
C THE FIRST ERROR OCCUPIES THE LEFT-MOST DIGIT
C THE SECOND ERROR OCCUPIES THE RIGHT-MOST DIGIT
C THREE OR MORE ERRORS REVERTS TO ERROR CODE=9
C 1: UNPHYSICAL DIRECTION (OUTSIDE BOUNDS)
C 2: UNPHYSICAL SPEED (OUTSIDE BOUNDS)
C 3: UNPHYSICAL CENTRAL PRESSURE (OUTSIDE BOUNDS)
C 4: UNPHYSICAL ENVIRONMENTAL PRESSURE (OUTSIDE BOUNDS)
C 5: UNPHYSICAL RMAX (OUTSIDE BOUNDS)
C 6: UNPHYSICAL VMAX (OUTSIDE BOUNDS)
C 7: MISSING OR UNINTERPRETABLE DEPTH OF CYCLONE CIRCULATION
C 8: COMBINATION OF TWO OF THE ERROR TYPES 1-6
C 9: COMBINATION OF THREE OR MORE OF THE ERROR TYPES 1-6
NADD=0
WRITE(6,1) NTEST,NOKAY,NBAD,DAY0,DAYMIN,DAYMX1,
1 DAYOFF
1 FORMAT(//'...ENTERING SECVCK TO CHECK SECONDARY VARIABLE ERRORS.',
1 ' NTEST,NOKAY,NBAD=',3I4/4X,'TIME PARAMETERS ARE: DAY0,',
2 'DAYMIN,DAYMX1,DAYOFF=',4F11.3///)
CALL WRNING('SECVCK')
C INITIALIZE SOME VARIABLES
NUNI=0
NSTART=0
SCRREC(0)='ZZZZZ'
STDAYP(0)=-999.0
SECBND(6,1:2)=TERBND(1,1:2)
NUMSTM(1:MAXSTM)=0
INDXST(1:MAXSTM,1:MAXSTM)=0
C FOR THE READABLE RECORDS, FIND THE UNIQUE STORMS AND SAVE THE
C INDEX FOR EACH STORM
WRITE(6,31)
31 FORMAT(/'...RECORDS THAT WILL BE CHECKED ARE:'/)
DO NREC=1,NTEST
BUFINZ=TSTREC(NREC)
WRITE(6,33) NREC,NUMTST(NREC),BUFINZ
33 FORMAT('...',I4,'...',I4,'...',A)
C DECODE DATE FOR SORTING PURPOSES
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
ENDDO
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
C CATEGORIZE ALL STORMS BY THEIR STORM ID
IOPT=5
STMREQ=STMIDZ
C ENDIF
NEWSTM=.TRUE.
DO NR=NSTART,NUNI
IF(STMREQ .EQ. SCRREC(NR)) THEN
NEWSTM=.FALSE.
INDX=NR
GO TO 85
ENDIF
ENDDO
85 NSTART=1
IF(NEWSTM) THEN
NUNI=NUNI+1
SCRREC(NUNI)=STMREQ
IOPSTM(NUNI)=IOPT
INDX=NUNI
ENDIF
NUMSTM(INDX)=NUMSTM(INDX)+1
INDXST(NUMSTM(INDX),INDX)=NREC
SRTDAY(NUMSTM(INDX),INDX)=DAYZ
ENDDO
WRITE(6,101) NUNI
101 FORMAT(/'...NUMBER OF UNIQUE STORMS=',I4)
C CHECK SECONDARY VARIABLES DIRECTION,SPEED, PCEN, PENV, RMAX
C VMAX AND STORM DEPTH FOR MISSING AND OUT OF BOUNDS VALUES
DO NUNIQ=1,NUNI
BUFINZ=TSTREC(INDXST(1,NUNIQ))
CALL DECVAR(ISTVAR(1),IENVAR(1),IVTVAR(1),IERDEC,FMTVIT(1),
1 BUFINZ)
print *, ' '
print *, ' '
IDTTRK=-IDATEZ
CALL SETTRK(IUNTOK,IOPSTM(NUNIQ),IDTTRK,DAY0,DAYMIN,
1 DAYMX1,DAYOFF,STMDRZ,STMSPZ,STMLTZ,STMLNZ,
2 SCRREC(NUNIQ),IERSET)
CALL PRVSTM(STLATP,STLONP,STDIRP,STSPDP,STDAYP,
1 STRMXP,STPCNP,STPENP,STVMXP,STDPTP,KSTPRV)
PRVSVR(1,-1:-KSTPRV:-1)=STDIRP(-1:-KSTPRV:-1)
PRVSVR(2,-1:-KSTPRV:-1)=STSPDP(-1:-KSTPRV:-1)
PRVSVR(3,-1:-KSTPRV:-1)=STPCNP(-1:-KSTPRV:-1)
PRVSVR(4,-1:-KSTPRV:-1)=STPENP(-1:-KSTPRV:-1)
PRVSVR(5,-1:-KSTPRV:-1)=STRMXP(-1:-KSTPRV:-1)
PRVSVR(6,-1:-KSTPRV:-1)=STVMXP(-1:-KSTPRV:-1)
C SORT ALL RECORDS BY TIME FOR EACH STORM SO THAT WE CAN TAKE
C THEM IN CHRONOLOGICAL ORDER
CALL SORTRL(SRTDAY(1:NUMSTM(NUNIQ),NUNIQ),IDASRT(1:NUMSTM(NUNIQ)),
1 NUMSTM(NUNIQ))
WRITE(6,107) KSTPRV,SCRREC(NUNIQ)
107 FORMAT(/'...READY FOR ERROR CHECK WITH KSTPRV, STMID=',I3,1X,A)
DO NUMST=1,NUMSTM(NUNIQ)
C INITIALIZE ERROR COUNTERS
NTOTER=0
NPOSER=0
IERROR(1:NSECVR+2)=0
NREC=INDXST(IDASRT(NUMST),NUNIQ)
BUFINZ=TSTREC(NREC)
C GET DATE/TIME, STORM LAT/LON, AND THE SECONDARY
C VARIABLES DIRECTION/SPEED, PCEN, PENV, RMAX
C ****NOTE: ALTHOUGH NOT STRICTLY A SECONDARY VARIABLE, VMAX
C IS CHECKED HERE SINCE IT IS NEEDED FOR CLIPER.
DO IV=1,ITERVR
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV)
ENDDO
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
JDY=IFIX(DAYZ)
INDX00=99
DO NP=-1,-KSTPRV,-1
IF(ABS(STDAYP(NP)-DAYZ) .LE. FIVMIN) INDX00=NP
ENDDO
IF(ABS(DAYZ-DAY0) .LT. FIVMIN) INDX00=0
IF(INDX00 .EQ. 99) THEN
WRITE(6,133) INDX00
133 FORMAT(/'******AN INDEXING ERROR HAS OCCURRED IN SECVCK, INDX00=',
1 I4)
CALL ABORT1('SECVCK ',133)
ENDIF
C ERROR RECOVERY FROM PERSISTENCE IS ALWAYS POSSIBLE. RECOVERY
C FROM CLIMATOLOGY IS POSSIBLE FOR ENVIRONMENTAL PRESSURE AND
C STORM SIZE.
C THE JMA MEMORIAL DIRECTION/SPEED CHECK IS NOW IMPLEMENTED:
C IF BOTH DIRECTION AND SPEED ARE ZERO, AND THE RSMC IS JMA,
C WE TRY TO RECOVER A BETTER DIRECTION/SPEED.
DO IV=ISECVR,ITERVR
RMISVR=RMISPR
SUBVAR=-99.0
IF(IV .EQ. ITERVR) RMISVR=RMISV
IF(ABS(VITVAR(IV)-RMISVR) .LE. EPSMIS .OR.
1 VITVAR(IV) .LT. SECBND(IV-ISECVR+1,1) .OR.
2 VITVAR(IV) .GT. SECBND(IV-ISECVR+1,2) .OR.
3 (IV-ISECVR+1 .LE. 2 .AND. VITVAR(5) .EQ. 0.0 .AND.
4 VITVAR(6) .EQ. 0.0 .AND. (RSMCZ .EQ. 'JMA' .OR.
5 RSMCZ .EQ. '!WJ' .OR. RSMCZ .EQ. '!JW'))) THEN
NTOTER=NTOTER+1
IF(IV-ISECVR+1 .EQ. 3) THEN
NPOSER=NPOSER+1
IERROR(NTOTER)=IABS(IV-ISECVR+1)
ELSE
IERROR(NTOTER)=-IABS(IV-ISECVR+1)
ENDIF
WRITE(6,141) NUNIQ,NUMST,INDX00,DAYZ,NTOTER,IERROR(NTOTER),
1 NAMVAR(IV),VITVAR(IV),RMISVR,SECBND(IV-ISECVR+1,1),
2 SECBND(IV-ISECVR+1,2),NNNREC,ZZZREC,TSTREC(NREC)
141 FORMAT(//'...ERROR CHECKING NUNIQ,NUMST,INDX00,DAYZ,NTOTER,',
1 'IERROR=',3I4,F11.3,2I4/4X,'HAS FOUND SECONDARY ',
2 'VARIABLE ',A,' WITH VALUE=',F7.1,' MISSING OR ',
3 'EXCEEDING BOUNDS. RMISVR,MINVAL,MAXVAL=',3F7.1/2(1X,
4 '@@@',A,'@@@'/),4X,A)
C NEGATE THE ERROR FLAG SO THAT IT SERVES ONLY AS A REMINDER THAT
C AN ERROR IS PRESENT
IF(IV-ISECVR+1 .LE. 2 .AND.
1 ((VITVAR(5) .NE. 0.0 .OR.
2 VITVAR(6) .NE. 0.0) .OR. (RSMCZ .NE. 'JMA' .AND.
3 RSMCZ .NE. '!WJ' .AND. RSMCZ .NE. '!JW'))) THEN
WRITE(6,151) NAMVAR(IV),IERROR(NTOTER)
151 FORMAT('...ERROR RECOVERY FOR ',A,' WILL BE DELAYED UNTIL DRSPCK',
1 ' (NO LONGER CALLED).'/4X,'THE ERROR TYPE ',I3,' IS MADE ',
2 'NEGATIVE AS A REMINDER THAT AN ERROR HAS OCCURRED.')
ELSE
C FOR ALL OTHER VARIABLES, IS THERE A PREVIOUS HISTORY?
IF(KSTPRV .GT. 0) THEN
INDPER=0
DO NP=INDX00-1,-KSTPRV,-1
IF(ABS(PRVSVR(IV-ISECVR+1,NP)-RMISVR) .GT. EPSMIS .AND.
1 PRVSVR(IV-ISECVR+1,NP) .GE. SECBND(IV-ISECVR+1,1) .AND.
2 PRVSVR(IV-ISECVR+1,NP) .LE. SECBND(IV-ISECVR+1,2)) THEN
c Because of the JMA memorial problem, we are not allowed to use
c a motionless storm as a persistence value
if(iv-isecvr+1 .le. 2 .and. prvsvr(1,np) .eq. 0 .and.
1 prvsvr(2,np) .eq. 0) then
ipers=0
else
INDPER=NP
IPERS=1
C WRITE(6,161) INDPER,DAYZ,STDAYP(INDPER),
C 1 PRVSVR(IV-ISECVR+1,INDPER)
C 161 FORMAT(/'...INDPER,DAYZ,STDAYP(INDPER),PRVSVR(IV-ISECVR+1,
C 1 'INDPER)=',I3,3F10.3)
GO TO 221
ENDIF
ENDIF
ENDDO
221 CONTINUE
C IS PERSISTENCE SUBSTITUTION POSSIBLE?
IF(DAYZ-STDAYP(INDPER) .LE. DTPERS .AND. IPERS .EQ. 1) THEN
SUBVAR=PRVSVR(IV-ISECVR+1,INDPER)
SUBFLG='P'
IF(NPOSER .GT. 0) NPOSER=NPOSER-1
IERROR(NTOTER)=-IABS(IERROR(NTOTER))
WRITE(6,223) SUBVAR
223 FORMAT('...THE MISSING OR ERRONEOUS VALUE WILL BE REPLACED BY ',
1 'A PERSISTENCE VALUE OF ',F7.1)
C PERSISTENCE SUBSTITUTION NOT POSSIBLE
ELSE
IF(IV-ISECVR+1 .LE. 3) THEN
SUBVAR=0.0
WRITE(6,224) NAMVAR(IV),DAYZ,STDAYP(INDPER),DTPERS
224 FORMAT(/'...TIME INTERVAL TO THE CLOSEST PREVIOUS RECORD WITH ',
1 'A NON-MISSING ',A,' EXCEEDS DTPERS OR A '/4X,'NON-',
2 'MISSING VALUE CANNOT BE FOUND. DAYZ,PREVIOUS DAY,',
3 'DTPERS=',3F10.3,'.'/4X,'NO RECOVERY POSSIBLE FOR THIS',
4 ' VARIABLE.')
ELSE
WRITE(6,225) NAMVAR(IV),DAYZ,STDAYP(INDPER),DTPERS
225 FORMAT(/'...TIME INTERVAL TO THE CLOSEST PREVIOUS RECORD WITH ',
1 'A NON-MISSING ',A,' EXCEEDS DTPERS OR A '/4X,'NON-',
2 'MISSING VALUE CANNOT BE FOUND. DAYZ,PREVIOUS DAY,',
3 'DTPERS=',3F10.3/4X,'WE WILL SUBSTITUTE A ',
4 'CLIMATOLOGICAL VALUE.')
ENDIF
ENDIF
C NO PRIOR HISTORY
ELSE
IF(IV-ISECVR+1 .LE. 3) THEN
SUBVAR=0.0
WRITE(6,226) KSTPRV
226 FORMAT(/'...KSTPRV=',I2,' SO THERE IS NO PRIOR HISTORY AND NO ',
1 'CHECKING. NO RECOVERY POSSIBLE FOR THIS VARIABLE.')
ELSE
WRITE(6,227) KSTPRV
227 FORMAT(/'...KSTPRV=',I2,' SO THERE IS NO PRIOR HISTORY AND NO ',
1 'CHECKING. CLIMATOLOGICAL VALUES WILL BE SUBSTITUTED.')
ENDIF
ENDIF
C CLIMATOLOGICAL VARIABLE SUBSTITUTION
IF(SUBVAR .EQ. -99.0) THEN
DO NBA=1,NBASIN
IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN
IBASN=NBA
GO TO 2228
ENDIF
ENDDO
2228 CONTINUE
C SUBSTITUTE A PRESSURE-WIND RELATIONSHIP FOR MAX WIND
IF(IV .EQ. ITERVR) THEN
SUBVAR=TCPWTB(VITVAR(7),IBASN)
ELSE
SUBVAR=TCCLIM(IV,IBASN)
ENDIF
SUBFLG='C'
WRITE(6,229) NAMVAR(IV),SUBVAR,NABASN(IBASN)
229 FORMAT(/'...FOR VARIABLE ',A,', THE CLIMATOLOGICAL VALUE IS',F7.1,
1 ' IN THE ',A,' BASIN.')
ENDIF
IF(SUBVAR .NE. 0.0) THEN
WRITE(TSTREC(NREC)(ISTVAR(IV):IENVAR(IV)),FMTVIT(IV))
1 NINT(SUBVAR/VITFAC(IV))
TSTREC(NREC)(ISTVAR(IV)-1:ISTVAR(IV)-1)=SUBFLG
WRITE(6,2219) TSTREC(NREC)
2219 FORMAT('...AFTER SUBSTITUTION, THE RECORD IS:'/4X,A)
BUFINZ=TSTREC(NREC)
c Only update vitvar after direction errors have been corrected
c in the rare case for a JMA report with 0000 direction and
c 0000 speed
if(iv-isecvr+1 .ge. 2) then
DO IVZ=1,ITERVR
CALL DECVAR(ISTVAR(IVZ),IENVAR(IVZ),IVTVAR(IVZ),IERDEC,
1 FMTVIT(IVZ),BUFINZ)
VITVAR(IVZ)=REAL(IVTVAR(IVZ))*VITFAC(IVZ)
ENDDO
endif
ENDIF
ENDIF
ENDIF
C THE JTWC MEMORIAL PRESSURE SWITCHING CHECK
C IV=7 IS PCEN
C IV=8 IS PENV
IF(IV-ISECVR+1 .EQ. 3) THEN
IF(VITVAR(IV) .GE. VITVAR(IV+1)) THEN
NTOTER=NTOTER+1
WRITE(6,2301) VITVAR(IV),VITVAR(IV+1)
2301 FORMAT(/'...UNPHYSICAL PCEN=',F7.1,' >= PENV=',F7.1)
IF(SUBVAR .GT. 0.0) THEN
NPOSER=NPOSER+1
IERROR(NTOTER)=IABS(IV-ISECVR+1)
WRITE(6,2303)
2303 FORMAT('...WE CANNOT RECOVER THIS ERROR SINCE SUBSTITUTION HAS ',
1 'GIVEN UNPHYSICAL RESULTS.')
ELSE
IF(VITVAR(IV) .NE. RMISVR .AND. VITVAR(IV+1) .NE. RMISVR) THEN
SUBFLG='Z'
SUBVR1=VITVAR(IV)
SUBVR2=VITVAR(IV+1)-1.0
WRITE(TSTREC(NREC)(ISTVAR(IV):IENVAR(IV)),FMTVIT(IV))
1 NINT(SUBVR2/VITFAC(IV))
WRITE(TSTREC(NREC)(ISTVAR(IV+1):IENVAR(IV+1)),FMTVIT(IV+1))
1 NINT(SUBVR1/VITFAC(IV+1))
TSTREC(NREC)(ISTVAR(IV)-1:ISTVAR(IV)-1)=SUBFLG
TSTREC(NREC)(ISTVAR(IV+1)-1:ISTVAR(IV+1)-1)=SUBFLG
WRITE(6,2219) TSTREC(NREC)
BUFINZ=TSTREC(NREC)
DO IVZ=1,ITERVR
CALL DECVAR(ISTVAR(IVZ),IENVAR(IVZ),IVTVAR(IVZ),IERDEC,
1 FMTVIT(IVZ),BUFINZ)
VITVAR(IVZ)=REAL(IVTVAR(IVZ))*VITFAC(IVZ)
ENDDO
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
C CHECK FOR MISSING DEPTH OF THE CYCLONIC CIRCULATION
ITPC=0
DO KTPC=1,MAXTPC
IF(STMDPZ .EQ. STMTPC(KTPC)) THEN
ITPC=KTPC
C WRITE(6,239) NUMST,STMDPZ
C 239 FORMAT('...RECORD ',I3,' HAS A PROPER CODE=',A,' FOR DEPTH OF ',
C 'THE CYCLONIC CIRCULATION.')
ENDIF
ENDDO
IF(ITPC .EQ. 0) THEN
SUBTOP=EXE
NTOTER=NTOTER+1
IERROR(NTOTER)=-7
WRITE(6,241) NUNIQ,NUMST,INDX00,DAYZ,NTOTER,IERROR(NTOTER),
1 STMDPZ,NNNREC,ZZZREC,TSTREC(NREC)
241 FORMAT(//'...ERROR CHECKING NUNIQ,NUMST,INDX00,DAYZ,NTOTER,',
1 'IERROR=',3I4,F11.3,2I4/4X,'HAS FOUND MISSING OR BAD ',
2 'CODE=',A,' FOR DEPTH OF THE CYCLONIC CIRCULATION. ',
3 'RECORD='/2(1X,'@@@',A,'@@@'/),4X,A)
IF(KSTPRV .GT. 0) THEN
INDPER=0
DO NP=INDX00-1,-KSTPRV,-1
DO ITPC=1,MAXTPC
IF(STDPTP(NP) .EQ. STMTPC(ITPC)) THEN
INDPER=NP
SUBTOP=STDPTP(NP)
SUBFLG='P'
WRITE(6,243) INDPER,DAYZ,STDAYP(INDPER),SUBTOP
243 FORMAT(/'...INDPER,DAYZ,STDAYP(INDPER),SUBTOP=',I3,2F10.3,1X,A)
GO TO 261
ENDIF
ENDDO
ENDDO
261 CONTINUE
IF(DAYZ-STDAYP(INDPER) .LE. DTPERS) THEN
WRITE(6,263) NAMVAR(MAXVIT+1),SUBTOP
263 FORMAT('...THE MISSING OR ERRONEOUS VALUE OF ',A,' WILL BE ',
1 'REPLACED BY A PERSISTENCE VALUE OF ',A)
ELSE
WRITE(6,273) DAYZ,STDAYP(INDPER),DTPERS
273 FORMAT(/'...TIME INTERVAL TO THE CLOSEST PREVIOUS RECORD WITH ',
1 'A PROPER STORM DEPTH CODE EXCEEDS DTPERS OR AN '/4X,
2 'ACCEPTABLE VALUE CANNOT BE FOUND. ',
3 'DAYZ,PREVIOUS DAY,DTPERS=',3F10.3/,4X,'WE WILL ',
4 'SUBSTITUTE A CLIMATOLOGICAL VALUE.')
ENDIF
ELSE
WRITE(6,277) KSTPRV
277 FORMAT(/'...KSTPRV=',I2,' SO THERE IS NO PRIOR HISTORY AND NO ',
1 'CHECKING. CLIMATOLOGICAL VALUES WILL BE SUBSTITUTED.')
ENDIF
C DETERMINE CLIMATOLOGICAL VALUE IF NECESSARY
IF(SUBTOP .EQ. EXE) THEN
IF(PCENZ .LE. 980.0) THEN
SUBTOP=DEEP
WRITE(6,279) PCENZ,SUBTOP
279 FORMAT('...CLIMATOLOGICAL SUBSTITUTION OF STORM DEPTH: PCEN, ',
1 'DEPTH=',F7.1,1X,A)
ELSE IF(PCENZ .LE. 1000.0) THEN
SUBTOP=MEDIUM
WRITE(6,279) PCENZ,SUBTOP
ELSE
SUBTOP=SHALO
WRITE(6,279) PCENZ,SUBTOP
ENDIF
SUBFLG='C'
ENDIF
WRITE(TSTREC(NREC)(MAXCHR:MAXCHR),'(A)') SUBTOP
TSTREC(NREC)(MAXCHR-1:MAXCHR-1)=SUBFLG
WRITE(6,269) TSTREC(NREC)
269 FORMAT('...AFTER SUBSTITUTION, THE RECORD IS:'/4X,A)
ENDIF
C ASSIGN SUMMARY ERROR CODE
C NO ERRORS
IF(NTOTER .EQ. 0) THEN
IETYP=0
ISGNER=1
C IF ALL ERRORS HAVE BEEN FIXED, SUMMARY CODE IS NEGATIVE
ELSE
IF(NPOSER .EQ. 0) THEN
ISGNER=-1
ELSE
ISGNER=1
ENDIF
C ADD CODE FOR DEPTH OF THE CYCLONIC CIRCULATION FIRST
NERZ=0
NALLER=NTOTER
IF(IABS(IERROR(NTOTER)) .EQ. 7) THEN
NERZ=1
IETYP=7
NALLER=NTOTER-1
ENDIF
C ALL OTHER ERRORS. PICK OUT ONLY ALL ERRORS THAT REMAIN OR
C ALL ERRORS THAT HAVE BEEN FIXED IF THERE ARE NO REMAINING
C ERRORS. DO NOTHING WITH OTHER ERRORS.
DO NER=1,NALLER
IF((ISGNER .LT. 0 .AND. IERROR(NER) .LT. 0) .OR.
1 (ISGNER .GT. 0 .AND. IERROR(NER) .GT. 0)) THEN
NERZ=NERZ+1
ELSE
GO TO 280
ENDIF
IF(NERZ .EQ. 1) THEN
IETYP=IABS(IERROR(NER))
ELSE IF(NERZ .EQ. 2) THEN
IETYP=IABS(IETYP)*10+IABS(IERROR(NER))
ELSE IF(NERZ .EQ. 3) THEN
IF(IABS(IERROR(NTOTER)) .EQ. 7) THEN
IETYP=78
ELSE
IETYP=9
ENDIF
ELSE
IF(IABS(IERROR(NTOTER)) .EQ. 7) THEN
IETYP=79
ELSE
IETYP=9
ENDIF
ENDIF
280 CONTINUE
ENDDO
ENDIF
IETYP=SIGN(IETYP,ISGNER)
WRITE(6,281) SCRREC(NUNIQ),NUMST,NUMSTM(NUNIQ),NTOTER,NPOSER,
1 ISGNER,IETYP,(IERROR(NER),NER=1,NTOTER)
281 FORMAT(/'...ERROR SUMMARY FOR STMID,NUMST,NUMSTM=',A,2I3,':'/4X,
1 'NTOTER,NPOSER,ISGNER,IETYP,IERROR=',4I4/(4X,10I4))
C WRITE(6,287) NREC,IETYP,NUMTST(NREC),NUMST,NUNIQ,BUFINZ
C 287 FORMAT(/'...DEBUGGING, NREC,IETYP,NUMTST(NREC),NUMST,NUNIQ,',
C 1 'BUFINZ=',5I4/4X,A)
IFSECV(NUMTST(NREC))=IETYP
IF(IETYP .GT. 0) THEN
NADD=NADD+1
NUMBAD(NADD+NBAD)=NUMTST(NREC)
BADREC(NADD+NBAD)=TSTREC(NREC)
ELSE
NOKAY=NOKAY+1
NUMOKA(NOKAY)=NUMTST(NREC)
OKAREC(NOKAY)=TSTREC(NREC)
ENDIF
ENDDO
ENDDO
WRITE(6,301) NOKAY,NADD,NTEST,(ERCSV(NER),NER=1,NERCSV)
301 FORMAT(//'...RESULTS OF THE SECONDARY VARIABLE ERROR CHECK ARE: ',
1 'NOKAY=',I4,' AND NADD=',I4,' FOR A TOTAL OF ',I4,
2 ' RECORDS.'//4X,'ERROR CODES ARE:'/(6X,A))
WRITE(6,303)
303 FORMAT(/'...NOTES: NEGATIVE ERROR CODES (EXCEPT DIR/SPD) INDICATE'
1 ,' SUCCESSFUL RECOVERY FROM MISSING OR ERRONEOUS DATA'/11X
2 ,'BY SUBSTITUTION FROM PERSISTENCE.'/11X,'A NEGATIVE ERR',
3 'OR CODE FOR DIR/SPD INDICATES THAT ERROR RECOVERY WILL ',
4 'BE POSTPONED UNTIL THE DIR/SPD CHECK.'/11X,'MULTIPLE ',
5 'ERRORS ARE HANDLED AS FOLLOWS:'/13X,'THE FIRST SECONDARY'
6 ,' ERROR OCCUPIES THE LEFT-MOST DIGIT.'/13X,'THE NEXT ',
7 'SECONDARY ERROR OCCUPIES THE RIGHT-MOST DIGIT.'/13X,
8 'THREE OR MORE ERRORS REVERTS TO ERROR CODE=7, ETC.'/13X,
9 'ERRORS FOR THE DEPTH OF THE CYCLONIC CIRCULATION ARE ',
A 'COUNTED SEPARATELY.'//3X,'OKAY RECORDS ARE:',100X,'ERC'/)
DO NOK=1,NOKAY
WRITE(6,309) NOK,NUMOKA(NOK),OKAREC(NOK),IFSECV(NUMOKA(NOK))
309 FORMAT(3X,I4,'...',I4,'...',A,'...',I3)
ENDDO
IF(NADD .GT. 0) WRITE(6,311) (NBAD+NBA,NUMBAD(NBAD+NBA),
1 BADREC(NBAD+NBA),
2 IFSECV(NUMBAD(NBAD+NBA)),
3 NBA=1,NADD)
311 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4,
1 '...',A,'...',I3))
NBAD=NBAD+NADD
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: WRNING WRITES WARNING MESSAGE ABOUT RECORD MODS
C PRGMMR: S. LORD ORG: NP22 DATE: 1992-02-21
C
C ABSTRACT: WRITES SIMPLE WARNING MESSAGE.
C
C PROGRAM HISTORY LOG:
C 1992-02-21 S. LORD
C
C USAGE: CALL WRNING(IDSUB)
C INPUT ARGUMENT LIST:
C IDSUB - SUBROUTINE NAME
C
C REMARKS: SEE REMARKS IN CODE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE WRNING(IDSUB)
CHARACTER*6 IDSUB
WRITE(6,1) IDSUB
1 FORMAT(21X,'***********************************************'/
1 21X,'***********************************************'/
2 21X,'**** ****'/
3 21X,'**** WARNING: RECORDS WITH CORRECT FORMAT ****'/
4 21X,'**** BUT MISSING OR ERRONEOUS ****'/
5 21X,'**** DATA MAY BE MODIFIED BY ****'/
6 21X,'**** THIS ROUTINE=',A6,'!!! ****'/
7 21X,'**** ****'/
8 21X,'**** TYPES OF SUBSTITUTIONS ARE: ****'/
9 21X,'**** CLIMATOLOGICAL SUBSTITUTION: C ****'/
O 21X,'**** RSMC AVERAGING: A ****'/
1 21X,'**** PERSISTENCE SUBSTITUTION: P ****'/
2 21X,'**** OVERLAP MODIFICATION: O ****'/
3 21X,'**** DIRECTION/SPEED SUBSTITUTION: S ****'/
4 21X,'**** LATITUDE/LONGITUDE SUBSTITUTION: L ****'/
4 21X,'**** SWITCHED PCEN-PENV SUBSTITUTION: Z ****'/
8 21X,'**** ****'/
6 21X,'***********************************************'/
7 21X,'***********************************************')
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: F1 RECALCULATES LONGITUDES
C PRGMMR: S. LORD ORG: NP22 DATE: 1993-05-01
C
C ABSTRACT: SEE COMMENTS IN PROGRAM. ORIGINALLY WRITTEN BY C. J. NEWMANN
C
C PROGRAM HISTORY LOG:
C 1993-05-01 S. LORD INSTALLED PROGRAM
C
C USAGE: CALL F1(ALON)
C INPUT ARGUMENT LIST: SEE COMMENTS IN PROGRAM
C
C OUTPUT ARGUMENT LIST:
C SEE COMMENTS IN PROGRAM
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
FUNCTION F1(ALON)
C CONVERT FROM E LONGITUDE TO THOSE ACCEPTABLE IN AL TAYLOR ROUTINES
IF(ALON.GT.180.)F1=360.-ALON
IF(ALON.LE.180.)F1=-ALON
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: F2 CALCULATES DATES
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-06-05
C
C ABSTRACT: SEE COMMENTS IN PROGRAM. ORIGINALLY WRITTEN BY C. J.
C NEWMANN
C
C PROGRAM HISTORY LOG:
C 1993-05-01 S. LORD INSTALLED PROGRAM
C 1998-06-05 D. A. KEYSER - Y2K, FORTRAN 90 COMPLIANT
C
C USAGE: CALL F2(IDATIM)
C INPUT ARGUMENT LIST:
C IDATIM - 10-DIGIT DATE IN FORM YYYYDDMMHH
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
FUNCTION F2(IDATIM)
C OBTAIN JULIAN DAY NUMBER
C 0000UTC ON 1 JAN IS SET TO DAY NUMBER 0 AND 1800UTC ON 31 DEC IS SET
C TO DAY NUMBER 364.75. LEAP YEARS ARE IGNORED.
CHARACTER*10 ALFA
WRITE(ALFA,'(I10)')IDATIM
READ(ALFA,'(I4,3I2)')KYR,MO,KDA,KHR
MON=MO
IF(MON.EQ.13)MON=1
DANBR=3055*(MON+2)/100-(MON+10)/13*2-91+KDA
F2=DANBR-1.+REAL(KHR/6)*0.25
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: SLDATE RETRIEVES DATE FROM SYSTEM AND DATE FILE
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-06-05
C
C ABSTRACT: RETRIEVES DATE FROM SYSTEM AND FROM A DATE FILE, AND
C OBTAINS THE DIFFERENCE BETWEEN THE TWO. CONSTRUCTS DATE
C IN FORM YYYYMMDD AND HHMM.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C 1998-06-05 D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE: CALL SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM)
C INPUT ARGUMENT LIST:
C IUNTDT - UNIT NUMBER FOR FILE CONTAINING RUN DATE
C
C OUTPUT ARGUMENT LIST:
C IDATEZ - DATE IN FORM YYYYMMDD
C IUTCZ - DATE IN FORM HHMM
C IOFFTM - OFFSET (HOURS *100) BETWEEN SYSTEM DATE AND
C - FILE DATE (SYSTEM DATE MINUS FILE DATE)
C
C INPUT FILES:
C UNIT "IUNTDT" - FILE CONTAINING RUN DATE IN I4,3I2 FORMAT
C - ('YYYYMMDDHH')
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM)
CHARACTER USRDAT*10
SAVE
DIMENSION IDAT(8),JDAT(6),RINC(5)
EQUIVALENCE (IDAT(1),JW3YR),(IDAT(2),JW3MO),(IDAT(3),JW3DA),
2 (IDAT(5),JW3HR),(IDAT(6),JW3MIN),(IDAT(7),JW3SEC)
READ(IUNTDT,1) USRDAT
1 FORMAT(A10)
WRITE(6,3) USRDAT
3 FORMAT(/'...',A10,'...')
C OBTAIN CURRENT SYSTEM DATE - IDAT (UTC)
CALL W3UTCDAT(IDAT)
C DECODE THE DATE LABEL INTO JDAT (UTC)
READ(USRDAT(1: 4),'(I4)') JDAT(1)
READ(USRDAT(5: 6),'(I2)') JDAT(2)
READ(USRDAT(7: 8),'(I2)') JDAT(3)
READ(USRDAT(9:10),'(I2)') JDAT(5)
C THIS IS THE TIME ZONE OFFSET (SAME AS FOR IDAT)
JDAT(4) = IDAT(4)
JDAT(6) = 0
C COMBINE YEAR, MONTH, DAY, HOUR, MINUTE TO FORM YYYYMMDD
IDATEZ=JDAT(1)*10000+JDAT(2)*100+JDAT(3)
IUTCZ =JDAT(5)*100+JDAT(6)
C OBTAIN TIME DIFFERENCE (CURRENT TIME - LABEL TIME) IN HOURS * 100
CALL W3DIFDAT(IDAT,(/JDAT(1),JDAT(2),JDAT(3),JDAT(4),JDAT(5),
$ JDAT(6),0,0/),2,RINC)
IOFFTM=NINT(RINC(2)*100.)
WRITE(6,5) JW3YR,JW3MO,JW3DA,JW3HR,JW3MIN,JW3SEC,IOFFTM
5 FORMAT(/'...CURRENT DATE/TIME FROM W3UTCDAT CALL IS:'/'JW3YR=',I5,
1 ' JW3MO=',I3,' JW3DA=',I3,' JW3HR=',I5,' JW3MIN=',I5,
2 ' JW3SEC=',I5,' OFFTIM=',I8)
WRITE(6,13) IDATEZ,IUTCZ
13 FORMAT('...IN SLDATE, IDATEZ,IUTCZ=',I10,2X,I4)
RETURN
C-----------------------------------------------------------------------
ENTRY SLDTCK(IUNTDT)
REWIND IUNTDT
WRITE(6,21) IUNTDT
21 FORMAT('...WRITING USRDAT TO UNIT',I3)
WRITE(IUNTDT,1) USRDAT
RETURN
C-----------------------------------------------------------------------
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FIXSLM MODIFIES SEA-LAND MASK
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: MODIFIES NCEP T126 GAUSSIAN GRID SEA-LAND MASK. CONVERTS
C SOME SMALL ISLANDS TO OCEAN POINTS. PROGRAM IS DEPENDENT
C ON MODEL RESOLUTION.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C 1992-04-08 S. J. LORD CONVERTED TO T126 FROM T80
C
C USAGE: CALL FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK)
C INPUT ARGUMENT LIST:
C LONF - NUMBER OF LONGITUDINAL POINTS, FIRST INDEX OF SLMASK
C LATG2 - NUMBER OF LATITUDINAL POINTS, SECOND INDEX OF SLMASK
C RLON - LONGITUDES
C RLAT - LATITUDES
C SLMASK - T162 SEA-LAND MASK ON GAUSSIAN GRID
C
C OUTPUT ARGUMENT LIST:
C SLMASK - MODIFIED T162 SEA-LAND MASK ON GAUSSIAN GRID
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK)
PARAMETER (MAXSLM=35)
SAVE
DIMENSION RLAT(LATG2),RLON(LONF),SLMASK(LONF,LATG2),IPT(MAXSLM),
1 JPT(MAXSLM)
DATA NOCEAN/21/,
C INDONESIAN ARCHIPELAGO,NEW CALEDONIA
1 IPT/133,135,129,177,
C YUCATAN
2 290,291,292,289,290,291,289,290,291,
C CUBA
3 299,300,301,302,303,303,304,305,14*0.0/,
C INDONESIAN ARCHIPELAGO,NEW CALEDONIA
1 JPT/106,105,106,118,
C YUCATAN
2 3*73,3*74,3*75,
C CUBA
3 3*72,2*73,3*74,14*0.0/
C WRITE(6,7)
C 7 FORMAT('...CONVERTING LAND TO OCEAN, NPT,IPT,RLON,JPT,RLAT=')
DO NPT=1,NOCEAN
SLMASK(IPT(NPT),JPT(NPT))=0.0
C WRITE(6,9) NPT,IPT(NPT),RLON(IPT(NPT)),JPT(NPT),RLAT(JPT(NPT))
C 9 FORMAT(4X,2I5,F10.3,I5,F10.3)
ENDDO
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: GAULAT CALCULATES GAUSSIAN GRID LATITUDES
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: CALCULATES GAUSSIAN GRID LATITUDES
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD - COPIED FROM KANAMITSU LIBRARY
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE GAULAT(GAUL,K)
IMPLICIT REAL(8) (A-H,O-Z)
DIMENSION A(500)
REAL GAUL(1)
SAVE
ESP=1.D-14
C=(1.D0-(2.D0/3.14159265358979D0)**2)*0.25D0
FK=K
KK=K/2
CALL BSSLZ1(A,KK)
DO IS=1,KK
XZ=COS(A(IS)/SQRT((FK+0.5D0)**2+C))
ITER=0
10 PKM2=1.D0
PKM1=XZ
ITER=ITER+1
IF(ITER.GT.10) GO TO 70
DO N=2,K
FN=N
PK=((2.D0*FN-1.D0)*XZ*PKM1-(FN-1.D0)*PKM2)/FN
PKM2=PKM1
PKM1=PK
ENDDO
PKM1=PKM2
PKMRK=(FK*(PKM1-XZ*PK))/(1.D0-XZ**2)
SP=PK/PKMRK
XZ=XZ-SP
AVSP=ABS(SP)
IF(AVSP.GT.ESP) GO TO 10
A(IS)=XZ
ENDDO
IF(K.EQ.KK*2) GO TO 50
A(KK+1)=0.D0
PK=2.D0/FK**2
DO N=2,K,2
FN=N
PK=PK*FN**2/(FN-1.D0)**2
ENDDO
50 CONTINUE
DO N=1,KK
L=K+1-N
A(L)=-A(N)
ENDDO
RADI=180./(4.*ATAN(1.))
GAUL(1:K)=ACOS(A(1:K))*RADI
C PRINT *,'GAUSSIAN LAT (DEG) FOR JMAX=',K
C PRINT *,(GAUL(N),N=1,K)
RETURN
70 WRITE(6,6000)
6000 FORMAT(//5X,14HERROR IN GAUAW//)
CALL ABORT1(' GAULAT',6000)
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: BSSLZ1 CALCULATES BESSEL FUNCTIONS
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: CALCULATES BESSEL FUNCTIONS
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD - COPIED FROM KANAMITSU LIBRARY
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE BSSLZ1(BES,N)
IMPLICIT REAL(8) (A-H,O-Z)
DIMENSION BES(N)
DIMENSION BZ(50)
DATA PI/3.14159265358979D0/
DATA BZ / 2.4048255577D0, 5.5200781103D0,
$ 8.6537279129D0,11.7915344391D0,14.9309177086D0,18.0710639679D0,
$ 21.2116366299D0,24.3524715308D0,27.4934791320D0,30.6346064684D0,
$ 33.7758202136D0,36.9170983537D0,40.0584257646D0,43.1997917132D0,
$ 46.3411883717D0,49.4826098974D0,52.6240518411D0,55.7655107550D0,
$ 58.9069839261D0,62.0484691902D0,65.1899648002D0,68.3314693299D0,
$ 71.4729816036D0,74.6145006437D0,77.7560256304D0,80.8975558711D0,
$ 84.0390907769D0,87.1806298436D0,90.3221726372D0,93.4637187819D0,
$ 96.6052679510D0,99.7468198587D0,102.888374254D0,106.029930916D0,
$ 109.171489649D0,112.313050280D0,115.454612653D0,118.596176630D0,
$ 121.737742088D0,124.879308913D0,128.020877005D0,131.162446275D0,
$ 134.304016638D0,137.445588020D0,140.587160352D0,143.728733573D0,
$ 146.870307625D0,150.011882457D0,153.153458019D0,156.295034268D0/
NN=N
IF(N.LE.50) GO TO 12
BES(50)=BZ(50)
BES(51:N)=BES(50:N-1)+PI
NN=49
12 CONTINUE
BES(1:NN)=BZ(1:NN)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: TRKSUB DETERMINES OBS. TROP. CYCLONE TRACKS
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: CONTAINS VARIOUS ENTRY POINTS TO DETERMINE TROPICAL
C CYCLONE TRACKS, CALCULATE STORM RELATIVE COORDINATE, DETERMINES
C FIRST OCCURRENCE OF A PARTICULAR STORM.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: CALL TRKSUB(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF,
C 1 STMDR0,STMSP0,STLAT0,STLON0,IERSET,
C 3 STLATP,STLONP,STDIRP,STSPDP,STDAYP,
C 4 STRMXP,STPCNP,STPENP,STVMXP,KSTPZ,
C 5 STDPTP,STMNTK)
C CALL SETTRK(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF,
C 1 STMDR0,STMSP0,STLAT0,STLON0,STMNTK,IERSET)
C INPUT ARGUMENT LIST:
C DAY0 - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899
C DAYMX - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899 (MAX)
C DAYMN - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899 (MIN)
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE TRKSUB(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF,
1 STMDR0,STMSP0,STLAT0,STLON0,IERSET,STLATP,
2 STLONP,STDIRP,STSPDP,STDAYP,STRMXP,STPCNP,
3 STPENP,STVMXP,KSTPZ,STDPTP,STMNTK)
PARAMETER (MAXSTM=70)
PARAMETER (NSTM=MAXSTM,NSTM1=NSTM+1)
PARAMETER (NPRVMX=61)
LOGICAL NOMIN,NOMAX,EXTRPB,EXTRPF
CHARACTER STMNTK*(*),STDPTP*1
SAVE
DIMENSION STDPTP(-NPRVMX:-1)
DIMENSION RINC(5)
CHARACTER STMNAM*9,STMID*3,RSMC*4
LOGICAL FSTFLG
DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
1 STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
2 IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
3 PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
4 R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
5 STMID(MAXSTM),FSTFLG(MAXSTM)
PARAMETER (MAXTPC= 3)
CHARACTER SHALO*1,MEDIUM*1,DEEP*1,STMTPC*1,EXE*1
DIMENSION STMTOP(0:MAXTPC)
DIMENSION STMTPC(0:MAXTPC)
EQUIVALENCE (STMTPC(0), EXE),(STMTPC(1),SHALO),(STMTPC(2),MEDIUM),
1 (STMTPC(3),DEEP)
DIMENSION TRKLTZ(0:NSTM1),TRKLNZ(0:NSTM1),
1 TRKDRZ(0:NSTM1),TRKSPZ(0:NSTM1),
2 TRKRMX(0:NSTM1),TRKPCN(0:NSTM1),
3 TRKPEN(0:NSTM1),TRKVMX(0:NSTM1),
4 TRKDPT(0:NSTM1)
DIMENSION STMDAY(0:NSTM1),SRTDAY(NSTM),IDASRT(0:NSTM1),
1 SRTLAT(NSTM),SRTLON(NSTM),SRTDIR(NSTM),SRTSPD(NSTM),
2 ISRTDA(NSTM),ISRTUT(NSTM),SRTRMX(NSTM),SRTPCN(NSTM),
3 SRTPEN(NSTM),SRTVMX(NSTM),SRTDPT(NSTM)
DIMENSION STLATP(-NPRVMX:-1),STLONP(-NPRVMX:-1),
1 STDIRP(-NPRVMX:-1),STSPDP(-NPRVMX:-1),
1 STDAYP(-NPRVMX: 0),STRMXP(-NPRVMX:-1),
1 STPCNP(-NPRVMX:-1),STPENP(-NPRVMX:-1),
2 STVMXP(-NPRVMX:-1)
EQUIVALENCE (TRKLTZ(1),STMLAT(1)),(TRKLNZ(1),STMLON(1)),
1 (TRKDRZ(1),STMDIR(1)),(TRKSPZ(1),STMSPD(1)),
2 (TRKRMX(1),RMAX (1)),(TRKPCN(1),PCEN (1)),
3 (TRKPEN(1),PENV (1)),(TRKVMX(1),VMAX (1)),
4 (TRKDPT(1),PTOP (1))
DATA SHALO/'S'/,MEDIUM/'M'/,DEEP/'D'/,EXE/'X'/,
1 STMTOP/-99.0,700.,400.,200./
C FIVMIN IS FIVE MINUTES IN UNITS OF FRACTIONAL DAYS
C FACSPD IS CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)*
DATA IPRNT/0/,FIVMIN/3.4722E-3/,FACSPD/0.77719/
C-----------------------------------------------------------------------
ENTRY SETTRK(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF,
1 STMDR0,STMSP0,STLAT0,STLON0,STMNTK,IERSET)
IERSET=0
IOPT=IOPTZ
IDTREQ=IDATTK
IF(IOPT .EQ. 5) THEN
STMID (1)=STMNTK(1:3)
ELSE IF(IOPT .EQ. 6) THEN
STMNAM(1)=STMNTK(1:9)
ELSE
WRITE(6,1) IOPT
1 FORMAT(/'******ILLEGAL OPTION IN SETTRK=',I4)
IERSET=1
RETURN
ENDIF
WRITE(6,6) IOPT,STMNTK,DAY0,DAYMN,DAYMX,IDTREQ,IHRREQ
6 FORMAT(/'...ENTERING SETTRK, WITH IOPT=',I2,'. LOOKING FOR ALL ',
1 'FIXES FOR ',A,' WITH CENTRAL TIME=',F12.2,/4X,' MIN/MAX',
2 ' TIMES=',2F12.2,' AND REQUESTED DATE/TIME=',2I10)
CALL NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ,
1 IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,
2 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,
3 PTOP,FSTFLG,STMNAM,STMID,RSMC)
C CONVERT FIX TIMES TO FLOATING POINT JULIAN DAY
DO KST=1,KSTORM
CALL ZTIME(IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/),
$ 1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,STMDAY(KST))
STMDAY(KST)=STMDAY(KST)+DAYOFF
c WRITE(6,16) IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN,JDY,
c 1 STMDAY(KST)
c 16 FORMAT('...STORM FIX TIMES ARE: IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,',
c 1 'JDY,STMDAY'/4X,8I8,F15.5)
ENDDO
CALL SORTRL(STMDAY(1:KSTORM),IDASRT(1:KSTORM),KSTORM)
c WRITE(6,26) (STMDAY(KST),IDASRT(KST),KST=1,KSTORM)
c 26 FORMAT(/'...SORTED STORM DAYS AND INDEX ARE:'/(5X,F15.5,I6))
C PICK OUT TIMES AND LOCATIONS FROM SORTED LIST OF STORM DAYS
NOMIN=.TRUE.
NOMAX=.TRUE.
EXTRPB=.FALSE.
EXTRPF=.FALSE.
KSRTMN=-1
KSRTMX=-1
DO KSRT=1,KSTORM
IF(STMDAY(KSRT) .GT. DAYMN .AND. NOMIN) THEN
NOMIN=.FALSE.
KSRTMN=KSRT-1
ENDIF
IF(STMDAY(KSRT) .GT. DAYMX .AND. NOMAX) THEN
NOMAX=.FALSE.
KSRTMX=KSRT
ENDIF
ENDDO
IF(KSRTMN .LE. 0) THEN
C WE HAVENT'T BEEN ABLE TO FIND A STMDAY THAT IS LESS THAN 8 HOURS
C EARLIER THAN THE TIME WINDOW. EITHER THIS IS THE FIRST TIME
C THIS STORM HAS BEEN RUN OR THERE MAY BE AN ERROR. IN EITHER
C CASE, WE ALLOW EXTRAPOLATION OF THE OBSERVED MOTION BACK
C IN TIME, BUT SET AN ERROR FLAG. THE SAME METHOD IS
C USED FOR THE LAST RUN OF A PARTICULAR STORM.
DT=STMDAY(1)-DAYMN
IF(DT .LE. 0.333333) THEN
WRITE(6,41) KSTORM,KSRT,DAYMN,(STMDAY(KST),KST=1,KSTORM)
41 FORMAT(/'######CANNOT FIND STORM RECORDS LESS THAN 8 HOURS ',
1 'BEFORE WINDOW MINIMUM.'/7X,'THIS IS THE FIRST RECORD ',
2 'FOR THIS STORM OR THERE MAY BE AN ERROR. KSTORM,KSRT,',
3 'DAYMN,STMDAY=',2I4,F10.3/(5X,10F12.3))
IERSET=41
ENDIF
EXTRPB=.TRUE.
KSRTMN=0
ISRT=IDASRT(1)
IDASRT(KSRTMN)=0
STMDAY(KSRTMN)=DAYMN
TRKDRZ(KSRTMN)=STMDIR(ISRT)
TRKSPZ(KSRTMN)=STMSPD(ISRT)
CALL DS2UV(USTM,VSTM,STMDIR(ISRT),STMSPD(ISRT))
TRKLTZ(KSRTMN)=STMLAT(ISRT)-VSTM*DT*FACSPD
TRKLNZ(KSRTMN)=STMLON(ISRT)-USTM*DT*FACSPD/COSD(STMLAT(ISRT))
TRKRMX(KSRTMN)=RMAX(ISRT)
TRKPCN(KSRTMN)=PCEN(ISRT)
TRKPEN(KSRTMN)=PENV(ISRT)
TRKVMX(KSRTMN)=VMAX(ISRT)
TRKDPT(KSRTMN)=PTOP(ISRT)
WRITE(6,39) ISRT,KSRTMN,STMDAY(KSRTMN),TRKDRZ(KSRTMN),
1 TRKSPZ(KSRTMN),USTM,VSTM,DT,TRKLTZ(KSRTMN),
2 TRKLNZ(KSRTMN),STMLAT(ISRT),STMLON(ISRT)
39 FORMAT(/'...EXTRAPOLATING FIX BACKWARDS IN TIME: ISRT,KSRTMN,',
1 '(STMDAY,TRKDRZ,TRKSPZ(KSRTMN)),USTM,VSTM,DT,'/41X,
2 '(TRKLTZ,TRKLNZ(KSRTMN)),(STMLAT,STMLON(ISRT))='/40X,
3 2I3,6F12.3/43X,4F12.3)
ENDIF
IF(KSRTMX .LE. 0) THEN
DT=DAYMX-STMDAY(KSTORM)
IF(DT .LE. 0.333333) THEN
WRITE(6,51) KSTORM,KSRT,DAYMX,(STMDAY(KST),KST=1,KSTORM)
51 FORMAT(/'######CANNOT FIND STORM RECORDS MORE THAN 8 HOURS ',
1 'AFTER WINDOW MAXIMUM.'/7X,'THIS IS THE LAST RECORD ',
2 'FOR THIS STORM OR THERE MAY BE AN ERROR. KSTORM,KSRT,',
3 'DAYMX,STMDAY=',2I4,F10.3/(5X,10F12.3))
IERSET=51
ENDIF
EXTRPF=.TRUE.
KSRTMX=KSTORM+1
ISRT=IDASRT(KSTORM)
IDASRT(KSRTMX)=KSTORM+1
STMDAY(KSRTMX)=DAYMX
TRKDRZ(KSRTMX)=STMDIR(ISRT)
TRKSPZ(KSRTMX)=STMSPD(ISRT)
CALL DS2UV(USTM,VSTM,TRKDRZ(ISRT),TRKSPZ(ISRT))
TRKLTZ(KSRTMX)=STMLAT(ISRT)+VSTM*DT*FACSPD
TRKLNZ(KSRTMX)=STMLON(ISRT)+USTM*DT*FACSPD/COSD(STMLAT(ISRT))
TRKRMX(KSRTMX)=RMAX(ISRT)
TRKPCN(KSRTMX)=PCEN(ISRT)
TRKPEN(KSRTMX)=PENV(ISRT)
TRKVMX(KSRTMX)=VMAX(ISRT)
TRKDPT(KSRTMX)=PTOP(ISRT)
WRITE(6,49) ISRT,STMDAY(KSRTMX),TRKDRZ(KSRTMX),TRKSPZ(KSRTMX),
1 USTM,VSTM,DT,TRKLTZ(KSRTMX),TRKLNZ(KSRTMX),
2 STMLAT(ISRT),STMLON(ISRT)
49 FORMAT(/'...EXTRAPOLATING FIX FORWARDS IN TIME: ISRT,(STMDAY,',
1 'TRKDIR,TRKSPD(KSRTMX)),USTM,VSTM,DT,'/41X,'(TRKLTZ,',
2 'TRKLNZ(KSRTMX)),(STMLAT,STMLON(ISRT))='/40X,I3,6F12.3/
3 43X,4F12.3)
ENDIF
KK=1
KST0=-1
TIMMIN=1.E10
C PUT ALL FIXES THAT DEFINE THE TIME WINDOW INTO ARRAYS SORTED
C BY TIME. FIRST, ELIMINATE RECORDS WITH DUPLICATE TIMES.
C OUR ARBITRARY CONVENTION IS TO KEEP THE LATEST RECORD. ANY
C FIX TIME WITHIN 5 MINUTES OF ITS PREDECESSOR IN THE SORTED
C LIST IS CONSIDERED DUPLICATE.
DO KST=KSRTMN,KSRTMX
IF(KST .GT. KSRTMN) THEN
IF(STMDAY(KST)-SRTDAY(KK) .LT. FIVMIN) THEN
WRITE(6,53) KST,KK,STMDAY(KST),SRTDAY(KK)
53 FORMAT(/'...TIME SORTED FIX RECORDS SHOW A DUPLICATE, KST,KK,',
1 'STMDAY(KST),SRTDAY(KK)=',2I5,2F12.3)
ELSE
KK=KK+1
ENDIF
ENDIF
C STORE SORTED LAT/LON, DIRECTION, SPEED FOR FUTURE USE.
SRTLAT(KK)=TRKLTZ(IDASRT(KST))
SRTLON(KK)=TRKLNZ(IDASRT(KST))
SRTDIR(KK)=TRKDRZ(IDASRT(KST))
SRTSPD(KK)=TRKSPZ(IDASRT(KST))
SRTDAY(KK)=STMDAY(KST)
SRTRMX(KK)=TRKRMX(IDASRT(KST))
SRTPCN(KK)=TRKPCN(IDASRT(KST))
SRTPEN(KK)=TRKPEN(IDASRT(KST))
SRTVMX(KK)=TRKVMX(IDASRT(KST))
SRTDPT(KK)=TRKDPT(IDASRT(KST))
c fixit?? - to avoid subscript zero warning on next two lines, I did
c the following ....
cdak ISRTDA(KK)=IDATE(IDASRT(KST))
cdak ISRTUT(KK)=IUTC (IDASRT(KST))
if(IDASRT(KST).ne.0) then
ISRTDA(KK)=IDATE(IDASRT(KST))
ISRTUT(KK)=IUTC (IDASRT(KST))
else
ISRTDA(KK)=0
ISRTUT(KK)=0
end if
IF(ABS(SRTDAY(KK)-DAY0) .LT. TIMMIN) THEN
IF(ABS(SRTDAY(KK)-DAY0) .LT. FIVMIN) KST0=KK
KSTZ=KK
TIMMIN=ABS(SRTDAY(KK)-DAY0)
ENDIF
ENDDO
KSTMX=KK
C ZERO OUT EXTRAPOLATED DATE AND TIME AS A REMINDER
IF(EXTRPF) THEN
ISRTDA(KSTMX)=0
ISRTUT(KSTMX)=0
ENDIF
IF(EXTRPB) THEN
ISRTDA(1)=0
ISRTUT(1)=0
ENDIF
IF(KSTZ .EQ. KSTMX .AND. .NOT. (EXTRPB .OR. EXTRPF)) THEN
WRITE(6,61) KSTZ,KSTMX,(SRTDAY(KST),KST=1,KSTMX)
61 FORMAT(/'******THE REFERENCE STORM INDEX IS THE MAXIMUM ALLOWED ',
1 'A PROBABLE ERROR HAS OCCURRED'/8X,'KSTZ,KSTMX,SRTDAY=',
2 2I5/(5X,10F12.3))
CALL ABORT1(' SETTRK',61)
ENDIF
IF(KST0 .LE. 0) THEN
WRITE(6,72) DAY0,KST0,(SRTDAY(KST),KST=1,KSTMX)
72 FORMAT(/'******THERE IS NO FIX AT THE ANALYSIS TIME, AN ',
1 'INTERPOLATED POSITION WILL BE CALCULATED'/5X,'DAY0,',
2 'KST0,SRTDAY=',F12.3,I6/(5X,10F12.3))
IF(DAY0-SRTDAY(KSTZ) .GT. 0.0) THEN
RATIO=(DAY0-SRTDAY(KSTZ))/(SRTDAY(KSTZ+1)-SRTDAY(KSTZ))
STLAT0=SRTLAT(KSTZ)+(SRTLAT(KSTZ+1)-SRTLAT(KSTZ))*RATIO
STLON0=SRTLON(KSTZ)+(SRTLON(KSTZ+1)-SRTLON(KSTZ))*RATIO
STMDR0=SRTDIR(KSTZ)+(SRTDIR(KSTZ+1)-SRTDIR(KSTZ))*RATIO
STMSP0=SRTSPD(KSTZ)+(SRTSPD(KSTZ+1)-SRTSPD(KSTZ))*RATIO
STDAY0=DAY0
ELSE
RATIO=(DAY0-SRTDAY(KSTZ-1))/(SRTDAY(KSTZ)-SRTDAY(KSTZ-1))
STLAT0=SRTLAT(KSTZ-1)+(SRTLAT(KSTZ)-SRTLAT(KSTZ-1))*RATIO
STLON0=SRTLON(KSTZ-1)+(SRTLON(KSTZ)-SRTLON(KSTZ-1))*RATIO
STMDR0=SRTDIR(KSTZ-1)+(SRTDIR(KSTZ)-SRTDIR(KSTZ-1))*RATIO
STMSP0=SRTSPD(KSTZ-1)+(SRTSPD(KSTZ)-SRTSPD(KSTZ-1))*RATIO
STDAY0=DAY0
ENDIF
ELSE
STLAT0=SRTLAT(KST0)
STLON0=SRTLON(KST0)
STMDR0=SRTDIR(KST0)
STMSP0=SRTSPD(KST0)
STDAY0=SRTDAY(KST0)
ENDIF
WRITE(6,77) (KSRT,ISRTDA(KSRT),ISRTUT(KSRT),
1 SRTDAY(KSRT),SRTLAT(KSRT),SRTLON(KSRT),
2 SRTDIR(KSRT),SRTSPD(KSRT),
3 SRTPCN(KSRT),SRTPEN(KSRT),SRTRMX(KSRT),
4 SRTVMX(KSRT),SRTDPT(KSRT),KSRT=1,KSTMX)
77 FORMAT(/'...FINAL SORTED LIST IS:'/6X,'YYYYMMDD',2X,'HHMM',4X,
1 'RJDAY',7X,'LAT',7X,'LON',6X,'DIR',7X,'SPEED',4X,' PCEN',
2 26X,'PENV',6X,'RMAX',5X,'VMAX',4X,'PTOP'/(1X,I3,2X,I8,2X,
3 I4,8F10.2,2(3X,F5.1)))
WRITE(6,79) STDAY0,STLAT0,STLON0,STMDR0,STMSP0
79 FORMAT(/'...THE REFERENCE TIME, LATITUDE, LONGITUDE, DIRECTION ',
1 'AND SPEED ARE:',5F12.3)
WRITE(6,89)
89 FORMAT(/'...END SETTRK')
RETURN
C-----------------------------------------------------------------------
ENTRY PRVSTM(STLATP,STLONP,STDIRP,STSPDP,STDAYP,
1 STRMXP,STPCNP,STPENP,STVMXP,STDPTP,KSTPZ)
C THIS ENTRY IS CURRENTLY SET UP TO RETURN THE TWO PREVIOUS
C SETS OF STORM LAT/LON, DIR/SPD, TIME. FOR CASES IN WHICH
C INSUFFICIENT STORM RECORDS HAVE BEEN FOUND, THE SLOTS ARE
C FILLED WITH -99.0 OR A DASH
C KSTPZ IS THE NUMBER OF PREVIOUS, NON-EXTRAPOLATED, STORM RECORDS
KSTPZ=MIN0(MAX0(KSTZ-1,0),NPRVMX)
STLATP(-NPRVMX:-1)=-99.0
STLONP(-NPRVMX:-1)=-99.0
STDIRP(-NPRVMX:-1)=-99.0
STSPDP(-NPRVMX:-1)=-99.0
STDAYP(-NPRVMX:-1)=-99.0
STRMXP(-NPRVMX:-1)=-99.0
STPCNP(-NPRVMX:-1)=-99.0
STPENP(-NPRVMX:-1)=-99.0
STVMXP(-NPRVMX:-1)=-99.0
STDPTP(-NPRVMX:-1)='-'
DO KSTP=1,KSTPZ
STLATP(-KSTP)=SRTLAT(KSTZ-KSTP)
STLONP(-KSTP)=SRTLON(KSTZ-KSTP)
STDIRP(-KSTP)=SRTDIR(KSTZ-KSTP)
STSPDP(-KSTP)=SRTSPD(KSTZ-KSTP)
STDAYP(-KSTP)=SRTDAY(KSTZ-KSTP)
STRMXP(-KSTP)=SRTRMX(KSTZ-KSTP)
STPCNP(-KSTP)=SRTPCN(KSTZ-KSTP)
STPENP(-KSTP)=SRTPEN(KSTZ-KSTP)
STVMXP(-KSTP)=SRTVMX(KSTZ-KSTP)
C RECODE PRESSURE STORM DEPTH INTO A CHARACTER
KTPC=0
DO KTOP=1,MAXTPC
IF(SRTDPT(KSTZ-KSTP) .EQ. STMTOP(KTOP)) KTPC=KTOP
ENDDO
STDPTP(-KSTP)=STMTPC(KTPC)
ENDDO
IF(EXTRPB .AND. KSTZ-KSTPZ .LE. 1) KSTPZ=KSTPZ-1
IF(KSTPZ .EQ. 0) THEN
WRITE(6,97)
97 FORMAT(/'...NO STORM RECORDS PRECEEDING THE REFERENCE TIME HAVE ',
1 'BEEN FOUND BY PRVSTM.')
ELSE
WRITE(6,98) KSTPZ,NPRVMX,STDAYP(-1)
98 FORMAT(/'...PRVSTM HAS FOUND',I3,' STORM RECORDS PRECEEDING THE ',
1 'REFERENCE TIME (MAX ALLOWED=',I2,').'/4X,'THE TIME ',
2 'CORRESPONDING TO INDEX -1 IS',F12.3,'.')
ENDIF
C WRITE(6,99) KSTZ,KSTPZ,(STLATP(KK),STLONP(KK),STDIRP(KK),
C 1 STSPDP(KK),STDAYP(KK),STRMXP(KK),STPCNP(KK),
C 2 STPENP(KK),STVMXP(KK),KK=-1,-NPRVMX,-1)
C 99 FORMAT(/'...FROM PRVSTM, KSTZ,KSTPZ,STLATP,STLONP,STDIRP,STSPDP,',
C 1 'STDAYP,STRMXP,STPCNP,STPENP,STVMXP=',2I3/(5X,9F10.2))
RETURN
C-----------------------------------------------------------------------
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: NEWVIT READS TROPICAL CYCLONE VITAL STAT. FILE
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: GENERAL FILE READER FOR TROPICAL CYCLONE VITAL STATISTICS
C FILE. CAN FIND ALL STORMS OF A PARTICULAR NAME OR ID, ALL
C STORMS ON A PARTICULAR DATE/TIME AND VARIOUS COMBINATIONS OF
C THE ABOVE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,
1 IHRREQ,IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,
2 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,
3 PTOP,FSTFLG,STMNAM,STMID,RSMC)
SAVE
DIMENSION RINC(5)
CHARACTER STMNAM*9,STMID*3,RSMC*4
LOGICAL FSTFLG
DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
1 STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
2 IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
3 PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
4 R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
5 STMID(MAXSTM),FSTFLG(MAXSTM)
PARAMETER (MAXCHR=95)
PARAMETER (MAXVIT=15)
PARAMETER (MAXTPC= 3)
CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,STMREQ*9,RELOCZ*1
CHARACTER BUFY2K*1
DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT),
1 ISTVAR(MAXVIT),IENVAR(MAXVIT),STMTOP(0:MAXTPC)
DIMENSION BUFIN(MAXCHR),FMTVIT(MAXVIT)
DIMENSION BUFY2K(MAXCHR)
EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
2 (BUFIN(37),LATNS),(BUFIN(43),LONEW),
3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ)
EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)
EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ),
1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ),
2 (VITVAR( 7),PCENZ), (VITVAR( 8),PENVZ),
3 (VITVAR( 9),RMAXZ), (VITVAR(10),VMAXZ),
4 (VITVAR(11),RMWZ), (VITVAR(12),R15NEZ),
5 (VITVAR(13),R15SEZ),(VITVAR(14),R15SWZ),
6 (VITVAR(15),R15NWZ)
DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/,
1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)',
2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/,
5 STMTOP/-99.0,700.,400.,200./
C FIVMIN IS FIVE MINUTES IN UNITS OF FRACTIONAL DAYS
DATA FIVMIN/3.4722E-3/,IRDERM/20/,NUM/1/
C THIS SUBROUTINE READS A GLOBAL VITAL STATISTICS FILE FOR
C TROPICAL CYCLONES. THERE ARE A NUMBER OF OPTIONS (IOPT)
C UNDER WHICH THIS ROUTINE WILL OPERATE:
C 1) FIND ALL STORMS ON A SPECIFIED DATE/TIME (+WINDOW)
C 2) FIND A PARTICULAR STORM NAME ON A SPECIFIED DATE/TIME
C (+WINDOW)
C 3) FIND ALL OCCURRENCES OF A PARTICULAR STORM NAME
C 4) SAME AS OPTION 2, EXCEPT FOR A PARTICULAR STORM ID
C 5) SAME AS OPTION 3, EXCEPT FOR A PARTICULAR STORM ID
C 6) ALL OCCURRENCES OF A PARTICULAR STORM NAME, EVEN
C BEFORE IT HAD A NAME (FIND FIRST OCCURRENCE OF
C STORM NAME, SUBSTITUE STORM ID, REWIND, THEN
C EXECUTE OPTION 5
C STORM ID POSITON CONTAINS THE BASIN IDENTIFIER IN THE
C LAST CHARACTER. THESE ABBREVIATIONS ARE:
C NORTH ATLANTIC: L
C EAST PACIFIC: E
C CENTRAL PACIFIC: C
C WEST PACIFIC: W
C AUSTRALIAN: U
C SOUTH INDIAN: S
C SOUTH PACIFIC P
C N ARABIAN SEA A
C BAY OF BENGAL B
C SOUTH CHINA SEA O
C EAST CHINA SEA T
C CHECK INPUT ARGUMENTS ACCORDING TO OPTION. ALSO DO OVERHEAD
C CHORES IF NECESSARY
IERVIT=0
STMREQ=' '
IYRREQ=-9999
IF(IOPT .LE. 2 .OR. IOPT .EQ. 4) THEN
IF(IDTREQ .LE. 0) THEN
WRITE(6,11) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
11 FORMAT(/'****** ILLEGAL DATE IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3)
IERVIT=10
ENDIF
IF(IHRREQ .LT. 0) THEN
WRITE(6,21) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
21 FORMAT(/'****** ILLEGAL HOUR IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3)
IERVIT=20
ENDIF
IF(IHRWIN .LT. 0) THEN
WRITE(6,31) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
31 FORMAT(/'****** ILLEGAL WINDOW IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3)
IERVIT=30
C SET UP PARAMETERS FOR TIME WINDOW
ELSE IF(IHRWIN .GT. 0) THEN
CALL ZTIME(IDTREQ,IHRREQ,IYRWIN,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYRWIN,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,
$ 0/),1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAY0)
C NORMAL CASE
WINDOW=REAL(IHRWIN)/24.
DAYPLS=DAY0+WINDOW+FIVMIN
DAYMNS=DAY0-WINDOW-FIVMIN
ENDIF
ENDIF
IF(IOPT .EQ. 2 .OR. IOPT .EQ. 3 .OR. IOPT .EQ. 6) THEN
IF(STMNAM(1) .EQ. ' ') THEN
WRITE(6,41) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
41 FORMAT(/'****** ILLEGAL STMNAM IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3)
IERVIT=40
ELSE
STMREQ=STMNAM(1)
ENDIF
ELSE IF(IOPT .EQ. 4 .OR. IOPT .EQ. 5) THEN
IF(STMID(1) .EQ. ' ') THEN
WRITE(6,51) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
51 FORMAT(/'****** ILLEGAL STMID IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3)
IERVIT=50
ELSE
STMREQ=STMID(1)
ENDIF
ELSE IF(IOPT .NE. 1) THEN
WRITE(6,61) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
61 FORMAT(/'****** ILLEGAL OPTION IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3)
IERVIT=60
ENDIF
C FOR OPTIONS 3, 5, 6 (ALL OCCURRENCES OPTIONS), SEARCH IS
C RESTRICTED TO A SPECIFIC YEAR when idtreq is positive
IF(IOPT .EQ. 3 .OR. IOPT .EQ. 5 .OR. IOPT .EQ. 6)
1 IYRREQ=IDTREQ/10000
C ****** ERROR EXIT ******
IF(IERVIT .GT. 0) RETURN
C INITIALIZE FILE AND COUNTERS
90 REWIND IOVITL
KREC=0
KSTORM=0
NERROR=0
C READ A RECORD INTO BUFFER
100 CONTINUE
READ(IOVITL,101,ERR=990,END=200) (BUFIN(NCH),NCH=1,MAXCHR)
101 FORMAT(95A1)
C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20
C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR
C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF
C LATITUDE N/S INDICATOR TO FIND OUT ...
IF(BUFIN(35).EQ.'N' .OR. BUFIN(35).EQ.'S') THEN
C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR
C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE
C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 2-digit year "',BUFIN(20:21),'"'
PRINT *, ' '
PRINT '(a,i0,a,a)', 'From unit ',iovitl,'; BUFIN-10: ',bufin
PRINT *, ' '
BUFY2K(1:19) = BUFIN(1:19)
IF(BUFIN(20)//BUFIN(21).GT.'20') THEN
BUFY2K(20) = '1'
BUFY2K(21) = '9'
ELSE
BUFY2K(20) = '2'
BUFY2K(21) = '0'
ENDIF
BUFY2K(22:95) = BUFIN(20:93)
BUFIN = BUFY2K
PRINT *, ' '
PRINT *, '==> 2-digit year converted to 4-digit year "',
$ BUFIN(20:23),'" via windowing technique'
PRINT *, ' '
PRINT *, 'From unit ',iovitl,'; BUFIN-10: ',bufin
PRINT *, ' '
ELSE IF(BUFIN(37).EQ.'N' .OR. BUFIN(37).EQ.'S') THEN
C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR
C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS
PRINT *, ' '
PRINT *, '==> Read in RECORD from tcvitals file -- contains a',
$ ' 4-digit year "',BUFIN(20:23),'"'
PRINT *, ' '
PRINT *, 'From unit ',iovitl,'; BUFIN-10: ',bufin
PRINT *, ' '
PRINT *, '==> No conversion necessary'
PRINT *, ' '
ELSE
PRINT *, ' '
PRINT *, '***** Cannot determine if this record contains ',
$ 'a 2-digit year or a 4-digit year - skip it and try reading ',
$ 'the next record'
PRINT *, ' '
GO TO 100
END IF
KREC=KREC+1
C DECODE DATE AND TIME
DO IV=1,2
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
c WRITE(6,109) IV,ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,
c 1 FMTVIT(IV)
c 109 FORMAT(/'...DECODING VARIABLE #',I2,' ISTART,IEND,IVALUE,IER,',
c 1 'FMT=',2I4,I10,I3,2X,A10)
ENDDO
C FILTER OUT RECORDS THAT ARE NOT GATHERED BY CURRENT OPTION
C FIRST: DATE/TIME/WINDOW FILTER
IF(IOPT .LE. 2 .OR. IOPT .EQ. 4) THEN
C EXACT DATE/UTC ARE SPECIFIED
IF(IHRWIN .EQ. 0) THEN
C WRITE(6,117) IDATEZ,IUTCZ
C 117 FORMAT(/'...NO WINDOW OPTION: IDATEZ,IUTCZ=',2I10)
IF(IDTREQ .NE. IDATEZ) GO TO 100
IF(IHRREQ .NE. IUTCZ ) GO TO 100
ELSE
CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/)
$ ,1,RINC)
JDY = NINT(RINC(1))
CALL FLDAY(JDY,IHR,IMIN,DAYZ)
C WRITE(6,119) IYR,IMO,IDA,IHR,IMIN,JDY,DAYZ,DAYMNS,DAYPLS,IYRMNS
C 119 FORMAT('...DEBUGGING WINDOW TIME SELECTION: IYR,IMO,IDA,IHR,',
C 1 'IMIN,JDY,DAYZ,DAYMNS,DAYPLS,IYRMNS='/15X,6I5,3F12.4,I5)
C YEAR WINDOW, THEN FRACTIONAL JULIAN DAY WINDOW
IF(IYR .NE. IYRWIN) GO TO 100
IF(DAYZ .LT. DAYMNS .OR. DAYZ .GT. DAYPLS) GO TO 100
ENDIF
ENDIF
C SECOND: STORM NAME FILTER
IF(IOPT .EQ. 2 .OR. IOPT .EQ. 3 .OR. IOPT .EQ. 6) THEN
IF(IPRNT .GT. 0) WRITE(6,123) STMNMZ,STMREQ
123 FORMAT('...STORM NAME FILTER, STMNMZ,STMREQ=',A9,2X,A9)
IF(STMNMZ .NE. STMREQ) GO TO 100
IF(IOPT .EQ. 3 .OR. IOPT .EQ. 6) then
if(iyrreq .gt. 0 .and. IDATEZ/10000 .NE. IYRREQ) go to 100
endif
C FOR OPTION 6, BRANCH BACK TO LOOK FOR STORM ID INSTEAD OF
C STORM NAME
IF(IOPT .EQ. 6) THEN
IOPT=5
STMREQ=STMIDZ
GO TO 90
ENDIF
ENDIF
C THIRD: STORM ID FILTER
IF(IOPT .EQ. 4 .AND. STMIDZ .NE. STMREQ) GO TO 100
IF(IOPT .EQ. 5 .AND. (STMIDZ .NE. STMREQ .OR. (iyrreq .gt. 0
1 .and. IDATEZ/10000 .NE. IYRREQ))) GO TO 100
C EUREKA
IF(IPRNT .GT. 0) WRITE(6,137) STMREQ,KREC
137 FORMAT('...REQUESTED STORM FOUND, NAME/ID=',A9,' AT RECORD #',I6)
DO IV=3,MAXVIT
CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
1 BUFINZ)
VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV)
ENDDO
C DEPTH OF CYCLONIC CIRCULATION
IF(STMDPZ .EQ. 'S') THEN
PTOPZ=STMTOP(1)
ELSE IF(STMDPZ .EQ. 'M') THEN
PTOPZ=STMTOP(2)
ELSE IF(STMDPZ .EQ. 'D') THEN
PTOPZ=STMTOP(3)
ELSE IF(STMDPZ .EQ. 'X') THEN
PTOPZ=-99.0
C WRITE(6,141) STMDPZ
C 141 FORMAT('******DEPTH OF CYCLONIC CIRCULATION HAS MISSING CODE=',A,
C 1 '.')
ELSE
WRITE(6,143) STMDPZ
143 FORMAT('******ERROR DECODING DEPTH OF CYCLONIC CIRCULATION, ',
1 'STMDPZ=',A1,'. ERROR RECOVERY NEEDED.')
ENDIF
C *****************************************************
C *****************************************************
C **** IMPORTANT NOTES: ****
C **** ****
C **** ALL STORM LONGITUDES CONVERTED TO ****
C **** 0-360 DEGREES, POSITIVE EASTWARD !!! ****
C **** ****
C **** ALL STORM SPEEDS ARE IN M/SEC ****
C **** ****
C **** ALL DISTANCE DATA ARE IN KM ****
C **** ****
C **** ALL PRESSURE DATA ARE IN HPA (MB) ****
C *****************************************************
C *****************************************************
C SIGN OF LATITUDE AND CONVERT LONGITUDE
IF(LATNS .EQ. 'S') THEN
STMLTZ=-STMLTZ
ELSE IF(LATNS .NE. 'N') THEN
WRITE(6,153) STMLTZ,STMLNZ,LATNS
153 FORMAT('******ERROR DECODING LATNS, ERROR RECOVERY NEEDED. ',
1 'STMLTZ,STMLNZ,LATNS=',2F12.2,2X,A1)
GO TO 100
ENDIF
IF(LONEW .EQ. 'W') THEN
STMLNZ=360.-STMLNZ
ELSE IF(LONEW .NE. 'E') THEN
WRITE(6,157) STMLTZ,STMLNZ,LATNS
157 FORMAT('******ERROR DECODING LONEW, ERROR RECOVERY NEEDED. ',
1 'STMLTZ,STMLNZ,LATNS=',2F12.2,2X,A1)
ENDIF
IF(IPRNT .EQ. 1)
1 WRITE(6,161) IDATEZ,IUTCZ,STMLTZ,STMLNZ,STMDRZ,STMSPZ,PENVZ,
2 PCENZ,RMAXZ,VMAXZ,RMWZ,R15NEZ,R15SEZ,R15SWZ,R15NWZ
161 FORMAT('...ALL STORM DATA CALCULATED: IDATEZ,IUTCZ,STMLTZ,',
1 'STMLNZ,STMDRZ,STMSPZ,PENVZ,PCENZ,RMAXZ,VMAXZ,RMWZ,',
2 'R15NEZ,R15SEZ,R15SWZ,R15NWZ='/5X,2I10,13F8.2)
IF(KSTORM .LT. MAXSTM) THEN
KSTORM=KSTORM+1
IDATE(KSTORM)=IDATEZ
IUTC(KSTORM)=IUTCZ
PTOP(KSTORM)=PTOPZ
STMLAT(KSTORM)=STMLTZ
STMLON(KSTORM)=STMLNZ
STMDIR(KSTORM)=STMDRZ
STMSPD(KSTORM)=STMSPZ
STMNAM(KSTORM)=STMNMZ
STMID (KSTORM)=STMIDZ
RSMC (KSTORM)=RSMCZ
RMAX(KSTORM)=RMAXZ
PENV(KSTORM)=PENVZ
PCEN(KSTORM)=PCENZ
VMAX(KSTORM)=VMAXZ
RMW(KSTORM)=RMWZ
R15NE(KSTORM)=R15NEZ
R15SE(KSTORM)=R15SEZ
R15SW(KSTORM)=R15SWZ
R15NW(KSTORM)=R15NWZ
C SET THE FIRST OCCURRENCE FLAG IF PRESENT
IF(FSTFLZ .EQ. ':') THEN
FSTFLG(KSTORM)=.TRUE.
ELSE
FSTFLG(KSTORM)=.FALSE.
ENDIF
GO TO 100
ELSE
GO TO 300
ENDIF
200 CONTINUE
IF(KSTORM .GT. 0) THEN
C NORMAL RETURN HAVING FOUND REQUESTED STORM (S) AT DATE/TIME/WINDOW
IF(IPRNT .EQ. 1) WRITE(6,201) STMREQ,IDTREQ,IHRREQ,KSTORM,KREC
201 FORMAT(/'...FOUND STORM NAME/ID ',A12,' AT DATE, TIME=',I9,'/',
1 I5,' UTC IN VITALS FILE.'/4X,I5,' RECORDS FOUND. ',
2 'TOTAL NUMBER OF RECORDS READ=',I7)
RETURN
C UNABLE TO FIND REQUESTED STORM AT DATE/TIME/WINDOW
ELSE
IF(IOPT .EQ. 1) STMREQ='ALLSTORMS'
WRITE(6,207) IOPT,STMREQ,STMNMZ
207 FORMAT(/'**** OPTION=',I3,' CANNOT FIND STORM NAME/ID=',A9,
1 '... LAST STORM FOUND=',A9)
WRITE(6,209) IDATEZ,IDTREQ,IUTCZ,IHRREQ
209 FORMAT('**** CANNOT FIND REQUESTED DATE/TIME, (FOUND, ',
1 'REQUESTED) (DATE/TIME)=',4I10/)
IERVIT=210
RETURN
ENDIF
300 WRITE(6,301) KSTORM
301 FORMAT(/'******KSTORM EXCEEDS AVAILABLE SPACE, KSTORM=',I5)
RETURN
990 WRITE(6,991) BUFIN
991 FORMAT('******ERROR READING STORM RECORD. BUFIN IS:'/' ******',A,
1 '******')
NERROR=NERROR+1
IF(NERROR .LE. IRDERM) GO TO 100
IERVIT=990
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: DECVAR DECODES VARIALES
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2004-06-08
C
C ABSTRACT: DECODES A PARTICULAR INTEGER VARIABLE FROM AN INPUT
C CHARACTER- BASED RECORD IN THE TROPICAL CYCLONE VITAL STATISTICS
C FILE. THIS IS DONE THROUGH AN INTERNAL READ.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C 2004-06-08 D. A. KEYSER - WHEN INTEGER VALUES ARE DECODED FROM
C CHARACTER-BASED RECORD VIA INTERNAL READ IN THIS SUBR.,
C IF BYTE IN UNITS DIGIT LOCATION IS ERRONEOUSLY CODED AS
C BLANK (" "), IT IS REPLACED WITH A "5" IN ORDER TO
C PREVENT INVALID VALUE FROM BEING RETURNED (I.E., IF
C "022 " WAS READ, IT WAS DECODED AS "22", IT IS NOW
C DECODED AS "225" - THIS HAPPENED FOR VALUE OF RADIUS OF
C LAST CLOSED ISOBAR FOR JTWC RECORDS FROM 13 JULY 2000
C THROUGH FNMOC FIX ON 26 MAY 2004 - THE VALUE WAS REPLACED
C BY CLIMATOLOGY BECAUSE IT FAILED A GROSS CHECK, HAD THIS
C CHANGE BEEN IN PLACE THE DECODED VALUE WOULD HAVE BEEN
C W/I 0.5 KM OF THE ACTUAL VALUE)
C
C USAGE: CALL DECVAR(ISTART,IEND,IVALUE,IERDEC,FMT,BUFF)
C INPUT ARGUMENT LIST:
C ISTART - INTEGER BYTE IN BUFF FROM WHICH TO BEGIN INTERNAL READ
C IEND - INTEGER BYTE IN BUFF FROM WHICH TO END INTERNAL READ
C FMT - CHARACTER*(*) FORMAT TO USE FOR INTERNAL READ
C BUFF - CHARACTER*(*) TROPICAL CYCLONE RECORD
C
C OUTPUT ARGUMENT LIST:
C IVALUE - INTEGER VALUE DECODED FROM BUFF
C IERDEC - ERROR RETURN CODE (= 0 - SUCCESSFUL DECODE,
C =10 - DECODE ERROR)
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: IF IERDEC = 10, IVALUE IS RETURNED AS -9, -99, -999
C OR -9999999 DEPENDING UPON THE VALUE OF FMT.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE DECVAR(ISTART,IEND,IVALUE,IERDEC,FMT,BUFF)
PARAMETER (NCHLIN=130)
CHARACTER FMT*(*),BUFF*(*),BUFF_save*130,OUTLIN*1
SAVE
DIMENSION OUTLIN(NCHLIN)
DIMENSION MISSNG(2:8)
DATA MISSNG/-9,-99,-999,-9999,-99999,-999999,-9999999/
C WRITE(6,1) FMT,ISTART,IEND,BUFF
C 1 FORMAT(/'...FMT,ISTART,IEND=',A10,2I5/' ...BUFF=',A,'...')
IF(BUFF(IEND:IEND).EQ.' ') THEN
BUFF_save = BUFF
BUFF(IEND:IEND) = '5'
WRITE(6,888) IEND
888 FORMAT(/' ++++++DECVAR: WARNING -- BLANK (" ") CHARACTER READ IN',
1 ' UNITS DIGIT IN BYTE',I4,' OF RECORD - CHANGE TO "5" ',
2 'AND CONTINUE DECODE'/)
OUTLIN=' '
OUTLIN(IEND:IEND)='5'
WRITE(6,'(130A1)') OUTLIN
WRITE(6,'(A130/)') BUFF_save(1:130)
ENDIF
READ(BUFF(ISTART:IEND),FMT,ERR=10) IVALUE
IERDEC=0
RETURN
10 CONTINUE
OUTLIN=' '
OUTLIN(ISTART:IEND)='*'
IVALUE = -9999999
K = IEND - ISTART + 1
IF(K.GT.1 .AND. K.LT.9) IVALUE = MISSNG(K)
WRITE(6,31) OUTLIN
WRITE(6,32) BUFF(1:130),IVALUE
31 FORMAT(/' ******DECVAR: ERROR DECODING, BUFF='/130A1)
32 FORMAT(A130/7X,'VALUE RETURNED AS ',I9/)
IERDEC=10
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: TIMSUB PERFORMS TIME CHORES
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-06-05
C
C ABSTRACT: VARIOUS ENTRIES CONVERT 8 DIGIT YYYYMMDD INTO YEAR, MONTH
C AND DAY, AND FRACTIONAL JULIAN DAY FROM INTEGER JULIAN DAY, HOUR
C AND MINUTE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C 1998-06-05 D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE: CALL TIMSUB(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,JDY,DAY)
C CALL FLDAY(JDY,IHR,IMIN,DAY)
C INPUT ARGUMENT LIST:
C IDATE - DATE IN FORM YYYYMMDD
C JDY - NUMBER OF DAYS SINCE 12/31/1899
C
C OUTPUT ARGUMENT LIST:
C IYR - YEAR IN FORM YYYY
C IMO - MONTH OF YEAR
C IDA - DAY OF MONTH
C IHR - HOUR OF DAY
C IMIN - MINUTE OF HOUR
C DAY - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE TIMSUB(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,JDY,DAY)
C-----------------------------------------------------------------------
ENTRY ZTIME(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN)
C PARSE 8 DIGIT YYYYMMDD INTO YEAR MONTH AND DAY
IYR = IDATE/10000
IMO =(IDATE-IYR*10000)/100
IDA = IDATE-IYR*10000-IMO*100
IHR =IUTC/100
IMIN=IUTC-IHR*100
RETURN
C-----------------------------------------------------------------------
C THIS ENTRY CALCULATES THE FRACTIONAL JULIAN DAY FROM INTEGERS
C JULIAN DAY, HOUR AND MINUTE (ACUALLY, JDY HERE IS NO. OF DAYS
C SINCE 12/31/1899)
ENTRY FLDAY(JDY,IHR,IMIN,DAY)
DAY=REAL(JDY)+(REAL(IHR)*60.+REAL(IMIN))/1440.
RETURN
C-----------------------------------------------------------------------
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: YTIME GETS INTEGER YYYY, YYYYMMDD, HHMM
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-10-29
C
C ABSTRACT: CALCULATES 8-DIGIT INTEGER YYYYMMDD, 4-DIGIT INTEGER YYYY,
C AND 6-DIGIT INTEGER HHMMSS FROM FRACTIONAL NUMBER OF DAYS SINCE
C 12/31/1899
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C 1998-10-29 D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE: CALL YTIME(IYR,DAYZ,IDATE,JUTC)
C INPUT ARGUMENT LIST:
C DAYZ - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899
C
C OUTPUT ARGUMENT LIST:
C IYR - YEAR (YYYY)
C IDATEZ - DATE IN FORM YYYYMMDD
C JUTC - DATE IN FORM HHMMSS
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE YTIME(IYR,DAYZ,IDATE,JUTC)
DIMENSION JDAT(8)
CALL W3MOVDAT((/DAYZ,0.,0.,0.,0./),(/1899,12,31,0,0,0,0,0/),JDAT)
IYR = JDAT(1)
IMO = JDAT(2)
IDA = JDAT(3)
IHR = JDAT(5)
IMN = JDAT(6)
ISC = JDAT(7)
IDATE=IDA+(100*IMO)+(10000*IYR)
JUTC =ISC+100*IMN+10000*IHR
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: SORTRL SORTS REAL NUMBERS
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-04
C
C ABSTRACT: SORTS REAL NUMBERS. OUTPUT ARRAY IS THE INDEX OF
C THE INPUT VALUES THAT ARE SORTED.
C
C PROGRAM HISTORY LOG:
C 1991-06-04 S. J. LORD (MODIFIED FROM NCAR CODE)
C
C USAGE: CALL SORTRL(A,LA,NL)
C INPUT ARGUMENT LIST:
C A - ARRAY OF ELEMENTS TO BE SORTED.
C NL - NUMBER OF ELEMENTS TO BE SORTED.
C
C OUTPUT ARGUMENT LIST:
C LA - INTEGER ARRAY CONTAINING THE INDEX OF THE SORTED
C - ELEMENTS. SORTING IS FROM SMALL TO LARGE. E.G.
C - LA(1) CONTAINS THE INDEX OF THE SMALLEST ELEMENT IN
C - ARRAY. LA(NL) CONTAINS THE INDEX OF THE LARGEST.
C
C
C REMARKS: NONE
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE SORTRL(A,LA,NL)
C ENTRY SORTRL(A,LA,NL) SORT UP REAL NUMBERS
C ** REVISED (6/13/84) FOR THE USE IN VAX-11
C ARGUMENTS ...
C A INPUT ARRAY OF NL ELEMENTS TO BE SORTED OR RE-ORDERED
C LA OUTPUT ARRAY OF NL ELEMENTS IN WHICH THE ORIGINAL LOCATION
C OF THE SORTED ELEMENTS OF A ARE SAVED, OR
C INPUT ARRAY TO SPECIFY THE REORDERING OF ARRAY A BY SORTED
C NL THE NUMBER OF ELEMENTS TO BE TREATED
SAVE
DIMENSION A(NL),LA(NL),LS1(64),LS2(64)
DATA NSX/64/
C SET THE ORIGINAL ORDER IN LA
DO L=1,NL
LA(L)=L
ENDDO
C SEPARATE NEGATIVES FROM POSITIVES
L = 0
M = NL + 1
12 L = L + 1
IF(L.GE.M) GO TO 19
IF(A(L)) 12,15,15
15 M = M - 1
IF(L.GE.M) GO TO 19
IF(A(M)) 18,15,15
18 AZ = A(M)
A(M) = A(L)
A(L) = AZ
LZ = LA(M)
LA(M) = LA(L)
LA(L) = LZ
GO TO 12
19 L = L - 1
C NOTE THAT MIN AND MAX FOR INTERVAL (1,NL) HAVE NOT BEEN DETERMINED
LS1(1) = 0
L2 = NL + 1
NS = 1
C STEP UP
20 LS1(NS) = LS1(NS) + 1
LS2(NS) = L
NS = NS + 1
IF(NS.GT.NSX) GO TO 80
L1 = L + 1
LS1(NS) = L1
L2 = L2 - 1
GO TO 40
C STEP DOWN
30 NS=NS-1
IF (NS.LE.0) GO TO 90
L1 = LS1(NS)
L2 = LS2(NS)
40 IF(L2.LE.L1) GO TO 30
C FIND MAX AND MIN OF THE INTERVAL (L1,L2)
IF (A(L1)-A(L2) .LE. 0) GO TO 52
AN = A(L2)
LN = L2
AX = A(L1)
LX = L1
GO TO 54
52 AN = A(L1)
LN = L1
AX = A(L2)
LX = L2
54 L1A = L1 + 1
L2A = L2 - 1
IF(L1A.GT.L2A) GO TO 60
DO L=L1A,L2A
IF (A(L)-AX .GT. 0) GO TO 56
IF (A(L)-AN .GE. 0) GO TO 58
AN = A(L)
LN = L
GO TO 58
56 AX = A(L)
LX = L
58 CONTINUE
ENDDO
C IF ALL ELEMENTS ARE EQUAL (AN=AX), STEP DOWN
60 IF (AN .EQ. AX) GO TO 30
C PLACE MIN AT L1, AND MAX AT L2
C IF EITHER LN=L2 OR LX=L1, FIRST EXCHANGE L1 AND L2
IF(LN.EQ.L2.OR.LX.EQ.L1) GO TO 62
GO TO 64
62 AZ=A(L1)
A(L1)=A(L2)
A(L2)=AZ
LZ=LA(L1)
LA(L1)=LA(L2)
LA(L2)=LZ
C MIN TO L1, IF LN IS NOT AT EITHER END
64 IF(LN.EQ.L1.OR.LN.EQ.L2) GO TO 66
A(LN)=A(L1)
A(L1)=AN
LZ=LA(LN)
LA(LN)=LA(L1)
LA(L1)=LZ
C MAX TO L2, IF LX IS NOT AT EITHER END
66 IF(LX.EQ.L2.OR.LX.EQ.L1) GO TO 68
A(LX)=A(L2)
A(L2)=AX
LZ=LA(LX)
LA(LX)=LA(L2)
LA(L2)=LZ
C IF ONLY THREE ELEMENTS IN (L1,L2), STEP DOWN.
68 IF(L1A.GE.L2A) GO TO 30
C SET A CRITERION TO SPLIT THE INTERVAL (L1A,L2A)
C AC IS AN APPROXIMATE ARITHMETIC AVERAGE OF AX AND AN,
C PROVIDED THAT AX IS GREATER THAN AN. (IT IS THE CASE, HERE)
C ** IF A IS DISTRIBUTED EXPONENTIALLY, GEOMETRIC MEAN MAY
C BE MORE EFFICIENT
AC = (AX+AN)/2
C MIN AT L1 AND MAX AT L2 ARE OUTSIDE THE INTERVAL
L = L1
M = L2
72 L = L + 1
IF(L.GE.M) GO TO 78
cc 73 CONTINUE
IF (A(L)-AC .LE. 0) GO TO 72
75 M = M - 1
IF(L.GE.M) GO TO 78
cc 76 CONTINUE
IF (A(M)-AC .GT. 0) GO TO 75
AZ = A(M)
A(M) = A(L)
A(L) = AZ
LZ = LA(M)
LA(M) = LA(L)
LA(L) = LZ
GO TO 72
C SINCE 75 IS ENTERED ONLY IF 73 IS FALSE, 75 IS NOT TENTATIVE
C BUT 72 IS TENTATIVE, AND MUST BE CORRECTED IF NO FALSE 76 OCCURS
78 L = L - 1
GO TO 20
80 WRITE(6,85) NSX
85 FORMAT(/' === SORTING INCOMPLETE. SPLIT EXCEEDED',I3,' ==='/)
90 RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: DS2UV CONVERTS DIRECTION/SPEED TO U/V MOTION
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: CONVERTS DIRECTION AND SPEED TO ZONAL AND MERIDIONAL
C MOTION.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE DS2UV(UZ,VZ,DIRZ,SPDZ)
C THIS SUBROUTINE PRODUCES U, V CARTESIAN WINDS FROM DIRECTION,SPEED
C ****** IMPORTANT NOTE: DIRECTION IS DIRECTION WIND IS
C BLOWING, THE OPPOSITE OF METEOROLOGICAL CONVENTION ***
UZ=SPDZ*SIND(DIRZ)
VZ=SPDZ*COSD(DIRZ)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: ATAN2D ARC TAN FUNCTION FROM DEGREES INPUT
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: ARC TAN FUNCTION FROM DEGREES INPUT.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
FUNCTION ATAN2D(ARG1,ARG2)
C DEGRAD CONVERTS DEGREES TO RADIANS
DATA DEGRAD/0.017453/
IF(ARG1 .EQ. 0.0 .AND. ARG2 .EQ. 0.0) THEN
ATAN2D=0.0
ELSE
ATAN2D=ATAN2(ARG1,ARG2)/DEGRAD
ENDIF
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: SIND SINE FUNCTION FROM DEGREES INPUT
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: SINE FUNCTION FROM DEGREES INPUT.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
FUNCTION SIND(ARG)
C DEGRAD CONVERTS DEGREES TO RADIANS
DATA DEGRAD/0.017453/
SIND=SIN(ARG*DEGRAD)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: COSD COSINE FUNCTION FROM DEGREES INPUT
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: RETURNS COSINE FUNCTION FROM DEGREES INPUT
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
FUNCTION COSD(ARG)
C DEGRAD CONVERTS DEGREES TO RADIANS
DATA DEGRAD/0.017453/
COSD=COS(ARG*DEGRAD)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: DISTSP DISTANCE ON GREAT CIRCLE
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: CALCULATES DISTANCE ON GREAT CIRCLE BETWEEN TWO LAT/LON
C POINTS.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: DXY=DISTSP(DLAT1,DLON1,DLAT2,DLON2)
C INPUT ARGUMENT LIST:
C DLAT1 - LATITUDE OF POINT 1 (-90<=LAT<=90)
C DLON1 - LONGITUDE OF POINT 1 (-180 TO 180 OR 0 TO 360)
C DLAT2 - LATITUDE OF POINT 2 (-90<=LAT<=90)
C DLON1 - LONGITUDE OF POINT 2
C
C
C REMARKS: DISTANCE IS IN METERS
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
FUNCTION DISTSP(DLAT1,DLON1,DLAT2,DLON2)
DATA REARTH/6.37E6/
XXD=COSD(DLON1-DLON2)*COSD(DLAT1)*COSD(DLAT2)+
1 SIND(DLAT1)*SIND(DLAT2)
XXM=AMIN1(1.0,AMAX1(-1.0,XXD))
DISTSP=ACOS(XXM)*REARTH
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AVGSUB CALCULATES AVERAGES
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06
C
C ABSTRACT: CALCULATES AVERAGES WEIGHTED AND UNWEIGHTED FOR ALL
C INPUT NUMBERS OR JUST POSITIVE ONES.
C
C PROGRAM HISTORY LOG:
C 1991-06-06 S. J. LORD
C
C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C INPUT ARGUMENT LIST:
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE AVGSUB(XX,WT,LX,AVX)
DIMENSION XX(LX),WT(LX)
AVX=0.0
N=0
DO L=1,LX
AVX=AVX+XX(L)
N=N+1
ENDDO
AVX=AVX/REAL(N)
RETURN
C-----------------------------------------------------------------------
ENTRY WTAVRG(XX,WT,LX,AVX)
AVX=0.0
W=0.0
DO L=1,LX
AVX=AVX+XX(L)*WT(L)
W=W+WT(L)
ENDDO
AVX=AVX/W
RETURN
C-----------------------------------------------------------------------
ENTRY WTAVGP(XX,WT,LX,AVX)
AVX=0.0
W=0.0
DO L=1,LX
IF(XX(L) .GE. 0.0) THEN
AVX=AVX+XX(L)*WT(L)
W=W+WT(L)
ENDIF
ENDDO
IF(W .NE. 0.0) THEN
AVX=AVX/W
ELSE
AVX=XX(1)
ENDIF
RETURN
C-----------------------------------------------------------------------
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: ABORT1 ERROR EXIT ROUTINE
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-05
C
C ABSTRACT: ERROR TERMINATION ROUTINE THAT LISTS ROUTINE WHERE
C ERROR OCCURRED AND THE NEAREST STATEMENT NUMBER.
C
C PROGRAM HISTORY LOG:
C 1991-06-05 S. J. LORD
C
C USAGE: CALL ABORT1(ME(KENTRY,ISTMT)
C INPUT ARGUMENT LIST:
C KENTRY - CHARACTER VARIABLE (*7) GIVING PROGRAM OR SUBROUTINE
C - WHERE ERROR OCCURRED.
C ISTMT - STATEMENT NUMBER NEAR WHERE ERROR OCCURRED.
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: THIS ROUTINE IS CALLED WHENEVER AN INTERNAL PROBLEM
C TO THE CODE IS FOUND. EXAMPLES ARE CALLING PARAMETERS THAT
C WILL OVERFLOW ARRAY BOUNDARIES AND OBVIOUS INCONSISTENCIES
C IN NUMBERS GENERATED BY THE CODE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE ABORT1(KENTRY,ISTMT)
CHARACTER*7 KENTRY
WRITE(6,10) KENTRY,ISTMT
10 FORMAT(//21X,'*********************************************'/
1 21X,'*********************************************'/
2 21X,'**** PROGRAM FAILED DUE TO FATAL ERROR ****'/
3 21X,'**** IN ROUTINE ',A,' NEAR ****'/
4 21X,'**** STATEMENT NUMBER',I5,'. ****'/
5 21X,'*********************************************'/
6 21X,'*********************************************')
CALL W3TAGE('SYNDAT_QCTROPCY')
call ERREXIT (20)
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: OFILE0 OPENS ALL DATA FILES LISTED IN TEXT FILE
C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-07
C
C ABSTRACT: OPENS ALL OF THE DATA FILES READ FROM A LIST IN A TEXT
C FILE.
C
C PROGRAM HISTORY LOG:
C 1991-06-07 S. J. LORD
C
C USAGE: CALL OFILE0(IUNTOP,NFILMX,NFTOT,FILNAM)
C INPUT ARGUMENT LIST:
C IUNTOP - UNIT NUMBER OF TEXT FILE ASSOCIATING UNIT NUMBERS
C - WITH FILE NAMES
C FILNAM - FILE NAMES (UPON INPUT ONLY ELEMENT 0 STORED -
C - THE FILE NAME ASSOCIATED WITH UNIT IUNTOP)
C NFILMX - THE MAXIMUM NUMBER OF FILES THAT CAN BE OPENED IN
C - THIS SUBROUTINE
C
C OUTPUT ARGUMENT LIST:
C NFTOT - NUMBER OF DATA FILES OPENED IN THIS SUBROUTINE
C
C INPUT FILES:
C UNIT "IUNTOP"
C - TEXT FILE ASSOCIATING UNIT NUMBERS WITH FILE NAMES
C MANY - READ FROM LIST IN UNIT IUNTOP
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C MACHINE: IBM-SP
C LANGUAGE: FORTRAN 90
C
C$$$
SUBROUTINE OFILE0(IUNTOP,NFILMX,NFTOT,FILNAM)
PARAMETER (IDGMAX=7)
SAVE
CHARACTER FILNAM*(*),CFORM*11,CSTAT*7,CACCES*10,MACHIN*10,
1 CFZ*1,CSTZ*1,CACZ*1,CPOS*10
DIMENSION IUNIT(NFILMX),CFORM(NFILMX),CSTAT(NFILMX),
1 CACCES(NFILMX),CPOS(NFILMX)
DIMENSION FILNAM(0:NFILMX)
INTEGER(4) IARGC,NDEF
NF=0
C DEFAULT FILENAME IS SPECIFIED BY THE CALLING PROGRAM.
C RUNNING THE PROGRAM WITH ARGUMENTS ALLOWS
C YOU TO SPECIFY THE FILENAM AS FOLLOWS:
NDEF=IARGC()
IF(NDEF .LT. 0) CALL GETARG(1_4,FILNAM(0))
LENG0=INDEX(FILNAM(0),' ')-1
WRITE(6,5) NDEF,FILNAM(0)(1:LENG0)
5 FORMAT(/'...SETTING UP TO READ I/O FILENAMES AND OPEN PARMS.',
1 ' NDEF,FILNAM(0)=',I2,1X,'...',A,'...')
OPEN(UNIT=IUNTOP,FORM='FORMATTED',STATUS='OLD',ACCESS=
1 'SEQUENTIAL',FILE=FILNAM(0)(1:leng0),ERR=95,IOSTAT=IOS)
READ(IUNTOP,11,ERR=90) MACHIN
11 FORMAT(A)
WRITE(6,13) MACHIN
13 FORMAT('...READY TO READ FILES TO OPEN ON MACHINE ',A)
DO IFILE=1,NFILMX
NF=NF+1
READ(IUNTOP,21,END=50,ERR=90,IOSTAT=IOS) IUNIT(NF),
1 CFZ,CSTZ,CACZ,FILNAM(NF)
21 FORMAT(I2,3(1X,A1),1X,A)
LENGTH=INDEX(FILNAM(NF),' ')-1
WRITE(6,23) NF,IUNIT(NF),CFZ,CSTZ,CACZ,FILNAM(NF)(1:LENGTH)
23 FORMAT('...FOR FILE #',I3,', READING IUNIT, ABBREVIATIONS CFZ',
1 ',CSTZ,CACZ='/4X,I3,3(1X,A,1X),5x,'...FILENAME=',A,'...')
c Interpret the abbreviations
if(CFZ .eq. 'f' .or. CFZ .eq. 'F') then
cform(nf)='FORMATTED'
else if(CFZ .eq. 'u' .or. CFZ .eq. 'U') then
cform(nf)='UNFORMATTED'
else
write(6,25) CFZ
25 format('******option ',a,' for format is not allowed. Abort')
call abort1(' OFILE0',25)
endif
if(CSTZ .eq. 'o' .or. CSTZ .eq. 'O') then
cstat(nf)='OLD'
else if(CSTZ .eq. 'n' .or. CSTZ .eq. 'N') then
cstat(nf)='NEW'
else if(CSTZ .eq. 'k' .or. CSTZ .eq. 'K') then
cstat(nf)='UNKNOWN'
else if(CSTZ .eq. 's' .or. CSTZ .eq. 'S') then
cstat(nf)='SCRATCH'
else
write(6,27) CSTZ
27 format('******option ',a,' for status is not allowed. Abort')
call abort1(' OFILE0',27)
endif
cpos(nf)=' '
if(CACZ .eq. 'd' .or. CACZ .eq. 'D') then
cacces(nf)='DIRECT'
else if(CACZ .eq. 'q' .or. CACZ .eq. 'Q') then
cacces(nf)='SEQUENTIAL'
else if(CACZ .eq. 'a' .or. CACZ .eq. 'A') then
cacces(nf)='APPEND'
else if(CACZ .eq. 's' .or. CACZ .eq. 'S') then
cacces(nf)='SEQUENTIAL'
cpos(nf)='APPEND'
else if(CACZ .eq. 't' .or. CACZ .eq. 'T') then
cacces(nf)='DIRECT'
cpos(nf)='APPEND'
else
write(6,29) CACZ
29 format('******option ',a,' for access is not allowed. Abort')
call abort1(' OFILE0',29)
endif
IF(CACCES(NF) .NE. 'DIRECT') THEN
if(cpos(nf) .eq. ' ') then
if (cstat(nf).eq.'OLD') then
OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS='OLD',
1 ACCESS=cacces(nf),FILE=FILNAM(NF)(1:LENGTH),
2 ERR=95,IOSTAT=IOS)
elseif (cstat(nf).eq.'NEW') then
OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS='NEW',
1 ACCESS=cacces(nf),FILE=FILNAM(NF)(1:LENGTH),
2 ERR=95,IOSTAT=IOS)
elseif (cstat(nf).eq.'UNKNOWN') then
OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS='UNKNOWN',
1 ACCESS=cacces(nf),FILE=FILNAM(NF)(1:LENGTH),
2 ERR=95,IOSTAT=IOS)
else
OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS=cstat(nf),
1 ACCESS=cacces(nf),
2 ERR=95,IOSTAT=IOS)
endif
else
if (cstat(nf).eq.'OLD') then
open(unit=iunit(nf),form=cform(nf),status='OLD',
1 access=cacces(nf),position=cpos(nf),
2 file=filnam(nf)(1:length),err=95,iostat=ios)
elseif (cstat(nf).eq.'NEW') then
open(unit=iunit(nf),form=cform(nf),status='NEW',
1 access=cacces(nf),position=cpos(nf),
2 file=filnam(nf)(1:length),err=95,iostat=ios)
elseif (cstat(nf).eq.'UNKNOWN') then
open(unit=iunit(nf),form=cform(nf),status='UNKNOWN',
1 access=cacces(nf),position=cpos(nf),
2 file=filnam(nf)(1:length),err=95,iostat=ios)
else
open(unit=iunit(nf),form=cform(nf),status=cstat(nf),
1 access=cacces(nf),position=cpos(nf),
2 err=95,iostat=ios)
endif
endif
ELSE
read(filnam(nf)(length+2:length+2+idgmax-1),37) lrec
37 format(i7)
write(6,39) lrec
39 format('...Direct access record length:',i7,'...')
if(cpos(nf) .eq. ' ') then
if (cstat(nf).eq.'OLD') then
OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS='OLD',
1 ACCESS=CACCES(NF),FILE=FILNAM(NF)(1:LENGTH),
2 ERR=95,IOSTAT=IOS,RECL=lrec)
elseif (cstat(nf).eq.'NEW') then
OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS='NEW',
1 ACCESS=CACCES(NF),FILE=FILNAM(NF)(1:LENGTH),
2 ERR=95,IOSTAT=IOS,RECL=lrec)
elseif (cstat(nf).eq.'UNKNOWN') then
OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS='UNKNOWN',
1 ACCESS=CACCES(NF),FILE=FILNAM(NF)(1:LENGTH),
2 ERR=95,IOSTAT=IOS,RECL=lrec)
else
OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS=CSTAT(NF),
1 ACCESS=CACCES(NF),
2 ERR=95,IOSTAT=IOS,RECL=lrec)
endif
else
if (cstat(nf).eq.'OLD') then
open(unit=iunit(nf),form=cform(nf),status='OLD',
1 access=cacces(nf),file=filnam(nf)(1:length),
2 position=cpos(nf),err=95,iostat=ios,recl=lrec)
elseif (cstat(nf).eq.'NEW') then
open(unit=iunit(nf),form=cform(nf),status='NEW',
1 access=cacces(nf),file=filnam(nf)(1:length),
2 position=cpos(nf),err=95,iostat=ios,recl=lrec)
elseif (cstat(nf).eq.'UNKNOWN') then
open(unit=iunit(nf),form=cform(nf),status='UNKNOWN',
1 access=cacces(nf),file=filnam(nf)(1:length),
2 position=cpos(nf),err=95,iostat=ios,recl=lrec)
else
open(unit=iunit(nf),form=cform(nf),status=cstat(nf),
1 access=cacces(nf),
2 position=cpos(nf),err=95,iostat=ios,recl=lrec)
endif
endif
ENDIF
ENDDO
WRITE(6,391) NFILMX
391 FORMAT('******NUMBER OF FILES TO BE OPENED MEETS OR EXCEEDS ',
1 'MAXIMUM SET BY PROGRAM (=',I3)
CALL ABORT1(' OFILE0',50)
50 CONTINUE
C WE HAVE DEFINED AND OPENED ALL FILES
NFTOT=NF-1
WRITE(6,51) NFTOT,MACHIN
51 FORMAT(/'...SUCCESSFULLY OPENED ',I3,' FILES ON ',A)
RETURN
90 CONTINUE
WRITE(6,91) FILNAM(0)(1:leng0),ios
91 FORMAT('******ERROR READING OPEN FILE=',A,' error=',i4)
CALL ABORT1(' OFILE0',91)
95 CONTINUE
WRITE(6,96) NF,IOS
96 FORMAT('******ERROR UPON OPENING FILE, NF,IOS=',2I5)
CALL ABORT1(' OFILE0',96)
END