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. 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 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 OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS=cstat(nf), 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),position=cpos(nf), 2 file=filnam(nf)(1:length),err=95,iostat=ios) 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 OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS=CSTAT(NF), 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),file=filnam(nf)(1:length), 2 position=cpos(nf),err=95,iostat=ios,recl=lrec) 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