program cliper5 !** This program runs the 5-day CLIPER forecast for the Atantic !** and east Pacific basins. ! Modifed 10/7/2016 - M. DeMaria and C. Mattocks for 11 to 15 ! output times in ifpclip5 array. ! Modifications: ! 6/4/21 (J. Dostalek) Started this Fortran 90 version ! 1/31/23 (J. Dostalek) This Fortran 90 version was created somewhat ! quickly to include in the February 2023 delivery to NHC. It gives the same ! results as the FORTRAN 77 version using al072022.com, ep122021.com, and ! cp012018.com as input, but will need some additional work to complete the ! goals of the f77 to f90 conversion. ! ------------------------------------------------------------------------------ implicit none include 'dataformats.inc' common/clip5/ifpclip5(15, 3) real :: latcur, loncur, wndcur, dircur, spdcur character(len=8) :: strmid character(len=4) :: techname character(len=10) :: aymdh character(len=50) :: input_file integer :: ifpclip5 integer :: i, j integer :: ios integer :: istat integer :: iymdh type(AID_DATA) comRcd, tauData ! ** Zero the final array do i = 1, 15 do j = 1, 3 ifpclip5(i, j) = 0 end do end do ! ** Get the command line parameter and the storms directory path call getarg(1, input_file) strmid = input_file(1:8) ! ** Open the input file open (21, file=input_file, status='old', iostat=ios, err=1010) ! ** Read in the compute data and close the file call getARecord(21, "CARQ", comRcd, istat) close (21) if (istat == 0) then print *, ' ERROR - reading file = ', input_file, ' istat = ', istat stop end if ! ** Read in the current data call getSingleTAU(comRcd, 0, tauData, istat) if (istat /= 1) then print *, ' ERROR - reading data = ', input_file, ' istat = ', istat stop end if aymdh = tauData%aRecord(1)%DTG read (tauData%aRecord(1)%DTG, '(i10)') iymdh latcur = tauData%aRecord(1)%lat loncur = tauData%aRecord(1)%lon wndcur = tauData%aRecord(1)%vmax dircur = float(tauData%aRecord(1)%dir) spdcur = float(tauData%aRecord(1)%speed) write (*, 1) strmid 1 format(' 5-DAY CLIPER forecast for ', a8, //) call CLIP_5(iymdh, latcur, loncur, wndcur, dircur, spdcur, strmid) ! ** Open the output file, write out the data and close the file open (31, file='cliper5.dat', status='unknown') !** Write the forecasts to a temporary adeck for merging with the ! ** actual adeck and close the file techname = 'CLP5' call newWriteAidRcd(31, strmid, aymdh, techname, ifpclip5) close (31) stop '***** 5-DAY CLIPER FORECASTS ARE FINISHED *****' !** Error messages 1010 print *, ' ERROR - opening file = ', input_file, ' istat = ', istat stop end !************************************************************************** subroutine clip_5(ymdh, latcur, loncur, wndcur, dircur, spdcur, strmid) !** written by Sim Aberson !** NOAA/AOML/Hurricane Research Division !** 1-APR-1998 !** Modified by Jim Gross 98/04/24 by changing arthmitic to floating !** point, finding an error, and combining the Atlantic and east !** Pacific into one 5_day CLIPER model !** Made operational by Jim Gross 01/05/17 !** Added limits on days and new dated regression coefficient files !** Jim Gross 05/04/22 ! Modifications: ! 6/4/21 (J. Dostalek) Started this Fortran 90 version !------------------------------------------------------------------------------- implicit none integer, intent(in) :: ymdh real, intent(in) :: latcur real, intent(in) :: loncur real, intent(in) :: wndcur real, intent(in) :: dircur real, intent(in) :: spdcur character(len=8), intent(in) :: strmid integer, parameter :: nvar = 27 real, dimension(2, 10) :: fpclip real :: wind real :: rdir, rspd real :: days real :: ucmp, vcmp real, dimension(12) :: jday real, dimension(40) :: acon real, dimension(40, nvar) :: coef real, dimension(nvar) :: x real, dimension(20) :: disp real :: fprite character(len=2) :: basin character(len=1) :: ew character(len=3), dimension(10) :: ftime character(len=256) include_path, al_file, gm_file, ep_file character(len=128) cof_location real :: degrad integer :: ios integer :: iyr, imo, ida, ihr integer :: i, j, k, klij, ijkl, jkli integer :: ifpclip5 common/clip5/ifpclip5(15, 3) ! ** LIST CONSTANTS FOR MERIDIONAL DISPLACEMENTS. data FTIME/' 12', ' 24', ' 36', ' 48', ' 60', ' 72', ' 84', ' 96', '108', & '120'/ 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/ degrad = atan(1.0)/45.0 ! ** WRITE THE INPUT PARAMETER TO THE PRINTER write (*, '(/,'' 5-DAY CLIPER '',/)') write (*, '('' INPUT PARAMETERS FOR TROPICAL CYCLONE '',A, '' ON YMDH = '' & ,I10.10,/)') STRMID, YMDH write (*, '('' LATCUR = '',F4.1,''N LONCUR = '',F5.1, ''W DIRCUR = '', & F4.0,'' DEG SPDCUR = '',F3.0, '' KT'',/,'' WNDCUR = '',F4.0,'' KT'',//)') & latcur, loncur, dircur, spdcur, wndcur basin = strmid(1:2) !** Open, read and write out regression coefficients file !** Get the include directory path ! call getenv ( "ATCFINC", include_path ) ! Use on the ATCF ! include_path = '/tpcprd/atcf_unix/prgms_white/cliper5' ! Use on the IBM ! include_path = 'include' ! Use locally call getenv("CLIPER5_COEF", cof_location) if (basin == 'al') then al_file = trim(cof_location)//'/clp5_al3104coeff.dat' open (21, file=al_file, status='old', iostat=ios, err=1010) gm_file = trim(cof_location)//'/clp5_gm3104coeff.dat' open (22, file=gm_file, status='old', iostat=ios, err=1020) do i = 1, 20 read (21, 1, iostat=ios, err=1030) acon(i), (coef(i, j), j=1, nvar) 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, nvar) end do close (21) close (22) else ep_file = trim(cof_location)//'/clp5_ep4904coeff.dat' open (21, file=ep_file, status='old', iostat=ios, err=1040) do i = 1, 20 read (21, 1, iostat=ios, err=1030) acon(i), (coef(i, j), j=1, nvar) end do close (21) end if iyr = ymdh/1000000 imo = ymdh/10000 - iyr*100 ida = ymdh/100 - imo*100 - iyr*10000 ihr = ymdh - ida*100 - imo*10000 - iyr*1000000 days = jday(imo) + real(ida) + real(ihr)/24.0 if (basin == 'al' .and. days < 152.0) days = 152.0 if (basin /= 'al' .and. days < 135.0) days = 135.0 if (days > 334.0) days = 334.0 wind = wndcur*111.1*1000.0/(60.0*3600.0) rdir = dircur + 180.0 if (rdir >= 360.0) rdir = rdir - 360.0 rspd = spdcur*111.1*1000.0/(60.0*3600.0) call uvcomp(rdir, rspd, ucmp, vcmp) ucmp = -ucmp x(1) = latcur x(2) = loncur x(3) = wind x(4) = days x(5) = vcmp x(6) = ucmp klij = 6 do ijkl = 1, 6 do jkli = ijkl, 6 klij = klij + 1 x(klij) = x(ijkl)*x(jkli) end do end do do i = 1, 20 disp(i) = acon(i) if (basin == 'al') then if (latcur < loncur - 64.0) disp(i) = acon(i + 20) end if end do do i = 1, 20 do j = 1, nvar if (basin == 'al') then if (latcur >= loncur - 64.0) then disp(i) = disp(i) + x(j)*coef(i, j) else disp(i) = disp(i) + x(j)*coef(i + 20, j) end if else disp(i) = disp(i) + x(j)*coef(i, j) end if end do end do fpclip(1, 1) = latcur + disp(1) do i = 2, 10 fpclip(1, i) = fpclip(1, i - 1) + disp(i) end do 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) end do ! ** WRITE 5-DAY CLIPER POSITION FORECAST TO THE PRINTER write (*, '('' FORECAST POSITIONS'',/)') write (*, '('' 00 HR = '',F5.1,'' N '',F6.1,'' W'')') latcur, loncur ! ** Form the integer values for the adeck do K = 1, 10 ifpclip5(k + 1, 1) = int(fpclip(1, k)*10.0 + 0.5) ifpclip5(k + 1, 2) = int(fpclip(2, k)*10.0 + 0.5) end do ! ** Write out the forecast for the correct hemisphere do k = 1, 10 EW = 'W' FPRITE = abs(FPCLIP(2, k)) if (FPCLIP(2, k) < 0.0) then EW = 'E' FPCLIP(2, k) = 360.0 + FPCLIP(2, k) end if write (*, '( 1X, A3, '' HR = '', F5.1, '' N '', F6.1, 1X, A )') FTIME(K), & FPCLIP(1, k), FPRITE, EW end do return 1010 print *, ' error opening alcoff.dat = ', ios, al_file stop 1020 print *, ' error opening gmcoff.dat = ', ios, gm_file stop 1030 print *, ' error reading alcoff.dat, gmcoff.dat or epcoff.dat = ', ios stop 1040 print *, ' error opening epcoff.dat = ', ios, ep_file stop end subroutine clip_5 !********************************************************************** subroutine uvcomp(dir, spd, u, v) ! Modifications: ! 6/4/21 (J. Dostalek) Started this Fortran 90 version !------------------------------------------------------------------------------- implicit none real, intent(in) :: dir real, intent(in) :: spd real, intent(out) :: u real, intent(out) :: v real :: degrad, dirdg, dirrd degrad = atan(1.0)/45.0 dirdg = 270.0 - dir if (dirdg < 0.0) then dirdg = dirdg + 360.0 end if dirrd = dirdg*degrad u = spd*cos(dirrd) v = spd*sin(dirrd) return end subroutine uvcomp