C -------------------------------------------------------------- C ATCFLIB A collection of routines for reading C and processing ATCF files. C C V4.6 24 Aug 2018 C V4.6.1 13 Dec 2018 Adds BT read routine that returns C POCI (READ_ATCF_BESTP). C V4.9.1 02 Nov 2020 Reads EMH/I/2 as EMX/I/2. C -------------------------------------------------------------- C C -------------------------------------------------------------- SUBROUTINE READ_ATCF_BEST(LU,IERR,NCYC,IYEAR,IMO,IDY,IHR, * RLAT,RLON,IWS,IPR,STATUS) C C Reads a line from the best track file and returns basic info. C -------------------------------------------------------------- C PARAMETER (LINE_LENGTH=100) C DIMENSION ICOM(24) CHARACTER*1 ALAT, ALON CHARACTER*2 BASIN, STATUS CHARACTER*100 LINE C JC = 0 IERR = 0 NCYC = -999 IYEAR = -999 IMO = -999 IDY = -999 IHR = -999 ILAT = -999 ILON = -999 IWS = -999 IPR = -999 ALAT = ' ' ALON = ' ' STATUS = ' ' C C C Read line from file C ------------------- READ(LU,'(A)',ERR=900,END=910) LINE C C C Search for all the commas that delimit the data fields. C ------------------------------------------------------- DO 100 L=1,24 105 JC = JC+1 IF (JC.GT.LINE_LENGTH) GOTO 110 IF (LINE(JC:JC).EQ.',') THEN ICOM(L) = JC NCOM = L ELSE GOTO 105 ENDIF 100 CONTINUE C C C Extract information C ------------------- 110 CONTINUE IF (NCOM.LT.11 .AND. NCOM.NE.8) GOTO 900 C IF (NCOM.LT.11) GOTO 900 IB = 1 IE = ICOM(1)-1 READ(LINE(IB:IE),'(A)') BASIN IB = ICOM(1)+1 IE = ICOM(2)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) NCYC IB = ICOM(2)+1 IE = ICOM(3)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,I4,3I2)') * IYEAR,IMO,IDY,IHR IB = ICOM(6)+1 IE = ICOM(7)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I4,A1)') ILAT,ALAT IB = ICOM(7)+1 IE = ICOM(8)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I5,A1)') ILON,ALON IB = ICOM(8)+1 C C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (NCOM.EQ.8) THEN IE = IB+3 ELSE IE = ICOM(9)-1 ENDIF C IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IWS IF (NCOM.EQ.8) GOTO 150 IB = ICOM(9)+1 IE = ICOM(10)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IPR IB = ICOM(10)+1 IE = ICOM(11)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,A2)') STATUS C 150 IF (ILAT.EQ.-999 .OR. ILON.EQ.-999) THEN RLAT = -999. RLON = -999. ELSE IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT = FLOAT(ILAT)/10. RLON = FLOAT(ILON)/10. ENDIF C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (STATUS.EQ.' ' .AND. IWS.LT.34) STATUS = 'TD' IF (STATUS.EQ.' ' .AND. IWS.GE.34) STATUS = 'EX' IF (STATUS.EQ.' ') STATUS = 'XX' C RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE READ_ATCF_BESTT(LU,IERR,NCYC,IYEAR,IMO,IDY,IHR, * RLAT,RLON,IWS,IPR,IRAD,IRADQ,STATUS) C C Reads a line from the best track file and returns basic info. C Modified to return wind radii information 11/03 JLF. C -------------------------------------------------------------- C PARAMETER (LINE_LENGTH=100) C DIMENSION ICOM(24) DIMENSION IRADQ(4) CHARACTER*1 ALAT, ALON CHARACTER*2 BASIN, STATUS CHARACTER*3 WINDCODE CHARACTER*100 LINE C JC = 0 IERR = 0 NCYC = -999 IYEAR = -999 IMO = -999 IDY = -999 IHR = -999 ILAT = -999 ILON = -999 IWS = -999 IPR = -999 ALAT = ' ' ALON = ' ' STATUS = ' ' IRAD = -999 DO 50 L=1,4 50 IRADQ(L) = -999 C C C Read line from file C ------------------- READ(LU,'(A)',ERR=900,END=910) LINE C C C Search for all the commas that delimit the data fields. C ------------------------------------------------------- DO 100 L=1,24 105 JC = JC+1 IF (JC.GT.LINE_LENGTH) GOTO 110 IF (LINE(JC:JC).EQ.',') THEN ICOM(L) = JC NCOM = L ELSE GOTO 105 ENDIF 100 CONTINUE C C C Extract information C ------------------- 110 CONTINUE IF (NCOM.LT.17 .AND. NCOM.NE.8) GOTO 900 IB = 1 IE = ICOM(1)-1 READ(LINE(IB:IE),'(A)') BASIN IB = ICOM(1)+1 IE = ICOM(2)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) NCYC IB = ICOM(2)+1 IE = ICOM(3)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,I4,3I2)') * IYEAR,IMO,IDY,IHR IB = ICOM(6)+1 IE = ICOM(7)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I4,A1)') ILAT,ALAT IB = ICOM(7)+1 IE = ICOM(8)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I5,A1)') ILON,ALON IB = ICOM(8)+1 C C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (NCOM.EQ.8) THEN IE = IB+3 ELSE IE = ICOM(9)-1 ENDIF C IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IWS IF (NCOM.EQ.8) GOTO 150 IB = ICOM(9)+1 IE = ICOM(10)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IPR IB = ICOM(10)+1 IE = ICOM(11)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,A2)') STATUS IB = ICOM(11)+1 IE = ICOM(12)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IRAD IF (IRAD.NE.34 .AND. IRAD.NE.50 .AND. IRAD.NE.64) GOTO 150 IB = ICOM(12)+1 IE = ICOM(13)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,A3)') WINDCODE IF (WINDCODE.EQ.'NEQ') THEN DO 130 L = 1,4 IX = 12 IB = ICOM(IX+L)+1 IE = ICOM(IX+L+1)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IRADQ(L) 130 CONTINUE ENDIF IF (WINDCODE.EQ.'AAA') THEN IX = 13 IB = ICOM(IX)+1 IE = ICOM(IX+1)-1 IF (LINE(IE:IE).NE.' ') THEN READ(LINE(IB:IE),*) IRADQ(1) IRADQ(2) = IRADQ(1) IRADQ(3) = IRADQ(1) IRADQ(4) = IRADQ(1) ENDIF ENDIF C 150 IF (ILAT.EQ.-999 .OR. ILON.EQ.-999) THEN RLAT = -999. RLON = -999. ELSE IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT = FLOAT(ILAT)/10. RLON = FLOAT(ILON)/10. ENDIF C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (STATUS.EQ.' ' .AND. IWS.LT.34) STATUS = 'TD' IF (STATUS.EQ.' ' .AND. IWS.GE.34) STATUS = 'EX' IF (STATUS.EQ.' ') STATUS = 'XX' C RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE READ_ATCF_BESTM(LU,IERR,NCYC,IYEAR,IMO,IDY,IHR,IMI, * RLAT,RLON,IWS,IPR,IRAD,IRADQ,STATUS) C C Reads a line from the best track file and returns basic info. C Modified to return minutes 07/10 JLF. C -------------------------------------------------------------- C PARAMETER (LINE_LENGTH=100) C DIMENSION ICOM(24) DIMENSION IRADQ(4) CHARACTER*1 ALAT, ALON CHARACTER*2 BASIN, STATUS CHARACTER*3 WINDCODE CHARACTER*100 LINE C JC = 0 IERR = 0 NCYC = -999 IYEAR = -999 IMO = -999 IDY = -999 IHR = -999 IMI = -999 ILAT = -999 ILON = -999 IWS = -999 IPR = -999 ALAT = ' ' ALON = ' ' STATUS = ' ' IRAD = -999 DO 50 L=1,4 50 IRADQ(L) = -999 C C C Read line from file C ------------------- READ(LU,'(A)',ERR=900,END=910) LINE C C C Search for all the commas that delimit the data fields. C ------------------------------------------------------- DO 100 L=1,24 105 JC = JC+1 IF (JC.GT.LINE_LENGTH) GOTO 110 IF (LINE(JC:JC).EQ.',') THEN ICOM(L) = JC NCOM = L ELSE GOTO 105 ENDIF 100 CONTINUE C C C Extract information C ------------------- 110 CONTINUE IF (NCOM.LT.17 .AND. NCOM.NE.8) GOTO 900 IB = 1 IE = ICOM(1)-1 READ(LINE(IB:IE),'(A)') BASIN IB = ICOM(1)+1 IE = ICOM(2)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) NCYC IB = ICOM(2)+1 IE = ICOM(3)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,I4,3I2)') * IYEAR,IMO,IDY,IHR IB = ICOM(3)+1 IE = ICOM(4)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IMI IB = ICOM(6)+1 IE = ICOM(7)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I4,A1)') ILAT,ALAT IB = ICOM(7)+1 IE = ICOM(8)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I5,A1)') ILON,ALON IB = ICOM(8)+1 C C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (NCOM.EQ.8) THEN IE = IB+3 ELSE IE = ICOM(9)-1 ENDIF C IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IWS IF (NCOM.EQ.8) GOTO 150 IB = ICOM(9)+1 IE = ICOM(10)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IPR IB = ICOM(10)+1 IE = ICOM(11)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,A2)') STATUS IB = ICOM(11)+1 IE = ICOM(12)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IRAD IF (IRAD.NE.34 .AND. IRAD.NE.50 .AND. IRAD.NE.64) GOTO 150 IB = ICOM(12)+1 IE = ICOM(13)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,A3)') WINDCODE IF (WINDCODE.EQ.'NEQ') THEN DO 130 L = 1,4 IX = 12 IB = ICOM(IX+L)+1 IE = ICOM(IX+L+1)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IRADQ(L) 130 CONTINUE ENDIF IF (WINDCODE.EQ.'AAA') THEN IX = 13 IB = ICOM(IX)+1 IE = ICOM(IX+1)-1 IF (LINE(IE:IE).NE.' ') THEN READ(LINE(IB:IE),*) IRADQ(1) IRADQ(2) = IRADQ(1) IRADQ(3) = IRADQ(1) IRADQ(4) = IRADQ(1) ENDIF ENDIF C 150 IF (ILAT.EQ.-999 .OR. ILON.EQ.-999) THEN RLAT = -999. RLON = -999. ELSE IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT = FLOAT(ILAT)/10. RLON = FLOAT(ILON)/10. ENDIF C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (STATUS.EQ.' ' .AND. IWS.LT.34) STATUS = 'TD' IF (STATUS.EQ.' ' .AND. IWS.GE.34) STATUS = 'EX' IF (STATUS.EQ.' ') STATUS = 'XX' C RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE READ_ATCF_BESTP(LU,IERR,NCYC,IYEAR,IMO,IDY,IHR,IMI, * RLAT,RLON,IWS,IPR,IRAD,IRADQ,IPOCI, * STATUS) C C Reads a line from the best track file and returns basic info. C Modification of READ_ATCF_BESTM to also return POCI, C 12/18 JLF. C -------------------------------------------------------------- C PARAMETER (LINE_LENGTH=103) C DIMENSION ICOM(24) DIMENSION IRADQ(4) CHARACTER*1 ALAT, ALON CHARACTER*2 BASIN, STATUS CHARACTER*3 WINDCODE CHARACTER*103 LINE C JC = 0 IERR = 0 NCYC = -999 IYEAR = -999 IMO = -999 IDY = -999 IHR = -999 IMI = -999 ILAT = -999 ILON = -999 IWS = -999 IPR = -999 IPOCI = -999 ALAT = ' ' ALON = ' ' STATUS = ' ' IRAD = -999 DO 50 L=1,4 50 IRADQ(L) = -999 C C C Read line from file C ------------------- READ(LU,'(A)',ERR=900,END=910) LINE C C C Search for all the commas that delimit the data fields. C ------------------------------------------------------- DO 100 L=1,24 105 JC = JC+1 IF (JC.GT.LINE_LENGTH) GOTO 110 IF (LINE(JC:JC).EQ.',') THEN ICOM(L) = JC NCOM = L ELSE GOTO 105 ENDIF 100 CONTINUE C C C Extract information C ------------------- 110 CONTINUE IF (NCOM.LT.17 .AND. NCOM.NE.8) GOTO 900 IB = 1 IE = ICOM(1)-1 READ(LINE(IB:IE),'(A)') BASIN IB = ICOM(1)+1 IE = ICOM(2)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) NCYC IB = ICOM(2)+1 IE = ICOM(3)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,I4,3I2)') * IYEAR,IMO,IDY,IHR IB = ICOM(3)+1 IE = ICOM(4)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IMI IB = ICOM(6)+1 IE = ICOM(7)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I4,A1)') ILAT,ALAT IB = ICOM(7)+1 IE = ICOM(8)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(I5,A1)') ILON,ALON IB = ICOM(8)+1 C C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (NCOM.EQ.8) THEN IE = IB+3 ELSE IE = ICOM(9)-1 ENDIF C IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IWS IF (NCOM.EQ.8) GOTO 150 IB = ICOM(9)+1 IE = ICOM(10)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IPR IB = ICOM(10)+1 IE = ICOM(11)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,A2)') STATUS IB = ICOM(11)+1 IE = ICOM(12)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IRAD IF (IRAD.NE.34 .AND. IRAD.NE.50 .AND. IRAD.NE.64) GOTO 150 IB = ICOM(12)+1 IE = ICOM(13)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(1X,A3)') WINDCODE IF (WINDCODE.EQ.'NEQ') THEN DO 130 L = 1,4 IX = 12 IB = ICOM(IX+L)+1 IE = ICOM(IX+L+1)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IRADQ(L) 130 CONTINUE ENDIF IF (WINDCODE.EQ.'AAA') THEN IX = 13 IB = ICOM(IX)+1 IE = ICOM(IX+1)-1 IF (LINE(IE:IE).NE.' ') THEN READ(LINE(IB:IE),*) IRADQ(1) IRADQ(2) = IRADQ(1) IRADQ(3) = IRADQ(1) IRADQ(4) = IRADQ(1) ENDIF ENDIF C 150 IF (NCOM.GE.18) THEN IB = ICOM(17)+1 IE = ICOM(18)-1 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),*) IPOCI ENDIF C IF (ILAT.EQ.-999 .OR. ILON.EQ.-999) THEN RLAT = -999. RLON = -999. ELSE IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT = FLOAT(ILAT)/10. RLON = FLOAT(ILON)/10. ENDIF C Special check for short line for some non-developing depressions C ---------------------------------------------------------------- IF (STATUS.EQ.' ' .AND. IWS.LT.34) STATUS = 'TD' IF (STATUS.EQ.' ' .AND. IWS.GE.34) STATUS = 'EX' IF (STATUS.EQ.' ') STATUS = 'XX' C RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE READ_OPERTRACK(LU,NB,IERR,IYEAR,IMO,IDY,IHR, * RLAT,RLON,IWS,IPR,IRAD,IRADQ,STATUS) C C Reads a line from the operational track file and returns basic C info. C -------------------------------------------------------------- C DIMENSION IRADQ(4) CHARACTER*2 STATUS CHARACTER*100 LINE C IERR = 0 IYEAR = -999 IMO = -999 IDY = -999 IHR = -999 RLAT = -999. RLON = -999. IWS = -999 IPR = -999 STATUS = ' ' IRAD = -999 DO 50 L=1,4 50 IRADQ(L) = -999 C C C Read header line from file if first read C ---------------------------------------- IF (NB.EQ.0) READ(LU,'(A)',ERR=900,END=910) LINE READ(LU,990,ERR=900,END=910) IDY,IMO,IYEAR,IHR,RLAT,RLON, * IWS,IPR,STATUS 990 FORMAT(I2,1X,I2,1X,I4,1X,I2,12X,F6.1,5X,F7.1,9X,I4,9X,I4,8X,A2) IF (IPR.EQ.0) IPR = -999 RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE GET_STMNAME(LU,IERR,STMNAME) C C Reads a line from the best track file and returns basic info. C Rewinds best track file when done. C -------------------------------------------------------------- C PARAMETER (LINE_LENGTH=160) DIMENSION ICOM(28) CHARACTER*10 STMNAME CHARACTER*160 LINE C JC = 0 IERR = 0 STMNAME = ' ' C C C Read line from file C ------------------- READ(LU,'(A)',ERR=900,END=910) LINE C C C Search for all the commas that delimit the data fields. C ------------------------------------------------------- DO 100 L=1,28 105 JC = JC+1 IF (JC.GT.LINE_LENGTH) GOTO 110 IF (LINE(JC:JC).EQ.',') THEN ICOM(L) = JC NCOM = L ELSE GOTO 105 ENDIF 100 CONTINUE C C C Extract information C ------------------- 110 IF (NCOM.LT.28) GOTO 900 IB = ICOM(27)+2 IE = ICOM(27)+11 IF (LINE(IE:IE).NE.' ') READ(LINE(IB:IE),'(A10)') STMNAME C DO 115 L = 10,1,-1 IF (STMNAME(L:L).EQ.' ') THEN STMNAME(1:10-L) = STMNAME(L+1:10) DO 116 K=10-L+1,10 116 STMNAME(K:K) = ' ' GOTO 950 ENDIF 115 CONTINUE RETURN C C C Errors C ------ 900 IERR = 1 GOTO 950 910 IERR = 2 GOTO 950 C C C Rewind best track file and return C --------------------------------- 950 REWIND(LU) RETURN C END C C C C --------------------------------------------------------------- SUBROUTINE LOAD_ADECK(LUT,LU,STMNAME,NLINES,INTERP12, * ACPTALLST_IT,SKP_ENSM, * NMINT,MODELINT2,MODELINTI) C C Loads A-DECK into COMMON BLOCK. C --------------------------------------------------------------- C PARAMETER(MXAL=500000) PARAMETER (NMINTX = 200) C CHARACTER*1 ALAT, ALON CHARACTER*2 BASIN, STATUS CHARACTER*3 FCSTR, WDCODE CHARACTER*4 TECH CHARACTER*4 MODELINT2(NMINTX), MODELINTI(NMINTX) CHARACTER*10 STMNAME CHARACTER*160 LINE LOGICAL INTERP12,ACPTALLST_IT,SKP_ENSM COMMON /ADECK/ NAL,NCYC,TECH(MXAL),TAU(MXAL),IYEAR(MXAL), * IMO(MXAL),IDY(MXAL),IHR(MXAL),RLAT(MXAL), * RLON(MXAL),IWS(MXAL),IPR(MXAL),STATUS(MXAL), * IWRAD(MXAL),WDCODE(MXAL),RAD1(MXAL),RAD2(MXAL), * RAD3(MXAL),RAD4(MXAL),IDIR(MXAL),ISPD(MXAL), * FCSTR(MXAL),POCI(MXAL),ROCI(MXAL),RMW(MXAL) C L = NLINES NCYC = 0 STMNAME = ' ' C 10 L = L+1 IF (L.GT.MXAL) THEN WRITE(LUT,*) 'ADECK TOO LONG IN LOAD_ADECK' STOP ENDIF TAU(L) = -99 TECH(L) = ' ' IYEAR(L) = 0 IMO(L) = 0 IDY(L) = 0 IHR(L) = 0 ILAT = 0 ILON = 0 ALAT = ' ' ALON = ' ' IWRAD(L) = 0 WDCODE(L) = ' ' RAD1(L) = -999 RAD2(L) = -999 RAD3(L) = -999 RAD4(L) = -999 IDIR(L) = -999 ISPD(L) = -999 POCI(L) = -999 ROCI(L) = -999 RMW(L) = -999 C C C Extract information C ------------------- 20 READ(LU,'(A)',END=910) LINE c write(lut,*) line IF (LINE(1:1).EQ.' ') GOTO 20 READ(LINE,'(A2,2X,I2,2X,I4,3I2,6X,A4,2X,I3,2X,I3,A1,2X,I4, * A1,2X,I3,2X,I4,2X,A2,2X,I3,2X,A3,4(2X,I4), * 2X,I4,2X,I4,2X,I3)', * ERR=920) BASIN,NCYC, * IYEAR(L),IMO(L),IDY(L),IHR(L),TECH(L),ITAU, * ILAT,ALAT,ILON,ALON,IWS(L),IPR(L),STATUS(L), * IWRAD(L),WDCODE(L),IRAD1,IRAD2,IRAD3,IRAD4, * IPOCI,IROCI,IRMW C IF (SKP_ENSM) THEN IF (TECH(L)(1:3).EQ.'EN0') GOTO 915 IF (TECH(L)(1:3).EQ.'EN1') GOTO 915 IF (TECH(L)(1:3).EQ.'EN2') GOTO 915 IF (TECH(L)(1:3).EQ.'EP0') GOTO 915 IF (TECH(L)(1:3).EQ.'EP1') GOTO 915 IF (TECH(L)(1:3).EQ.'EP2') GOTO 915 IF (TECH(L)(1:3).EQ.'EE0') GOTO 915 IF (TECH(L)(1:3).EQ.'EE1') GOTO 915 IF (TECH(L)(1:3).EQ.'EE2') GOTO 915 IF (TECH(L)(1:3).EQ.'EE3') GOTO 915 IF (TECH(L)(1:3).EQ.'EE4') GOTO 915 IF (TECH(L)(1:3).EQ.'EE5') GOTO 915 IF (TECH(L)(1:3).EQ.'AP0') GOTO 915 IF (TECH(L)(1:3).EQ.'AP1') GOTO 915 IF (TECH(L)(1:3).EQ.'CP0') GOTO 915 IF (TECH(L)(1:3).EQ.'CP1') GOTO 915 IF (TECH(L)(1:3).EQ.'FP0') GOTO 915 IF (TECH(L)(1:3).EQ.'FP1') GOTO 915 IF (TECH(L)(1:3).EQ.'FP2') GOTO 915 IF (TECH(L)(1:3).EQ.'UE0') GOTO 915 IF (TECH(L)(1:3).EQ.'UE1') GOTO 915 IF (TECH(L)(1:3).EQ.'UE2') GOTO 915 IF (TECH(L)(1:3).EQ.'UE3') GOTO 915 ENDIF C TAU(L) = ITAU RAD1(L) = IRAD1 RAD2(L) = IRAD2 RAD3(L) = IRAD3 RAD4(L) = IRAD4 POCI(L) = IPOCI ROCI(L) = IROCI RMW(L) = IRMW C FCSTR(L) = 'XXX' IF (TECH(L).EQ.'OFCL' .OR. TECH(L).EQ.'OFCO') * FCSTR(L) = LINE(135:137) IF (LINE(140:142).NE.' ')READ(LINE(140:142),*,ERR=920)IDIR(L) IF (LINE(145:147).NE.' ')READ(LINE(145:147),*,ERR=920)ISPD(L) IF (TECH(L).EQ.'CARQ'.AND. * (IWRAD(L).EQ.34.OR.IWRAD(L).EQ.35.OR.IWRAD(L).EQ.0) .AND. * LINE(150:159).NE.'INVEST ') * STMNAME = LINE(150:159) IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT(L) = FLOAT(ILAT)/10. RLON(L) = FLOAT(ILON)/10. C C C Change all 12-h interpolated models to standard "I" nomenclature C This allows no distinction between the 2 and I models, which C will result in the first one present in the deck (generally the C "2" model) being verified. Underlying assumption is that if a C "2" model is present in the deck, then the forecast process C began without the benefit of the I model being present. C ---------------------------------------------------------------- IF (TECH(L)(4:4) .EQ. '2' .AND. INTERP12) THEN DO 100 N=1,NMINT IF (TECH(L).EQ.MODELINT2(N)) TECH(L)=MODELINTI(N) 100 CONTINUE ENDIF C C C Special treatment for ECMWF, which has a duplicate tracker C (EMH) that is often available earlier than EMX. Because C sometimes there is only EMH, we'll use that as if it were C EMX. C ----------------------------------------------------------- IF (TECH(L).EQ.'EMH') TECH(L) = 'EMX' IF (TECH(L).EQ.'EMHI') TECH(L) = 'EMXI' IF (TECH(L).EQ.'EMH2') TECH(L) = 'EMX2' C C C Sometimes models change their names, so this code allows us C to use the current name and accept equivalent runs from C earlier years. C C If we're accepting all status types into the verification, C that means we also want to include all provisional C forecasts. C ----------------------------------------------------------- IF (TECH(L).EQ.'CONU') TECH(L) = 'TVCN' IF (ACPTALLST_IT .AND. TECH(L).EQ.'OFCP') TECH(L) = 'OFCL' C C GOTO 10 C C 910 NAL = L-1 NLINES = NAL RETURN C C Skipping undesired lines C ------------------------ 915 L = L-1 GOTO 10 C C 920 WRITE(LUT,'("*** BAD RECORD IN ADECK ***")') !pause L = L-1 GOTO 10 END C C C C --------------------------------------------------------------- SUBROUTINE READ_ATCF_ADECK(LU,IERR,NCYC,TECH,TAU, * IYEAR,IMO,IDY,IHR, * RLAT,RLON,IWS,IPR,STATUS,FCSTR, * IDIR,ISPD) C C Reads a line from the a deck file and returns basic info. C --------------------------------------------------------------- C CHARACTER*1 ALAT, ALON CHARACTER*2 BASIN, STATUS CHARACTER*3 FCSTR CHARACTER*4 TECH CHARACTER*150 LINE C IERR = 0 NCYC = 0 TAU = -99 TECH = ' ' IYEAR = 0 IMO = 0 IDY = 0 IHR = 0 ILAT = 0 ILON = 0 ALAT = ' ' ALON = ' ' IDIR = -999 ISPD = -999 C C C Read line from file C ------------------- READ(LU,'(A)',ERR=900,END=910) LINE C C C Extract information C ------------------- READ(LINE,'(A2,2X,I2,2X,I4,3I2,6X,A4,2X,I3,2X,I3,A1,2X,I4,A1, * 2X,I3,2X,I4,2X,A2)') BASIN,NCYC,IYEAR,IMO,IDY,IHR, * TECH,ITAU,ILAT,ALAT,ILON,ALON,IWS,IPR,STATUS C TAU = ITAU FCSTR = 'XXX' IF (TECH.EQ.'OFCL') FCSTR = LINE(135:137) IF (LINE(140:142).NE.' ') READ(LINE(140:142),*,ERR=50) IDIR IF (LINE(145:147).NE.' ') READ(LINE(145:147),*,ERR=50) ISPD 50 IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT = FLOAT(ILAT)/10. RLON = FLOAT(ILON)/10. RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C ----------------------------------------------------------- SUBROUTINE GET_MODEL_FCSTC(LU,LUT,MODELIN,IMON,IDAY,IHOUR, * FLAT,FLON,FWND,FRAD,FCSTRX,LAG) C C Locates a specific model forecast from an ATCF A deck C COMMON block. C ----------------------------------------------------------- C C PARAMETER (NVTX=8) PARAMETER (MXAL=500000) C DIMENSION MODA(12) DIMENSION FLAT(NVTX), FLON(NVTX), FWND(NVTX), ITIME(NVTX) DIMENSION FRAD(NVTX,3,4) CHARACTER*2 STATUS CHARACTER*3 FCSTR, FCSTRX, WDCODE CHARACTER*4 MODELIN, MODEL, TECH CHARACTER*6 DTGROUP, ADECK_DTGROUP CHARACTER*10 STMNAME LOGICAL FOUNDMODEL, FOUNDVT(NVTX), FOUNDCOMP, MODEL_COMPLETE LOGICAL IGNORE_SPECIALS C COMMON /ADECK/ NAL,NCYC,TECH(MXAL),TAU(MXAL),IYEAR(MXAL), * IMO(MXAL),IDY(MXAL),IHR(MXAL),RLAT(MXAL), * RLON(MXAL),IWS(MXAL),IPR(MXAL),STATUS(MXAL), * IWRAD(MXAL),WDCODE(MXAL),RAD1(MXAL),RAD2(MXAL), * RAD3(MXAL),RAD4(MXAL),IDIR(MXAL),ISPD(MXAL), * FCSTR(MXAL),POCI(MXAL),ROCI(MXAL),RMW(MXAL) C DATA ITIME/0,12,24,36,48,72,96,120/ DATA MODA/31,28,31,30,31,30,31,31,30,31,30,31/ C C C Initialize variables C -------------------- IMONX = IMON IDAYX = IDAY IHOURX = IHOUR IF (LAG.GT.24 .OR. LAG.LT.0) STOP IF (LAG.NE.0) THEN IHOURX = IHOURX-LAG IF (IHOURX.LT.0) THEN IHOURX = IHOURX+24 IDAYX = IDAYX-1 ENDIF IF (IDAYX.LE.0) THEN IMONX = IMONX-1 IDAXY = MODA(IMONX) ENDIF ENDIF WRITE(DTGROUP,'(3I2.2)') IMONX,IDAYX,IHOURX DO 30 J = 1,NVTX FLAT(J) = -999. FLON(J) = -999. FWND(J) = -999. DO 35 K = 1,3 DO 40 L = 1,4 40 FRAD(J,K,L) = -999. 35 CONTINUE FOUNDVT(J) = .FALSE. 30 CONTINUE FOUNDMODEL = .FALSE. FOUNDCOMP = .FALSE. FCSTRX = 'XXX' MODEL_COMPLETE = .FALSE. MODEL = MODELIN IGNORE_SPECIALS = .TRUE. C C C SHIPS data from 1996-8 appears as LBAR. C --------------------------------------- IF (IYEAR(1).GE.1996 .AND. IYEAR(1).LE.1998) THEN IF (MODEL .EQ. 'SHIP') MODEL = 'LBAR' ENDIF C C C Scan A-deck data. Only accept first occurrance of a position or C wind speed forecast, and only accept first grouping of lines for C a particular model/time. This latter criteria added 11/27/03, C so that we didn't have to read till the end looking for radii. C ---------------------------------------------------------------- LX = 0 100 LX = LX+1 IF (LX.GT.NAL) GOTO 180 WRITE(ADECK_DTGROUP,'(3I2.2)') IMO(LX),IDY(LX),IHR(LX) IF (ADECK_DTGROUP.NE.DTGROUP) GOTO 100 C IF (TECH(LX)(1:1).EQ.' ') THEN TECH(LX)(1:3) = TECH(LX)(2:4) TECH(LX)(4:4) = '-' ENDIF C C C Found compute, store TAU=0 info in case we need it. C --------------------------------------------------- IF (LAG.EQ.0 .AND. TECH(LX).EQ.'CARQ' .AND. * NINT(TAU(LX)).EQ.0) THEN FOUNDCOMP = .TRUE. CLAT = RLAT(LX) CLON = RLON(LX) CWND = IWS(LX) ENDIF C C C If looking for OFCL, take OFCO instead, if available. C ----------------------------------------------------- IF (IGNORE_SPECIALS .AND. * MODEL.EQ.'OFCL' .AND. TECH(LX).EQ.'OFCO') THEN MODEL = 'OFCO' DO 230 J = 1,NVTX FLAT(J) = -999. FLON(J) = -999. FWND(J) = -999. DO 235 K = 1,3 DO 240 L = 1,4 240 FRAD(J,K,L) = -999. 235 CONTINUE FOUNDVT(J) = .FALSE. 230 CONTINUE FOUNDMODEL = .FALSE. FCSTRX = 'XXX' MODEL_COMPLETE = .FALSE. ENDIF C C C Is this the right model? If so, C determine which tau/space it goes into. C --------------------------------------- IF (TECH(LX).EQ.MODEL) THEN FOUNDMODEL = .TRUE. FCSTRX = FCSTR(LX) DO 120 I = 1,NVTX IF (NINT(TAU(LX)).EQ.ITIME(I)+LAG) THEN C C Only accept radii forecast if fcst wind speed C meets the threshhold, e.g., if fcst speed is C 30 kt, then there are NO 34 kt wind radii forecasts, C even though line in A deck has all 0's. C ---------------------------------------------------- IRX = INDEX_WRAD(IWRAD(LX)) IF (IRX.NE.0 .AND. IWS(LX).GE.IWRAD(LX)) THEN IF (WDCODE(LX).EQ.'NEQ') THEN FRAD(I,IRX,1) = RAD1(LX) FRAD(I,IRX,2) = RAD2(LX) FRAD(I,IRX,3) = RAD3(LX) FRAD(I,IRX,4) = RAD4(LX) ENDIF IF (WDCODE(LX).EQ.'AAA') THEN FRAD(I,IRX,1) = RAD1(LX) FRAD(I,IRX,2) = RAD1(LX) FRAD(I,IRX,3) = RAD1(LX) FRAD(I,IRX,4) = RAD1(LX) ENDIF C C Have to toss all the radii forecasts if wind speed C meets the threshold and all the radii are 0 - C this means that no radii forecast was made for this C time period. C ---------------------------------------------------- IF (FRAD(I,IRX,1).EQ.0. .AND. * FRAD(I,IRX,2).EQ.0. .AND. * FRAD(I,IRX,3).EQ.0. .AND. * FRAD(I,IRX,4).EQ.0.) THEN DO 110 N=1,4 110 FRAD(I,IRX,N) = -999. ENDIF ENDIF C IF (.NOT.FOUNDVT(I)) THEN FLAT(I) = RLAT(LX) FLON(I) = RLON(LX) FWND(I) = IWS(LX) FOUNDVT(I) = .TRUE. ENDIF ENDIF 120 CONTINUE ENDIF C C C Can we stop reading the data from the A-deck? C Yes, if we've found the compute, the model forecast, C a line for each forecast time, and the current line C in the A-deck is now a different model. C However, if the desired model is OFCL we may need to C search for OFCO, an original OFCL superceded by a C special advisory. C ---------------------------------------------------- IF (.NOT.FOUNDCOMP) GOTO 100 IF (.NOT.FOUNDMODEL) GOTO 100 IF (TECH(LX).EQ.MODEL) THEN DO 130 I = NVTX,1,-1 IF (.NOT.FOUNDVT(I)) GOTO 100 130 CONTINUE MODEL_COMPLETE = .TRUE. ENDIF IF (MODEL_COMPLETE) THEN IF (MODEL.NE.'OFCL') GOTO 180 IF (.NOT.IGNORE_SPECIALS) GOTO 180 ENDIF GOTO 100 C C C Fill in TAU=0 from CARQ if blank C -------------------------------- 180 IF (FOUNDMODEL .AND. FOUNDCOMP) THEN IF (FLAT(1).EQ.-999.) FLAT(1) = CLAT IF (FLON(1).EQ.-999.) FLON(1) = CLON IF (FWND(1).EQ.-999.) FWND(1) = CWND ENDIF GOTO 800 C C C Exit C ---- 800 DO 810 J = 1,NVTX IF (FLAT(J).EQ.0.) FLAT(J) = -999. IF (FLON(J).EQ.0.) FLON(J) = -999. IF (FWND(J).EQ.0.) FWND(J) = -999. 810 CONTINUE RETURN END C C C C ----------------------------------------------------------- SUBROUTINE GET_MODEL_FCSTC7(LU,LUT,MODELIN,IMON,IDAY,IHOUR, * FLAT,FLON,FWND,FRAD,FCSTRX,LAG) C C Locates a specific model forecast from an ATCF A deck C COMMON block. C ----------------------------------------------------------- C C PARAMETER (NVTX=15) PARAMETER (MXAL=500000) C DIMENSION MODA(12) DIMENSION FLAT(NVTX), FLON(NVTX), FWND(NVTX), ITIME(NVTX) DIMENSION FRAD(NVTX,3,4) CHARACTER*2 STATUS CHARACTER*3 FCSTR, FCSTRX, WDCODE CHARACTER*4 MODELIN, MODEL, TECH CHARACTER*6 DTGROUP, ADECK_DTGROUP CHARACTER*10 STMNAME LOGICAL FOUNDMODEL, FOUNDVT(NVTX), FOUNDCOMP, MODEL_COMPLETE LOGICAL IGNORE_SPECIALS C COMMON /ADECK/ NAL,NCYC,TECH(MXAL),TAU(MXAL),IYEAR(MXAL), * IMO(MXAL),IDY(MXAL),IHR(MXAL),RLAT(MXAL), * RLON(MXAL),IWS(MXAL),IPR(MXAL),STATUS(MXAL), * IWRAD(MXAL),WDCODE(MXAL),RAD1(MXAL),RAD2(MXAL), * RAD3(MXAL),RAD4(MXAL),IDIR(MXAL),ISPD(MXAL), * FCSTR(MXAL),POCI(MXAL),ROCI(MXAL),RMW(MXAL) C DATA ITIME/0,12,24,36,48,60,72,84,96,108,120,132,144,156,168/ DATA MODA/31,28,31,30,31,30,31,31,30,31,30,31/ C C C Initialize variables C -------------------- IMONX = IMON IDAYX = IDAY IHOURX = IHOUR IF (LAG.GT.24 .OR. LAG.LT.0) STOP IF (LAG.NE.0) THEN IHOURX = IHOURX-LAG IF (IHOURX.LT.0) THEN IHOURX = IHOURX+24 IDAYX = IDAYX-1 ENDIF IF (IDAYX.LE.0) THEN IMONX = IMONX-1 IDAXY = MODA(IMONX) ENDIF ENDIF WRITE(DTGROUP,'(3I2.2)') IMONX,IDAYX,IHOURX DO 30 J = 1,NVTX FLAT(J) = -999. FLON(J) = -999. FWND(J) = -999. DO 35 K = 1,3 DO 40 L = 1,4 40 FRAD(J,K,L) = -999. 35 CONTINUE FOUNDVT(J) = .FALSE. 30 CONTINUE FOUNDMODEL = .FALSE. FOUNDCOMP = .FALSE. FCSTRX = 'XXX' MODEL_COMPLETE = .FALSE. MODEL = MODELIN IGNORE_SPECIALS = .TRUE. C C C SHIPS data from 1996-8 appears as LBAR. C --------------------------------------- IF (IYEAR(1).GE.1996 .AND. IYEAR(1).LE.1998) THEN IF (MODEL .EQ. 'SHIP') MODEL = 'LBAR' ENDIF C C C Scan A-deck data. Only accept first occurrance of a position or C wind speed forecast, and only accept first grouping of lines for C a particular model/time. This latter criteria added 11/27/03, C so that we didn't have to read till the end looking for radii. C ---------------------------------------------------------------- LX = 0 100 LX = LX+1 IF (LX.GT.NAL) GOTO 180 WRITE(ADECK_DTGROUP,'(3I2.2)') IMO(LX),IDY(LX),IHR(LX) IF (ADECK_DTGROUP.NE.DTGROUP) GOTO 100 C IF (TECH(LX)(1:1).EQ.' ') THEN TECH(LX)(1:3) = TECH(LX)(2:4) TECH(LX)(4:4) = '-' ENDIF C C C Found compute, store TAU=0 info in case we need it. C --------------------------------------------------- IF (LAG.EQ.0 .AND. TECH(LX).EQ.'CARQ' .AND. * NINT(TAU(LX)).EQ.0) THEN FOUNDCOMP = .TRUE. CLAT = RLAT(LX) CLON = RLON(LX) CWND = IWS(LX) ENDIF C C C If looking for OFCL, take OFCO instead, if available. C ----------------------------------------------------- IF (IGNORE_SPECIALS .AND. * MODEL.EQ.'OFCL' .AND. TECH(LX).EQ.'OFCO') THEN MODEL = 'OFCO' DO 230 J = 1,NVTX FLAT(J) = -999. FLON(J) = -999. FWND(J) = -999. DO 235 K = 1,3 DO 240 L = 1,4 240 FRAD(J,K,L) = -999. 235 CONTINUE FOUNDVT(J) = .FALSE. 230 CONTINUE FOUNDMODEL = .FALSE. FCSTRX = 'XXX' MODEL_COMPLETE = .FALSE. ENDIF C C C Is this the right model? If so, C determine which tau/space it goes into. C --------------------------------------- IF (TECH(LX).EQ.MODEL) THEN FOUNDMODEL = .TRUE. FCSTRX = FCSTR(LX) DO 120 I = 1,NVTX IF (NINT(TAU(LX)).EQ.ITIME(I)+LAG) THEN C C Only accept radii forecast if fcst wind speed C meets the threshhold, e.g., if fcst speed is C 30 kt, then there are NO 34 kt wind radii forecasts, C even though line in A deck has all 0's. C ---------------------------------------------------- IRX = INDEX_WRAD(IWRAD(LX)) IF (IRX.NE.0 .AND. IWS(LX).GE.IWRAD(LX)) THEN IF (WDCODE(LX).EQ.'NEQ') THEN FRAD(I,IRX,1) = RAD1(LX) FRAD(I,IRX,2) = RAD2(LX) FRAD(I,IRX,3) = RAD3(LX) FRAD(I,IRX,4) = RAD4(LX) ENDIF IF (WDCODE(LX).EQ.'AAA') THEN FRAD(I,IRX,1) = RAD1(LX) FRAD(I,IRX,2) = RAD1(LX) FRAD(I,IRX,3) = RAD1(LX) FRAD(I,IRX,4) = RAD1(LX) ENDIF C C Have to toss all the radii forecasts if wind speed C meets the threshold and all the radii are 0 - C this means that no radii forecast was made for this C time period. C ---------------------------------------------------- IF (FRAD(I,IRX,1).EQ.0. .AND. * FRAD(I,IRX,2).EQ.0. .AND. * FRAD(I,IRX,3).EQ.0. .AND. * FRAD(I,IRX,4).EQ.0.) THEN DO 110 N=1,4 110 FRAD(I,IRX,N) = -999. ENDIF ENDIF C IF (.NOT.FOUNDVT(I)) THEN FLAT(I) = RLAT(LX) FLON(I) = RLON(LX) FWND(I) = IWS(LX) FOUNDVT(I) = .TRUE. ENDIF ENDIF 120 CONTINUE ENDIF C C C Can we stop reading the data from the A-deck? C Yes, if we've found the compute, the model forecast, C a line for each forecast time, and the current line C in the A-deck is now a different model. C However, if the desired model is OFCL we may need to C search for OFCO, an original OFCL superceded by a C special advisory. C ---------------------------------------------------- IF (.NOT.FOUNDCOMP) GOTO 100 IF (.NOT.FOUNDMODEL) GOTO 100 IF (TECH(LX).EQ.MODEL) THEN DO 130 I = NVTX,1,-1 IF (.NOT.FOUNDVT(I)) GOTO 100 130 CONTINUE MODEL_COMPLETE = .TRUE. ENDIF IF (MODEL_COMPLETE) THEN IF (MODEL.NE.'OFCL') GOTO 180 IF (.NOT.IGNORE_SPECIALS) GOTO 180 ENDIF GOTO 100 C C C Fill in TAU=0 from CARQ if blank C -------------------------------- 180 IF (FOUNDMODEL .AND. FOUNDCOMP) THEN IF (FLAT(IXTAU(0)).EQ.-999.) FLAT(IXTAU(0)) = CLAT IF (FLON(IXTAU(0)).EQ.-999.) FLON(IXTAU(0)) = CLON IF (FWND(IXTAU(0)).EQ.-999.) FWND(IXTAU(0)) = CWND ENDIF GOTO 800 C C C Exit C ---- 800 DO 810 J = 1,NVTX IF (FLAT(J).EQ.0.) FLAT(J) = -999. IF (FLON(J).EQ.0.) FLON(J) = -999. IF (FWND(J).EQ.0.) FWND(J) = -999. 810 CONTINUE RETURN END C C C C -------------------------------------------------------------- SUBROUTINE GET_CARQ(IMON,IDAY,IHOUR,RLAT0,RLON0,WS0,DIR0,SPD0, * RLAT12,RLON12,WS12,DIR12,SPD12, * PROCI,RADOCI,RADMW) C C Locates compute data from an ATCF A deck COMMON block. C -------------------------------------------------------------- C C PARAMETER (MXAL=500000) C CHARACTER*2 STATUS CHARACTER*3 FCSTR, WDCODE CHARACTER*4 TECH CHARACTER*6 DTGROUP, ADECK_DTGROUP LOGICAL FOUNDCOMP0, FOUNDCOMP12 C COMMON /ADECK/ NAL,NCYC,TECH(MXAL),TAU(MXAL),IYEAR(MXAL), * IMO(MXAL),IDY(MXAL),IHR(MXAL),RLAT(MXAL), * RLON(MXAL),IWS(MXAL),IPR(MXAL),STATUS(MXAL), * IWRAD(MXAL),WDCODE(MXAL),RAD1(MXAL),RAD2(MXAL), * RAD3(MXAL),RAD4(MXAL),IDIR(MXAL),ISPD(MXAL), * FCSTR(MXAL),POCI(MXAL),ROCI(MXAL),RMW(MXAL) C C C C Initialize variables C -------------------- WRITE(DTGROUP,'(3I2.2)') IMON,IDAY,IHOUR RLAT0 = -999. RLON0 = -999. WS0 = -999. DIR0 = -999. SPD0 = -999. RLAT12= -999. RLON12= -999. WS12 = -999. DIR12 = -999. SPD12 = -999. PROCI = -999. RADOCI= -999. RADMW = -999. FOUNDCOMP0 = .FALSE. FOUNDCOMP12 = .FALSE. C C C Scan A-deck data. Only accept first occurrance of a position or C wind speed forecast, and only accept first grouping of lines for C a particular model/time. This latter criteria added 11/27/03, C so that we didn't have to read till the end looking for radii. C ---------------------------------------------------------------- LX = 0 100 LX = LX+1 IF (LX.GT.NAL) GOTO 180 WRITE(ADECK_DTGROUP,'(3I2.2)') IMO(LX),IDY(LX),IHR(LX) IF (ADECK_DTGROUP.NE.DTGROUP) GOTO 100 C C C Found compute, grab data. C --------------------------------------------------- IF (TECH(LX).EQ.'CARQ' .AND. NINT(TAU(LX)).EQ.0) THEN FOUNDCOMP0 = .TRUE. RLAT0 = RLAT(LX) RLON0 = RLON(LX) WS0 = IWS(LX) DIR0 = IDIR(LX) SPD0 = ISPD(LX) PROCI = POCI(LX) RADOCI= ROCI(LX) RADMW = RMW(LX) ENDIF IF (TECH(LX).EQ.'CARQ' .AND. NINT(TAU(LX)).EQ.-12) THEN FOUNDCOMP12 = .TRUE. RLAT12= RLAT(LX) RLON12= RLON(LX) WS12 = IWS(LX) DIR12 = IDIR(LX) SPD12 = ISPD(LX) ENDIF C C C Can we stop reading the data from the A-deck? C ---------------------------------------------------- IF (.NOT.FOUNDCOMP0) GOTO 100 IF (.NOT.FOUNDCOMP12) GOTO 100 C C C Exit C ---- 180 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE READ_ATCF_BESTMAN(LU,IERR,NCYC,IYEAR,IMO,IDY,IHR, * RLAT,RLON,IWS,IPR) C C Reads a line from a hand-made best track file. C -------------------------------------------------------------- C CHARACTER*1 ALAT, ALON CHARACTER*81 LINE C IERR = 0 NCYC = 0 IYEAR = 0 IMO = 0 IDY = 0 IHR = 0 ILAT = 0 ILON = 0 ALAT = ' ' ALON = ' ' C C C Read line from file C ------------------- 100 READ(LU,'(A)',ERR=900,END=910) LINE READ(LINE,'(5I2,1X,I3,A1,I4,A1,1X,I3,1X,I4)') NCYC,IYR,IMO, * IDY,IHR,ILAT,ALAT,ILON,ALON,IWS,IPR IF (IYR.LT.50) THEN IYEAR = IYR+2000 ELSE IYEAR = IYR+1900 ENDIF IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT = FLOAT(ILAT)/10. RLON = FLOAT(ILON)/10. RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C ------------------------------------------ FUNCTION INDEX_WRAD(IRAD) C ------------------------------------------ C INDEX_WRAD = 0 IF (IRAD.EQ.34 .OR. IRAD.EQ.35) INDEX_WRAD = 1 IF (IRAD.EQ.50) INDEX_WRAD = 2 IF (IRAD.EQ.64 .OR. IRAD.EQ.65) INDEX_WRAD = 3 RETURN END C C C C ------------------------------------------ FUNCTION IXTAU(IHR) C ------------------------------------------ C PARAMETER (NVTX=15) DIMENSION ITIME(NVTX) DATA ITIME/0,12,24,36,48,60,72,84,96,108,120,132,144,156,168/ DO 100 I=1,NVTX IF (ITIME(I).EQ.IHR) THEN IXTAU=I RETURN ENDIF 100 CONTINUE IXTAU = -1 WRITE(1,*) '*** INVALID TIME IN IXTAU ***' STOP RETURN END C C C C ------------------------------------------ SUBROUTINE MAXRADII(IRADII,IX,MAXRAD) C ------------------------------------------ C DIMENSION IRADII(3,4) MAXRAD = -999 DO 100 L=1,4 IF (IRADII(IX,L).GT.MAXRAD) MAXRAD=IRADII(IX,L) 100 CONTINUE RETURN END C C C -------------------------------------------------------------- SUBROUTINE READ_ATCF_FIX(LU,IERR,LINE,FIXTYPE,NCYC,IYEAR,IMO, * IDY,IHR,IMN,RLAT,RLON) C C Reads a line from the fix file and returns C basic info. C -------------------------------------------------------------- C CHARACTER*1 FIXTYPE, ALAT, ALON CHARACTER*81 LINE C IERR = 0 FIXTYPE = ' ' NCYC = 0 IYEAR = 0 IMO = 0 IDY = 0 IHR = 0 IMN = 0 ILAT = 0 ILON = 0 ALAT = ' ' ALON = ' ' C C C Read line from fix file C ----------------------- READ(LU,'(A)',ERR=900,END=910) LINE C C C Determine what kind of fix it is C -------------------------------- READ(LINE,'(A1,I2,I4,4I2,I3,A1,I4,A1)') FIXTYPE,NCYC,IYEAR, * IMO,IDY,IHR,IMN,ILAT,ALAT,ILON,ALON C IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON RLAT = FLOAT(ILAT)/10. RLON = FLOAT(ILON)/10. RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE READ_ATCF_FIX2002(LU,IERR,LINE,FIXTYPE,NCYC, * IYEAR,IMO,IDY,IHR,IMN,RLAT,RLON, * NFLD,FIELD) C C Reads a line from the fix file and returns info from the C common section. The entire record is broken up into character C fields. C C Based on new 2002 fix file format. C -------------------------------------------------------------- C PARAMETER (LINE_LENGTH=1000, MAXFIELDS=100) C DIMENSION ICOM(MAXFIELDS) CHARACTER*1 ALAT, ALON CHARACTER*4 FIXTYPE CHARACTER*52 FIELD(MAXFIELDS) CHARACTER*1000 LINE C NCYC = 0 IYEAR = 0 IMO = 0 IDY = 0 IHR = 0 IMN = 0 ILAT = 0 ILON = 0 ALAT = ' ' ALON = ' ' RLAT = -999. RLON = -999. IERR = 0 C C C Read line from file C ------------------- LINE = ' ' READ(LU,'(A)',ERR=900,END=910) LINE DO 10 L=1,MAXFIELDS 10 FIELD(L) = ' ' C C C Determine the last filled character in the line C ----------------------------------------------- DO 50 L = LINE_LENGTH,1,-1 IF (LINE(L:L).NE.' ' .AND. LINE(L:L).NE.',') GOTO 60 50 CONTINUE IF (L.LE.1) GOTO 920 60 LASTCHAR = L C C C Search for all the commas that delimit the data fields. C ------------------------------------------------------- JC = 0 DO 100 L=1,MAXFIELDS 105 JC = JC+1 IF (JC.GT.LASTCHAR) GOTO 110 IF (LINE(JC:JC).EQ.',') THEN ICOM(L) = JC NCOM = L ELSE GOTO 105 ENDIF 100 CONTINUE C C C Extract information C ------------------- 110 NFLD = NCOM+1 DO 130 L = 1,NFLD IF (L.EQ.1) THEN IB = 1 ELSE IB = ICOM(L-1)+2 ENDIF IF (L.EQ.NFLD) THEN IE = LASTCHAR ELSE IE = ICOM(L)-1 ENDIF FIELD(L) = ' ' IF (IB.GT.IE) GOTO 130 READ(LINE(IB:IE),'(A)') FIELD(L) 130 CONTINUE C C READ(FIELD(2),*,ERR=920) NCYC READ(FIELD(3),'(I4,4I2)',ERR=920) IYEAR,IMO,IDY,IHR,IMN READ(FIELD(5),'(A4)',ERR=920) FIXTYPE READ(FIELD(8),'(I4,A1)',ERR=920) ILAT,ALAT READ(FIELD(9),'(I5,A1)',ERR=920) ILON,ALON IF (ALAT.EQ.'S') ILAT = -ILAT IF (ALON.EQ.'W') ILON = -ILON IF (ILAT.NE.0 .AND. ILON.NE.0) THEN RLAT = FLOAT(ILAT)/100. RLON = FLOAT(ILON)/100. ENDIF C RETURN C C 900 IERR = 1 RETURN 910 IERR = 2 RETURN 920 IERR = 3 WRITE(1,'("Unreadable fix record: ",a50)') line(1:50) RETURN END C C C C -------------------------------------------------------------- SUBROUTINE SATFIX(LINE,CI,TNUM,ODT,SITE,MICROWAVE,SUBT) C -------------------------------------------------------------- C CHARACTER*4 SITE CHARACTER*81 LINE LOGICAL MICROWAVE,SUBT C MICROWAVE = .FALSE. SUBT = .FALSE. IF (LINE(45:45).EQ.'S') MICROWAVE = .TRUE. ODT = 0.0 IF (LINE(27:28).EQ.' ') THEN TNUM = 0 ELSE READ(LINE(27:28),'(F2.0)') TNUM ENDIF IF (LINE(29:30).EQ.' ') THEN CI = 0 ELSE READ(LINE(29:30),'(F2.0)') CI ENDIF C SITE = LINE(78:81) DO 100 L=46,71 IF (LINE(L:L+3).EQ.'ODT=' .OR. LINE(L:L+3).EQ.'odt=') THEN READ(LINE(L+4:L+6),*,ERR=900) ODT IF (ODT.GE.10.) ODT = ODT/10. ODT = ODT*10. ENDIF IF (LINE(L:L+3).EQ.'SUBT' .OR. LINE(L:L+3).EQ.'subt') THEN SUBT = .TRUE. ENDIF 100 CONTINUE C C 900 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE SATFIX2002(NFLD,FIELD,CI,TNUM,SITE,SUBT) C -------------------------------------------------------------- C PARAMETER (MAXFIELDS=100) CHARACTER*52 FIELD(MAXFIELDS) CHARACTER*4 SITE LOGICAL SUBT C C SITE = ' ' SUBT = .FALSE. CI=0. TNUM=0. IF (NFLD.LT.38) RETURN C READ(FIELD(35),'(2F2.0)') TNUM,CI IF (NFLD.GE.40 .AND. FIELD(40).EQ.'S') SUBT = .TRUE. SITE = FIELD(31)(2:5) IF (SITE(1:1).EQ.' ') THEN DO 100 L=1,3 100 SITE(L:L) = SITE(L+1:L+1) SITE(4:4) = ' ' ENDIF C 900 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE ODTFIX2002(NFLD,FIELD,ODT) C -------------------------------------------------------------- C PARAMETER (MAXFIELDS=100) CHARACTER*52 FIELD(MAXFIELDS) C C ODT = 0. IF (NFLD.LT.36) RETURN C READ(FIELD(36),'(I2)') ITAVG ODT = ITAVG C 900 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE ADTFIX2012(NFLD,FIELD,ADT) C -------------------------------------------------------------- C PARAMETER (MAXFIELDS=100) CHARACTER*52 FIELD(MAXFIELDS) INTEGER CI_NUMBER C C ADT = 0. IF (NFLD.LT.34) RETURN C READ(FIELD(34),'(I2)') CI_NUMBER ADT = CI_NUMBER C 900 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE ACFIX(LINE,SLPMIN,FLWSMX,SFCWSMX,IFLPR,IFLHT) C C SLPMIN Minimum sea-level pressure (mb) C FLWSMX Max flight-level wind (kt) C SFCWSMX Max surface wind (kt) C IFLPR Flight level (mb) C IFLHT Flight level (hundreds of feet) C -------------------------------------------------------------- C CHARACTER*81 LINE C SLPMIN = -999. C 300 IF (LINE(52:54).NE.' ') READ(LINE(52:54),'(F3.0)') SLPMIN IF (SLPMIN.GT.0. .AND. SLPMIN.LT.100.) SLPMIN=SLPMIN+1000. READ(LINE(44:46),'(F3.0)') FLWSMX READ(LINE(34:36),'(F3.0)') SFCWSMX READ(LINE(27:29),'(I3)') IFLPR READ(LINE(25:26),'(I2)') IFLHT RETURN END C C C C -------------------------------------------------------------- SUBROUTINE ACFIX2002(NFLD,FIELD,SLPMIN,FLWSMX,SFCWSMX,IFLPR, * IFLHT) C C SLPMIN Minimum sea-level pressure (mb) C FLWSMX Max flight-level wind (kt) C SFCWSMX Max surface wind (kt) C IFLPR Flight level (mb) C IFLHT Flight level (hundreds of feet) C -------------------------------------------------------------- C PARAMETER (MAXFIELDS=100) CHARACTER*52 FIELD(MAXFIELDS) C C SLPMIN = -999. FLWSMX = -999. SFCWSMX = -999. IFLPR = -999 IFLHT = -999 IF (NFLD.LT.33) RETURN C IF (FIELD(43).NE.' ') READ(FIELD(43),*) SLPMIN IF (FIELD(40).NE.' ') READ(FIELD(40),*) FLWSMX IF (FIELD(36).NE.' ') READ(FIELD(36),*) SFCWSMX IF (FIELD(34).NE.' ') READ(FIELD(34),*) IFLPR IF (FIELD(33).NE.' ') READ(FIELD(33),*) IFLHT RETURN END C C C C -------------------------------------------------------------- SUBROUTINE SCATFIX(LINE,SITE) C -------------------------------------------------------------- C CHARACTER*4 SITE CHARACTER*81 LINE C SITE = LINE(78:81) C C 900 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE FIND_ACFIXES(LUT,LUFI,OFILE,STMID,NFX,NACF,TIMEACF) C C Searches fix file for aircraft fixes. C Fix file assumed to be already open if OFILE = .TRUE. C Returned array of times is in minutes since Jan 1. C Returned number of AC fixes is NACF. C -------------------------------------------------------------- C C PARAMETER (MAXFIELDS = 100) CHARACTER*1 FTYPE CHARACTER*4 FIXTYPE CHARACTER*8 STMID CHARACTER*18 FNAMEIN CHARACTER*52 FIELD(MAXFIELDS) CHARACTER*81 LINE CHARACTER*1000 LLINE DIMENSION TIMEACF(NFX) LOGICAL OFILE, FIXFILE_2002 C C C Initialize variables C -------------------- BAD = -999. NACF = 0 DO 110 L = 1,8 110 CALL UPPERCASE(STMID(L:L)) READ(STMID(5:8),*) IYEAR FIXFILE_2002 = .FALSE. IF (IYEAR.GE.2002) FIXFILE_2002 = .TRUE. C C C Open fix file? C -------------- IF (OFILE) THEN FNAMEIN(1:5) = 'data/' FNAMEIN(6:6) = 'f' FNAMEIN(7:14) = STMID FNAMEIN(15:18) = '.dat' DO 120 L = 1,18 CALL LOWERCASE(FNAMEIN(L:L)) 120 CONTINUE C OPEN(LUFI,FILE=FNAMEIN,STATUS='OLD',ERR=9000) ENDIF C C C Read fix file and record all times of aircraft fixes. C ----------------------------------------------------- REWIND(LUFI) 300 IF (FIXFILE_2002) THEN CALL READ_ATCF_FIX2002(LUFI,IERR,LLINE,FIXTYPE,NCYC, * IYEARF,IMOF,IDYF,IHRF,IMNF,RLATF,RLONF,NFLD,FIELD) ELSE CALL READ_ATCF_FIX(LUFI,IERR,LINE,FTYPE,NCYC,IYEARF,IMOF, * IDYF,IHRF,IMNF,RLATF,RLONF) FIXTYPE = ' ' IF (FTYPE.EQ.'1'.OR.FTYPE.EQ.'A'.OR. * FTYPE.EQ.'I') FIXTYPE = 'DVTS' IF (FTYPE.EQ.'2'.OR.FTYPE.EQ.'B'.OR. * FTYPE.EQ.'J') FIXTYPE = 'AIRC' IF (FTYPE.EQ.'3'.OR.FTYPE.EQ.'C'.OR. * FTYPE.EQ.'K') FIXTYPE = 'RDRC' IF (FTYPE.EQ.'4'.OR.FTYPE.EQ.'D'.OR. * FTYPE.EQ.'L') FIXTYPE = 'SYNP' IF (FTYPE.EQ.'5') FIXTYPE = 'QSCT' ENDIF C IF (IERR.EQ.1) GOTO 9000 IF (IERR.EQ.2) GOTO 1000 IF (FIXTYPE.NE.'AIRC') GOTO 300 C CALL JULIAN_DAY(IMOF,IDYF,IYEAR,JULDAY) NACF = NACF+1 TIMEACF(NACF) = FLOAT(IMNF)+FLOAT(IHRF)*60.+FLOAT(JULDAY)*1440. GOTO 300 C C C End of fix file reached. C ------------------------ 1000 IF (OFILE) THEN CLOSE(LUFI) ELSE REWIND(LUFI) ENDIF RETURN C C C Errors C ------ 9000 WRITE(LUT,'("*** FATAL ERROR: FILE I/O ERROR ***")') STOP END C C C C ---------------------------------------------------------------- SUBROUTINE MATCH_ACFIXES(IYEAR,IMO,IDY,IHR,IMN,NACF,TIMEACF, * DIFFMIN) C C Determines time difference from nearest AC fix. C Input time is given by ,IYEAR,IMO,IDY,IHR,IMN. C Array of fix times obtained from FIND_ACFIXES. C If no AC fixes, then DIFFMIN is -999. C ---------------------------------------------------------------- C C DIMENSION TIMEACF(NACF) C C DIFFMIN = 500000. CALL JULIAN_DAY(IMO,IDY,IYEAR,JULDAY) TIMEIN = FLOAT(IMN)+FLOAT(IHR)*60.+FLOAT(JULDAY)*1440. C C Determine minimum time from input array. C ---------------------------------------- IF (NACF.LE.0) THEN DIFFMIN = -999. RETURN ENDIF C DO 100 L = 1,NACF TIMEDIFF = ABS(TIMEIN-TIMEACF(L)) IF (TIMEDIFF.LT.DIFFMIN) DIFFMIN = TIMEDIFF 100 CONTINUE C RETURN END C C C C ------------------------------------------------------------- SUBROUTINE DVORAK(I,CODE) C ------------------------------------------------------------- DIMENSION DV(142) C DATA DV/25,25,25,25,25,25,26,27,28,29, * 30,31,32,33,34,35,37,39,41,43, * 45,47,49,51,53,55,57,59,61,63, * 65,67,70,72,75,77,80,82,85,87, * 90,92,95,97,100,102,105,107,110,112, * 115,117,120,122,125,127,130,132,135,137, * 140,143,146,149,152,155,158,161,164,167,170, * 1030,1030,1030,1030,1030,1030,1030,1030,1030,1030, * 1009,1008,1007,1007,1006,1005,1004,1003,1002,1001, * 1000,999,998,996,995,994,993,991,990,988, * 987,985,984,982,981,979,977,975,974,972, * 970,968,966,964,962,960,958,955,953,951, * 948,945,943,940,938,935,932,929,927,924, * 921,918,915,912,909,906,903,900,896,893,890/ C CODE = DV(I*71+(NINT(CODE)-9)) RETURN END C C C C ------------------------------------------------------------- SUBROUTINE DVORAKST(I,CODE) C ------------------------------------------------------------- DIMENSION DV(142) C DATA DV/25,26,26,27,27,28,29,30,31,32, * 33,34,35,36,37,38,40,42,44,46, * 48,50,53,55,58,60,61,62,63,64, * 65,67,70,72,75,77,80,82,85,87, * 90,92,95,97,100,102,105,107,110,112, * 115,117,120,122,125,127,130,132,135,137, * 140,143,146,149,152,155,158,161,164,167,170, * 1030,1030,1030,1030,1030,1030,1030,1030,1030,1030, * 1009,1008,1007,1007,1006,1005,1004,1003,1002,1001, * 1000,999,998,996,995,994,993,991,990,988, * 987,985,984,982,981,979,977,975,974,972, * 970,968,966,964,962,960,958,955,953,951, * 948,945,943,940,938,935,932,929,927,924, * 921,918,915,912,909,906,903,900,896,893,890/ C CODE = DV(I*71+(NINT(CODE)-9)) RETURN END C C C SUBROUTINE NEWSTMID(STMID,STMID8) CHARACTER*6 STMID CHARACTER*8 STMID8 C STMID8(1:4) = STMID(1:4) READ(STMID(5:6),*) IYR IF (IYR.LT.50) THEN IYEAR = IYR+2000 ELSE IYEAR = IYR+1900 ENDIF WRITE(STMID8(5:8),'(I4.4)') IYEAR RETURN END C C C SUBROUTINE GETFIELD(LINE,NF,ICOM,STRING,IFC) DIMENSION ICOM(500) CHARACTER*100 STRING CHARACTER*1000 LINE C IB = ICOM(NF-1)+2 IF (NF.EQ.1) IB = 1 IE = ICOM(NF)-1 STRING = ' ' READ(LINE(IB:IE),'(A)') STRING C IFC = 0 DO 100 L=1,100 IF (STRING(L:L).NE.' ') THEN IFC = L GOTO 200 ENDIF 100 CONTINUE C 200 RETURN END C C C C -------------------------------------------------------------- SUBROUTINE EXTRACT_FIXES(LUT,STMID,IMO,IDY,IHR,TOLM,FIXM, * SITEM,RLAT,RLON,WS) C C Searches fix file for specific fixes corresponding to best C track data. C C IMO,IDY,IHR: Time to search for. C TOLM: Tolerance (minutes) to accept a match. C FIXM: What kind of fix to search for (DVTS, etc.) C SITEM: Accept fixes from this site only. C RLAT,RLON,WS: Returned fix values. C -------------------------------------------------------------- C C PARAMETER (MAXFIELDS = 100) CHARACTER*1 FTYPE CHARACTER*18 FNAMEIN CHARACTER*8 STMID CHARACTER*4 SITE, SITEM, FIXM, FIXTYPE CHARACTER*52 FIELD(MAXFIELDS) CHARACTER*81 LINE CHARACTER*1000 LLINE LOGICAL FIXFILE_2002, MICROWAVE, SUBT C C C C Initialize variables C -------------------- LUFI = 199 BAD = -999. RLAT = BAD RLON = BAD WS = BAD TOLH = TOLM/60. C C DO 110 L = 1,8 110 CALL UPPERCASE(STMID(L:L)) READ(STMID(5:8),*) IYEAR FIXFILE_2002 = .FALSE. IF (IYEAR.GE.2002) FIXFILE_2002 = .TRUE. C C C Open file for current storm C ---------------------------- FNAMEIN(1:5) = 'data/' FNAMEIN(6:6) = 'f' FNAMEIN(7:14) = STMID FNAMEIN(15:18) = '.dat' C DO 120 L = 1,18 CALL LOWERCASE(FNAMEIN(L:L)) 120 CONTINUE OPEN(LUFI,FILE=FNAMEIN,STATUS='OLD',ERR=9000) C C C Now search fix file for desired fix. C -------------------------------------- 400 CONTINUE 410 IF (FIXFILE_2002) THEN CALL READ_ATCF_FIX2002(LUFI,IERR,LLINE,FIXTYPE,NCYC, * IYEARF,IMOF,IDYF,IHRF,IMNF,RLATF,RLONF,NFLD,FIELD) ELSE CALL READ_ATCF_FIX(LUFI,IERR,LINE,FTYPE,NCYC,IYEARF,IMOF, * IDYF,IHRF,IMNF,RLATF,RLONF) FIXTYPE = ' ' IF (FTYPE.EQ.'1'.OR.FTYPE.EQ.'A'.OR. * FTYPE.EQ.'I') FIXTYPE = 'DVTS' IF (FTYPE.EQ.'2'.OR.FTYPE.EQ.'B'.OR. * FTYPE.EQ.'J') FIXTYPE = 'AIRC' IF (FTYPE.EQ.'3'.OR.FTYPE.EQ.'C'.OR. * FTYPE.EQ.'K') FIXTYPE = 'RDRC' IF (FTYPE.EQ.'4'.OR.FTYPE.EQ.'D'.OR. * FTYPE.EQ.'L') FIXTYPE = 'SYNP' IF (FTYPE.EQ.'5') FIXTYPE = 'QSCT' ENDIF C IF (IERR.EQ.1) GOTO 9000 IF (IERR.EQ.2) GOTO 1000 C C C C Check to see if the fix is close enough to the besttrack time. C -------------------------------------------------------------- HRB = IHR HRF = FLOAT(IHRF)+FLOAT(IMNF)/60. CALL DIFTIME(IYEARF,IMOF,IDYF,HRF,IYEARF,IMO,IDY,HRB,DELH) IF (ABS(DELH).GT.TOLH) GOTO 400 C C C C C Check to see if this fix is the type asked for C ---------------------------------------------- 500 CONTINUE C C C SATELLITE DVORAK CLASSIFICATION C ------------------------------------------ IF (FIXTYPE.EQ.FIXM .AND. FIXTYPE.EQ.'DVTS') THEN IF (FIXFILE_2002) THEN CALL SATFIX2002(NFLD,FIELD,CI,TNUM,SITE,SUBT) ELSE MICROWAVE = .FALSE. CALL SATFIX(LINE,CI,TNUM,ODT,SITE,MICROWAVE,SUBT) IF (MICROWAVE) GOTO 410 ENDIF C IF (SITE.EQ.'KMIA' .OR. SITE.EQ.'TSAF') SITE = 'TAFB' IF (SITE.EQ.'SAB ' .OR. SITE.EQ.' SAB') SITE = 'KSAB' IF (SITE.EQ.'GWC ' .OR. SITE.EQ.' GWC') SITE = 'KGWC' IF (SITE.NE.SITEM) GOTO 410 RLAT = RLATF RLON = RLONF IF (CI.EQ.0) GOTO 600 CIW = CI CIP = CI IF (CIW.GE.10) THEN CALL DVORAK(0,CIW) WS = CIW ENDIF GOTO 600 ENDIF C C C C Fix was not one that we wanted. Go back for next fix. C ----------------------------------------------------- GOTO 400 C C C Found desired fix. Return C --------------------------------------------------- 600 CLOSE(LUFI) RETURN C C C End of fix file reached without finding fix. C ------------------------------------------------ 1000 CLOSE(LUFI) RETURN C C C Errors C ------ 9000 WRITE(LUT,'("*** FATAL ERROR: FILE I/O ERROR ***")') STOP END C C C C C ----------------------------------------------------------- SUBROUTINE BT_INTERP(NBT,BMO,BDY,BHR,BLAT,BLON,BWS,BPR, * IN_MO,IN_DY,IN_HR,IN_MN, * XLAT,XLON,XWS,XPR) C C Interpolates from best track to a specified time. C ----------------------------------------------------------- C DIMENSION BMO(NBT),BDY(NBT),BHR(NBT),BLAT(NBT),BLON(NBT) DIMENSION BWS(NBT),BPR(NBT),BTIME(NBT) DIMENSION MDAYS(12) C DATA MDAYS/31,28,31,30,31,30,31,31,30,31,30,31/ C BAD = -999. XLAT = BAD XLON = BAD XWS = BAD XPR = BAD MONB1 = NINT(BMO(1)) IN_DAYS = IN_DY IF (IN_MO.GT.MONB1) IN_DAYS = IN_DAYS+MDAYS(MONB1) TIME_IN = FLOAT(IN_MN+IN_HR*60+IN_DAYS*1440) C 100 DO 120 I=1,NBT DAYS = BDY(I) IF (BMO(I).GT.MONB1) DAYS = DAYS+FLOAT(MDAYS(MONB1)) BTIME(I) = DAYS*1440. + BHR(I)*60. 120 CONTINUE C CALL POLATE(NBT,BTIME,BLAT,TIME_IN,BTLATI,M,BAD) CALL POLATE(NBT,BTIME,BLON,TIME_IN,BTLONI,M,BAD) CALL POLATE(NBT,BTIME,BWS,TIME_IN,BTWSI,M,BAD) CALL POLATE(NBT,BTIME,BPR,TIME_IN,BTPRI,M,BAD) IF (M.GT.1) THEN TIMEDIFF = 0. TIMEDIFF = BTIME(M) - BTIME(M-1) IF (TIMEDIFF.GT.360) THEN BTLATI = BAD BTLONI = BAD BTWSI = BAD BTPRI = BAD ENDIF ENDIF C XLAT = BTLATI XLON = BTLONI XWS = BTWSI XPR = BTPRI RETURN END C C C C ------------------------------------------------------------- SUBROUTINE BT_INTERPMN(NBT,BMO,BDY,BHR,BMN,BLAT,BLON,BWS,BPR, * IN_MO,IN_DY,IN_HR,IN_MN, * XLAT,XLON,XWS,XPR) C C Interpolates from best track to a specified time. C ------------------------------------------------------------- C DIMENSION BMO(NBT),BDY(NBT),BHR(NBT),BMN(NBT) DIMENSION BLAT(NBT),BLON(NBT) DIMENSION BWS(NBT),BPR(NBT),BTIME(NBT) DIMENSION MDAYS(12) C DATA MDAYS/31,28,31,30,31,30,31,31,30,31,30,31/ C BAD = -999. XLAT = BAD XLON = BAD XWS = BAD XPR = BAD MONB1 = NINT(BMO(1)) IN_DAYS = IN_DY IF (IN_MO.GT.MONB1) IN_DAYS = IN_DAYS+MDAYS(MONB1) TIME_IN = FLOAT(IN_MN+IN_HR*60+IN_DAYS*1440) C 100 DO 120 I=1,NBT DAYS = BDY(I) IF (BMO(I).GT.MONB1) DAYS = DAYS+FLOAT(MDAYS(MONB1)) BTIME(I) = DAYS*1440. + BHR(I)*60. + BMN(I) 120 CONTINUE C CALL POLATE(NBT,BTIME,BLAT,TIME_IN,BTLATI,M,BAD) CALL POLATE(NBT,BTIME,BLON,TIME_IN,BTLONI,M,BAD) CALL POLATE(NBT,BTIME,BWS,TIME_IN,BTWSI,M,BAD) CALL POLATE(NBT,BTIME,BPR,TIME_IN,BTPRI,M,BAD) IF (M.GT.1) THEN TIMEDIFF = 0. TIMEDIFF = BTIME(M) - BTIME(M-1) IF (TIMEDIFF.GT.360) THEN BTLATI = BAD BTLONI = BAD BTWSI = BAD BTPRI = BAD ENDIF ENDIF C XLAT = BTLATI XLON = BTLONI XWS = BTWSI XPR = BTPRI RETURN END C C C C --------------------------------------------------- SUBROUTINE WWUS(LUF,STMIDIN,IMO,IDY,IHR, * TSWATCH,TSWARN,HWATCH,HWARN) C C Determines whether a US mainland watch or warning C was in effect at or after t0. Searches up to 125 C hours after t0 in the following intervals: C C # INTERVAL C ------------- C 1 t0,t0+5 h C 2 t12,t0+17 C 3 t24,t0+29 C 4 t36,t0+41 C 5 t48,t0+53 C 6 t72,t0+77 C 7 t96,t0+101 C 8 t120,t0+125 C C Requires that watch/warning file already be open. C --------------------------------------------------- C PARAMETER (NHRS=126, NVTX=8) DIMENSION MDAYS(12) DIMENSION IMONTH(NHRS),IDAY(NHRS),IHOUR(NHRS) CHARACTER*8 STMIDIN, STMID CHARACTER*10 STMNAME CHARACTER*60 LINE LOGICAL TSWATCH(NVTX),TSWARN(NVTX) LOGICAL HWATCH(NVTX),HWARN(NVTX) C DATA MDAYS/31,28,31,30,31,30,31,31,30,31,30,31/ C C C Initialize variables C -------------------- DO 50 L=1,NVTX TSWATCH(L) = .FALSE. TSWARN(L) = .FALSE. HWATCH(L) = .FALSE. HWARN(L) = .FALSE. 50 CONTINUE REWIND(LUF) C C C Determine the time intervals to search for. C ------------------------------------------- IMONTH(1) = IMO IDAY(1) = IDY IHOUR(1) = IHR DO 100 L = 2,NHRS IMONTH(L) = IMONTH(L-1) IDAY(L) = IDAY(L-1) IHOUR(L) = IHOUR(L-1)+1 IF (IHOUR(L).GE.24) THEN IHOUR(L) = IHOUR(L)-24 IDAY(L) = IDAY(L)+1 ENDIF IF (IDAY(L).GE.MDAYS(IMONTH(L))) THEN IDAY(L) = 1 IMONTH(L)= IMONTH(L)+1 ENDIF 100 CONTINUE C C C Read line from watch/warning file C --------------------------------- 200 READ(LUF,'(A)',END=1000) LINE READ(LINE,'(I2,1X,I2,1X,I4,1X,I2,1X,A10,I2,1X,A8)',ERR=900) * IMW,IDW,IYRW,IHW,STMNAME,NREC,STMID C C C Does this match the storm ID? If not, skip to next block C --------------------------------------------------------- IF (STMID.NE.STMIDIN) THEN DO 220 I=1,NREC 220 READ(LUF,'(A)',END=1000) LINE GOTO 200 ENDIF C C C We have a storm match. Now check times C --------------------------------------- DO 310 I=1,NREC READ(LUF,'(I1)') NWW DO 320 L=1,NHRS IF (IMONTH(L).EQ.IMW .AND. * IDAY(L).EQ.IDW .AND. * IHOUR(L).EQ.IHW) THEN IX = 0 IF (L.GE.1 .AND. L.LE.6) IX = 1 IF (L.GE.8 .AND. L.LE.13) IX = 2 IF (L.GE.20 .AND. L.LE.25) IX = 3 IF (L.GE.32 .AND. L.LE.37) IX = 4 IF (L.GE.44 .AND. L.LE.49) IX = 5 IF (L.GE.68 .AND. L.LE.73) IX = 6 IF (L.GE.92 .AND. L.LE.97) IX = 7 IF (L.GE.116 .AND. L.LE.121) IX = 8 IF (IX.EQ.0) GOTO 320 IF (NWW.EQ.1) TSWATCH(IX)=.TRUE. IF (NWW.EQ.2) TSWARN(IX) =.TRUE. IF (NWW.EQ.5) HWATCH(IX) =.TRUE. IF (NWW.EQ.6) HWARN(IX) =.TRUE. ENDIF 320 CONTINUE 310 CONTINUE C C C Go back for next date/time group. C --------------------------------- GOTO 200 C C C Error C ----- 900 WRITE(1,'(" Error after line: ",/,A)') LINE STOP C C C End of file, return C ------------------- 1000 RETURN END C C C C --------------------------------------------------- SUBROUTINE WWUS7(LUF,STMIDIN,IMO,IDY,IHR, * TSWATCH,TSWARN,HWATCH,HWARN) C C Determines whether a US mainland watch or warning C was in effect at or after t0. C Requires that watch/warning file already be open. C C Note - Believe this routine is flawed because the C warning array length of 10 wasn't updated when C NVTX of the calling program was increased to 15. C JLF 2/27/20. C --------------------------------------------------- C PARAMETER (NHRS=174, NVTX=10) DIMENSION MDAYS(12) DIMENSION IMONTH(NHRS),IDAY(NHRS),IHOUR(NHRS) CHARACTER*8 STMIDIN, STMID CHARACTER*10 STMNAME CHARACTER*60 LINE LOGICAL TSWATCH(NVTX),TSWARN(NVTX) LOGICAL HWATCH(NVTX),HWARN(NVTX) C DATA MDAYS/31,28,31,30,31,30,31,31,30,31,30,31/ C C C Initialize variables C -------------------- DO 50 L=1,NVTX TSWATCH(L) = .FALSE. TSWARN(L) = .FALSE. HWATCH(L) = .FALSE. HWARN(L) = .FALSE. 50 CONTINUE REWIND(LUF) C C C Determine the time intervals to search for. C ------------------------------------------- IMONTH(1) = IMO IDAY(1) = IDY IHOUR(1) = IHR DO 100 L = 2,NHRS IMONTH(L) = IMONTH(L-1) IDAY(L) = IDAY(L-1) IHOUR(L) = IHOUR(L-1)+1 IF (IHOUR(L).GE.24) THEN IHOUR(L) = IHOUR(L)-24 IDAY(L) = IDAY(L)+1 ENDIF IF (IDAY(L).GE.MDAYS(IMONTH(L))) THEN IDAY(L) = 1 IMONTH(L)= IMONTH(L)+1 ENDIF 100 CONTINUE C C C Read line from watch/warning file C --------------------------------- 200 READ(LUF,'(A)',END=1000) LINE READ(LINE,'(I2,1X,I2,1X,I4,1X,I2,1X,A10,I2,1X,A8)',ERR=900) * IMW,IDW,IYRW,IHW,STMNAME,NREC,STMID C C C Does this match the storm ID? If not, skip to next block C --------------------------------------------------------- IF (STMID.NE.STMIDIN) THEN DO 220 I=1,NREC 220 READ(LUF,'(A)',END=1000) LINE GOTO 200 ENDIF C C C We have a storm match. Now check times C --------------------------------------- DO 310 I=1,NREC READ(LUF,'(I1)') NWW DO 320 L=1,NHRS IF (IMONTH(L).EQ.IMW .AND. * IDAY(L).EQ.IDW .AND. * IHOUR(L).EQ.IHW) THEN IX = 0 IF (L.GE.1 .AND. L.LE.6) IX = 1 IF (L.GE.8 .AND. L.LE.13) IX = 2 IF (L.GE.20 .AND. L.LE.25) IX = 3 IF (L.GE.32 .AND. L.LE.37) IX = 4 IF (L.GE.44 .AND. L.LE.49) IX = 5 IF (L.GE.68 .AND. L.LE.73) IX = 6 IF (L.GE.92 .AND. L.LE.97) IX = 7 IF (L.GE.116 .AND. L.LE.121) IX = 8 IF (L.GE.140 .AND. L.LE.145) IX = 9 IF (L.GE.164 .AND. L.LE.169) IX = 10 IF (IX.EQ.0) GOTO 320 IF (NWW.EQ.1) TSWATCH(IX)=.TRUE. IF (NWW.EQ.2) TSWARN(IX) =.TRUE. IF (NWW.EQ.5) HWATCH(IX) =.TRUE. IF (NWW.EQ.6) HWARN(IX) =.TRUE. ENDIF 320 CONTINUE 310 CONTINUE C C C Go back for next date/time group. C --------------------------------- GOTO 200 C C C Error C ----- 900 WRITE(1,'(" Error after line: ",/,A)') LINE STOP C C C End of file, return C ------------------- 1000 RETURN END C C C C --------------------------------------------------- SUBROUTINE WWUS15(LUF,STMIDIN,IMO,IDY,IHR, * TSWATCH,TSWARN,HWATCH,HWARN) C C Determines whether a US mainland watch or warning C was in effect at various lead times after the C specified input date/time of IMO/IDY/IHR (t0). C C This version is for NVTX=15, 12-hourly verification C times out to 168 hours. Searches for existing W/Ws C after t0 in the following intervals: C C # VT Search Interval C ------------------------ C 1 000 1-6 h C 2 012 8-13 C 3 024 20-25 C 4 036 32-37 C 5 048 44-49 C 6 060 56-61 C 7 072 68-73 C 8 084 80-85 C 9 096 92-97 C 10 108 104-109 C 11 120 116-121 C 12 132 128-133 C 13 144 140-145 C 14 156 152-157 C 15 168 164-169 C C For example, if the input (initial) time is 9/1/00Z, C then a warning at 9/1/21Z would flag the t=24 h C verification time of 9/2/00Z as having a warning in C effect (becasuse the warning was issued between 20 and C 25 hours after the initial time). C C All the warnings for a given storm are checked against C the initial time. C C Requires that watch/warning file already be open. C --------------------------------------------------- C PARAMETER (NHRS=174, NVTX=15) DIMENSION MDAYS(12) DIMENSION IMONTH(NHRS),IDAY(NHRS),IHOUR(NHRS) CHARACTER*8 STMIDIN, STMID CHARACTER*10 STMNAME CHARACTER*60 LINE LOGICAL TSWATCH(NVTX),TSWARN(NVTX) LOGICAL HWATCH(NVTX),HWARN(NVTX) C DATA MDAYS/31,28,31,30,31,30,31,31,30,31,30,31/ C C C Initialize variables C -------------------- DO 50 L=1,NVTX TSWATCH(L) = .FALSE. TSWARN(L) = .FALSE. HWATCH(L) = .FALSE. HWARN(L) = .FALSE. 50 CONTINUE REWIND(LUF) C C C Determine the time intervals to search for. C ------------------------------------------- IMONTH(1) = IMO IDAY(1) = IDY IHOUR(1) = IHR DO 100 L = 2,NHRS IMONTH(L) = IMONTH(L-1) IDAY(L) = IDAY(L-1) IHOUR(L) = IHOUR(L-1)+1 IF (IHOUR(L).GE.24) THEN IHOUR(L) = IHOUR(L)-24 IDAY(L) = IDAY(L)+1 ENDIF IF (IDAY(L).GE.MDAYS(IMONTH(L))) THEN IDAY(L) = 1 IMONTH(L)= IMONTH(L)+1 ENDIF 100 CONTINUE C C C Read line from watch/warning file C --------------------------------- 200 READ(LUF,'(A)',END=1000) LINE READ(LINE,'(I2,1X,I2,1X,I4,1X,I2,1X,A10,I2,1X,A8)',ERR=900) * IMW,IDW,IYRW,IHW,STMNAME,NREC,STMID C C C Does this match the storm ID? If not, skip to next block C --------------------------------------------------------- IF (STMID.NE.STMIDIN) THEN DO 220 I=1,NREC 220 READ(LUF,'(A)',END=1000) LINE GOTO 200 ENDIF C C C We have a storm match. Now check times C --------------------------------------- DO 310 I=1,NREC READ(LUF,'(I1)') NWW DO 320 L=1,NHRS IF (IMONTH(L).EQ.IMW .AND. * IDAY(L).EQ.IDW .AND. * IHOUR(L).EQ.IHW) THEN IX = 0 IF (L.GE.1 .AND. L.LE.6) IX = 1 IF (L.GE.8 .AND. L.LE.13) IX = 2 IF (L.GE.20 .AND. L.LE.25) IX = 3 IF (L.GE.32 .AND. L.LE.37) IX = 4 IF (L.GE.44 .AND. L.LE.49) IX = 5 IF (L.GE.56 .AND. L.LE.61) IX = 6 IF (L.GE.68 .AND. L.LE.73) IX = 7 IF (L.GE.80 .AND. L.LE.85) IX = 8 IF (L.GE.92 .AND. L.LE.97) IX = 9 IF (L.GE.104 .AND. L.LE.109) IX = 10 IF (L.GE.116 .AND. L.LE.121) IX = 11 IF (L.GE.128 .AND. L.LE.133) IX = 12 IF (L.GE.140 .AND. L.LE.145) IX = 13 IF (L.GE.152 .AND. L.LE.157) IX = 14 IF (L.GE.164 .AND. L.LE.169) IX = 15 C IF (IX.EQ.0) GOTO 320 IF (NWW.EQ.1) TSWATCH(IX)=.TRUE. IF (NWW.EQ.2) TSWARN(IX) =.TRUE. IF (NWW.EQ.5) HWATCH(IX) =.TRUE. IF (NWW.EQ.6) HWARN(IX) =.TRUE. ENDIF 320 CONTINUE 310 CONTINUE C C C Go back for next date/time group. C --------------------------------- GOTO 200 C C C Error C ----- 900 WRITE(1,'(" Error after line: ",/,A)') LINE STOP C C C End of file, return C ------------------- 1000 RETURN END C C C C --------------------------------------------------- SUBROUTINE WW_TABLE(LUT,LUFI,LUFO,STMIDIN) C C Searches watch/warning table for all entries for C a given storm and writes them out in tabular form. C C Requires that watch/warning file already be open. C --------------------------------------------------- C PARAMETER (NWTYPES=6, NWMAX=20) DIMENSION NWARN(NWTYPES), NWARNP(NWTYPES) CHARACTER*8 STMIDIN, STMID CHARACTER*10 STMNAME CHARACTER*36 ACTION CHARACTER*22 CWARN(NWTYPES) CHARACTER*25 BREAK1,BREAK2,BREAK1P,BREAK2P CHARACTER*50 LINE,WARN(NWTYPES,NWMAX), WARNP(NWTYPES,NWMAX) LOGICAL WUSED(NWTYPES,NWMAX), WUSEDP(NWTYPES,NWMAX) C DATA CWARN/'Tropical Storm Watch ', * 'Tropical Storm Warning', * 'Gale Warning ', * 'Storm Warning ', * 'Hurricane Watch ', * 'Hurricane Warning '/ C C C Rewind file, initialize variables C --------------------------------- REWIND(LUFI) DO 110 L=1,NWTYPES NWARNP(L) = 0 DO 120 K=1,NWMAX WARN(L,K) = ' ' WARNP(L,K) = ' ' WUSED(L,K) = .FALSE. WUSEDP(L,K) = .FALSE. 120 CONTINUE 110 CONTINUE NLINES = 0 C C C Read line from watch/warning file C --------------------------------- 200 NLINES = NLINES+1 READ(LUFI,'(A)',END=1000) LINE C WRITE(LUT,'(A)') LINE READ(LINE,'(I2,1X,I2,1X,I4,1X,I2,1X,A10,I2,1X,A8)',ERR=1900) * IMW,IDW,IYRW,IHW,STMNAME,NREC,STMID C C C Does this match the storm ID? If not, skip to next block C --------------------------------------------------------- IF (STMID.NE.STMIDIN) THEN IF (NREC.GT.0) THEN DO 220 I=1,NREC NLINES=NLINES+1 220 READ(LUFI,'(A)',END=1000) LINE ENDIF GOTO 200 ENDIF C C C We have a storm match. Read all current warnings. C -------------------------------------------------- 300 DO 305 I = 1,NWTYPES 305 NWARN(I) = 0 IF (NREC.EQ.0) GOTO 330 DO 310 I = 1,NREC NLINES = NLINES+1 READ(LUFI,'(A)') LINE C WRITE(LUT,'(A)') LINE READ(LINE,'(I1)') IWT NWARN(IWT) = NWARN(IWT)+1 WARN(IWT,NWARN(IWT)) = LINE(4:50) WUSED(IWT,NWARN(IWT)) = .FALSE. 310 CONTINUE C C C Compare current warnings to previous warnings. C ---------------------------------------------- 330 CONTINUE C C C Check for upgrades or downgrades w/identical breakpoints C -------------------------------------------------------- DO 340 I = 1,NWTYPES DO 345 J = 1,NWARNP(I) CALL GETBREAK(WARNP(I,J),BREAK1P,BREAK2P) DO 346 M = 1,NWARN(I) IF (WARNP(I,J).EQ.WARN(I,M)) GOTO 345 346 CONTINUE DO 350 K = 1,NWTYPES IF (I.EQ.K) GOTO 350 DO 355 L = 1,NWARN(K) CALL GETBREAK(WARN(K,L),BREAK1,BREAK2) CALL NMATCHES(BREAK1,BREAK2,BREAK1P,BREAK2P,NM) IF (NM.LT.2) GOTO 355 IF (WUSED(K,L)) GOTO 355 WRITE(ACTION,'("changed to ",A)') CWARN(K) CALL WRWARN(LUFO,IDW,IHW,CWARN(I),ACTION, * BREAK1,BREAK2) WUSEDP(I,J) = .TRUE. WUSED(K,L) = .TRUE. 355 CONTINUE 350 CONTINUE 345 CONTINUE 340 CONTINUE C C C Check remaining warnings for changes. C ------------------------------------- DO 440 I = 1,NWTYPES C C If no warnings of this type are currently in effect. C ---------------------------------------------------- IF (NWARN(I).EQ.0) THEN IF (NWARNP(I).EQ.0) GOTO 440 DO 441 J = 1,NWARNP(I) IF (.NOT.WUSEDP(I,J)) THEN ACTION = 'discontinued' BREAK1 = 'All' BREAK2 = BREAK1 CALL WRWARN(LUFO,IDW,IHW,CWARN(I),ACTION, * BREAK1,BREAK2) GOTO 440 ENDIF 441 CONTINUE GOTO 440 ENDIF C C If no warnings of type were previously in effect. C ---------------------------------------------------- IF (NWARNP(I).EQ.0) THEN DO 450 J = 1,NWARN(I) IF (WUSED(I,J)) GOTO 450 ACTION = 'issued' CALL GETBREAK(WARN(I,J),BREAK1,BREAK2) CALL WRWARN(LUFO,IDW,IHW,CWARN(I),ACTION,BREAK1,BREAK2) 450 CONTINUE GOTO 440 ENDIF C C C Some are and some were. Discontinue any old ones. C -------------------------------------------------- DO 460 J = 1,NWARNP(I) IF (WUSEDP(I,J)) GOTO 460 CALL GETBREAK(WARNP(I,J),BREAK1P,BREAK2P) DO 465 K = 1,NWARN(I) CALL GETBREAK(WARN(I,K),BREAK1,BREAK2) CALL NMATCHES(BREAK1,BREAK2,BREAK1P,BREAK2P,NM) IF (NM.GE.2) GOTO 460 IF (NM.EQ.1) THEN ACTION = 'modified to' CALL WRWARN(LUFO,IDW,IHW,CWARN(I),ACTION, * BREAK1,BREAK2) GOTO 460 ENDIF 465 CONTINUE ACTION = 'discontinued' CALL WRWARN(LUFO,IDW,IHW,CWARN(I),ACTION,BREAK1P,BREAK2P) 460 CONTINUE C C C Print out any new ones. C ----------------------- DO 480 J = 1,NWARN(I) IF (WUSED(I,J)) GOTO 480 CALL GETBREAK(WARN(I,J),BREAK1,BREAK2) DO 470 K = 1,NWARNP(I) IF (WUSEDP(I,K)) GOTO 470 CALL GETBREAK(WARNP(I,K),BREAK1P,BREAK2P) CALL NMATCHES(BREAK1,BREAK2,BREAK1P,BREAK2P,NM) IF (NM.GE.1) GOTO 480 470 CONTINUE ACTION = 'issued' CALL WRWARN(LUFO,IDW,IHW,CWARN(I),ACTION,BREAK1,BREAK2) 480 CONTINUE C C C Go on to next warning type. C --------------------------- 440 CONTINUE C C C Save all current warnings and C Go back for next date/time group. C --------------------------------- 500 DO 510 I = 1,NWTYPES NWARNP(I) = NWARN(I) DO 520 J = 1,NWARN(I) WARNP(I,J) = WARN(I,J) WUSEDP(I,J) = .FALSE. 520 CONTINUE DO 530 J = NWARN(I)+1,NWMAX WARNP(I,J) = ' ' WUSEDP(I,J) = .FALSE. 530 CONTINUE 510 CONTINUE GOTO 200 C C C End of file, return C ------------------- 1000 RETURN C C Errors C ------ 1900 WRITE(LUT,'("Input file error on line ",I6,":",/,A)') * NLINES, LINE END C C C C ------------------------------------------------------------- SUBROUTINE WRWARN(LUFO,IDW,IHW,WARNING,ACTION,BREAK1,BREAK2) C ------------------------------------------------------------- C CHARACTER*36 ACTION CHARACTER*22 WARNING CHARACTER*58 WARNACT CHARACTER*25 BREAK1,BREAK2 CHARACTER*54 BREAKPOINTS C DO 100 L=25,1,-1 IF (BREAK1(L:L).NE.' ') THEN N1E = L GOTO 105 ENDIF 100 CONTINUE 105 DO 110 L=25,1,-1 IF (BREAK2(L:L).NE.' ') THEN N2E = L GOTO 115 ENDIF 110 CONTINUE C 115 BREAKPOINTS = ' ' IF (BREAK1.EQ.BREAK2) THEN BREAKPOINTS = BREAK1 ELSE BREAKPOINTS(1:N1E) = BREAK1(1:N1E) BREAKPOINTS(N1E+1:N1E+4) = ' to ' BREAKPOINTS(N1E+5:N1E+4+N2E) = BREAK2(1:N2E) ENDIF C DO 117 L=54,1,-1 IF (BREAKPOINTS(L:L).NE.' ') THEN NBE = L GOTO 119 ENDIF 117 CONTINUE C 119 DO 120 L=22,1,-1 IF (WARNING(L:L).NE.' ') THEN NWE = L GOTO 125 ENDIF 120 CONTINUE C 125 DO 130 L=36,1,-1 IF (ACTION(L:L).NE.' ') THEN NAE = L GOTO 135 ENDIF 130 CONTINUE C 135 WARNACT = ' ' WARNACT(1:NWE) = WARNING(1:NWE) WARNACT(NWE+1:NWE+1) = ' ' WARNACT(NWE+2:NWE+1+NAE) = ACTION(1:NAE) C WRITE(LUFO,399) IDW,'/',IHW*100,CHAR(9),WARNACT(1:NWE+1+NAE), * CHAR(9),BREAKPOINTS(1:NBE) 399 FORMAT(I2,1X,A1,1X,I4.4,A,A,A,A) RETURN END C C C C ---------------------------------------------------------- SUBROUTINE GETBREAK(BREAK,BREAK1,BREAK2) C ---------------------------------------------------------- C CHARACTER*50 BREAK CHARACTER*25 BREAK1,BREAK2 C BREAK1 = ' ' BREAK2 = ' ' NEQ1 = 0 NEQ2 = 0 DO 110 L=1,50 IF (BREAK(L:L).EQ.'=' .AND. NEQ1.EQ.0) NEQ1 = L IF (BREAK(L:L).EQ.'=' .AND. NEQ1.GT.0) NEQ2 = L 110 CONTINUE BREAK1 = BREAK(1:NEQ1-1) BREAK2 = BREAK(NEQ1+1:NEQ2-1) RETURN END C C C -------------------------------------- SUBROUTINE NMATCHES(CN1,CN2,CO1,CO2,N) C -------------------------------------- CHARACTER*25 CN1,CN2,CO1,CO2 C N = 0 IF (CN1.EQ.CO1) N = N+1 IF (CN1.EQ.CO2) N = N+1 IF (CN2.EQ.CO1) N = N+1 IF (CN2.EQ.CO2) N = N+1 RETURN END C C C C --------------------------------------------------- SUBROUTINE WW_COUNT(LUT,LUFI,LUFO,IWTYPE) C C Tabulates data from WW file. C C Requires that watch/warning file and the output C file already be open. C --------------------------------------------------- C PARAMETER (NWTYPES=6, NWMAX=20, NYEARS=50) DIMENSION IYEAR(NYEARS), TOTAL_TIME(NYEARS) CHARACTER*8 STMID, STMID2 CHARACTER*10 STMNAME, STMNAME2 CHARACTER*22 CWARN(NWTYPES) CHARACTER*50 LINE LOGICAL MATCH C DATA CWARN/'Tropical Storm Watch ', * 'Tropical Storm Warning', * 'Gale Warning ', * 'Storm Warning ', * 'Hurricane Watch ', * 'Hurricane Warning '/ C C C Rewind file, initialize variables C --------------------------------- REWIND(LUFI) DEFAULT_INT = 6. IY_START = 1970 IY_STOP = 2006 DO 100 I = 1,NYEARS IYEAR(I) = IY_START-1+I TOTAL_TIME(I) = 0. 100 CONTINUE C C C Read one block from watch/warning file C Including header line from next block. C -------------------------------------- 200 CONTINUE READ(LUFI,'(A)',END=1000) LINE 210 READ(LINE,'(I2,1X,I2,1X,I4,1X,I2,1X,A10,I2,1X,A8)',ERR=1900) * IMW,IDW,IYRW,IHW,STMNAME,NREC,STMID MATCH = .FALSE. IF (NREC.EQ.0) GOTO 230 DO 220 I = 1,NREC READ(LUFI,'(A)') LINE READ(LINE,'(I1)') IWT IF (IWT.EQ.IWTYPE) MATCH = .TRUE. 220 CONTINUE C 230 IF (.NOT. MATCH) GOTO 200 C C C There was a watch/warning of the desired type in the last block C Read next header to see if same storm or not. C --------------------------------------------------------------- READ(LUFI,'(A)',END=1000) LINE READ(LINE,'(I2,1X,I2,1X,I4,1X,I2,1X,A10,I2,1X,A8)',ERR=1900) * IMW2,IDW2,IYRW2,IHW2,STMNAME2,NREC2,STMID2 IX = IYRW-IY_START+1 C C C If same storm, need to determine elapsed time C --------------------------------------------- IF (STMID.EQ.STMID2) THEN HW = FLOAT(IHW) HW2 = FLOAT(IHW2) CALL DIFTIME(IYRW,IMW,IDW,HW,IYRW2,IMW2,IDW2,HW2,DIFF) ELSE DIFF = DEFAULT_INT IF (IHW.EQ.0.OR.IHW.EQ.6.OR.IHW.EQ.12.OR.IHW.EQ.18) DIFF=3.0 ENDIF C C C Add elapsed time to year's total. C --------------------------------- TOTAL_TIME(IX) = TOTAL_TIME(IX) + DIFF C C C Go back for next block. Header has already been read. C ------------------------------------------------------ GOTO 210 C C C End of file, return C ------------------- 1000 WRITE(LUFO,'("Total hours for: ",a22)') CWARN(IWTYPE) DO 1050 I=1,NYEARS IF (IYEAR(I).LE. IY_STOP) WRITE(LUFO,'(I4,2X,F10.1)') * IYEAR(I),TOTAL_TIME(I) 1050 CONTINUE RETURN C C C Errors C ------ 1900 WRITE(LUT,'("Input file error on line:",/,A)') LINE END C C C C ------------------------------------------------------- SUBROUTINE KZC_PW(ISTAT,WS,FWDSPD,IRAD, * POCI,RLAT,KZC_PRESS) C C Routine computes Knaff-Zehr-Courtney pressure C (Courtney and Knaff 2009). Based on Landsea C implementation, Jan 2011). C C Modifications 4/11 for weaker systems. C C ISTAT Cyclone type C WS Storm intensity (kt) C FWDSPD Translation speed (kt) C IRAD1-4 34 kt wind radii (nm) C POCI Pressure of outermost closed isobar (mb) C RLAT Storm latitude (degrees) C KZC_PRESS Output minimum central pressure C ------------------------------------------------------- C DIMENSION IRAD(4) CHARACTER*2 ISTAT LOGICAL DEBUG C DEBUG = .FALSE. C IF (DEBUG) THEN WRITE(1,'(/"ISTAT,WSPD,FWDSPD: ",A2,2F10.0)') * ISTAT,WS,FWDSPD WRITE(1,'("34 KT RADII: ",4I6)') (IRAD(L),L=1,4) WRITE(1,'("POCI,RLAT: ",2F10.1)') POCI,RLAT ENDIF C KZC_PRESS = -999 IF (WS.LE.0. .OR. FWDSPD.LT.0. .OR. POCI.LE.0. .OR. * RLAT.LT.-90.) RETURN IF (ISTAT.NE.'TD' .AND. * ISTAT.NE.'TS' .AND. * ISTAT.NE.'HU') RETURN C RADSUM = 0 NRAD = 0 DO 100 L=1,4 IF (IRAD(L).GT.0) THEN RADSUM = RADSUM+FLOAT(IRAD(L)) NRAD = NRAD+1 ENDIF 100 CONTINUE C V500_CLIMO = WS*((66.785 - 0.09102*WS + 1.0619*(RLAT - * 25.))/500.)**(0.1147 + 0.0055*WS - * 0.001*(RLAT - 25.)) SR_WIND = WS - 1.5 * FWDSPD**(0.63) C C Size is handled differently for TS/H vs TDs C ------------------------------------------- IF (NRAD.GT.0) THEN AVGRAD = RADSUM/FLOAT(NRAD) V500 = AVGRAD/9. - 3. SIZE = V500/V500_CLIMO ELSE SIZE = 0.5 ENDIF C C Compute KZC pressure C -------------------- KZC_PRESS = NINT(23.286 - 0.483*SR_WIND - * (SR_WIND/24.254)**(2.) - * 12.587*SIZE - 0.483*RLAT + POCI + 2.) C C Now a final adjustment for weaker systems. Sets C a minimum delta-p based on wind speed. C --------------------------------------------- IDELTA = 0 IDELP = NINT(POCI) - KZC_PRESS IF (NINT(WS).LE.20 .AND. IDELP.LT.2) IDELTA = 2 IF (NINT(WS).EQ.25 .AND. IDELP.LT.3) IDELTA = 3 IF (NINT(WS).EQ.30 .AND. IDELP.LT.4) IDELTA = 4 IF (NINT(WS).EQ.35 .AND. IDELP.LT.5) IDELTA = 5 IF (NINT(WS).EQ.40 .AND. IDELP.LT.6) IDELTA = 6 IF (NINT(WS).EQ.45 .AND. IDELP.LT.8) IDELTA = 8 IF (NINT(WS).EQ.50 .AND. IDELP.LT.10) IDELTA = 10 IF (IDELTA.GT.0) KZC_PRESS = NINT(POCI)-IDELTA C C IF (DEBUG) WRITE(1,'("KZC PRESS = ",I5)') KZC_PRESS C RETURN END C C C C ------------------------------------------------------------ SUBROUTINE BTCLIP5(BASIN,IYR,IMO,IDY,IHR,NBT,BMO,BDY,BHR, * BLAT,BLON,BWS,CLAT,CLON,SWND) C C Returns best-track cliper forecast. Output is at 12, 24, 36, C 48, 60, 72, 84, 96, 108, and 120 h. C Valid for Atlantic and East Pacific. EP coefficients used C for CP. C C BASIN AL or EP or CP. C IYR Year (4 digit) C IMO,IDY,IHR Time to compute a cliper forecast for. C NBT Number of elements in the best track data arrays. C BMO,BDY,BHR Arrays of best track dates/times. C BLAT(NBT) BT latitude (deg N). C BLON(NBT) BT longitude (deg E). C BWS(NBT) BT wind speed (kt). C CLAT(NVTX) Returned array of BT CLIPER lats. C CLON(NVTX) Returned array of BT CLIPER lons. C SWND(NVTX) Returned array of BT SHIFOR winds. C ------------------------------------------------------------ C PARAMETER (NVTX=10) DIMENSION BMO(NBT), BDY(NBT), BHR(NBT) DIMENSION BLAT(NBT), BLON(NBT), BWS(NBT) DIMENSION CLAT(NVTX), CLON(NVTX) DIMENSION FPCLIP(2,NVTX), IWSHIF(NVTX), SWND(NVTX) CHARACTER*2 BASIN C C C RLAT0 = -999. RLON0 = -999. RLAT12= -999. RLON12= -999. DIR0 = -999. SPD0 = -999. WS0 = -999. WS12 = -999. DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE C C C Compute input parameters for the CLIPER subroutine. C Start by checking for a BT match to desired time. C --------------------------------------------------- DO 110 L = 1,NBT IF (IMO.EQ.NINT(BMO(L)).AND.IDY.EQ.NINT(BDY(L)) * .AND.IHR.EQ.NINT(BHR(L))) * THEN L0 = L GOTO 200 ENDIF 110 CONTINUE C C Could not find a best track entry for the requested time C -------------------------------------------------------- GOTO 800 C C C Found a valid match at index L0. Get initial position. C ------------------------------------------------------- 200 RLAT0 = BLAT(L0) RLON0 = -BLON(L0) WS0 = BWS(L0) C C Get previous, next positions to estimate current speed C ------------------------------------------------------ LB = L0-1 LF = L0+1 IF (LB.LT.1) LB=1 IF (LB.EQ.LF) LF=LF+1 IF (LF.GT.NBT) LF = NBT IF (LB.EQ.LF) GOTO 800 CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR0) SPD0 = DIST/DELTAH C C C Get additional parameters for SHIFOR C ------------------------------------ LB = L0-2 LF = L0 IF (LB.LT.1) LB=1 IF (LB.EQ.LF) LF=LF+1 IF (LF.GT.NBT) LF = NBT IF (LB.EQ.LF) GOTO 800 CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR12) SPD12 = DIST/DELTAH WS12 = BWS(LB) C C C Get CLIPER forecast. C ----------------------------------------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 CALL CLIP_5(IMO,IDY,IHR,RLAT0,RLON0,WS0,DIR0,SPD0,BASIN,FPCLIP) C C C Run best-track SHIFOR C --------------------- IF (DIR12.EQ.-999. .OR. SPD12.EQ.-999.) GOTO 800 IF (WS12.EQ.-999.) GOTO 800 UCMP = DIR12 VCMP = SPD12 CALL UVCOMP(UCMP,VCMP) UCMP = -UCMP VCMP = -VCMP IF (BASIN.EQ.'AL') CALL ATSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'EP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'CP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) C C C Place results in final arrays. C ------------------------------ DO 550 K=1,NVTX CLAT(K) = FPCLIP(1,K) CLON(K) = -FPCLIP(2,K) IF (IWSHIF(K).GT.0) SWND(K) = IWSHIF(K) 550 CONTINUE C C C All done, go back C ----------------- 800 RETURN END C C C C ------------------------------------------------------------ SUBROUTINE BTCLIPD5(BASIN,IYR,IMO,IDY,IHR,NBT,BMO,BDY,BHR, * BLAT,BLON,BWS,CLAT,CLON,SWND) C C Returns best-track cliper/decay SHIFOR forecast. C Output is at 12, 24, 36, 48, 60, 72, 84, 96, 108, and 120 h. C Valid for Atlantic and East Pacific. EP coefficients used C for CP. C C Decay SHIFOR differs from original in that it uses the C CLIPER track and Mark DeMaria's decay rate to decay the C intensity forecast over land. There is also a new lower C limit of 15 kt imposed (limit on SHIFOR was 1 kt). C C BASIN AL or EP or CP. C IYR Year (4 digit) C IMO,IDY,IHR Time to compute a cliper forecast for. C NBT Number of elements in the best track data arrays. C BMO,BDY,BHR Arrays of best track dates/times. C BLAT(NBT) BT latitude (deg N). C BLON(NBT) BT longitude (deg E). C BWS(NBT) BT wind speed (kt). C CLAT(NVTX) Returned array of BT CLIPER lats. C CLON(NVTX) Returned array of BT CLIPER lons. C SWND(NVTX) Returned array of BT SHIFOR winds. C ------------------------------------------------------------ C PARAMETER (NVTX=10) DIMENSION BMO(NBT), BDY(NBT), BHR(NBT) DIMENSION BLAT(NBT), BLON(NBT), BWS(NBT) DIMENSION CLAT(NVTX), CLON(NVTX) DIMENSION FPCLIP(2,NVTX), IWSHIF(NVTX), SWND(NVTX) DIMENSION FTIME(NVTX+1), RLAT(NVTX+1), RLON(NVTX+1) DIMENSION VMAX(NVTX+1), VMAXD(NVTX+1), DLAND(NVTX+1) CHARACTER*2 BASIN C C C DT = 1.0 RCRAD = 110. RLAT0 = -999. RLON0 = -999. RLAT12= -999. RLON12= -999. DIR0 = -999. SPD0 = -999. WS0 = -999. WS12 = -999. DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE C C C Compute input parameters for the CLIPER subroutine. C Start by checking for a BT match to desired time. C --------------------------------------------------- DO 110 L = 1,NBT IF (IMO.EQ.NINT(BMO(L)).AND.IDY.EQ.NINT(BDY(L)) * .AND.IHR.EQ.NINT(BHR(L))) * THEN L0 = L GOTO 200 ENDIF 110 CONTINUE C C Could not find a best track entry for the requested time C -------------------------------------------------------- GOTO 800 C C C Found a valid match at index L0. Get initial position. C ------------------------------------------------------- 200 RLAT0 = BLAT(L0) RLON0 = -BLON(L0) WS0 = BWS(L0) C C Get previous, next positions to estimate current speed C ------------------------------------------------------ LB = L0-1 LF = L0+1 IF (LB.LT.1) LB=1 IF (LB.EQ.LF) LF=LF+1 IF (LF.GT.NBT) LF = NBT IF (LB.EQ.LF) GOTO 800 CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR0) SPD0 = DIST/DELTAH C C C Get additional parameters for SHIFOR C ------------------------------------ LB = L0-2 LF = L0 IF (LB.LT.1) LB=1 IF (LB.EQ.LF) LF=LF+1 IF (LF.GT.NBT) LF = NBT IF (LB.EQ.LF) GOTO 800 CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR12) SPD12 = DIST/DELTAH WS12 = BWS(LB) C C C Get CLIPER forecast. C ----------------------------------------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 CALL CLIP_5(IMO,IDY,IHR,RLAT0,RLON0,WS0,DIR0,SPD0,BASIN,FPCLIP) C C C Run best-track SHIFOR C --------------------- IF (DIR12.EQ.-999. .OR. SPD12.EQ.-999.) GOTO 800 IF (WS12.EQ.-999.) GOTO 800 UCMP = DIR12 VCMP = SPD12 CALL UVCOMP(UCMP,VCMP) UCMP = -UCMP VCMP = -VCMP IF (BASIN.EQ.'AL') CALL ATSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'EP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'CP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) C C C Place results in final arrays. C ------------------------------ DO 550 K=1,NVTX CLAT(K) = FPCLIP(1,K) CLON(K) = -FPCLIP(2,K) IF (IWSHIF(K).GT.0) SWND(K) = IWSHIF(K) 550 CONTINUE C C C C Decay the SHIFOR forecast C ------------------------- FTIME(1) = 0. RLAT(1) = RLAT0 RLON(1) = RLON0 VMAX(1) = WS0 DO 600 K=1,NVTX FTIME(K+1) = FLOAT(K*12) RLAT(K+1) = CLAT(K) RLON(K+1) = -CLON(K) VMAX(K+1) = SWND(K) IF (VMAX(K+1).LT.15.) VMAX(K+1) = 15. 600 CONTINUE CALL DECAY_OLD(FTIME,RLAT,RLON,VMAX,VMAXD,DT,RCRAD,DLAND,1) DO 620 K=1,NVTX SWND(K) = VMAXD(K+1) IF (SWND(K).LT.15.) SWND(K) = 15. 620 CONTINUE C C C C All done, go back C ----------------- 800 RETURN END C C C C ------------------------------------------------------------ SUBROUTINE OCLIP5(BASIN,IYR,IMO,IDY,IHR, * RLAT0,RLON0E,WS0,DIR0,SPD0, * RLAT12,RLON12E,WS12,DIR12,SPD12, * CLAT,CLON,SWND) C C Reruns operational 5-day cliper/shifor forecast. C Output is at 12, 24, 36, 48, 60, 72, 84, 96, 108, and 120 h. C Valid for Atlantic and East Pacific. EP coefficients used C for CP. C C BASIN AL or EP or CP. C IYR Year (4 digit) C IMO,IDY,IHR Time to compute a cliper forecast for. C RLAT0 Initial lat C RLON0E Initial long (deg E) C WS0 Initial wind speed C DIR0 Initial heading C SPD0 Initial forward speed C RLAT12 t-12h lat C RLON12E t-12h long (deg E) C WS12 t-12h wind speed C DIR12 t-12h heading C SPD12 t-12h forward speed C CLAT(NVTX) Returned array of CLIPER lats. C CLON(NVTX) Returned array of CLIPER lons. C SWND(NVTX) Returned array of SHIFOR winds. C ------------------------------------------------------------ C PARAMETER (NVTX=10) DIMENSION CLAT(NVTX), CLON(NVTX) DIMENSION FPCLIP(2,NVTX), IWSHIF(NVTX), SWND(NVTX) CHARACTER*2 BASIN C C DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE C RLON0 = -999. RLON12 = -999. IF (RLON0E.NE.-999.) RLON0 = -RLON0E IF (RLON12E.NE.-999.) RLON12 = -RLON12E C C C Get CLIPER forecast. C -------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 CALL CLIP_5(IMO,IDY,IHR,RLAT0,RLON0,WS0,DIR0,SPD0,BASIN,FPCLIP) C C C Get SHIFOR forecast. C -------------------- IF (RLAT12.EQ.-999. .OR. RLON12.EQ.-999.) GOTO 800 IF (WS12.EQ.-999.) GOTO 800 RLATB = RLAT12 RLONB = RLON12 RLATF = RLAT0 RLONF = RLON0 CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIRL12) SPDL12 = DIST/12. IF (DIRL12.EQ.-999. .OR. SPDL12.EQ.-999.) GOTO 800 UCMP = DIRL12 VCMP = SPDL12 CALL UVCOMP(UCMP,VCMP) UCMP = -UCMP VCMP = -VCMP IF (BASIN.EQ.'AL') CALL ATSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'EP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'CP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) C C C Place results in final arrays. C ------------------------------ DO 550 K=1,NVTX CLAT(K) = FPCLIP(1,K) CLON(K) = -FPCLIP(2,K) IF (IWSHIF(K).GT.0) SWND(K) = IWSHIF(K) 550 CONTINUE C C C All done, go back C ----------------- 800 RETURN END C C C C ------------------------------------------------------------ SUBROUTINE OCLIPD5(BASIN,IYR,IMO,IDY,IHR, * RLAT0,RLON0E,WS0,DIR0,SPD0, * RLAT12,RLON12E,WS12,DIR12,SPD12, * CLAT,CLON,SWND) C C Reruns operational 5-day cliper/decay shifor forecast. C Output is at 12, 24, 36, 48, 60, 72, 84, 96, 108, and 120 h. C Valid for Atlantic and East Pacific. EP coefficients used C for CP. C C Decay SHIFOR differs from original in that it uses the C CLIPER track and Mark DeMaria's decay rate to decay the C intensity forecast over land. There is also a new lower C limit of 15 kt imposed (limit on SHIFOR was 1 kt). C C BASIN AL or EP or CP. C IYR Year (4 digit) C IMO,IDY,IHR Time to compute a cliper forecast for. C RLAT0 Initial lat C RLON0E Initial long (deg E) C WS0 Initial wind speed C DIR0 Initial heading C SPD0 Initial forward speed C RLAT12 t-12h lat C RLON12E t-12h long (deg E) C WS12 t-12h wind speed C DIR12 t-12h heading C SPD12 t-12h forward speed C CLAT(NVTX) Returned array of CLIPER lats. C CLON(NVTX) Returned array of CLIPER lons. C SWND(NVTX) Returned array of DECAY SHIFOR winds. C ------------------------------------------------------------ C PARAMETER (NVTX=10) DIMENSION CLAT(NVTX), CLON(NVTX) DIMENSION FPCLIP(2,NVTX), IWSHIF(NVTX), SWND(NVTX) DIMENSION FTIME(NVTX+1), RLAT(NVTX+1), RLON(NVTX+1) DIMENSION VMAX(NVTX+1), VMAXD(NVTX+1), DLAND(NVTX+1) CHARACTER*2 BASIN C C DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE C RLON0 = -999. RLON12 = -999. IF (RLON0E.NE.-999.) RLON0 = -RLON0E IF (RLON12E.NE.-999.) RLON12 = -RLON12E DT = 1.0 RCRAD = 110. C C C Get CLIPER forecast. C -------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 CALL CLIP_5(IMO,IDY,IHR,RLAT0,RLON0,WS0,DIR0,SPD0,BASIN,FPCLIP) C C C Get SHIFOR forecast. C -------------------- IF (RLAT12.EQ.-999. .OR. RLON12.EQ.-999.) GOTO 800 IF (WS12.EQ.-999.) GOTO 800 RLATB = RLAT12 RLONB = RLON12 RLATF = RLAT0 RLONF = RLON0 CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIRL12) SPDL12 = DIST/12. IF (DIRL12.EQ.-999. .OR. SPDL12.EQ.-999.) GOTO 800 UCMP = DIRL12 VCMP = SPDL12 CALL UVCOMP(UCMP,VCMP) UCMP = -UCMP VCMP = -VCMP IF (BASIN.EQ.'AL') CALL ATSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'EP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'CP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) C C C Place results in final arrays. C ------------------------------ DO 550 K=1,NVTX CLAT(K) = FPCLIP(1,K) CLON(K) = -FPCLIP(2,K) IF (IWSHIF(K).GT.0) SWND(K) = IWSHIF(K) 550 CONTINUE C C C Decay the SHIFOR forecast C ------------------------- FTIME(1) = 0. RLAT(1) = RLAT0 RLON(1) = -RLON0E VMAX(1) = WS0 DO 600 K=1,NVTX FTIME(K+1) = FLOAT(K*12) RLAT(K+1) = CLAT(K) RLON(K+1) = -CLON(K) VMAX(K+1) = SWND(K) IF (VMAX(K+1).LT.15.) VMAX(K+1) = 15. 600 CONTINUE CALL DECAY_OLD(FTIME,RLAT,RLON,VMAX,VMAXD,DT,RCRAD,DLAND,1) DO 620 K=1,NVTX SWND(K) = VMAXD(K+1) IF (SWND(K).LT.15.) SWND(K) = 15. 620 CONTINUE C C C C All done, go back C ----------------- 800 RETURN END C C C C ------------------------------------------------------------ SUBROUTINE OCLIPD5_TEST(BASIN,IYR,IMO,IDY,IHR, * RLAT0,RLON0E,WS0,DIR0,SPD0, * RLAT12,RLON12E,WS12,DIR12,SPD12, * CLAT,CLON,SWND) C C Reruns operational 5-day cliper/decay shifor forecast. C Output is at 12, 24, 36, 48, 60, 72, 84, 96, 108, and 120 h. C Valid for Atlantic and East Pacific. EP coefficients used C for CP. C C Decay SHIFOR differs from original in that it uses the C CLIPER track and Mark DeMaria's decay rate to decay the C intensity forecast over land. There is also a new lower C limit of 15 kt imposed (limit on SHIFOR was 1 kt). C C BASIN AL or EP or CP. C IYR Year (4 digit) C IMO,IDY,IHR Time to compute a cliper forecast for. C RLAT0 Initial lat C RLON0E Initial long (deg E) C WS0 Initial wind speed C DIR0 Initial heading C SPD0 Initial forward speed C RLAT12 t-12h lat C RLON12E t-12h long (deg E) C WS12 t-12h wind speed C DIR12 t-12h heading C SPD12 t-12h forward speed C CLAT(NVTX) Returned array of CLIPER lats. C CLON(NVTX) Returned array of CLIPER lons. C SWND(NVTX) Returned array of DECAY SHIFOR winds. C ------------------------------------------------------------ C PARAMETER (NVTX=10) DIMENSION CLAT(NVTX), CLON(NVTX) DIMENSION FPCLIP(2,NVTX), IWSHIF(NVTX), SWND(NVTX) DIMENSION FTIME(NVTX+1), RLAT(NVTX+1), RLON(NVTX+1) DIMENSION VMAX(NVTX+1), VMAXD(NVTX+1), DLAND(NVTX+1) CHARACTER*2 BASIN C C DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE C RLON0 = -999. RLON12 = -999. IF (RLON0E.NE.-999.) RLON0 = -RLON0E IF (RLON12E.NE.-999.) RLON12 = -RLON12E DT = 1.0 RCRAD = 0.0 C C C Get CLIPER forecast. C -------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 CALL CLIP_5(IMO,IDY,IHR,RLAT0,RLON0,WS0,DIR0,SPD0,BASIN,FPCLIP) C C C Get SHIFOR forecast. C -------------------- IF (RLAT12.EQ.-999. .OR. RLON12.EQ.-999.) GOTO 800 IF (WS12.EQ.-999.) GOTO 800 RLATB = RLAT12 RLONB = RLON12 RLATF = RLAT0 RLONF = RLON0 CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIRL12) SPDL12 = DIST/12. IF (DIRL12.EQ.-999. .OR. SPDL12.EQ.-999.) GOTO 800 UCMP = DIRL12 VCMP = SPDL12 CALL UVCOMP(UCMP,VCMP) UCMP = -UCMP VCMP = -VCMP IF (BASIN.EQ.'AL') CALL ATSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'EP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) IF (BASIN.EQ.'CP') CALL EPSHIF5D(IYR,IMO,IDY,RLAT0,RLON0, * UCMP,VCMP,WS0,WS12,IWSHIF) C C C Place results in final arrays. C ------------------------------ DO 550 K=1,NVTX CLAT(K) = FPCLIP(1,K) CLON(K) = -FPCLIP(2,K) IF (IWSHIF(K).GT.0) SWND(K) = IWSHIF(K) 550 CONTINUE C C C Decay the SHIFOR forecast C ------------------------- FTIME(1) = 0. RLAT(1) = RLAT0 RLON(1) = -RLON0E VMAX(1) = WS0 DO 600 K=1,NVTX FTIME(K+1) = FLOAT(K*12) RLAT(K+1) = CLAT(K) RLON(K+1) = -CLON(K) VMAX(K+1) = SWND(K) IF (VMAX(K+1).LT.15.) VMAX(K+1) = 15. 600 CONTINUE CALL DECAY_OLD(FTIME,RLAT,RLON,VMAX,VMAXD,DT,RCRAD,DLAND,1) DO 620 K=1,NVTX SWND(K) = VMAXD(K+1) IF (SWND(K).LT.15.) SWND(K) = 15. 620 CONTINUE C C C C All done, go back C ----------------- 800 RETURN END C C C C ------------------------------------------------------------ SUBROUTINE TRJ_CLP(IYR,IMO,IDY,IHR, * RLAT00,RLON00E,VMX00,DIR0,SPD0, * RLATM12,RLON12E,VMXM12, * CLAT,CLON,SWND) C C Driver subroutine for Mark DeMaria TCLP forecasts. C Output is at 12, 24, 36, 48, 60, 72, 84, 96, 108, 120, 144, 168 h. C Valid for Atlantic and East Pacific. C C C IYR Year (4 digit) C IMO,IDY,IHR Time to compute a cliper forecast for. C RLAT00 Initial lat C RLON00E Initial long (deg E) C VMX00 Initial wind speed C DIR0 Initial heading C SPD0 Initial forward speed C RLATM12 t-12h lat C RLON12E t-12h long (deg E) C VMXM12 t-12h wind speed C CLAT(NVTX) Returned array of TCLP lats. C CLON(NVTX) Returned array of TCLP lons. C SWND(NVTX) Returned array of DECAY SHIFOR winds. C ------------------------------------------------------------ c PARAMETER (NVTX=15, MXT=80) DIMENSION CLAT(NVTX), CLON(NVTX), SWND(NVTX), ITIME(NVTX) DIMENSION flon(0:mxt),flat(0:mxt),fvmax(0:mxt) C DATA ITIME/0,12,24,36,48,60,72,84,96,108,120,132,144,156,168/ C DTHR = 6.0 NDT = 30 IOPER = 0 IFTYPET = 2 IFTYPEI = 2 IPF = 1 C DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE C RLON00W = -RLON00E RLON00 = 360.0-RLON00W RLON12W = -RLON12E RLONM12 = 360-RLON12W CALL UVCOMP2(DIR0,SPD0,U,V) CX00 = -U CY00 = -V C call tclip(rlon00,rlat00,rlonm12,rlatm12,cx00,cy00,ipf, + vmx00,vmxm12,iyr,imo,idy,ihr,dthr,ndt,ioper, + iftypet,iftypei,flon,flat,fvmax,ierr) IF (IERR.NE.0) RETURN C c lulog = 6 c write(lulog,200) iyr,imo,idy,ihr,ierr c 200 format(/,'Test of tclip, date=',i4,1x,2(i2.2),' time=',i2.2, c + ' ierr= ',i2) c write(lulog,206) vmx00,vmxm12,dir0,spd0 c 206 format('vmx(0)=',f6.1,' vmx(-12)=',f6.1, c + ' dir=',f6.1,' spd= ',f6.1) c DO K=0,NDT TTIME = DTHR*FLOAT(K) DO L=2,NVTX IF (NINT(TTIME).EQ.ITIME(L)) THEN CLAT(L) = FLAT(K) CLON(L) = FLON(K)-360.0 SWND(L) = FVMAX(K) IF (NINT(CLAT(L)).EQ.0 .AND. NINT(CLON(L)).EQ.-360) THEN CLAT(L) = -999. CLON(L) = -999. SWND(L) = -999. ENDIF ENDIF ENDDO c write(lulog,210) ttime,flat(k),flon(k)-360.0,fvmax(k) c 210 format('t=',f6.1,' lat=',f7.2,' lon=',f7.2,' vmax=',f6.1) enddo c RETURN END C C C C ------------------------------------------------------------------ subroutine clip_5(imo,ida,ihr,latcur,loncur,wndcur,dircur,spdcur, * basin,fpclip) C C written by Sim Aberson 1-APR-1998 C NOAA/AOML/Hurricane Research Division C Modified by Jim Gross 98/04/24 by changing arthmitic to floating C point, finding an error, and combining the Atlantic and east C Pacific into one 5_day CLIPER model C C Made operational by Jim Gross 2001/05/17 C C Note: output longitudes are in degrees E (0-360). C C Modified by James Franklin, July 2002, to better integrate with C verify_model.f. C C Modified 26 April 2005 to use new coefficient files based on C 1931-2004 dependent data (in the Atlantic). Also added date C limits on initial day. C ------------------------------------------------------------------ c parameter (nvaratl=27, nvargulf=27, nvar=nvaratl) c dimension fpclip(2,10) real latcur, loncur, wind, rdir, days, ucmp, vcmp, jday(12), * acon(40), coef(40,nvar), x(nvar), disp(20) c character*2 basin character*40 alfile, gmfile, epfile c data jday / 1.0, 32.0, 60.0, 91.0, 121.0, 152.0, * 182.0, 213.0, 244.0, 274.0, 305.0, 335.0 / c c c Current files c ------------- alfile = 'support_files/clp5_al3104coeff.dat' gmfile = 'support_files/clp5_gm3104coeff.dat' epfile = 'support_files/clp5_ep4904coeff.dat' c c Original Aberson files c ---------------------- c alfile = 'clp5_al6100coeff.dat' c gmfile = 'clp5_gm6100coeff.dat' c epfile = 'clp5_ep6100coeff.dat' c degrad=atan(1.0)/45.0 C c c Open, and read regression coefficients file c ------------------------------------------- if ( basin .eq. 'al' .or. basin .eq. 'AL') then open(21,file=alfile,status='old',iostat=ios,err=1010) open(22,file=gmfile,status='old',iostat=ios,err=1020) do i = 1, 20 read (21,1,iostat=ios,err=1030) * acon(i), (coef(i,j),j=1,nvaratl) 1 format (f11.6,4x,4e15.7,/,5(5e15.7,/)) read (22,1,iostat=ios,err=1030) * acon(i+20),(coef(i+20,j),j=1,nvargulf) enddo close(21) close(22) else open(21,file=epfile,status='old',iostat=ios,err=1040) do i = 1,20 read (21,1,iostat=ios,err=1030) * acon(i), (coef(i,j),j=1,nvaratl) enddo close(21) endif c c days = jday(imo) + real(ida) + real(ihr)/24.0 c if (basin .eq. 'al' .or. basin .eq. 'AL') then if (days.lt.152.0) days = 152.0 else if (days.lt.135.0) days = 135.0 endif if (days .gt. 334.0) days = 334.0 c wind = wndcur*111.1*1000.0/(60.0*3600.0) rdir = dircur + 180.0 if ( rdir .ge. 360.0 ) rdir = rdir - 360.0 rspd = spdcur*111.1*1000.0/(60.0*3600.0) c ucmp = rdir vcmp = rspd call uvcomp(ucmp,vcmp) c ucmp = -ucmp c x(1) = latcur x(2) = loncur x(3) = wind x(4) = days x(5) = vcmp x(6) = ucmp c klij = 6 c do ijkl = 1, 6 do jkli = ijkl, 6 klij = klij + 1 x(klij) = x(ijkl)*x(jkli) enddo enddo c do i = 1, 20 disp(i) = acon(i) if (basin.eq.'al' .or. basin.eq.'AL') then if ( latcur .lt. loncur - 64.0) disp(i) = acon(i + 20) endif enddo c do i = 1, 20 do j = 1, nvar if (basin.eq.'al' .or. basin.eq.'AL') then if ( latcur .ge. loncur - 64.0 ) then disp(i) = disp(i) + x(j)*coef(i,j) else disp(i) = disp(i) + x(j)*coef(i+20,j) endif else disp(i) = disp(i) + x(j)*coef(i,j) endif c enddo enddo c fpclip(1,1) = latcur + disp(1) do i = 2, 10 fpclip(1,i) = fpclip(1,i - 1) + disp(i) enddo c fpclip(2,1) = loncur + disp(11)/ * cos((latcur + fpclip(1,1))* * degrad/2.0 ) do i = 2, 10 fpclip(2,i) = fpclip(2,i - 1) + disp(i + 10)/ * cos((fpclip(1,i - 1) + fpclip(1,i))* * degrad/2.0) enddo C C c Round to the nearest tenth c -------------------------- DO K = 1, 10 fpclip(1,k) = float(nint(fpclip(1,k)*10.0))/10. fpclip(2,k) = float(nint(fpclip(2,k)*10.0))/10. enddo c c c Check hemisphere c ---------------- do k = 1, 10 IF ( FPCLIP( 2, k ) .LT. 0.0 ) THEN FPCLIP( 2, k ) = 360.0 + FPCLIP( 2, k ) ENDIF enddo c c c All done, return c ---------------- return c c c Error messages c -------------- 1010 print *, ' error opening alcoff.dat = ',ios stop c 1020 print *, ' error opening gfcoff.dat = ',ios stop c 1030 print *, ' error reading coefficient file = ',ios stop c 1040 print *, ' error opening epcoff.dat = ',ios stop c end C C C subroutine atshif5d(iyear,imonth,iday,alat,alon,ucmp12,vcmp12, * vel,vel12,iwnd) c c This subroutine calculates tropical cyclone intensities through 120 c hours based upon climatology and persistence using the years c 1967-1999. The model was created using the total change in intensity c for each period (12-hr,....120-hr) from intial conditions as the c predictand and 35 predictors including and derived from c julian day, latitude, longitude, zonal speed, meridional speed, c current intensity the past 12-hour intensity trend. c c In the formulation of the model linear terms are first put into the c model using a forward stepping approach for the 12-hour forecast. c The linear predictors chosen in this forward stepping process c are then forced into the model and exposed to the 2nd order terms, c which at this point are allowed to come into the model in a c stepwise fashion. A backward step is then performed to remove c predictors that are no longer significant. Then a final stepwise c stepping proceedure is performed possibly adding a removing predictors c c c Following the 12-hour forecast the predictors chosen for the previous c forecast period are then given preference in the selection process. c Again, the predictors chosen in this forward stepping process c are then forced into the model and exposed to the 2nd order terms, c which at this point are allowed to come into the model in a c stepwise fashion. A backward pass through the data is then performed c to remove predictors that are no longer significant. Followed by c a final step that is stepwise. c c J. Knaff (04/05/2001) c c Modified by James Franklin 7/2002 for compatibility with c verify_model.f c c Modified by James Franklin 3/2006 to avoid losing forecasts of winds c less than zero. Before, such forecasts were tossed, resulting in a loss of official c forecasts in homogeneous comparisons. Now, if the model forecasts a negative c windspeed, then the output value is set to 1 kt. c common /coefats/ scoef(10,36), avg(10,36), sdev(10,36) c c dimension coeficients. c parameter(nc=36) real p(36), forecast(10) double precision dv (10) dimension iwnd(10) c c dimension input. c real alat, alon, vel, vel12 c c intialize to zero c rad = 3.14159/180. do i=1,10 dv(i)=0.0 iwnd(i)=0 end do c c c check for system intensity requirements. c if (vel.lt.15.0.OR.vel12.lt.15.0) return c c create predictor pool (first order terms, squares, and c co-variances terms) c c p1 = julian day - 253 c p2 = lat c p3 = lon c p4 = u ! zonal speed of the storm over the last 12 hours c p5 = v ! meridional speed of the storm over the last 12 hours c p6 = vmax c p7 = delta vmax c c calculate julian day c call julian_day(imonth,iday,iyear,julday) c c assign predictor values from the input data c p(1) = dble(julday-253) p(2) = dble(alat) p(3) =dble(alon) c avglat=(alat+alat12)/2.0 c p(4) =dble((alon-alon12)* (-60.0)/ 12.0 * c . COS(rad*avglat)) c p(5)=dble((alat-alat12)*60./12.) p(4)=dble(ucmp12) p(5)=dble(vcmp12) p(6)=dble(vel) p(7)=dble(vel-vel12) p(8)=p(1)**2 !p1*p1 p(9)=p(1)*p(2) !p1*p2 p(10)=p(1)*p(3) !p1*p3 p(11)=p(1)*p(4) !etc.... p(12)=p(1)*p(5) p(13)=p(1)*p(6) p(14)=p(1)*p(7) p(15)=p(2)**2 p(16)=p(2)*p(3) p(17)=p(2)*p(4) p(18)=P(2)*p(5) p(19)=p(2)*p(6) p(20)=p(2)*p(7) p(21)=p(3)**2 p(22)=p(3)*p(4) p(23)=p(3)*p(5) p(24)=p(3)*p(6) p(25)=p(3)*p(7) p(26)=p(4)**2 p(27)=p(4)*p(5) p(28)=p(4)*p(6) p(29)=p(4)*p(7) p(30)=p(5)**2 p(31)=p(5)*p(6) p(32)=p(5)*p(7) p(33)=p(6)**2 p(34)=p(6)*p(7) p(35)=p(7)**2 p(36)=vel c c calculate the predicted incremental change in velocity c do i=1,10 dv(i)=0.0 ! intitialize array to zero. do j=1,35 dv(i)=dv(i)+dble(scoef(i,j)*((p(j)-avg(i,j))/sdev(i,j))) end do dv(i)=dv(i)*dble(sdev(i,36)) + dble(avg(i,36)) end do c c c construct forecast intensities c forecast(1)=p(36)+dv(1) do i=1,10 forecast(i)= p(36)+sngl(dv(i)) end do do i=1,10 c if (forecast(i).lt.0.0)forecast(i)=0.0 c c Modification to avoid losing forecasts - JLF 3/13/06 c ---------------------------------------------------- if (forecast(i).lt.0.5)forecast(i)=1.0 iwnd(i)=nint(forecast(i)) end do c return end c c c block data atlshifor_data c c block data for the standardized coeficients to the 5-day c Atlantic SHIFOR c c These are used by alshif5d and passed via a common block c initialized in this subprogram. The common block is not passed c to the main program. c c scoef are the standardized coeficients c avg are the averages c sdev are the standard deviations. c c common /coefats/ scoef(10,36), avg(10,36), sdev(10,36) c data (scoef( 1,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.9632107E-01, 0.2161774E+00, 0.0000000E+00,-0.2598887E+00, . 0.6619257E+00,-0.6903946E-01, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.3840485E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.2655196E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 1,j),j=1,36) / 0.6924230E+00, 0.2501092E+02, . 0.6001072E+02,-0.2517827E+01, 0.4779600E+01, 0.5636170E+02, . 0.2587011E+01, 0.1030277E+04, 0.1775327E+02, 0.4254318E+02, . 0.3506200E+02,-0.1217535E+02, 0.1154956E+03,-0.1672390E+02, . 0.6990111E+03, 0.1512090E+04,-0.2923416E+01, 0.1318952E+03, . 0.1450323E+04, 0.5226493E+02, 0.3901107E+04,-0.1370406E+03, . 0.2816506E+03, 0.3394556E+04, 0.1688047E+03, 0.9963890E+02, .-0.9566036E-01,-0.1150216E+03,-0.1612303E+02, 0.4871619E+02, . 0.2915584E+03, 0.1450799E+02, 0.3791872E+04, 0.1823332E+03, . 0.8294604E+02, 0.2005495E+01/ data (sdev( 1,j),j=1,36) / 0.3209314E+02, 0.8571875E+01, . 0.1731675E+02, 0.9659969E+01, 0.5086838E+01, 0.2480592E+02, . 0.8733048E+01, 0.1864341E+04, 0.8357047E+03, 0.2234280E+04, . 0.2879513E+03, 0.2154462E+03, 0.1749152E+04, 0.3003741E+03, . 0.4446778E+03, 0.6461969E+03, 0.2631858E+03, 0.1692676E+03, . 0.8461565E+03, 0.2281288E+03, 0.2127881E+04, 0.5451351E+03, . 0.3145661E+03, 0.1852198E+04, 0.5793061E+03, 0.1301999E+03, . 0.7732862E+02, 0.5875003E+03, 0.9362686E+02, 0.7837893E+02, . 0.3577816E+03, 0.6779141E+02, 0.3409085E+04, 0.6547117E+03, . 0.1612456E+03, 0.9235003E+01/ data (scoef( 2,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.1233280E+00, 0.2059798E+00, 0.0000000E+00,-0.2399135E+00, . 0.7064717E+00,-0.1008747E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.1276496E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.3583669E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.3909434E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 2,j),j=1,36) / 0.9079197E+00, 0.2451084E+02, . 0.5893240E+02,-0.3085352E+01, 0.4501705E+01, 0.5650076E+02, . 0.2622774E+01, 0.9678882E+03, 0.2445280E+02, 0.7167412E+02, . 0.3633494E+02,-0.1068501E+02, 0.1269655E+03,-0.1328003E+02, . 0.6709643E+03, 0.1464025E+04,-0.2066254E+02, 0.1185758E+03, . 0.1428452E+04, 0.5308390E+02, 0.3755662E+04,-0.1573582E+03, . 0.2618678E+03, 0.3339356E+04, 0.1592436E+03, 0.9354892E+02, .-0.6658569E+01,-0.1436312E+03,-0.1608299E+02, 0.4283905E+02, . 0.2740909E+03, 0.1404197E+02, 0.3795095E+04, 0.1763668E+03, . 0.7905362E+02, 0.3726980E+01/ data (sdev( 2,j),j=1,36) / 0.3110060E+02, 0.8378330E+01, . 0.1681333E+02, 0.9167630E+01, 0.4751629E+01, 0.2455349E+02, . 0.8496373E+01, 0.1768235E+04, 0.7934583E+03, 0.2132501E+04, . 0.2678891E+03, 0.1941161E+03, 0.1705528E+04, 0.2929895E+03, . 0.4255700E+03, 0.6396952E+03, 0.2369832E+03, 0.1480606E+03, . 0.8353543E+03, 0.2164446E+03, 0.2038278E+04, 0.5116897E+03, . 0.2930400E+03, 0.1768569E+04, 0.5501223E+03, 0.1166377E+03, . 0.6353190E+02, 0.5536301E+03, 0.8621957E+02, 0.6173920E+02, . 0.3307446E+03, 0.5880326E+02, 0.3329759E+04, 0.6239390E+03, . 0.1531375E+03, 0.1532608E+02/ data (scoef( 3,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.1334133E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.6672866E+00,-0.1210680E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.2524992E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.5450201E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.1718453E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.4152353E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 3,j),j=1,36) / 0.9616966E+00, 0.2404943E+02, . 0.5779779E+02,-0.3558863E+01, 0.4308050E+01, 0.5671110E+02, . 0.2737719E+01, 0.9210535E+03, 0.2779111E+02, 0.8878762E+02, . 0.3805056E+02,-0.1038823E+02, 0.1297228E+03,-0.1325298E+02, . 0.6464169E+03, 0.1417209E+04,-0.3392802E+02, 0.1093273E+03, . 0.1409962E+04, 0.5483954E+02, 0.3607683E+04,-0.1723524E+03, . 0.2469319E+03, 0.3293460E+04, 0.1577506E+03, 0.9111264E+02, .-0.1095332E+02,-0.1681860E+03,-0.1828591E+02, 0.3958164E+02, . 0.2626406E+03, 0.1389569E+02, 0.3815360E+04, 0.1803387E+03, . 0.7714023E+02, 0.4966674E+01/ data (sdev( 3,j),j=1,36) / 0.3033690E+02, 0.8249646E+01, . 0.1634490E+02, 0.8857997E+01, 0.4585509E+01, 0.2448144E+02, . 0.8346269E+01, 0.1721265E+04, 0.7590904E+03, 0.2051263E+04, . 0.2579913E+03, 0.1808050E+03, 0.1664844E+04, 0.2869225E+03, . 0.4123503E+03, 0.6362572E+03, 0.2202684E+03, 0.1374561E+03, . 0.8296448E+03, 0.2083708E+03, 0.1948476E+04, 0.4887198E+03, . 0.2799759E+03, 0.1721974E+04, 0.5274450E+03, 0.1109338E+03, . 0.5723892E+02, 0.5324178E+03, 0.8228619E+02, 0.5533614E+02, . 0.3181781E+03, 0.5351896E+02, 0.3303091E+04, 0.6109392E+03, . 0.1502984E+03, 0.2018737E+02/ data (scoef( 4,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.1179411E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.5688543E+00,-0.1263167E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.3047682E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.6389252E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.1818729E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.3632210E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 4,j),j=1,36) / 0.8890815E+00, 0.2363174E+02, . 0.5672563E+02,-0.3959007E+01, 0.4171206E+01, 0.5699431E+02, . 0.2956177E+01, 0.8737126E+03, 0.2832931E+02, 0.9426695E+02, . 0.3968130E+02,-0.1056524E+02, 0.1285152E+03,-0.1212280E+02, . 0.6245836E+03, 0.1374201E+04,-0.4443031E+02, 0.1024761E+03, . 0.1394454E+04, 0.5930000E+02, 0.3471278E+04,-0.1841963E+03, . 0.2358062E+03, 0.3260008E+04, 0.1639787E+03, 0.9053625E+02, .-0.1423454E+02,-0.1899361E+03,-0.2018777E+02, 0.3704388E+02, . 0.2550115E+03, 0.1441322E+02, 0.3847742E+04, 0.1924855E+03, . 0.7592820E+02, 0.5805893E+01/ data (sdev( 4,j),j=1,36) / 0.2954891E+02, 0.8132701E+01, . 0.1592306E+02, 0.8653384E+01, 0.4432809E+01, 0.2448550E+02, . 0.8197918E+01, 0.1667888E+04, 0.7266108E+03, 0.1972593E+04, . 0.2514733E+03, 0.1682396E+03, 0.1624908E+04, 0.2809930E+03, . 0.4014341E+03, 0.6329095E+03, 0.2091046E+03, 0.1281973E+03, . 0.8236214E+03, 0.2017373E+03, 0.1863299E+04, 0.4736634E+03, . 0.2677355E+03, 0.1698982E+04, 0.5058230E+03, 0.1072277E+03, . 0.5339523E+02, 0.5209970E+03, 0.8075079E+02, 0.5054678E+02, . 0.3098015E+03, 0.5224454E+02, 0.3286008E+04, 0.5994625E+03, . 0.1427729E+03, 0.2406040E+02/ data (scoef( 5,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.1066351E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.4361093E+00,-0.1229526E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.3588182E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.7048543E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.7875312E-01, . 0.0000000E+00,-0.1810176E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.2748392E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 5,j),j=1,36) / 0.7411598E+00, 0.2323304E+02, . 0.5587768E+02,-0.4325152E+01, 0.4093352E+01, 0.5715955E+02, . 0.3132390E+01, 0.8297267E+03, 0.2728141E+02, 0.9450549E+02, . 0.4206970E+02,-0.1141570E+02, 0.1228300E+03,-0.1365545E+02, . 0.6040857E+03, 0.1336892E+04,-0.5336236E+02, 0.9788639E+02, . 0.1375858E+04, 0.6265878E+02, 0.3368683E+04,-0.1953185E+03, . 0.2288874E+03, 0.3232563E+04, 0.1698837E+03, 0.9092222E+02, .-0.1654315E+02,-0.2097693E+03,-0.2138794E+02, 0.3543734E+02, . 0.2507907E+03, 0.1472942E+02, 0.3870560E+04, 0.2028622E+03, . 0.7680764E+02, 0.6461952E+01/ data (sdev( 5,j),j=1,36) / 0.2879951E+02, 0.8020582E+01, . 0.1569833E+02, 0.8499159E+01, 0.4322857E+01, 0.2456659E+02, . 0.8186252E+01, 0.1617134E+04, 0.6940360E+03, 0.1907284E+04, . 0.2470698E+03, 0.1595705E+03, 0.1592168E+04, 0.2760713E+03, . 0.3922771E+03, 0.6302870E+03, 0.2006715E+03, 0.1216372E+03, . 0.8166120E+03, 0.1994494E+03, 0.1810311E+04, 0.4624083E+03, . 0.2593056E+03, 0.1694290E+04, 0.4982435E+03, 0.1037749E+03, . 0.5123920E+02, 0.5120408E+03, 0.8149457E+02, 0.4752918E+02, . 0.3031102E+03, 0.5243453E+02, 0.3284298E+04, 0.5991281E+03, . 0.1446465E+03, 0.2705362E+02/ data (scoef( 6,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.8026610E-01, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.3887290E+00,-0.1167581E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.3965225E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.7556319E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.9791975E-01, . 0.0000000E+00,-0.1792372E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.2562578E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 6,j),j=1,36) / 0.5282349E+00, 0.2288561E+02, . 0.5509222E+02,-0.4616736E+01, 0.4066473E+01, 0.5720878E+02, . 0.3269119E+01, 0.7833530E+03, 0.2451029E+02, 0.8987844E+02, . 0.4654677E+02,-0.1255986E+02, 0.1154485E+03,-0.1190449E+02, . 0.5868539E+03, 0.1304664E+04,-0.5985332E+02, 0.9588982E+02, . 0.1357026E+04, 0.6501071E+02, 0.3277084E+04,-0.2018239E+03, . 0.2255694E+03, 0.3203238E+04, 0.1741666E+03, 0.9196463E+02, .-0.1768923E+02,-0.2261230E+03,-0.2270596E+02, 0.3445014E+02, . 0.2489540E+03, 0.1535398E+02, 0.3879045E+04, 0.2116815E+03, . 0.7734914E+02, 0.6904808E+01/ data (sdev( 6,j),j=1,36) / 0.2798798E+02, 0.7945013E+01, . 0.1555665E+02, 0.8406735E+01, 0.4233170E+01, 0.2462512E+02, . 0.8165998E+01, 0.1559906E+04, 0.6625800E+03, 0.1841586E+04, . 0.2441215E+03, 0.1501844E+03, 0.1544518E+04, 0.2655307E+03, . 0.3854558E+03, 0.6318023E+03, 0.1945790E+03, 0.1180420E+03, . 0.8090012E+03, 0.1964395E+03, 0.1767535E+04, 0.4526402E+03, . 0.2536928E+03, 0.1695497E+04, 0.4891541E+03, 0.1022458E+03, . 0.5073444E+02, 0.5048276E+03, 0.8129501E+02, 0.4514432E+02, . 0.2981933E+03, 0.5209768E+02, 0.3278063E+04, 0.5976022E+03, . 0.1443764E+03, 0.2930631E+02/ data (scoef( 7,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.1047530E+00,-0.8868639E-01, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.4587812E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.8218156E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.1123108E+00, . 0.0000000E+00,-0.1655864E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 7,j),j=1,36) / 0.4207630E+00, 0.2255040E+02, . 0.5443819E+02,-0.4917055E+01, 0.4062362E+01, 0.5703888E+02, . 0.3388848E+01, 0.7403136E+03, 0.2312487E+02, 0.9094167E+02, . 0.4966651E+02,-0.1176302E+02, 0.1092751E+03,-0.4587674E+01, . 0.5698082E+03, 0.1275754E+04,-0.6694496E+02, 0.9490926E+02, . 0.1333167E+04, 0.6673709E+02, 0.3206201E+04,-0.2110588E+03, . 0.2246610E+03, 0.3166486E+04, 0.1796703E+03, 0.9265514E+02, .-0.1852151E+02,-0.2425760E+03,-0.2346312E+02, 0.3375825E+02, . 0.2468534E+03, 0.1563206E+02, 0.3860909E+04, 0.2147707E+03, . 0.7540719E+02, 0.7243947E+01/ data (sdev( 7,j),j=1,36) / 0.2721044E+02, 0.7830068E+01, . 0.1558119E+02, 0.8276644E+01, 0.4154732E+01, 0.2465152E+02, . 0.7996647E+01, 0.1486568E+04, 0.6332492E+03, 0.1784579E+04, . 0.2395884E+03, 0.1394451E+03, 0.1492160E+04, 0.2504226E+03, . 0.3766640E+03, 0.6321689E+03, 0.1879339E+03, 0.1158340E+03, . 0.7986561E+03, 0.1904583E+03, 0.1749101E+04, 0.4422272E+03, . 0.2496878E+03, 0.1696971E+04, 0.4733990E+03, 0.1008219E+03, . 0.4979871E+02, 0.4965642E+03, 0.7946046E+02, 0.4403391E+02, . 0.2927683E+03, 0.5060949E+02, 0.3274097E+04, 0.5828798E+03, . 0.1414711E+03, 0.3087317E+02/ data (scoef( 8,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.9537594E-01, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.4518728E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.8478302E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.1335201E+00, . 0.0000000E+00,-0.1486502E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 8,j),j=1,36) / 0.4769039E+00, 0.2223271E+02, . 0.5392975E+02,-0.5245444E+01, 0.4073866E+01, 0.5679109E+02, . 0.3439451E+01, 0.6933816E+03, 0.2537599E+02, 0.9890241E+02, . 0.5022994E+02,-0.1020454E+02, 0.1035189E+03,-0.2918435E+01, . 0.5532652E+03, 0.1250069E+04,-0.7521220E+02, 0.9437025E+02, . 0.1308384E+04, 0.6672680E+02, 0.3154948E+04,-0.2238049E+03, . 0.2245567E+03, 0.3128242E+04, 0.1821682E+03, 0.9341725E+02, .-0.1931823E+02,-0.2613367E+03,-0.2460387E+02, 0.3332844E+02, . 0.2451973E+03, 0.1544944E+02, 0.3841154E+04, 0.2145339E+03, . 0.7453392E+02, 0.7796921E+01/ data (sdev( 8,j),j=1,36) / 0.2633330E+02, 0.7680913E+01, . 0.1570454E+02, 0.8119729E+01, 0.4091335E+01, 0.2482301E+02, . 0.7920240E+01, 0.1413855E+04, 0.6058992E+03, 0.1721314E+04, . 0.2337595E+03, 0.1330247E+03, 0.1450492E+04, 0.2424808E+03, . 0.3661280E+03, 0.6296606E+03, 0.1804536E+03, 0.1136799E+03, . 0.7890709E+03, 0.1860230E+03, 0.1750739E+04, 0.4317303E+03, . 0.2462065E+03, 0.1700974E+04, 0.4660102E+03, 0.1003206E+03, . 0.4966600E+02, 0.4872369E+03, 0.7847066E+02, 0.4366581E+02, . 0.2870837E+03, 0.5009062E+02, 0.3295655E+04, 0.5789249E+03, . 0.1388171E+03, 0.3218217E+02/ data (scoef( 9,j),j=1,36) / 0.0000000E+00, 0.3089123E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.1055703E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.5977988E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.1598280E+00, . 0.1132629E+00,-0.2142111E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00,-0.2412702E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 9,j),j=1,36) / 0.4476055E+00, 0.2192138E+02, . 0.5340811E+02,-0.5579272E+01, 0.4054054E+01, 0.5657278E+02, . 0.3548601E+01, 0.6483376E+03, 0.2617615E+02, 0.1013527E+03, . 0.5210487E+02,-0.9421763E+01, 0.9515031E+02,-0.3575154E+01, . 0.5370754E+03, 0.1224067E+04,-0.8324326E+02, 0.9253274E+02, . 0.1284906E+04, 0.6745268E+02, 0.3103078E+04,-0.2374746E+03, . 0.2228494E+03, 0.3088268E+04, 0.1870104E+03, 0.9521982E+02, .-0.2048142E+02,-0.2797499E+03,-0.2673219E+02, 0.3287624E+02, . 0.2417376E+03, 0.1522926E+02, 0.3831306E+04, 0.2196652E+03, . 0.7287435E+02, 0.8194879E+01/ data (sdev( 9,j),j=1,36) / 0.2546458E+02, 0.7520314E+01, . 0.1583576E+02, 0.8007618E+01, 0.4055698E+01, 0.2512221E+02, . 0.7765975E+01, 0.1336978E+04, 0.5802391E+03, 0.1659712E+04, . 0.2310691E+03, 0.1320454E+03, 0.1407886E+04, 0.2287508E+03, . 0.3549326E+03, 0.6250199E+03, 0.1747647E+03, 0.1116726E+03, . 0.7815645E+03, 0.1800884E+03, 0.1754649E+04, 0.4243386E+03, . 0.2447865E+03, 0.1705707E+04, 0.4525801E+03, 0.1010436E+03, . 0.5000002E+02, 0.4821107E+03, 0.7772745E+02, 0.4336179E+02, . 0.2819421E+03, 0.5012947E+02, 0.3344774E+04, 0.5673912E+03, . 0.1336848E+03, 0.3292386E+02/ data (scoef(10,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.9469541E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.1078930E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, .-0.1727341E+00, 0.0000000E+00,-0.6476331E+00, 0.0000000E+00, . 0.0000000E+00,-0.6957146E+00, 0.0000000E+00, 0.1605409E+00, . 0.1261314E+00,-0.1576631E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg(10,j),j=1,36) / 0.3980477E+00, 0.2159967E+02, . 0.5280331E+02,-0.5925649E+01, 0.4006236E+01, 0.5633189E+02, . 0.3727766E+01, 0.6011931E+03, 0.2631410E+02, 0.1027855E+03, . 0.5542253E+02,-0.9485357E+01, 0.8738937E+02,-0.7033623E+00, . 0.5208379E+03, 0.1195026E+04,-0.9081781E+02, 0.8989330E+02, . 0.1261422E+04, 0.7061524E+02, 0.3041471E+04,-0.2519473E+03, . 0.2191908E+03, 0.3042551E+04, 0.1953049E+03, 0.9791512E+02, .-0.2154251E+02,-0.2975466E+03,-0.2856389E+02, 0.3216120E+02, . 0.2370388E+03, 0.1545336E+02, 0.3819031E+04, 0.2332690E+03, . 0.7262690E+02, 0.8647505E+01/ data (sdev(10,j),j=1,36) / 0.2452266E+02, 0.7370310E+01, . 0.1591915E+02, 0.7926909E+01, 0.4014973E+01, 0.2541850E+02, . 0.7665672E+01, 0.1239007E+04, 0.5538984E+03, 0.1587020E+04, . 0.2307229E+03, 0.1327658E+03, 0.1352833E+04, 0.2263261E+03, . 0.3441646E+03, 0.6174752E+03, 0.1699011E+03, 0.1090849E+03, . 0.7755641E+03, 0.1731434E+03, 0.1751020E+04, 0.4186579E+03, . 0.2430095E+03, 0.1705991E+04, 0.4421535E+03, 0.1029045E+03, . 0.4997415E+02, 0.4806690E+03, 0.7786277E+02, 0.4229101E+02, . 0.2772892E+03, 0.4837127E+02, 0.3400294E+04, 0.5601602E+03, . 0.1343539E+03, 0.3347443E+02/ end c c c subroutine epshif5d(iyear,imonth,iday,elat,elon,ucmp12,vcmp12, * vel,vel12,iwnd) c c This subroutine calculates tropical cyclone in the eastern Pacific c intensities through 120 hours based upon climatology and persistence c using tropical cyclone data during the years 1975-1999 for development. c Tropical cyclones used in this developmental dataset had initial c positions south of 35N and east of 160W and were 50km from any c coastline. The linear regression model (one for each forecast time) c was created using the total change in intensity for each period c (12-hr,....120-hr) from intial conditions as the predictand and c 35 predictors including and derived from julian day, latitude, c longitude, zonal speed, meridional speed, current intensity the c past 12-hour intensity trend. c c In the formulation of the model linear terms are first put into the c model using a forward stepping approach for the 12-hour forecast. c The linear predictors chosen in this forward stepping process c are then forced into the model and exposed to the 2nd order terms, c which at this point are allowed to come into the model in a c stepwise fashion. A backward step is then performed to remove c predictors that are no longer significant. Then a final stepwise c stepping proceedure is performed possibly adding a removing predictors c c c Following the 12-hour forecast the predictors chosen for the previous c forecast period are then given preference in the selection process. c Again, the predictors chosen in this forward stepping process c are then forced into the model and exposed to the 2nd order terms, c which at this point are allowed to come into the model in a c stepwise fashion. A backward pass through the data is then performed c to remove predictors that are no longer significant. Followed by c a final step that is stepwise. Probabilities were set at .000000001%. c c J. Knaff (04/12/2001) c c Modified by James Franklin 7/2002 for compatibility with c verify_model.f c c Modified by James Franklin 3/2006 to avoid losing forecasts of winds c less than zero. Before, such forecasts were tossed, resulting in a loss of official c forecasts in homogeneous comparisons. Now, if the model forecasts a negative c windspeed, then the output value is set to 1 kt. c c common /coefeps/ scoef(10,36), avg(10,36), sdev(10,36) c c dimension coeficients. c parameter(nc=36) real p(36), forecast(10) double precision dv (10) dimension iwnd(10) c c dimension input. c real elat, elon, vel, vel12 c c intialize to zero c rad = 3.14159/180. do i=1,10 dv(i)=0.0 iwnd(i)=0 end do c c c check for system intensity requirements. c if (vel.lt.15.0.OR.vel12.lt.15.0) return c c create predictor pool (first order terms, squares, and c co-variances terms) c c p1 = absolute value of (julian day - 238) c p2 = lat c p3 = lon c p4 = u ! zonal speed of the storm over the last 12 hours c p5 = v ! meridional speed of the storm over the last 12 hours c p6 = vmax c p7 = delta vmax c c calculate julian day c call julian_day(imonth,iday,iyear,julday) c c assign predictor values from the input data c p(1) = dble(abs(julday-238)) p(2) = dble(elat) p(3) = dble(elon) c avglat=(elat+elat12)/2.0 c p(4) =dble((elon-elon12)* (-60.0)/ 12.0 * c . COS(rad*avglat)) c p(5)=dble((elat-elat12)*60./12.) p(4)=dble(ucmp12) p(5)=dble(vcmp12) p(6)=dble(vel) p(7)=dble(vel-vel12) p(8)=p(1)**2 !p1*p1 p(9)=p(1)*p(2) !p1*p2 p(10)=p(1)*p(3) !p1*p3 p(11)=p(1)*p(4) !etc.... p(12)=p(1)*p(5) p(13)=p(1)*p(6) p(14)=p(1)*p(7) p(15)=p(2)**2 p(16)=p(2)*p(3) p(17)=p(2)*p(4) p(18)=P(2)*p(5) p(19)=p(2)*p(6) p(20)=p(2)*p(7) p(21)=p(3)**2 p(22)=p(3)*p(4) p(23)=p(3)*p(5) p(24)=p(3)*p(6) p(25)=p(3)*p(7) p(26)=p(4)**2 p(27)=p(4)*p(5) p(28)=p(4)*p(6) p(29)=p(4)*p(7) p(30)=p(5)**2 p(31)=p(5)*p(6) p(32)=p(5)*p(7) p(33)=p(6)**2 p(34)=p(6)*p(7) p(35)=p(7)**2 p(36)=vel c c calculate the predicted incremental change in velocity c c do i=1,10 dv(i)=0.0 ! intitialize array to zero. do j=1,35 dv(i)=dv(i)+dble(scoef(i,j)*((p(j)-avg(i,j))/sdev(i,j))) end do dv(i)=dv(i)*dble(sdev(i,36)) + dble(avg(i,36)) end do c c c construct forecast intensities c forecast(1)=p(36)+dv(1) do i=1,10 forecast(i)= p(36)+sngl(dv(i)) end do do i=1,10 c if (forecast(i).lt.0.0)forecast(i)=0.0 c c Modification to avoid losing forecasts - JLF 3/13/06 c ---------------------------------------------------- if (forecast(i).lt.0.5)forecast(i)=1.0 iwnd(i)=nint(forecast(i)) end do c c return end C C C block data epacshifor_data c c This subprogram contains the standardized coefficients, means and c standard deviations of the predictors used in the eastern Pacific c version of the Statistical Hurricane Intensity Forecast. These c data are used in subroutine epshif5d and are passed via a common c block. c c scoef are the standardized coefficients c avg are the averages c sdev are the standard deviations c c common /coefeps/ scoef(10,36), avg(10,36), sdev(10,36) c data (scoef( 1,j),j=1,36) / 0.0000000E+00,-0.1823524E+00, .-0.6025346E-01, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.7614017E+00, 0.0000000E+00,-0.9648295E-01, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2989867E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2441196E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 1,j),j=1,36) / 0.3409045E+02, 0.1647778E+02, . 0.1194100E+03,-0.7575877E+01, 0.2703427E+01, 0.6359764E+02, . 0.8415730E+00, 0.1709157E+04, 0.5391900E+03, 0.3987097E+04, .-0.2346845E+03, 0.8988298E+02, 0.1862021E+04, 0.3237899E+02, . 0.2843427E+03, 0.1978615E+04,-0.1227261E+03, 0.4757833E+02, . 0.9302553E+03,-0.9259438E+00, 0.1446544E+05,-0.9215050E+03, . 0.3176249E+03, 0.6665289E+04, 0.5694735E+02, 0.8057443E+02, .-0.1971690E+02,-0.4274374E+03,-0.7634565E+01, 0.1694525E+02, . 0.1703698E+03, 0.4083034E+01, 0.3833088E+04, 0.7290146E+02, . 0.1182917E+03,-0.6213483E-01/ data (sdev( 1,j),j=1,36) / 0.2338930E+02, 0.3581487E+01, . 0.1437713E+02, 0.4814886E+01, 0.3104484E+01, 0.2800452E+03, . 0.1084420E+02, 0.2377903E+04, 0.3472305E+03, 0.2704805E+04, . 0.2426896E+03, 0.1372968E+03, 0.1545159E+04, 0.4306967E+03, . 0.1266151E+03, 0.5390896E+03, 0.8227717E+02, 0.6035736E+02, . 0.5446276E+03, 0.1866596E+03, 0.3603070E+04, 0.6238622E+03, . 0.3774387E+03, 0.3333336E+04, 0.1306984E+04, 0.7470361E+02, . 0.2940368E+02, 0.4714602E+03, 0.9879948E+02, 0.2882326E+02, . 0.3413755E+03, 0.4834698E+02, 0.3712495E+04, 0.2072621E+04, . 0.2253573E+03, 0.1101109E+02/ data (scoef( 2,j),j=1,36) / 0.0000000E+00,-0.2201037E+00, .-0.1125746E+01, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.7669960E+00, 0.0000000E+00,-0.1205761E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.3805355E+00, 0.9819010E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00,-0.3280108E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 2,j),j=1,36) / 0.3388374E+02, 0.1621464E+02, . 0.1190225E+03,-0.7737213E+01, 0.2666646E+01, 0.6608255E+02, . 0.1375492E+01, 0.1694369E+04, 0.5275113E+03, 0.3950797E+04, .-0.2393237E+03, 0.8834578E+02, 0.1907476E+04, 0.5036208E+02, . 0.2745901E+03, 0.1940280E+04,-0.1240043E+03, 0.4571776E+02, . 0.9503964E+03, 0.8596223E+01, 0.1436974E+05,-0.9367046E+03, . 0.3124024E+03, 0.6867745E+04, 0.1217556E+03, 0.8150956E+02, .-0.2046919E+02,-0.4495492E+03,-0.1176072E+02, 0.1598613E+02, . 0.1734764E+03, 0.5824803E+01, 0.4036648E+04, 0.9347293E+02, . 0.1184358E+03,-0.3540846E+00/ data (sdev( 2,j),j=1,36) / 0.2337367E+02, 0.3417155E+01, . 0.1426190E+02, 0.4652715E+01, 0.2979298E+01, 0.2928763E+03, . 0.1079621E+02, 0.2404624E+04, 0.3395607E+03, 0.2700929E+04, . 0.2367192E+03, 0.1330576E+03, 0.1568953E+04, 0.4286487E+03, . 0.1185794E+03, 0.5170034E+03, 0.7846817E+02, 0.5543961E+02, . 0.5550459E+03, 0.1833025E+03, 0.3568410E+04, 0.6010082E+03, . 0.3588002E+03, 0.3373653E+04, 0.1297714E+04, 0.7369955E+02, . 0.2833205E+02, 0.4820746E+03, 0.9938897E+02, 0.2604367E+02, . 0.3510014E+03, 0.4619587E+02, 0.3774183E+04, 0.2161811E+04, . 0.2182329E+03, 0.1938118E+02/ data (scoef( 3,j),j=1,36) / 0.0000000E+00,-0.2303735E+00, .-0.1473419E+01, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.7107538E+00, 0.0000000E+00,-0.1389359E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.4188341E+00, 0.1300377E+01, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.6600728E-01, . 0.0000000E+00, 0.0000000E+00,-0.3934926E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 3,j),j=1,36) / 0.3368899E+02, 0.1595987E+02, . 0.1186078E+03,-0.7856443E+01, 0.2622831E+01, 0.6849837E+02, . 0.2040401E+01, 0.1680311E+04, 0.5164424E+03, 0.3916439E+04, .-0.2425100E+03, 0.8671753E+02, 0.1946771E+04, 0.7170458E+02, . 0.2654435E+03, 0.1902633E+04,-0.1242365E+03, 0.4395626E+02, . 0.9662881E+03, 0.2062413E+02, 0.1426791E+05,-0.9467457E+03, . 0.3062754E+03, 0.7042070E+04, 0.2034481E+03, 0.8239523E+02, .-0.2073621E+02,-0.4684744E+03,-0.1724166E+02, 0.1511958E+02, . 0.1754523E+03, 0.7855410E+01, 0.4233243E+04, 0.1224204E+03, . 0.1156651E+03,-0.9270607E+00/ data (sdev( 3,j),j=1,36) / 0.2335459E+02, 0.3275283E+01, . 0.1414661E+02, 0.4546905E+01, 0.2870793E+01, 0.3072913E+03, . 0.1056016E+02, 0.2435531E+04, 0.3325807E+03, 0.2700756E+04, . 0.2341398E+03, 0.1308612E+03, 0.1594228E+04, 0.4169710E+03, . 0.1119010E+03, 0.4971324E+03, 0.7578139E+02, 0.5153394E+02, . 0.5683723E+03, 0.1760623E+03, 0.3533794E+04, 0.5863201E+03, . 0.3425258E+03, 0.3432086E+04, 0.1268322E+04, 0.7296887E+02, . 0.2785581E+02, 0.4960866E+03, 0.9846447E+02, 0.2392651E+02, . 0.3619989E+03, 0.4294414E+02, 0.3852650E+04, 0.2257165E+04, . 0.2120755E+03, 0.2645941E+02/ data (scoef( 4,j),j=1,36) / 0.0000000E+00,-0.6944878E+00, .-0.1674557E+01, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.6274028E+00, 0.0000000E+00,-0.1514233E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.5581393E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.4049150E+00, 0.1250209E+01, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.7471567E-01, . 0.0000000E+00, 0.0000000E+00,-0.4392256E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 4,j),j=1,36) / 0.3350910E+02, 0.1571008E+02, . 0.1181326E+03,-0.7945663E+01, 0.2557487E+01, 0.7075982E+02, . 0.2670429E+01, 0.1667663E+04, 0.5056566E+03, 0.3882390E+04, .-0.2444269E+03, 0.8436892E+02, 0.1976468E+04, 0.9222919E+02, . 0.2567841E+03, 0.1864842E+04,-0.1238269E+03, 0.4194849E+02, . 0.9755518E+03, 0.3153982E+02, 0.1415158E+05,-0.9529552E+03, . 0.2972958E+03, 0.7171507E+04, 0.2793818E+03, 0.8310629E+02, .-0.2060539E+02,-0.4832446E+03,-0.2235800E+02, 0.1434458E+02, . 0.1753482E+03, 0.9751166E+01, 0.4404444E+04, 0.1549809E+03, . 0.1150295E+03,-0.1737848E+01/ data (sdev( 4,j),j=1,36) / 0.2334276E+02, 0.3158935E+01, . 0.1401045E+02, 0.4469423E+01, 0.2793746E+01, 0.3236109E+03, . 0.1038819E+02, 0.2472404E+04, 0.3255645E+03, 0.2702188E+04, . 0.2325489E+03, 0.1293590E+03, 0.1617585E+04, 0.4053358E+03, . 0.1064771E+03, 0.4795868E+03, 0.7352919E+02, 0.4875947E+02, . 0.5826815E+03, 0.1700602E+03, 0.3490472E+04, 0.5741495E+03, . 0.3301058E+03, 0.3499914E+04, 0.1247264E+04, 0.7179615E+02, . 0.2745527E+02, 0.5120160E+03, 0.9851597E+02, 0.2227744E+02, . 0.3742758E+03, 0.4073142E+02, 0.3942398E+04, 0.2366353E+04, . 0.2132211E+03, 0.3194976E+02/ data (scoef( 5,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.6812104E+00, 0.0000000E+00,-0.1495004E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2898585E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.5135095E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2273493E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.8122859E-01, . 0.0000000E+00, 0.0000000E+00,-0.3064732E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 5,j),j=1,36) / 0.3327280E+02, 0.1547144E+02, . 0.1176365E+03,-0.8025509E+01, 0.2476860E+01, 0.7294497E+02, . 0.3328004E+01, 0.1649972E+04, 0.4945912E+03, 0.3841616E+04, .-0.2455439E+03, 0.8077078E+02, 0.1994411E+04, 0.1132713E+03, . 0.2486167E+03, 0.1828098E+04,-0.1232210E+03, 0.3979703E+02, . 0.9797526E+03, 0.4265947E+02, 0.1403067E+05,-0.9581615E+03, . 0.2865943E+03, 0.7265209E+04, 0.3586360E+03, 0.8392738E+02, .-0.2025503E+02,-0.4949773E+03,-0.2786637E+02, 0.1355154E+02, . 0.1738348E+03, 0.1159021E+02, 0.4546875E+04, 0.1918206E+03, . 0.1140813E+03,-0.2786772E+01/ data (sdev( 5,j),j=1,36) / 0.2330202E+02, 0.3041842E+01, . 0.1386926E+02, 0.4418356E+01, 0.2723592E+01, 0.3420756E+03, . 0.1015003E+02, 0.2512109E+04, 0.3184644E+03, 0.2702379E+04, . 0.2311652E+03, 0.1254157E+03, 0.1632792E+04, 0.3962381E+03, . 0.1006864E+03, 0.4603183E+03, 0.7158336E+02, 0.4644048E+02, . 0.5971776E+03, 0.1630912E+03, 0.3445141E+04, 0.5664914E+03, . 0.3198441E+03, 0.3571135E+04, 0.1213577E+04, 0.7166328E+02, . 0.2698355E+02, 0.5301886E+03, 0.9685469E+02, 0.2155422E+02, . 0.3892121E+03, 0.3890517E+02, 0.4031562E+04, 0.2486870E+04, . 0.2124573E+03, 0.3609719E+02/ data (scoef( 6,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.6261557E+00, 0.0000000E+00,-0.1497080E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2719499E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.5162974E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2741849E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.7807224E-01, . 0.0000000E+00, 0.0000000E+00,-0.2952774E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 6,j),j=1,36) / 0.3309105E+02, 0.1524456E+02, . 0.1170965E+03,-0.8085144E+01, 0.2390498E+01, 0.7491747E+02, . 0.3891728E+01, 0.1636725E+04, 0.4848110E+03, 0.3805275E+04, .-0.2458836E+03, 0.7685264E+02, 0.2000089E+04, 0.1311931E+03, . 0.2410369E+03, 0.1792407E+04,-0.1222881E+03, 0.3766839E+02, . 0.9766734E+03, 0.5174439E+02, 0.1390026E+05,-0.9611770E+03, . 0.2751466E+03, 0.7302574E+04, 0.4254768E+03, 0.8465199E+02, .-0.1974076E+02,-0.5023709E+03,-0.3289441E+02, 0.1277484E+02, . 0.1704612E+03, 0.1295930E+02, 0.4633386E+04, 0.2234049E+03, . 0.1132493E+03,-0.3925989E+01/ data (sdev( 6,j),j=1,36) / 0.2327682E+02, 0.2939717E+01, . 0.1373689E+02, 0.4391593E+01, 0.2657386E+01, 0.3626381E+03, . 0.9905671E+01, 0.2560954E+04, 0.3121063E+03, 0.2704248E+04, . 0.2283015E+03, 0.1202093E+03, 0.1636206E+04, 0.3908052E+03, . 0.9559690E+02, 0.4429090E+03, 0.7007668E+02, 0.4442154E+02, . 0.6100070E+03, 0.1564196E+03, 0.3400547E+04, 0.5635516E+03, . 0.3103789E+03, 0.3626780E+04, 0.1178258E+04, 0.7209558E+02, . 0.2665871E+02, 0.5498324E+03, 0.9543129E+02, 0.2097211E+02, . 0.4054575E+03, 0.3702311E+02, 0.4106859E+04, 0.2619981E+04, . 0.2103640E+03, 0.3879220E+02/ data (scoef( 7,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.5853452E+00, 0.0000000E+00,-0.1406750E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2364586E+00, 0.0000000E+00,-0.8097417E-01, . 0.0000000E+00,-0.4477453E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.3301889E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.8612577E-01,-0.2660320E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 7,j),j=1,36) / 0.3287039E+02, 0.1503177E+02, . 0.1165874E+03,-0.8148692E+01, 0.2312446E+01, 0.7469045E+02, . 0.4279135E+01, 0.1621358E+04, 0.4750126E+03, 0.3765667E+04, .-0.2458547E+03, 0.7305763E+02, 0.1991023E+04, 0.1410150E+03, . 0.2340843E+03, 0.1759192E+04,-0.1215257E+03, 0.3584299E+02, . 0.9667653E+03, 0.5768961E+02, 0.1377877E+05,-0.9648518E+03, . 0.2649892E+03, 0.7298661E+04, 0.4706489E+03, 0.8548945E+02, .-0.1926236E+02,-0.5090874E+03,-0.3672544E+02, 0.1212880E+02, . 0.1640531E+03, 0.1378406E+02, 0.4672013E+04, 0.2449278E+03, . 0.1147646E+03,-0.4972365E+01/ data (sdev( 7,j),j=1,36) / 0.2325965E+02, 0.2851655E+01, . 0.1364507E+02, 0.4369481E+01, 0.2604390E+01, 0.3572350E+03, . 0.9822130E+01, 0.2620210E+04, 0.3063521E+03, 0.2710421E+04, . 0.2250002E+03, 0.1148629E+03, 0.1627826E+04, 0.3834453E+03, . 0.9109157E+02, 0.4275875E+03, 0.6883896E+02, 0.4284667E+02, . 0.6080621E+03, 0.1531289E+03, 0.3367195E+04, 0.5614836E+03, . 0.3026992E+03, 0.3670575E+04, 0.1166571E+04, 0.7268656E+02, . 0.2630556E+02, 0.5491028E+03, 0.9548569E+02, 0.2073056E+02, . 0.3987535E+03, 0.3619340E+02, 0.4166875E+04, 0.2772995E+04, . 0.2160317E+03, 0.4040804E+02/ data (scoef( 8,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00,-0.1366803E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2516920E+00, 0.0000000E+00,-0.9944827E-01, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2916846E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00,-0.3086647E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 8,j),j=1,36) / 0.3267741E+02, 0.1483578E+02, . 0.1161084E+03,-0.8193725E+01, 0.2257631E+01, 0.7162686E+02, . 0.4580464E+01, 0.1611289E+04, 0.4663680E+03, 0.3730107E+04, .-0.2449940E+03, 0.7036105E+02, 0.1976781E+04, 0.1472987E+03, . 0.2277729E+03, 0.1728568E+04,-0.1205942E+03, 0.3454231E+02, . 0.9528255E+03, 0.6192274E+02, 0.1366508E+05,-0.9661400E+03, . 0.2576956E+03, 0.7274969E+04, 0.5052988E+03, 0.8597862E+02, .-0.1888309E+02,-0.5160939E+03,-0.3935513E+02, 0.1167900E+02, . 0.1558802E+03, 0.1408596E+02, 0.4682938E+04, 0.2563573E+03, . 0.1164193E+03,-0.5997314E+01/ data (sdev( 8,j),j=1,36) / 0.2331542E+02, 0.2770294E+01, . 0.1356292E+02, 0.4341210E+01, 0.2565874E+01, 0.3118126E+03, . 0.9770463E+01, 0.2700221E+04, 0.3019180E+03, 0.2728907E+04, . 0.2217190E+03, 0.1108056E+03, 0.1614140E+04, 0.3789682E+03, . 0.8680218E+02, 0.4127718E+03, 0.6735981E+02, 0.4158892E+02, . 0.5858888E+03, 0.1504650E+03, 0.3336576E+04, 0.5575274E+03, . 0.2972206E+03, 0.3702202E+04, 0.1157438E+04, 0.7301750E+02, . 0.2609112E+02, 0.5195650E+03, 0.9562437E+02, 0.2091177E+02, . 0.3571355E+03, 0.3537364E+02, 0.4208102E+04, 0.2944192E+04, . 0.2209439E+03, 0.4131228E+02/ data (scoef( 9,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00,-0.1245924E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.2065900E+00, 0.0000000E+00,-0.1119146E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.3103650E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00,-0.3156649E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg( 9,j),j=1,36) / 0.3256700E+02, 0.1464551E+02, . 0.1155945E+03,-0.8221828E+01, 0.2212730E+01, 0.6724372E+02, . 0.4851480E+01, 0.1610180E+04, 0.4590651E+03, 0.3702369E+04, .-0.2446719E+03, 0.6839015E+02, 0.1959760E+04, 0.1568171E+03, . 0.2217126E+03, 0.1698372E+04,-0.1193639E+03, 0.3350007E+02, . 0.9351116E+03, 0.6553180E+02, 0.1354381E+05,-0.9647840E+03, . 0.2514245E+03, 0.7223625E+04, 0.5354881E+03, 0.8602952E+02, .-0.1838713E+02,-0.5213773E+03,-0.4177164E+02, 0.1129564E+02, . 0.1469301E+03, 0.1391820E+02, 0.4667659E+04, 0.2648191E+03, . 0.1178677E+03,-0.7068398E+01/ data (sdev( 9,j),j=1,36) / 0.2344619E+02, 0.2687708E+01, . 0.1348207E+02, 0.4293741E+01, 0.2530070E+01, 0.2366000E+03, . 0.9713761E+01, 0.2796710E+04, 0.2982126E+03, 0.2756915E+04, . 0.2191171E+03, 0.1077691E+03, 0.1599424E+04, 0.3733430E+03, . 0.8225807E+02, 0.3977646E+03, 0.6485299E+02, 0.4052077E+02, . 0.5554506E+03, 0.1482124E+03, 0.3306920E+04, 0.5491180E+03, . 0.2916813E+03, 0.3740634E+04, 0.1145511E+04, 0.7211736E+02, . 0.2558451E+02, 0.4751219E+03, 0.9594357E+02, 0.2122226E+02, . 0.2924824E+03, 0.3480763E+02, 0.4253586E+04, 0.3133444E+04, . 0.2277168E+03, 0.4168740E+02/ data (scoef(10,j),j=1,36) / 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,-0.6412943E+00, . 0.0000000E+00, 0.0000000E+00,-0.1008322E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00,-0.1808974E+00, 0.0000000E+00,-0.9930872E-01, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, . 0.0000000E+00, 0.1000000E+01/ data (avg(10,j),j=1,36) / 0.3244245E+02, 0.1446961E+02, . 0.1151464E+03,-0.8219359E+01, 0.2156941E+01, 0.6130843E+02, . 0.5112215E+01, 0.1608799E+04, 0.4521713E+03, 0.3675283E+04, .-0.2431198E+03, 0.6584370E+02, 0.1934150E+04, 0.1645114E+03, . 0.2161679E+03, 0.1671032E+04,-0.1178861E+03, 0.3231959E+02, . 0.9146586E+03, 0.6895284E+02, 0.1344060E+05,-0.9605197E+03, . 0.2440476E+03, 0.7157191E+04, 0.5657189E+03, 0.8555419E+02, .-0.1777317E+02,-0.5241910E+03,-0.4391199E+02, 0.1068508E+02, . 0.1363673E+03, 0.1368596E+02, 0.4633374E+04, 0.3485460E+03, . 0.1163851E+03,-0.8081436E+01/ data (sdev(10,j),j=1,36) / 0.2358951E+02, 0.2607800E+01, . 0.1348963E+02, 0.4242887E+01, 0.2456545E+01, 0.2957923E+02, . 0.9501540E+01, 0.2905742E+04, 0.2946989E+03, 0.2792864E+04, . 0.2139260E+03, 0.1052045E+03, 0.1575003E+04, 0.3630870E+03, . 0.7811045E+02, 0.3847938E+03, 0.6279043E+02, 0.3821323E+02, . 0.5127150E+03, 0.1431177E+03, 0.3302588E+04, 0.5408215E+03, . 0.2809234E+03, 0.3784311E+04, 0.1114523E+04, 0.7099328E+02, . 0.2340798E+02, 0.4078613E+03, 0.9483244E+02, 0.1876076E+02, . 0.1704033E+03, 0.3395292E+02, 0.4303698E+04, 0.8312715E+03, . 0.2208521E+03, 0.4166153E+02/ end C C subroutine julian_day(imon,iday,iyear,julday) c c This routine calculates the Julian day (julday) from c the month (imon), day (iday), and year (iyear). The c appropriate correction is made for leap year. c dimension ndmon(12) c c Specify the number of days in each month ndmon(1) = 31 ndmon(2) = 28 ndmon(3) = 31 ndmon(4) = 30 ndmon(5) = 31 ndmon(6) = 30 ndmon(7) = 31 ndmon(8) = 31 ndmon(9) = 30 ndmon(10) = 31 ndmon(11) = 30 ndmon(12) = 31 c c Correct for leap year if (mod(iyear,4) .eq. 0) ndmon(2)=29 c c Check for illegal input if (imon .lt. 1 .or. imon .gt. 12) then julday=-1 return endif c if (iday .lt. 1 .or. iday .gt. ndmon(imon)) then julday=-1 return endif c c Calculate the Julian day julday = iday if (imon .gt. 1) then do 10 i=2,imon julday = julday + ndmon(i-1) 10 continue endif c return end C C C subroutine calendar_day(iyear,julday,imon,iday) c c This routine calculates the calendar day (julday) from c the Julian day and year. The c appropriate correction is made for leap year. c integer daytab(24) data daytab/31,28,31,30,31,30,31,31,30,31,30,31, * 31,29,31,30,31,30,31,31,30,31,30,31/ c if ((mod(iyear,4).eq.0.and.mod(iyear,100).ne.0) .or. * (mod(iyear,400).eq.0)) then leap = 1 else leap = 0 endif c i=1 mday = julday do while (mday>daytab(i+12*leap)) ii = i+12*leap mday = mday-daytab(ii) i=i+1 end do imon=i iday=mday return end C C C C ------------------------------------------------------------ SUBROUTINE BTCLIP(BASIN,IMO,IDY,IHR,NBT,BMO,BDY,BHR, * BLAT,BLON,BWS,CLAT,CLON,SWND) C C Returns original BT cliper forecast. Output is 12,24,36,48, C 60, and 72 h. Remaining elements of CLAT, CLON are -999. C Valid for the north Atlantic only. C C IMO,IDY,IHR Time to compute a cliper forecast for. C NBT Number of elements in the best track data arrays. C BMO,BDY,BHR Arrays of best track dates/times. C BLAT(NBT) BT latitude (deg N). C BLON(NBT) BT longitude (deg E). C BWS(NBT) BT wind speed (kt). C CLAT(NVTX) Returned array of BT CLIPER lats. C CLON(NVTX) Returned array of BT CLIPER lons. C SWND(NVTX) Placeholder for SHIFOR forecast - not used. C ------------------------------------------------------------ C PARAMETER (NVTX=10) DIMENSION BMO(NBT), BDY(NBT), BHR(NBT) DIMENSION BLAT(NBT), BLON(NBT), BWS(NBT) DIMENSION CLAT(NVTX), CLON(NVTX), SWND(NVTX) DIMENSION DISP(12) CHARACTER*2 BASIN C C RLAT0 = -999. RLON0 = -999. DIR0 = -999. SPD0 = -999. DIR12 = -999. SPD12 = -999. WS0 = -999. DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE IF (BASIN.NE.'AL') RETURN C C C Compute input parameters for the CLIPER subroutine. C Start by checking for a BT match to desired time. C --------------------------------------------------- DO 110 L = 1,NBT IF (IMO.EQ.NINT(BMO(L)).AND.IDY.EQ.NINT(BDY(L)) * .AND.IHR.EQ.NINT(BHR(L))) * THEN L0 = L GOTO 200 ENDIF 110 CONTINUE C C Could not find a best track entry for the requested time C -------------------------------------------------------- GOTO 800 C C C Found a valid match at index L0. Get initial position. C ------------------------------------------------------- 200 RLAT0 = BLAT(L0) RLON0 = -BLON(L0) WS0 = BWS(L0) C C Get previous, next positions to estimate current speed C ------------------------------------------------------ LB = L0-1 LF = L0+1 IF (LB.LT.1) LB=1 IF (LF.GT.NBT) LF = NBT CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR0) SPD0 = DIST/DELTAH C DIR0 = NINT(DIR0) C SPD0 = NINT(SPD0) C C C Now try to get previous 12 h speed C ---------------------------------- LB = L0-3 LF = L0-1 IF (LB.LT.1) LB=1 IF (LF.LE.LB) LF=LB+1 CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR12) SPD12 = DIST/DELTAH C DIR12 = NINT(DIR12) C SPD12 = NINT(SPD12) C C C C Generate CLIPER displacements and convert to lat/lon. C ----------------------------------------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (DIR12.EQ.-999. OR. SPD12.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 C WRITE(1,'(3I2,1X,7F9.1)') C * IMO,IDY,IHR,RLAT0,RLON0,DIR0,SPD0,DIR12,SPD12,WS0 CALL CLIPER(RLAT0,RLON0,DIR0,SPD0,DIR12,SPD12,WS0,IMO,IDY,DISP) GBEAR = 360. GSIZE = 1. CALL STHGPR(RLAT0,RLON0,GBEAR,GSIZE,0.,0.) DO 510 I=1,6 K=2*I J=(2*I)-1 CALL XY2LLH(DISP(K),DISP(J),CLAT(I),CLON(I)) CLAT(I) = FLOAT(INT(CLAT(I)*10.+0.5))/10. CLON(I) = -FLOAT(INT(CLON(I)*10.+0.5))/10. 510 CONTINUE C C C All done, go back C ----------------- 800 RETURN END C C C C ------------------------------------------------------------ SUBROUTINE BTCLIPA(BASIN,IMO,IDY,IHR,NBT,BMO,BDY,BHR, * BLAT,BLON,BWS,CLAT,CLON,SWND) C C Returns BT cliper forecast, using Sim Aberson version C of Charlie Neumann's original model, except raw output is C every 12 h out to 120 h. Valid for the north Atlantic only. C C IMO,IDY,IHR Time to compute a cliper forecast for. C NBT Number of elements in the best track data arrays. C BMO,BDY,BHR Arrays of best track dates/times. C BLAT(NBT) BT latitude (deg N). C BLON(NBT) BT longitude (deg E). C BWS(NBT) BT wind speed (kt). C CLAT(NVTX) Returned array of BT CLIPER lats. C CLON(NVTX) Returned array of BT CLIPER lons. C SWND(NVTX) Placeholder for SHIFOR forecast - not used. C ------------------------------------------------------------ C PARAMETER (NVTX=10) parameter (nvaratl=165,nvar=nvaratl) DIMENSION BMO(NBT), BDY(NBT), BHR(NBT) DIMENSION BLAT(NBT), BLON(NBT), BWS(NBT) DIMENSION CLAT(NVTX), CLON(NVTX), SWND(NVTX) CHARACTER*2 BASIN CHARACTER*40 ALFILE C real rlat(11),rlon(11),jday(12), 1 acon(20),coef(20,nvar),x(nvar),disp(20) data jday /1.,32.,60.,91.,121.,152.,182.,213.,244.,274.,305.,335./ C C RLAT0 = -999. RLON0 = -999. DIR0 = -999. SPD0 = -999. DIR12 = -999. SPD12 = -999. WS0 = -999. DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE IF (BASIN.NE.'AL') RETURN C C C Compute input parameters for the CLIPER subroutine. C Start by checking for a BT match to desired time. C --------------------------------------------------- DO 110 L = 1,NBT IF (IMO.EQ.NINT(BMO(L)).AND.IDY.EQ.NINT(BDY(L)) * .AND.IHR.EQ.NINT(BHR(L))) * THEN L0 = L GOTO 200 ENDIF 110 CONTINUE C C Could not find a best track entry for the requested time C -------------------------------------------------------- GOTO 800 C C C Found a valid match at index L0. Get initial position. C ------------------------------------------------------- 200 RLAT0 = BLAT(L0) RLON0 = -BLON(L0) WS0 = BWS(L0) C C Get previous, next positions to estimate current speed C ------------------------------------------------------ LB = L0-1 LF = L0+1 IF (LB.LT.1) LB=1 IF (LF.GT.NBT) LF = NBT CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR0) SPD0 = DIST/DELTAH C DIR0 = NINT(DIR0) C SPD0 = NINT(SPD0) C C C Now try to get previous 12 h speed C ---------------------------------- LB = L0-3 LF = L0-1 IF (LB.LT.1) LB=1 IF (LF.LE.LB) LF=LB+1 CALL DIFTIME(2000,NINT(BMO(LB)),NINT(BDY(LB)),BHR(LB), * 2000,NINT(BMO(LF)),NINT(BDY(LF)),BHR(LF),DELTAH) RLATB = BLAT(LB) RLONB = -BLON(LB) RLATF = BLAT(LF) RLONF = -BLON(LF) CALL LL2DB(RLATB,RLONB,RLATF,RLONF,DIST,DIR12) SPD12 = DIST/DELTAH C DIR12 = NINT(DIR12) C SPD12 = NINT(SPD12) C C C C Generate CLIPER displacements and convert to lat/lon. C ----------------------------------------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (DIR12.EQ.-999. OR. SPD12.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 C WRITE(1,'(3I2,1X,7F9.1)') C * IMO,IDY,IHR,RLAT0,RLON0,DIR0,SPD0,DIR12,SPD12,WS0 C C Sim's code begins here, with modifications. C ------------------------------------------- alfile = 'support_files/sda_alclpt_coeff.dat' open (21,file=alfile,status='old',err=900) do i=1,20 read(21,599,err=900) acon(i),(coef(i,j),j=1,nvaratl) 599 format(33(5e16.9,/),e16.9) c599 format(33(5e15.7,/),e15.7) c599 format(23(7f11.4,/),5f11.4) end do close (21) rlat(1) = RLAT0 rlon(1) = RLON0 wind=WS0*111.1*1000./(60.*3600.) days=jday(IMO)+real(IDY)+real(IHR)/24. rdir=DIR0+180. if(rdir.ge.360.)rdir=rdir-360. rspd=SPD0*111.1*1000./(60.*3600.) call uvcomp2(rdir,rspd,ucmp,vcmp) rdir=DIR12+180. if(rdir.ge.360.)rdir=rdir-360. rspd=SPD12*111.1*1000./(60.*3600.) call uvcomp2(rdir,rspd,ucmpm12,vcmpm12) ucmp=-ucmp ucmpm12=-ucmpm12 x(1)=rlat(1) x(2)=rlon(1) x(3)=wind x(4)=days x(5)=vcmp x(6)=ucmp x(7)=vcmpm12 x(8)=ucmpm12 c write(1,*) (x(i),i=1,8) c rlat(1) = 17.1 c rlon(1) = 84.2 c x(1) = 17.1 c x(2) = 84.2 c x(3) = 15.43056 c x(4) = 155. c x(5) = 4.008976 c x(6) = 2.314584 c x(7) = 4.899859 c x(8) = 2.828935 c write(1,*) (x(i),i=1,8) klij=8 do ijkl=1,8 do jkli=ijkl,8 klij=klij+1 x(klij)=x(ijkl)*x(jkli) end do end do do ijkl=1,8 do jkli=ijkl,8 do lijk=jkli,8 klij=klij+1 x(klij)=x(ijkl)*x(jkli)*x(lijk) end do end do end do do i=1,20 disp(i)=acon(i) c if(rlat(1).lt.rlon(1)-64.)disp(i)=acon(i+20) end do do i=1,20 do j=1,nvar c if(rlat(1).ge.rlon(1)-64.)then disp(i)=disp(i)+x(j)*coef(i,j) c else c disp(i)=disp(i)+x(j)*coef(i+20,j) c endif end do end do do i=2,11 rlat(i)=rlat(1)+disp(i-1) end do do i=2,11 disp(i+9)=disp(i+9)/cos((real((rlat(1)+rlat(i))/2.))* * 3.14159/180.0) end do do i=2,11 rlon(i)=rlon(1)+disp(i+9) end do c write(1,101) c 1 (int(rlat(i)*10.+0.5),int(rlon(i)*10.+0.5),i=2,5), c 2 int(rlat(7)*10.+0.5),int(rlon(7)*10.+0.5) c write(1,101) c 1 (int(rlat(i)*10.+0.5),int(rlon(i)*10.+0.5),i=7,11) 101 format(10i4) C C C Load final array of forecast values. C ------------------------------------ DO 510 I=1,10 CLAT(I) = FLOAT(INT(RLAT(I+1)*10.+0.5))/10. CLON(I) = -FLOAT(INT(RLON(I+1)*10.+0.5))/10. c write(1,*) clat(i),clon(i) 510 CONTINUE C C C All done, go back C ----------------- 800 RETURN C C C Error on coefficient file C ------------------------- 900 WRITE(1,'("FATAL ERROR READING CLIPER COEFFICIENTS.")') STOP C END C C C C ------------------------------------------------------------ SUBROUTINE OCLIP(BASIN,IYR,IMO,IDY,IHR, * RLAT0,RLON0E,WS0,DIR0,SPD0, * RLAT12,RLON12E,WS12,DIR12,SPD12, * CLAT,CLON,SWND) C C Reruns operational 3-day cliper forecast. C Output variables formally at 12, 24, 36, 48, 60, 72, C 84, 96, 108, and 120 h, but only filled for 12, 24, 36, 48, C and 72 h. Valid for Atlantic basin only. C C BASIN AL or EP. C IYR Year (4 digit) C IMO,IDY,IHR Time to compute a cliper forecast for. C RLAT0 Initial lat C RLON0E Initial long (deg E) C WS0 Initial wind speed C DIR0 Initial heading C SPD0 Initial forward speed C RLAT12 t-12h lat C RLON12E t-12h long (deg E) C WS12 t-12h wind speed C DIR12 t-12h heading C SPD12 t-12h forward speed C CLAT(NVTX) Returned array of CLIPER lats. C CLON(NVTX) Returned array of CLIPER lons. C SWND(NVTX) Returned array of SHIFOR winds (not yet). C ------------------------------------------------------------ C PARAMETER (NVTX=10) DIMENSION CLAT(NVTX), CLON(NVTX) DIMENSION IWSHIF(NVTX), SWND(NVTX) DIMENSION FLAT(5),FLON(5) CHARACTER*2 BASIN C C DO 50 J = 1,NVTX CLAT(J) = -999. CLON(J) = -999. SWND(J) = -999. 50 CONTINUE C IF (BASIN.NE.'AL') RETURN C RLON0 = -999. RLON12 = -999. IF (RLON0E.NE.-999.) RLON0 = -RLON0E IF (RLON12E.NE.-999.) RLON12 = -RLON12E C C C Get CLIPER forecast. C -------------------- 500 IF (RLAT0.EQ.-999. .OR. RLON0.EQ.-999.) GOTO 800 IF (DIR0.EQ.-999. OR. SPD0.EQ.-999.) GOTO 800 IF (WS0.EQ.-999.) GOTO 800 CALL OPCLIP(RLAT0,RLON0,DIR0,SPD0,DIR12,SPD12,WS0,IMO,IDY, * FLAT,FLON) C C C Place results in final arrays. C ------------------------------ DO 510 I=1,5 II = I IF (I.EQ.5) II = 6 CLON(II) = -FLON(I) CLAT(II) = FLAT(I) 510 CONTINUE C C C All done, go back C ----------------- 800 RETURN END C C C C ---------------------------------------------------------------- SUBROUTINE OPCLIP(Y,X,DNOW,SNOW,DM12,SM12,WKTS,MO,KDA,YF,XF) C C THIS IS THE OPERATIONAL SUBROUTINE--NOT THE 'BEST-TRACK' VERSION C THIS VERSION CONTAINS GULF OF MEXICO CORRECTION C C Modified to pass lat,lon not displacements. JLF 1/2004. C ---------------------------------------------------------------- C LOGICAL SKIP_OUTPUT DIMENSION DISP(10),FULL(10),GULF(10),CNS(14,5),CEW(8,5),ND(12), 00065700 1 P(14),XG(5),YG(5),XA(5),YA(5),XF(5),YF(5) 00065800 COMMON /BLK13/DAN 00065900 COMMON /BLK3/ STMNAM(5),IN(10),LIST(5,6),FP(6,6) 00066000 C 00066100 C REFER TO NOAA TECHNICAL MEMORANDUM NWS SR-62 (C.J. NEUMANN, JAN 1972) 00066200 C FOR A DESCRIPTION OF CLIPER SYSTEM. 00066300 C 00066400 C 00066500 C LIST CONSTANTS FOR MERIDIONAL DISPLACEMENTS. 00066600 C 00066700 DATA CNS/7.60553,13.59909,-2.575127,-.0001868914,.00460007, 00066800 1.0022623,-.001491833,-.0002678624,-.00006994195,.00004407501, 00066900 2-.0002049626,.00007781249,.1430621,-.00008156078,30.30846, 00067000 322.91538,-2.484599,.004968631,.009297729,.02511378,-.007839641, 00067100 4-.005977559,-.0003504201,.0001557468,-.0009956548,.0004778924, 00067200 5.3879478,-.000671019,67.69324,31.94291,-3.697592,.009672852, 00067300 6.009539232,.06322068,-.01332191,-.01610885,-.0007292257, 00067400 7.0002341562,-.002814067,.001145255,.8940798,-.002181595,120.27143,00067500 838.94701,-4.380877,.01323013,.02292699,.09532129,-.01664333, 00067600 9-.03200883,-.001216522,.000315372,-.005450743,.001867606,1.666658,00067700 1-.004353084,263.15653,48.41731,-4.456658,.01126704,.04297187, 00067800 2.16962,-.01748416,-.06485724,-.002215515,.0003599106,-.012677, 00067900 3.003690242,4.121246,-.01102184/ 00068000 C 00068100 C LIST CONSTANTS FOR ZONAL DISPLACEMENTS. 00068200 C 00068300 DATA CEW/-3.52591,13.69309,-2.637347,.8151257,.6867776, 00068400 1-.002168753,-.000596625,.1247267,-13.12388,23.30256,-3.215529, 00068500 23.584506,3.949364,-.007860247,-.006764091,.5135556,-28.48156, 00068600 332.37355,-5.342858,8.073875,9.321241,-.01318171,-.02040824, 00068700 41.044624,-44.13759,38.93667,-6.819777,14.10797,16.35476, 00068800 5-.01967039,-.03853289,1.698018,-60.23074,46.26022,-8.8089, 00068900 629.11625,32.91178,-.02181549,-.08553838,3.291178/ 00069000 C 00069100 DATA ND/0,31,59,90,120,151,181,212,243,273,304,334/ 00069200 C C Skip written output (JLF 1/2004) DATA SKIP_OUTPUT/.TRUE./ C 00069300 C CHECK FOR STORM LOCATION AND DETERMINE WEIGHTING FACTORS 00069400 WA=(X-Y-61.)/5. 00069500 WB=(Y-13.)/4. 00069600 IF(WA.GT.1.)WA=1. 00069700 IF(WA.LT.0.)WA=0. 00069800 IF(WB.GT.1.)WB=1. 00069900 IF(WB.LT.0.)WB=0. 00070000 WGULF=WA*WB 00070100 WFULL=1.-WGULF 00070200 C COMPUTE DAY NUMBER AND SUBTRACT OFF MEANS 00070300 C 00070400 DAN=ND(MO)+KDA 00070500 DANBR=ND(MO)+KDA-248 00070600 IF(DANBR.LT.-95.)DANBR=-95. 00070700 IF(DANBR.GT.82.)DANBR=82. 00070800 C 00070900 WMPH=(WKTS*1.15)-71. 00071000 ALAT=Y-24. 00071100 ALON=X-68. 00071200 C 00071300 C CONVERT PRESENT AND PAST MOTION TO U AND V COMPONENTS. 00071400 C 00071500 T=.0174533 00071600 UNOW=SIN(DNOW*T)*SNOW 00071700 VNOW=COS(DNOW*T)*SNOW 00071800 UM12=SIN(DM12*T)*SM12 00071900 VM12=COS(DM12*T)*SM12 00072000 CALL CGULF(Y,X,UNOW,VNOW,UM12,VM12,DAN,WKTS,WGULF,GULF) 00072100 C 00072200 C SET UP MERIDIONAL PREDICTORS AND COMPUTE MERIDIONAL DISPLACEMENTS. 00072300 C 00072400 P(1)=1.0 00072500 P(2)=VNOW 00072600 P(3)=VM12 00072700 P(4)=VNOW*VM12*VM12 00072800 P(5)=WMPH*VM12 00072900 P(6)=VNOW*WMPH 00073000 P(7)=VNOW*VNOW*VM12 00073100 P(8)=ALAT*ALAT*VNOW 00073200 P(9)=DANBR*DANBR*VM12 00073300 P(10)=VNOW*DANBR*DANBR 00073400 P(11)=ALAT*ALAT*DANBR 00073500 P(12)=WMPH*DANBR*VM12 00073600 P(13)=UNOW 00073700 P(14)=DANBR*DANBR 00073800 DO 15 I=1,5 00073900 ZZ=0. 00074000 DO 10 J=1,14 00074100 10 ZZ=ZZ+CNS(J,I)*P(J) 00074200 15 FULL(2*I-1)=ZZ 00074300 C 00074400 C SET UP ZONAL PREDICTORS AND COMPUTE ZONAL DISPLACEMENTS. 00074500 C 00074600 P(2)=UNOW 00074700 P(3)=UM12 00074800 P(4)=ALAT 00074900 P(5)=VNOW 00075000 P(6)=VNOW*VNOW*UM12 00075100 P(7)=ALAT*VNOW*UM12 00075200 P(8)=ALON 00075300 DO 25 I=1,5 00075400 ZZ=0. 00075500 DO 20 J=1,8 00075600 20 ZZ=ZZ+CEW(J,I)*P(J) 00075700 C CHANGE SIGN TO DESIGNATE WESTWARD MOTION AS POSITIVE MOTION. 00075800 25 FULL(2*I)=-ZZ 00075900 C COMPUTE COMBINED DISPLACEMENTS AND OUTPUT SUPPLEMENTAL 00076000 C CLIPER MESSAGE 00076100 C C Skip written output...JLF 1/2004 C IF (SKIP_OUTPUT) GOTO 100 WRITE(6,32) 00076200 32 FORMAT(1H1,15X,39HSUPPLEMENTAL OUTPUT FOR CLIPER FORECAST) 00076300 IF(WFULL.EQ.0.)WRITE(6,33) 00076400 IF(WGULF.EQ.0.)WRITE(6,34) 00076500 IF(WFULL.NE.0.AND.WGULF.NE.0.)WRITE(6,35) 00076600 33 FORMAT(1H0,15X,42HFORECAST BASED ON GULF OF MEXICO EQUATIONS) 00076700 34 FORMAT(1H0,15X,42HFORECAST BASED ON ATLANTIC BASIN EQUATIONS) 00076800 35 FORMAT(1H0,15X,37HFORECAST BASED ON WEIGHTED AVERAGE OF,/,16X,43HA00076900 1TLANTIC BASIN AND GULF OF MEXICO EQUATIONS) 00077000 WRITE(6,36)STMNAM,DNOW,SNOW,DAN,DM12,SM12,WKTS 00077100 36 FORMAT(1H0,15X,8HRUN FOR ,5A4,/,21X,15HCURRENT MOTION ,F4.0,1H/,F300077200 1.0,12H DAYNUMBER=,F4.0,/,21X,15H12H OLD MOTION ,F4.0,1H/,F3.0,7H 00077300 2 WIND=,F4.0) 00077400 WRITE(6,38)WFULL,WGULF 00077500 38 FORMAT(1H0,15X,48HFCST FULL BASIN GULF OF MEXICO COMPOSITE00077600 1,/,16X,13HTIME WEIGHT=,F4.2,12H WEIGHT=,F4.2) 00077700 C 100 DO 40 I=1,10 00077800 DISP(I)=GULF(I)*WGULF+FULL(I)*WFULL 00077900 40 CONTINUE 00078000 DO 42 I=1,5 00078100 YG(I)=GULF(2*I-1)/60.+Y 00078200 XG(I)=GULF(2*I)/COS((YG(I)+Y)*T/2.)/60.+X 00078300 IF(WGULF.EQ.0.)YG(I)=-99.9 00078400 IF(WGULF.EQ.0.)XG(I)=-99.9 00078500 YA(I)=FULL(2*I-1)/60.+Y 00078600 XA(I)=FULL(2*I)/COS((YA(I)+Y)*T/2.)/60.+X 00078700 YF(I)=DISP(2*I-1)/60.+Y 00078800 XF(I)=DISP(2*I)/COS((YF(I)+Y)*T/2.)/60.+X 00078900 42 CONTINUE 00079000 C WRITE POSITIONS 00079100 IF (SKIP_OUTPUT) RETURN ITME=0 00079200 WRITE(6,305)ITME,Y,X,Y,X,Y,X 00079300 305 FORMAT(1H ,16X,I2,F7.1,2HN ,F5.1,4HW ,2(F5.1,2HN ,F5.1,4HW )) 00079400 DO 44 I=1,5 00079500 ITME=12*I 00079600 IF(I.EQ.5)ITME=72 00079700 WRITE(6,305)ITME,YA(I),XA(I),YG(I),XG(I),YF(I),XF(I) 00079800 44 CONTINUE 00079900 * WRITE(6,310) 00080000 * 310 FORMAT(1H0,16X,49H.......... END OF CLIPER FORECAST ..............00080100 * 1.,///) 00080200 RETURN 00080300 END 00080400 C C C SUBROUTINE CGULF(Y,X,U,V,U12,V12,DN,W,WGULF,GULF) 00010000 C THIS SUBROUTINE WAS ADDED JUNE 1980 AND INCLUDES A CLIPER EQUATION 00011000 C SET DEVELOPED FOR THE WESTERN GULF OF MEXICO AND NORTHWEST CARIBBEAN00012000 C SEA. IT IS CALLED BY SUBROUTINE CLIPER AND IS IN THE NHC72 OVERLAY 00013000 DIMENSION GULF(10),X12(37),X24(37),X36(37),X48(37),X72(37), 00014000 1 P(37),Y12(37),Y24(37),Y36(37),Y48(37),Y72(37) 00015000 DATA Y12/ 0.0888784, 2.0189338, -3.0232588, 5.0112631, 00016000 1 -0.4663586, -2.2601204, 1.6083838, -0.0002354, 0.0025722, 00017000 2 0.0380934, -0.0006782, -0.0451460, 0.0196852, 0.0053249, 00018000 3 -0.0941109, 0.1065220, 0.0371968, -0.0074174, 0.0114476, 00019000 4 0.0397118, -0.1690010, -0.1136812, -0.0028529, 0.0703457, 00019100 5 -0.0153966, -0.0423261, 0.1190649, 0.0001786, 0.0059967, 00019200 6 -0.0224450, -0.0375346, 0.1719109, 0.2308200, -0.1857073, 00019300 7 -0.0995993, 0.0085389, 138.45727/ 00019400 DATA Y24/ -0.1899584, 8.6911949, -7.7038102, 17.8842992, 00019500 1 1.8958812, -26.6646610, 0.8565066, -0.0005621, -0.0008909, 00019600 2 0.0850158, 0.0034124, -0.1292738, 0.0426631, 0.0168735, 00019700 3 -0.1717200, 0.0842524, 0.0193852, -0.0207373, 0.1633104, 00019800 4 0.0636077, -0.5315965, -0.4433265, -0.0009782, 0.2091911, 00019900 5 0.1755244, 0.0419906, 0.3086234, -0.0357209, 0.0119171, 00020000 6 -0.1367056, -0.0408844, 0.5093530, 0.8909345, -0.5621746, 00020100 7 -0.3903772, 0.0554313, 408.02599/ 00020200 DATA Y36/ -1.2791723, 18.5437755, -21.4965205, 15.7440568, 00020300 1 13.7586086, -56.0136527, -1.0273326, -0.0010307, -0.0173412, 00020400 2 -0.0069898, 0.0192933, -0.1414892, 0.0882439, 0.0368659, 00020500 3 -0.2220821, 0.1678605, 0.1462510, -0.0429246, -0.0773177, 00020600 4 0.1059194, -1.3342283, -0.8653569, 0.0101134, 0.3178639, 00020700 5 0.4078366, -0.0984645, 0.7358741, 0.0350543, 0.0221573, 00020800 6 0.2828421, -0.1563257, 1.0009459, 1.6636230, -1.0310655, 00020900 7 -0.6516668, 0.1635486,1203.12003/ 00021000 DATA Y48/ -2.2503651, 29.2124117, -40.3642497, 17.0779631, 00021100 1 17.2671773,-104.0852329, 12.0955831, -0.0017919, -0.0235381, 00021200 2 -0.0449264, 0.0317965, -0.2155600, 0.1666921, 0.0817288, 00021300 3 0.2846074, -0.0195034, 0.2448353, -0.0474278, -0.1532889, 00021400 4 0.1664857, -1.9062156, -1.2207714, 0.0097954, -0.1064522, 00021500 5 1.0404667, -0.2380823, 0.9551006, -0.0139472, 0.0130756, 00021600 6 0.4827187, -0.3369744, 0.9455972, 2.3926721, -0.9962841, 00021700 7 -0.9012016, 0.2849380,2280.38586/ 00021800 DATA Y72/ -1.4432551, 69.0610138, -95.5025662, -27.2247875, 00021900 1 29.0697411,-193.8726068, 19.9328988, -0.0065750, -0.0171360, 00022000 2 -0.0367320, 0.0388394, -0.6790639, 0.4813834, 0.2157335, 00022100 3 0.8932160, 0.0837914, 0.4136060, -0.0491940, -0.3513719, 00022200 4 0.2171922, -2.6074776, -1.9936009, -0.0604859, -1.0243483, 00022300 5 2.4907242, -0.6472058, 1.1425050, -0.0513188, -0.0240031, 00022400 6 0.6859001, -0.3869234, 0.6265983, 3.8490617, -0.7979159, 00022500 7 -1.4598369, 0.3810998,4739.46017/ 00022600 DATA X12/ -0.6704965, 1.4162022, -4.6100138, 1.9871832, 00022700 1 17.5537836, -2.1569492, -5.3402337, 0.0012716, 0.0030864, 00022800 2 0.0278260, 0.0000683, -0.0343753, 0.0304263, 0.0099592, 00022900 3 0.0788021, -0.0810208, 0.1417678, 0.0012298, -0.0018823, 00023000 4 -0.0419311, 0.0747932, -0.0306750, -0.0050167, -0.0070392, 00023100 5 0.0516586, -0.1393882, 0.0512521, 0.0067553, -0.0037287, 00023200 6 -0.0017485, 0.0441335, -0.2081854, 0.1950879, 0.0235002, 00023300 7 -0.1346830, -0.0285769, 259.47152/ 00023400 DATA X24/ -3.2076529, 18.7032497, -51.1117663, 5.6067213, 00023500 1 41.0624529, -5.9989359, -10.5029546, 0.0062741, 0.0186705, 00023600 2 0.1565185, -0.0014309, -0.3151049, 0.3294738, 0.0497310, 00023700 3 0.4094322, -0.3283910, 0.2947786, 0.0020355, 0.0202198, 00023800 4 -0.1759863, 0.1977871, -0.0611235, -0.0238707, -0.0192411, 00023900 5 0.1737112, -0.2251423, 0.3112377, -0.0422888, -0.0167690, 00024000 6 0.0152779, 0.1156717, -0.8251600, 0.5527846, 0.0455937, 00024100 7 -0.3788840, -0.1737905,2398.43577/ 00024200 DATA X36/ -6.6781488, 45.4614176,-144.0815478, -5.8840358, 00024300 1 69.7781262, -2.2740308, -4.6481818, 0.0134484, 0.0379086, 00024400 2 0.3815790, -0.0039753, -0.7343225, 0.9044577, 0.1020808, 00024500 3 1.2687996, -0.5415504, 0.4282047, 0.0083583, 0.2549853, 00024600 4 -0.4604174, 0.0714267, -0.0236414, -0.0567410, -0.3394735, 00024700 5 0.3102145, -0.4093667, 0.5577365, -0.0197161, -0.0410260, 00024800 6 0.0190018, 0.1124278, -1.3487227, 0.5703272, -0.0312319, 00024900 7 -0.3382746, -0.4661488,6604.67254/ 00025000 DATA X48/ -11.2833695, 67.7041708,-213.4578700, 7.2101560, 00025100 1 103.3901233, -19.5321088, -14.6757722, 0.0229843, 0.0483794, 00025200 2 0.4193408, -0.0036961, -0.9820638, 1.3240829, 0.1520701, 00025300 3 2.3483309, -1.0601856, 0.4061403, 0.0143723, 0.9105408, 00025400 4 -0.9182075, 0.0862826, -0.1668057, -0.0868560, -0.8808472, 00025500 5 0.7276123, -0.3159147, 0.5817031, -0.0911473, -0.0663834, 00025600 6 -0.4230014, 0.3969854, -2.0183565, 0.7029859, 0.2263893, 00025700 7 -0.3186548, -0.7828428,9918.98936/ 00025800 DATA X72/ -20.0923662, 140.1359479,-364.9217391, 111.3688979, 00025900 1 174.4471782,-107.3250567, -43.3118878, 0.0429588, 0.0710944, 00026000 2 0.5375573, -0.0133502, -1.8051834, 2.2847824, 0.2595816, 00026100 3 4.8826019, -3.0362177, 0.2986331, 0.0258721, 2.1804674, 00026200 4 -1.8921960, 0.2580539, -0.5958524, -0.1663261, -2.3306786, 00026300 5 2.2924075, -0.7559446, 0.7681488, 0.0810918, -0.1449324, 00026400 6 -1.4833308, 1.2019937, -3.7551080, 1.0364360, 0.7572207, 00026500 7 -0.3288727, -1.4009940,16794.94253/ 00026600 C INITIALIZE PREDICTAND ARRAY WITH ZEROS 00026700 DO 105 I=1,10 00026800 GULF(I)=0. 00026900 105 CONTINUE 00027000 IF(WGULF.EQ.0.)RETURN 00027100 C COMPUTE PREDICTORS 00027200 P(1)=DN 00027300 P(2)=Y 00027400 P(3)=X 00027500 P(4)=V 00027600 P(5)=U 00027700 P(6)=V12 00027800 P(7)=U12 00027900 L=7 00028000 DO 110 I=1,7 00028100 K=I 00028200 DO 110 J=1,K 00028300 L=L+1 00028400 P(L)=P(I)*P(J) 00028500 110 CONTINUE 00028600 P(36)=W 00028700 P(37)=1. 00028800 C COMPUTE DISPLACEMENTS 00028900 DO 115 I=1,37 00029000 GULF(1)=GULF(1)+Y12(I)*P(I) 00029100 GULF(2)=GULF(2)-X12(I)*P(I) 00029200 GULF(3)=GULF(3)+Y24(I)*P(I) 00029300 GULF(4)=GULF(4)-X24(I)*P(I) 00029400 GULF(5)=GULF(5)+Y36(I)*P(I) 00029500 GULF(6)=GULF(6)-X36(I)*P(I) 00029600 GULF(7)=GULF(7)+Y48(I)*P(I) 00029700 GULF(8)=GULF(8)-X48(I)*P(I) 00029800 GULF(9)=GULF(9)+Y72(I)*P(I) 00029900 GULF(10)=GULF(10)-X72(I)*P(I) 00030000 115 CONTINUE 00030100 RETURN 00030200 END 00030300 C C C SUBROUTINE CLIPER(Y,X,DNOW,SNOW,DM12,SM12,WKTS,MO,KDA,DISP) 00000100 C 00000104 C Y AND X ARE CURRENT LAT AND LON OF STORM 00000105 C DNOW AND SNOW ARE CURRENT (ESTIMATED INSTANTANEOUS) DIRECTION (DEG) 00000110 C SPEED OF STORM (KNOTS) 00000115 C DM12 AND SM12 ARE DIRECTION AND SPEED OF STORM 12 HOURS EARLIER. THIS 00000120 C COULD BE AN AVERAGE BETWEEN -6 AND -18 HRS. 00000125 C WKTS IS STORM INTENSITY IN KNOTS 00000130 C MO AND KDA ARE INTEGER VALUES OF CURRENT MONTH AND DAY 00000135 C 00000140 C DISP RETURNS FORECAST DISPLACEMENTS IN NAUTICAL MILES WHERE... 00000145 C DISP(01) AND DISP(02) ARE 12 HR MERIDIONAL AND ZONAL DISPLACEMENTS 00000150 C DISP(03) AND DISP(04) ARE 24 HR " " " " 00000155 C DISP(05) AND DISP(06) ARE 36 HR " " " " 00000160 C DISP(07) AND DISP(08) ARE 48 HR " " " " 00000165 C DISP(09) AND DISP(10) ARE 60 HR " " " " 00000170 C DISP(11) AND DISP(12) ARE 72 HR " " " " 00000175 C 00000200 C THIS DATASET IS NOW NAMED' NWS.WD80.CJN.SOURCE1(PGM22) 00000300 C 00000400 DIMENSION DISP(12),CNS(14,6),CEW(8,6),ND(12),P(14) 00000500 C 00000600 C LIST CONSTANTS FOR MERIDIONAL DISPLACEMENTS. 00000700 C 00000800 DATA CNS/7.60553,13.59909,-2.575127,-.0001868914,.00460007, 00000900 1.0022623,-.001491833,-.0002678624,-.00006994195,.00004407501, 00001000 2-.0002049626,.00007781249,.1430621,-.00008156078,30.30846, 00001100 322.91538,-2.484599,.004968631,.009297729,.02511378,-.007839641, 00001200 4-.005977559,-.0003504201,.0001557468,-.0009956548,.0004778924, 00001300 5.3879478,-.000671019,67.69324,31.94291,-3.697592,.009672852, 00001400 6.009539232,.06322068,-.01332191,-.01610885,-.0007292257, 00001500 7.0002341562,-.002814067,.001145255,.8940798,-.002181595,120.27143,00001600 838.94701,-4.380877,.01323013,.02292699,.09532129,-.01664333, 00001700 9-.03200883,-.001216522,.000315372,-.005450743,.001867606,1.666658,00001800 1-.004353084,186.02612,44.48386,-4.72498,.01074,.03200,.13383, 00001900 2-.01607,-.04866,-.00172,.00036,-.00877,.00271,2.76818,-.00733, 00002000 3263.15653,48.41731,-4.456658,.01126704,.04297187,.16962, 00002100 4-.01748416,-.06485724,-.002215515,.0003599106,-.012677,.003690242,00002200 54.121246,-.01102184/ 00002300 C 00002400 C LIST CONSTANTS FOR ZONAL DISPLACEMENTS. 00002500 C 00002600 DATA CEW/-3.52591,13.69309,-2.637347,.8151257,.6867776, 00002700 1-.002168753,-.000596625,.1247267,-13.12388,23.30256,-3.215529, 00002800 23.584506,3.949364,-.007860247,-.006764091,.5135556,-28.48156, 00002900 332.37355,-5.342858,8.073875,9.321241,-.01318171,-.02040824, 00003000 41.044624,-44.13759,38.93667,-6.819777,14.10797,16.35476, 00003100 5-.01967039,-.03853289,1.698018,-55.80913,43.27097,-7.86100, 00003200 621.27143,24.07252,-.02254,-.05992,2.47757,-60.23074,46.26022, 00003300 7-8.8089,29.11625,32.91178,-.02181549,-.08553838,3.291178/ 00003400 C 00003500 DATA ND/0,31,59,90,120,151,181,212,243,273,304,334/ 00003600 C 00003700 C COMPUTE DAY NUMBER AND SUBTRACT OFF MEANS 00003800 C 00003900 DANBR=ND(MO)+KDA-248 00004000 C HOLD CONSTANT ALL DAY NBRS BEFORE JUNE 2 AND AFTER NOV 26 00004105 IF(DANBR.LT.-95.)DANBR=-95. 00004110 IF(DANBR.GT.82.)DANBR=82. 00004115 WMPH=(WKTS*1.15)-71. 00004120 ALAT=Y-24. 00004200 ALON=X-68. 00004300 C 00004400 C CONVERT PRESENT AND PAST MOTION TO U AND V COMPONENTS. 00004500 C 00004600 T=.0174533 00004700 UNOW=SIN(DNOW*T)*SNOW 00004800 VNOW=COS(DNOW*T)*SNOW 00004900 UM12=SIN(DM12*T)*SM12 00005000 VM12=COS(DM12*T)*SM12 00005100 C 00005200 C SET UP MERIDIONAL PREDICTORS AND COMPUTE MERIDIONAL DISPLACEMENTS. 00005300 C SOUTHWARD MOTION IS NEGATIVE. 00005400 C 00005500 P(1)=1.0 00005600 P(2)=VNOW 00005700 P(3)=VM12 00005800 P(4)=VNOW*VM12*VM12 00005900 P(5)=WMPH*VM12 00006000 P(6)=VNOW*WMPH 00006100 P(7)=VNOW*VNOW*VM12 00006200 P(8)=ALAT*ALAT*VNOW 00006300 P(9)=DANBR*DANBR*VM12 00006400 P(10)=VNOW*DANBR*DANBR 00006500 P(11)=ALAT*ALAT*DANBR 00006600 P(12)=WMPH*DANBR*VM12 00006700 P(13)=UNOW 00006800 P(14)=DANBR*DANBR 00006900 DO 15 I=1,6 00007000 ZZ=0. 00007100 DO 10 J=1,14 00007200 10 ZZ=ZZ+CNS(J,I)*P(J) 00007300 15 DISP(2*I-1)=ZZ 00007400 C 00007500 C SET UP ZONAL PREDICTORS AND COMPUTE ZONAL DISPLACEMENTS. 00007600 C WESTWARD MOTION IS NEGATIVE. 00007700 C 00007800 P(2)=UNOW 00007900 P(3)=UM12 00008000 P(4)=ALAT 00008100 P(5)=VNOW 00008200 P(6)=VNOW*VNOW*UM12 00008300 P(7)=ALAT*VNOW*UM12 00008400 P(8)=ALON 00008500 DO 25 I=1,6 00008600 ZZ=0. 00008700 DO 20 J=1,8 00008800 20 ZZ=ZZ+CEW(J,I)*P(J) 00008900 25 DISP(2*I)=ZZ 00009000 RETURN 00009100 END 00009200 C C C BLOCK DATA CLIPER_DATA 00009300 C 00009400 C THIS DATASET IS NOW NAMED' NWS.WD80.CJN.SOURCE1(PGM04) 00009500 C 00009600 C ALBION D. TAYLOR, MARCH 19, 1982 00009700 C THE HURRICANE GRID IS BASED ON AN OBLIQUE EQUIDISTANT CYLINDRICAL 00009800 C MAP PROJECTION ORIENTED ALONG THE TRACK OF THE HURRICANE. 00009900 C 00010000 C THE X (OR I) COORDINATE XI OF A POINT REPRESENTS THE DISTANCE 00010100 C FROM THAT POINT TO THE GREAT CIRCLE THROUGH THE HURRICANE, IN 00010200 C THE DIRECTION OF MOTION OF THE HURRICANE MOTION. POSITIVE VALUES 00010300 C REPRESENT DISTANCES TO THE RIGHT OF THE HURRICANE MOTION, NEGATIVE 00010400 C VALUES REPRESENT DISTANCES TO THE LEFT. 00010500 C THE Y (OR J) COORDINATE OF THE POINT REPRESENTS THE DISTANCE 00010600 C ALONG THE GREAT CIRCLE THROUGH THE HURRICANE TO THE PROJECTION 00010700 C OF THE POINT ONTO THAT CIRCLE. POSITIVE VALUES REPRESENT 00010800 C DISTANCE IN THE DIRECTION OF HURRICANE MOTION, NEGATIVE VALUES 00010900 C REPRESENT DISTANCE IN THE OPPOSITE DIRECTION. 00011000 C 00011100 C SCALE DISTANCES ARE STRICTLY UNIFORM IN THE I-DIRECTION ALWAYS. 00011200 C THE SAME SCALE HOLDS IN THE J-DIRECTION ONLY ALONG THE HURRICANE TRAC00011300 C ELSEWHERE, DISTANCES IN THE J-DIRECTION ARE EXAGERATED BY A FACTOR 00011400 C INVERSELY PROPORTIONAL TO THE COSINE OF THE ANGULAR DISTANCE FROM 00011500 C THE TRACK. THE SCALE IS CORRECT TO 1 PERCENT WITHIN A DISTANCE OF 00011600 C 480 NM OF THE STORM TRACK, 5 PERCENT WITHIN 1090 NM, AND 00011700 C 10 PERCENT WITHIN 1550 NM. 00011800 C 00011900 C BIAS VALUES ARE ADDED TO THE XI AND YJ COORDINATES FOR CONVENIENCE 00012000 C IN INDEXING. 00012100 C 00012200 C A PARTICULAR GRID IS SPECIFIED BY THE USER BY MEANS OF A CALL 00012300 C TO SUBROUTINE STHGPR (SET HURRICANE GRID PARAMETERS) 00012400 C WITH ARGUMENTS (XLATH,XLONH,BEAR,GRIDSZ,XIO,YJO) 00012500 C WHERE 00012600 C XLATH,XLONH = LATITUDE, LONGITUDE OF THE HURRICANE 00012700 C BEAR = BEARING OF THE HURRICANE MOTION 00012800 C GRIDSZ = SIZE OF GRID ELEMENTS IN NAUTICAL MILES 00012900 C XIO, YJO = OFFSETS IN I AND J COORDINATES (OR I AND J 00013000 C COORDINATES OF HURRICANE) 00013100 C AND WHERE 00013200 C LATITUDES, LONGITUDES AND BEARINGS ARE GIVEN IN DEGREES, 00013300 C POSITIVE VALUES ARE NORTH AND WEST, NEGATIVE SOUTH AND EAST, 00013400 C BEARINGS ARE GIVEN CLOCKWISE FROM NORTH. 00013500 C 00013600 C THE CALL TO STHGPR SHOULD BE MADE ONCE ONLY, AND BEFORE REFERENCE 00013700 C TO ANY CALL TO LL2XYH OR XY2LLH. IN DEFAULT, THE SYSTEM 00013800 C WILL ASSUME A STORM AT LAT,LONG=0.,0., BEARING DUE NORTH, 00013900 C WITH A GRIDSIZE OF 120 NAUTICAL MILES AND OFFSETS OF 0.,0. . 00014000 C 00014100 C TO CONVERT FROM GRID COORDINATES XI AND YJ, USE A CALL TO 00014200 C CALL XY2LLH(XI,YJ,XLAT,XLONG) 00014300 C THE SUBROUTINE WILL RETURN THE LATITUDE AND LONGITUDE CORRESPONDING 00014400 C TO THE GIVEN VALUES OF XI AND YJ. 00014500 C 00014600 C TO CONVERT FROM LATITUDE AND LONGITUDE TO GRID COORDINATES, USE 00014700 C CALL LL2XYH(XLAT,XLONG,XI,YJ) 00014800 C THE SUBROUTINE WILL RETURN THE I-COORDINATE XI AND Y-COORDINATE 00014900 C YJ CORRESPONDING TO THE GIVEN VALUES OF LATITUDE XLAT AND 00015000 C LONGITUDE XLONG. 00015100 COMMON /HGRPRM/ A(3,3),RADPDG,RRTHNM,DGRIDH,HGRIDX,HGRIDY 00015200 DATA A /0.,-1.,0., 1.,0.,0., 0.,0.,1./ 00015300 DATA RADPDG/1.745 3293 E-2/,RRTHNM /3 440.17/ 00015400 DATA DGRIDH/120./ 00015500 DATA HGRIDX,HGRIDY/0.,0./ 00015600 END 00015700 C C C SUBROUTINE STHGPR(XLATH,XXXXX,BEAR,GRIDSZ,XI0,YJ0) 00015800 C ALBION D. TAYLOR, MARCH 19, 1982 00015900 COMMON /HGRPRM/ A(3,3),RADPDG,RRTHNM,DGRIDH,HGRIDX,HGRIDY 00016000 C MAKE CERTAIN THAT INCOMING LONGITUDES CONFORM TO PROGRAM CONVENTION 00016100 XLONH=XXXXX 00016200 IF(XLONH.LT.0.0.AND.XLONH.GE.-180.0)GOTO 10 00016300 IF(XLONH.GT.180.0)XLONH=XLONH-360. 00016400 IF(XLONH.LT.-180.0)XLONH=XLONH+360. 00016500 10 CONTINUE 00016600 CLAT=COS(RADPDG*XLATH) 00016700 SLAT=SIN(RADPDG*XLATH) 00016800 SLON=SIN(RADPDG*XLONH) 00016900 CLON=COS(RADPDG*XLONH) 00017000 SBEAR=SIN(RADPDG*BEAR) 00017100 CBEAR=COS(RADPDG*BEAR) 00017200 A(1,1)= CLAT*SLON 00017300 A(1,2)= CLAT*CLON 00017400 A(1,3)= SLAT 00017500 A(2,1)= - CLON*CBEAR + SLAT*SLON*SBEAR 00017600 A(2,2)= SLON*CBEAR + SLAT*CLON*SBEAR 00017700 A(2,3)= - CLAT* SBEAR 00017800 A(3,1)= - CLON*SBEAR - SLAT*SLON*CBEAR 00017900 A(3,2)= SLON*SBEAR - SLAT*CLON*CBEAR 00018000 A(3,3)= CLAT* CBEAR 00018100 DGRIDH=GRIDSZ 00018200 HGRIDX=XI0 00018300 HGRIDY=YJ0 00018400 RETURN 00018500 END 00018600 C C C SUBROUTINE LL2XYH(XLAT,XXXXX,XI,YJ) 00018700 C ALBION D. TAYLOR, MARCH 19, 1982 00018800 COMMON /HGRPRM/ A(3,3),RADPDG,RRTHNM,DGRIDH,HGRIDX,HGRIDY 00018900 DIMENSION ZETA(3),ETA(3) 00019000 XLONG=XXXXX 00019100 IF(XLONG.LT.0.0.AND.XLONG.GE.-180.0)GOTO 10 00019200 IF(XLONG.GT.180.0)XLONG=XLONG-360. 00019300 IF(XLONG.LT.-180.0)XLONG=XLONG+360. 00019400 10 CONTINUE 00019500 CLAT=COS(RADPDG*XLAT) 00019600 SLAT=SIN(RADPDG*XLAT) 00019700 SLON=SIN(RADPDG*XLONG) 00019800 CLON=COS(RADPDG*XLONG) 00019900 ZETA(1)=CLAT*SLON 00020000 ZETA(2)=CLAT*CLON 00020100 ZETA(3)=SLAT 00020200 DO 20 I=1,3 00020300 ETA(I)=0. 00020400 DO 20 J=1,3 00020500 ETA(I)=ETA(I) + A(I,J)*ZETA(J) 00020600 20 CONTINUE 00020700 R=SQRT(ETA(1)*ETA(1) + ETA(3)*ETA(3)) 00020800 XI=HGRIDX+RRTHNM*ATAN2(ETA(2),R)/DGRIDH 00020900 IF(R.LE.0.) GO TO 40 00021000 YJ=HGRIDY+RRTHNM*ATAN2(ETA(3),ETA(1))/DGRIDH 00021100 RETURN 00021200 40 YJ=0. 00021300 RETURN 00021400 END 00021500 C C C SUBROUTINE XY2LLH(XI,YJ,XLAT,XLONG) 00021600 C ALBION D. TAYLOR, MARCH 19, 1982 00021700 COMMON /HGRPRM/ A(3,3),RADPDG,RRTHNM,DGRIDH,HGRIDX,HGRIDY 00021800 DIMENSION ZETA(3),ETA(3) 00021900 CXI=COS(DGRIDH*(XI-HGRIDX)/RRTHNM) 00022000 SXI=SIN(DGRIDH*(XI-HGRIDX)/RRTHNM) 00022100 SYJ=SIN(DGRIDH*(YJ-HGRIDY)/RRTHNM) 00022200 CYJ=COS(DGRIDH*(YJ-HGRIDY)/RRTHNM) 00022300 ETA(1)=CXI*CYJ 00022400 ETA(2)=SXI 00022500 ETA(3)=CXI*SYJ 00022600 DO 20 I=1,3 00022700 ZETA(I)=0. 00022800 DO 20 J=1,3 00022900 ZETA(I)=ZETA(I) + A(J,I)*ETA(J) 00023000 20 CONTINUE 00023100 R=SQRT(ZETA(1)*ZETA(1) + ZETA(2)*ZETA(2)) 00023200 XLAT=ATAN2(ZETA(3),R)/RADPDG 00023300 IF(R.LE.0.) GO TO 40 00023400 XLONG=ATAN2(ZETA(1),ZETA(2))/RADPDG 00023500 RETURN 00023600 40 XLONG=0. 00023700 RETURN 00023800 END 00023900 C C C SUBROUTINE LL2DB(XLATO,XXXX1,XLATT,XXXX2,DIST,BEAR) 00029000 C ALBION D. TAYLOR MARCH 18, 1981 00029100 DATA RRTHNM/3 440.17/,RADPDG/1.745 3293 E-2/ 00029200 C RRTHNM=RADIUS OF EARTH IN NAUT. MILES, RADPDG==OF RADIANS 00029300 C PER DEGREE 00029400 C*---------------------------------------------------------------------*00029500 C* GIVEN AN ORIGIN AT LATITUDE, LONGITUDE=XLATO,XLONO, WILL LOCATE *00029600 C* A TARGET POINT AT LATITUDE, LONGITUDE = XLATT, XLONT. RETURNS *00029700 C* DISTANCE DIST IN NAUTICAL MILES, AND BEARING BEAR (DEGREES CLOCKWISE*00029800 C* FROM NORTH). *00029900 C* *00030000 C* ALL LATITUDES ARE IN DEGREES, NORTH POSITIVE AND SOUTH NEGATIVE. *00030100 C* ALL LONGITUDES ARE IN DEGREES, WEST POSITIVE AND EAST NEGATIVE. *00030200 C* *00030300 C* NOTE-- WHEN ORIGIN IS AT NORTH OR SOUTH POLE, BEARING IS NO LONGER *00030400 C* MEASURED FROM NORTH. INSTEAD, BEARING IS MEASURED CLOCKWISE *00030500 C* FROM THE LONGITUDE OPPOSITE THAT SPECIFIED IN XLONO. *00030600 C* EXAMPLE-- IF XLATO=90., XLONO=80., THE OPPOSITE LONGITUDE IS -100. *00030700 C* (100 EAST), AND A TARGET AT BEARING 30. WILL LIE ON THE -70. *00030800 C* (70 EAST) MERIDIAN *00030900 C*---------------------------------------------------------------------*00031000 XLONO=XXXX1 00031100 IF(XLONO.LT.0.0.AND.XLONO.GE.-180.0)GOTO 10 00031200 IF(XLONO.GT.180.0)XLONO=XLONO-360. 00031300 IF(XLONO.LT.-180.0)XLONO=XLONO+360. 00031400 10 CONTINUE 00031500 XLONT=XXXX2 00031600 IF(XLONT.LT.0.0.AND.XLONT.GE.-180.0)GOTO 15 00031700 IF(XLONT.GT.180.0)XLONT=XLONT-360. 00031800 IF(XLONT.LT.-180.0)XLONT=XLONT+360. 00031900 15 CONTINUE 00032000 CLATO=COS(RADPDG*XLATO) 00032100 SLATO=SIN(RADPDG*XLATO) 00032200 CLATT=COS(RADPDG*XLATT) 00032300 SLATT=SIN(RADPDG*XLATT) 00032400 CDLON=COS(RADPDG*(XLONT-XLONO)) 00032500 SDLON=SIN(RADPDG*(XLONT-XLONO)) 00032600 Z=SLATT*SLATO + CLATT*CLATO*CDLON 00032700 Y= - CLATT*SDLON 00032800 X=CLATO*SLATT - SLATO*CLATT*CDLON 00032900 R=SQRT(X*X+Y*Y) 00033000 DIST=RRTHNM*ATAN2(R,Z) 00033100 IF (R.LE.0.) GO TO 20 00033200 BEAR=ATAN2(-Y,-X)/RADPDG + 180. 00033300 RETURN 00033400 20 BEAR=0. 00033500 RETURN 00033600 END 00033700 C C C subroutine acerr(btlat,btlon,flat,flon,npts, + crosse,alonge,ierr) c c This routine calculates the along and cross track errors c of a track forecast. c c Input: btlat(npts) - best track latitude points (deg N) c btlon(npts) - best track longitude points (deg E positive, c deg W negative) c flat(npts) - forecast latitude points (deg N) c flon(npts) - forecast longitude points (deg E) c npts - The number of lat/lon points (times) c c Output: crosse(npts)- The cross track component of the error (km) c alonge(npts)- The along track component of the error (km) c ierr - Error flag c =0 for normal return c >0 for error c c Notes: The btlat, btlon, flat, and flon arrays can have missing c values (use -999. for missing). The missing values c are replaced by linearly interpolated values. Valid c lat/lons must be available for at least two time periods. c c It is assumed that btlat,btlon and flat,flon are in c arrays with equally spaced times. For example, btlat(1) c is at t=0, btlat(2) is at t=12 hr, btlat(3) is at t=24 hr c etc. The time interval does not need to be 12 hr. c c The along and cross track errors will be calculated for c up to the last time that a valid btlat,btlon,flat,flon c are all available. c c The along track error is positive if it is in the same c direction as the best track motion. c c The cross track error is positive if it is to the right c of the best track motion. c c The motion vector for error at time=n is calculated using c the positions btlat(n-1),bton(n-1) and c btlat(n),btlon(n), except when n=1. c If the motion vector has zero magnitude at a particular time, c the motion vector from the previously available time c is used instead. c c Passed variables dimension btlat(npts),btlon(npts) dimension flat(npts),flon(npts) dimension alonge(npts),crosse(npts) c c Local variables parameter (mxp=100) dimension blat(mxp),blon(mxp),plat(mxp),plon(mxp) dimension head(mxp) c c Set debug flag (idbug=0 for no debug writes) idbug=0 lulog=6 c c Specify value for missing lat/lons rmiss=-999.0 c c Check working array size if (npts .gt. mxp) then ierr=1 return endif c c Copy best track and forecast lat/lon to temporary arrays c and initialize errors to zero do k=1,npts blat(k) = btlat(k) blon(k) = btlon(k) plat(k) = flat(k) plon(k) = flon(k) c crosse(k) = 0.0 alonge(k) = 0.0 enddo c c Find the first and last point with a valid lat/lon nfirst=0 nlast = 0 nsum = 0 do k=1,npts if (blat(k) .gt. rmiss .and. + blon(k) .gt. rmiss .and. + plat(k) .gt. rmiss .and. + plon(k) .gt. rmiss ) then c nlast=k nsum=nsum+1 c if (nfirst .eq. 0) nfirst=k endif enddo c c Check to make sure at least 2 valid points are available if (nsum .lt. 2) then ierr=2 return endif c if (nlast .gt. nfirst+1) then c Check for missing lat/lons and fill them in c using linear interpolation c do 10 k=nfirst+1,nlast-1 if (blat(k) .le. rmiss .or. blon(k) .le. rmiss) then c A best track point is missing. Fill in with interpolated value. c c Find first good blat before current point km = 0 do kk=k-1,nfirst,-1 if (blat(kk) .gt. rmiss) then km = kk go to 1000 endif enddo 1000 continue c c Find first good blat after current point kp = 0 do kk=k+1,nlast if (blat(kk) .gt. rmiss) then kp = kk go to 1001 endif enddo 1001 continue c if (km .eq. 0 .or. kp .eq. 0) go to 910 c rk = float(k) rm = float(km) rp = float(kp) c c Perform interpolation wm = (rp-rk)/(rp-rm) wp = (rk-rm)/(rp-rm) blat(k) = wm*blat(km) + wp*blat(kp) c c Find first good blon before current point km = 0 do kk=k-1,nfirst,-1 if (blon(kk) .gt. rmiss) then km = kk go to 1002 endif enddo 1002 continue c c Find first good blon after current point kp = 0 do kk=k+1,nlast if (blon(kk) .gt. rmiss) then kp = kk go to 1003 endif enddo 1003 continue c if (km .eq. 0 .or. kp .eq. 0) go to 910 c rk = float(k) rm = float(km) rp = float(kp) c c Perform interpolation wm = (rp-rk)/(rp-rm) wp = (rk-rm)/(rp-rm) blon(k) = wm*blon(km) + wp*blon(kp) c endif c if (plat(k) .le. rmiss .or. plon(k) .le. rmiss) then c A forecast track point is missing. Fill in with interpolated value. c c Find first good plat before current point km = 0 do kk=k-1,nfirst,-1 if (plat(kk) .gt. rmiss) then km = kk go to 2000 endif enddo 2000 continue c c Find first good plat after current point kp = 0 do kk=k+1,nlast if (plat(kk) .gt. rmiss) then kp = kk go to 2001 endif enddo 2001 continue c if (km .eq. 0 .or. kp .eq. 0) go to 910 c rk = float(k) rm = float(km) rp = float(kp) c c Perform interpolation wm = (rp-rk)/(rp-rm) wp = (rk-rm)/(rp-rm) plat(k) = wm*plat(km) + wp*plat(kp) c c Find first good plon before current point km = 0 do kk=k-1,nfirst,-1 if (plon(kk) .gt. rmiss) then km = kk go to 2002 endif enddo 2002 continue c c Find first good plon after current point kp = 0 do kk=k+1,nlast if (plon(kk) .gt. rmiss) then kp = kk go to 2003 endif enddo 2003 continue c if (km .eq. 0 .or. kp .eq. 0) go to 910 c rk = float(k) rm = float(km) rp = float(kp) c c Perform interpolation wm = (rp-rk)/(rp-rm) wp = (rk-rm)/(rp-rm) plon(k) = wm*plon(km) + wp*plon(kp) endif c 10 continue endif c c Calculate the storm heading using the best track call sthcal(blat,blon,mxp,nfirst,nlast,head) c c Calculate the cross and along track errors dtr = 3.14159265/180.0 do n=nfirst,nlast rlat2 = plat(n) rlon2 = plon(n) rlat1 = blat(n) rlon1 = blon(n) c c Calculate eastward,northward components of the error call distk(rlon1,rlat1,rlon2,rlat2,dx,dy,rad) c c Rotate error into cross and along track components crosse(n) = dx*sin(dtr*head(n)) - dy*cos(dtr*head(n)) alonge(n) = dy*sin(dtr*head(n)) + dx*cos(dtr*head(n)) enddo c if (idbug .ne. 0) then write(lulog,300) nfirst,nlast,nsum 300 format(/,'nfirst,nlast,nsum: ',i3,1x,i3,1x,i3,/) c write(lulog,310) 310 format(' i time btlat btlon flat flon', + ' blat blon plat plon', + ' head crosse alonge') c do i=1,npts itime = 12*(i-1) write(lulog,320) i,itime,btlat(i),btlon(i),flat(i),flon(i), + blat(i),blon(i),plat(i),plon(i), + head(i),crosse(i),alonge(i) 320 format( i2,1x,i4,2(1x,f7.2,1x,f8.2,2x,f7.2,1x,f8.2), + f6.1,1x,f6.1,1x,f6.1) enddo endif c ierr=0 return c 910 continue ierr=3 return c end subroutine sthcal(blat,blon,mxp,nfirst,nlast,head) c This routine calculates the storm heading measured CCW c in degrees CCW relative to the +x axis (east). It is assumed c that blat and blon are available for all points from n=nfirst c to n=nlast. c dimension blat(mxp),blon(mxp),head(mxp) c do n=nfirst+1,nlast rlat2 = blat(n ) rlat1 = blat(n-1) rlon2 = blon(n ) rlon1 = blon(n-1) c call distk(rlon1,rlat1,rlon2,rlat2,dx,dy,rad) c if (rad .le. 0.0) then head(n) = -999. else call ctor(dx,dy,rad,head(n)) endif enddo head(nfirst) = head(nfirst+1) c c Check to see how many headings are missing nmiss = 0 ntot = 1 + nlast-nfirst do n=nfirst,nlast if (head(n) .le. -999.) nmiss=nmiss+1 enddo c if (nmiss .eq. 0) then c None are missing return elseif (nmiss .eq. ntot) then c The storm is stationary, set all headings to north do n=nfirst,nlast head(n) = 90.0 enddo else c Some heading missing, find nearest values c do n=nfirst+1,nlast if (head(n) .le. -999.) then c Search backwards for first available value do k=n-1,nfirst,-1 if (head(k) .gt. -999.) then head(n) = head(k) go to 1000 endif enddo 1000 continue endif enddo c do n=nfirst,nlast-1 if (head(n) .le. -999.) then c Search forward for first available value do k=n+1,nlast if (head(k) .gt. -999.) then head(n) = head(k) go to 1001 endif enddo 1001 continue endif enddo c endif c return end subroutine ctor(x,y,r,theta) c This routine converts from Cartesion coordinates c to radial coordinates, where theta is in c degrees measured counter-clockwise from c the +x-axis. c r = sqrt(x*x + y*y) c if (r .le. 0.0) then theta = 0.0 return endif c rtd = 57.296 theta = rtd*acos(x/r) if (y .lt. 0.0) theta = 360.0 - theta c return end subroutine rtoc(r,theta,x,y) c This routine converts from radial coordinates c to Cartesian coordinates, where theta is in c degrees measured counter-clockwise from c the +x-axis. c rtd = 57.296 x = r*cos(theta/rtd) y = r*sin(theta/rtd) c return end subroutine distk(rlon1,rlat1,rlon2,rlat2,dx,dy,rad) c This routine calculates the distance in km (rad) between the c points (rlon1,rlat1) and (rlon2,rlat2) using an approximate c formula. The lon and lat are in deg E and N. The east and c north components of the distance (dx,dy) are also calculated. c dtk = 111.1 dtr = 0.0174533 c cfac = cos(0.5*dtr*(rlat1+rlat2)) c dx = dtk*(rlon2-rlon1)*cfac dy = dtk*(rlat2-rlat1) rad = sqrt(dx*dx + dy*dy) c return end subroutine distki(rlon1,rlat1,dx,dy,rlon2,rlat2) c This routine performs the inverse of routine distk. c The latitude and longitude (rlon2,rlat2) of the point a distance c dx and dy (km) from the point (rlon1,rlat1) is calculated c using an approximate formula. The lon and lat are in deg E c and deg N. c dtk = 111.1 dtr = 0.0174533 c if (rlat1 .eq. 90.0) then rlat2 = rlat1 rlon2 = rlon1 return endif c rlat2 = rlat1 + dy/dtk cfac = cos(0.5*dtr*(rlat1+rlat2)) rlon2 = rlon1 + dx/(dtk*cfac) c return end c c c SUBROUTINE ALAND ( CLON, CLAT, DIST ) C c Input: CLON - Longitude (deg W negative) c CLAT - Latitude (deg N positive) c c Output: DIST - distance (km) to nearest coastline. DIST is positive if the c point CLON,CLAT is over water and negative if it is over land. c c This version is valid for tropical cyclones in the Atlantic, c east, and central North Pacific. c c The represenation of the coastline and islands is in the file c aland.dat c C SUBROUTINE LAND COMPUTES THE DISTANCE (KM) FROM, AND NORMAL BEARING C TO, THE NEAREST COASTLINE TO A CYCLONE CENTRAL AT LATITUDE 'CLAT C AND LONGITUDE 'CLON'. COASTLINES ARE STORED IN THE COMMON BLOCK C /COAST/ AND FOR UP TO 20 ISLANDS (NUMBER NISL) OF UP TO 30 COASTAL C LINE SEGMENTS. THE INTIIAL POINTS OF EACH SEGMENT ARE STORED C IN COUNTERCLOCKWISE ORDER AROUND THE COAST. THE LAST INDEX IN C 'XISL' OR 'XCON' IS 1 FOR LONGITUDE AND 2 FOR LATITUDE. C C THE DISTANCE FROM THE CYCLONE TO THE NEAREST POINT ON EACH COASTAL C SEGMENT IS CALCULATED, AND THE MINIMUM ABSOLUTE VALUE IS ACCEPTED C AS THE COASTAL DISTANCE FOR THAT PARTICULAR LAND MASS. NEGATIVE C VALUES ARE INLAND. THE MINIMUM ABSOLUTE VALUE OF ALL COASTAL C DISTANCES FOR THE CYCLONE IS RETURNED AS THE COASTAL DISTANCE FOR C THIS PARTICULAR CYCLONE. C C SEVERAL MODIFICATIONS WERE MADE TO THE SUBROUTINE LAND C TO FACILITATE FUTURE CHANGES TO THE DATA FILE C USED TO DETERMINE A TROPICAL CYCLONE'S DISTANCE FROM LAND. C C THE VARIABLES NCONOB AND NISLOB SPECIFY THE LIMITS C FOR THE NUMBER OF POINTS WHICH DEFINE A CONTINENT AND ISLAND C RESPECTIVELY. THE VARIABLE NCOAST IS THE LIMIT FOR THE NUMBER C OF ISLANDS. PROVIDED THESE NUMBERS ARE NOT EXCEEDED ANY CHANGES C TO THE DATA FILE LAND.DAT SHOULD BE TRANSPARENT TO THE PROGRAM. C 5/13/92 J.KAPLAN C PARAMETER (NCOAST=30) PARAMETER (NCONOB=400) PARAMETER (NISLOB=100) C C REAL*8 CISL(NCOAST) REAL*4 XISL(NCOAST,NISLOB,2), DI(NCOAST), BI(NCOAST), 1 XCON(NCONOB,2), DWRC(NCONOB), BWRC(NCONOB), 2 DWRK(NISLOB), BWRK(NISLOB) INTEGER*4 NPT(NCOAST), LT(NCOAST) CHARACTER CISL(NCOAST)*8 LOGICAL*1 FLAG1, LPR C DATA FLAG1/.FALSE./ DATA LPR /.FALSE./ DATA IOPTN /7/ DATA LUIN /55/ save flag1,xisl,xcon,ncon,nisl,npt,lt,cisl C IF( FLAG1 ) GO TO 409 C C T H I S I S C O A S L I N E I N P U T ********** C C ON VAX c OPEN(LUIN,FILE='D11:[HRD.DEMARIA.ATLC]ALAND.DAT', c + FORM='FORMATTED',STATUS='OLD',READONLY) C C ON HP WORKSTATION c OPEN(LUIN,FILE='/home/demaria/land/aland.dat', c + FORM='FORMATTED',STATUS='OLD') C C On Linux OPEN(LUIN,FILE='support_files/aland.dat', + FORM='FORMATTED',STATUS='OLD') c C ON TYPE42 C OPEN(LUIN,FILE='ALAND.DAT', C + FORM='FORMATTED',STATUS='OLD',READONLY) C 405 CONTINUE C C READ CONTINENT COASTAL POINTS C READ TOTAL NUMBER OF CONTINENT POINTS C READ(LUIN,209,END=995) NCON, CISL(1), LT(1) C IF (NCON.GT.NCONOB) THEN WRITE(6,*)'NUMBER OF CONTINENT POINTS EXCEEDS PROGRAM LIMIT 1 OF ',NCONOB STOP ENDIF C DO 105 I = 1,NCON READ(LUIN,207,END=995) XCON(I,1), XCON(I,2) 207 FORMAT(F7.1,F6.1) 105 CONTINUE C C COPY INITIAL POINT INTO NCON+1 ARRAY ADDRESS (WILL BE NEEDED C TO COMPUTE DISTANCE AND BEARING FROM LAST POINT IN CLOSED LOOP C TO 'NEXT' POINT (WHICH IS THE FIRST POINT ENTERED). XCON(NCON+1,1) = XCON(1,1) XCON(NCON+1,2) = XCON(1,2) C C OUTPUT THE COASTAL POINTS FOR THE CONTINENT IF( LPR ) WRITE(6,305) CISL(1), NCON 305 FORMAT(/,5X,'COASTLINE OF ',A8,/,5X,'IS DEFINED BY THE FOLLOWING ' 1 ,I3,' POINTS') C IF( LPR )WRITE(6,307) ( I, XCON(I,1), XCON(I,2), I=1,NCON ) 307 FORMAT(6(1X,I3,' (',F6.1,F5.1,')')) C C READ ISLAND NAMES AND COASTAL POINTS C NISL = 0 200 NISL = NISL + 1 N= NISL + 1 C READ(LUIN,209,END=407) NPT(N), CISL(N), LT(N) 209 FORMAT(I3,1X,A8,1X,I1) C NPTS = NPT(N) C DO 109 I = 1,NPTS READ(LUIN,207,END=995) XISL(N,I,1), XISL(N,I,2) 109 CONTINUE C C COPY INITIAL POINT INTO NPTS+1 ARRAY SPACE (WILL BE NEEDED TO C COMPUTE DISTANCE AND BEARING FROM LAST POINT IN CLOSED LOOP TO C 'NEXT' POINT (WHICH IS THE FIRST POINT ENTERED). C XISL(N,NPTS+1,1) = XISL(N,1,1) XISL(N,NPTS+1,2) = XISL(N,1,2) C C OUTPUT THE NAME AND COASTLINE POINTS FOR THIS ISLAND C IF( LPR ) WRITE(6,305) CISL(N), NPT(N) NPTS = NPT(N) IF( LPR ) WRITE(6,307) (I, XISL(N,I,1), XISL(N,I,2), I=1,NPTS ) GO TO 200 C C COME HERE IF THERE ARE NO MORE ISLANDS TO ENTER...EOF ENCOUNTE C ON READ(LUIN,205) AT THE TOP OF THIS INPUT SEGMENT C 407 NISL = NISL - 1 FLAG1 = .TRUE. CLOSE(LUIN) C C T H I S I S L A N D N A V I G A T I O N ********** C 409 CONTINUE C C PROCESS CONTINENT C C COMPUTE ANGLE OF PREVIOUS SEGMENT IF NEEDED FOR BAY OR PENINSULA C COASTLINE DETERMINATION FOR SIGN OF DISTANCE IN LSUB1 CALL LSUB2(XCON(1,1),XCON(NCON,1),XCON(1,2),XCON(NCON,2),DX0,DY0, 1 AL0) C ANGLE OF PREVIOUS SEGMENT IS DIRECTED WITH ORIGIN AT BEGINNING OF C CURRENT SEGMENT AL0 = ANGL(AL0+180.) C DO 113 I = 1,NCON C COMPUTE DISTANCE FROM BEGINNING POINT TO END POINT OF SEGMENT C ( COMPONENTS (DX,DY) AND FROM BEGINNING POINT TO CYCLONE C ( COMPONENTS (DXC,DYC) ). C CALL LSUB2(XCON(I+1,1),XCON(I,1),XCON(I+1,2),XCON(I,2), DX, DY, 1 AL) CALL LSUB2( CLON,XCON(I,1), CLAT,XCON(I,2),DXC,DYC, 1 AC) C C CALL DISTANCE, ANGLE CALCULATION SHELL C CALL LSUB1 ( DX, DY, DXC, DYC, AL0,AL,AC, A, DRA, D ) C DWRC(I) = D BWRC(I) = A AL0 = ANGL(AL+180.) 113 CONTINUE C C COMPUTE MINIMUM DISTANCE FROM CYCLONE TO CONTINENT DM = 1000. DO 115 I = 1,NCON IF( ABS(DWRC(I)).LT.DM ) IM=I DM = ABS(DWRC(IM)) 115 CONTINUE C C ASSIGN CONTINENT DISTANCE TO FIRST ADDRESS IN WORKING ARRAY DI, BI DI(1) = DWRC(IM) BI(1) = BWRC(IM) C C C OUTER LOOP FOR NUMBER OF ISLANDS NISL C DO 117 N = 2,NISL+1 NPTS = NPT(N) C C LOOP THROUGH NPT(N) COASTAL SEGMENTS OF NTH ISLAND. CALL LSUB2(XISL(N,1,1),XISL(N,NPTS,1),XISL(N,1,2), 1 XISL(N,NPTS,2),DX0,DY0,AL0) AL0 = ANGL(AL0+180.) C DO 119 I = 1,NPTS C COMPUTE DISTANCE FROM BEGINNING POINT TO END POINT OF SEGMENT C (DX, DY) AND BEGINNING POINT TO CYCLONE (DXC, DYC) C CALL LSUB2(XISL(N,I+1,1),XISL(N,I,1),XISL(N,I+1,2), 1 XISL(N,I,2), DX, DY, AL) CALL LSUB2(CLON,XISL(N,I,1),CLAT,XISL(N,I,2) 1 ,DXC,DYC, AC) C CALL LSUB1 ( DX, DY, DXC, DYC, AL0,AL,AC, A, DRA, D ) DWRK(I) = D BWRK(I) = A C AL0 = ANGL(AL+180.) 119 CONTINUE C DM = 1000. DO 121 I = 1,NPTS IF( ABS(DWRK(I)).LT.DM ) IM = I DM = ABS(DWRK(IM)) 121 CONTINUE C DI(N) = DWRK(IM) BI(N) = BWRK(IM) 117 CONTINUE C DMIN = 9999. DO 116 N=1,NISL+1 IF( ABS(DI(N)).GE.DMIN ) GO TO 116 IMN = N DMIN= ABS(DI(N)) 116 CONTINUE C DIST = DI(IMN)*111.12 BRG = BI(IMN) RETURN C C ERROR MESSAGES C 995 WRITE(6,3995) N, CISL(N) 3995 FORMAT(///,5X,'END OF FILE WHILE ATTEMPTING TO READ THE COAST POIN 1TS FOR',/,5X,'ISLAND N=',I2,' WITH NAME ',A8,/,5X,'PROBABLE CAUSE 2IS MISMATCHED NUMBER OF POINTS SPECIFIED FOR ISLAND COAST AND',/,5 3X,'ACTUAL NUMBER OF POINTS ON LIST.') C STOP END SUBROUTINE LSUB1 ( DX, DY, DXC, DYC, AL0,AL,AC, A, DRA, D ) DR = 180./3.141592 C C COMPUTE CYCLONE DISTANCE TO COASTAL SEGMENT ACL = ANGL(AC-AL) DL = SQRT(DX*DX + DY*DY) DC = SQRT(DXC*DXC + DYC*DYC) DNC = -DC*SIN(ACL/DR) DAC = DC*COS(ACL/DR) DRA = DAC/DL C C ASSIGN DISTANCE FROM CYCLONE TO COAST C IF DISTANCE RATIO IS IN RANGE 0-1, USE NORMAL DISTANCE C IF DISTANCE RANGE OUTSIDE ABOVE, USE DISTANCE FROM CYCLONE C TO INITIAL POINT OF SEGMENT, WITH SIGN DEPENDING ON THE ANGLE OF C THE COAST AT THAT POINT C C DETERMINE DISTANCE AND WHETHER OVER LAND OR WATER SGNA = 1. IF( ABS(ACL).GE.1.E-5 ) SGNA = ACL/ABS(ACL) AC0 = ANGL(AC-AL0) ALL0= ANGL(AL0-AL) C DFLAG = 0. IF( DNC.LT.0. ) DFLAG = 180. AFC = -90. - AC AFR = DFLAG- AL C IF( DRA.GT.1. ) GO TO 405 IF( DRA.LT.0. ) GO TO 407 C C DISTANCE IS ALONG NORMAL TO COAST D = DNC A = AFR GO TO 410 C C DISTANCE IS APPROXIMATED BY DISTANCE TO CYCLONE, BUT WILL BE C DEFINITELY LONGER THAN, AND THEREFORE SUPERSEDED BY, THE C DISTANCE FROM THE INITIAL POINT OF THE NEXT COASTAL SEGMENT 405 D = -DC*SGNA A = AFC GO TO 410 C C DISTANCE IS THAT FROM INITIAL POINT TO CYCLONE. POINT IS OVER C WATER IF BEARING OF VECTOR TO CYCLONE IS LESS THAN BEARING C OF PREVIOUS COASTAL SEGMENT, OR IF TO RIGHT OF CURRENT COASTAL C SEGMENT 407 D = -DC*SGNA A = AFC C C DISTANCE OFFSHORE/ONSHORE IS NOW SET UP RELATIVE TO CURRENT COASTAL C SEGMENT...NEGATIVE IS ONSHORE, OR TO THE LEFT. CORRECT DEPENDING C UPON ORIENTATION OF PREVIOUS COASTAL SEGMENT C IF( D.LE.0. ) GO TO 409 C CYCLONE IS OFFSHORE (TO RIGHT) IF( AC0.LE.0.AND.ALL0.LE.0. ) D = -D GO TO 410 C CYCLONE IS ONSHORE (TO LEFT) 409 IF( AC0.GT.0.AND.ALL0.GT.0 ) D = -D C C TRANSFORM BEARING FROM THE -180 TO +180 RANGE USED INTERNALLY C TO THE 0 TO 360 RANGE FOR DISPLAY PURPOSES. 410 IF( A.LT.0. ) A = A + 360. C RETURN END SUBROUTINE LSUB2( X2, X1, Y2, Y1, DX, DY, A ) DR = 180./3.141592 DY = Y2-Y1 DX = (X2-X1)*COS((Y2+Y1)/(2.*DR)) A = 0. DD = ABS(DX)+ABS(DY) IF( DD.LE.1.E-5 ) RETURN A = ATAN2(DY,DX)*DR RETURN END C REAL FUNCTION ANGL(A) ANGL = A IF( A.LE.-180.) ANGL = A + 360. IF( A.GT. 180.) ANGL = A - 360. RETURN END C C C subroutine decay_old(ftime,rlat,rlon,vmax,vmaxa,dt, * rcrad,dland,lulg) C C This routine adjusts a tropical cyclone intensity C forecast to account for decay over land. this version is C valid for the atlantic basin and was written by M. DeMaria C and J. Kaplan of the Hurricane Research Division, May 1994. C C Note: M. DeMaria says it's good for the EPAC and CPAC as well. C C Modified 6/22/18 JLF to change imax from 21 to 11 to match how the C routine was being called. Previous compilers allowed the arrays to C be shorter than 21 but not gfortran. C C This version was modified 4/10/97 (MDM) to include the C New England coefficients. The distance inland correction C is disabled in this version (idtlc=0). C C New version created 9/30/2004 that allows for decay proportional C to the fraction of the storm circulation over land. C (Set rcrad > 0.0 to activate this option). The logic of the code c was changed so accomodate this option. The old distance inland c correction was completely eliminated with this modification. C C ********** INPUT ********** C C ftime: the time in hours (for example, 0.,12.,24. ... 72.) C The times need to sequential, but the time interval C does not need to be even. C rlat: The storm latitude (deg n) at the times in array ftime C rlon: The storm longitude (deg w positive) at the times in C array ftime C vmax: The storm maximum wind (kt) at the times in array ftime. C Set vmax=0 for missing forecast times. C dt: Interval (hr) for linearly interpolating track C positions. C lulg: Unit number for write statements C C ********** OUTPUT ********** C C vmaxa: The storm maximum wind (kt) adjusted for decay over land C at the times in array ftime. C C dland: The distance (km) from the storm center (rlat,rlon) to C the nearest major land mass. dland is negative if the C point is storm center is inland. C C ********** METHOD ********* C C The simple exponential decay model developed by M. DeMaria C and J. Kaplan at HRD is used to decay the storm intensity for C the portions of the track over land. C C In this version, the decay rate is proportional to the fraction C of the storm circualtion over land. C C ********** PARAMETER SPECIFICATION ********** C C Specify the maximum number of time values. parameter (imax=11) C C Specify the time interval (hr) for linearly interpolating C the track positions. C data dt /1.00/ C C Set interp=1 to print out (to unit lulg) all intermediate C intensity calculations or else set interp=0 for no print data interp /0/ C C Specify decay model parameters C C Coefficients for east/gulf coast data rf1,a1,vb1,rclat1 /0.9,0.095,26.7,36.0/ C C Coefficients for New England data rf2,a2,vb2,rclat2 /0.9,0.183,29.6,40.0/ C C Specify radius of storm circulation (km) for fractional C decay option. Set rcrad to zero to eliminate this option. C c data rcrad / 110.0/ c data rcrad / 0.0/ c common /mparm/ alpha,vb,redfac C C ********** DIMENSION ARRAYS ********** C dimension ftime(imax),rlat(imax),rlon(imax) dimension vmax(imax),vmaxa(imax),dland(imax) C c Arrays for small time step parameter (imaxs=1000) dimension ftimes(imaxs),rlats(imaxs),rlons(imaxs) dimension vmaxs(imaxs),vmaxas(imaxs) dimension dlands(imaxs),flands(imaxs) c C ********** MODEL CODE ********* C C Write model message to log file if (interp .gt. 0) then write(lulg,810) rcrad 810 format(' Decay model with rcrad= ',f5.0,' km') endif C c Initialize vmaxa array to zero do i=1,imax vmaxa(i) = 0.0 enddo c C Find the number of valid forecast times itimet = 0 do 10 i=1,imax if (vmax(i) .lt. 0.5) go to 1000 itimet=i 10 continue C 1000 continue C There must be at least two valid forecast times if (itimet .lt. 2) return C C Check to make sure times are sequential itime=0 do 15 i=2,itimet if (ftime(i) .le. ftime(i-1)) go to 1100 itime=i 15 continue C 1100 continue if (itime .lt. 2) return c if (interp .gt. 2) then do i=1,itime write(6,887) ftime(i),rlat(i),rlon(i),vmax(i) enddo endif c c Calcuate the time values at the small time interval points ntimes = 1 + (ftime(itime)-ftime(1))/dt do i=1,ntimes ftimes(i) = ftime(1) + dt*float(i-1) enddo c c Interpolate the input lat,lon and max winds to the c small time interval c c ++Find vmax on small time grid iflag=1 lflag=0 xi = 0.0 c call xint(ftime,vmax,itime,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,ntimes call xint(ftime,vmax,itime,iflag,lflag, + ftimes(i),vmaxs(i),ierr) enddo c c ++Find lat on small time grid iflag=1 call xint(ftime,rlat,itime,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,ntimes call xint(ftime,rlat,itime,iflag,lflag, + ftimes(i),rlats(i),ierr) enddo c c ++Find lon on small time grid iflag=1 call xint(ftime,rlon,itime,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,ntimes call xint(ftime,rlon,itime,iflag,lflag, + ftimes(i),rlons(i),ierr) enddo c c Calcuate distance to land and fractional land at small time points do i=1,ntimes call aland(-rlons(i),rlats(i),dlands(i)) call fland_old(-rlons(i),rlats(i),rcrad,flands(i)) enddo c c Integrate the decay model over the small time points do i=1,ntimes if (rcrad .gt. 0.0) then call fland_old(-rlons(i),rlats(i),rcrad,flands(i)) else flands(i) = 1.0 endif enddo c vmaxas(1) = vmaxs(1) c do i=2,ntimes c At each step in this loop, the decay model is integrated c from t=ftimes(i-1) to t=ftimes(i) c c Calculate decay model parameters at current latitude rlatt = rlats(i-1) if (rlatt .ge. rclat2) then redfac = rf2 alpha = a2 vb = vb2 elseif (rlatt .le. rclat1) then redfac = rf1 alpha = a1 vb = vb1 else w1 = (rclat2-rlatt)/(rclat2-rclat1) w2 = (rlatt-rclat1)/(rclat2-rclat1) C redfac = w1*rf1 + w2*rf2 alpha = w1*a1 + w2*a2 vb = w1*vb1 + w2*vb2 endif C vmaxt1 = vmaxas(i-1) c if (dlands(i) .ge. 0.0) then c ++ This is an over-water point c c Check to see if storm just moved over water. c If so, adjust for land/ocean surface roughness differences if (dlands(i-1) .lt. 0.) then vmaxt1 = vmaxt1/redfac endif c vmaxt2 = vmaxt1 + (vmaxs(i)-vmaxs(i-1)) else c ++ This is an over-land point c c Check to see if storm just moved over land. c If so, adjust for ocean/land surface roughness differences if (dlands(i-1) .ge. 0.) then vmaxt1 = redfac*vmaxt1 endif c t = ftimes(i)-ftimes(i-1) fbar = 0.5*(flands(i)+flands(i-1)) vmaxt2 = vb + (vmaxt1-vb)* exp(-fbar*alpha*t) endif c vmaxas(i) = vmaxt2 enddo c if (interp .gt. 2) then do i=1,ntimes write(6,887) ftimes(i),vmaxs(i),vmaxas(i),rlats(i),rlons(i), + dlands(i),flands(i) 887 format(8(f6.1,1x)) enddo endif c c Interpolate decay vmaxas back to original forecast times iflag=1 c call xint(ftimes,vmaxas,ntimes,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,itime call xint(ftimes,vmaxas,ntimes,iflag,lflag, + ftime(i),vmaxa(i),ierr) enddo c c Interpolate dlands back to original forecast times iflag=1 c call xint(ftimes,dlands,ntimes,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,itime call xint(ftimes,dlands,ntimes,iflag,lflag, + ftime(i),dland(i),ierr) enddo c return end subroutine fland_old(slon,slat,rkm,fraction) c This routine calcuates the fraction of the circular area c centered at the point (slat,slon) that is over land. c c Input: rkm - radius of circle in km c slat - center latitude of the circle (deg N pos) c slon - center longitude of the circle (deg W neg) c c Output: fraction - the fraction of the circle over land c c Calculate the distance to nearest land at the circle center call aland(slon,slat,d00) c c Check for special cases if (rkm .le. 0.0) then fraction = 1.0 return endif c if (d00 .gt. rkm) then fraction = 0.0 return endif c if (d00 .lt. -rkm) then fraction = 1.0 return endif c c Perform area integration fraction = 0.0 dx = 25.0 if (dx .ge. rkm/4.0) dx = rkm/4.0 dy = dx c pi = 3.14159 dtr= pi/180.0 xfac = 111.1*cos(slat*dtr) yfac = 111.1 c n = ifix(rkm/dx) c ntotal = 0 nland = 0 do j=-n,n do i=-n,n x = float(i)*dx y = float(j)*dy r = sqrt(x*x + y*y) if (r .gt. rkm) go to 1000 c tlat = slat + x/xfac tlon = slon + y/yfac c call aland(tlon,tlat,tdtl) ntotal = ntotal+1 if (tdtl .le. 0.0) nland = nland+1 1000 continue c enddo enddo c fraction = float(nland)/float(ntotal) c return end subroutine xint(x,f,n,iflag,lflag,xi,fi,ierr) c This routine applies a quadratic interpolation procedure c to f(x) between x(1) and x(n). f(x) is assumed to be c represented by quadratic polynomials between the points c x(i). The polynomials are chosen so that they equal f(i) c at the points x(i), the first derviatives on either c side of the interior x(i) match at x(i), and the second c derivative of the approximated function integrated c over the domain is minimized. c c This version is for interpolating longitude c c Input: x(1),x(2) ... x(n) The x values (must be sequential) c f(1),f(2) ... f(n) The function values c n The number of x,f pairs c iflag Flag for initialization c =1 for coefficient calculation c =0 to use previous coefficients c lflag Flag for linear interpolation c =0 to perform linear interpolation c =1 to perform quadratic interpolation c xi The x value at which to interpolate f c c Output: fi The interpolated function value c ierr Error flag c =0 Normal return c =1 Parameter nmax is too small c =2 The x values are not sequential c =3 Coefficient iteration did not c converge c =4 Mix-up finding coefficients c =5 if xi .gt. x(n) or .lt. x(1), c xi is set to nearest endpoint c before the interpolation c c Note: fi is set to -99.9 if c ierr=1,2,3 or 4 c parameter (nmax=1000) c dimension x(n),f(n) c c Save variables dimension ax(nmax),bx(nmax),cx(nmax) c c Temporary local variables dimension df(nmax),dx(nmax),gm(nmax),ct(nmax) c common /xsave/ ax,bx,cx c c Specify unit number for debug write statements c and debug flag idbug = 0 lutest = 6 c c Initialize error flag ierr = 0 c c Specify minimum reduction in cost function for convergence thresh = 1.0e-10 c c Check to make sure nmax is large enough, and n is .gt. 1 if (n .gt. nmax .or. n .lt. 2) then ierr=1 fi = -99.9 return endif c if (iflag .eq. 1) then c Perform the initialization for later interpolation c c Check to make sure x is sequential do 10 i=1,n-1 if (x(i) .ge. x(i+1)) then ierr=2 fi = -99.9 return endif 10 continue c c Check for special case where n=2. Only linear interpolation c is possible. if (n .eq. 2) then cx(1) = 0.0 bx(1) = (f(2)-f(1))/(x(2)-x(1)) ax(1) = f(1) - bx(1)*x(1) go to 1500 endif c c Calculate x and f differences do 15 i=1,n-1 df(i) = f(i+1)-f(i) dx(i) = x(i+1)-x(i) 15 continue c c Calculate domain size d = x(n) - x(1) c c Check for linearity of input points eps = 1.0e-10 bb = (f(2)-f(1))/(x(2)-x(1)) aa = f(1) - bb*x(1) dev = 0.0 do 12 i=3,n dev = dev + abs(aa + bb*x(i) - f(i)) 12 continue c if (dev .lt. eps .or. lflag .eq. 0) then do 13 i=1,n-1 cx(i) = 0.0 13 continue go to 1000 endif c c Iterate to find the c-coefficients cx(1) = 0.0 nit = 100 slt = 0.01 cfsave = 1.0e+10 c do 20 k=1,nit c Calculate c values do 25 i=2,n-1 cx(i) = -cx(i-1)*dx(i-1)/dx(i) + -df(i-1)/(dx(i)*dx(i-1)) + +df(i )/(dx(i)*dx(i )) 25 continue c c Calculate current value of cost function cf0 = 0.0 do 26 i=1,n-1 cf0 = cf0 + cx(i)*cx(i)*dx(i) 26 continue cf0 = 0.5*cf0/d c if (idbug .ne. 0) then write(lutest,101) cf0 101 format(/,' cf0=',e13.6) endif c c Check for convergence rel = abs(cf0 - cfsave)/abs(cfsave) if (rel .lt. thresh) go to 1000 cfsave = cf0 c c Calculate values of Lagrange multipliers gm(n-1) = cx(n-1)*dx(n-1)/d c if (n .gt. 3) then do 30 i=n-2,2,-1 gm(i) = cx(i)*dx(i)/d - gm(i+1)*dx(i)/dx(i+1) 30 continue endif c c Calculate gradient of cost function with respect to c1 dsdc1 = dx(1)*(cx(1)/d - gm(2)/dx(2)) c c Adjust cx(1) using trial step ct(1) = cx(1) - slt*dsdc1 c c Calculate remaining c values at trial step do 33 i=2,n-1 ct(i) = -ct(i-1)*dx(i-1)/dx(i) + -df(i-1)/(dx(i)*dx(i-1)) + +df(i )/(dx(i)*dx(i )) 33 continue c c Calculate cost function at trial step cft = 0.0 do 31 i=1,n-1 cft = cft + ct(i)*ct(i)*dx(i) 31 continue cft = 0.5*cft/d c c write(6,*) 'dsdc1,cft,cf0',dsdc1,cft,cf0 c Calculate optimal step length and re-adjust cx(1) den = 2.0*((cft-cf0) + slt*dsdc1*dsdc1) if (den .ne. 0.0) then slo = dsdc1*dsdc1*slt*slt/den else slo =0.0 endif c c Adjust slo if desired slo = 1.0*slo c cx(1) = cx(1) - slo*dsdc1 c if (idbug .ne. 0) then write(lutest,100) k,cft,slt,slo 100 format(' Iteration=',i4,' cf1=',e11.4,' slt=',e11.4, + ' slo=',e11.4) c do 99 j=1,n-1 write(lutest,102) j,cx(j) 102 format(' i=',i2,' c=',f8.4) 99 continue endif c c Calculate trial step for next time step slt = 0.5*slo 20 continue c c Iteration did not converge ierr=3 fi=-99.9 return c c Iteration converged 1000 continue c if (idbug .ne. 0) then write(lutest,104) 104 format(/,' Iteration converged') endif c c Calculate b and a coefficients do 40 i=1,n-1 bx(i) = df(i)/dx(i) - cx(i)*(x(i+1) + x(i)) ax(i) = f(i) - bx(i)*x(i) - cx(i)*x(i)*x(i) 40 continue endif c 1500 continue c Interpolate the function c c Check for xi out of bounds if (xi .lt. x(1)) then xi = x(1) ierr = 5 endif c if (xi .gt. x(n)) then xi = x(n) ierr = 5 endif c c Find the interval for the interpolation ii = 1 do 50 i=2,n if (xi .le. x(i)) then ii = i-1 go to 2000 endif 50 continue c fi = -99.9 ierr=4 return c 2000 continue fi = ax(ii) + bx(ii)*xi + cx(ii)*xi*xi c return end c c c subroutine decay(ftime,rlat,rlon,vmax,vmaxa,dland,lulg) C C This routine adjusts a tropical cyclone intensity C forecast to account for decay over land. this version is C valid for the atlantic basin and was written by M. DeMaria C and J. Kaplan of the Hurricane Research Division, May 1994. C C This version was modified 4/10/97 (MDM) to include the C New England coefficients. The distance inland correction C is disabled in this version (idtlc=0). C C New version created 9/30/2004 that allows for decay proportional C to the fraction of the storm circulation over land. C (Set rcrad > 0.0 to activate this option). The logic of the code c was changed so accomodate this option. The old distance inland c correction was completely eliminated with this modification. C c Modified 12/19/2011 to include west Pacific option and to change c longitude input to deg E positive, deg W negative. The routines xint.f c and fland.f were removed from the source code so those need to be included c in the Makefile or compile script. Common block mparm was removed and save c statements were added. c c Required routines c xint.f c aland.f c wland.f c dtland.f c fland.f (new version with deg E pos, deg W neg) c C ********** INPUT ********** C C ftime: the time in hours (for example, 0.,12.,24. ... 72.) C The times need to sequential, but the time interval C does not need to be even. C rlat: The storm latitude (deg N) at the times in array ftime C rlon: The storm longitude (deg E positive, deg W neg) at the times in C array ftime C vmax: The storm maximum wind (kt) at the times in array ftime. C Set vmax=0 for missing forecast times. C lulg: Unit number for write statements C C ********** OUTPUT ********** C C vmaxa: The storm maximum wind (kt) adjusted for decay over land C at the times in array ftime. C C dland: The distance (km) from the storm center (rlat,rlon) to C the nearest major land mass. dland is negative if the C point is storm center is inland. C C ********** METHOD ********* C C The simple exponential decay model developed by M. DeMaria C and J. Kaplan at HRD is used to decay the storm intensity for C the portions of the track over land. C C In this version, the decay rate is proportional to the fraction C of the storm circualtion over land. C C ********** PARAMETER SPECIFICATION ********** C C Specify the maximum number of time values. parameter (imax=21) C C Specify the time interval (hr) for linearly interpolating C the track positions. data dt /1.00/ C C Set interp=1 to print out (to unit lulg) all intermediate C intensity calculations or else set interp=0 for no print data interp /1/ C C Specify decay model parameters C C Coefficients for east/gulf coast data rf1,a1,vb1,rclat1 /0.9,0.095,26.7,36.0/ C C Coefficients for New England data rf2,a2,vb2,rclat2 /0.9,0.183,29.6,40.0/ C C Specify radius of storm circulation (km) for fractional C decay option. Set rcrad to zero to eliminate this option. C data rcrad / 110.0/ c data rcrad / 0.0/ c c common /mparm/ alpha,vb,redfac save rf1,a1,vb1,rclat1 save rf2,a2,vb2,rclat2 save rcrad,dt,interp C C ********** DIMENSION ARRAYS ********** C dimension ftime(imax),rlat(imax),rlon(imax) dimension vmax(imax),vmaxa(imax),dland(imax) C c Arrays for small time step parameter (imaxs=1000) dimension ftimes(imaxs),rlats(imaxs),rlons(imaxs) dimension vmaxs(imaxs),vmaxas(imaxs) dimension dlands(imaxs),flands(imaxs) c C ********** MODEL CODE ********* C C Write model message to log file if (interp .gt. 0) then write(lulg,810) rcrad 810 format(' Decay model with rcrad= ',f5.0,' km') endif C c Initialize vmaxa array to zero do i=1,imax vmaxa(i) = 0.0 enddo c C Find the number of valid forecast times itimet = 0 do 10 i=1,imax if (vmax(i) .lt. 0.5) go to 1000 itimet=i 10 continue C 1000 continue C There must be at least two valid forecast times if (itimet .lt. 2) return C C Check to make sure times are sequential itime=0 do 15 i=2,itimet if (ftime(i) .le. ftime(i-1)) go to 1100 itime=i 15 continue C 1100 continue if (itime .lt. 2) return c if (interp .gt. 2) then do i=1,itime write(6,887) ftime(i),rlat(i),rlon(i),vmax(i) enddo endif c c Calcuate the time values at the small time interval points ntimes = 1 + (ftime(itime)-ftime(1))/dt do i=1,ntimes ftimes(i) = ftime(1) + dt*float(i-1) enddo c c Interpolate the input lat,lon and max winds to the c small time interval c c ++Find vmax on small time grid iflag=1 lflag=0 xi = 0.0 c call xint(ftime,vmax,itime,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,ntimes call xint(ftime,vmax,itime,iflag,lflag, + ftimes(i),vmaxs(i),ierr) enddo c c ++Find lat on small time grid iflag=1 call xint(ftime,rlat,itime,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,ntimes call xint(ftime,rlat,itime,iflag,lflag, + ftimes(i),rlats(i),ierr) enddo c c ++Find lon on small time grid iflag=1 call xint(ftime,rlon,itime,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,ntimes call xint(ftime,rlon,itime,iflag,lflag, + ftimes(i),rlons(i),ierr) enddo c c Calcuate distance to land and fractional land at small time points do i=1,ntimes call dtland(rlons(i),rlats(i),dlands(i)) enddo c c Integrate the decay model over the small time points do i=1,ntimes if (rcrad .gt. 0.0) then call fland(rlons(i),rlats(i),rcrad,flands(i)) else flands(i) = 1.0 endif enddo c vmaxas(1) = vmaxs(1) c do i=2,ntimes c At each step in this loop, the decay model is integrated c from t=ftimes(i-1) to t=ftimes(i) c c Calculate decay model parameters at current latitude rlatt = rlats(i-1) if (rlatt .ge. rclat2) then redfac = rf2 alpha = a2 vb = vb2 elseif (rlatt .le. rclat1) then redfac = rf1 alpha = a1 vb = vb1 else w1 = (rclat2-rlatt)/(rclat2-rclat1) w2 = (rlatt-rclat1)/(rclat2-rclat1) C redfac = w1*rf1 + w2*rf2 alpha = w1*a1 + w2*a2 vb = w1*vb1 + w2*vb2 endif C vmaxt1 = vmaxas(i-1) c if (dlands(i) .ge. 0.0) then c ++ This is an over-water point c c Check to see if storm just moved over water. c If so, adjust for land/ocean surface roughness differences if (dlands(i-1) .lt. 0.) then vmaxt1 = vmaxt1/redfac endif c vmaxt2 = vmaxt1 + (vmaxs(i)-vmaxs(i-1)) else c ++ This is an over-land point c c Check to see if storm just moved over land. c If so, adjust for ocean/land surface roughness differences if (dlands(i-1) .ge. 0.) then vmaxt1 = redfac*vmaxt1 endif c t = ftimes(i)-ftimes(i-1) fbar = 0.5*(flands(i)+flands(i-1)) vmaxt2 = vb + (vmaxt1-vb)* exp(-fbar*alpha*t) endif c vmaxas(i) = vmaxt2 enddo c if (interp .gt. 2) then do i=1,ntimes write(6,887) ftimes(i),vmaxs(i),vmaxas(i),rlats(i),rlons(i), + dlands(i),flands(i) 887 format(8(f6.1,1x)) enddo endif c c Interpolate decay vmaxas back to original forecast times iflag=1 c call xint(ftimes,vmaxas,ntimes,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,itime call xint(ftimes,vmaxas,ntimes,iflag,lflag, + ftime(i),vmaxa(i),ierr) enddo c c Interpolate dlands back to original forecast times iflag=1 c call xint(ftimes,dlands,ntimes,iflag,lflag,xi,fi,ierr) c iflag=0 do i=1,itime call xint(ftimes,dlands,ntimes,iflag,lflag, + ftime(i),dland(i),ierr) enddo c return end c c c SUBROUTINE WLAND ( CLON, CLAT, DIST ) C c Input: CLON - Longitude (deg E positive) c CLAT - Latitude (deg N positive) c c Output: DIST - distance (km) to nearest coastline. DIST is positive if the c point CLON,CLAT is over water and negative if it is over land. c C THIS VERSION IS FOR THE WESTERN PACIFIC (0 to 180 deg E longitude) C C SUBROUTINE LAND COMPUTES THE DISTANCE FROM, AND NORMAL BEARING C TO, THE NEAREST COASTLINE TO A CYCLONE CENTRAL AT LATITUDE 'CLAT C AND LONGITUDE 'CLON'. COASTLINES ARE STORED IN THE COMMON BLOCK C /COAST/ AND FOR UP TO 20 ISLANDS (NUMBER NISLW) OF UP TO 30 COASTAL C LINE SEGMENTS. THE INTIIAL POINTS OF EACH SEGMENT ARE STORED C IN COUNTERCLOCKWISE ORDER AROUND THE COAST. THE LAST INDEX IN C 'XISLW' OR 'XCONW' IS 1 FOR LONGITUDE AND 2 FOR LATITUDE. C C THE DISTANCE FROM THE CYCLONE TO THE NEAREST POINT ON EACH COASTAL C SEGMENT IS CALCULATED, AND THE MINIMUM ABSOLUTE VALUE IS ACCEPTED C AS THE COASTAL DISTANCE FOR THAT PARTICULAR LAND MASS. NEGATIVE C VALUES ARE INLAND. THE MINIMUM ABSOLUTE VALUE OF ALL COASTAL C DISTANCES FOR THE CYCLONE IS RETURNED AS THE COASTAL DISTANCE FOR C THIS PARTICULAR CYCLONE. C C SEVERAL MODIFICATIONS WERE MADE TO THE SUBROUTINE LAND C TO FACILITATE FUTURE CHANGES TO THE DATA FILE C USED TO DETERMINE A TROPICAL CYCLONE'S DISTANCE FROM LAND. C C THE VARIABLES NCONWOB AND NISLWOB SPECIFY THE LIMITS C FOR THE NUMBER OF POINTS WHICH DEFINE A CONTINENT AND ISLAND C RESPECTIVELY. THE VARIABLE NCOAST IS THE LIMIT FOR THE NUMBER C OF ISLANDS. PROVIDED THESE NUMBERS ARE NOT EXCEEDED ANY CHANGES C TO THE DATA FILE LAND.DAT SHOULD BE TRANSPARENT TO THE PROGRAM. C 5/13/92 J.KAPLAN C PARAMETER (NCOAST=30) PARAMETER (NCONWOB=800) PARAMETER (NISLWOB=100) C C REAL*8 CISL(NCOAST) REAL XISLW(NCOAST,NISLWOB,2), DI(NCOAST), BI(NCOAST), 1 XCONW(NCONWOB,2), DWRC(NCONWOB), BWRC(NCONWOB), 2 DWRK(NISLWOB), BWRK(NISLWOB) INTEGER*4 NPT(NCOAST), LT(NCOAST) CHARACTER CISL(NCOAST)*8 CHARACTER*256 coef_location, filename LOGICAL*1 FLAG1W, LPR C DATA FLAG1W/.FALSE./ DATA LPR /.FALSE./ C DATA LPR /.TRUE./ DATA IOPTN /7/ DATA LUIN /55/ C save flagw1,xislw,xconw,nconw,npt,nislw,lt,cisl c c Set ioper=1 to add path to land data file ioper=0 c IF( FLAG1W ) GO TO 409 C C T H I S I S C O A S L I N E I N P U T ********** C if (ioper .eq. 1) then call getenv( "SHIPS_COEF", coef_location ) filename = trim( coef_location )//'/'//'wland.dat' else filename = 'support_files/wland.dat' endif OPEN(LUIN,FILE=filename, + FORM='FORMATTED',STATUS='OLD') C 405 CONTINUE C C READ CONTINENT COASTAL POINTS C READ TOTAL NUMBER OF CONTINENT POINTS C READ(LUIN,209,END=995) NCONW, CISL(1), LT(1) C IF (NCONW.GT.NCONWOB) THEN WRITE(6,*)'NUMBER OF CONTINENT POINTS EXCEEDS PROGRAM LIMIT 1 OF ',NCONWOB STOP ENDIF C DO 105 I = 1,NCONW READ(LUIN,207,END=995) XCONW(I,1), XCONW(I,2) 207 FORMAT(F7.1,F6.1) 105 CONTINUE C C COPY INITIAL POINT INTO NCONW+1 ARRAY ADDRESS (WILL BE NEEDED C TO COMPUTE DISTANCE AND BEARING FROM LAST POINT IN CLOSED LOOP C TO 'NEXT' POINT (WHICH IS THE FIRST POINT ENTERED). XCONW(NCONW+1,1) = XCONW(1,1) XCONW(NCONW+1,2) = XCONW(1,2) C C OUTPUT THE COASTAL POINTS FOR THE CONTINENT IF( LPR ) WRITE(6,305) CISL(1), NCONW 305 FORMAT(/,5X,'COASTLINE OF ',A8,/,5X,'IS DEFINED BY THE FOLLOWING ' 1 ,I3,' POINTS') C IF( LPR )WRITE(6,307) ( I, XCONW(I,1), XCONW(I,2), I=1,NCONW ) 307 FORMAT(6(1X,I3,' (',F6.1,F5.1,')')) C C READ ISLAND NAMES AND COASTAL POINTS C NISLW = 0 200 NISLW = NISLW + 1 N= NISLW + 1 C READ(LUIN,209,END=407) NPT(N), CISL(N), LT(N) 209 FORMAT(I3,1X,A8,1X,I1) C NPTS = NPT(N) C DO 109 I = 1,NPTS READ(LUIN,207,END=995) XISLW(N,I,1), XISLW(N,I,2) 109 CONTINUE C C COPY INITIAL POINT INTO NPTS+1 ARRAY SPACE (WILL BE NEEDED TO C COMPUTE DISTANCE AND BEARING FROM LAST POINT IN CLOSED LOOP TO C 'NEXT' POINT (WHICH IS THE FIRST POINT ENTERED). C XISLW(N,NPTS+1,1) = XISLW(N,1,1) XISLW(N,NPTS+1,2) = XISLW(N,1,2) C C OUTPUT THE NAME AND COASTLINE POINTS FOR THIS ISLAND C IF( LPR ) WRITE(6,305) CISL(N), NPT(N) NPTS = NPT(N) IF( LPR ) WRITE(6,307) (I, XISLW(N,I,1), XISLW(N,I,2), I=1,NPTS ) GO TO 200 C C COME HERE IF THERE ARE NO MORE ISLANDS TO ENTER...EOF ENCOUNTE C ON READ(LUIN,205) AT THE TOP OF THIS INPUT SEGMENT C 407 NISLW = NISLW - 1 FLAG1W = .TRUE. CLOSE(5) C C T H I S I S L A N D N A V I G A T I O N ********** C 409 CONTINUE C C PROCESS CONTINENT C C COMPUTE ANGLWE OF PREVIOUS SEGMENT IF NEEDED FOR BAY OR PENINSULA C COASTLINE DETERMINATION FOR SIGN OF DISTANCE IN LSUBW1 CALL LSUBW2(XCONW(1,1),XCONW(NCONW,1),XCONW(1,2), 1 XCONW(NCONW,2), 1 DX0,DY0,AL0) C ANGLWE OF PREVIOUS SEGMENT IS DIRECTED WITH ORIGIN AT BEGINNING OF C CURRENT SEGMENT AL0 = ANGLW(AL0+180.) C DO 113 I = 1,NCONW C COMPUTE DISTANCE FROM BEGINNING POINT TO END POINT OF SEGMENT C ( COMPONENTS (DX,DY) AND FROM BEGINNING POINT TO CYCLONE C ( COMPONENTS (DXC,DYC) ). C CALL LSUBW2(XCONW(I+1,1),XCONW(I,1),XCONW(I+1,2),XCONW(I,2), 1 DX,DY,AL) CALL LSUBW2(CLON,XCONW(I,1),CLAT,XCONW(I,2),DXC,DYC, 1 AC) C C CALL DISTANCE, ANGLWE CALCULATION SHELL C C ** DEBUG C WRITE(6,*) 'I,DX,DY',I,DX,DY CALL LSUBW1 ( DX, DY, DXC, DYC, AL0,AL,AC, A, DRA, D ) C DWRC(I) = D BWRC(I) = A AL0 = ANGLW(AL+180.) 113 CONTINUE C C COMPUTE MINIMUM DISTANCE FROM CYCLONE TO CONTINENT DM = 1000. DO 115 I = 1,NCONW IF( ABS(DWRC(I)).LT.DM ) IM=I DM = ABS(DWRC(IM)) 115 CONTINUE C C ASSIGN CONTINENT DISTANCE TO FIRST ADDRESS IN WORKING ARRAY DI, BI DI(1) = DWRC(IM) BI(1) = BWRC(IM) C C C OUTER LOOP FOR NUMBER OF ISLANDS NISLW C DO 117 N = 2,NISLW+1 NPTS = NPT(N) C C LOOP THROUGH NPT(N) COASTAL SEGMENTS OF NTH ISLAND. CALL LSUBW2(XISLW(N,1,1),XISLW(N,NPTS,1),XISLW(N,1,2), 1 XISLW(N,NPTS,2),DX0,DY0,AL0) AL0 = ANGLW(AL0+180.) C DO 119 I = 1,NPTS C COMPUTE DISTANCE FROM BEGINNING POINT TO END POINT OF SEGMENT C (DX, DY) AND BEGINNING POINT TO CYCLONE (DXC, DYC) C CALL LSUBW2(XISLW(N,I+1,1),XISLW(N,I,1),XISLW(N,I+1,2), 1 XISLW(N,I,2), DX, DY, AL) CALL LSUBW2(CLON,XISLW(N,I,1),CLAT,XISLW(N,I,2) 1 ,DXC,DYC, AC) C CALL LSUBW1 ( DX, DY, DXC, DYC, AL0,AL,AC, A, DRA, D ) DWRK(I) = D BWRK(I) = A C AL0 = ANGLW(AL+180.) 119 CONTINUE C DM = 1000. DO 121 I = 1,NPTS IF( ABS(DWRK(I)).LT.DM ) IM = I DM = ABS(DWRK(IM)) 121 CONTINUE C DI(N) = DWRK(IM) BI(N) = BWRK(IM) 117 CONTINUE C DMIN = 9999. DO 116 N=1,NISLW+1 IF( ABS(DI(N)).GE.DMIN ) GO TO 116 IMN = N DMIN= ABS(DI(N)) 116 CONTINUE C DIST = DI(IMN)*111.12 BRG = BI(IMN) RETURN C C ERROR MESSAGES C 995 WRITE(6,3995) N, CISL(N) 3995 FORMAT(///,5X,'END OF FILE WHILE ATTEMPTING TO READ THE COAST POIN 1TS FOR',/,5X,'ISLAND N=',I2,' WITH NAME ',A8,/,5X,'PROBABLE CAUSE 2IS MISMATCHED NUMBER OF POINTS SPECIFIED FOR ISLAND COAST AND',/,5 3X,'ACTUAL NUMBER OF POINTS ON LIST.') C STOP END SUBROUTINE LSUBW1 ( DX, DY, DXC, DYC, AL0,AL,AC, A, DRA, D ) DR = 180./3.141592 C C COMPUTE CYCLONE DISTANCE TO COASTAL SEGMENT ACL = ANGLW(AC-AL) DL = SQRT(DX*DX + DY*DY) DC = SQRT(DXC*DXC + DYC*DYC) DNC = -DC*SIN(ACL/DR) DAC = DC*COS(ACL/DR) DRA = DAC/DL C C ASSIGN DISTANCE FROM CYCLONE TO COAST C IF DISTANCE RATIO IS IN RANGE 0-1, USE NORMAL DISTANCE C IF DISTANCE RANGE OUTSIDE ABOVE, USE DISTANCE FROM CYCLONE C TO INITIAL POINT OF SEGMENT, WITH SIGN DEPENDING ON THE ANGLWE OF C THE COAST AT THAT POINT C C DETERMINE DISTANCE AND WHETHER OVER LAND OR WATER SGNA = 1. IF( ABS(ACL).GE.1.E-5 ) SGNA = ACL/ABS(ACL) AC0 = ANGLW(AC-AL0) ALL0= ANGLW(AL0-AL) C DFLAG = 0. IF( DNC.LT.0. ) DFLAG = 180. AFC = -90. - AC AFR = DFLAG- AL C IF( DRA.GT.1. ) GO TO 405 IF( DRA.LT.0. ) GO TO 407 C C DISTANCE IS ALONG NORMAL TO COAST D = DNC A = AFR GO TO 410 C C DISTANCE IS APPROXIMATED BY DISTANCE TO CYCLONE, BUT WILL BE C DEFINITELY LONGER THAN, AND THEREFORE SUPERSEDED BY, THE C DISTANCE FROM THE INITIAL POINT OF THE NEXT COASTAL SEGMENT 405 D = -DC*SGNA A = AFC GO TO 410 C C DISTANCE IS THAT FROM INITIAL POINT TO CYCLONE. POINT IS OVER C WATER IF BEARING OF VECTOR TO CYCLONE IS LESS THAN BEARING C OF PREVIOUS COASTAL SEGMENT, OR IF TO RIGHT OF CURRENT COASTAL C SEGMENT 407 D = -DC*SGNA A = AFC C C DISTANCE OFFSHORE/ONSHORE IS NOW SET UP RELATIVE TO CURRENT COASTAL C SEGMENT...NEGATIVE IS ONSHORE, OR TO THE LEFT. CORRECT DEPENDING C UPON ORIENTATION OF PREVIOUS COASTAL SEGMENT C IF( D.LE.0. ) GO TO 409 C CYCLONE IS OFFSHORE (TO RIGHT) IF( AC0.LE.0.AND.ALL0.LE.0. ) D = -D GO TO 410 C CYCLONE IS ONSHORE (TO LEFT) 409 IF( AC0.GT.0.AND.ALL0.GT.0 ) D = -D C C TRANSFORM BEARING FROM THE -180 TO +180 RANGE USED INTERNALLY C TO THE 0 TO 360 RANGE FOR DISPLAY PURPOSES. 410 IF( A.LT.0. ) A = A + 360. C RETURN END SUBROUTINE LSUBW2( X2, X1, Y2, Y1, DX, DY, A ) DR = 180./3.141592 DY = Y2-Y1 DX = (X2-X1)*COS((Y2+Y1)/(2.*DR)) A = 0. DD = ABS(DX)+ABS(DY) IF( DD.LE.1.E-5 ) RETURN A = ATAN2(DY,DX)*DR RETURN END C REAL FUNCTION ANGLW(A) ANGLW = A IF( A.LE.-180.) ANGLW = A + 360. IF( A.GT. 180.) ANGLW = A - 360. RETURN END subroutine dtland(rlon,rlat,dtl) c This routine calculates the distance to nearest land using routine c aland for the western hemisphere and part of the eastern hemipshere (-180 to 20) c or wland for the rest of the eastern hemisphere (20 to 180) c c Input: rlon - Longitude (deg W negative, deg E positive) c rlat - Latitude (deg N) c c Note: Longitude for western hemisphere can also be in c 0 to 360 deg convention c c Output: dtl - distance to land (km) c c Determine which hemisphere the point is in tlat = rlat tlon = rlon if (tlon .ge. 180.0) then tlon = tlon - 360.0 endif c if (tlon .le. 20.0) then ihem = 2 else ihem = 1 endif c c Check for lat/lon out of bounds if (tlat .gt. 90.0 .or. tlat .lt. -90.0) ihem=0 if (tlon .lt. -180.0 .or. tlon .gt. 180.0) ihem=0 c if (ihem .eq. 2) then call aland(tlon,tlat,dtl) elseif (ihem .eq. 1) then call wland(tlon,tlat,dtl) else dtl = -9999. endif c return end subroutine fland(slon,slat,rkm,fraction) c This routine calcuates the fraction of the circular area c centered at the point (slat,slon) that is over land. c c Input: rkm - radius of circle in km c slat - center latitude of the circle (deg N pos) c slon - center longitude of the circle (deg W neg, deg E pos) c Note: Deg W neg value can also be in 0 to 360 deg convention c c Output: fraction - the fraction of the circle over land c c Modified 11/25/2011 to call dtland instead of aland. Also, longitude c input modified to include eastern hemisphere option (deg E positive) c c Calculate the distance to nearest land at the circle center call dtland(slon,slat,d00) c c Check for special cases if (rkm .le. 0.0) then fraction = 1.0 return endif c if (d00 .gt. rkm) then fraction = 0.0 return endif c if (d00 .lt. -rkm) then fraction = 1.0 return endif c c Perform area integration fraction = 0.0 dx = 25.0 if (dx .ge. rkm/4.0) dx = rkm/4.0 dy = dx c pi = 3.14159 dtr= pi/180.0 xfac = 111.1*cos(slat*dtr) yfac = 111.1 c n = ifix(rkm/dx) c ntotal = 0 nland = 0 do j=-n,n do i=-n,n x = float(i)*dx y = float(j)*dy r = sqrt(x*x + y*y) if (r .gt. rkm) go to 1000 c tlat = slat + x/xfac tlon = slon + y/yfac c call dtland(tlon,tlat,tdtl) ntotal = ntotal+1 if (tdtl .le. 0.0) nland = nland+1 1000 continue c enddo enddo c fraction = float(nland)/float(ntotal) c return end subroutine bassel(rlat,rlon,ibasin) c This routine determines which basin a given c lat/lon point is in c c Input: c rlat - latitude deg N c rlon - longitude deg E (0-360 convention) c c Output c ibasin = 1 for Atlantic c = 2 for east Pacific c = 3 for west Pacific c = 4 for south Pacific c = 5 for Indian Ocean c ibasin = 1 if (rlat .ge. 0.0) then if (rlat .le. 8.0) then if (rlon .lt. 285.0) ibasin=2 elseif (rlat .gt. 8.0 .and. rlat .le. 15.0) then if (rlon .lt. 275.0) ibasin=2 elseif (rlat .gt. 15.0 .and. rlat .le. 17.5) then if (rlon .lt. 270.0) ibasin=2 elseif (rlat .gt. 17.5 ) then if (rlon .lt. 260.0) ibasin=2 endif endif c if ((rlon .lt. 180.0) .and. (rlat .ge. 0.0)) ibasin=3 c if ((rlon .lt. 280.0) .and. (rlat .lt. 0.0)) ibasin=4 c if (rlon .lt. 100.0) ibasin=5 return end subroutine tadd(iyr,imon,iday,itime,ihra,iyra,imona,idaya,itimea) c This subroutine calculates the year,month,day,time c (iyra,imona,idaya,itimea) that are ihra hours after c the input year,month,day,time (iyr,imon,iday,itime). c c ihra can not exceed the number of hours in 9 months. c c If ihra is negative, the year,month,day,time that are abs(ihra) c before the input year,month,day,time are calculated. c c The Julian day utilities jday and jdayi are called c by this routine. c iyra = iyr imona = imon idaya = iday c if (ihra .lt. 0) go to 1000 c c ** Start calculation for positive ihra ** c c Add the hours to the input time itimea = itime+ihra c if (itimea .lt. 24) return c c Calculate the number of extra days in the itimea variable c and subtract them from itimea idayex = itimea/24 itimea = itimea - idayex*24 c c Calculate Julian day of input date c and add extra days to it call jday(imon,iday,iyr,jdate) jdate = jdate + idayex c c Check to see if year has changed call jday(12,31,iyr,jmax) c if (jdate .gt. jmax) then iyra = iyr+1 jdate = jdate-jmax else iyra = iyr endif c c Calculate month and day corresponding to the c increased jdate call jdayi(jdate,iyra,imona,idaya) c return c 1000 continue c ** Start calculation for negative ihra ** c Add the hours to the input time itimea = itime+ihra c if (itimea .ge. 0) return c c Calculate adjusted time idayex = -1 + itimea/24 itimea = itimea - idayex*24 if (itimea .eq. 24) then itimea=0 idayex = idayex + 1 endif c c Calculate Julian day of input date c and subtract extra days from it call jday(imon,iday,iyr,jdate) jdate = jdate + idayex c c Check to see if year has changed if (jdate .lt. 1) then iyra = iyra-1 jdate = jdate + 365 if (mod(iyr-1,4) .eq. 0) jdate = jdate + 1 endif c c Calculate month and day corresponding to the c decreased jdate call jdayi(jdate,iyra,imona,idaya) c return end subroutine jday(imon,iday,iyear,julday) c This routine calculates the Julian day (julday) from c the month (imon), day (iday), and year (iyear). The c appropriate correction is made for leap year. c dimension ndmon(12) c c Specify the number of days in each month ndmon(1) = 31 ndmon(2) = 28 ndmon(3) = 31 ndmon(4) = 30 ndmon(5) = 31 ndmon(6) = 30 ndmon(7) = 31 ndmon(8) = 31 ndmon(9) = 30 ndmon(10) = 31 ndmon(11) = 30 ndmon(12) = 31 c c Correct for leap year if (mod(iyear,4) .eq. 0) ndmon(2)=29 c c Check for illegal input if (imon .lt. 1 .or. imon .gt. 12) then julday=-1 return endif c if (iday .lt. 1 .or. iday .gt. ndmon(imon)) then julday=-1 return endif c c Calculate the Julian day julday = iday if (imon .gt. 1) then do 10 i=2,imon julday = julday + ndmon(i-1) 10 continue endif c return end subroutine jdayi(julday,iyear,imon,iday) c This routine calculates the month (imon) and day (iday) c from the Julian day (julday) and year (iyear). c The appropriate correction is made for leap year. c dimension ndmon(12),nsum(13) c c Specify the number of days in each month ndmon(1) = 31 ndmon(2) = 28 ndmon(3) = 31 ndmon(4) = 30 ndmon(5) = 31 ndmon(6) = 30 ndmon(7) = 31 ndmon(8) = 31 ndmon(9) = 30 ndmon(10) = 31 ndmon(11) = 30 ndmon(12) = 31 c c Correct for leap year if (mod(iyear,4) .eq. 0) ndmon(2)=29 c c Check for illegal input if (mod(iyear,4) .eq. 0) then mxjul = 366 else mxjul = 365 endif c if (julday .lt. 1 .or. julday .gt. mxjul) then imon = -1 iday = -1 return endif c c Calculate the month and day nsum(1) = 0 do 10 i=1,12 nsum(i+1) = nsum(i) + ndmon(i) 10 continue c do 20 i=2,13 if (julday .le. nsum(i)) then imon = i-1 go to 1000 endif 20 continue 1000 continue c iday = julday - nsum(imon) c return end subroutine mpicalo(sst,rmpi,ibasin) c This routine calculates the maximum potential intensity (kt) c from the sst (C) using empirical relationships. c c This version was modifed March 2006 to c use the original formulas from DK 1994 and c WH 1997, rather than the formulas adjusted c for the average storm translational speed. c c Input: c sst: SST in deg C c tspeed: Storm translational speed in knots c ibasin: Basin indicator c ibasin=1 for Atlantic c ibasin=2 for East Pacific c ibasin=3 for West Pacific c c Output: c rmpi: Maximum potential intensity (kt) c Note: rmpi is set to 999.9 for missing SST c c Check for illegal sst values if (sst .gt. 35.0 .or. sst .lt. 0.0) then rmpi=999.9 return endif c if (ibasin .eq. 1) then c Atlantic function (DeMaria and Kaplan 1994) c vcold = 34.2 vcold = 28.2 vadd = 55.8 a = 0.1813 tmax = 30.00 c rmpi = vcold + vadd*exp(-a*(tmax-sst)) rmpi = rmpi*1.944 elseif (ibasin .eq. 2) then c East Pacific function (Whitney and Hobgood 1997) a = -79.2 b = 5.362 c = 0.0 c c = 4.7 C tmin = 20.0 sstt = sst if (sstt .lt. tmin) sstt=tmin C rmpi = a + b*sstt + c rmpi = rmpi*1.944 elseif (ibasin .eq. 3) then C West Pacific function vcold = 19.7 vadd = 88.0 a = .1909 tmax = 30.00 C rmpi = vcold + vadd*exp(-a*(tmax-sst)) rmpi = rmpi*1.944 else rmpi = 999.9 return endif C if (rmpi .gt. 165.0) rmpi=165.0 c return end c c c subroutine tclip(rlon00,rlat00,rlonm12,rlatm12,cx00,cy00,ipf, + vmx00,vmxm12,iyr,imon,iday,itime,dthr,ndt,ioper, + iftypet,iftypei,flon,flat,fvmax,ierr) c c This routine makes a climatology and persistence forecast by following c a trajectory where the horizontal motion is a weighted sum of c a climatological storm motion vector and persistence. The intensity forecast c is from a version of LGEM with climatological input. c c Input: rlon00 - Longitude at t=0 (0 to 360 deg) c rlat00 - Latitude at t=0 (-90 to 90 deg) c rlonm12 - same as rlon00 at t=-12 hr (not used if ipf=1) c rlatm12 - same as rlat 00 at t=-12 hr (not used if ipf=1) c cx00 - eastward component of storm motion at t=0 (kt) (not used if ipf=0) c cy00 - northward component of storm motion at t=0 (kt) (not used if ipf=0) c ipf - Method for calculation initial motion, c =1 to use cx00,cy00 or c =0 to calculate it from rlon,rlat at t=0 and -12 hr c vmx00 - Maximum wind at t=0 (kt) c vmxm12 - Maximum wind at t=-12 hr (kt) c iyr - 4 digit year of t=0 c imon - 2 digit month of t=0 c iday - 2 digit day of t=0 c itme - 2 digit time of t=0 c dthr - forecast output time step (hr) c ndt - Number of time steps c ioper - Flag for add path to file open on NCEP operational computers c iftypet - =0 for persistence only, c =1 for climatology only c =2 for climatology and persistence, for track forecast c iftypei - =0 for persistence only, c =1 for climatology only c =2 for climatology and persistence, for intensity forecast c c Output: flon(0:ndt) - Forecast longitudes (0 to 360 deg) c flat(0:ndt) - Forecast latitudes (-90 to 90 deg) c fvmax(0:ndt)- Forecast vmax (kt) c ierr - Error variable (=0 for normal completion) c (=1 if climo files are missing) c c Passed variables dimension flat(0:ndt),flon(0:ndt),fvmax(0:ndt) c c Internal variables parameter (mdt=2400) dimension flons(0:mdt),flats(0:mdt),vmaxs(0:mdt) dimension cx(0:mdt),cy(0:mdt) dimension cxc(0:mdt),cyc(0:mdt) dimension cxp(0:mdt),cyp(0:mdt) dimension wxc(0:mdt),wyc(0:mdt) dimension wxp(0:mdt),wyp(0:mdt) dimension dtlnd(0:mdt),flnd(0:mdt),sstc(0:mdt),vmpi(0:mdt) dimension tf(0:mdt) dimension iyrf(0:mdt),imonf(0:mdt),idayf(0:mdt),itimef(0:mdt) c dimension cappa(0:mdt),cappap(0:mdt),cappac(0:mdt) dimension wcc(0:mdt),wcp(0:mdt) c parameter (mxc=360,myc=181,ntc=12) c dimension uclim(mxc,myc,ntc),vclim(mxc,myc,ntc),cclim(mxc,myc,ntc) dimension sstclim(mxc,myc,ntc) dimension ndmo(ntc) c common /climo/ uclim,vclim,cclim,glon1,glat1,dlon,dlat,nxc,nyc common /climoo/ sstclim,glono1,glato1,dlono,dlato,nxco,nyco common /climot/ ndmo c common /pncon1/ pi,dtr,ckt2ms,deg2m,eradkm,eradm,rmiss common /pncon2/ rf1,rf2,a1,a2,vb1,vb2,rclat1,rclat2,rcrad common /pncon3/ auc,avc,efuc,efvc,aup,avp common /pncon4/ efcp,acc,acp,rnn,beta c data iclimo /1/ c c Set the maximum time step (hr) to use for the integration dtmax = 1.0 c c Set mpired=1 to linearly reduce MPI to vmpizer as SST approaches sstzer, starting c at sstmin mpired=1 sstmin=20.0 sstzer =10.0 vmpizer=1.0 c c Set minimum intensity (kt) vmin = 15.0 c c Set maximum time (hr) over land before dissipation tolmax = 72.0 c c Set mpispd=1 to add a fraction of the translational speed to the mpi mpispd=1 c c Set unit number (lulog) for debug write statements and debug write flag lulog = 6 idbug = 0 c c Initialize forecast to zero do k=0,ndt flat(k) = 0.0 flon(k) = 0.0 fvmax(k)= 0.0 enddo c do i=0,mdt flons(i) = 0.0 flats(i) = 0.0 vmaxs(i) = 0.0 enddo c call pninit c c Initialize the position flon(0) = rlon00 flat(0) = rlat00 flons(0) = rlon00 flats(0) = rlat00 vmaxs(0) = vmx00 fvmax(0) = vmx00 c c Determine which basin the storm starts in call bassel(flat(0),flon(0),ibasin) c ierr = 0 if (iclimo .eq. 1) then c Get climatological u,v,cappa and SST fields call getclimo(ioper,ierrc) if (ierrc .ne. 0) then ierr=ierrc return endif c glon2 = glon1 + dlon*float(nxc-1) glat2 = glat1 + dlat*float(nyc-1) endif c c write(6,750) glon1,glon2,dlon,nxc,glat1,glat2,dlat,nyc c 750 format(' glon1,glon2,dlon,nxc:',3(f6.1,1x),i3, c + ' glat1,glat2,dlat,nyc:',3(f6.1,1x),i3) c c Initialize numerical and physical constants c Calculate initial storm motion vector if necessary and c convert it to m/s if (ipf .eq. 0) then cfac = cos(0.5*dtr*(rlat00+rlatm12)) dlon00 = (rlon00-rlonm12)*cfac dlat00 = (rlat00-rlatm12) c c Check to see if Greenwich meridian was crossed if (dlon00 .gt. 180.0) dlon00 = dlon00 - 360.0 if (dlon00 .lt. -180.0) dlon00 = dlon00 + 360.0 c cxp(0) = (dlon00*deg2m)/(12*3600.0) cyp(0) = (dlat00*deg2m)/(12*3600.0) else cxp(0) = cx00*ckt2ms cyp(0) = cy00*ckt2ms endif c c Compare dtmax and output time step and compute the c interval for saving the output (intsave) and the c total number of time steps to integrate the model if (dthr .lt. dtmax) then intsave = 1 ndts = ndt dts = dthr else intsave = ifix(0.1 + dthr/dtmax) ndts = ndt*intsave dts = dthr/float(intsave) endif dtss = 3600.0*dts c c c Calcuate time (hr) at each time step, c the date/time to the nearest hour at each time step, c and persistence vector at each time step tf(0) = 0.0 iyrf(0) = iyr imonf(0) = imon idayf(0) = iday itimef(0) = itime c do k=1,ndts tf(k) = tf(0) + dts*float(k) c itadd = ifix(tf(k) + 0.49) call tadd(iyr,imon,iday,itime,itadd, + iyrf(k),imonf(k),idayf(k),itimef(k)) cxp(k) = cxp(0) cyp(k) = cyp(0) enddo c if (idbug .eq. 1) then write(lulog,700) cxp(0),cyp(0),dthr,dts,ndts 700 format('Initial motion vector (m/s): ',f7.2,1x,f7.2, + /,'Output time step=',f6.1, + /,'Integration time step=',f6.1, + /,'No. of time steps= ',i6) endif c c *** Forward time step c ++ Track call clsst(flons(0),flats(0),imonf(0),idayf(0),sstc(0)) call uvcal(flons(0),flats(0),vmaxs(0),tf(0), + imonf(0),idayf(0),iftypet, + cxp(0),cyp(0),cxc(0),cyc(0), + wxp(0),wyp(0),wxc(0),wyc(0), + cx(0),cy(0)) c fxm1 = cx(0)/(dtr*eradm*cos(dtr*flats(0))) fym1 = cy(0)/(dtr*eradm) c flons(1) = flons(0) + dtss*fxm1 flats(1) = flats(0) + dtss*fym1 c c ++ Intensity call dtland(flons(0),flats(0),dtlnd(0)) call fland(flons(0),flats(0),rcrad,flnd(0)) call mpicalo(sstc(0),vmpi(0),ibasin) call mpicalo(sstmin,vmpimin,ibasin) if (mpired .eq. 1) call rmpi(sstmin,vmpimin,sstzer,vmpizer, + sstc(0),vmpi(0)) if (mpispd .eq. 1) call ampi(cx(0),cy(0),vmpi(0)) c c Calculate initial growth rate from persistence call capinit(rlon00,rlat00,vmx00,rlonm12,rlatm12,vmxm12, + vmpi(0),iyr,imon,iday,cappa00) c do k=0,ndts cappap(k) = cappa00 cappac(k) = 0.0 cappa(k) = 0.0 wcp(k) = 0.0 wcc(k) = 0.0 enddo c call capcal(flons(0),flats(0),tf(0),imonf(0),idayf(0), + iftypei,cappap(0),cappac(0),wcp(0),wcc(0), + cappa(0)) c fvm0 = cappa(0)*vmaxs(0) - beta*vmaxs(0)*(vmaxs(0)/vmpi(0))**rnn c if (dtlnd(0) .lt. 0.0) then c Use inland decay model for intensity change call dparm(flats(0),redfac,alpha,vb) vmaxs(1) = vmaxs(0) - dts*alpha*flnd(0)*(vmaxs(0)-vb1) else vmaxs(1) = vmaxs(0) + dts*fvm0 endif c if (idbug .eq. 1) then call tsprint(tf(0),flons(0),flats(0),vmaxs(0), + cxp(0),cyp(0),cxc(0),cyc(0), + wxp(0),wyp(0),wxc(0),wyc(0), + cx(0),cy(0),dtlnd(0),sstc(0),vmpi(0), + cappap(0),cappac(0),cappa(0), + wcp(0),wcc(0),lulog) endif c c ++ Prepare for next time step and print if necessary call clsst(flons(1),flats(1),imonf(1),idayf(1),sstc(1)) call uvcal(flons(1),flats(1),vmaxs(1),tf(1), + imonf(1),idayf(1),iftypet, + cxp(1),cyp(1),cxc(1),cyc(1), + wxp(1),wyp(1),wxc(1),wyc(1), + cx(1),cy(1)) c fxm0 = cx(1)/(dtr*eradm*cos(dtr*flats(1))) fym0 = cy(1)/(dtr*eradm) c call dtland(flons(1),flats(1),dtlnd(1)) call fland(flons(1),flats(1),rcrad,flnd(1)) call mpicalo(sstc(1),vmpi(1),ibasin) if (mpired .eq. 1) call rmpi(sstmin,vmpimin,sstzer,vmpizer, + sstc(1),vmpi(1)) if (mpispd .eq. 1) call ampi(cx(1),cy(1),vmpi(1)) c call capcal(flons(1),flats(1),tf(1),imonf(1),idayf(1), + iftypei,cappap(1),cappac(1),wcp(1),wcc(1), + cappa(1)) fvm0 = cappa(1)*vmaxs(1) - beta*vmaxs(1)*(vmaxs(1)/vmpi(1))**rnn c if (idbug .eq. 1) then call tsprint(tf(1),flons(1),flats(1),vmaxs(1), + cxp(1),cyp(1),cxc(1),cyc(1), + wxp(1),wyp(1),wxc(1),wyc(1), + cx(1),cy(1),dtlnd(1),sstc(1),vmpi(1), + cappap(1),cappac(1),cappa(1), + wcp(1),wcc(1),lulog) endif c c *** Adams-Bashforth time steps for track, forward for intensity, to desired time c c Set time over land counter toland = 0.0 c do k=2,ndts c c ++ Track flons(k) = flons(k-1) - 0.5*dtss*fxm1 + 1.5*dtss*fxm0 flats(k) = flats(k-1) - 0.5*dtss*fym1 + 1.5*dtss*fym0 c fxm1 = fxm0 fym1 = fym0 c c ++ Intensity if (dtlnd(k-1) .lt. 0.0) then c Use inland decay model for intensity change call dparm(flats(k-1),redfac,alpha,vb) c c Check to see if storm just moved from water to land. c If so, multiple surface roughness adjustment parameter if (dtlnd(k-1) .lt. 0.0 .and. dtlnd(k-2) .ge. 0.0) then vmaxs(k-1) = vmaxs(k-1)*redfac endif c vmaxs(k) = vmaxs(k-1) - dts*alpha*flnd(k-1)*(vmaxs(k-1)-vb1) c toland = toland + dts if (toland .gt. tolmax) go to 3000 else c Check to see if storm just moved from water to land. c If so, multiple surface roughness adjustment parameter if (dtlnd(k-1) .ge. 0.0 .and. dtlnd(k-2) .lt. 0.0) then vmaxs(k-1) = vmaxs(k-1)/redfac endif c c Use climatological version of LGEM for intensity change vmaxs(k) = vmaxs(k-1) + dts*fvm0 c c Reset time of land counter since storm is over water again toland = 0.0 c c Check to see if vmax is below minimum intensity if (vmaxs(k) .lt. vmin) go to 3000 endif c c Check to see if storm is out of climo domain if (flons(k) .lt. glon1 .or. flons(k) .gt. glon2) go to 3000 if (flats(k) .lt. glat1 .or. flats(k) .gt. glat2) go to 3000 c c ++ Prepare for next time step and print if necessary call clsst(flons(k),flats(k),imonf(k),idayf(k),sstc(k)) call uvcal(flons(k),flats(k),vmaxs(k),tf(k), + imonf(k),idayf(k),iftypet, + cxp(k),cyp(k),cxc(k),cyc(k), + wxp(k),wyp(k),wxc(k),wyc(k), + cx(k),cy(k)) c fxm0 = cx(k)/(dtr*eradm*cos(dtr*flats(k))) fym0 = cy(k)/(dtr*eradm) c call dtland(flons(k),flats(k),dtlnd(k)) call fland(flons(k),flats(k),rcrad,flnd(k)) call mpicalo(sstc(k),vmpi(k),ibasin) if (mpired .eq. 1) call rmpi(sstmin,vmpimin,sstzer,vmpizer, + sstc(k),vmpi(k)) if (mpispd .eq. 1) call ampi(cx(k),cy(k),vmpi(k)) c call capcal(flons(k),flats(k),tf(k),imonf(k),idayf(k), + iftypei,cappap(k),cappac(k),wcp(k),wcc(k), + cappa(k)) fvm0 = cappa(k)*vmaxs(k) + -beta*vmaxs(k)*(vmaxs(k)/vmpi(k))**rnn c if (idbug .eq. 1) then call tsprint(tf(k),flons(k),flats(k),vmaxs(k), + cxp(k),cyp(k),cxc(k),cyc(k), + wxp(k),wyp(k),wxc(k),wyc(k), + cx(k),cy(k),dtlnd(k),sstc(k),vmpi(k), + cappap(k),cappac(k),cappa(k), + wcp(k),wcc(k),lulog) endif enddo c 3000 continue c c *** Extract forecast at output time steps kk = 0 do k=1,ndts if (mod(k,intsave) .eq. 0) then kk = kk + 1 flon(kk) = flons(k) flat(kk) = flats(k) fvmax(kk)= vmaxs(k) endif enddo c return end subroutine pninit c This routine initializes needed constants c common /pncon1/ pi,dtr,ckt2ms,deg2m,eradkm,eradm,rmiss common /pncon2/ rf1,rf2,a1,a2,vb1,vb2,rclat1,rclat2,rcrad common /pncon3/ aup,avp,efup,efvp,auc,avc common /pncon4/ efcp,acc,acp,rnn,beta c c Numerical constants pi = 3.14159265 dtr = pi/180.0 c c Physical constants eradkm = 6371.0 eradm = eradkm*1000.0 c c Conversion factors deg2m = 2.0*pi*eradm/360.0 ckt2ms = 1.0/1.944 c c Missing data flag rmiss = -999. c c Parameters for inland decay model rf1 = 0.9 rf2 = 0.9 a1 = 0.095 a2 = 0.183 vb1 = 26.7 vb2 = 29.6 rclat1 = 36.0 rclat2 = 40.0 rcrad = 110.0 c c Parameters for weighting climatology and persistence track forecast auc = 1.0 avc = 1.0 aup = 1.0 avp = 1.0 c efup = 1.0/76.0 efvp = 1.0/40.0 c c Parameters for LGEM intensity forecast efcp = 1.0/8.0 acc = 1.0 acp = 1.0 rnn = 2.5 beta = 1.0/24.0 c return end subroutine uvcal(slon,slat,vmax,t,imon,iday,iftype, + cxp,cyp,cxc,cyc, + wxp,wyp,wxc,wyc, + cx,cy) c c This routine estimates the storm motion vector (cx,cy) c as a weighted average of climatology and persistence c c Input: c slon: storm longitude ( 0 to 360) c slat: storm latitude (-90 to 90) c vmax: max wind (kt) c t : forecast time (hr) c imon: Month (1-12) c iday: Day of the month (1-31) c iftype: Method for averaging persistence and climatology c (=0 for persistence, =1 for climo, =2 for time weighted average) c cxp,cyp: t=0 motion vector (m/s) c c Output: c wxp: The weight on the x-component of persistence c wyp: The weight on the y-component of persistence c wxc: The weight on the x-component of climatology c wyc: The weight on the y-component of climatology c cx: The x-component of the motion vector (m/s) c cy: The y-component of the motion vector (m/s) c common /pncon3/ aup,avp,efup,efvp,auc,avc c c Get climatological storm motion vector call cluvc(slon,slat,imon,iday,cxc,cyc,cappa) c c Calcuate the climatology and persistence weights if (iftype .eq. 0) then wxp = 1.0 wyp = 1.0 wxc = 0.0 wyc = 0.0 elseif (iftype .eq. 1) then wxp = 0.0 wyp = 0.0 wxc = 1.0 wyc = 1.0 else wxp = aup*exp(-t*efup) wyp = avp*exp(-t*efvp) wxc = auc*(1.0-wxp) wyc = avc*(1.0-wyp) endif c cx = wxc*cxc + wxp*cxp cy = wyc*cyc + wyp*cyp c return end subroutine tsprint(t,flon,flat,vmax, + cxp,cyp,cxc,cyc, + wxp,wyp,wxc,wyc, + cx,cy,dtlnd,sst,vmpi, + cappap,cappac,cappa, + wcp,wcc,lulog) c c This routine prints the storm info at a single time c tlon = flon if (tlon .gt. 180.0) tlon=tlon-360.0 c write(lulog,100) t,tlon,flat,vmax,cxp,cyp,cxc,cyc, + wxp,wyp,wxc,wyc,cx,cy,dtlnd,sst,vmpi, + 100.0*cappap,100.0*cappac,100.0*cappa, + wcp,wcc 100 format('t=',f7.1,' lon,lat,v=',f7.2,1x,f6.2,1x,f6.1, + ' cpx,y=',f6.2,1x,f6.2,' ccx,y=',f6.2,1x,f6.2, + ' wpx,y=',f5.2,1x,f5.2,' wcx,y=',f5.2,1x,f5.2, + ' cx,y=',f6.2,1x,f6.2,' dtl=',f6.0,' sst=',f5.1, + ' mpi=',f4.0,' kp,kc,k=',3(f5.2,1x), + ' wcp,wcc=',f5.2,1x,f5.2) c return end subroutine dparm(slat,redfac,alpha,vb) c This routine calculates the parameters of the inland decay c model as a function of latitude c common /pncon2/ rf1,rf2,a1,a2,vb1,vb2,rclat1,rclat2,rcrad c if (slat .ge. rclat2) then redfac = rf2 alpha = a2 vb = vb2 elseif (slat .le. rclat1) then redfac = rf1 alpha = a1 vb = vb1 else w1 = (rclat2-slat)/(rclat2-rclat1) w2 = (slat-rclat1)/(rclat2-rclat1) c redfac = w1*rf1 + w2*rf2 alpha = w1*a1 + w2*a2 vb = w1*vb1 + w2*vb2 endif c return end subroutine getclimo(ioper,ierrc) c This routine gets the monthly climatology fields for u,v,cappa and SST c parameter (mxc=360,myc=181,ntc=12) c dimension uclim(mxc,myc,ntc),vclim(mxc,myc,ntc),cclim(mxc,myc,ntc) dimension sstclim(mxc,myc,ntc) dimension ndmo(ntc) c character *256 coef_location,fntemp c common /climo/ uclim,vclim,cclim,glon1,glat1,dlon,dlat,nxc,nyc common /climoo/ sstclim,glono1,glato1,dlono,dlato,nxco,nyco common /climot/ ndmo c dimension txy(nxc,nyc) c character *3 tchar c c Specify the unit number to use lut = 61 c c Scale for cappa cscale = 100.0 c c Specify the number of days in each month ndmo( 1) = 31 ndmo( 2) = 28 ndmo( 3) = 31 ndmo( 4) = 30 ndmo( 5) = 31 ndmo( 6) = 30 ndmo( 7) = 31 ndmo( 8) = 31 ndmo( 9) = 30 ndmo(10) = 31 ndmo(11) = 30 ndmo(12) = 31 c c *** Open and read the u,v,cappa climo file if (ioper .eq. 1) then call getenv("SHIPS_COEF",coef_location ) fntemp = trim( coef_location )//'oban_WH.dat' else fntemp = 'support_files/oban_WH.dat' endif c open(file=fntemp,unit=lut,form='formatted', + status='old',err=901) c c ++ Read the header line and check parameters read(lut,*,err=911) glon1,dlon,nxc,glat1,dlat,nyc c c ++ Read the data do m=1,ntc read(lut,*,err=911) read(lut,*,err=911) do j=nyc,1,-1 read(lut,*,err=911) (uclim(i,j,m),i=1,nxc) enddo c read(lut,*,err=911) read(lut,*,err=911) do j=nyc,1,-1 read(lut,*,err=911) (vclim(i,j,m),i=1,nxc) enddo c read(lut,*,err=911) read(lut,*,err=911) do j=nyc,1,-1 read(lut,*,err=911) (cclim(i,j,m),i=1,nxc) enddo enddo c c Scale cappa do m=1,12 do j=1,nyc do i=1,nxc cclim(i,j,m) = cclim(i,j,m)/cscale enddo enddo enddo c close(lut) c c *** Open and read the SST climo file if (ioper .eq. 1) then call getenv("SHIPS_COEF",coef_location ) fntemp = trim( coef_location )//'clim_rsst.dat' else fntemp = 'support_files/clim_rsst.dat' endif c open(file=fntemp,unit=lut,form='formatted', + status='old',err=903) c c ++ Read the header line and check parameters read(lut,*,err=913) iyr1,iyr2,nxco,glono1,dlono,nyco,glato1,dlato c c ++ Read the data do m=1,ntc read(lut,100,err=912) tchar 100 format(a3) read(lut,101,err=912) ptemp 101 format(5x,f6.1) do j=1,nyco read(lut,102,err=912) (sstclim(i,j,m),i=1,nxco) 102 format(1000f8.2) enddo read(lut,100,err=912) tchar enddo close(lut) c ierrc = 0 return c 901 continue ierrc=1 return c 903 continue ierrc=3 return c 911 continue ierrc=11 return c 912 continue ierrc=12 return c 913 continue ierrc=13 return c end subroutine clsst(slon,slat,imon,iday,sst) c This routine interpolates the monthly SST climatology c values to the point (slon,slat) on imon/iday. c common /pncon1/ pi,dtr,ckt2ms,deg2m,eradkm,eradm,rmiss common /climoo/ sstclim,glono1,glato1,dlono,dlato,nxco,nyco common /climot/ ndmo c parameter (mxc=360,myc=181,ntc=12) c dimension sstclim(mxc,myc,ntc) dimension ndmo(ntc) c c Climo only includes 28 days in Feb so adjust Feb 29th idayt = iday if (imon .eq. 2 .and. iday .eq. 29) idayt=28 c c Check for illegal dates if (imon .lt. 1 .or. imon .gt. 12) go to 900 if (idayt .lt. 1 .or. idayt .gt. ndmo(imon)) go to 900 c c Find time weights call tweight(imon,idayt,ndmo,ntc,imon1,imon2,wt1,wt2) c c Find lon,lat array indices of the four points surrounding c the point slon,slat: (i0,j0),(i1,j0),(i0,j1),(i1,j1) and the c weights for linearly interpolating a function to the input point c (w00,w10,w01,w11). call llindx(slon,slat,glono1,glato1,dlono,dlato,nxco,nyco, + i0,i1,j0,j1,w00,w10,w01,w11) c sst1 = w00*sstclim(i0,j0,imon1) + w10*sstclim(i1,j0,imon1) + + w01*sstclim(i0,j1,imon1) + w11*sstclim(i1,j1,imon1) c sst2 = w00*sstclim(i0,j0,imon2) + w10*sstclim(i1,j0,imon2) + + w01*sstclim(i0,j1,imon2) + w11*sstclim(i1,j1,imon2) c sst = wt1*sst1 + wt2*sst2 c return c 900 continue sst = rmiss return c end subroutine tweight(imon,iday,ndmo,ntc,imon1,imon2,wt1,wt2) c This routine calculates the time weights (wt1,wt2) c for linearly interpolating to a date located between c any two months. The indices imon1 and imon2 of the two c months are also returned. c dimension ndmo(ntc) c c Find indices of 2 months closest to input date imon1 = imon rndmo1 = float(ndmo(imon1)) rmid1 = 0.5*(rndmo1+1.0) rday = float(iday) if (rday .ge. rmid1) then imon2 = imon1 + 1 else imon2 = imon1 - 1 endif c c Impose temporal periodicity if (imon2 .eq. 13) imon2 = 1 if (imon2 .eq. 0) imon2 = 12 c rndmo2 = float(ndmo(imon2)) rmid2 = 0.5*(rndmo2+1.0) c c Calculate time weights dcen1 = abs(rmid1-rday) dedg1 = rmid1-dcen1-1.0 dcen2 = rmid2 d1 = dcen1 d2 = dcen2+dedg1 wt1 = d2/(d1+d2) wt2 = d1/(d1+d2) c c write(6,800) imon1,imon2,rndmo1,rndmo2,d1,d2,wt1,wt2 c 800 format('imon1,imon2,rndmo1,rndmo2: ',2(i4),2(f6.0), c + ' d1,d2: ',f6.1,1x,f6.1,' wt1,wt2: '3(f6.2)) c return end subroutine llindx(slon,slat,glon1,glat1,dlon,dlat,nxc,nyc, + i0,i1,j0,j1,w00,w10,w01,w11) c This routine finds the lon,lat indices (i0,j0) of the point to the c lower left of the input point slon,slat. An evenly spaced lat/lon grid c that is periodic in x is assumed, where the point (1,1) corresponds c to (glon1,glat1) and there are (nx,ny) total grid points. For the x c periodicity it is assumed that f(1,j) = f(nxc+1). c c The incides for defining all four points around the input point (i1,j1) c are also calculated as well as the linear interpolation weights for those c 4 points (w00,w10,w01,w11) c c Find the indices of the point to the lower left of the input point i0 = 1 + ifix( (slon-glon1)/dlon ) j0 = 1 + ifix( (slat-glat1)/dlat ) c c Do not let index be outside the domain if (i0 .gt. nxc) i0 = nxc if (i0 .lt. 1) i0 = 1 if (j0 .gt. nyc) j0 = nyc if (j0 .lt. 1) j0 = 1 c c Find indices of the point to the upper right of the input point i1 = i0 + 1 j1 = j0 + 1 c c Do not let index be outside the domain if (i1 .gt. nxc) i1 = nxc if (i1 .lt. 1) i1 = 1 if (j1 .gt. nyc) j1 = nyc if (j1 .lt. 1) j1 = 1 c c Calculate normalized x,y coordinates in the grid cell x = ((slon-glon1) - float(i0-1)*dlon)/dlon y = ((slat-glat1) - float(j0-1)*dlat)/dlat c c Calculate weights w00 = 1 - x - y + x*y w10 = x - x*y w01 = y - x*y w11 = x*y c c write(6,800) slon,slat,i0,i1,j0,j1,x,y,w00,w10,w01,w11 c 800 format(/,'lon,lat,i0,i1,j0,j1: ',2(f6.1,1x),4(i4), c + ' x,y: ',f6.2,1x,f6.2,' w00,10,01,11: ',4(f7.3,1x)) c return end subroutine ampi(cx,cy,vmpi) c This routine adjusts the MPI by a adding a fraction of the c translational speed. c c Input: cx,cy - the components of the motion vector (m/s) c vmpi - the unadjusted MPI in kt c c Output: vmpi - the adjusted MPI in kt c common /pncon1/ pi,dtr,ckt2ms,deg2m,eradkm,eradm,rmiss c spd = sqrt(cx*cx + cy*cy)/ckt2ms c if (spd .le. 0.0) return vmpi = vmpi + 1.5*(spd**0.63) c return end subroutine cluvc(slon,slat,imon,iday,u,v,cappa) c This routine gets the climatological values of u,v (m/s) c and cappa (1/hr) at the point slon,slat on the date imon/iday c parameter (mxc=360,myc=181,ntc=12) c dimension uclim(mxc,myc,ntc),vclim(mxc,myc,ntc),cclim(mxc,myc,ntc) dimension ndmo(ntc) c common /climo/ uclim,vclim,cclim,glon1,glat1,dlon,dlat,nxc,nyc common /climot/ ndmo c common /pncon1/ pi,dtr,ckt2ms,deg2m,eradkm,eradm,rmiss c c Climo only includes 28 days in Feb so adjust Feb 29th idayt = iday if (imon .eq. 2 .and. idayt .eq. 29) idayt=28 c c Check for illegal dates if (imon .lt. 1 .or. imon .gt. 12) go to 900 if (idayt .lt. 1 .or. idayt .gt. ndmo(imon)) go to 900 c c Find time weights call tweight(imon,idayt,ndmo,ntc,imon1,imon2,wt1,wt2) c c Find lon,lat array indices of the four points surrounding c the point slon,slat: (i0,j0),(i1,j0),(i0,j1),(i1,j1) and the c weights for linearly interpolating a function to the input point c (w00,w10,w01,w11). call llindx(slon,slat,glon1,glat1,dlon,dlat,nxc,nyc, + i0,i1,j0,j1,w00,w10,w01,w11) c u1 = w00*uclim(i0,j0,imon1) + w10*uclim(i1,j0,imon1) + + w01*uclim(i0,j1,imon1) + w11*uclim(i1,j1,imon1) c u2 = w00*uclim(i0,j0,imon2) + w10*uclim(i1,j0,imon2) + + w01*uclim(i0,j1,imon2) + w11*uclim(i1,j1,imon2) c u = wt1*u1 + wt2*u2 c v1 = w00*vclim(i0,j0,imon1) + w10*vclim(i1,j0,imon1) + + w01*vclim(i0,j1,imon1) + w11*vclim(i1,j1,imon1) c v2 = w00*vclim(i0,j0,imon2) + w10*vclim(i1,j0,imon2) + + w01*vclim(i0,j1,imon2) + w11*vclim(i1,j1,imon2) c v = wt1*v1 + wt2*v2 c cappa1 = w00*cclim(i0,j0,imon1) + w10*cclim(i1,j0,imon1) + + w01*cclim(i0,j1,imon1) + w11*cclim(i1,j1,imon1) c cappa2 = w00*cclim(i0,j0,imon2) + w10*cclim(i1,j0,imon2) + + w01*cclim(i0,j1,imon2) + w11*cclim(i1,j1,imon2) c cappa = wt1*cappa1 + wt2*cappa2 c return c 900 continue return c end subroutine capinit(rlon00,rlat00,vmx00,rlonm12,rlatm12,vmxm12, + vmpi,iyr,imon,iday,cappa00) c This routine calculates the initial growth rate (cappa00) c using 12 hr persistence. c common /pncon4/ efcp,acc,acp,rnn,beta c c Check to see if the storm is over land now or 12 hr ago. If so, c skip calculation and use climtological growth rate instead. c call dtland(rlon00 ,rlat00 ,dtlnd00) call dtland(rlonm12,rlatm12,dtlndm12) c if (dtlnd00 .lt. 0.0 .or. dtlndm12 .lt. 0.0) then cappa00 = 0.01 else cappa00 = beta*(vmx00/vmpi)**rnn + + (1.0/vmx00)*(vmx00-vmxm12)/12.0 endif c return end subroutine capcal(slon,slat,t,imon,iday, + iftype,cappap,cappac,wcp,wcc, + cappa) c This routine calculates the growth rate cappa as a weighted c average between persistence and climatology c c Input: c slon: storm longitude ( 0 to 360) c slat: storm latitude (-90 to 90) c t : forecast time (hr) c imon: Month (1-12) c iday: Day of the month (1-31) c iftype: Method for averaging persistence and climatology c (=0 for persistence, =1 for climo, =2 for time weighted average) c cappap: t=0 growth rate (1/hr) c c Output: c cappac: Climatological growth rate c wcp: Weight on persistence growth rate c wcc: Weight on climo growth ratec c cappa: Combined persistence and climo growth rate c common /pncon4/ efcp,acc,acp,rnn,beta c c Calculate climatological growth rate call cluvc(slon,slat,imon,iday,cxc,cyc,cappac) c c Calcuate the climatology and persistence weights if (iftype .eq. 0) then wcp = 1.0 wcc = 0.0 elseif (iftype .eq. 1) then wcp = 0.0 wcc = 1.0 else wcp = acp*exp(-t*efcp) wcc = acc*(1.0-wcp) endif c cappa = wcp*cappap + wcc*cappac c return end subroutine rmpi(sstmin,vmpimin,sstzer,vmpizer,sst,vmpi) c This routine reduces linearly reduces mpi to vmpizer by c sst=sstzer if sst < sstmin. c if (sst .ge. sstmin) then return elseif (sst .le. sstzer) then vmpi = vmpizer else vmpi = vmpizer + (sst-sstzer)*(vmpimin-vmpizer)/(sstmin-sstzer) endif c return end