diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d161862 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +# ignore ALL .log files +*.log + +*.o +*.mod +*.exe + diff --git a/README.md b/README.md index e574fc9..615660f 100644 --- a/README.md +++ b/README.md @@ -1 +1,3 @@ # SPEEDY-ML + +Fortran code for a hybrid model that combines an atmospheric general circulation model (SPEEDY) and a reservoir computing-based machine learning algorithm. diff --git a/src/at_gcm.f90 b/src/at_gcm.f90 new file mode 100755 index 0000000..f6dc46f --- /dev/null +++ b/src/at_gcm.f90 @@ -0,0 +1,108 @@ +module speedy_main + +contains + +subroutine agcm_main(input_ndays,start_from_file,internal_state_vector) + use mod_tsteps, only: ndaysl, ihout, nmonts, sixhrrun + use mod_utilities, only : state_vector_type + + implicit none + + ! program : agcm_main + integer, intent(in) :: input_ndays, start_from_file + type(state_vector_type), intent(inout), optional :: internal_state_vector + + ! experiment identifier + character(len=3) :: cexp = 'exp' + integer :: jday, ndays + + ! 1. initialization + ! ndays = no. of integration days, set by agcm_init + if(present(internal_state_vector)) then + print *, 'starting with interal_state_vector' + call agcm_init(cexp, 0, 0, 0, ndays,start_from_file,internal_state_vector) + else + call agcm_init(cexp, 0, 0, 0, ndays,start_from_file,internal_state_vector) + endif + + ! 2. do loop over total no. of integration days + if(present(internal_state_vector)) then + ndays = input_ndays + endif + + ndays = input_ndays + print *, 'integration length in days: ', ndays + + if(present(internal_state_vector)) then + if(internal_state_vector%is_safe_to_run_speedy) then + do jday = 1, ndays + ! 2.2 run atmospheric model for 1 day + call agcm_1day(jday, cexp) + + ! 2.1 exchange data with coupler + call agcm_to_coupler(jday) + call coupler_to_agcm(jday) + + enddo + endif + else + do jday = 1, ndays + ! 2.2 run atmospheric model for 1 day + call agcm_1day(jday, cexp) + + ! 2.1 exchange data with coupler + call agcm_to_coupler(jday) + call coupler_to_agcm(jday) + + enddo + endif + + ! Restart dataset is only written at the end + !call restart(2) +end subroutine + +subroutine agcm_1day(jday, cexp) + ! subroutine agcm_1day (jday) + ! + ! perform atm. model integration for 1 day, + ! post-proc. and i/o at selected times + + use mod_tsteps, only: nsteps, idout, nstout, ihout + use mod_date, only: iyear, imonth, iday, ndaytot, newdate + + implicit none + + integer, intent(in) :: jday + character(len=3), intent(in) :: cexp + integer :: istep + + if (iday == 1) print *, ' start of year/month = ', iyear, imonth + + istep = 1 + (jday - 1) * nsteps + + ! 1. set forcing terms according to date + call fordate(1) + + ! 2. set daily-average flux arrays to zero + call dmflux(0) + + ! 3. integrate the atmospheric model for 1 day + call stloop(istep) + + ! 4. write daily-mean output + !call dmout(idout) + + ! 5. write time-mean output files and restart file at the end of selected + ! months + !if (iday == 1) then + ! write monthly-mean output for previous month + ! if (ihout .eqv. .false.) then + ! if (nstout < 0) call tmout(1) + ! end if + + ! open new output files at the beginning of each year + ! if (imonth == 1 .and. jday < ndaytot .and. (ihout .eqv. .false.)) call setgrd(1, cexp) + !endif +end subroutine + +end module speedy_main diff --git a/src/cpl_bcinterp.f90 b/src/cpl_bcinterp.f90 new file mode 100755 index 0000000..9cb0776 --- /dev/null +++ b/src/cpl_bcinterp.f90 @@ -0,0 +1,60 @@ +subroutine forint(ngp,imon,fmon,for12,for1) + ! Aux. routine FORINT : linear interpolation of monthly-mean forcing + + implicit none + + integer, intent(in) :: ngp, imon + real, intent(in) :: fmon, for12(ngp,*) + real, intent(inout) :: for1(ngp) + integer :: imon2 + real :: wmon + + if (fmon.le.0.5) then + imon2 = imon-1 + if (imon.eq.1) imon2 = 12 + wmon = 0.5-fmon + else + imon2 = imon+1 + if (imon.eq.12) imon2 = 1 + wmon = fmon-0.5 + end if + + for1 = for12(:,imon) + wmon*(for12(:,imon2) - for12(:,imon)) +end + +subroutine forin5(ngp,imon,fmon,for12,for1) + ! Aux. routine FORIN5 : non-linear, mean-conserving interpolation + ! of monthly-mean forcing fields + + implicit none + + integer, intent(in) :: ngp, imon + real, intent(in) :: fmon, for12(ngp,12) + real, intent(inout) :: for1(ngp) + integer :: im1, im2, ip1, ip2 + real :: c0, t0, t1, t2, t3, wm1, wm2, w0, wp1, wp2 + + im2 = imon-2 + im1 = imon-1 + ip1 = imon+1 + ip2 = imon+2 + + if (im2.lt.1) im2 = im2+12 + if (im1.lt.1) im1 = im1+12 + if (ip1.gt.12) ip1 = ip1-12 + if (ip2.gt.12) ip2 = ip2-12 + + c0 = 1./12. + t0 = c0*fmon + t1 = c0*(1.-fmon) + t2 = 0.25*fmon*(1-fmon) + + wm2 = -t1 +t2 + wm1 = -c0 +8*t1 -6*t2 + w0 = 7*c0 +10*t2 + wp1 = -c0 +8*t0 -6*t2 + wp2 = -t0 +t2 + + for1 = wm2*for12(:,im2) + wm1*for12(:,im1) + w0*for12(:,imon) +& + & wp1*for12(:,ip1) + wp2*for12(:,ip2) +end diff --git a/src/cpl_land.f90 b/src/cpl_land.f90 new file mode 100755 index 0000000..930d31b --- /dev/null +++ b/src/cpl_land.f90 @@ -0,0 +1,123 @@ +subroutine ini_land(istart) + ! subroutine ini_land (istart) + ! + ! Input : istart = restart flag ( 0 = no, 1 = yes) + + use mod_atparam + use mod_var_land, only: stlcl_ob, stl_lm + + implicit none + + integer, intent(in) :: istart + + ! 1. Compute climatological fields for initial date + call atm2land(0) + + ! 2. Initialize prognostic variables of land model + ! in case of no restart or no coupling + if (istart.le.0 .or. istart == 2) then + stl_lm(:) = stlcl_ob(:) ! land sfc. temperature + end if + + ! 3. Compute additional land variables + call land2atm(0) +end + +subroutine atm2land(jday) + use mod_cpl_flags, only: icland + use mod_atparam + use mod_cpl_land_model, only: vland_input + use mod_flx_land, only: hflux_l + use mod_cli_land, only: stl12, snowd12, soilw12 + use mod_date, only: imont1, tmonth + use mod_var_land, only: stlcl_ob, snowdcl_ob, soilwcl_ob, stl_lm + + implicit none + + integer, intent(in) :: jday + integer, parameter :: nlon=ix, nlat=il, ngp=nlon*nlat + + ! 1. Interpolate climatological fields to actual date + + ! Climatological land sfc. temperature + call forin5(ngp,imont1,tmonth,stl12,stlcl_ob) + + ! Climatological snow depth + call forint(ngp,imont1,tmonth,snowd12,snowdcl_ob) + + ! Climatological soil water availability + call forint(ngp,imont1,tmonth,soilw12,soilwcl_ob) + + if (jday.le.0) return + + ! 2. Set input variables for mixed-layer/ocean model + if (icland.gt.0) then + vland_input(:,1) = stl_lm(:) + vland_input(:,2) = hflux_l(:) + vland_input(:,3) = stlcl_ob(:) + end if + + ! 3. Call message-passing routines to send data (if needed) +end + +subroutine land2atm(jday) + use mod_cpl_flags, only: icland + use mod_atparam + use mod_cpl_land_model, only: land_model, vland_output + use mod_var_land + + implicit none + + integer, intent(in) :: jday + + if (jday.gt.0.and.icland.gt.0) then + ! 1. Run ocean mixed layer or + ! call message-passing routines to receive data from ocean model + call land_model + + ! 2. Get updated variables for mixed-layer/ocean model + stl_lm(:) = vland_output(:,1) ! land sfc. temperature + end if + + ! 3. Compute land-sfc. fields for atm. model + ! 3.1 Land sfc. temperature + if (icland.le.0) then + ! Use observed climatological field + stl_am(:) = stlcl_ob(:) + else + ! Use land model sfc. temperature + stl_am(:) = stl_lm(:) + end if + + ! 3.2 Snow depth and soil water availability + snowd_am(:) = snowdcl_ob(:) + soilw_am(:) = soilwcl_ob(:) +end + +subroutine rest_land(imode) + ! subroutine rest_land (imode) + + ! Purpose : read/write land variables from/to a restart file + ! Input : IMODE = 0 : read model variables from a restart file + ! = 1 : write model variables to a restart file + + use mod_cpl_flags, only: icland + use mod_atparam + use mod_var_land, only: stl_am, stl_lm + + implicit none + + integer, intent(in) :: imode + + if (imode.eq.0) then + read (3) stl_lm(:) ! Land sfc. temperature + else + ! Write land model variables from coupled runs, + ! otherwise write fields used by atmospheric model + if (icland.gt.0) then + write (10) stl_lm(:) + else + write (10) stl_am(:) + end if + end if +end diff --git a/src/cpl_main_interface.f90 b/src/cpl_main_interface.f90 new file mode 100755 index 0000000..e9685d1 --- /dev/null +++ b/src/cpl_main_interface.f90 @@ -0,0 +1,59 @@ +subroutine ini_coupler(istart) + ! + ! subroutine ini_coupler (istart) + ! + + use mod_atparam + use mod_cpl_land_model, only: land_model_init + use mod_surfcon, only: fmask, alb0 + use mod_cli_land, only: fmask_l + use mod_cli_sea, only: fmask_s, deglat_s + + implicit none + + integer, intent(in) :: istart + + ! 1.1 initialize land model constants + call land_model_init(fmask_l,alb0) + + ! 1.2 initialize land model variables + call ini_land(istart) + + ! 2.1 initialize sea and ice model constants + call sea_model_init(fmask_s,deglat_s) + + ! 2.2 initialize sea and ice model variables + call ini_sea(istart) +end + +subroutine agcm_to_coupler(jday) + ! + ! subroutine agcm_to_coupler (jday) + ! + + implicit none + + integer, intent(in) :: jday + + ! 1. send fields to land model + call atm2land(jday) + + ! 2. send fields to sea and ice model + call atm2sea(jday) +end + +subroutine coupler_to_agcm(jday) + ! + ! subroutine coupler_to_agcm (jday) + ! + + implicit none + + integer, intent(in) :: jday + + ! 1. get updated fields from land model + call land2atm(jday) + + ! 2. get updated fields from sea and ice model + call sea2atm(jday) +end diff --git a/src/cpl_sea.f90 b/src/cpl_sea.f90 new file mode 100755 index 0000000..537a5d4 --- /dev/null +++ b/src/cpl_sea.f90 @@ -0,0 +1,278 @@ +subroutine ini_sea(istart) + ! subroutine ini_sea(istart) + + ! Input : istart = restart flag ( 0 = no, 1 = yes) + + use mod_cpl_flags, only: icsea + use mod_atparam + use mod_cli_sea, only: deglat_s + use mod_var_sea + + use mpires, only : internal_state_vector + use mod_io, only : write_netcdf_2d + + implicit none + + integer, intent(in) :: istart + real, allocatable :: diff(:), temp(:), temp2d(:,:) + real :: bias + + ! 1. Compute climatological fields for initial date + call atm2sea(0) + + ! 2. Initialize prognostic variables of ocean/ice model + ! in case of no restart or no coupling + !sstcl_ob = sstcl_ob + 2.0 !THIS NEEDS TO BE CHANGED TROY SST TODO NOTE + sst_om(:) = sstcl_ob(:) ! SST + tice_om(:) = ticecl_ob(:) ! sea ice temperature + sice_om(:) = sicecl_ob(:) ! sea ice fraction + + if (icsea.le.0) sst_om(:) = 0. + + ! 3. Compute additional sea/ice variables + wsst_ob(:) = 0. + if (icsea.ge.4) call sea_domain('elnino',deglat_s,wsst_ob) + + call sea2atm(0) + + if(internal_state_vector%hybrid_slab) then + temp = reshape(internal_state_vector%sst_hybrid,[ix*il]) + diff = sst_am - temp + where(diff < 6.0) + sst_am = temp + internal_state_vector%sst_bias + end where + sst_am(:) = sst_am(:)+sice_am(:)*(tice_am(:)-sst_am(:)) + endif + sst_am(:) = sst_am(:) + internal_state_vector%sst_bias +end + +subroutine atm2sea(jday) + ! subroutine atm2sea(jday) + + use mod_cpl_flags, only: icsea, icice, isstan + use mod_atparam + use mod_cplvar_sea, only: vsea_input + use mod_date, only: iday, imont1, tmonth + use mod_flx_sea, only: hflux_s, hflux_i + use mod_cli_sea, only: fmask_s, sst12, sice12, sstan3, hfseacl, sstom12 + use mod_var_sea, only: sstcl_ob, sicecl_ob, ticecl_ob, sstan_ob, sstcl_om,& + & sst_om, tice_om + + implicit none + + integer, intent(in) :: jday + integer, parameter :: nlon=ix, nlat=il, ngp=nlon*nlat + + real :: fmasks(ngp) ! sea fraction + real :: hfyearm(ngp) ! annual mean heat flux into the ocean + integer :: j + real :: sstcl0, sstfr + + ! 1. Interpolate climatological fields and obs. SST anomaly + ! to actual date + + ! Climatological SST + call forin5(ngp,imont1,tmonth,sst12,sstcl_ob) + + ! Climatological sea ice fraction + call forint(ngp,imont1,tmonth,sice12,sicecl_ob) + + ! SST anomaly + if (isstan.gt.0) then + if (iday.eq.1.and.jday.gt.0) call OBS_SSTA + call forint (ngp,2,tmonth,sstan3,sstan_ob) + end if + + ! Ocean model climatological SST + if (icsea.ge.3) then + call forin5 (ngp,imont1,tmonth,sstom12,sstcl_om) + end if + + ! Adjust climatological fields over sea ice + + ! SST at freezing point + sstfr = 273.2-1.8 + + do j=1,ngp + sstcl0 = sstcl_ob(j) + + if (sstcl_ob(j).gt.sstfr) then + sicecl_ob(j) = min(0.5,sicecl_ob(j)) + ticecl_ob(j) = sstfr + if (sicecl_ob(j).gt.0.) then + sstcl_ob(j) = sstfr+(sstcl_ob(j)-sstfr)/(1.-sicecl_ob(j)) + end if + else + sicecl_ob(j) = max(0.5,sicecl_ob(j)) + ticecl_ob(j) = sstfr+(sstcl_ob(j)-sstfr)/sicecl_ob(j) + !ticecl_ob(j) = sstcl_ob(j) + sstcl_ob(j) = sstfr + end if + + if (icsea.ge.3) sstcl_om(j) = sstcl_om(j)+(sstcl_ob(j)-sstcl0) + end do + + hfyearm = reshape(hfseacl, (/ngp/)) + fmasks = reshape(fmask_s, (/ngp/)) + + if (jday.le.0) return + ! 2. Set input variables for mixed-layer/ocean model + if (icsea.gt.0.or.icice.gt.0) then + vsea_input(:,1) = sst_om(:) + vsea_input(:,2) = tice_om(:) + vsea_input(:,3) = sicecl_ob(:) + !vsea_input(:,4) = hflux_s(:)*fmasks(:) + !vsea_input(:,5) = hflux_i(:)*fmasks(:) + vsea_input(:,4) = hflux_s(:) + vsea_input(:,5) = hflux_i(:) + vsea_input(:,6) = sstcl_ob(:) + vsea_input(:,7) = ticecl_ob(:) + !vsea_input(:,8) = hfyearm(:)*fmasks(:) + vsea_input(:,8) = hfyearm(:) + end if + + ! 3. Call message-passing routines to send data (if needed) +end + +subroutine sea2atm(jday) + ! subroutine sea2atm(jday) + + use mod_cpl_flags, only: icsea, icice, isstan + use mod_atparam + use mod_cplvar_sea, only: vsea_output + use mod_var_sea + + implicit none + + integer, intent(in) :: jday + + if (jday.gt.0.and.(icsea.gt.0.or.icice.gt.0)) then + ! 1. Run ocean mixed layer or + ! call message-passing routines to receive data from ocean model + call sea_model + + ! 2. Get updated variables for mixed-layer/ocean model + sst_om(:) = vsea_output(:,1) ! sst + tice_om(:) = vsea_output(:,2) ! sea ice temperature + sice_om(:) = vsea_output(:,3) ! sea ice fraction + + !sice_om(:) = sicecl_ob(:) + end if + + ! 3. Compute sea-sfc. anomalies and full fields for atm. model + ! 3.1 SST + sstan_am(:) = 0. + + if (icsea.le.1) then + if (isstan.gt.0) sstan_am(:) = sstan_ob(:) + + ! Use observed SST (climatological or full field) + sst_am(:) = sstcl_ob(:) + sstan_am(:) + else if (icsea.eq.2) then + ! Use full ocean model SST + sst_am(:) = sst_om(:) + else if (icsea.ge.3) then + ! Define SST anomaly from ocean model ouput and climatology + sstan_am(:) = sst_om(:) - sstcl_om(:) + + ! Merge with observed SST anomaly in selected area + if (icsea.ge.4) then + sstan_am(:) = sstan_am(:) + wsst_ob(:)*(sstan_ob(:)-sstan_am(:)) + end if + + ! Add observed SST climatology to model SST anomaly + sst_am(:) = sstcl_ob(:) + sstan_am(:) + end if + + ! 3.2 Sea ice fraction and temperature + if (icice.gt.0) then + sice_am(:) = sice_om(:) + tice_am(:) = tice_om(:) + else + sice_am(:) = sicecl_ob(:) + tice_am(:) = ticecl_ob(:) + end if + + sst_am(:) = sst_am(:)+sice_am(:)*(tice_am(:)-sst_am(:)) + ssti_om(:) = sst_om(:)+sice_am(:)*(tice_am(:)-sst_om(:)) +end + +subroutine rest_sea(imode) + ! subroutine rest_sea(imode) + + ! Purpose : read/write sea variables from/to a restart file + ! Input : IMODE = 0 : read model variables from a restart file + ! = 1 : write model variables to a restart file + + use mod_cpl_flags, only: icsea, icice + use mod_atparam + use mod_var_sea, only: sst_om, tice_om, sice_om, sst_am, tice_am, sice_am + + implicit none + + integer, intent(in) :: imode + integer, parameter :: nlon=ix, nlat=il, ngp=nlon*nlat + + real :: sst_c(ngp) ! sst corrected for sea-ice values + real :: sstfr + + if (imode.eq.0) then + read (3) sst_om(:) ! sst + read (3) tice_om(:) ! sea ice temperature + read (3) sice_om(:) ! sea ice fraction + else + ! write sea/ice model variables from coupled runs, + ! otherwise write fields used by atmospheric model + sstfr = 273.2-1.8 + + if (icsea.gt.0) then + write (10) sst_om(:) + else + sst_c(:) = max(sst_am(:),sstfr) + write (10) sst_c(:) + end if + + if (icice.gt.0) then + write (10) tice_om(:) + write (10) sice_om(:) + else + write (10) tice_am(:) + write (10) sice_am(:) + end if + end if +end + +subroutine obs_ssta + ! subroutine obs_ssta + + ! Purpose : update observed SST anomaly array + + use mod_atparam + use mod_cli_sea, only: sstan3, bmask_s + use mod_date, only: imonth + use mod_tsteps, only: iyear0, issty0 + + implicit none + + integer :: i, j, next_month + integer, parameter :: nlon = ix, nlat = il, ngp = ix*il + real :: inp(nlon,nlat) + + sstan3(:,:,1) = sstan3(:,:,2) + sstan3(:,:,2) = sstan3(:,:,3) + + ! Compute next month given initial SST year + next_month = (iyear0 - issty0) * 12 + imonth + + ! Read next month SST anomalies + call load_boundary_file(1,30,inp,next_month-1) + + sstan3(1:nlon,1:nlat,3) = inp + + call forchk(bmask_s,sstan3(1,1,3),nlon*nlat,1,-50.,50.,0.) + + 100 continue + + print *, ' warning: end-of-file reached on ssT anomaly file' + print *, ' sst anomaly will be kept constant' +end diff --git a/src/cpl_sea_model.f90 b/src/cpl_sea_model.f90 new file mode 100755 index 0000000..bc2a9c6 --- /dev/null +++ b/src/cpl_sea_model.f90 @@ -0,0 +1,301 @@ +subroutine sea_model_init(fmask_s,rlat) + ! subroutine sea_model_init (fmask_s,rlat) + ! + ! Purpose : Initialization of sea model + ! Initialized common blocks: sea_mc + + use mod_atparam + use mod_cplcon_sea + + implicit none + + integer, parameter :: nlon=ix, nlat=il, ngp=nlon*nlat + + ! Input variables + real fmask_s(nlon,nlat) ! sea mask (fraction of sea) + real rlat(nlat) ! latitudes in degrees + + ! Auxiliary variables + + ! Domain mask + real :: dmask(nlon,nlat) + + ! Domain flags + logical :: l_globe, l_northe, l_natlan, l_npacif, l_tropic, l_indian + + ! Heat capacity of mixed-l + real :: hcaps(nlat) + + ! Heat capacity of sea-ice + real :: hcapi(nlat) + + integer :: i, j + real :: coslat, crad + + ! 1. Set geographical domain, heat capacities and dissipation times + ! for sea (mixed layer) and sea-ice + + ! Model parameters (default values) + + ! ocean mixed layer depth: d + (d0-d)*(cos_lat)^3 + real :: depth_ml = 60. ! High-latitude depth + real :: dept0_ml = 40. ! Minimum depth (tropics) + + ! sea-ice depth : d + (d0-d)*(cos_lat)^2 + real :: depth_ice = 2.5 ! High-latitude depth + real :: dept0_ice = 1.5 ! Minimum depth + + ! Dissipation time (days) for sea-surface temp. anomalies + real :: tdsst = 90. + + ! Dissipation time (days) for sea-ice temp. anomalies + real :: dice = 30. + + ! Minimum fraction of sea for the definition of anomalies + real :: fseamin = 1./3. + + ! Dissipation time (days) for sea-ice temp. anomalies + real :: tdice + + ! Geographical domain + ! note : more than one regional domain may be set .true. + l_globe = .true. ! global domain + l_northe = .false. ! Northern hem. oceans (lat > 20N) + l_natlan = .false. ! N. Atlantic (lat 20-80N, lon 100W-45E) + l_npacif = .false. ! N. Pacific (lat 20-80N, lon 100E-100W) + l_tropic = .false. ! Tropics (lat 30S-30N) + l_indian = .false. ! Indian Ocean (lat 30S-30N, lon 30-120E) + + ! Reset model parameters + include "cls_insea.h" + + ! Heat capacities per m^2 (depth*heat_cap/m^3) + crad=asin(1.)/90. + do j=1,nlat + coslat = cos(crad*rlat(j)) + hcaps(j) = 4.18e+6*(depth_ml +(dept0_ml -depth_ml) *coslat**3) + hcapi(j) = 1.93e+6*(depth_ice+(dept0_ice-depth_ice)*coslat**2) + end do + + ! 3. Compute constant parameters and fields + + ! Set domain mask + if (l_globe) then + dmask(:,:) = 1. + else + dmask(:,:) = 0. + if (l_northe) call SEA_DOMAIN ('northe',rlat,dmask) + !fkif (l_arctic) call SEA_DOMAIN ('arctic',rlat,dmask) + if (l_natlan) call SEA_DOMAIN ('natlan',rlat,dmask) + if (l_npacif) call SEA_DOMAIN ('npacif',rlat,dmask) + if (l_tropic) call SEA_DOMAIN ('tropic',rlat,dmask) + if (l_indian) call SEA_DOMAIN ('indian',rlat,dmask) + end if + + ! Smooth latitudinal boundaries and blank out land points + do j=2,nlat-1 + rhcaps(:,j) = 0.25*(dmask(:,j-1)+2*dmask(:,j)+dmask(:,j+1)) + end do + dmask(:,2:nlat-1) = rhcaps(:,2:nlat-1) + + do j=1,nlat + do i=1,nlon + if (fmask_s(i,j).lt.fseamin) dmask(i,j) = 0 + end do + end do + + ! Set heat capacity and dissipation time over selected domain + do j=1,nlat + rhcaps(:,j) = 86400./hcaps(j) + rhcapi(:,j) = 86400./hcapi(j) + end do + + cdsea = dmask*tdsst/(1.+dmask*tdsst) + cdice = dmask*tdice/(1.+dmask*tdice) +end + +subroutine sea_model + ! subroutine sea_model + + ! Purpose : Integrate slab ocean and sea-ice models for one day + + use mod_atparam + use mod_cplcon_sea + use mod_cplvar_sea + + implicit none + + integer, parameter :: nlon=ix, nlat=il, ngp=nlon*nlat + + !real vsea_input(nlon,nlat,8), vsea_output(nlon,nlat,3) + + ! Input variables: + real :: sst0(nlon,nlat) ! SST at initial time + real :: tice0(nlon,nlat) ! sea ice temp. at initial time + real :: sice0(nlon,nlat) ! sea ice fraction at initial time + real :: hfsea(nlon,nlat) ! sea+ice sfc. heat flux between t0 and t1 + real :: hfice(nlon,nlat) ! ice-only sfc. heat flux between t0 and t1 + + real :: sstcl1(nlon,nlat) ! clim. SST at final time + real :: ticecl1(nlon,nlat) ! clim. sea ice temp. at final time + real :: hfseacl(nlon,nlat) ! clim. heat flux due to advection/upwelling + + ! Output variables + real :: sst1(nlon,nlat) ! SST at final time + real :: tice1(nlon,nlat) ! sea ice temp. at final time + real :: sice1(nlon,nlat) ! sea ice fraction at final time + + ! Auxiliary variables + real :: hflux(nlon,nlat) ! net sfc. heat flux + real :: tanom(nlon,nlat) ! sfc. temperature anomaly + real :: cdis(nlon,nlat) ! dissipation ceofficient + + real :: anom0, sstfr + + sst0 = reshape(vsea_input(:,1), (/nlon, nlat/)) + tice0 = reshape(vsea_input(:,2), (/nlon, nlat/)) + sice0 = reshape(vsea_input(:,3), (/nlon, nlat/)) + hfsea = reshape(vsea_input(:,4), (/nlon, nlat/)) + hfice = reshape(vsea_input(:,5), (/nlon, nlat/)) + sstcl1 = reshape(vsea_input(:,6), (/nlon, nlat/)) + ticecl1 = reshape(vsea_input(:,7), (/nlon, nlat/)) + hfseacl = reshape(vsea_input(:,8), (/nlon, nlat/)) + + sstfr = 273.2-1.8 ! SST at freezing point + + !beta = 1. ! heat flux coef. at sea-ice bottom + + ! 1. Ocean mixed layer + ! Net heat flux + hflux = hfsea-hfseacl-sice0*(hfice+beta*(sstfr-tice0)) + + ! Anomaly at t0 minus climatological temp. tendency + tanom = sst0 - sstcl1 + + ! Time evoloution of temp. anomaly + tanom = cdsea*(tanom+rhcaps*hflux) + + ! Full SST at final time + sst1 = tanom + sstcl1 + + ! 2. Sea-ice slab model + + ! Net heat flux + hflux = hfice + beta*(sstfr-tice0) + + ! Anomaly w.r.t final-time climatological temp. + tanom = tice0 - ticecl1 + + ! Definition of non-linear damping coefficient + anom0 = 20. + cdis = cdice*(anom0/(anom0+abs(tanom))) + !cdis(:,:) = cdice(:,:) + + ! Time evoloution of temp. anomaly + tanom = cdis*(tanom+rhcapi*hflux) + + ! Full ice temperature at final time + tice1 = tanom + ticecl1 + + ! Persistence of sea ice fraction + sice1 = sice0 + + vsea_output(:,1) = reshape(sst1, (/ngp/)) + vsea_output(:,2) = reshape(tice1, (/ngp/)) + vsea_output(:,3) = reshape(sice1, (/ngp/)) +end + +subroutine sea_domain(cdomain,rlat,dmask) + ! subroutine sea_domain (cdomain,rlat,dmask) + + ! Purpose : Definition of ocean domains + + use mod_atparam + + implicit none + + integer, parameter :: nlon=ix, nlat=il + + ! Input variables + + character(len=6), intent(in) :: cdomain ! domain name + real, intent(in) :: rlat(nlat) ! latitudes in degrees + + ! Output variables (initialized by calling routine) + real, intent(inout) :: dmask(nlon,nlat) ! domain mask + + integer :: i, j + real :: arlat, dlon, rlon, rlonw, wlat + + print *, 'sea domain : ', cdomain + + dlon = 360./float(nlon) + + if (cdomain.eq.'northe') then + do j=1,nlat + if (rlat(j).gt.20.0) dmask(:,j) = 1. + end do + end if + + if (cdomain.eq.'natlan') then + do j=1,nlat + if (rlat(j).gt.20.0.and.rlat(j).lt.80.0) then + do i=1,nlon + rlon = (i-1)*dlon + if (rlon.lt.45.0.or.rlon.gt.260.0) dmask(i,j) = 1. + end do + end if + end do + end if + + if (cdomain.eq.'npacif') then + do j=1,nlat + if (rlat(j).gt.20.0.and.rlat(j).lt.65.0) then + do i=1,nlon + rlon = (i-1)*dlon + if (rlon.gt.120.0.and.rlon.lt.260.0) dmask(i,j) = 1. + end do + end if + end do + end if + + if (cdomain.eq.'tropic') then + do j=1,nlat + if (rlat(j).gt.-30.0.and.rlat(j).lt.30.0) dmask(:,j) = 1. + end do + end if + + if (cdomain.eq.'indian') then + do j=1,nlat + if (rlat(j).gt.-30.0.and.rlat(j).lt.30.0) then + do i=1,nlon + rlon = (i-1)*dlon + if (rlon.gt.30.0.and.rlon.lt.120.0) dmask(i,j) = 1. + end do + end if + end do + end if + + if (cdomain.eq.'elnino') then + do j=1,nlat + arlat = abs(rlat(j)) + if (arlat.lt.25.0) then + wlat = 1. + if (arlat.gt.15.0) wlat = (0.1*(25.-arlat))**2 + rlonw = 300.-2*max(rlat(j),0.) + do i=1,nlon + rlon = (i-1)*dlon + if (rlon.gt.165.0.and.rlon.lt.rlonw) then + dmask(i,j) = wlat + else if (rlon.gt.155.0.and.rlon.lt.165.0) then + dmask(i,j) = wlat*0.1*(rlon-155.) + end if + end do + end if + end do + end if + + !do j=1,nlat + ! print *, 'lat = ',rlat(j),' sea model domain = ',dmask(nlon/2,j) + !end do +end diff --git a/src/dyn_geop.f90 b/src/dyn_geop.f90 new file mode 100755 index 0000000..06cf2e5 --- /dev/null +++ b/src/dyn_geop.f90 @@ -0,0 +1,33 @@ +subroutine geop(jj) + ! subroutine geop (jj) + ! + ! Purpose : compute spectral geopotential from spectral temperature T + ! and spectral topography PHIS, as in GFDL Climate Group GCM + ! Input : jj = time level index (1 or 2) + ! Modified common blocks : DYNSP2 + + use mod_atparam + use mod_dynvar + use mod_dyncon1, only: xgeop1, xgeop2, hsg, fsg + + implicit none + + integer, intent(in) :: jj + integer :: k + real :: corf + + ! 1. Bottom layer (integration over half a layer) + phi(:,:,kx) = phis + xgeop1(kx) * t(:,:,kx,jj) + + ! 2. Other layers (integration two half-layers) + do k = kx-1,1,-1 + phi(:,:,k) = phi(:,:,k+1) + xgeop2(k+1)*t(:,:,k+1,jj)& + & + xgeop1(k)*t(:,:,k,jj) + end do + + ! 3. lapse-rate correction in the free troposphere + do k = 2,kx-1 + corf=xgeop1(k)*0.5*log(hsg(k+1)/fsg(k))/log(fsg(k+1)/fsg(k-1)) + phi(1,:,k) = phi(1,:,k) + corf*(t(1,:,k+1,jj) - t(1,:,k-1,jj)) + end do +end diff --git a/src/dyn_grtend.f90 b/src/dyn_grtend.f90 new file mode 100755 index 0000000..e230209 --- /dev/null +++ b/src/dyn_grtend.f90 @@ -0,0 +1,279 @@ +subroutine grtend(vordt,divdt,tdt,psdt,trdt,j1,j2) + ! subroutine grtend (vordt,divdt,tdt,psdt,trdt,j1,j2) + ! + ! Purpose: compute non-linear tendencies in grid-point space + ! from dynamics and physical parametrizations, + ! and convert them to spectral tendencies + ! + ! dF/dt = T_dyn(F(J2)) + T_phy(F(J1)) + ! + ! Input: j1 = time level index for physical tendencies + ! j2 = time level index for dynamical tendencies + ! Output: vordt = spectral tendency of vorticity + ! divdt = spectral tendency of divergence + ! tdt = spectral tendency of temperature + ! psdt = spectral tendency of log(p_s) + ! trdt = spectral tendency of tracers + + USE mod_atparam + USE mod_dynvar + use mod_dyncon1, only: akap, rgas, dhs, fsg, dhsr, fsgr, coriol + use mod_dyncon2, only: tref, tref3 + + implicit none + + !** notes **** + ! -- TG does not have to be computed at both time levels every time step, + ! I have left it this way to retain parallel structure with subroutine + ! using latitude loop + ! -- memory can be reduced considerably eliminating TGG, computing VORG + ! only when needed, etc -- I have not optimized this subroutine for + ! routine use on the YMP + ! -- results from grtend1.F should duplicate results from grtend.F + ! -- Isaac + !************ + + complex, dimension(mx,nx,kx), intent(inout) :: vordt, divdt, tdt + complex, intent(inout) :: psdt(mx,nx), trdt(mx,nx,kx,ntr) + integer, intent(in) :: j1, j2 + + complex :: dumc(mx,nx,3), zero + + real, dimension(ix,il,kx) :: utend, vtend, ttend + real :: trtend(ix,il,kx,ntr) + + real, dimension(ix,il,kx) :: ug, vg, tg, vorg, divg, tgg, puv + real, dimension(ix,il) :: px, py, umean, vmean, dmean, pstar + real :: trg(ix,il,kx,ntr), sigdt(ix,il,kxp) + real :: temp(ix,il,kxp), sigm(ix,il,kxp), dumr(ix,il,3) + + integer :: iitest = 0, k, i, itr, j + + zero = (0.,0.) + + if (iitest.eq.1) print*,'inside GRTEND' + + ! ------------- + ! Grid converts + + if (iitest.eq.1) print*,'a' + + do k=1,kx + call grid(vor(1,1,k,j2),vorg(1,1,k),1) + call grid(div(1,1,k,j2),divg(1,1,k),1) + call grid( t(1,1,k,j2), tg(1,1,k),1) + + do itr=1,ntr + call grid(tr(1,1,k,j2,itr),trg(1,1,k,itr),1) + end do + + call uvspec(vor(1,1,k,j2),div(1,1,k,j2),dumc(1,1,1),dumc(1,1,2)) + call grid(dumc(1,1,2),vg(1,1,k),2) + call grid(dumc(1,1,1),ug(1,1,k),2) + + do j=1,il + do i=1,ix + vorg(i,j,k)=vorg(i,j,k)+coriol(j) + end do + end do + end do + + if (iitest.eq.1) print*,'b' + + umean(:,:) = 0.0 + vmean(:,:) = 0.0 + dmean(:,:) = 0.0 + + if (iitest.eq.1) print*,'c' + do k=1,kx + umean(:,:) = umean(:,:) + ug(:,:,k) * dhs(k) + vmean(:,:) = vmean(:,:) + vg(:,:,k) * dhs(k) + dmean(:,:) = dmean(:,:) + divg(:,:,k) * dhs(k) + end do + + ! Compute tendency of log(surface pressure) + if (iitest.eq.1) print*,'d' + ! ps(1,1,j2)=zero + call grad(ps(1,1,j2),dumc(1,1,2),dumc(1,1,3)) + call grid(dumc(1,1,2),px,2) + call grid(dumc(1,1,3),py,2) + + dumr(:,:,1) = -umean * px - vmean * py + call spec(dumr(1,1,1),psdt) + psdt(1,1)=zero + + ! Compute "vertical" velocity + sigdt(:,:,1) = 0.0 + sigdt(:,:,kxp) = 0.0 + sigm(:,:,1) = 0.0 + sigm(:,:,kxp) = 0.0 + + ! (The following combination of terms is utilized later in the + ! temperature equation) + do k=1,kx + puv(:,:,k) = (ug(:,:,k) - umean) * px + (vg(:,:,k) - vmean) * py + end do + + if (iitest.eq.1) print*,'e' + + do k=1,kx + !cspj sigdt is the vertical velocity (in sigma coords) + sigdt(:,:,k+1) = sigdt(:,:,k) - dhs(k)*(puv(:,:,k)+divg(:,:,k)-dmean) + sigm(:,:,k+1) = sigm(:,:,k) - dhs(k)*puv(:,:,k) + end do + + ! Subtract part of temperature field that is used as reference for + ! implicit terms + if (iitest.eq.1) print*,'f' + + do k=1,kx + do j=1,il + do i=1,ix + tgg(i,j,k) = tg(i,j,k)-tref(k) + end do + end do + end do + + px = rgas*px + py = rgas*py + + ! Zonal wind tendency + temp(:,:,1) = 0.0 + temp(:,:,kxp) = 0.0 + + do k=2,kx + temp(:,:,k) = sigdt(:,:,k) * (ug(:,:,k) - ug(:,:,k-1)) + end do + + do k=1,kx + utend(:,:,k) = vg(:,:,k) * vorg(:,:,k) - tgg(:,:,k)*px& + & - (temp(:,:,k+1) + temp(:,:,k))*dhsr(k) + end do + + ! Meridional wind tendency + if (iitest.eq.1) print*,'g' + + do k=2,kx + temp(:,:,k) = sigdt(:,:,k) * (vg(:,:,k) - vg(:,:,k-1)) + end do + + do k=1,kx + vtend(:,:,k) = -ug(:,:,k)*vorg(:,:,k) - tgg(:,:,k)*py& + & - (temp(:,:,k+1) + temp(:,:,k))*dhsr(k) + end do + + ! Temperature tendency + do k=2,kx + temp(:,:,k) = sigdt(:,:,k)*(tgg(:,:,k) - tgg(:,:,k-1))& + & + sigm(:,:,k)*(tref(k) - tref(k-1)) + end do + + do k=1,kx + do j=1,il + do i=1,ix + ttend(i,j,k)=tgg(i,j,k)*divg(i,j,k)& + & -(temp(i,j,k+1)+temp(i,j,k))*dhsr(k)& + & +fsgr(k)*tgg(i,j,k)*(sigdt(i,j,k+1)+sigdt(i,j,k))& + & +tref3(k)*(sigm(i,j,k+1)+sigm(i,j,k))& + & +akap*(tg(i,j,k)*puv(i,j,k)& + & -tgg(i,j,k)*dmean(i,j)) + end do + end do + end do + + if (iitest.eq.1) print*,'h' + ! Tracer tendency + + do itr=1,ntr + do k=2,kx + do j=1,il + do i=1,ix + temp(i,j,k)=sigdt(i,j,k)*(trg(i,j,k,itr)-trg(i,j,k-1,itr)) + end do + end do + end do + + !spj for moisture, vertical advection is not possible between top + !spj two layers + !kuch three layers + !if(iinewtrace.eq.1)then + do k=2,3 + do j=1,il + do i=1,ix + temp(i,j,k)=0. + enddo + enddo + enddo + !endif + + do k=1,kx + do j=1,il + do i=1,ix + trtend(i,j,k,itr)=trg(i,j,k,itr)*divg(i,j,k)-(temp(i,j,k+1)& + & +temp(i,j,k))*dhsr(k) + end do + end do + end do + end do + + if (iitest.eq.1) print*,'h' + + !******************** physics **************************** + + call geop(j1) + + call phypar (vor(1,1,1,j1),div(1,1,1,j1),t(1,1,1,j1),tr(1,1,1,j1,1),phi,& + & ps(1,1,j1),utend,vtend,ttend,trtend) + + + !********************************************************* + + if (iitest.eq.1) print*,'i' + + do k=1,kx + ! convert u and v tendencies to vor and div spectral tendencies + ! vdspec takes a grid u and a grid v and converts them to + ! spectral vor and div + call vdspec(utend(1,1,k),vtend(1,1,k),vordt(1,1,k),divdt(1,1,k),2) + + ! add lapl(0.5*(u**2+v**2)) to div tendency, + ! and add div(vT) to spectral t tendency + do j=1,il + do i=1,ix + dumr(i,j,1)=0.5*(ug(i,j,k)*ug(i,j,k)+vg(i,j,k)*vg(i,j,k)) + dumr(i,j,2)=-ug(i,j,k)*tgg(i,j,k) + dumr(i,j,3)=-vg(i,j,k)*tgg(i,j,k) + end do + end do + + ! divergence tendency + call spec(dumr(1,1,1),dumc(1,1,1)) + call lap (dumc(1,1,1),dumc(1,1,2)) + + !fk-- Change to keep dimensions + divdt(:,:,k) = divdt(:,:,k) - dumc(:,:,2) + + ! temperature tendency + call vdspec(dumr(1,1,2),dumr(1,1,3),dumc(1,1,1),tdt(1,1,k),2) + call spec(ttend(1,1,k),dumc(1,1,2)) + + !fk-- Change to keep dimensions + tdt(:,:,k) = tdt(:,:,k) + dumc(:,:,2) + + ! tracer tendency + do itr=1,ntr + do j=1,il + do i=1,ix + dumr(i,j,2)=-ug(i,j,k)*trg(i,j,k,itr) + dumr(i,j,3)=-vg(i,j,k)*trg(i,j,k,itr) + end do + end do + + call spec(trtend(1,1,k,itr),dumc(1,1,2)) + call vdspec(dumr(1,1,2),dumr(1,1,3),dumc(1,1,1),trdt(1,1,k,itr),2) + + !fk-- Change to keep dimensions + trdt(:,:,k,itr) = trdt(:,:,k,itr) + dumc(:,:,2) + end do + end do +end diff --git a/src/dyn_implic.f90 b/src/dyn_implic.f90 new file mode 100755 index 0000000..b081ea9 --- /dev/null +++ b/src/dyn_implic.f90 @@ -0,0 +1,68 @@ +subroutine implic(divdt,tdt,psdt) + ! + ! subroutine implic (divdt,tdt,psdt) + ! + ! Purpose : Correct tendencies for implicit gravity wave model + ! Input/output : divdt = divergence tendency + ! tdt = temperature tendency + ! psdt = tendency of log(surf.pressure) + ! + + use mod_atparam + use mod_dyncon1, only: dhs + use mod_dyncon2, only: tref1, xc, xd, xj, dhsx, elz + + implicit none + + integer, parameter :: mxnxkx = mx*nx*kx + + complex, intent(inout) :: divdt(mx,nx,kx), tdt(mx,nx,kx), psdt(mx,nx) + complex :: ye(mx,nx,kx), yf(mx,nx,kx), zero + integer :: k1, k, m, n, ll, mm + + zero = (0.,0.) + + ye(:,:,:) = zero + + do k1=1,kx + do k=1,kx + ye(:,:,k) = ye(:,:,k) + xd(k,k1) * tdt(:,:,k1) + end do + end do + + do k=1,kx + ye(:,:,k) = ye(:,:,k) + tref1(k) * psdt + end do + + do k=1,kx + do m=1,mx + do n=1,nx + yf(m,n,k)=divdt(m,n,k)+elz(m,n)*ye(m,n,k) + end do + end do + end do + + divdt(:,:,:) = zero + + do n=1,nx + do m=1,mx + mm=isc*(m-1)+1 + ll=mm+n-2 + if(ll.ne.0) then + do k1=1,kx + divdt(m,n,:) = divdt(m,n,:) + xj(:,k1,ll) * yf(m,n,k1) + end do + endif + end do + end do + + do k=1,kx + psdt = psdt - divdt(:,:,k) * dhsx(k) + end do + + do k=1,kx + do k1=1,kx + tdt(:,:,k) = tdt(:,:,k) + xc(k,k1) * divdt(:,:,k1) + end do + end do +end diff --git a/src/dyn_sptend.f90 b/src/dyn_sptend.f90 new file mode 100755 index 0000000..0091d22 --- /dev/null +++ b/src/dyn_sptend.f90 @@ -0,0 +1,67 @@ +subroutine sptend (divdt,tdt,psdt,j4) + ! subroutine sptend (divdt,tdt,psdt,j4) + ! + ! Purpose : compute spectral tendencies of divergence, temperature + ! and log_surf.pressure) + ! Input/output : divdt = divergence tendency (spec.) + ! tdt = temperature tendency (spec.) + ! psdt = tendency of log_surf.pressure (spec.) + ! j4 = time level index (1 or 2) + + use mod_atparam + use mod_dynvar + use mod_dyncon1, only: rgas, dhs, dhsr + use mod_dyncon2, only: tref, tref2, tref3 + + implicit none + + complex, intent(inout) :: psdt(mx,nx), divdt(mx,nx,kx), tdt(mx,nx,kx) + integer, intent(in) :: j4 + + complex :: dumk(mx,nx,kxp), dmeanc(mx,nx), sigdtc(mx,nx,kxp) + complex :: tempc(mx,nx,3) + complex :: dumc(mx,nx,2), zero + + integer :: k + + zero = (0.,0.) + + ! Vertical mean div and pressure tendency + dmeanc(:,:) = zero + do k=1,kx + dmeanc = dmeanc + div(:,:,k,j4) * dhs(k) + end do + + psdt = psdt - dmeanc + psdt(1,1) = zero + + ! Sigma-dot "velocity" and temperature tendency + sigdtc(:,:,1) = zero + sigdtc(:,:,kxp) = zero + + do k=1,kxm + sigdtc(:,:,k+1) = sigdtc(:,:,k) - dhs(k)*(div(:,:,k,j4) - dmeanc) + end do + + dumk(:,:,1) = zero + dumk(:,:,kxp) = zero + + do k=2,kx + dumk(:,:,k) = sigdtc(:,:,k) * (tref(k) - tref(k-1)) + end do + + do k=1,kx + tdt(:,:,k) = tdt(:,:,k) - (dumk(:,:,k+1) + dumk(:,:,k)) * dhsr(k)& + & + tref3(k) * (sigdtc(:,:,k+1) + sigdtc(:,:,k))& + & - tref2(k) * dmeanc + end do + + ! Geopotential and divergence tendency + call geop(j4) + + do k=1,kx + dumc(:,:,1) = phi(:,:,k) + rgas*tref(k)*ps(:,:,j4) + call lap(dumc(1,1,1),dumc(1,1,2)) + divdt(:,:,k) = divdt(:,:,k) - dumc(:,:,2) + end do +end diff --git a/src/dyn_step.f90 b/src/dyn_step.f90 new file mode 100755 index 0000000..0c5388c --- /dev/null +++ b/src/dyn_step.f90 @@ -0,0 +1,276 @@ +subroutine step(j1,j2,dt,alph,rob,wil) + ! subroutine step (j1,j2,dt,alph,rob,wil) + ! + ! Purpose: perform one time step starting from F(1) and F(2) + ! and using the following scheme: + ! + ! Fnew = F(1) + DT * [ T_dyn(F(J2)) + T_phy(F(1)) ] + ! F(1) = (1-2*eps)*F(J1) + eps*[F(1)+Fnew] + ! F(2) = Fnew + ! + ! Input: + ! If J1=1, J2=1 : forward time step (eps=0) + ! If J1=1, J2=2 : initial leapfrog time step (eps=0) + ! If J1=2, J2=2 : leapfrog time step with time filter (eps=ROB) + ! DT = time step (if DT < or = 0, tendencies are computed but + ! no time stepping is performed) + ! alph = 0 : forward step for gravity wave terms + ! alph = 1 : backward implicit step for g.w. + ! alph = 0.5 : centered implicit step for g.w. + ! rob = Robert filter coefficient + ! wil = Williams filter coefficient + + use mod_dyncon0, only: tdrs + use mod_atparam + use mod_dynvar + use mod_hdifcon + + implicit none + + integer, intent(in) :: j1, j2 + real, intent(in) :: dt, alph, rob, wil + complex, dimension(mx,nx,kx) :: ordt, divdt, tdt, vordt + complex :: psdt(mx,nx), trdt(mx,nx,kx,ntr) + real :: eps, sdrag + + complex :: ctmp(mx,nx,kx) + + integer :: iitest = 0, n, itr, k, m + + if (iitest.eq.1) print*, ' inside step' + + ! 1. Computation of grid-point tendencies + ! (converted to spectral at the end of GRTEND) + if (iitest.eq.1) print*,' call grtend' + call grtend(vordt,divdt,tdt,psdt,trdt,1,j2) + + ! 2. Computation of spectral tendencies + if (alph.eq.0.) then + if (iitest.eq.1) print*,' call sptend' + call sptend(divdt,tdt,psdt,j2) + else + if (iitest.eq.1) print*,' call sptend' + call sptend(divdt,tdt,psdt,1) + + ! implicit correction + if (iitest.eq.1) print*,' call implic' + call implic(divdt,tdt,psdt) + endif + + ! 3. Horizontal diffusion + if (iitest.eq.1) print*, ' biharmonic damping ' + + ! 3.1 Diffusion of wind and temperature + call hordif(kx,vor,vordt,dmp, dmp1) + call hordif(kx,div,divdt,dmpd,dmp1d) + + do k=1,kx + do m=1,mx + do n=1,nx + ctmp(m,n,k) = t(m,n,k,1)+tcorh(m,n)*tcorv(k) + enddo + enddo + enddo + + call hordif(kx,ctmp,tdt,dmp,dmp1) + + ! 3.2 Stratospheric diffusion and zonal wind damping + sdrag = 1./(tdrs*3600.) + do n = 1,nx + vordt(1,n,1) = vordt(1,n,1)-sdrag*vor(1,n,1,1) + divdt(1,n,1) = divdt(1,n,1)-sdrag*div(1,n,1,1) + enddo + + call hordif(1,vor, vordt,dmps,dmp1s) + call hordif(1,div, divdt,dmps,dmp1s) + call hordif(1,ctmp,tdt, dmps,dmp1s) + + ! 3.3 Check for eddy kinetic energy growth rate + ! CALL CGRATE (VOR,DIV,VORDT,DIVDT) + + ! 3.4 Diffusion of tracers + do k=1,kx + do m=1,mx + do n=1,nx + ctmp(m,n,k) = tr(m,n,k,1,1)+qcorh(m,n)*qcorv(k) + enddo + enddo + enddo + + call hordif(kx,ctmp,trdt,dmpd,dmp1d) + + if (ntr.gt.1) then + do itr=2,ntr + call hordif(kx,tr(1,1,1,1,itr),trdt(1,1,1,itr),dmp,dmp1) + enddo + endif + + ! 4. Time integration with Robert filter + if (dt.le.0.) return + + if (iitest.eq.1) print*,' time integration' + + if (j1.eq.1) then + eps = 0. + else + eps = rob + endif + + call timint(j1,dt,eps,wil,1,ps,psdt) + + call timint(j1,dt,eps,wil,kx,vor,vordt) + call timint(j1,dt,eps,wil,kx,div,divdt) + call timint(j1,dt,eps,wil,kx,t, tdt) + + do itr=1,ntr + call timint(j1,dt,eps,wil,kx,tr(1,1,1,1,itr),trdt(1,1,1,itr)) + enddo +end + +subroutine hordif(nlev,field,fdt,dmp,dmp1) + ! Aux. subr. HORDIF (NLEV,FIELD,FDT,DMP,DMP1) + ! Purpose : Add horizontal diffusion tendency of FIELD + ! to spectral tendency FDT at NLEV levels + ! using damping coefficients DMP and DMP1 + + USE mod_atparam + + implicit none + + integer, intent(in) :: nlev + complex, intent(in) :: field(mxnx,kx) + complex, intent(inout) :: fdt(mxnx,kx) + real, intent(in) :: dmp(mxnx), dmp1(mxnx) + integer :: k, m + + do k=1,nlev + do m=1,mxnx + fdt(m,k)=(fdt(m,k)-dmp(m)*field(m,k))*dmp1(m) + enddo + enddo +end + +subroutine timint(j1,dt,eps,wil,nlev,field,fdt) + ! Aux. subr. timint (j1,dt,eps,wil,nlev,field,fdt) + ! Purpose : Perform time integration of field at nlev levels + ! using tendency fdt + + use mod_atparam + + implicit none + + integer, intent(in) :: j1, nlev + real, intent(in) :: dt, eps, wil + complex, intent(in) :: fdt(mxnx,nlev) + complex, intent(inout) :: field(mxnx,nlev,2) + real :: eps2 + complex :: fnew(mxnx) + integer :: k, m + + eps2 = 1.-2.*eps + + if (ix.eq.iy*4) then + do k=1,nlev + call trunct(fdt(1,k)) + enddo + endif + + ! The actual leap frog with the robert filter + do k=1,nlev + do m=1,mxnx + fnew (m) = field(m,k,1) + dt*fdt(m,k) + field(m,k,1) = field(m,k,j1) + wil*eps*(field(m,k,1)& + & -2*field(m,k,j1)+fnew(m)) + + ! and here comes Williams' innovation to the filter + field(m,k,2) = fnew(m)-(1-wil)*eps*(field(m,k,1)& + &-2*field(m,k,j1)+fnew(m)) + enddo + enddo +end + +subroutine cgrate(vor,div,vordt,divdt) + ! SUBROUTINE CGRATE (VOR,DIV,VORDT,DIVDT) + ! + ! Purpose: Check growth rate of eddy kin. energy + ! Input : VOR = vorticity + ! DIV = divergence + ! VORDT = time derivative of VOR + ! DIVDT = time derivative of DIV + + USE mod_atparam + + implicit none + + complex, dimension(mx,nx,kx), intent(in) :: vor, div + complex, dimension(mx,nx,kx), intent(inout) :: vordt, divdt + complex :: temp(mx,nx) + real :: cdamp, grate, grmax, rnorm + integer :: k, m, n + + grmax=0.2/(86400.*2.) + + cdamp=0. + + do k=2,kx + grate=0. + rnorm=0. + + call invlap (vor(1,1,k),temp) + + do n=1,nx + do m=2,mx + grate=grate-real(vordt(m,n,k)*conjg(temp(m,n))) + rnorm=rnorm-real( vor(m,n,k)*conjg(temp(m,n))) + enddo + enddo + + if (grate.gt.grmax*rnorm) cdamp = max(cdamp,0.8*grate/rnorm) + ! if (grate.gt.grmax*rnorm) cdamp =& + ! & max(cdamp,(grate*grate)/(grmax*rnorm*rnorm)) + enddo + + if (cdamp.gt.0.) then + print *, ' rot. wind damping enabled' + + do k=1,kx + do n=1,nx + do m=2,mx + vordt(m,n,k)=vordt(m,n,k)-cdamp*vor(m,n,k) + enddo + enddo + enddo + endif + + cdamp=0. + + do k=2,kx + grate=0. + rnorm=0. + + call invlap (div(1,1,k),temp) + + do n=1,nx + do m=2,mx + grate=grate-real(divdt(m,n,k)*conjg(temp(m,n))) + rnorm=rnorm-real( div(m,n,k)*conjg(temp(m,n))) + enddo + enddo + + if (grate.gt.grmax*rnorm) cdamp = max(cdamp,0.8*grate/rnorm) + !if (grate.gt.grmax*rnorm) cdamp =& + ! & max(cdamp,(grate*grate)/(grmax*rnorm*rnorm)) + enddo + + if (cdamp.gt.0.) then + print *, ' div. wind damping enabled' + + do k=1,kx + do n=1,nx + do m=2,mx + divdt(m,n,k)=divdt(m,n,k)-cdamp*div(m,n,k) + enddo + enddo + enddo + endif +end diff --git a/src/dyn_stloop.f90 b/src/dyn_stloop.f90 new file mode 100755 index 0000000..b292720 --- /dev/null +++ b/src/dyn_stloop.f90 @@ -0,0 +1,96 @@ +subroutine stloop(istep) + ! subroutine stloop (istep) + ! + ! Purpose: Perform a series of time steps calling + ! post-processing/output routines at selected steps + ! Input/output : istep = time step index + ! Updated common block : lflag2 + + use mod_lflags, only: lradsw, lrandf + use mod_tsteps + use mod_date, only: ihour, newdate, iyear + use mod_dynvar + + use speedy_res_interface, only : getspeedyvariable + use mod_reservoir, only : global_time_step + + implicit none + + integer, intent(inout) :: istep + integer :: iitest = 0, j, jj + integer :: window_size + + window_size = 24/global_time_step + + ! Break up each day into 24 1-hour windows + do jj = 1,window_size + ! Each 1-hour window has nsteps/24 actual timesteps + do j = 1, nsteps/window_size + !if (iitest == 0) print*, 'stloop: calling step ', istep + + !Keep track of the timestep and record state vector + currentstep = currentstep + 1 + !if(era_start.ne.3) then + ! call getspeedyvariable() + !endif + + print *, 'made it here', currentstep + ! Set logical flags + lradsw = (mod(istep,nstrad) == 1) + lrandf = ((istep <= nstrdf) .or. (nstrdf < 0)) + + ! Perform one leapfrog time step + call step(2, 2, delt2, alph, rob, wil) + + ! Do diagnostic, post-processing and I/O tasks + call diagns(2, istep) + + if (ihout .eqv. .false.) then + if (mod(istep, nstppr) == 0) call tminc + if (nstout > 0 .and. mod(istep, nstout) == 0) call tmout(1) + end if + + if(era_start.ne.3) then + call getspeedyvariable() + endif + istep = istep + 1 + + if(mod(j,window_size) == 0) then + ! Increment hour timer (takes values of 0, 6, 12 or 18) + print *, 'ihour before',ihour + + ihour = mod(ihour + 1 , 24) + + print *, 'ihour after',ihour + ! If it's a new day... + if (ihour .eq. 0) then + ! Compute new date + call newdate(1) + end if + endif + + end do + + ! Increment hour timer (takes values of 0, 6, 12 or 18) + !ihour = mod(ihour + res%timestep , 24) + + ! If it's a new day... + !if (ihour .eq. 0) then + ! Compute new date + ! call newdate(1) + !end if + + if(onehr_run) then + !call restart(2) + call iogrid(69) + + print *,'normal end with 1-hr fcst (yeahhhhhhh!!!!)' + stop + endif + if(onehr_hybrid) then + print *, 'exiting speedy via onehr_hybrid' + call iogrid(31) + exit + endif + end do +end diff --git a/src/ini_agcm_init.f90 b/src/ini_agcm_init.f90 new file mode 100755 index 0000000..530847e --- /dev/null +++ b/src/ini_agcm_init.f90 @@ -0,0 +1,102 @@ +subroutine agcm_init(cexp, inidate, ntimes, irstart, ndays, start_from_file, internal_state_vector) + ! subroutine agcm_init (cexp,inidate,ntimes,irstart, + ! & ndays) + ! + ! purpose: initialization of atmos. model and coupling interface + ! + + use mod_cpl_flags, only: icsea, isstan + use mod_tsteps + use mod_date, only: newdate, ndaytot, iyear, imonth, iday, ihour + + use mod_utilities, only : state_vector_type + implicit none + + ! input (reset by input/include files if inidate = 0): + character(len=3), intent(inout) :: cexp ! experiment identifier + integer, intent(in) :: inidate ! initial date yyyymm + integer, intent(in) :: ntimes ! integr. length in months (< 0) or days (> 0) + integer, intent(in) :: irstart ! restart flag: 0 = no, > 0 = yes + integer, intent(in) :: start_from_file !0 starts from fort.2 if its 1 then uses internal to program type state_vector_type + + type(state_vector_type), intent(inout), optional :: internal_state_vector + ! output: + integer, intent(inout) :: ndays ! total no. of integration days + + + + print *, ' hallo from speedy_agcm' + + ! 1. set run initial time, duration, time-stepping and coupling options + + if(start_from_file == 0) then + read (2,*) istart !from rest=0, from restartfile=1, from era=2 + read (2,*) era_start !start from grid initial condition=0, Start from grid era_5 re_analysis=1, regrid era=2 + read (2,'(a)') era_file + era_file = trim(era_file) + + read (2,*) era_hour !era hour of the month 1 = 00UTC of the first day of the month + read (2,*) era_hour_plus_one !So I dont have to do calendar stuff in fortran + + ! Read date from fort.2 file + read (2,*) iyear0 + read (2,*) imont0 + read (2,*) iday + read (2,*) ihour + else if(start_from_file == 1) then + if(present(internal_state_vector)) then + istart = internal_state_vector%istart + era_start = internal_state_vector%era_start + era_file = internal_state_vector%era_file + era_file = trim(era_file) + + iyear0 = internal_state_vector%iyear0 + imont0 = internal_state_vector%imont0 + iday = internal_state_vector%iday + ihour = internal_state_vector%ihour + else + print *, 'something went horribly wrong check internal_state_vector killing the program' + stop + endif + endif + + iyear = iyear0 + imonth = imont0 + + call newdate(0) + + print *, 'start date ', iyear, imonth, iday, ihour + + isst0 = (iyear0 - issty0) * 12 + imont0 + + ndays = ndaytot + + ! check consistency of coupling and prescribed SST anomaly flags + if (icsea >= 4) isstan = 1 + + ! 2. initialization of atmospheric model constants and variables + call ini_atm(cexp) + + if(present(internal_state_vector)) then + if(internal_state_vector%is_safe_to_run_speedy) then + ! 3. initialization of coupled modules (land, sea, ice) + call ini_coupler(istart) + + ! 4. set up the forcing fields for the first time step + call fordate(0) + + ! 5. do the initial (2nd-order) time step, initialize the semi-impl. scheme + call stepone + endif + else + ! 3. initialization of coupled modules (land, sea, ice) + call ini_coupler(istart) + + ! 4. set up the forcing fields for the first time step + call fordate(0) + + ! 5. do the initial (2nd-order) time step, initialize the semi-impl. + ! scheme + call stepone + endif +end subroutine diff --git a/src/ini_fordate.f90 b/src/ini_fordate.f90 new file mode 100755 index 0000000..5878b31 --- /dev/null +++ b/src/ini_fordate.f90 @@ -0,0 +1,158 @@ +subroutine fordate(imode) + ! + ! subroutine fordate (imode) + ! + ! purpose : compute forcing fields for the current date + ! and correction terms for horiz. diffusion + ! + ! input : imode : 0 = initialization step, 1 = daily update + + use mod_lflags, only: lco2 + use mod_dyncon0, only: refrh1 + use mod_atparam + use mod_hdifcon, only: tcorh, qcorh + use mod_physcon, only: rd + use mod_surfcon, only: phis0, alb0, sd2sc + use mod_cli_land, only: fmask_l + use mod_date, only: iyear, tyear + use mod_var_land, only: stl_am, snowd_am + use mod_cli_sea, only: fmask_s + use mod_var_sea, only: sstcl_ob, sst_am, sice_am + use mod_radcon, only: ablco2, ablco2_ref, albsea, albice, snowc, albsn,& + & alb_l, alb_s, albsfc + + implicit none + + integer, parameter :: nlon = ix, nlat = il, nlev = kx, ngp = nlon * nlat + + integer, intent(in) :: imode + real, dimension(nlon, nlat) :: corh, tsfc, tref, psfc, qsfc, qref, psfc_dummy + real :: gamlat(nlat) + + real :: fland(ngp), alb_0(ngp) + + real :: del_co2, dummy, pexp + integer :: i, j, ij, iitest = 0, iyear_ref + + fland = reshape(fmask_l, (/ngp/)) + alb_0 = reshape(alb0, (/ngp/)) + + ! time variables for interpolation are set by newdate + + ! 1. time-independent parts of physical parametrizations + if (imode == 0) then + call radset + call sflset(phis0) + + ablco2_ref = ablco2 + end if + + ! 2. daily-mean radiative forcing + ! incoming solar radiation + call sol_oz(tyear) + + ! total surface albedo + + do j = 1, ngp + snowc(j) = min(1., snowd_am(j)/sd2sc) + alb_l(j) = alb_0(j) + snowc(j) * (albsn - alb_0(j)) + alb_s(j) = albsea + sice_am(j) * (albice - albsea) + albsfc(j) = alb_s(j) + fland(j) * (alb_l(j) - alb_s(j)) + end do + + ! linear trend of co2 absorptivity (del_co2: rate of change per year) + iyear_ref = 1950 + del_co2 = 0.005 + ! del_co2 = 0.0033 + + if (lco2) then + ablco2 = ablco2_ref * exp(del_co2 * (iyear + tyear - iyear_ref)) + end if + + ! 3. temperature correction term for horizontal diffusion + call setgam(tyear,gamlat) + + do j = 1, nlat + do i = 1, nlon + corh(i,j) = gamlat(j) * phis0(i,j) + end do + end do + + if (iitest > 1.and.imode == 0) then + call outest(19,phis0) + call outest(19,corh) + end if + + call spec(corh,tcorh) + +! 4. humidity correction term for horizontal diffusion + ij = 0 + do j = 1, nlat + pexp = 1./(rd * gamlat(j)) + do i = 1, nlon + ij = ij + 1 +! tsfc(i,j) = fmask_l(i,j)*stlcl_ob(ij) +! & +fmask_s(i,j)*sstcl_ob(ij) + tsfc(i,j) = fmask_l(i,j) * stl_am(ij)& + & + fmask_s(i,j) * sst_am(ij) + tref(i,j) = tsfc(i,j) + corh(i,j) + psfc(i,j) = (tsfc(i,j)/tref(i,j))**pexp + end do + end do + + !Troy edited this for gcc 2021 + psfc_dummy = 1.0 + + call shtorh(0, ngp, tref, psfc_dummy, -1., dummy, dummy, qref) + call shtorh(0, ngp, tsfc, psfc, 1., dummy, dummy, qsfc) + + corh = refrh1 * (qref - qsfc) + + if (iitest > 1.and.imode == 0) call outest(19,corh) + + call spec(corh,qcorh) +end + +subroutine setgam(tyear,gamlat) + ! aux. routine gamlat : compute reference lapse rate + ! as a function of latitude and date + + use mod_dyncon0, only: gamma + use mod_atparam + use mod_physcon, only: gg + + implicit none + + real, intent(in) :: tyear + integer, parameter :: nlon = ix, nlat = il, nlev = kx, ngp = nlon * nlat + integer :: j + + real, intent(inout) :: gamlat(nlat) + + gamlat(1) = gamma/(1000. * gg) + do j = 2, nlat + gamlat(j) = gamlat(1) + end do +end + +subroutine outest(iunit,fout) + ! aux. routine outest : write one field on a test output file + + use mod_atparam + + implicit none + + integer, intent(in) :: iunit + real, intent(in) :: fout(ix, il) + integer :: i, j + + real*4 :: r4out(ix,il) + + do j = 1, il + do i = 1, ix + r4out(i,j) = fout(i,j) + end do + end do + + write (iunit) r4out +end diff --git a/src/ini_impint.f90 b/src/ini_impint.f90 new file mode 100755 index 0000000..71fdd83 --- /dev/null +++ b/src/ini_impint.f90 @@ -0,0 +1,153 @@ +subroutine impint(dt,alph) + ! subroutine impint(dt,alph) + ! + ! Purpose : initialize constants for implicit computation of + ! horizontal diffusion and gravity waves + ! Input : dt = time step + ! alph = stepping coefficient for gravity wave scheme + ! (0.0 = forward, 0.5 = centred, 1.0 = backward) + ! Initialized common blocks : dync5, dync6, hdifc2 + + ! IMPINT initializes constants for the implicit gravity wave computation. + ! It is assumed that that all implicit steps are of length DELT2 and use + ! the forward/backward parameter ALPH. IMPINT has to be re-called + ! whenever either of these two parameters is changed. IMPINT should + ! be called even if the explicit option is chosen for the gravity wave + ! terms (the reference state temperature TREF is subtracted from some + ! terms anyway to reduce roundoff error; also the constants needed for + ! the biharmonic diffusion, which is assumed always to be backwards + ! implicit, are defined in IMPINT) + + use mod_dyncon0, only: gamma + use mod_atparam + use mod_dyncon1, only: akap, rgas, hsg, dhs, fsg, fsgr, a, grav + use mod_dyncon2 + use mod_hdifcon, only: dmp, dmpd, dmps, dmp1, dmp1d, dmp1s + + implicit none + + real, intent(in) :: dt, alph + real :: dsum(kx), ya(kx,kx) + integer :: indx(kx), m, n, k, k1, k2, l, ll, mm + real :: rgam, xi, xxi, xxx + + ! 1. Constants for backwards implicit biharmonic diffusion + do m=1,mx + do n=1,nx + dmp1 (m,n)=1./(1.+dmp (m,n)*dt) + dmp1d(m,n)=1./(1.+dmpd(m,n)*dt) + dmp1s(m,n)=1./(1.+dmps(m,n)*dt) + end do + end do + + ! 1. Constants for implicit gravity wave computation + ! reference atmosphere, function of sigma only + rgam = rgas*gamma/(1000.*grav) + + do k=1,kx + tref(k)=288.*max(0.2,fsg(k))**rgam + print *, ' tref = ', tref(k) + tref1(k)=rgas*tref(k) + tref2(k)=akap*tref(k) + tref3(k)=fsgr(k)*tref(k) + end do + + ! Other constants + xi=dt*alph + xxi = xi/(a*a) + + dhsx = xi * dhs + + do n=1,nx + do m=1,mx + mm=isc*(m-1)+1 + ll=mm+n-2 + elz(m,n)=float(ll)*float(ll+1)*xxi + end do + end do + + !T(K) = TEX(K)+YA(K,K')*D(K') + XA(K,K')*SIG(K') + + xa(:kx,:kxm) = 0.0 + + do k=1,kx + do k1=1,kx + ya(k,k1)=-akap*tref(k)*dhs(k1) + end do + end do + + do k=2,kx + xa(k,k-1)=0.5*(akap*tref(k)/fsg(k)-(tref(k)-tref(k-1))/dhs(k)) + end do + + do k=1,kxm + xa(k,k)=0.5*(akap*tref(k)/fsg(k)-(tref(k+1)-tref(k))/dhs(k)) + end do + + !sig(k)=xb(k,k')*d(k') + dsum(1)=dhs(1) + do k=2,kx + dsum(k)=dsum(k-1)+dhs(k) + end do + + do k=1,kxm + do k1=1,kx + xb(k,k1)=dhs(k1)*dsum(k) + if(k1.le.k) xb(k,k1)=xb(k,k1)-dhs(k1) + end do + end do + + !t(k)=tex(k)+xc(k,k')*d(k') + do k=1,kx + do k1=1,kx + xc(k,k1)=ya(k,k1) + do k2=1,kxm + xc(k,k1)=xc(k,k1)+xa(k,k2)*xb(k2,k1) + end do + end do + end do + + !P(K)=XD(K,K')*T(K') + xd = 0.0 + + do k=1,kx + do k1=k+1,kx + xd(k,k1)=rgas*log(hsg(k1+1)/hsg(k1)) + end do + end do + do k=1,kx + xd(k,k)=rgas*log(hsg(k+1)/fsg(k)) + end do + + !P(K)=YE(K)+XE(K,K')*D(K') + do k=1,kx + do k1=1,kx + xe(k,k1)=0. + do k2=1,kx + xe(k,k1)=xe(k,k1)+xd(k,k2)*xc(k2,k1) + end do + end do + end do + + do l=1,lmax + xxx=(float(l)*float(l+1))/(a*a) + do k=1,kx + do k1=1,kx + xf(k,k1,l)=xi*xi*xxx*(rgas*tref(k)*dhs(k1)-xe(k,k1)) + end do + end do + do k=1,kx + xf(k,k,l)=xf(k,k,l)+1. + end do + end do + + do l=1,lmax + call inv(xf(1,1,l),xj(1,1,l),indx,kx) + end do + + do k=1,kx + do k1=1,kx + xc(k,k1)=xc(k,k1)*xi + end do + end do +end diff --git a/src/ini_inbcon.f90 b/src/ini_inbcon.f90 new file mode 100755 index 0000000..578fda8 --- /dev/null +++ b/src/ini_inbcon.f90 @@ -0,0 +1,495 @@ +subroutine inbcon(grav0,radlat) + ! + ! subroutine inbcon (grav0,radlat) + ! + ! Purpose : Read topography and climatological boundary conditions + ! Input : grav0 = gravity accel. + ! radlat = grid latitudes in radiants + + use mod_cpl_flags, only: icsea, isstan + use mod_tsteps, only: isst0 + use mod_atparam + use mod_surfcon + use mod_cli_land + use mod_cli_sea + !use mod_io, only : write_netcdf_2d,read_netcdf_2d_dp + + implicit none + + real, intent(in) :: grav0, radlat(il) + integer, parameter :: nlon = ix, nlat = il, ngp = ix*il + + real*4 :: r4inp(nlon,nlat), dummy4 + real :: inp(nlon,nlat), phis1(nlon,nlat) + real :: veg(nlon,nlat), swl1(nlon,nlat), swl2(nlon,nlat) + + integer :: iitest=1, i, idep2, irec, irecl, it, j, jrec + real :: rad2deg, rsw, sdep1, sdep2, swroot, swwil2, thrsh + real, allocatable :: temp2d(:,:) + + ! Set threshold for land-sea mask definition + ! (ie minimum fraction of either land or sea) + + thrsh = 0.1 + + ! 1. Read topographical fields (orography, land-sea mask) + if (iitest >= 1) print *,' read orography' + + call load_boundary_file(1,20,inp,0) + + phi0 = grav0*inp + + call truncg (ntrun,phi0,phis0) + + if (iitest >= 1) print *,' read fractional land-sea mask' + + call load_boundary_file(1,20,inp,1) + + fmask = inp + + ! 2. Initialize land-sfc boundary conditions + + ! 2.1 Fractional and binary land masks + do j=1,il + do i=1,ix + fmask_l(i,j) = fmask(i,j) + + if (fmask_l(i,j).ge.thrsh) then + bmask_l(i,j) = 1. + if (fmask(i,j).gt.(1.-thrsh)) fmask_l(i,j) = 1. + else + bmask_l(i,j) = 0. + fmask_l(i,j) = 0. + end if + + fmask1(i,j) = fmask_l(i,j) + end do + end do + + ! 2.2 Annual-mean surface albedo + if (iitest >= 1) print *,' read surface albedo' + + call load_boundary_file(1,20,inp,2) + + alb0 = inp + + ! 2.3 Land-surface temp. + if (iitest >= 1) print *,' reading land-surface temp.' + + do it = 1,12 + call load_boundary_file(1,23,inp,it-1) + + call fillsf(inp,nlon,nlat,0.) + + stl12(1:nlon,1:nlat,it) = inp + end do + + if (iitest == 1) print *,' checking land-surface temp.' + + call forchk(bmask_l,stl12,ngp,12,0.,400.,273.) + + ! 2.4 Snow depth + if (iitest >= 1) print *,' reading snow depth' + + do it = 1,12 + call load_boundary_file(1,24,inp,it-1) + + snowd12(1:nlon,1:nlat,it) = inp + end do + + if (iitest >= 1) print *,' checking snow depth' + + CALL FORCHK (bmask_l,snowd12,ngp,12,0.,20000.,0.) + + ! 2.5 Read soil moisture and compute soil water availability + ! using vegetation fraction + + if (iitest >= 1) print *,' reading soil moisture' + + ! Read vegetation fraction + call load_boundary_file(1,20,veg,3) + call load_boundary_file(1,20,inp,4) + + ! Combine high and low vegetation fractions + veg = max(0.,veg+0.8*inp) + + ! Read soil moisture + sdep1 = 70. + idep2 = 3 + sdep2 = idep2*sdep1 + + swwil2= idep2*swwil + rsw = 1./(swcap+idep2*(swcap-swwil)) + + do it = 1,12 + call load_boundary_file(1,26,swl1,3*it-3) + call load_boundary_file(1,26,swl2,3*it-2) + + ! Combine soil water content from two top layers + do j = 1,nlat + do i = 1,nlon + swroot = idep2*swl2(i,j) + inp(i,j) = min(1.,rsw*(swl1(i,j)+veg(i,j)*max(0.,swroot-swwil2))) + end do + end do + + soilw12(1:nlon,1:nlat,it) = inp + end do + + if (iitest >= 1) print *,' checking soil moisture' + + call forchk(bmask_l,soilw12,ngp,12,0.,10.,0.) + + ! 3. Initialize sea-sfc boundary conditions + + ! 3.1 Fractional and binary sea masks + do j=1,il + do i=1,ix + fmask_s(i,j) = 1.-fmask(i,j) + + if (fmask_s(i,j).ge.thrsh) then + bmask_s(i,j) = 1. + if (fmask_s(i,j).gt.(1.-thrsh)) fmask_s(i,j) = 1. + else + bmask_s(i,j) = 0. + fmask_s(i,j) = 0. + end if + end do + end do + + ! Grid latitudes for sea-sfc. variables + rad2deg = 90.0/asin(1.) + deglat_s = rad2deg*radlat + + ! 3.2 SST + if (iitest >= 1) print *,' reading sst' + + do it = 1,12 + call load_boundary_file(1,21,inp,it-1) + + call fillsf(inp,nlon,nlat,0.) + + sst12(1:nlon,1:nlat,it) = inp + end do + + if (iitest >= 1) print *,' checking sst' + + call forchk(bmask_s,sst12,ngp,12,100.,400.,273.) + + ! 3.3 Sea ice concentration + if (iitest >= 1) print *,' reading sea ice' + + do it = 1,12 + call load_boundary_file(1,22,inp,it-1) + + inp = max(inp,0.) + + sice12(1:nlon,1:nlat,it) = inp + end do + + if (iitest >= 1) print *,' checking sea ice' + + call forchk(bmask_s,sice12,ngp,12,0.,1.,0.) + + ! 3.4 SST anomalies for initial and prec./following months + if (isstan > 0) then + if (iitest >= 1) print *,' reading sst anomalies' + + print *, 'isst0 = ', isst0 + do it=1,3 + if ((isst0 <= 1 .and. it /= 2) .or. isst0 > 1) then + call load_boundary_file(1,30,inp,isst0-2+it-1) + end if + + sstan3(1:nlon,1:nlat,it) = inp + end do + + if (iitest >= 1) print *,' checking sst anomalies' + + call forchk(bmask_s,sstan3,ngp,3,-50.,50.,0.) + end if + + ! 4. Climatological fields for the ocean model (TO BE RECODED) + ! 4.1. Annual-mean heat flux into sea-surface + + hfseacl = 0.0 + + if (icsea >= 1) then + if (iitest >= 1) print *,' reading sfc heat fluxes' + + irecl = 4*ix*il + irec = 0 + + open ( unit=31, file='fort.31', status='old',& + & form='unformatted', access='direct', recl=irecl ) + + do it = 1,12 + irec=irec+2 + read (31,rec=irec) r4inp + + do j = 1,il + do i = 1,ix + hfseacl(i,j) = hfseacl(i,j)+r4inp(i,j) + end do + end do + end do + + do j = 1,il + do i = 1,ix + if (bmask_s(i,j).gt.0.) then + hfseacl(i,j) = hfseacl(i,j)/(12.*fmask_s(i,j)) + else + hfseacl(i,j) = 0. + end if + end do + end do + + if (iitest >= 1) print *,' checking sfc heat fluxes' + + call forchk (bmask_s,hfseacl,ix*il,1,-1000.,1000.,0.) + end if + + ! 4.2. Ocean model SST climatology: + ! defined by adding SST model bias to obs. climatology + ! (bias may be defined in a different period from climatology) + + if (icsea >= 3) then + if (iitest >= 1) print *,' reading ocean model SST bias' + + !irecl = 4*ix*il + !irec = 0 + + !open ( unit=32, file='fort.32', status='old',& + ! & form='unformatted', access='direct', recl=irecl ) + + do it = 1,12 + ! irec=irec+1 + ! read (32,rec=irec) r4inp + read (32) r4inp + + do j = 1,il + do i = 1,ix + sstom12(i,j,it) = sst12(i,j,it)+r4inp(i,j) + end do + end do + end do + + if (iitest >= 1) print *,' checking ocean model SST' + + call forchk (bmask_s,sstom12,ix*il,12,100.,400.,273.) + end if +end + +subroutine forchk (fmask,field,ngp,nf,fmin,fmax,fset) + ! Aux. routine forchk: Check consistency of sfc fields with land-sea mask + ! and set undefined values to a constant (to avoid over/underflow) + + implicit none + + real, intent(in) :: fmask(ngp) + real, intent(inout) :: field(ngp,nf) + integer, intent(in) :: ngp, nf + real, intent(in) :: fmin, fmax, fset + + integer :: jf, jgp, nfault + + do jf = 1,nf + nfault=0 + + do jgp = 1,ngp + if (fmask(jgp).gt.0.0) then + if (field(jgp,jf).lt.fmin.or.field(jgp,jf).gt.fmax) then + nfault = nfault+1 + end if + else + field(jgp,jf) = fset + end if + end do + + print *, ' field: ', jf, ' no. of faulty points:', nfault + end do + + print *, ' undefined values set to', fset +end + +subroutine ftland (stl,phi0,phis0,fmaskl) + use mod_dyncon0, only: gamma + use mod_dyncon1, only: gcos, grav + use mod_atparam + + implicit none + + integer, parameter :: nlon = ix, nlat = il + + real, dimension(nlon, nlat), intent(inout) :: stl, phi0, phis0, fmaskl + real :: stl2(nlon,nlat), sumt, sumw + integer :: nl8, nlat1, nlat2, i, idtr, itr, j, jband, jfil + real :: gam + + nl8 = nlat/8 + gam = 0.001*gamma/grav + + nlat1 = 1 + nlat2 = nl8 + + do jband=1,8 + sumt=0. + sumw=0. + + do j=nlat1,nlat2 + do i=1,nlon + stl(i,j)=stl(i,j)+gam*phi0(i,j) + sumt=sumt+gcos(j)*fmaskl(i,j)*stl(i,j) + sumw=sumw+gcos(j)*fmaskl(i,j) + end do + end do + + SUMT=SUMT/SUMW + + do j=nlat1,nlat2 + do i=1,nlon + if (fmaskl(i,j).eq.0.) stl(i,j)=sumt + end do + end do + + nlat1=nlat1+nl8 + nlat2=nlat2+nl8 + end do + + itr=7 + idtr=(ntrun-6)/3 + + do jfil=1,4 + call truncg (itr,stl,stl2) + + do j=1,nlat + do i=1,nlon + if (fmaskl(i,j).eq.0.) stl(i,j)=stl2(i,j) + end do + end do + + itr=min(itr+idtr,ntrun) + end do + + call truncg (itr,stl,stl2) + + stl = stl2 - gam * phis0 +end + +subroutine truncg (itr,fg1,fg2) + ! subroutine truncg (itr,fg1,fg2) + ! Purpose : compute a spectrally-filtered grid-point field + ! Input : itr : spectral truncation (triangular) + ! : fg1 : original grid-point field + ! Output : fg2 : filtered grid-point field + + USE mod_atparam + + implicit none + + integer, intent(in) :: itr + + real, dimension(ix,il), intent(inout) :: fg1 (ix,il), fg2(ix,il) + complex :: fsp(mx,nx), zero + integer :: n, m, itwn + + print *, 'Filter applied at wavenumber ', itr + + zero = (0.,0.) + + call spec (fg1,fsp) + + do n=1,nx + do m=1,mx + itwn=isc*(m-1)+n-1 + if (itwn.gt.itr) fsp(m,n)=zero + end do + end do + + call grid (fsp,fg2,1) +end + +subroutine fillsf(sf,nlon,nlat,fmis) + ! subroutine fillsf (sf,nlon,nlat) + ! Purpose: replace missing values in surface fields + ! NB: it is assumed that non-missing values exist near the Equator + + implicit none + + real :: sf(nlon,nlat), sf2(0:nlon+1) + integer, intent(in) :: nlon, nlat + real, intent(in) :: fmis + + integer :: khem, j, j1, j2, j3, i, nmis + real :: fmean + + do khem = 1,2 + if (khem == 1) then + j1 = nlat/2 + j2 = 1 + j3 = -1 + else + j1 = j1+1 + j2 = nlat + j3 = 1 + end if + + do j=j1,j2,j3 + sf2(1:nlon) = sf(1:nlon,j) + + nmis = 0 + do i=1,nlon + if (sf(i,j) < fmis) then + nmis = nmis+1 + sf2(i) = 0. + end if + end do + + if (nmis < nlon) fmean = sum(sf2(1:nlon))/float(nlon-nmis) + + do i=1,nlon + if (sf(i,j).lt.fmis) sf2(i) = fmean + end do + + sf2(0) = sf2(nlon) + sf2(nlon+1) = sf2(1) + do i=1,nlon + if (sf(i,j).lt.fmis) sf(i,j) = 0.5*(sf2(i-1)+sf2(i+1)) + end do + end do + end do +end + +subroutine load_boundary_file(ioflag,iunit,fld,offset) + ! if ioflag = 1 : read field on from unit=iunit + ! if ioflag = 2 : write field on from unit=iunit + + use mod_atparam + + implicit none + + integer, parameter :: nlon = ix, nlat = il, ngp = ix*il + integer, intent(in) :: ioflag, iunit, offset + real :: fld(nlon,nlat) + real(4) :: inp(nlon,nlat) + integer :: i + + open(unit=iunit, form='unformatted', access='direct', recl=nlon*4, convert='little_endian') + !open(unit=iunit, form='binary', access='direct', recl=nlon*4, convert='little_endian') + if (ioflag <= 1) then + do i = 1, nlat + read(iunit,rec=offset*nlat+i) inp(:,nlat+1-i) + end do + + fld = inp + + ! Fix undefined values + where (fld <= -999) fld = 0.0 + else + inp = fld + do i = nlat*offset+1, nlat*offset+nlat + write(iunit,rec=i) inp(:,i) + end do + endif + close(unit=iunit) +end diff --git a/src/ini_indyns.f90 b/src/ini_indyns.f90 new file mode 100755 index 0000000..071bb76 --- /dev/null +++ b/src/ini_indyns.f90 @@ -0,0 +1,128 @@ +subroutine indyns + ! subroutine indyns + ! + ! Purpose : set time-stepping constants and initialize coefficients + ! and spectral operators for model dynamics + ! Initialized common blocks: dync0, dync1, dync2, dync3, dync4, + ! hdifc1, hdifc3, + ! common blocks for spectral transforms + ! (through routine parmtr) + ! + + use mod_tsteps, only: nsteps, alph + use mod_dyncon0 + use mod_dyncon1 + use mod_atparam + use mod_hdifcon, only: dmp, dmpd, dmps, tcorv, qcorv + use mod_spectral, only: sia, cosg + + implicit none + + integer :: j, k, jj, npowhd + real :: elap, elapn, hdifd, hdiff, hdifs, qexp, rad1, rgam, rlap, twn + + ! 1. Definition of constants + if (mod(nsteps,2) /= 0) stop ' Invalid no. of time steps' + + ! alph = 0 ---- forward step for gravity wave terms + ! alph = 1 ---- backward implicit ----------------- + ! alph = 0.5 -- centered implicit ----------------- + alph = 0.5 + + ! Power of Laplacian in horizontal diffusion + npowhd = 4 + + ! 2. Definition of model levels + + ! 2.1 Half (vertical velocity) levels + if (kx == 5) then + hsg(:6) = (/ 0.000, 0.150, 0.350, 0.650, 0.900, 1.000 /) + else if (kx == 7) then + hsg(:8) = (/ 0.020, 0.140, 0.260, 0.420, 0.600, 0.770, 0.900, 1.000 /) + else if (kx == 8) then + hsg(:9) = (/ 0.000, 0.050, 0.140, 0.260, 0.420, 0.600, 0.770, 0.900, 1.000 /) + end if + + do k = 1, kxp + print *, ' Model half-level (*1000)', k, nint(HSG(k)*1000) + end do + + ! 2.2 Layer thicknesses and full (u,v,T) levels + do k = 1, kx + dhs(k) = hsg(k+1)-hsg(k) + fsg(k) = 0.5*(hsg(k+1)+hsg(k)) + end do + + do k = 1, kx + print *, ' Model full-level (*1000)', k, nint(FSG(k)*1000) + end do + + ! 2.3 Additional functions of sigma + do k = 1, kx + dhsr(k) = 0.5/dhs(k) + fsgr(k) = akap/(2.*fsg(k)) + end do + + ! 3. Horizontal functions and spectral operators + + ! 3.1 Initialization of spectral operators + call parmtr(rearth) + + ! 3.2 Latitudes and functions of latitude + ! NB: J=1 is Southernmost point! + do j = 1, iy + jj = il + 1 - j + rad1 = asin(sia(j)) + radang(j) = -rad1 + radang(jj) = rad1 + gsin(j) = -sia(j) + gsin(jj) = sia(j) + end do + + do j = 1, il + gcos(j) = cosg(j) + coriol(j) = 2.*omega*gsin(j) + end do + + + ! 4. Coefficients to compute geopotential + do k = 1, kx + xgeop1(k) = rgas*log(hsg(k+1)/fsg(k)) + if (k /= kx) xgeop2(k+1) = rgas*log(fsg(k+1)/hsg(k+1)) + end do + + ! 5. Coefficients for horizontal diffusion + + ! 5.1 Spectral damping coefficients + hdiff = 1./(thd *3600.) + hdifd = 1./(thdd*3600.) + hdifs = 1./(thds*3600.) + rlap = 1./float(mtrun*(mtrun+1)) + + do j = 1, nx + do k = 1, mx + twn = float(isc*(k-1)+j-1) + elap = (twn*(twn+1.)*rlap) + elapn = elap**npowhd + dmp(k,j) = hdiff*elapn + dmpd(k,j) = hdifd*elapn + dmps(k,j) = hdifs*elap + end do + ! dmps(1,j)=0. + end do + + ! 5.2 Orographic correction terms for temperature and humidity + ! (vertical component) + rgam = rgas*gamma/(1000.*grav) + qexp = hscale/hshum + + tcorv(1)=0. + qcorv(1)=0. + qcorv(2)=0. + + do k = 2, kx + tcorv(k) = fsg(k)**rgam + if (k.gt.2) qcorv(k) = fsg(k)**qexp + print *, ' temp/hum correction at level ', k, tcorv(k), qcorv(k) + end do +end diff --git a/src/ini_iniatm.f90 b/src/ini_iniatm.f90 new file mode 100755 index 0000000..5f4cc10 --- /dev/null +++ b/src/ini_iniatm.f90 @@ -0,0 +1,135 @@ +subroutine ini_atm(cexp) + ! subroutine ini_atm (cexp) + ! + ! purpose : call initialization routines for all model common blocks + + use mod_tsteps, only: nmonts, nsteps, nstout, idout, iyear0, imont0, indrdf, ipout, ihout + use mod_atparam + use mod_dyncon1, only: grav, hsg, fsg, radang + use mod_tmean + use mod_date, only: ndaytot + + implicit none + + character(len=3) :: cexp ! experiment identifier + real :: ppl(kx) ! post-processing levels (hpa/1000) + integer :: iitest = 1, is3d = 1, k, nddm, ndm, ndtm, ntm + + ! 1. initialize ffts + if (iitest == 1) print *, 'calling inifft' + call inifft + + ! 2. initialize dynamical constants and operators + if (iitest == 1) print *, 'calling indyns' + call indyns + + ! 3. set post-processing levels + do k = 1, kx + ppl(k) = prlev(fsg(k)) + end do + + ! 4. initialize constants for physical parametrization + if (iitest == 1) print *, 'calling inphys' + call inphys(hsg, ppl, radang) + + ! 5. initialize forcing fields (boundary cond. + random forcing) + if (iitest == 1) print *, 'calling inbcon' + call inbcon(grav,radang) + + if (iitest == 1) print *, 'calling inirdf' + call inirdf(indrdf) + + ! 6. initialize model variables + if (iitest == 1) print *, 'calling invars' + call invars + + ! 7. initialize time-mean arrays for surface fluxes and output fields + if (iitest == 1) print *, 'calling dmflux' + !call dmflux(0) + + if (iitest == 1) print *, 'calling dmout' + !call dmout(0) + + if (ihout .eqv. .false.) then ! Do not call time-mean procedures if IHOUT = true + !if (iitest == 1) print *, 'calling tmout' + !call tmout(0) + + ! 8. set up the time-mean and daily-mean output (grads format) + ! 8.1 control files for time-means + !if (nstout <= 0) then + ! ntm = nmonts + ! ndtm = - 1 + !else + ! ntm = ndaytot*nsteps/nstout + ! ndtm = 1440*nstout/nsteps + !end if + + if (iitest == 1) print *, 'calling setctl' + + !call setctl(12, ix, il, kx, ntm, ndtm, is3d, ns3d1, ns2d_1, ns2d_2,& + ! & radang, ppl, 'attm', cexp, iyear0, imont0) + !is3d = is3d + ns3d1 + !call setctl(14, ix, il, kx, ntm, ndtm, is3d, ns3d2, 0, 0, radang, ppl,& + ! & 'atva', cexp, iyear0, imont0) + + !is3d = is3d + ns3d2 + !call setctl(16, ix, il, kx, ntm, ndtm, is3d, ns3d3, 0, 0, radang, ppl,& + ! & 'atdf', cexp, iyear0, imont0) + + ! 8.2 control files for daily means + !ndm = ndaytot + !nddm = 1 + + if (iitest == 1) print *, 'calling setctl_d' + + !if (idout == 1) then + ! call setctl_d(18, ix, il, kx, ndm, nddm, 3, 1, radang, ppl, 'daytm',& + ! & cexp, iyear0, imont0) + !else if (idout == 2) then + ! call setctl_d(18, ix, il, kx, ndm, nddm, ns2d_d1, 1, radang, ppl,& + ! & 'daytm', cexp, iyear0, imont0) + !else if (idout >= 3) then + ! call setctl_d(18, ix, il, kx, ndm, nddm, ns2d_d1, ns2d_d2, radang, ppl,& + ! & 'daytm', cexp, iyear0, imont0) + !end if + else + !call iogrid(5) ! create control file for 6-hourly output + !if (ipout) then + ! call iogrid(3) + ! call geop(1) + !end if + end if + + ! 8.3 output files for grid-point fields + !if (ihout .eqv. .false.) call setgrd(0,cexp) + + ! Write initial data + !if (ihout .and. ipout) call iogrid(2) + !if (ihout) call iogrid(4) + + contains + function prlev(siglev) + ! function prlev (siglev) + ! purpose : select the closest standard pressure level for post-proc. + ! input : siglev = sigma level + implicit none + + real, intent(in) :: siglev + real :: plev(14) = (/ 0.925, 0.850, 0.775, 0.700, 0.600, 0.500, 0.400,& + & 0.300, 0.250, 0.200, 0.150, 0.100, 0.050, 0.030 /) + real :: prlev, dif, adif + integer :: k + + dif = 1.0 - siglev + + prlev = 1.0 + + do k = 1, 14 + adif = abs(plev(k) - siglev) + if (adif <= dif) then + dif = adif + prlev = plev(k) + end if + end do + end +end diff --git a/src/ini_inirdf.f90 b/src/ini_inirdf.f90 new file mode 100755 index 0000000..25cc8a9 --- /dev/null +++ b/src/ini_inirdf.f90 @@ -0,0 +1,186 @@ +subroutine inirdf(indrdf) + ! subroutine inirdf (indrdf) + ! + ! Purpose : Initialize random diabatic forcing + ! Input : inirdf = index of forcing perturbation + + use mod_atparam + use mod_physcon, only: slat + use mod_randfor, only: randfh + + implicit none + + real, external :: ran1 + + integer, intent(in) :: indrdf + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real :: redgrd(0:36,0:18), randf2(nlon,nlat), rnlon(0:18), colat(nlat) + real :: ampl, flat1, flat2, fran, freq0, rdeg, rlon + integer :: i, iseed, j, jlat, jlat1, jlat2, jlon, jlon1, nf, ntrfor + + integer :: nlonrg(0:18) = (/ 1, 6, 12, 18, 24, 28, 32, 34, 36, 36,& + & 36, 34, 32, 28, 24, 18, 12, 6, 1 /) + + ! RMS aplitude of (non-null) horizontal perturbation + ampl = 0.5 + + ! Frequency of grid points with null perturbation + freq0 = 0. + + ! ntrfor = spectral truncation of random forcing + ntrfor = 18 + + ! 1. Initialization + iseed = -abs(indrdf) + if (indrdf.lt.0.) ampl = -ampl + + do i=1,20 + fran = ran1(iseed) + end do + + do jlat=0,18 + rnlon(jlat) = float(nlonrg(jlat))/float(nlon) + end do + + rdeg = 9./asin(1.) + do j=1,nlat + colat(j)=rdeg*asin(slat(j))+9. + end do + + do nf=1,2 + ! 2. Fill reduced grid with normally-distributed random numbers + do jlat=0,18 + call gausts(nlonrg(jlat),0.,ampl,0.,0,iseed,redgrd(1,jlat)) + + if (freq0.gt.0.) then + do jlon=1,nlonrg(jlat) + fran = RAN1(iseed) + if (fran.lt.freq0) redgrd(jlon,jlat) = 0. + end do + end if + + redgrd(0,jlat) = redgrd(nlonrg(jlat),jlat) + end do + + ! 3. Interpolate random field to gaussian grid + do j=1,nlat + jlat1 = int(colat(j)) + jlat2 = jlat1+1 + + do i=1,nlon + rlon = (i-1)*rnlon(jlat1) + jlon = int(rlon) + flat1 = redgrd(jlon,jlat1) + (rlon-jlon) *& + & (redgrd(jlon+1,jlat1)-redgrd(jlon,jlat1)) + + rlon = (i-1)*rnlon(jlat2) + jlon1 = int(rlon) + flat2 = redgrd(jlon,jlat2) + (rlon-jlon) *& + & (redgrd(jlon+1,jlat2)-redgrd(jlon,jlat2)) + + randf2(i,j) = flat1+(colat(j)-jlat1)*(flat2-flat1) + end do + end do + + ! 4. Spectral filter of gaussian-grid field + call truncg(ntrfor,randf2,randfh(1,1,nf)) + end do +end + +subroutine gausts(nt,av,sd,ac,ndis,iseed,ts) + ! subroutine gausts (nt,av,sd,ac,ndis,iseed,ts) + ! Computes a gaussian-dist. time series (ts) of (nt) random values, with + ! assigned average (av), stand. dev. (sd), and lag-1 autocorrelation (ac). + ! Autocor. may be discontinued at the limits between (ndis) sub-series. + ! Uses function ran1 to generate uniform deviates from seed (iseed) + ! Adapted from Numerical Recipes, Chapter 7.2 + + implicit none + + real, external :: ran1 + + integer, intent(in) :: nt, ndis, iseed + real, intent(in) :: av, sd, ac + real, intent(inout) :: ts(nt) + integer :: j, nt2, j2, jd + real :: v1, v2, rsq, fact, sd2 + + rsq = 2.0 + + ! 1. Generate a time series of (nt) gaussian deviates + do j=2,nt,2 + do while(rsq.gt.1.or.rsq.eq.0.) + v1=2.*ran1(iseed)-1. + v2=2.*ran1(iseed)-1. + rsq=v1*v1+v2*v2 + end do + + fact=sqrt(-2.*log(rsq)/rsq) + ts(j-1)=v1*fact + ts(j) =v2*fact + end do + + ! 2. Introduce autocorrelation (if requested) + if (ac.ne.0.) then + nt2=nt/max(1,ndis) + sd2=sqrt(1.-ac*ac) + + j=0 + do jd=1,ndis + j=j+1 + do j2=2,nt2 + j=j+1 + ts(j)=ac*ts(j-1)+sd2*ts(j) + end do + end do + end if + + ! 3. Set assigned average and standard deviation + do j=1,nt + ts(j)=sd*ts(j)+av + end do +end + +function ran1(idum) + ! function ran1 (idum) + ! Returns a uniform random deviate between 0.0 and 1.0 + ! Set IDUM to any negative value to (re)initialize the sequence + ! From Numerical Recipes, Chapter 7.1 + + implicit none + + integer :: idum + integer, parameter :: im=714025, ia=1366, ic=150889 + real, parameter :: rm=1./im + integer, save :: iy = -1 + integer :: j + real :: ran1 + + integer, save :: ir(97) = 0.0 + + if (idum.lt.0.or.iy.lt.0) then + ! Initialize the shuffle array + idum=mod(ic+abs(idum),im) + + do j=1,97 + idum=mod(ia*idum+ic,im) + ir(j)=idum + end do + + idum=mod(ia*idum+ic,im) + iy=idum + end if + + ! Get one integer number from the shuffle table + j=1+(97*iy)/im + !if (j.gt.97.or.j.lt.1) stop ' error in random no. generator' + iy=ir(j) + + ! Turn the selected integer into a real no. between 0 and 1 + ran1=iy*rm + + ! Replace the selected integer with another random integer + idum=mod(ia*idum+ic,im) + ir(j)=idum +end diff --git a/src/ini_inphys.f90 b/src/ini_inphys.f90 new file mode 100755 index 0000000..771d1fd --- /dev/null +++ b/src/ini_inphys.f90 @@ -0,0 +1,51 @@ +subroutine inphys(hsg,ppl,rlat) + ! + ! subroutine inphys (hsg,ppl,rlat) + ! + ! Purpose: Initialize common blocks for physical parametrization routines + ! Input : hsg : sigma at half levels + ! ppl : pressure levels for post-processing + ! rlat : gaussian-grid latitudes + ! Initialized common blocks: phycon, fsiglt, forcon, + ! cnvcon, lsccon, radcon, sflcon, vdicon + + use mod_atparam + use mod_physcon + + implicit none + + integer, parameter :: nlon = ix, nlat = il, nlev = kx, ngp = nlon*nlat + + real :: hsg(0:nlev), ppl(nlev), rlat(nlat) + integer :: j, k + + ! 1.2 Functions of sigma and latitude + sigh(0) = hsg(0) + + do k = 1, nlev + sig(k) = 0.5*(hsg(k)+hsg(k-1)) + sigl(k) = log(sig(k)) + sigh(k) = hsg(k) + dsig(k) = hsg(k)-hsg(k-1) + pout(k) = ppl(k) + grdsig(k) = gg/(dsig(k)*p0) + grdscp(k) = grdsig(k)/cp + end do + + ! Weights for vertical interpolation at half-levels(1,nlev) and surface + ! Note that for phys.par. half-lev(k) is between full-lev k and k+1 + ! Fhalf(k) = Ffull(k)+WVI(K,2)*(Ffull(k+1)-Ffull(k)) + ! Fsurf = Ffull(nlev)+WVI(nlev,2)*(Ffull(nlev)-Ffull(nlev-1)) + do k = 1, nlev-1 + wvi(k,1) = 1./(sigl(k+1)-sigl(k)) + wvi(k,2) = (log(sigh(k))-sigl(k))*wvi(k,1) + end do + + wvi(nlev,1) = 0. + wvi(nlev,2) = (log(0.99)-sigl(nlev))*wvi(nlev-1,1) + + do j = 1, nlat + slat(j) = sin(rlat(j)) + clat(j) = cos(rlat(j)) + end do +end diff --git a/src/ini_invars.f90 b/src/ini_invars.f90 new file mode 100755 index 0000000..4c59d7c --- /dev/null +++ b/src/ini_invars.f90 @@ -0,0 +1,145 @@ +subroutine invars + ! subroutine invars (istart) + ! + ! Purpose : initialize all spectral variables starting from + ! either a reference atmosphere or a restart file + ! Input : istart = 0 : reference atmosphere (at rest) + ! = 1 : restart file + ! Initialized common blocks : date1, dynsp1, dynsp2 (phis only), + ! sfcanom, sfcflux + + use mod_tsteps, only: iyear0, imont0, istart, era_start + use mod_dyncon0, only: gamma, hscale, hshum, refrh1 + use mod_atparam + use mod_dynvar + use mod_dyncon1, only: grav, rgas, fsg + use mod_surfcon, only: phi0, phis0 + use mod_date, only: iyear, imonth, iday, ihour + + implicit none + + complex :: zero, ccon, surfs(mx,nx) + real :: surfg(ix,il) + real :: gam1, esref, factk, gam2, qexp, qref, rgam, rgamr, rlog0, tref, ttop + integer :: i, j, k + + gam1 = gamma/(1000.*grav) + zero = (0.,0.) + ccon = (1.,0.)*sqrt(2.) + + ! 1. Compute spectral surface geopotential + call spec(phi0,phis) + if (ix.eq.iy*4) call trunct(phis) + + call grid(phis,phis0,1) + + if (istart.eq.0) then + ! 2. Start from reference atmosphere (at rest) + print*, ' starting from rest' + + iyear = iyear0 + imonth = imont0 + iday = 1 + ihour = 0 + + ! 2.1 Set vorticity, divergence and tracers to zero + vor(:,:,:,1) = zero + div(:,:,:,1) = zero + tr(:,:,:,1,:) = zero + + ! 2.2 Set reference temperature : + ! tropos: T = 288 degK at z = 0, constant lapse rate + ! stratos: T = 216 degK, lapse rate = 0 + tref = 288. + ttop = 216. + gam2 = gam1/tref + rgam = rgas*gam1 + rgamr = 1./rgam + + ! Surface and stratospheric air temperature + t(:,:,1,1) = zero + t(:,:,2,1) = zero + surfs = -gam1 * phis + + t(1,1,1,1) = ccon*ttop + t(1,1,2,1) = ccon*ttop + surfs(1,1) = ccon*tref - gam1*phis(1,1) + + ! Temperature at tropospheric levels + do k=3,kx + factk=fsg(k)**rgam + t(:,:,k,1) = surfs * factk + end do + + ! 2.3 Set log(ps) consistent with temperature profile + ! p_ref = 1013 hPa at z = 0 + rlog0 = log(1.013) + + do j=1,il + do i=1,ix + surfg(i,j) = rlog0 + rgamr*log(1.-gam2*phis0(i,j)) + end do + end do + + call spec(surfg,ps) + if (ix.eq.iy*4) call trunct(ps) + + ! 2.4 Set tropospheric spec. humidity in g/kg + ! Qref = RHref * Qsat(288K, 1013hPa) + esref = 17. + qref = refrh1*0.622*esref + qexp = hscale/hshum + + ! Spec. humidity at the surface + do j=1,il + do i=1,ix + surfg(i,j)=qref*exp(qexp*surfg(i,j)) + end do + print *, ' q0 jlat = ', j, surfg(1,j) + end do + + call spec(surfg,surfs) + if (ix.eq.iy*4) call trunct (surfs) + + ! Spec. humidity at tropospheric levels + do k=3,kx + factk=fsg(k)**qexp + print *, 'vertical scale factor at level ', k, factk + tr(:,:,k,1,1) = surfs * factk + end do + + ! Print diagnostics from initial conditions + call diagns (1,0) + else if (istart .eq. 1) then + ! 3. Start from restart file + print*,' reading a restart file' + + call restart(0) + + ! Print diagnostics from initial conditions + call diagns (2,0) + else if ((istart .eq. 2).and.(era_start == 0)) then + ! 4. Start from grid initial condition + + call iogrid(27) + call diagns(1,0) + else if ((istart .eq. 2).and.(era_start == 1)) then + ! 5. Start from grid era_5 re_analysis + + call iogrid(28) + call diagns(1,0) + else if ((istart .eq. 2).and.(era_start == 2)) then + ! 6. Regrid era data + + call iogrid(29) + call diagns(1,0) + else if((istart .eq. 2).and.(era_start == 3)) then + !7. hybrid machine learning!!! + + call iogrid(30) + call diagns(1,0) + else + print *, 'IMPOSSIBLE!! check the fort.2 file!' + stop + endif +end diff --git a/src/ini_stepone.f90 b/src/ini_stepone.f90 new file mode 100755 index 0000000..82e695b --- /dev/null +++ b/src/ini_stepone.f90 @@ -0,0 +1,35 @@ +subroutine stepone + ! subroutine stepone + ! + ! purpose : call initialization of semi-implicit scheme + ! and perform initial time step + + use mod_tsteps, only: delt, delt2, alph, rob, wil, istart + + implicit none + + integer :: iitest = 1 + real :: delth + + if (iitest == 1) print *, ' instep: initial time step' + + if (istart == 0 .or. istart == 2) then + + delth = 0.5 * delt + + if (iitest == 1) print *, ' semi-impl. initialization' + call impint(delth, alph) + + if (iitest == 1) print *, ' forward half-step' + call step(1, 1, delth, alph, rob, wil) + + if (iitest == 1) print *, ' semi-impl. initialization' + call impint(delt, alph) + + if (iitest == 1) print *, ' leapfrog half-step' + call step(1, 2, delt, alph, rob, wil) + end if + + if (iitest == 1) print *, ' semi-impl. initialization' + call impint(delt2, alph) +end diff --git a/src/mod_atparam.f90 b/src/mod_atparam.f90 new file mode 100755 index 0000000..a7d3daf --- /dev/null +++ b/src/mod_atparam.f90 @@ -0,0 +1,15 @@ +module mod_atparam + implicit none + + private + public isc, ntrun, mtrun, ix, iy + public nx, mx, mxnx, mx2, il, ntrun1, nxp, mxp, lmax + public kx, kx2, kxm, kxp, ntr + + integer, parameter :: isc = 1 + integer, parameter :: ntrun = 30, mtrun = 30, ix = 96, iy = 48/2 + integer, parameter :: nx = ntrun+2, mx = mtrun+1, mxnx = mx*nx, mx2 = 2*mx + integer, parameter :: il = 2*iy, ntrun1 = ntrun+1 + integer, parameter :: nxp = nx+1 , mxp = isc*mtrun+1, lmax = mxp+nx-2 + integer, parameter :: kx = 8, kx2=2*kx, kxm=kx-1, kxp=kx+1, ntr=1 +end module diff --git a/src/mod_calendar.f90 b/src/mod_calendar.f90 new file mode 100755 index 0000000..01ef9dc --- /dev/null +++ b/src/mod_calendar.f90 @@ -0,0 +1,214 @@ +module mod_calendar + !module to hold calendar stuff for hybrid and parallel reservoir + !calculations and this is completely independent from speedy's + !internal calendar + + use mod_utilities, only : calendar_type + + implicit none + + type(calendar_type) :: calendar + + contains + + subroutine initialize_calendar(datetime,startyear,startmonth,startday,starthour) + type(calendar_type), intent(inout) :: datetime + integer, intent(in) :: startyear,startmonth,startday,starthour + + datetime%startyear = startyear + datetime%startmonth = startmonth + datetime%startday = startday + datetime%starthour = starthour + end subroutine + + subroutine get_current_time_delta_hour(datetime,hours_elapsed) + !Takes an initialized calendar_type object and updates the current date + !variables + type(calendar_type), intent(inout) :: datetime + integer, intent(in) :: hours_elapsed + + !Local stuff + integer :: years_elasped, months_elapsed, days_elapsed, day_of_year + integer :: month, day_while_counter, leap_days + integer :: i + integer, parameter :: hours_in_year=8760 !Average number of hours in a year (includes leap year) + + integer, parameter :: hours_in_a_day=24 + + logical :: is_leap_year + !365-day calendar + integer :: ncal365(12) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31,& + 30, 31 /) + + !Get the new year first + years_elasped = hours_elapsed/hours_in_year + + datetime%currentyear = years_elasped + datetime%startyear + + !We need to get the leap years between start and now + leap_days = 0 + do i=0,years_elasped - 1 + call leap_year_check(datetime%startyear+i,is_leap_year) + if(is_leap_year) then + leap_days = leap_days + 1 + endif + end do + + !Lets find what day we are in the year + call leap_year_check(datetime%currentyear,is_leap_year) + + day_of_year = (mod(hours_elapsed,hours_in_year)/hours_in_a_day) - leap_days + if(is_leap_year) then + ncal365(2) = 29 + end if + + day_while_counter = day_of_year + month = 1 + do while(day_while_counter > 0) + day_while_counter = day_while_counter - ncal365(month) + month = month + 1 + end do + + month = month - 1 + + if(month <= 0) then + month = 12 + datetime%currentyear = datetime%currentyear - 1 + endif + + months_elapsed = month + + !Set the new month + datetime%currentmonth = months_elapsed + + !Get day of month + days_elapsed = ncal365(month) + day_while_counter + datetime%currentday = days_elapsed + + !Get hour of day + datetime%currenthour = mod(hours_elapsed,hours_in_a_day) + + return + end subroutine + + subroutine leap_year_check(year,is_leap_year) + integer, intent(in) :: year + logical, intent(out) :: is_leap_year + + if((mod(year,4) == 0).and.(mod(year,100) /= 0)) then + is_leap_year = .True. + else if(mod(year,400) == 0) then + is_leap_year = .True. + else + is_leap_year = .False. + endif + return + end subroutine + + subroutine numof_hours(startyear,endyear,numofhours) + !Get the number of hours assumes you start of jan 1 of start year and end + !dec 31 of + !endyear + integer, intent(in) :: startyear, endyear + integer, intent(out) :: numofhours + + integer :: years_elapsed, i + integer, parameter :: hours_in_year=8760 !Number of hours in a 365 day year + integer, parameter :: hours_in_year_leap_year = 8784 + + logical :: is_leap_year + + years_elapsed = endyear-startyear + numofhours = 0 + do i=0,years_elapsed + call leap_year_check(startyear+i,is_leap_year) + if(is_leap_year) then + numofhours = numofhours + hours_in_year_leap_year + else + numofhours = numofhours + hours_in_year + endif + enddo + end subroutine + + subroutine numof_hours_into_year(year,month,day,hour,numofhours) + !Get the number of hours you are into the year assumes you start of jan 1 of year + integer, intent(in) :: year,month,day,hour + integer, intent(out) :: numofhours + + integer :: months_elapsed, i + + logical :: is_leap_year + + integer :: ncal365(12) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31,& + 30, 31 /) + + integer :: ncal_leap(12) = (/ 31, 29, 31, 30, 31, 30, 31, 31, 30, 31,& + 30, 31 /) + + months_elapsed = month + + numofhours = 0 + call leap_year_check(year,is_leap_year) + !Loop through months + if (months_elapsed > 1) then + do i=1,months_elapsed-1 + if(is_leap_year) then + numofhours = numofhours + 24*ncal_leap(i) + else + numofhours = numofhours + 24*ncal365(i) + endif + enddo + endif + + !Loop through days + if(day > 1) then + do i=1,day-1 + numofhours = numofhours + 24 + enddo + endif + + numofhours = numofhours+hour + + if(numofhours == 0) then + numofhours = 1 + endif + end subroutine + + subroutine time_delta_between_two_dates(start_year,start_month,start_day,start_hour,end_year,end_month,end_day,end_hour,numofhours) + integer, intent(in) :: start_year,start_month,start_day,start_hour + integer, intent(in) :: end_year,end_month,end_day,end_hour + integer, intent(out) :: numofhours + + !Local variables + integer :: hours_into_start_year, hours_into_end_year + integer :: hours_between_years + + if(start_year /= end_year) then + call numof_hours(start_year,end_year-1,hours_between_years) + + call numof_hours_into_year(start_year,start_month,start_day,start_hour,hours_into_start_year) + + call numof_hours_into_year(end_year,end_month,end_day,end_hour,hours_into_end_year) + + numofhours = hours_between_years + hours_into_end_year - hours_into_start_year + + else + call numof_hours_into_year(start_year,start_month,start_day,start_hour,hours_into_start_year) + + call numof_hours_into_year(end_year,end_month,end_day,end_hour,hours_into_end_year) + + numofhours = hours_into_end_year - hours_into_start_year + + endif + + end subroutine + + subroutine time_delta_between_two_dates_datetime_type(datatime1,datetime2,timedelta) + type(calendar_type), intent(inout) :: datatime1,datetime2 + + integer, intent(out) :: timedelta + + call time_delta_between_two_dates(datatime1%currentyear,datatime1%currentmonth,datatime1%currentday,datatime1%currenthour,datetime2%currentyear,datetime2%currentmonth,datetime2%currentday,datetime2%currenthour,timedelta) + + end subroutine +end module mod_calendar diff --git a/src/mod_clean_speedy.f90 b/src/mod_clean_speedy.f90 new file mode 100755 index 0000000..56c1bf7 --- /dev/null +++ b/src/mod_clean_speedy.f90 @@ -0,0 +1,58 @@ +module mod_clean_speedy + !We need to flush the memeory of speedy + !This module sets every speedy variable to zero + + use mod_cli_land + use mod_cli_sea + use mod_cplcon_sea + use mod_cpl_land_model + use mod_cplvar_sea + use mod_dyncon1 + + subroutine clean_up_speedy() + !mod_cli_land vars + fmask_l = 0.0 + bmask_l = 0.0 + stl12 = 0.0 + snowd12 = 0.0 + soilw12 = 0.0 + + !mod_cli_sea.f90 vars + fmask_s = 0.0 + bmask_s = 0.0 + deglat_s = 0.0 + sst12 = 0.0 + + !mod_cplcon_sea vars + rhcaps = 0.0 + rhcapi = 0.0 + cdsea = 0.0 + cdice = 0.0 + + !mod_cpl_land_model + rhcapl = 0.0 + cdland = 0.0 + vland_input = 0.0 + vland_output = 0.0 + + !mod_cplvar_sea + vsea_input = 0.0 + vsea_output = 0.0 + + !mod_dyncon1 + hsg = 0.0 + dhs = 0.0 + fsg = 0.0 + dhsr = 0.0 + fsgr = 0.0 + radang = 0.0 + gsin = 0.0 + gcos = 0.0 + coriol = 0.0 + xgeop1 = 0.0 + xgeop2 = 0.0 + + + + + diff --git a/src/mod_cli_land.f90 b/src/mod_cli_land.f90 new file mode 100755 index 0000000..36c1ab9 --- /dev/null +++ b/src/mod_cli_land.f90 @@ -0,0 +1,25 @@ +module mod_cli_land + use mod_atparam + + implicit none + + private + public fmask_l, bmask_l, stl12, snowd12, soilw12 + + ! Land masks + ! Fraction of land + real :: fmask_l(ix,il) + + ! Binary land mask + real :: bmask_l(ix,il) + + ! Monthly-mean climatological fields over land + ! Land surface temperature + real :: stl12(ix,il,12) + + ! Snow depth (water equiv.) + real :: snowd12(ix,il,12) + + ! Soil water availabilityend module + real :: soilw12(ix,il,12) +end module diff --git a/src/mod_cli_sea.f90 b/src/mod_cli_sea.f90 new file mode 100755 index 0000000..dcc8c22 --- /dev/null +++ b/src/mod_cli_sea.f90 @@ -0,0 +1,36 @@ +module mod_cli_sea + use mod_atparam + + implicit none + + private + public fmask_s, bmask_s, deglat_s, sst12, sice12, sstan3, hfseacl, sstom12 + + ! Sea masks + ! Fraction of sea + real :: fmask_s(ix,il) + + ! Binary sea mask + real :: bmask_s(ix,il) + + ! Grid latitudes + real :: deglat_s(il) + + ! Monthly-mean climatological fields over sea + ! Sea/ice surface temperature + real :: sst12(ix,il,12) + + ! Sea ice fraction + real :: sice12(ix,il,12) + + ! SST anomaly fields + ! SST anomaly in 3 consecutive months + real :: sstan3(ix,il,3) + + ! Climatological fields from model output + ! Annual-mean heat flux into sea sfc. + real :: hfseacl(ix,il) + + ! Ocean model SST climatology + real :: sstom12(ix,il,12) +end module diff --git a/src/mod_cnvcon.f90 b/src/mod_cnvcon.f90 new file mode 100755 index 0000000..afb3dbf --- /dev/null +++ b/src/mod_cnvcon.f90 @@ -0,0 +1,26 @@ +!> @brief +!> Convection constants. +module mod_cnvcon + implicit none + + private + public psmin, trcnv, rhbl, rhil, entmax, smf + + ! Minimum (norm.) sfc. pressure for the occurrence of convection + real, parameter :: psmin = 0.8 + + ! Time of relaxation (in hours) towards reference state + real, parameter :: trcnv = 6.0 + + ! Relative hum. threshold in the boundary layer + real, parameter :: rhbl = 0.9 + + ! Rel. hum. threshold in intermed. layers for secondary mass flux + real, parameter :: rhil = 0.7 + + ! Max. entrainment as a fraction of cloud-base mass flux + real, parameter :: entmax = 0.5 + + ! Ratio between secondary and primary mass flux at cloud-base + real, parameter :: smf = 0.8 +end module diff --git a/src/mod_cnvcon.pert.f90 b/src/mod_cnvcon.pert.f90 new file mode 100755 index 0000000..9345e6d --- /dev/null +++ b/src/mod_cnvcon.pert.f90 @@ -0,0 +1,26 @@ +!> @brief +!> Convection constants. +module mod_cnvcon + implicit none + + private + public psmin, trcnv, rhbl, rhil, entmax, smf + + ! Minimum (norm.) sfc. pressure for the occurrence of convection + real, parameter :: psmin = 0.8 + + ! Time of relaxation (in hours) towards reference state + real, parameter :: trcnv = 4.0 + + ! Relative hum. threshold in the boundary layer + real, parameter :: rhbl = 0.8 + + ! Rel. hum. threshold in intermed. layers for secondary mass flux + real, parameter :: rhil = 0.9 + + ! Max. entrainment as a fraction of cloud-base mass flux + real, parameter :: entmax = 0.3 + + ! Ratio between secondary and primary mass flux at cloud-base + real, parameter :: smf = 0.7 +end module diff --git a/src/mod_cpl_flags.f90 b/src/mod_cpl_flags.f90 new file mode 100755 index 0000000..384a131 --- /dev/null +++ b/src/mod_cpl_flags.f90 @@ -0,0 +1,20 @@ +!> @brief +!> Flags to set coupling options (see doc_instep.txt). +module mod_cpl_flags + implicit none + + private + public icland, icsea, icice, isstan + + ! Flag for land-coupling + integer :: icland = 1 + + ! Flag for sea (SST) coupling + integer :: icsea = 0 + + ! Flag for sea-ice coupling + integer :: icice = 1 + + ! Flag for observed SST anomaly + integer :: isstan = 0 +end module diff --git a/src/mod_cpl_land_model.f90 b/src/mod_cpl_land_model.f90 new file mode 100755 index 0000000..7c334b1 --- /dev/null +++ b/src/mod_cpl_land_model.f90 @@ -0,0 +1,127 @@ +module mod_cpl_land_model + use mod_atparam + + implicit none + + ! 1./heat_capacity (land) + real :: rhcapl(ix,il) + + ! 1./dissip_time (land) + real :: cdland(ix,il) + + ! Input and output land variables exchanged by coupler + ! Land model input variables + real :: vland_input(ix*il,4) + + ! Land model output variables + real :: vland_output(ix*il,2) + + contains + subroutine land_model_init(fmask_l,alb0) + ! subroutine land_model_init (fmask_l,alb0) + ! + ! purpose : initialization of land model + ! initialized common blocks: land_mc + + ! Input variables + ! Land mask (fraction of land) + real, intent(in) :: fmask_l(ix,il) + ! Annual-mean albedo + real, intent(in) :: alb0(ix,il) + + ! Auxiliary variables + integer :: i, j + real :: dmask(ix,il) ! domain mask + real :: depth_soil, depth_lice, tdland, hcapl, hcapli, flandmin + + ! 1. Set heat capacities and dissipation times for + ! soil and ice-sheet layers + + ! Model parameters (default values) + + ! Soil layer depth (m) + depth_soil = 1.0 + + ! Land-ice depth (m) + depth_lice = 5.0 + + ! Dissipation time (days) for land-surface temp. anomalies + tdland = 40. + + ! Minimum fraction of land for the definition of anomalies + flandmin = 1./3. + + ! Reset model parameters + include "cls_inland.h" + + ! Heat capacities per m^2 (depth*heat_cap/m^3) + hcapl = depth_soil*2.50e+6 + hcapli = depth_lice*1.93e+6 + + ! 2. Compute constant fields + ! Set domain mask (blank out sea points) + dmask(:,:) = 1. + + do j=1,il + do i=1,ix + if (fmask_l(i,j).lt.flandmin) dmask(i,j) = 0 + end do + end do + + ! Set time_step/heat_capacity and dissipation fields + do j=1,il + do i=1,ix + if (alb0(i,j).lt.0.4) then + rhcapl(i,j) = 86400./hcapl + else + rhcapl(i,j) = 86400./hcapli + endif + end do + end do + + cdland(:,:) = dmask(:,:)*tdland/(1.+dmask(:,:)*tdland) + end + + subroutine land_model + ! subroutine land_model + ! + ! purpose : integrate slab land-surface model for one day + + !real vland_input(ix,il,3), vland_output(ix,il,2) + + ! Input variables: + real :: stl0(ix*il) ! land temp. at initial time + real :: hfland(ix*il) ! land sfc. heat flux between t0 and t1 + real :: stlcl1(ix*il) ! clim. land temp. at final time + + ! Output variables + real :: stl1(ix*il) ! land temp. at final time + + ! Auxiliary variables + real :: hflux(ix*il) ! net sfc. heat flux + real :: tanom(ix*il) ! sfc. temperature anomaly + + ! Initialise variables + stl0 = vland_input(:,1) + hfland = vland_input(:,2) + stlcl1 = vland_input(:,3) + + ! 1. Land-surface (soil/ice-sheet) layer + + ! Net heat flux + ! (snow correction to be added?) + hflux = hfland + + ! Anomaly w.r.t final-time climatological temp. + tanom = stl0 - stlcl1 + + ! Time evoloution of temp. anomaly + tanom = reshape(cdland, (/ ix*il /))*& + & (tanom+reshape(rhcapl, (/ ix*il /))*hflux) + + ! Full SST at final time + stl1 = tanom + stlcl1 + + vland_output(:,1) = stl1 + end +end diff --git a/src/mod_cplcon_sea.f90 b/src/mod_cplcon_sea.f90 new file mode 100755 index 0000000..2b277c9 --- /dev/null +++ b/src/mod_cplcon_sea.f90 @@ -0,0 +1,24 @@ +module mod_cplcon_sea + use mod_atparam + + implicit none + + private + public rhcaps, rhcapi, cdsea, cdice, beta + + ! Constant parameters and fields in sea/ice model + ! 1./heat_capacity (sea) + real :: rhcaps(ix,il) + + ! 1./heat_capacity (ice) + real :: rhcapi(ix,il) + + ! 1./dissip_time (sea) + real :: cdsea(ix,il) + + ! 1./dissip_time (ice) + real :: cdice(ix,il) + + ! Heat flux coef. at sea/ice int. + real :: beta = 1.0 +end module diff --git a/src/mod_cplvar_sea.f90 b/src/mod_cplvar_sea.f90 new file mode 100755 index 0000000..32b7649 --- /dev/null +++ b/src/mod_cplvar_sea.f90 @@ -0,0 +1,15 @@ +module mod_cplvar_sea + use mod_atparam + + implicit none + + private + public vsea_input, vsea_output + + ! Input and output sea variables exchanged by coupler + ! Ocean model input variables + real :: vsea_input(ix*il,8) + + ! Ocean model output variablesend module + real :: vsea_output(ix*il,3) +end module diff --git a/src/mod_date.f90 b/src/mod_date.f90 new file mode 100755 index 0000000..5305862 --- /dev/null +++ b/src/mod_date.f90 @@ -0,0 +1,91 @@ +module mod_date + implicit none + + private + public iyear, imonth, iday, imont1, tmonth, tyear, ndaycal, ndaytot + public ihour + public newdate + + ! Date and time variables (updated in NEWDATE) + integer :: iyear, imonth, iday, imont1, ihour + real :: tmonth, tyear + + ! Calendar set-up (initialized in NEWDATE) + integer :: ndaycal(12,2), ndaytot + + contains + subroutine newdate(imode) + !-- subroutine newdate (imode) + !-- purpose: initilialize and update date variables + !-- input : imode = 0 for initialization, > 0 for update + + use mod_tsteps + + implicit none + + integer, intent(in) :: imode + integer, parameter :: ncal = 365 + integer :: jm, im + + ! 365-day calendar + integer :: ncal365(12) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31,& + & 30, 31 /) + + if (imode <= 0) then + ! calendar + if (ncal == 365) then + ndaycal(:,1) = ncal365(:) + else + ndaycal(:,1) = 30 + end if + + ndaycal(1,2) = 0 + do jm = 2, 12 + ndaycal(jm,2) = ndaycal(jm-1,1)+ndaycal(jm-1,2) + end do + + ! total no. of integration days + ndaytot = ndaysl + im = imont0 + + do jm=1,nmonts + ndaytot = ndaytot+ndaycal(im,1) + im = im+1 + if (im.eq.13) im=1 + end do + else + ! set new date + iday = iday+1 + + ! Leap year and February? + if (mod(iyear,4) == 0 .and. imonth == 2) then + if (iday > 29) then + iday = 1 + imonth = imonth+1 + end if + else + if (iday > ndaycal(imonth,1)) then + iday = 1 + imonth = imonth+1 + end if + end if + + if (imonth > 12) then + imonth = 1 + iyear = iyear+1 + end if + end if + + ! additional variables to define forcing terms and boundary cond. + if (iseasc >= 1) then + imont1 = imonth + tmonth = (iday-0.5)/float(ndaycal(imonth,1)) + tyear = (ndaycal(imonth,2)+iday-0.5)/float(ncal) + else + imont1 = imont0 + tmonth = 0.5 + tyear = (ndaycal(imont1,2)& + & +0.5*ndaycal(imont1,2))/float(ncal) + end if + end subroutine +end module diff --git a/src/mod_dyncon0.f90 b/src/mod_dyncon0.f90 new file mode 100755 index 0000000..7b2df6e --- /dev/null +++ b/src/mod_dyncon0.f90 @@ -0,0 +1,36 @@ +!> @brief +!> Constants for initialization of dynamics. +module mod_dyncon0 + implicit none + + private + public gamma, hscale, hshum, refrh1, thd, thdd, thds, tdrs + + ! Ref. temperature lapse rate (-dT/dz in deg/km) + real, parameter :: gamma = 6.0 + + ! Ref. scale height for pressure (in km) + real, parameter :: hscale = 7.5 + + ! Ref. scale height for spec. humidity (in km) + real, parameter :: hshum = 2.5 + + ! Ref. relative humidity of near-surface air + real, parameter :: refrh1 = 0.7 + + ! Max damping time (in hours) for hor. diffusion (del^6) of temperature and + ! vorticity + real, parameter :: thd = 2.4 + + ! Max damping time (in hours) for hor. diffusion (del^6) + ! of divergence + real, parameter :: thdd = 2.4 + + ! Max damping time (in hours) for extra diffusion (del^2) + ! in the stratosphere + real, parameter :: thds = 12.0 + + ! Damping time (in hours) for drag on zonal-mean wind + ! in the stratosphere + real, parameter :: tdrs = 24.0 * 30.0 +end module diff --git a/src/mod_dyncon0.pert.f90 b/src/mod_dyncon0.pert.f90 new file mode 100755 index 0000000..1fb02d8 --- /dev/null +++ b/src/mod_dyncon0.pert.f90 @@ -0,0 +1,36 @@ +!> @brief +!> Constants for initialization of dynamics. +module mod_dyncon0 + implicit none + + private + public gamma, hscale, hshum, refrh1, thd, thdd, thds, tdrs + + ! Ref. temperature lapse rate (-dT/dz in deg/km) + real, parameter :: gamma = 6.0 + + ! Ref. scale height for pressure (in km) + real, parameter :: hscale = 7.5 + + ! Ref. scale height for spec. humidity (in km) + real, parameter :: hshum = 2.5 + + ! Ref. relative humidity of near-surface air + real, parameter :: refrh1 = 0.7 + + ! Max damping time (in hours) for hor. diffusion (del^6) of temperature and + ! vorticity + real, parameter :: thd = 2.88 + + ! Max damping time (in hours) for hor. diffusion (del^6) + ! of divergence + real, parameter :: thdd = 2.88 + + ! Max damping time (in hours) for extra diffusion (del^2) + ! in the stratosphere + real, parameter :: thds = 14.4 + + ! Damping time (in hours) for drag on zonal-mean wind + ! in the stratosphere + real, parameter :: tdrs = 24.0 * 36.0 +end module diff --git a/src/mod_dyncon1.f90 b/src/mod_dyncon1.f90 new file mode 100755 index 0000000..a146562 --- /dev/null +++ b/src/mod_dyncon1.f90 @@ -0,0 +1,30 @@ +module mod_dyncon1 + use mod_atparam + + implicit none + + private + public rearth, omega, grav, akap, rgas, pi, a, g + public hsg, dhs, fsg, dhsr, fsgr + public radang, gsin, gcos, coriol + public xgeop1, xgeop2 + + ! Physical constants for dynamics + real, parameter :: rearth = 6.371e+6 + real, parameter :: omega = 7.292e-05 + real, parameter :: grav = 9.81 + real, parameter :: akap = 2./7. + real, parameter :: rgas = akap*1004. + real, parameter :: pi = 4.*atan(1.) + real, parameter :: a = rearth + real, parameter :: g = grav + + ! Vertical level parameters (initial. in indyns) + real :: hsg(kxp), dhs(kx), fsg(kx), dhsr(kx), fsgr(kx) + + ! Functions of lat. and lon. (initial. in indyns) + real :: radang(il), gsin(il), gcos(il), coriol(il) + + ! Constants for hydrostatic eq. (initial. in indyns) + real :: xgeop1(kx), xgeop2(kx) +end module diff --git a/src/mod_dyncon2.f90 b/src/mod_dyncon2.f90 new file mode 100755 index 0000000..5fbaf5d --- /dev/null +++ b/src/mod_dyncon2.f90 @@ -0,0 +1,16 @@ +module mod_dyncon2 + use mod_atparam + + implicit none + + private + public :: tref, tref1, tref2, tref3 + public :: xa, xb, xc, xd, xe, xf, xg, xh, xj, dhsx, elz + + ! Temp. profile for semi-imp. scheme (initial. in IMPINT) + real, dimension(kx) :: tref, tref1, tref2, tref3 + + real, dimension(kx,kx) :: xa, xb, xc, xd, xe + real, dimension(kx,kx,lmax) :: xf, xg, xh, xj + real :: dhsx(kx), elz(mx,nx) +end module diff --git a/src/mod_dynvar.f90 b/src/mod_dynvar.f90 new file mode 100755 index 0000000..d66d469 --- /dev/null +++ b/src/mod_dynvar.f90 @@ -0,0 +1,35 @@ +!> @brief +!> Prognostic spectral variables for model dynamics, and geopotential. +!> Initialised in invars. +module mod_dynvar + use mod_atparam + + implicit none + + private + public vor, div, t, ps, tr + public phi, phis + + ! Prognostic spectral variables (updated in step) + ! Vorticity + complex :: vor(MX,NX,KX,2) + + ! Divergence + complex :: div(MX,NX,KX,2) + + ! Absolute temperature + complex :: t(MX,NX,KX,2) + + ! Log of (norm.) sfc pressure (p_s/p0) + complex :: PS(MX,NX,2) + + ! Tracers (tr.1: spec. humidity in g/kg) + complex :: TR(MX,NX,KX,2,NTR) + + ! Geopotential (updated in geop) + ! Atmos. geopotential + complex :: PHI(MX,NX,KX) + + ! Surface geopotential + complex :: PHIS(MX,NX) +end module diff --git a/src/mod_fft.f90 b/src/mod_fft.f90 new file mode 100755 index 0000000..ed4dec8 --- /dev/null +++ b/src/mod_fft.f90 @@ -0,0 +1,10 @@ +module mod_fft + use mod_atparam, only: ix + + implicit none + + private + public wsave + + real :: wsave(2*ix+15) +end module diff --git a/src/mod_flx_land.f90 b/src/mod_flx_land.f90 new file mode 100755 index 0000000..9f8ef7b --- /dev/null +++ b/src/mod_flx_land.f90 @@ -0,0 +1,40 @@ +module mod_flx_land + use mod_atparam + + implicit none + + private + public prec_l, snowf_l, evap_l, ustr_l, vstr_l, ssr_l, slr_l, shf_l, ehf_l,& + & hflux_l + + ! Fluxes at land surface (all downward, except evaporation) + ! Precipitation (land) + real :: prec_l(ix*il) + + ! Snowfall (land) + real :: snowf_l(ix*il) + + ! Evaporation (land) + real :: evap_l(ix*il) + + ! u-wind stress (land) + real :: ustr_l(ix*il) + + ! v-wind stress (land) + real :: vstr_l(ix*il) + + ! Sfc short-wave radiation (land) + real :: ssr_l(ix*il) + + ! Sfc long-wave radiation (land) + real :: slr_l(ix*il) + + ! Sensible heat flux (land) + real :: shf_l(ix*il) + + ! Latent heat flux (land) + real :: ehf_l(ix*il) + + ! Net heat flux into land sfc.end module + real :: hflux_l(ix*il) +end module diff --git a/src/mod_flx_sea.f90 b/src/mod_flx_sea.f90 new file mode 100755 index 0000000..5c1e02e --- /dev/null +++ b/src/mod_flx_sea.f90 @@ -0,0 +1,43 @@ +module mod_flx_sea + use mod_atparam + + implicit none + + private + public prec_s, snowf_s, evap_s, ustr_s, vstr_s, ssr_s, slr_s, shf_s, ehf_s,& + & hflux_s, hflux_i + + ! Fluxes at sea surface (all downward, except evaporation) + ! Precipitation (sea) + real :: prec_s(ix*il) + + ! Snowfall (sea) + real :: snowf_s(ix*il) + + ! Evaporation (sea) + real :: evap_s(ix*il) + + ! u-wind stress (sea) + real :: ustr_s(ix*il) + + ! v-wind stress (sea) + real :: vstr_s(ix*il) + + ! Sfc short-wave radiation (sea) + real :: ssr_s(ix*il) + + ! Sfc long-wave radiation (sea) + real :: slr_s(ix*il) + + ! Sensible heat flux (sea) + real :: shf_s(ix*il) + + ! Latent heat flux (sea) + real :: ehf_s(ix*il) + + ! Net heat flux into sea sfc. + real :: hflux_s(ix*il) + + ! Net heat flux into sea-ice sfc. + real :: hflux_i(ix*il) +end module diff --git a/src/mod_hdifcon.f90 b/src/mod_hdifcon.f90 new file mode 100755 index 0000000..2351a64 --- /dev/null +++ b/src/mod_hdifcon.f90 @@ -0,0 +1,20 @@ +module mod_hdifcon + use mod_atparam + + implicit none + + private + public dmp, dmpd, dmps, dmp1, dmp1d, dmp1s, tcorv, qcorv, tcorh, qcorh + + ! Damping coef. for horizontal diffusion (explicit) (initial. in indyns) + real, dimension(mx,nx) :: dmp, dmpd, dmps + + ! Damping coef. for horizontal diffusion (implicit) (initial. in indyns) + real, dimension(mx,nx) :: dmp1, dmp1d, dmp1s + + ! Vertical comp. of orographic correction (initial. in INDYNS) + real, dimension(kx) :: tcorv, qcorv + + ! Horizontal component of orographic correction (updated in FORDATE) + complex, dimension(mx,nx) :: tcorh, qcorh +end module diff --git a/src/mod_io.f90 b/src/mod_io.f90 new file mode 100755 index 0000000..2c20386 --- /dev/null +++ b/src/mod_io.f90 @@ -0,0 +1,2584 @@ +module mod_io + use iso_fortran_env + + use netcdf + use mod_utilities, only : dp, speedygridnum, xgrid, ygrid, zgrid, & + speedylat, model_parameters_type, int_32, & + e_constant + + implicit none + + integer :: error + + interface write_netcdf + module procedure write_netcdf_4d + module procedure write_netcdf_4d_logp + module procedure write_netcdf_4d_multi_2d + module procedure write_netcdf_4d_multi_2d_no_sst + end interface + + contains + + function file_exists(filename) result(result_bool) + character(len=*), intent(in) :: filename + logical :: result_bool + + !Very basic way to check if a file exists + inquire(file=trim(filename),exist=result_bool) + + end function + + !-----------NETCDF SECTION ------------------! + subroutine write_netcdf_4d(model_parameters,dat,timestep,filename) + use netcdf + + use stringtype, only : string + use mod_utilities, only : main_type + + real(kind=dp), intent(in) :: dat(:,:,:,:) + integer, intent(in) :: timestep + character(len=*), intent(in) :: filename + type(model_parameters_type) :: model_parameters + + integer, parameter :: numdims=4 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start(numdims),varcount(numdims) + integer, dimension(numdims) :: arrdims + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:) + + type(string) :: units(model_parameters%full_predictvars) + type(string) :: varname(model_parameters%full_predictvars) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + !units(4)%str = 'log(surfacepressure)' + !varname(4)%str = 'logp' + + !copy data + allocate(copy,source=dat) + + dimsx = size(dat,2) + dimsy = size(dat,3) + dimsz = size(dat,4) + + varcount = [integer:: dimsx, dimsy, dimsz, 1] + start = [integer:: 1, 1, 1, timestep ] + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678, -38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989, -9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + if(timestep.eq.1) then + call nc_check(nf90_create(path=filename,cmode=NF90_CLOBBER, ncid=file_id)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', dimsz, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', NF90_UNLIMITED, timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + do i=1, model_parameters%full_predictvars + + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start, count=varcount)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + ! close; done + call nc_check(nf90_close(file_id)) + else + call nc_check(nf90_open(filename,nf90_write,file_id)) + do i=1,model_parameters%full_predictvars + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start,count=varcount)) + enddo + call nc_check(nf90_close(file_id)) + endif + return + end subroutine write_netcdf_4d + + subroutine write_netcdf_4d_logp(model_parameters,grid4d,grid3d,timestep,filename) + use, intrinsic :: ieee_arithmetic + + use stringtype, only : string + use mod_utilities, only : e_constant + + real(kind=dp), intent(in) :: grid4d(:,:,:,:) + real(kind=dp), intent(in) :: grid3d(:,:) !Yes I know bad name sorry + + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + type(model_parameters_type), intent(in) :: model_parameters + + integer, parameter :: numdims4d=4, numdims3d=3 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:) + + type(string) :: units(5) + type(string) :: varname(5) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific-Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + !copy data + allocate(copy,source=grid4d) + + + !if(res%specific_humidity_log_bool) then + ! copy(4,:,:,:) = e_constant**copy(4,:,:,:) - res%specific_humidity_epsilon + !endif + + dimsx = size(grid4d,2) + dimsy = size(grid4d,3) + dimsz = size(grid4d,4) + + varcount4d = [integer:: dimsx, dimsy, dimsz, 1] + start4d = [integer:: 1, 1, 1, timestep] + + varcount3d = [integer:: dimsx, dimsy, 1] + start3d = [integer:: 1, 1, timestep] + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678, -38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989, -9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + if(timestep.eq.1) then + call nc_check(nf90_create(path=filename,cmode=NF90_CLOBBER, ncid=file_id)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', dimsz, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', NF90_UNLIMITED, timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, model_parameters%full_predictvars + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d, count=varcount4d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + !Lets do logp + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + ! close; done + call nc_check(nf90_close(file_id)) + else + call nc_check(nf90_open(filename,nf90_write,file_id)) + do i=1,model_parameters%full_predictvars + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d,count=varcount3d)) + + call nc_check(nf90_close(file_id)) + endif + return + end subroutine write_netcdf_4d_logp + + subroutine write_netcdf_4d_multi_2d(model_parameters,grid4d,grid3d,timestep,filename,ocean_model) + use, intrinsic :: ieee_arithmetic + + use stringtype, only : string + use mod_utilities, only : unstandardize_data, reservoir_type, e_constant + + real(kind=dp), intent(in) :: grid4d(:,:,:,:) + real(kind=dp), intent(in) :: grid3d(:,:,:) !Yes I know bad name sorry + + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + logical :: ocean_model + + type(model_parameters_type), intent(in) :: model_parameters + + integer, parameter :: numdims4d=4, numdims3d=3 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:), copy3d(:,:,:) + + type(string) :: units(7) + type(string) :: varname(7) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific-Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + units(6)%str = 'Kelvin' + varname(6)%str = 'SST' + + units(7)%str = 'in/6hr' + varname(7)%str = 'p6hr' + + !copy data + allocate(copy,source=grid4d) + allocate(copy3d, source=grid3d) + + !unstandarize the data + !call unstandardize_data(res,copy,res%mean,res%std) + + !if(res%specific_humidity_log_bool) then + ! copy(4,:,:,:) = e_constant**copy(4,:,:,:) - + ! res%specific_humidity_epsilon + !endif + + dimsx = size(grid4d,2) + dimsy = size(grid4d,3) + dimsz = size(grid4d,4) + + varcount4d = (/ dimsx, dimsy, dimsz, 1 /) + start4d = (/ 1, 1, 1, timestep /) + + varcount3d = (/ dimsx, dimsy, 1 /) + start3d = (/ 1, 1, timestep /) + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = speedylat + + if(timestep.eq.1) then + call nc_check(nf90_create(path=filename,cmode=ior(nf90_clobber,nf90_64bit_offset),ncid=file_id)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', dimsz, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', NF90_UNLIMITED, timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, model_parameters%full_predictvars + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d, count=varcount4d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + !Lets do logp + + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, grid3d(1,:,:),start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + if(model_parameters%slab_ocean_model_bool) then + call nc_check(nf90_redef(file_id)) + + !Lets do SST + call nc_check(nf90_def_var(file_id,varname(6)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(6)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, grid3d(2,:,:),start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + endif + + + if(model_parameters%precip_bool) then + call nc_check(nf90_redef(file_id)) + + !Lets do 6 hour precip + call nc_check(nf90_def_var(file_id,varname(7)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(7)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + copy3d(3,:,:) = model_parameters%precip_epsilon * ( e_constant**grid3d(3,:,:) - 1) + copy3d(3,:,:) = copy3d(3,:,:) * 39.3701 + + call nc_check(nf90_put_var(file_id, array_id, copy3d(3,:,:), start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + endif + + ! close; done + call nc_check(nf90_close(file_id)) + else + call nc_check(nf90_open(filename,nf90_write,file_id)) + do i=1, model_parameters%full_predictvars + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, grid3d(1,:,:),start=start3d,count=varcount3d)) + + if(ocean_model) then + call nc_check(nf90_inq_varid(file_id,varname(6)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, grid3d(2,:,:), start=start3d, count=varcount3d)) + endif + + if(model_parameters%precip_bool) then + copy3d(3,:,:) = model_parameters%precip_epsilon * (e_constant**grid3d(3,:,:) - 1) + copy3d(3,:,:) = copy3d(3,:,:) * 39.3701 + + call nc_check(nf90_inq_varid(file_id,varname(7)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy3d(3,:,:), start=start3d, count=varcount3d)) + endif + + call nc_check(nf90_close(file_id)) + endif + return + end subroutine + + subroutine write_netcdf_4d_multi_2d_no_sst(model_parameters,grid4d,grid3d,timestep,filename) + use, intrinsic :: ieee_arithmetic + + use stringtype, only : string + use mod_utilities, only : unstandardize_data, reservoir_type, e_constant + + real(kind=dp), intent(in) :: grid4d(:,:,:,:) + real(kind=dp), intent(in) :: grid3d(:,:,:) !Yes I know bad name sorry + + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + logical :: ocean_model + + type(model_parameters_type), intent(in) :: model_parameters + + integer, parameter :: numdims4d=4, numdims3d=3 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:), copy3d(:,:,:) + + type(string) :: units(6) + type(string) :: varname(6) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific-Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + units(6)%str = 'in/6hr' + varname(6)%str = 'p6hr' + + !copy data + allocate(copy,source=grid4d) + allocate(copy3d,source=grid3d) + + !unstandarize the data + !call unstandardize_data(res,copy,res%mean,res%std) + + !if(res%specific_humidity_log_bool) then + ! copy(4,:,:,:) = e_constant**copy(4,:,:,:) - + ! res%specific_humidity_epsilon + !endif + + dimsx = size(grid4d,2) + dimsy = size(grid4d,3) + dimsz = size(grid4d,4) + + varcount4d = (/ dimsx, dimsy, dimsz, 1 /) + start4d = (/ 1, 1, 1, timestep /) + + varcount3d = (/ dimsx, dimsy, 1 /) + start3d = (/ 1, 1, timestep /) + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = speedylat + + if(timestep.eq.1) then + call nc_check(nf90_create(path=filename,cmode=ior(nf90_clobber,nf90_64bit_offset),ncid=file_id)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', dimsz, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', NF90_UNLIMITED, timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, model_parameters%full_predictvars + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d, count=varcount4d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + !Lets do logp + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, grid3d(1,:,:),start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + + if(model_parameters%precip_bool) then + !Lets do 6 hour precip + call nc_check(nf90_def_var(file_id,varname(6)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(6)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + copy3d(2,:,:) = model_parameters%precip_epsilon * (e_constant**grid3d(2,:,:) - 1) + copy3d(2,:,:) = copy3d(2,:,:) * 39.3701 + + call nc_check(nf90_put_var(file_id, array_id, copy3d(2,:,:),start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + endif + + ! close; done + call nc_check(nf90_close(file_id)) + else + call nc_check(nf90_open(filename,nf90_write,file_id)) + do i=1, model_parameters%full_predictvars + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, grid3d(1,:,:),start=start3d,count=varcount3d)) + + if(model_parameters%precip_bool) then + copy3d(2,:,:) = model_parameters%precip_epsilon * (e_constant**grid3d(2,:,:) - 1) + copy3d(2,:,:) = copy3d(2,:,:) * 39.3701 + + call nc_check(nf90_inq_varid(file_id,varname(6)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy3d(2,:,:),start=start3d, count=varcount3d)) + endif + + call nc_check(nf90_close(file_id)) + endif + return + end subroutine + + subroutine write_netcdf_4d_multi_2d_sst_only(model_parameters,grid4d,grid3d,timestep,filename) + use, intrinsic :: ieee_arithmetic + + use stringtype, only : string + use mod_utilities, only : unstandardize_data, reservoir_type, e_constant + + real(kind=dp), intent(in) :: grid4d(:,:,:,:) + real(kind=dp), intent(in) :: grid3d(:,:,:) !Yes I know bad name sorry + + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + logical :: ocean_model + + type(model_parameters_type), intent(in) :: model_parameters + + integer, parameter :: numdims4d=4, numdims3d=3 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:), copy3d(:,:,:) + + type(string) :: units(6) + type(string) :: varname(6) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific-Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + units(6)%str = 'Kelvin' + varname(6)%str = 'sst' + + !copy data + allocate(copy,source=grid4d) + allocate(copy3d,source=grid3d) + + !unstandarize the data + !call unstandardize_data(res,copy,res%mean,res%std) + + !if(res%specific_humidity_log_bool) then + ! copy(4,:,:,:) = e_constant**copy(4,:,:,:) - + ! res%specific_humidity_epsilon + !endif + + dimsx = size(grid4d,2) + dimsy = size(grid4d,3) + dimsz = size(grid4d,4) + + varcount4d = (/ dimsx, dimsy, dimsz, 1 /) + start4d = (/ 1, 1, 1, timestep /) + + varcount3d = (/ dimsx, dimsy, 1 /) + start3d = (/ 1, 1, timestep /) + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = speedylat + + if(timestep.eq.1) then + call nc_check(nf90_create(path=filename,cmode=ior(nf90_clobber,nf90_64bit_offset),ncid=file_id)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', dimsz, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', NF90_UNLIMITED, timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, model_parameters%full_predictvars + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d, count=varcount4d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + !Lets do logp + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, grid3d(1,:,:),start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + + if(model_parameters%slab_ocean_model_bool) then + !Lets do sst + call nc_check(nf90_def_var(file_id,varname(6)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(6)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy3d(2,:,:),start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + endif + + ! close; done + call nc_check(nf90_close(file_id)) + else + call nc_check(nf90_open(filename,nf90_write,file_id)) + do i=1, model_parameters%full_predictvars + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, grid3d(1,:,:),start=start3d,count=varcount3d)) + + if(model_parameters%slab_ocean_model_bool) then + call nc_check(nf90_inq_varid(file_id,varname(6)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy3d(2,:,:),start=start3d, count=varcount3d)) + endif + + call nc_check(nf90_close(file_id)) + endif + return + end subroutine + + subroutine write_netcdf_speedy_full_mpi(timestep,model_parameters,filename,mpi_res,grid4d,grid3d) + use mpi + + use mod_utilities, only : mpi_type, model_parameters_type + use stringtype, only : string + + real(kind=dp), intent(in), optional :: grid4d(:,:,:,:) + real(kind=dp), intent(in), optional :: grid3d(:,:) !Yes I know bad name sorry + + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + type(model_parameters_type), intent(in) :: model_parameters + + type(mpi_type), intent(in) :: mpi_res + + !local netcdf stuff + integer, parameter :: numdims4d=4, numdims3d=3, numspeedyvars=5 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:) + + type(string) :: units(numspeedyvars) + type(string) :: varname(numspeedyvars) + + logical :: makefile + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific_Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + dimsx = xgrid!size(grid4d,2) + dimsy = ygrid!size(grid4d,3) + dimsz = zgrid!size(grid4d,4) + + varcount4d = [integer:: dimsx, dimsy, dimsz, 1] + start4d = [integer:: 1, 1, 1, timestep] + + varcount3d = [integer:: dimsx, dimsy, 1 ] + start3d = [integer:: 1, 1, timestep ] + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678,-38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989, -9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + if(timestep == 1) then + makefile = .True. + else + makefile = .False. + endif + + if(makefile) then + !call nc_check(nf90_create(filename,IOR(NF90_NETCDF4,NF90_MPIIO),file_id,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL)) + call nc_check(nf90_create(filename,IOR(NF90_NETCDF4,NF90_MPIIO),file_id,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', dimsz, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', int(model_parameters%predictionlength/model_parameters%timestep+1,kind=int32), timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, numspeedyvars-1 + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + call nc_check(nf90_var_par_access(file_id, array_id, nf90_collective)) + + !Write out the values + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + + enddo + !Lets do logp + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + call nc_check(nf90_var_par_access(file_id, array_id, nf90_collective)) + + !Write out the values + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + call nc_check(nf90_close(file_id)) + else + !call nc_check(nf90_open(filename,IOR(NF90_WRITE,NF90_MPIIO),file_id,comm=mpi_res%mpi_world%MPI_VAL,info=MPI_INFO_NULL)) + call nc_check(nf90_open(filename,IOR(NF90_WRITE,NF90_MPIIO),file_id,comm=mpi_res%mpi_world,info=MPI_INFO_NULL)) + + if(mpi_res%is_root) then + !copy data + allocate(copy,source=grid4d) + do i=1, numspeedyvars-1 + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_var_par_access(file_id,array_id,nf90_independent)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + + call nc_check(nf90_var_par_access(file_id,array_id,nf90_independent)) + + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d,count=varcount3d)) + deallocate(copy) + endif + + call nc_check(nf90_close(file_id)) + endif + + return + end subroutine + + subroutine write_netcdf_speedy_full(grid4d,grid3d,timestep,filename) + use stringtype, only : string + + real(kind=dp), intent(in) :: grid4d(:,:,:,:) + real(kind=dp), intent(in) :: grid3d(:,:) !Yes I know bad name sorry + integer, intent(in) :: timestep + character(len=*), intent(in) :: filename + + integer, parameter :: numdims4d=4, numdims3d=3, numspeedyvars=5 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:) + + type(string) :: units(numspeedyvars) + type(string) :: varname(numspeedyvars) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific_Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + !copy data + allocate(copy,source=grid4d) + + dimsx = size(grid4d,2) + dimsy = size(grid4d,3) + dimsz = size(grid4d,4) + + varcount4d = [integer:: dimsx, dimsy, dimsz, 1] + start4d = [integer:: 1, 1, 1, timestep ] + + varcount3d = [integer:: dimsx, dimsy, 1] + start3d = [integer:: 1, 1, timestep ] + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678, -38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989, -9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + if(timestep.eq.1) then + call nc_check(nf90_create(path=filename,cmode=NF90_CLOBBER, ncid=file_id)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', dimsz, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', NF90_UNLIMITED, timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, numspeedyvars-1 + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d, count=varcount4d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + !Lets do logp + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d, count=varcount3d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + ! close; done + call nc_check(nf90_close(file_id)) + else + call nc_check(nf90_open(filename,nf90_write,file_id)) + do i=1, numspeedyvars-1 + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d,count=varcount3d)) + + call nc_check(nf90_close(file_id)) + endif + + deallocate(copy) + return + end subroutine + + subroutine read_netcdf_4d(varname,filename,var) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + + real(kind=dp), allocatable, intent(out) :: var(:,:,:,:) + + !Parmeter + integer, parameter :: numofdims = 4 !We can assume its a 4d variable + + !Local netcdf variables + integer :: ncid + integer :: varid + + integer :: dimids(numofdims), dim_length(numofdims) + + integer :: i + + call nc_check(nf90_open(filename, nf90_nowrite, ncid)) + + call nc_check(nf90_inq_varid(ncid,varname,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do i=1,numofdims + call nc_check(nf90_inquire_dimension(ncid,dimids(i),len=dim_length(i))) + enddo + + allocate(var(dim_length(1),dim_length(2),dim_length(3),dim_length(4))) + + call nc_check(nf90_get_var(ncid,varid,var)) + + return + end subroutine + + subroutine read_netcdf_3d(varname,filename,var) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + + real(kind=dp), allocatable, intent(out) :: var(:,:,:) + + !Parmeter + integer, parameter :: numofdims = 3 !We can assume its a 3d variable + + !Local netcdf variables + integer :: ncid + integer :: varid + + integer :: dimids(numofdims), dim_length(numofdims) + + integer :: i + + call nc_check(nf90_open(filename, nf90_nowrite, ncid)) + + call nc_check(nf90_inq_varid(ncid,varname,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do i=1,numofdims + call nc_check(nf90_inquire_dimension(ncid,dimids(i),len=dim_length(i))) + enddo + + allocate(var(dim_length(1),dim_length(2),dim_length(3))) + + call nc_check(nf90_get_var(ncid,varid,var)) + + return + end subroutine + + subroutine write_netcdf_2d(var,varname,filename,units) + use netcdf + + real(kind=dp), intent(in) :: var(:,:) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: units + + + integer, parameter :: numdims=2 + integer :: dimsx,dimsy + + integer :: file_id, xdim_id, ydim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start(numdims),varcount(numdims) + integer, dimension(numdims) :: arrdims + + integer :: i, counter + + real(kind=dp) :: lon(96), lat(48) + + dimsx = size(var,1) + dimsy = size(var,2) + + varcount = [integer:: dimsx, dimsy ] + start = [integer:: 1, 1] + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678, -38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989,-9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + call nc_check(nf90_create(path=filename,cmode=NF90_CLOBBER,ncid=file_id)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', dimsy, ydim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims = (/ xdim_id, ydim_id/) + + call nc_check(nf90_def_var(file_id,varname,NF90_REAL,arrdims,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, var,start=start, count=varcount)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + ! close; done + call nc_check(nf90_close(file_id)) + end subroutine + + subroutine write_netcdf_2d_non_met_data(var,varname,filename,units) + real(kind=dp), intent(in) :: var(:,:) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: units + + integer, parameter :: numdims=2 + integer :: dimsx,dimsy + + integer :: file_id, xdim_id, ydim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start(numdims),varcount(numdims) + integer, dimension(numdims) :: arrdims + + integer :: i, counter + + dimsx = size(var,1) + dimsy = size(var,2) + + varcount = [integer:: dimsx, dimsy ] + start = [integer:: 1, 1] + + call nc_check(nf90_create(path=filename,cmode=NF90_CLOBBER,ncid=file_id)) + + call nc_check(nf90_def_dim(file_id, 'X', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Y', dimsy, ydim_id)) + + arrdims = (/ xdim_id, ydim_id/) + + call nc_check(nf90_def_var(file_id,varname,NF90_REAL,arrdims,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, var,start=start, count=varcount)) + + call nc_check(nf90_close(file_id)) + end subroutine + + subroutine read_netcdf_2d_dp(varname,filename,var) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + + real(kind=dp), allocatable, intent(out) :: var(:,:) + + !Parmeter + integer, parameter :: numofdims = 2 !We can assume its a 2d variable + + !Local netcdf variables + integer :: ncid + integer :: varid + + integer :: dimids(numofdims), dim_length(numofdims) + + integer :: i + + call nc_check(nf90_open(filename, nf90_nowrite, ncid)) + + call nc_check(nf90_inq_varid(ncid,varname,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do i=1,numofdims + call nc_check(nf90_inquire_dimension(ncid,dimids(i),len=dim_length(i))) + enddo + + allocate(var(dim_length(1),dim_length(2))) + + call nc_check(nf90_get_var(ncid,varid,var)) + call nc_check(nf90_close(ncid)) + return + end subroutine + + subroutine write_netcdf_1d_non_met_data_int(var,varname,filename,units) + integer, intent(in) :: var(:) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: units + + integer, parameter :: numdims=1 + integer :: dimsx,dimsy + + integer :: file_id, xdim_id, ydim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start(numdims),varcount(numdims) + integer, dimension(numdims) :: arrdims + + integer :: i, counter + + dimsx = size(var,1) + + varcount = [dimsx] + start = [integer:: 1] + + call nc_check(nf90_create(path=filename,cmode=NF90_CLOBBER,ncid=file_id)) + + call nc_check(nf90_def_dim(file_id, 'X', dimsx, xdim_id)) + + arrdims = (/ xdim_id/) + + call nc_check(nf90_def_var(file_id,varname,NF90_INT,arrdims,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, var,start=start, count=varcount)) + + call nc_check(nf90_close(file_id)) + end subroutine + + subroutine write_netcdf_1d_non_met_data_real(var,varname,filename,units) + real(kind=dp), intent(in) :: var(:) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: units + + integer, parameter :: numdims=1 + integer :: dimsx,dimsy + + integer :: file_id, xdim_id, ydim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start(numdims),varcount(numdims) + integer, dimension(numdims) :: arrdims + + integer :: i, counter + + dimsx = size(var,1) + + varcount = [dimsx] + start = [integer:: 1] + + call nc_check(nf90_create(path=filename,cmode=NF90_CLOBBER,ncid=file_id)) + + call nc_check(nf90_def_dim(file_id, 'X', dimsx, xdim_id)) + + arrdims = (/ xdim_id/) + + call nc_check(nf90_def_var(file_id,varname,NF90_REAL,arrdims,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units)) + + call nc_check(nf90_enddef(file_id)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, var,start=start, count=varcount)) + + call nc_check(nf90_close(file_id)) + end subroutine + + subroutine write_netcdf_2d_reservoir_matrices_mpi(mpi_res,var,varname,filename,units) + use mpi + use netcdf + + use mod_utilities, only : mpi_type, reservoir_type + + type(mpi_type), intent(in) :: mpi_res + + real(kind=dp), intent(in) :: var(:,:) + + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: units + + integer, parameter :: numdims=3 + integer :: dimsx,dimsy,dimsworker + + integer :: file_id, xdim_id, ydim_id, workerdim_id + integer :: array_id, xvar_id, yvar_id + integer :: start(numdims),varcount(numdims) + integer, dimension(numdims) :: arrdims + + integer :: i, counter + + dimsx = size(var,1) + dimsy = size(var,2) + dimsworker = mpi_res%numprocs + + varcount = [integer:: 1, dimsx, dimsy ] + start = [integer:: mpi_res%proc_num, 1, 1] + + if(.not.file_exists(filename)) then + !call nc_check(nf90_create(path=filename,cmode=IOR(NF90_NETCDF4, NF90_MPIIO),ncid=file_id,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL)) + call nc_check(nf90_create(path=filename,cmode=IOR(NF90_NETCDF4, NF90_MPIIO),ncid=file_id,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + call nc_check(nf90_def_dim(file_id, 'worker', dimsworker, workerdim_id)) + call nc_check(nf90_def_dim(file_id, 'X', dimsx, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Y', dimsy, ydim_id)) + + arrdims = (/ workerdim_id,xdim_id, ydim_id/) + + call nc_check(nf90_def_var(file_id,varname,NF90_REAL,arrdims,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units)) + + call nc_check(nf90_enddef(file_id)) + endif + + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, var,start=start, count=varcount)) + + call nc_check(nf90_close(file_id)) + end subroutine + + subroutine read_netcdf_1d_dp(varname,filename,var) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + + real(kind=dp), allocatable, intent(out) :: var(:) + + !Parmeter + integer, parameter :: numofdims = 1!We can assume its a 1d variable + + !Local netcdf variables + integer :: ncid + integer :: varid + + integer :: dimids(numofdims), dim_length(numofdims) + + integer :: i + + call nc_check(nf90_open(filename, nf90_nowrite, ncid)) + + call nc_check(nf90_inq_varid(ncid,varname,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do i=1,numofdims + call nc_check(nf90_inquire_dimension(ncid,dimids(i),len=dim_length(i))) + enddo + + allocate(var(dim_length(1))) + + call nc_check(nf90_get_var(ncid,varid,var)) + call nc_check(nf90_close(ncid)) + return + end subroutine + + subroutine read_netcdf_1d_int(varname,filename,var) + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + + integer, allocatable, intent(out) :: var(:) + + !Parmeter + integer, parameter :: numofdims = 1!We can assume its a 1d variable + + !Local netcdf variables + integer :: ncid + integer :: varid + + integer :: dimids(numofdims), dim_length(numofdims) + + integer :: i + + call nc_check(nf90_open(filename, nf90_nowrite, ncid)) + + call nc_check(nf90_inq_varid(ncid,varname,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do i=1,numofdims + call nc_check(nf90_inquire_dimension(ncid,dimids(i),len=dim_length(i))) + enddo + + allocate(var(dim_length(1))) + + call nc_check(nf90_get_var(ncid,varid,var)) + call nc_check(nf90_close(ncid)) + return + end subroutine + + subroutine nc_check(status,worker,message) + use netcdf + + integer, intent (in) :: status + integer, intent(in), optional :: worker + character(len=*), intent(in), optional :: message + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + if(present(worker)) print *, 'processor',worker + if(present(message)) print *, message + stop "Stopped" + end if + end subroutine nc_check + + !-----------Parallel netcdf Routines----------! + + subroutine read_era_data_parallel(filename,model_parameters,mpi_res,grid,era_data,start_time_arg,stride_arg) + use mpi + use netcdf + + use mod_utilities, only : era_data_type, mpi_type, grid_type, model_parameters_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + character(len=*), intent(in) :: filename + + type(era_data_type), intent(inout) :: era_data + + integer, intent(in), optional :: start_time_arg, stride_arg + + !Local netcdf stuff + integer :: start4d(4), start3d(3) + integer :: count4d(4), count3d(3) + integer :: stride4d(4), stride3d(3) + integer :: ncid, varid + integer :: dimids(4), dim_length(4) + integer :: i,j + integer :: start_time, stride + + integer, parameter :: maxnum_of_dims=4 + integer, parameter :: num_of_era_vars=5 + + type(string) :: era_var_names(num_of_era_vars) + + if(present(start_time_arg)) then + start_time = start_time_arg + else + start_time = 1 + endif + + if(present(stride_arg)) then + stride = stride_arg + else + stride = 1 + endif + + era_var_names(1)%str = 'Temperature' + era_var_names(2)%str = 'U-wind' + era_var_names(3)%str = 'V-wind' + era_var_names(4)%str = 'Specific_Humidity' + era_var_names(5)%str = 'logp' + + !call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL)) + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + do i=1, num_of_era_vars-1 + call nc_check(nf90_inq_varid(ncid,era_var_names(i)%str,varid)) + + !call nc_check(nf90_var_par_access(ncid, varid, nf90_collective)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + + if(i == 1) then + do j=1,maxnum_of_dims + call nc_check(nf90_inquire_dimension(ncid,dimids(j),len=dim_length(j))) + enddo + !lets allocate grid4 + !allocate(era_data%eravariables(num_of_era_vars-1,grid%inputxchunk,grid%inputychunk,grid%inputzchunk,dim_length(4)/stride)) + allocate(era_data%eravariables(num_of_era_vars-1,grid%inputxchunk,grid%inputychunk,zgrid,dim_length(4)/stride)) + endif + + !check if its a periodicboundary or not + if(grid%periodicboundary) then + !Do stuff + !start4d = [integer:: grid%input_xstart,grid%input_ystart,grid%input_zstart,start_time] + !count4d = [integer:: xgrid-grid%input_xstart+1,grid%inputychunk,grid%inputzchunk,dim_length(4)/stride] + start4d = [integer:: grid%input_xstart,grid%input_ystart,1,start_time] + count4d = [integer:: xgrid-grid%input_xstart+1,grid%inputychunk,zgrid,dim_length(4)/stride] + stride4d = [integer:: 1,1,1,stride] + + print *, 'start4d_1',start4d,mpi_res%proc_num + print *, 'count4d_1',count4d,mpi_res%proc_num + + call nc_check(nf90_get_var(ncid,varid,era_data%eravariables(i,1:(xgrid-(grid%input_xstart-1)),:,:,:),start=start4d,count=count4d))!,stride=stride4d),mpi_res%proc_num,'first') + + !start4d = [integer:: 1,grid%input_ystart,grid%input_zstart,start_time] + !count4d = [integer:: grid%input_xend,grid%inputychunk,grid%inputzchunk,dim_length(4)/stride] + start4d = [integer:: 1,grid%input_ystart,1,start_time] + count4d = [integer:: grid%input_xend,grid%inputychunk,zgrid,dim_length(4)/stride] + + print *, 'start4d_2',start4d,mpi_res%proc_num + print *, 'count4d_2',count4d,mpi_res%proc_num + call nc_check(nf90_get_var(ncid,varid,era_data%eravariables(i,(xgrid-(grid%input_xstart-1))+1:grid%inputxchunk,:,:,:),start=start4d,count=count4d))!,stride=stride4d),mpi_res%proc_num,'second') + else + !start4d = [integer:: grid%input_xstart,grid%input_ystart,grid%input_zstart,start_time] + !count4d = [integer:: grid%inputxchunk,grid%inputychunk,grid%inputzchunk,dim_length(4)/stride] + start4d = [integer:: grid%input_xstart,grid%input_ystart,1,start_time] + count4d = [integer:: grid%inputxchunk,grid%inputychunk,zgrid,dim_length(4)/stride] + stride4d = [integer:: 1,1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,era_data%eravariables(i,:,:,:,:),start=start4d,count=count4d))!,stride=stride4d)) + endif + enddo + + !Time to do logp + call nc_check(nf90_inq_varid(ncid,era_var_names(num_of_era_vars)%str,varid)) + + !call nc_check(nf90_var_par_access(ncid, varid, nf90_collective)) + + allocate(era_data%era_logp(grid%inputxchunk,grid%inputychunk,dim_length(4)/stride)) + + if(grid%periodicboundary) then + + start3d = [integer:: grid%input_xstart,grid%input_ystart,start_time] + count3d = [integer:: xgrid-grid%input_xstart+1,grid%inputychunk,dim_length(4)/stride] + stride3d = [integer:: 1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,era_data%era_logp(1:(xgrid-(grid%input_xstart-1)),:,:),start=start3d,count=count3d))!,stride=stride3d)) + + start3d = [integer:: 1,grid%input_ystart,start_time] + count3d = [integer:: grid%input_xend,grid%inputychunk,dim_length(4)/stride] + + + call nc_check(nf90_get_var(ncid,varid,era_data%era_logp((xgrid-(grid%input_xstart-1))+1:grid%inputxchunk,:,:),start=start3d,count=count3d))!,stride=stride3d)) + + else + start3d = [integer:: grid%input_xstart,grid%input_ystart,start_time] + count3d = [integer:: grid%inputxchunk,grid%inputychunk,dim_length(4)/stride] + stride3d = [integer:: 1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,era_data%era_logp,start=start3d,count=count3d))!,stride=stride3d)) + endif + + call nc_check(nf90_close(ncid)) + end subroutine + + subroutine read_era_data_parallel_old(filename,mpi_res,grid,era_data) + use mpi + use netcdf + + use mod_utilities, only : era_data_type, mpi_type, grid_type, reservoir_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + + character(len=*), intent(in) :: filename + + type(era_data_type), intent(out) :: era_data + + !Local netcdf stuff + integer :: start4d(4), start3d(3) + integer :: count4d(4), count3d(3) + integer :: ncid, varid + integer :: dimids(4), dim_length(4) + integer :: i,j + + integer, parameter :: maxnum_of_dims=4 + integer, parameter :: num_of_era_vars=5 + + type(string) :: era_var_names(num_of_era_vars) + + era_var_names(1)%str = 'Temperature' + era_var_names(2)%str = 'U-wind' + era_var_names(3)%str = 'V-wind' + era_var_names(4)%str = 'Specific_Humidity' + era_var_names(5)%str = 'logp' + + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO),ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + do i=1, num_of_era_vars-1 + call nc_check(nf90_inq_varid(ncid,era_var_names(i)%str,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do j=1,maxnum_of_dims + call nc_check(nf90_inquire_dimension(ncid,dimids(j),len=dim_length(j))) + enddo + + if(i == 1) then + !lets allocate era data + allocate(era_data%eravariables(num_of_era_vars-1,grid%inputxchunk,grid%inputychunk,dim_length(3),dim_length(4))) + endif + + !check if its a periodicboundary or not + if(grid%periodicboundary) then + !Do stuff + start4d = [grid%input_xstart,grid%input_ystart,1,1] + count4d = [xgrid-grid%input_xstart+1,grid%inputychunk,dim_length(3),dim_length(4)] + + call nc_check(nf90_get_var(ncid,varid,era_data%eravariables(i,1:(xgrid-(grid%input_xstart-1)),:,:,:),start=start4d,count=count4d),mpi_res%proc_num,'first') + + start4d = [1,grid%input_ystart,1,1] + count4d = [grid%input_xend,grid%inputychunk,dim_length(3),dim_length(4)] + + call nc_check(nf90_get_var(ncid,varid,era_data%eravariables(i,(xgrid-(grid%input_xstart-1))+1:grid%inputxchunk,:,:,:),start=start4d,count=count4d),mpi_res%proc_num,'second') + else + start4d = [grid%input_xstart,grid%input_ystart,1,1] + count4d = [grid%inputxchunk,grid%inputychunk,dim_length(3),dim_length(4)] + + call nc_check(nf90_get_var(ncid,varid,era_data%eravariables(i,:,:,:,:),start=start4d,count=count4d)) + endif + enddo + + !Time to do logp + call nc_check(nf90_inq_varid(ncid,era_var_names(num_of_era_vars)%str,varid)) + + allocate(era_data%era_logp(grid%inputxchunk,grid%inputychunk,dim_length(4))) + + if(grid%periodicboundary) then + + start3d = [grid%input_xstart,grid%input_ystart,1] + count3d = [xgrid-grid%input_xstart+1,grid%inputychunk,dim_length(4)] + + call nc_check(nf90_get_var(ncid,varid,era_data%era_logp(1:(xgrid-(grid%input_xstart-1)),:,:),start=start3d,count=count3d)) + + start3d = [1,grid%input_ystart,1] + count3d = [grid%input_xend,grid%inputychunk,dim_length(4)] + + call nc_check(nf90_get_var(ncid,varid,era_data%era_logp((xgrid-(grid%input_xstart-1))+1:grid%inputxchunk,:,:),start=start3d,count=count3d)) + endif + + call nc_check(nf90_close(ncid)) + end subroutine + + subroutine read_speedy_data_parallel_old(filename,mpi_res,grid,speedy_data) + use mpi + use netcdf + + use mod_utilities, only : speedy_data_type, mpi_type, grid_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + + character(len=*), intent(in) :: filename + + type(speedy_data_type), intent(out) :: speedy_data + + !Local netcdf stuff + integer :: start4d(4), start3d(3) + integer :: count4d(4), count3d(3) + integer :: ncid, varid + integer :: dimids(4), dim_length(4) + integer :: i,j + + integer, parameter :: maxnum_of_dims=4 + integer, parameter :: num_of_speedy_vars=5 + + type(string) :: speedy_var_names(num_of_speedy_vars) + + speedy_var_names(1)%str = 'Temperature' + speedy_var_names(2)%str = 'U-wind' + speedy_var_names(3)%str = 'V-wind' + speedy_var_names(4)%str = 'Specific_Humidity' + speedy_var_names(5)%str = 'logp' + + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO),ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + do i=1, num_of_speedy_vars-1 + call nc_check(nf90_inq_varid(ncid,speedy_var_names(i)%str,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + if(i == 1) then + do j=1,maxnum_of_dims + call nc_check(nf90_inquire_dimension(ncid,dimids(j),len=dim_length(j))) + enddo + + !lets allocate speedy data + allocate(speedy_data%speedyvariables(num_of_speedy_vars-1,grid%resxchunk,grid%resychunk,dim_length(3),dim_length(4))) + endif + + start4d = [grid%res_xstart,grid%res_ystart,1,1] + count4d = [grid%resxchunk,grid%resychunk,dim_length(3),dim_length(4)] + + call nc_check(nf90_get_var(ncid,varid,speedy_data%speedyvariables(i,:,:,:,:),start=start4d,count=count4d)) + enddo + + !Time to do logp + call nc_check(nf90_inq_varid(ncid,speedy_var_names(num_of_speedy_vars)%str,varid)) + + allocate(speedy_data%speedy_logp(grid%resxchunk,grid%resychunk,dim_length(4))) + + start3d = [grid%res_xstart,grid%res_ystart,1] + count3d = [grid%resxchunk,grid%resychunk,dim_length(4)] + + call nc_check(nf90_get_var(ncid,varid,speedy_data%speedy_logp,start=start3d,count=count3d)) + + call nc_check(nf90_close(ncid)) + end subroutine + + subroutine read_speedy_data_parallel(filename,mpi_res,grid,speedy_data,start_time_arg,stride_arg) + use mpi + use netcdf + + use mod_utilities, only : speedy_data_type, mpi_type, grid_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + + character(len=*), intent(in) :: filename + + type(speedy_data_type), intent(out) :: speedy_data + + integer, intent(in), optional :: start_time_arg, stride_arg + + !Local netcdf stuff + integer :: start4d(4), start3d(3) + integer :: count4d(4), count3d(3) + integer :: stride4d(4), stride3d(3) + integer :: ncid, varid + integer :: dimids(4), dim_length(4) + integer :: i,j + integer :: start_time, stride + + integer, parameter :: maxnum_of_dims=4 + integer, parameter :: num_of_speedy_vars=5 + + type(string) :: speedy_var_names(num_of_speedy_vars) + + if(present(start_time_arg)) then + start_time = start_time_arg + else + start_time = 1 + endif + + if(present(stride_arg)) then + stride = stride_arg + else + stride = 1 + endif + + speedy_var_names(1)%str = 'Temperature' + speedy_var_names(2)%str = 'U-wind' + speedy_var_names(3)%str = 'V-wind' + speedy_var_names(4)%str = 'Specific_Humidity' + speedy_var_names(5)%str = 'logp' + + !call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL)) + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + do i=1, num_of_speedy_vars-1 + call nc_check(nf90_inq_varid(ncid,speedy_var_names(i)%str,varid)) + + !call nc_check(nf90_var_par_access(ncid, varid, nf90_collective)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + if(i == 1) then + do j=1,maxnum_of_dims + call nc_check(nf90_inquire_dimension(ncid,dimids(j),len=dim_length(j))) + enddo + + !lets allocate speedy data + allocate(speedy_data%speedyvariables(num_of_speedy_vars-1,grid%resxchunk,grid%resychunk,zgrid,dim_length(4)/stride)) + endif + + !start4d = [integer:: grid%res_xstart,grid%res_ystart,grid%res_zstart,start_time] + !count4d = [integer:: grid%resxchunk,grid%resychunk,grid%reszchunk,dim_length(4)/stride] + start4d = [integer:: grid%res_xstart,grid%res_ystart,1,start_time] + count4d = [integer:: grid%resxchunk,grid%resychunk,zgrid,dim_length(4)/stride] + stride4d = [integer:: 1,1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,speedy_data%speedyvariables(i,:,:,:,:),start=start4d,count=count4d,stride=stride4d)) + enddo + + !Time to do logp + call nc_check(nf90_inq_varid(ncid,speedy_var_names(num_of_speedy_vars)%str,varid)) + + !call nc_check(nf90_var_par_access(ncid, varid, nf90_collective)) + + allocate(speedy_data%speedy_logp(grid%resxchunk,grid%resychunk,dim_length(4)/stride)) + + start3d = [integer:: grid%res_xstart,grid%res_ystart,start_time] + count3d = [integer:: grid%resxchunk,grid%resychunk,dim_length(4)/stride] + stride3d = [integer:: 1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,speedy_data%speedy_logp,start=start3d,count=count3d,stride=stride3d)) + + call nc_check(nf90_close(ncid)) + end subroutine + + subroutine write_prediction_local_region_vert_level_mpi(grid,model_parameters,mpi_res,grid4d,grid3d,timestep,filename,make_file) + use mpi + + use mod_utilities, only : mpi_type, grid_type, model_parameters_type + use stringtype, only : string + + type(grid_type), intent(in) :: grid + type(model_parameters_type), intent(in) :: model_parameters + type(mpi_type), intent(in) :: mpi_res + + real(kind=dp), intent(inout) :: grid4d(:,:,:,:), grid3d(:,:) + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + logical, intent(in) :: make_file + + integer, parameter :: numdims4d=4, numdims3d=3, numspeedyvars=5 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:) + + type(string) :: units(numspeedyvars) + type(string) :: varname(numspeedyvars) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific_Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + !copy data + allocate(copy,source=grid4d) + + dimsx = size(grid4d,2) + dimsy = size(grid4d,3) + dimsz = size(grid4d,4) + + varcount4d = [integer:: dimsx, dimsy, dimsz, 1] + start4d = [integer:: grid%res_xstart, grid%res_ystart, grid%res_zstart, timestep] + + varcount3d = [integer:: dimsx, dimsy, 1] + start3d = [integer:: grid%res_xstart, grid%res_ystart, timestep] + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678,-38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989, -9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + if(make_file) then + !call nc_check(nf90_create(filename,IOR(NF90_NETCDF4,NF90_MPIIO),file_id,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL)) + call nc_check(nf90_create(filename,IOR(NF90_NETCDF4,NF90_MPIIO),file_id,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', xgrid, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', ygrid, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', zgrid, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', int(model_parameters%predictionlength/model_parameters%timestep,kind=int32), timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, numspeedyvars-1 + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !parallel io is more complicated + ! Unlimited dimensions require collective writes + call nc_check(nf90_var_par_access(file_id, array_id, nf90_collective)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d, count=varcount4d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + !Lets do logp + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + call nc_check(nf90_var_par_access(file_id,array_id,nf90_independent)) + + if(grid%logp_bool) then + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d, count=varcount3d)) + endif + + ! close; done + call nc_check(nf90_close(file_id)) + else + !call nc_check(nf90_open(filename,IOR(NF90_WRITE,NF90_MPIIO),file_id,comm=mpi_res%mpi_world%MPI_VAL,info=MPI_INFO_NULL),message='nf90_open') + call nc_check(nf90_open(filename,IOR(NF90_WRITE,NF90_MPIIO),file_id,comm=mpi_res%mpi_world,info=MPI_INFO_NULL),message='nf90_open') + + do i=1, numspeedyvars-1 + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_var_par_access(file_id,array_id,nf90_independent)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + + call nc_check(nf90_var_par_access(file_id,array_id,nf90_independent)) + + if(grid%logp_bool) then + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d,count=varcount3d)) + endif + + call nc_check(nf90_close(file_id)) + endif + + deallocate(copy) + return + end subroutine write_prediction_local_region_vert_level_mpi + + subroutine read_prediction_local_region_vert_level_mpi(grid,model_parameters,mpi_res,grid4d,grid2d,timestep,filename) + use mpi + use netcdf + + use mod_utilities, only : era_data_type, mpi_type, grid_type, model_parameters_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: timestep + + real(kind=dp), allocatable, intent(out) :: grid4d(:,:,:,:), grid2d(:,:) + + character(len=*), intent(in) :: filename + + + !Local netcdf stuff + integer :: start4d(4), start3d(3) + integer :: count4d(4), count3d(3) + integer :: ncid, varid + integer :: dimids(4), dim_length(4) + integer :: i,j + + integer, parameter :: maxnum_of_dims=4 + integer, parameter :: num_of_era_vars=5 + + type(string) :: era_var_names(num_of_era_vars) + + era_var_names(1)%str = 'Temperature' + era_var_names(2)%str = 'U-wind' + era_var_names(3)%str = 'V-wind' + era_var_names(4)%str = 'Specific_Humidity' + era_var_names(5)%str = 'logp' + + !call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL)) + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + if(allocated(grid4d)) deallocate(grid4d) + if(allocated(grid2d)) deallocate(grid2d) + + !lets allocate grid4 + if(allocated(grid4d)) print *, 'grid4d in mod io',shape(grid4d) + allocate(grid4d(num_of_era_vars-1,grid%inputxchunk,grid%inputychunk,grid%inputzchunk)) + do i=1, num_of_era_vars-1 + call nc_check(nf90_inq_varid(ncid,era_var_names(i)%str,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do j=1,maxnum_of_dims + call nc_check(nf90_inquire_dimension(ncid,dimids(j),len=dim_length(j))) + enddo + + !check if its a periodicboundary or not + if(grid%periodicboundary) then + !Do stuff + start4d = [integer:: grid%input_xstart,grid%input_ystart,grid%input_zstart,timestep] + count4d = [integer:: xgrid-grid%input_xstart+1,grid%inputychunk,grid%inputzchunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid4d(i,1:(xgrid-(grid%input_xstart-1)),:,:),start=start4d,count=count4d),mpi_res%proc_num,'first') + + start4d = [integer:: 1,grid%input_ystart,grid%input_zstart,timestep] + count4d = [integer:: grid%input_xend,grid%inputychunk,grid%inputychunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid4d(i,(xgrid-(grid%input_xstart-1))+1:grid%inputxchunk,:,:),start=start4d,count=count4d),mpi_res%proc_num,'second') + else + start4d = [integer:: grid%input_xstart,grid%input_ystart,grid%input_zstart,timestep] + count4d = [integer:: grid%inputxchunk,grid%inputychunk,grid%inputzchunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid4d(i,:,:,:),start=start4d,count=count4d)) + endif + enddo + + !Time to do logp + call nc_check(nf90_inq_varid(ncid,era_var_names(num_of_era_vars)%str,varid)) + + allocate(grid2d(grid%inputxchunk,grid%inputychunk)) + + if(grid%periodicboundary) then + + start3d = [integer:: grid%input_xstart,grid%input_ystart,timestep] + count3d = [integer:: xgrid-grid%input_xstart+1,grid%inputychunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid2d(1:(xgrid-(grid%input_xstart-1)),:),start=start3d,count=count3d)) + + start3d = [integer:: 1,grid%input_ystart,timestep] + count3d = [integer:: grid%input_xend,grid%inputychunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid2d((xgrid-(grid%input_xstart-1))+1:grid%inputxchunk,:),start=start3d,count=count3d)) + + else + start3d = [integer:: grid%input_xstart,grid%input_ystart,timestep] + count3d = [integer:: grid%inputxchunk,grid%inputychunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid2d,start=start3d,count=count3d)) + endif + call nc_check(nf90_close(ncid)) + end subroutine + + subroutine write_truth_local_region_vert_level_mpi(grid,model_parameters,mpi_res,grid4d,grid3d,timestep,filename) + use mpi + + use mod_utilities, only : mpi_type, grid_type, model_parameters_type + use stringtype, only : string + + type(grid_type), intent(in) :: grid + type(model_parameters_type), intent(in) :: model_parameters + type(mpi_type), intent(in) :: mpi_res + + real(kind=dp), intent(inout) :: grid4d(:,:,:,:), grid3d(:,:) + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + integer, parameter :: numdims4d=4, numdims3d=3, numspeedyvars=5 + integer :: dimsx,dimsy,dimsz + + integer :: file_id, xdim_id, ydim_id, zdim_id, timedim_id + integer :: array_id, xvar_id, yvar_id + integer :: start4d(numdims4d),varcount4d(numdims4d),start3d(numdims3d),varcount3d(numdims3d) + integer :: arrdims4d(numdims4d),arrdims3d(numdims3d) + + integer :: i, counter + + real(kind=dp) :: lon(xgrid), lat(ygrid) + + real(kind=dp), allocatable :: copy(:,:,:,:) + + type(string) :: units(numspeedyvars) + type(string) :: varname(numspeedyvars) + + units(1)%str = 'Kelvin' + varname(1)%str = 'Temperature' + + units(2)%str = 'm/s' + varname(2)%str = 'U-wind' + + units(3)%str = 'm/s' + varname(3)%str = 'V-wind' + + units(4)%str = 'g/kg' + varname(4)%str = 'Specific_Humidity' + + units(5)%str = 'log(surfacepressure)' + varname(5)%str = 'logp' + + !copy data + allocate(copy,source=grid4d) + + dimsx = size(grid4d,2) + dimsy = size(grid4d,3) + dimsz = size(grid4d,4) + + varcount4d = [integer:: dimsx, dimsy, dimsz, 1] + start4d = [integer:: grid%res_xstart, grid%res_ystart, grid%res_zstart, timestep ] + + varcount3d = [integer:: dimsx, dimsy, 1] + start3d = [integer:: grid%res_xstart, grid%res_ystart, timestep ] + + lon = (/(real(counter)*3.75,counter=0,95)/) + lat = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678,-38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989, -9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + if(timestep.eq.1) then + !call nc_check(nf90_create(filename,IOR(NF90_NETCDF4,NF90_MPIIO),file_id,comm=mpi_res%mpi_world%MPI_VAL,info=MPI_INFO_NULL)) + call nc_check(nf90_create(filename,IOR(NF90_NETCDF4,NF90_MPIIO),file_id,comm=mpi_res%mpi_world,info=MPI_INFO_NULL)) + + ! define the dimensions + call nc_check(nf90_def_dim(file_id, 'Lon', xgrid, xdim_id)) + call nc_check(nf90_def_dim(file_id, 'Lat', ygrid, ydim_id)) + call nc_check(nf90_def_dim(file_id, 'Sigma_Level', zgrid, zdim_id)) + call nc_check(nf90_def_dim(file_id, 'Timestep', int(model_parameters%predictionlength/model_parameters%timestep + 1,kind=int32), timedim_id)) + + !Assign lat and lon ids and units + call nc_check(nf90_def_var(file_id,'Lon',NF90_REAL,xdim_id,xvar_id)) + call nc_check(nf90_def_var(file_id,'Lat',NF90_REAL,ydim_id,yvar_id)) + + call nc_check(nf90_put_att(file_id,xvar_id,"units",'degrees_north')) + call nc_check(nf90_put_att(file_id,yvar_id,"units",'degrees_east')) + ! now that the dimensions are defined, we can define variables on + ! them,... + arrdims4d = (/ xdim_id, ydim_id, zdim_id, timedim_id /) + arrdims3d = (/ xdim_id, ydim_id, timedim_id /) + + do i=1, numspeedyvars-1 + call nc_check(nf90_def_var(file_id,varname(i)%str,NF90_REAL,arrdims4d,array_id)) + ! ...and assign units to them as an attribute + + call nc_check(nf90_put_att(file_id, array_id, "units", units(i)%str)) + + call nc_check(nf90_enddef(file_id)) + + !parallel io is more complicated + ! Unlimited dimensions require collective writes + call nc_check(nf90_var_par_access(file_id, array_id, nf90_collective)) + + !Write out the values + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d, count=varcount4d)) + + call nc_check(nf90_put_var(file_id, xvar_id, lon)) + + call nc_check(nf90_put_var(file_id, yvar_id, lat)) + + call nc_check(nf90_redef(file_id)) + enddo + !Lets do logp + call nc_check(nf90_def_var(file_id,varname(5)%str,NF90_REAL,arrdims3d,array_id)) + + call nc_check(nf90_put_att(file_id, array_id, "units", units(5)%str)) + + call nc_check(nf90_enddef(file_id)) + + call nc_check(nf90_var_par_access(file_id,array_id,nf90_collective)) + !Write out the values + + if(grid%logp_bool) then + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d, count=varcount3d)) + endif + ! close; done + call nc_check(nf90_close(file_id)) + else + !call nc_check(nf90_open(filename,IOR(NF90_WRITE,NF90_MPIIO),file_id,comm=mpi_res%mpi_world%MPI_VAL,info=MPI_INFO_NULL)) + call nc_check(nf90_open(filename,IOR(NF90_WRITE,NF90_MPIIO),file_id,comm=mpi_res%mpi_world,info=MPI_INFO_NULL)) + + do i=1, numspeedyvars-1 + call nc_check(nf90_inq_varid(file_id,varname(i)%str,array_id)) + call nc_check(nf90_var_par_access(file_id,array_id,nf90_collective)) + call nc_check(nf90_put_var(file_id, array_id, copy(i,:,:,:),start=start4d,count=varcount4d)) + enddo + + call nc_check(nf90_inq_varid(file_id,varname(5)%str,array_id)) + + call nc_check(nf90_var_par_access(file_id,array_id,nf90_collective)) + + call nc_check(nf90_put_var(file_id, array_id, grid3d,start=start3d,count=varcount3d)) + + call nc_check(nf90_close(file_id)) + endif + + deallocate(copy) + return + end subroutine write_truth_local_region_vert_level_mpi + + subroutine read_full_file_4d(grid4d,grid2d,timestep,filename) + use stringtype, only : string + + real(kind=dp), intent(inout) :: grid4d(:,:,:,:), grid2d(:,:) + integer, intent(in) :: timestep + + character(len=*), intent(in) :: filename + + !Local netcdf stuff + integer :: start4d(4), start3d(3) + integer :: count4d(4), count3d(3) + integer :: ncid, varid + integer :: dimids(4), dim_length(4) + integer :: i,j + + integer, parameter :: maxnum_of_dims=4 + integer, parameter :: num_of_era_vars=5 + integer, parameter :: num_of_height_levels=8 + + type(string) :: era_var_names(num_of_era_vars) + + era_var_names(1)%str = 'Temperature' + era_var_names(2)%str = 'U-wind' + era_var_names(3)%str = 'V-wind' + era_var_names(4)%str = 'Specific_Humidity' + era_var_names(5)%str = 'logp' + + call nc_check(nf90_open(filename, nf90_nowrite, ncid)) + + start4d = [integer:: 1,1,1,timestep] + count4d = [integer:: xgrid,ygrid,num_of_height_levels,1] + + do i=1, num_of_era_vars - 1 + call nc_check(nf90_inq_varid(ncid,era_var_names(i)%str,varid)) + + call nc_check(nf90_get_var(ncid,varid,grid4d(i,:,:,:))) + enddo + + call nc_check(nf90_inq_varid(ncid,era_var_names(num_of_era_vars)%str,varid)) + + call nc_check(nf90_get_var(ncid,varid,grid2d(:,:))) + + call nc_check(nf90_close(ncid)) + return + end subroutine + + subroutine read_3d_file_parallel(filename,varname,mpi_res,grid,var3d,start_time_arg,stride_arg,time_length) + use mpi + use netcdf + + use mod_utilities, only : speedy_data_type, mpi_type, grid_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + + real(kind=dp), allocatable, intent(inout) :: var3d(:,:,:) + + integer, intent(in), optional :: start_time_arg, stride_arg, time_length + + !Local netcdf stuff + integer :: start3d(3) + integer :: count3d(3) + integer :: stride3d(3) + integer :: ncid, varid + integer :: dimids(3), dim_length(3) + integer :: i,j,maxnum_of_dims + integer :: start_time, stride + + if(present(start_time_arg)) then + start_time = start_time_arg + else + start_time = 1 + endif + + if(present(stride_arg)) then + stride = stride_arg + else + stride = 1 + endif + + maxnum_of_dims = 3 + + !call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL),message='nf90_open') + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL),message='nf90_open') + + call nc_check(nf90_inq_varid(ncid,varname,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do j=1,maxnum_of_dims + call nc_check(nf90_inquire_dimension(ncid,dimids(j),len=dim_length(j)),message='nf90_inquire_dimension') + enddo + + + if(present(time_length)) then + dim_length(3) = time_length + endif + + call nc_check(nf90_inq_varid(ncid,varname,varid),message='nf90_inq_varid') + + allocate(var3d(grid%inputxchunk,grid%inputychunk,dim_length(3)/stride)) + + if(grid%periodicboundary) then + + start3d = [integer:: grid%input_xstart,grid%input_ystart,start_time] + count3d = [integer:: xgrid-grid%input_xstart+1,grid%inputychunk,dim_length(3)/stride] + stride3d = [integer:: 1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,var3d(1:(xgrid-(grid%input_xstart-1)),:,:),start=start3d,count=count3d,stride=stride3d)) + + start3d = [integer:: 1,grid%input_ystart,start_time] + count3d = [integer:: grid%input_xend,grid%inputychunk,dim_length(3)/stride] + stride3d = [integer:: 1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,var3d((xgrid-(grid%input_xstart-1))+1:grid%inputxchunk,:,:),start=start3d,count=count3d,stride=stride3d)) + + else + start3d = [integer:: grid%input_xstart,grid%input_ystart,start_time] + count3d = [integer:: grid%inputxchunk,grid%inputychunk,dim_length(3)/stride] + stride3d = [integer:: 1,1,stride] + + call nc_check(nf90_get_var(ncid,varid,var3d,start=start3d,count=count3d)) + endif + call nc_check(nf90_close(ncid)) + end subroutine read_3d_file_parallel + + subroutine read_3d_file_parallel_res(filename,varname,mpi_res,grid,var3d,time_index) + !Parallel IO routine to read a file containing a 3d variable (x,y,t) + + !This routine needs to be called by all processors even if some of the + !processors dont use that data. (e.g. for sst variables some workers dont + !need it but in order for parallel io to work in netcdf all processors + !need to open the file) + use mpi + use netcdf + + use mod_utilities, only : speedy_data_type, mpi_type, grid_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + + real(kind=dp), allocatable, intent(inout) :: var3d(:,:,:) + + integer, intent(in), optional :: time_index + + !Local netcdf stuff + integer :: start3d(3) + integer :: count3d(3) + integer :: ncid, varid + integer :: dimids(3), dim_length(3) + integer :: i,j,maxnum_of_dims + integer :: start_time_index + + maxnum_of_dims = 3 + + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL),message='nf90_open') + + call nc_check(nf90_inq_varid(ncid,varname,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + do j=1,maxnum_of_dims + call nc_check(nf90_inquire_dimension(ncid,dimids(j),len=dim_length(j)),message='nf90_inquire_dimension') + enddo + + if(present(time_index)) then + start_time_index = time_index + dim_length(3) = 1 + else + start_time_index = 1 + endif + + call nc_check(nf90_inq_varid(ncid,varname,varid),message='nf90_inq_varid') + + allocate(var3d(grid%resxchunk,grid%resychunk,dim_length(3))) + + start3d = [grid%res_xstart,grid%res_ystart,start_time_index] + count3d = [grid%resxchunk,grid%resychunk,dim_length(3)] + + call nc_check(nf90_get_var(ncid,varid,var3d,start=start3d,count=count3d)) + + call nc_check(nf90_close(ncid)) + end subroutine read_3d_file_parallel_res + + subroutine read_prediction_local_model_vert_level_mpi(grid,model_parameters,mpi_res,grid4d,grid2d,timestep,filename) + use mpi + use netcdf + + use mod_utilities, only : era_data_type, mpi_type, grid_type, model_parameters_type + use stringtype, only : string + + type(mpi_type), intent(in) :: mpi_res + type(grid_type), intent(in) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: timestep + + real(kind=dp), allocatable, intent(out) :: grid4d(:,:,:,:), grid2d(:,:) + + character(len=*), intent(in) :: filename + + + !Local netcdf stuff + integer :: start4d(4), start3d(3) + integer :: count4d(4), count3d(3) + integer :: ncid, varid + integer :: dimids(4), dim_length(4) + integer :: i,j + + integer, parameter :: maxnum_of_dims=4 + integer, parameter :: num_of_speedy_vars=5 + + type(string) :: speedy_var_names(num_of_speedy_vars) + + speedy_var_names(1)%str = 'Temperature' + speedy_var_names(2)%str = 'U-wind' + speedy_var_names(3)%str = 'V-wind' + speedy_var_names(4)%str = 'Specific_Humidity' + speedy_var_names(5)%str = 'logp' + + !call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world%MPI_VAL, info=MPI_INFO_NULL)) + call nc_check(nf90_open(filename, IOR(NF90_NOWRITE, NF90_MPIIO), ncid,comm=mpi_res%mpi_world, info=MPI_INFO_NULL)) + + allocate(grid4d(num_of_speedy_vars-1,grid%resxchunk,grid%resychunk,grid%reszchunk)) + allocate(grid2d(grid%resxchunk,grid%resychunk)) + + do i=1, num_of_speedy_vars-1 + call nc_check(nf90_inq_varid(ncid,speedy_var_names(i)%str,varid)) + + call nc_check(nf90_inquire_variable(ncid,varid,dimids=dimids)) + + start4d = [integer:: grid%res_xstart,grid%res_ystart,grid%res_zstart,timestep] + count4d = [integer:: grid%resxchunk,grid%resychunk,grid%reszchunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid4d(i,:,:,:),start=start4d,count=count4d)) + enddo + + !Time to do logp + call nc_check(nf90_inq_varid(ncid,speedy_var_names(num_of_speedy_vars)%str,varid)) + + start3d = [integer:: grid%res_xstart,grid%res_ystart,timestep] + count3d = [integer:: grid%resxchunk,grid%resychunk,1] + + call nc_check(nf90_get_var(ncid,varid,grid2d,start=start3d,count=count3d)) + + call nc_check(nf90_close(ncid)) + end subroutine +end module mod_io diff --git a/src/mod_lflags.f90 b/src/mod_lflags.f90 new file mode 100755 index 0000000..c2e2f9e --- /dev/null +++ b/src/mod_lflags.f90 @@ -0,0 +1,26 @@ +!> @brief +!> Logical flags to control certain behaviour. +module mod_lflags + implicit none + + private + public lppres, lco2, lradsw, lrandf + + ! Logical flags to activate processes throughout the integration + + ! Flag to post-process upper-air fields on pressure levels (.false. for + ! model level p.p.) + logical, parameter :: lppres = .true. + + ! Flag for CO2 optical thickness increase + logical, parameter :: lco2 = .false. + + ! Logical flags to activate processes in selected time steps (updated in + ! STLOOP) + + ! Flag for shortwave radiation routine + logical :: lradsw = .true. + + ! Flag for random diabatic forcing + logical :: lrandf = .false. +end module diff --git a/src/mod_linalg.f90 b/src/mod_linalg.f90 new file mode 100755 index 0000000..21ed286 --- /dev/null +++ b/src/mod_linalg.f90 @@ -0,0 +1,532 @@ +module mod_linalg + + use MKL_SPBLAS + use mod_utilities, only : dp, main_type, reservoir_type + + implicit none + + contains + + subroutine mklsparse(reservoir) + !routine to make a MKL sparse array + + type(reservoir_type), intent(inout) :: reservoir + + integer :: stat + + stat = mkl_sparse_d_create_coo(reservoir%cooA, SPARSE_INDEX_BASE_ONE, reservoir%n, reservoir%n, reservoir%k, reservoir%rows, reservoir%cols, reservoir%vals) + if(stat.ne.0) then + print *, 'MKL sparse creation failed because of stat error',stat,'exiting' + print *, 'res%n,res%k',reservoir%n,reservoir%k + stop + endif + + reservoir%descrA%TYPE = SPARSE_MATRIX_TYPE_GENERAL + end subroutine + + subroutine pinv_svd(A,m,n,Ainv) + !A Moore-Penrose pseudo-inverse using single value decomposition + + external DLANGE + real(kind=dp) :: DLANGE + + integer,intent(in) :: m, n + real(kind=dp),intent(in) :: A(m,n) + real(kind=dp),intent(out) :: Ainv(n,m) + real(kind=dp),dimension(m,n):: A1, A2, sigma, temp + integer :: i, j, k, l, lwork, info + real(kind=dp), allocatable, dimension(:,:) :: U + real(kind=dp), allocatable, dimension(:,:) :: VT + real(kind=dp), dimension(N,N) :: BUFF + real(kind=dp), allocatable, dimension(:) :: WORK + real(kind=dp), allocatable, dimension(:) :: RWORK + real(kind=dp), allocatable, dimension(:) :: S + real(kind=dp),parameter :: thres=1e-2 !TODO maybe change this + real(kind=dp) :: normA, normAPA, normPAP, tester + logical, parameter :: verbose= .False. + + k=min(m,n) + l=max(m,n) + lwork = max(1,3*k+l,5*k)*4 + + allocate(U(m,k)) + allocate(VT(k,n)) + allocate(work(lwork)) + allocate(S(k)) + + !This is needed because LAPACK likes destroying input matrices + A1 = A + A2 = A + + ! Compute the SVD of A1 + call DGESVD('S', 'S', M, N, A1, M, S, U, M, VT, K, WORK, LWORK,INFO) !Major problem was fixed we didnt need RWORK and led to memory problems + if(INFO /= 0) then + print *, 'PINV DGESVD has a problem error is info=',INFO + + endif + + ! Compute PINV = VT**T * SIGMA * U**T in two steps + do j = 1, K + tester = s(j) + !Need this because if tester is smaller than threshold makes S(j) zero + !Because when we take the reciprical we dont want to get too large of a + !number. See numerical linear algebra book on single value decomposition + !and svd to get an pseudo-inverse + + + if(tester.gt.thres) then + call DSCAL( M, real(1 / S( j ),kind=dp), U( 1, j ), 1 ) + else + call DSCAL( M, 0.0_dp, U( 1, j ), 1 ) + endif + end do + + call DGEMM( 'C', 'C', N, M, K, real(1.0,kind=dp), VT, K, U, M, real(0.0,kind=dp), Ainv, N) + + !If you really don't believe me that the above code works you can + !check by making verbose true + if(verbose) then + !check if the diagonals of temp are one + temp = matmul(A,Ainv) + print *,'max of what should be an identity maxtrix if not close to one then problem', maxval(temp) + ! check the result + normA = DLANGE( 'F', M, N, A2, M, lwork ) + call DGEMM( 'N', 'N', N, N, M, real(1.0), Ainv, N, A2, M, real(0.0), BUFF, N ) + + call DGEMM( 'N', 'N', M, N, N, real(-1.0), A2, M, BUFF, N, real(1.0), A2, M ) + normAPA = DLANGE( 'F', M, N, A2, M, lwork ) + + call DGEMM( 'N', 'N', N, M, N, real(-1.0), BUFF, N, Ainv, N, real(1.0), Ainv, N ); + normPAP = DLANGE( 'F', N, M, Ainv, N, lwork ) + + write(*,"(A, e11.4)") '|| A - A*P*A || = ', normAPA/normA + write(*,"(A, e11.4)") '|| P - P*A*P || = ', normPAP/normA + endif + + return + end subroutine + + subroutine mldivide(A,B) + !What should be the same as matlab mldivide also known as \ + !Solves A*x = B given A and B + !A is n-by-n and B + !B becomes X at the exit if info == 0 + + real(kind=dp), intent(inout) :: A(:,:), B(:,:) + + + !Local parameters + real(kind=dp), allocatable :: temp2d(:,:) + + integer :: n, m, k, l + + !lapack stuff + integer :: nrhs, lda, ldb, info + integer, allocatable :: ipiv(:) + + + !check if inputs are the right shape + n = size(A,1) + m = size(A,2) + l = size(B,1) + k = size(B,2) + + if(n /= l) then + print *, 'Column of A is not the same size of column of B. Cant compute solution returning A and B unchanged' + return + endif + + nrhs = k + lda = max(1,n) + ldb = max(1,n) + + allocate(ipiv(n)) + + call dgesv(n, nrhs, A, lda, ipiv, B, ldb, info ) + + if(info /= 0) then + print *, 'something went wrong with dgesv info = ',info + print *, 'B is not the solution' + endif + end subroutine + + subroutine eigval(A,x,y,maxeig) + !Outdated routine to get eigenvalues of a + !dense array + integer, intent(in) :: x,y + real, intent(in),dimension(x,y) :: A + integer :: ldVL, ldVR, lworker, ierr, info, i, ldA + real, allocatable :: work(:), VR(:,:), VL(:,:) + real, dimension(x) :: eig, wr, wi + character :: jobVL, jobVR + real :: maxeig + external SGEEV + + print *,'test' + jobVL = 'N' ! The left eigenvector u(j) of A satisfies: u(j)**H * A = lambda(j) * u(j)**H. 'N' to not compute. + jobVR = 'N' ! The right eigenvector v(j) of A satisfies: A * v(j) = lambda(j) * v(j). 'V' to compute. + ldA = x; ldVL = 1; ldVR = 1 + lworker = max(1,5*x) + allocate(work(lworker)) + call SGEEV(jobVL,jobVR,x,A,ldA,WR,WI,VL,ldVL,VR,ldVR,work,lworker,info) !TODO this is not working + + do i=1,x + eig(i) = (wr(i)**2+wi(i)**2)**0.5 + enddo + maxeig = maxval(eig) + return + end subroutine + + subroutine makesparse(reservoir) + !This subroutine 100% works for making a random + !sparse matrix + !Hand checked this + use mod_utilities, only : shuffle + + type(reservoir_type), intent(inout) :: reservoir + + integer :: counter, leftover, i + + !Get random vals + call RANDOM_NUMBER(reservoir%vals) + + !This block makes a random choice with no repeat (for small M >100 or + !very dense sparse matrix technically there could be a repeat + !row/column pair but its low chance) and doesnt affect anything. + !The random choice uses a kshuffle to make the random choice + if(reservoir%k.gt.reservoir%n) then + counter = floor(real(reservoir%k/reservoir%n)) + leftover = mod(reservoir%k,reservoir%n) + do i = 1,counter + call shuffle(reservoir%n,reservoir%n,reservoir%rows((i-1)*reservoir%n+1:i*reservoir%n)) + call shuffle(reservoir%n,reservoir%n,reservoir%cols((i-1)*reservoir%n+1:i*reservoir%n)) + enddo + + if(leftover.ne.0) then + call shuffle(reservoir%n,leftover,reservoir%rows((i-1)*reservoir%n+1:reservoir%k)) + call shuffle(reservoir%n,leftover,reservoir%cols((i-1)*reservoir%n+1:reservoir%k)) + endif + else + call shuffle(reservoir%n,reservoir%k,reservoir%rows) + + call shuffle(reservoir%n,reservoir%k,reservoir%cols) + endif + + call mklsparse(reservoir) + return + + end subroutine + + subroutine sparse_eigen(reservoir,maxn,k,eigs) + !Horrible to follow routine to get the max eigenvalue of a sparse array + !Do not touch this + !--------------------------------------------------------------------------- + ! + ! %-----------------------------% + ! | Define maximum dimensions | + ! | for all arrays. | + ! | MAXN: Maximum dimension | + ! | of the A allowed. | + ! | MAXNEV: Maximum NEV allowed | + ! | MAXNCV: Maximum NCV allowed | + ! %-----------------------------% + ! + type(reservoir_type) :: reservoir + integer, intent(in) :: k, maxn + + real(kind=dp), intent(out) :: eigs + ! %--------------% + ! | Local Arrays | + ! %--------------% + ! + integer maxnev, maxncv, ldv + parameter (maxncv=30) + integer iparam(11), ipntr(14) + logical select(maxncv) + real(kind=dp) :: ax(maxn), d(maxncv,3), resid(maxn),v(maxn,maxncv), workd(3*maxn),workev(3*maxncv),workl(3*maxncv*maxncv+6*maxncv) + ! + ! %---------------% + ! | Local Scalars | + ! %---------------% + ! + character bmat*1, which*2 + integer ido, n, nx, nev, ncv, lworkl, info, j, ierr, nconv, maxitr, ishfts, mode + real(kind=dp) :: tol, sigmar, sigmai + logical first, rvec + ! + ! %------------% + ! | Parameters | + ! %------------% + ! + real(kind=dp) :: zero + parameter (zero = 0.0D+0) + ! + ! %-----------------------------% + ! | BLAS & LAPACK routines used | + ! %-----------------------------% + real(kind=dp) :: dlapy2, dnrm2 + external dlapy2, dnrm2, daxpy + ! + ! %--------------------% + ! | Intrinsic function | + ! %--------------------% + ! + intrinsic abs + ! + ! %-----------------------% + ! | Executable Statements | + ! %-----------------------% + ! | N <= MAXN | + ! | NEV <= MAXNEV | + ! | NEV + 2 <= NCV <= MAXNCV | + ! %--------------------------------------------------% + ! + + maxnev=k + ldv=maxn + nx = reservoir%n + n = nx + nev = 4 + ncv = 20 + if ( n .gt. maxn ) then + print *, ' ERROR with _NDRV1: N is greater than MAXN ' + go to 9000 + else if ( nev .gt. maxnev ) then + print *, ' ERROR with _NDRV1: NEV is greater than MAXNEV ' + go to 9000 + else if ( ncv .gt. maxncv ) then + print *, ' ERROR with _NDRV1: NCV is greater than MAXNCV ' + go to 9000 + end if + bmat = 'I' + which = 'LM' + ! + ! %-----------------------------------------------------% + ! | The work array WORKL is used in DNAUPD as | + ! | workspace. Its dimension LWORKL is set as | + ! | illustrated below. The parameter TOL determines | + ! | the stopping criterion. If TOL<=0, machine | + ! | precision is used. The variable IDO is used for | + ! | reverse communication, and is initially set to 0. | + ! | Setting INFO=0 indicates that a random vector is | + ! | generated in DNAUPD to start the Arnoldi iteration. | + ! %-----------------------------------------------------% + ! + lworkl = 3*ncv**2+6*ncv + tol = zero + ido = 0 + info = 0 + ! + ! %---------------------------------------------------% + ! | This program uses exact shifts with respect to | + ! | the current Hessenberg matrix (IPARAM(1) = 1). | + ! | IPARAM(3) specifies the maximum number of Arnoldi | + ! | iterations allowed. Mode 1 of DNAUPD is used | + ! | (IPARAM(7) = 1). All these options can be changed | + ! | by the user. For details see the documentation in | + ! | DNAUPD. | + ! %---------------------------------------------------% + ! + ishfts = 1 + maxitr = 300 + mode = 1 + ! + iparam(1) = ishfts + iparam(3) = maxitr + iparam(7) = mode + ! + ! %-------------------------------------------% + ! | M A I N L O O P (Reverse communication) | + ! %-------------------------------------------% + ! + 10 continue + ! + ! %---------------------------------------------% + ! | Repeatedly call the routine DNAUPD and take | + ! | actions indicated by parameter IDO until | + ! | either convergence is indicated or maxitr | + ! | has been exceeded. | + ! %---------------------------------------------% + ! + call dnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, info ) + ! + if (ido .eq. -1 .or. ido .eq. 1) then + ! + ! %-------------------------------------------% + ! | Perform matrix vector multiplication | + ! | y <--- OP*x | + ! | The user should supply his/her own | + ! | matrix vector multiplication routine here | + ! | that takes workd(ipntr(1)) as the input | + ! | vector, and return the matrix vector | + ! | product to workd(ipntr(2)). | + ! %-------------------------------------------% + ! + call smatrix_vector(reservoir, nx, workd(ipntr(1)), workd(ipntr(2))) + ! %-----------------------------------------% + ! | L O O P B A C K to call DNAUPD again. | + ! %-----------------------------------------% + ! + go to 10 + ! + end if + ! + ! %----------------------------------------% + ! | Either we have convergence or there is | + ! | an error. | + ! %----------------------------------------% + ! + if ( info .lt. 0 ) then + ! + ! %--------------------------% + ! | Error message, check the | + ! | documentation in DNAUPD. | + ! %--------------------------% + ! + print *, ' ' + print *, ' Error with _naupd, info = ', info + print *, ' Check the documentation of _naupd' + print *, ' ' + ! + else + ! + ! %-------------------------------------------% + ! | No fatal errors occurred. | + ! | Post-Process using DNEUPD. | + ! | | + ! | Computed eigenvalues may be extracted. | + ! | | + ! | Eigenvectors may also be computed now if | + ! | desired. (indicated by rvec = .true.) | + ! %-------------------------------------------% + ! + rvec = .true. + ! + call dneupd(rvec, 'A', select, d, d(1,2), v, ldv, sigmar, sigmai, workev, bmat, n, which, nev,tol, resid, ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, ierr ) + ! + ! %-----------------------------------------------% + ! | The real part of the eigenvalue i returned | + ! | in the first column of the two dimensional | + ! | array D, and the imaginary part is returned | + ! | in the second column of D. The corresponding | + ! | eigenvectors are returned in the first NEV | + ! | columns of the two dimensional array V if | + ! | requested. Otherwise, an orthogonal basis | + ! | for the invariant subspace corresponding to | + ! | the eigenvalues in D is returned in V. | + ! %-----------------------------------------------% + ! + if ( ierr .ne. 0) then + + ! %------------------------------------% + ! | Error condition: | + ! | Check the documentation of DNEUPD.| + ! %------------------------------------% + ! + print *, ' ' + print *, ' Error with _neupd, info = ', ierr + print *, ' Check the documentation of _neupd. ' + print *, ' ' + ! + else +! + first = .true. + nconv = iparam(5) + do 20 j=1, nconv +! +! %---------------------------% +! | Compute the residual norm | +! | | +! | || A*x - lambda*x || | +! | | +! | for the NCONV accurately | +! | computed eigenvalues and | +! | eigenvectors. (iparam(5) | +! | indicates how many are | +! | accurate to the requested | +! | tolerance) | +! %---------------------------% +! + if (d(j,2) .eq. zero) then +! +! %--------------------% +! | Ritz value is real | +! %--------------------% +! + call smatrix_vector(reservoir, nx, v(1,j), ax) + call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) + d(j,3) = dnrm2(n, ax, 1) + d(j,3) = d(j,3) / abs(d(j,1)) +! + else if (first) then +! +! %------------------------% +! | Ritz value is complex. | +! | Residual of one Ritz | +! | value of the conjugate | +! | pair is computed. | +! %------------------------% + ! + call smatrix_vector(reservoir, nx, v(1,j), ax) + call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) + call daxpy(n, d(j,2), v(1,j+1), 1, ax, 1) + d(j,3) = dnrm2(n, ax, 1) + call smatrix_vector(reservoir, nx, v(1,j+1), ax) + call daxpy(n, -d(j,2), v(1,j), 1, ax, 1) + call daxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) + d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) + d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) + d(j+1,3) = d(j,3) + first = .false. + else + first = .true. + end if +! + 20 continue +! + end if +! +! %-------------------------------------------% +! | Print additional convergence information. | +! %-------------------------------------------% +! + if ( info .eq. 1) then + print *, ' ' + print *, ' Maximum number of iterations reached.' + print *, ' ' + else if ( info .eq. 3) then + print *, ' ' + print *, ' No shifts could be applied during implicit',' Arnoldi update, try increasing NCV.' + print *, ' ' + end if +! + end if +! +! %---------------------------% +! | Done with program dndrv1. | +! %---------------------------% +! + 9000 continue +! + eigs = maxval(d) + return + + end subroutine + + subroutine smatrix_vector(reservoir, col, x, y) + + type(reservoir_type), intent(in) :: reservoir + + integer, intent(in) :: col + real(kind=dp), intent(inout) :: x(col), y(col) + + real(kind=dp) :: alpha, beta + integer :: info + alpha = 1.0 + beta = 0.0 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + + return + end subroutine +end module diff --git a/src/mod_lsccon.f90 b/src/mod_lsccon.f90 new file mode 100755 index 0000000..b898516 --- /dev/null +++ b/src/mod_lsccon.f90 @@ -0,0 +1,20 @@ +!> @brief +!> Constants for large-scale condensation. +module mod_lsccon + implicit none + + private + public trlsc, rhlsc, drhlsc, rhblsc + + ! Relaxation time (in hours) for specific humidity + real, parameter :: trlsc = 4.0 + + ! Maximum relative humidity threshold (at sigma=1) + real, parameter :: rhlsc = 0.9 + + ! Vertical range of relative humidity threshold + real, parameter :: drhlsc = 0.1 + + ! Relative humidity threshold for boundary layer + real, parameter :: rhblsc = 0.95 +end module diff --git a/src/mod_physcon.f90 b/src/mod_physcon.f90 new file mode 100755 index 0000000..2ad4bb3 --- /dev/null +++ b/src/mod_physcon.f90 @@ -0,0 +1,46 @@ +module mod_physcon + use mod_atparam + + implicit none + + private + public p0, gg, rd, cp, alhc, alhs, sbc + public sig, sigl, sigh, dsig, pout, grdsig, grdscp, wvi, slat, clat + + ! Physical constants + ! Reference pressure + real, parameter :: p0 = 1.e+5 + + ! Gravity accel. + real, parameter :: gg = 9.81 + + ! Gas constant for dry air + real, parameter :: rd = 287. + + ! Specific heat at constant pressure + real, parameter :: cp = 1004. + + ! Latent heat of condensation, in J/g for consistency with spec.hum. in g/Kg + real, parameter :: alhc = 2501.0 + + ! Latent heat of sublimation + real, parameter :: alhs = 2801.0 + + ! Stefan-Boltzmann constant + real, parameter :: sbc = 5.67e-8 + + ! Functions of sigma and latitude (initial. in INPHYS) + ! sig = full-level sigma + ! sigl = logarithm of full-level sigma + ! sigh = half-level sigma + ! dsig = layer depth in sigma + ! pout = norm. pressure level [p/p0] for post-processing + ! grdsig = g/(d_sigma p0) : to convert fluxes of u,v,q into d(u,v,q)/dt + ! grdscp = g/(d_sigma p0 c_p): to convert energy fluxes into dT/dt + ! wvi = weights for vertical interpolation + ! slat = sin(lat) + ! clat = cos(lat) + real, dimension(kx) :: sig, sigl, dsig, pout, grdsig, grdscp + real :: wvi(kx,2), sigh(0:kx) + real, dimension(il) :: slat, clat +end module diff --git a/src/mod_physvar.f90 b/src/mod_physvar.f90 new file mode 100755 index 0000000..da34130 --- /dev/null +++ b/src/mod_physvar.f90 @@ -0,0 +1,77 @@ +module mod_physvar + use mod_atparam + + implicit none + + private + public ug1, vg1, tg1, qg1, phig1, pslg1 + public se, rh, qsat + public psg, ts, tskin, u0, v0, t0, q0, cloudc, clstr, cltop, prtop + public tt_cnv, qt_cnv, tt_lsc, qt_lsc, tt_rsw, tt_rlw, ut_pbl, vt_pbl,& + & tt_pbl, qt_pbl + public precnv, precls, snowcv, snowls, cbmf, tsr, ssrd, ssr, slrd, slr,& + & olr, slru, ustr, vstr, shf, evap, hfluxn + + ! ug1 = u-wind + ! vg1 = v-wind + ! tg1 = abs. temperature + ! qg1 = specific humidity (g/kg) + ! phig1 = geopotential + ! pslg1 = log. of surface pressure + real, dimension(ix*il,kx) :: ug1, vg1, tg1, qg1, phig1 + real :: pslg1(ix*il) + + ! se = dry static energy + ! rh = relative humidity + ! qsat = saturation specific humidity (g/kg) + real, dimension(ix*il,kx) :: se, rh, qsat + + ! psg = surface pressure + ! ts = surface temperature + ! tskin = skin temperature + ! u0 = near-surface u-wind + ! v0 = near-surface v-wind + ! t0 = near-surface air temperature + ! q0 = near-surface specific humidity (g/kg) + ! cloudc = total cloud cover (fraction) + ! clstr = stratiform cloud cover (fraction) + ! cltop = norm. pressure at cloud top + ! prtop = top of precipitation (level index) + real, dimension(ix*il) :: psg, ts, tskin, u0, v0, t0, q0, cloudc, clstr,& + & cltop, prtop + + ! tt_cnv = temperature tendency due to convection + ! qt_cnv = sp. humidity tendency due to convection + ! tt_lsc = temperature tendency due to large-scale condensation + ! qt_lsc = sp. humidity tendency due to large-scale condensation + ! tt_rsw = temperature tendency due to short-wave radiation + ! tt_rlw = temperature tendency due to long-wave radiation + ! ut_pbl = u-wind tendency due to PBL and diffusive processes + ! vt_pbl = v-wind tendency due to PBL and diffusive processes + ! tt_pbl = temperature tendency due to PBL and diffusive processes + ! qt_pbl = sp. humidity tendency due to PBL and diffusive processes + real, dimension(ix*il,kx) :: tt_cnv, qt_cnv, tt_lsc, qt_lsc, tt_rsw,& + & tt_rlw, ut_pbl, vt_pbl, tt_pbl, qt_pbl + + ! precnv = convective precipitation [g/(m^2 s)], total + ! precls = large-scale precipitation [g/(m^2 s)], total + ! snowcv = convective precipitation [g/(m^2 s)], snow only + ! snowls = large-scale precipitation [g/(m^2 s)], snow only + ! cbmf = cloud-base mass flux + ! tsr = top-of-atm. shortwave radiation (downward) + ! ssrd = surface shortwave radiation (downward-only) + ! ssr = surface shortwave radiation (net downward) + ! slrd = surface longwave radiation (downward-only) + ! slr = surface longwave radiation (net upward) + ! olr = outgoing longwave radiation (upward) + ! slru = surface longwave emission (upward) + ! (1:land, 2:sea, 3: wgt. average) + ! ustr = u-stress (1:land, 2:sea, 3: wgt. average) + ! vstr = v-stress (1:land, 2:sea, 3: wgt. average) + ! shf = sensible heat flux (1:land, 2:sea, 3: wgt. average) + ! evap = evaporation [g/(m^2 s)] (1:land, 2:sea, 3: wgt. average) + ! hfluxn = net heat flux into surf. (1:land, 2:sea, 3: ice-sea dif.) + real, dimension(ix*il) :: precnv, precls, snowcv, snowls, cbmf, tsr, ssrd,& + & ssr, slrd, slr, olr + real, dimension(ix*il,3) :: slru, ustr, vstr, shf, evap, hfluxn +end module diff --git a/src/mod_radcon.f90 b/src/mod_radcon.f90 new file mode 100755 index 0000000..6a90b02 --- /dev/null +++ b/src/mod_radcon.f90 @@ -0,0 +1,127 @@ +module mod_radcon + use mod_atparam + + implicit none + + private + public solc, albsea, albice, albsn, rhcl1, rhcl2, qacl, wpcl, pmaxcl,& + & clsmax, clsminl, gse_s0, gse_s1, albcl, albcls, epssw, epslw, emisfc,& + & absdry, absaer, abswv1, abswv2, abscl1, abscl2, ablwin, ablco2,& + & ablco2_ref, ablwv1, ablwv2, ablcl1, ablcl2 + public fband + public fsol, ozone, ozupp, zenit, stratz + public alb_l, alb_s, albsfc, snowc + public tau2, st4a, stratc, flux + public qcloud, irhtop + + ! Radiation and cloud constants + + ! solc = Solar constant (area averaged) in W/m^2 + ! albsea = Albedo over sea + ! albice = Albedo over sea ice (for ice fraction = 1) + ! albsn = Albedo over snow (for snow cover = 1) + + ! rhcl1 = relative hum. threshold corr. to cloud cover = 0 + ! rhcl2 = relative hum. corr. to cloud cover = 1 + ! qacl = specific hum. threshold for cloud cover + ! wpcl = cloud c. weight for the sq. root of precip. (for p = 1 mm/day) + ! pmaxcl = max. value of precip. (mm/day) contributing to cloud cover + + ! clsmax = maximum stratiform cloud cover + ! clsminl= minimum stratiform cloud cover over land (for RH = 1) + ! gse_s0 = gradient of dry static energy corresp. to strat.c.c. = 0 + ! gse_s1 = gradient of dry static energy corresp. to strat.c.c. = 1 + + ! albcl = cloud albedo (for cloud cover = 1) + ! albcls = stratiform cloud albedo (for st. cloud cover = 1) + ! epssw = fraction of incoming solar radiation absorbed by ozone + ! epslw = fraction of blackbody spectrum absorbed/emitted by PBL only + ! emisfc = longwave surface emissivity + + ! shortwave absorptivities (for dp = 10^5 Pa) : + ! absdry = abs. of dry air (visible band) + ! absaer = abs. of aerosols (visible band) + ! abswv1 = abs. of water vapour (visible band, for dq = 1 g/kg) + ! abswv2 = abs. of water vapour (near IR band, for dq = 1 g/kg) + ! abscl2 = abs. of clouds (visible band, for dq_base = 1 g/kg) + ! abscl1 = abs. of clouds (visible band, maximum value) + + ! longwave absorptivities (per dp = 10^5 Pa) : + ! ablwin = abs. of air in "window" band + ! ablco2 = abs. of air in CO2 band + ! ablwv1 = abs. of water vapour in H2O band 1 (weak), for dq = 1 g/kg + ! ablwv2 = abs. of water vapour in H2O band 2 (strong), for dq = 1 g/kg + ! ablcl1 = abs. of "thick" clouds in window band (below cloud top) + ! ablcl2 = abs. of "thin" upper clouds in window and H2O bands + + real :: solc = 342.0 + + real :: albsea = 0.07 + real :: albice = 0.60!0.75 + real :: albsn = 0.60 + + real :: rhcl1 = 0.30 + real :: rhcl2 = 1.00 + real :: qacl = 0.20 + real :: wpcl = 0.2 + real :: pmaxcl = 10.0 + + real :: clsmax = 0.60!0.50 + real :: clsminl = 0.15 + real :: gse_s0 = 0.25 + real :: gse_s1 = 0.40 + + real :: albcl = 0.43 + real :: albcls = 0.50 + + real :: epssw = 0.020!0.025 + real :: epslw = 0.05 + real :: emisfc = 0.98 + + real :: absdry = 0.033 + real :: absaer = 0.033 + real :: abswv1 = 0.022 + real :: abswv2 = 15.000 + + real :: abscl1 = 0.015 + real :: abscl2 = 0.15 + + real :: ablwin = 0.3 + real :: ablco2 = 6.0!5.0 + real :: ablwv1 = 0.7 + real :: ablwv2 = 50.0 + + real :: ablcl1 = 12.0 + real :: ablcl2 = 0.6 + real :: ablco2_ref + + ! Time-invariant fields (initial. in radset) + ! fband = energy fraction emitted in each LW band = f(T) + real :: fband(100:400,4) + + ! Zonally-averaged fields for SW/LW scheme (updated in sol_oz) + ! fsol = flux of incoming solar radiation + ! ozone = flux absorbed by ozone (lower stratos.) + ! ozupp = flux absorbed by ozone (upper stratos.) + ! zenit = optical depth ratio (function of solar zenith angle) + ! stratz = stratospheric correction for polar night + real, dimension(ix*il) :: fsol, ozone, ozupp, zenit, stratz + + ! Radiative properties of the surface (updated in fordate) + ! alb_l = daily-mean albedo over land (bare-land + snow) + ! alb_s = daily-mean albedo over sea (open sea + sea ice) + ! albsfc = combined surface albedo (land + sea) + ! snowc = effective snow cover (fraction) + real, dimension(ix*il) :: alb_l, alb_s, albsfc, snowc + + ! Transmissivity and blackbody rad. (updated in radsw/radlw) + ! tau2 = transmissivity of atmospheric layers + ! st4a = blackbody emission from full and half atmospheric levels + ! stratc = stratospheric correction term + ! flux = radiative flux in different spectral bands + real :: tau2(ix*il,kx,4), st4a(ix*il,kx,2), stratc(ix*il,2), flux(ix*il,4) + + ! Radiative properties of clouds (updated in cloud) + ! qcloud = Equivalent specific humidity of clouds + real, dimension(ix*il) :: qcloud, irhtop +end module diff --git a/src/mod_randfor.f90 b/src/mod_randfor.f90 new file mode 100755 index 0000000..7748146 --- /dev/null +++ b/src/mod_randfor.f90 @@ -0,0 +1,11 @@ +module mod_randfor + use mod_atparam + + implicit none + + private + public randfh, randfv + + ! Random diabatic forcing (initial. in INIRDF, modified by XS_RDF)) + real :: randfh(ix,il,2), randfv(il,kx,2) +end module diff --git a/src/mod_reservoir.f90 b/src/mod_reservoir.f90 new file mode 100755 index 0000000..0830b63 --- /dev/null +++ b/src/mod_reservoir.f90 @@ -0,0 +1,1713 @@ +module mod_reservoir + USE, INTRINSIC :: IEEE_ARITHMETIC + use MKL_SPBLAS + use mod_utilities, only : dp, main_type, reservoir_type, grid_type, model_parameters_type + + implicit none + + integer :: global_time_step +contains + +subroutine initialize_model_parameters(model_parameters,processor,num_of_procs) + use mpires, only : distribute_prediction_marker + + !bunch of reservoir parameters + type(model_parameters_type) :: model_parameters + integer, intent(in) :: processor, num_of_procs + + model_parameters%number_of_regions = 1152 + + model_parameters%ml_only = .False. + + model_parameters%num_predictions = 1 + model_parameters%trial_name = '6000_20_20_20_beta_res0.001_beta_model_1.0_prior_0.0_overlap1_vertlevel_1_precip_epsilon0.001_2kbias_10_year_then_platue_speedy_atmo_only' !14d_0.9rho_10noise_beta0.001_20years' + !model_parameters%trial_name = '6000_20_20_20_beta_res0.01_beta_model_1.0_prior_0.0_overlap1_vertlevels_4_vertlap_6_slab_ocean_model_true_precip_true' + !'4000_20_20_20_beta_res0.01_beta_model_1.0_prior_0.0_overlap1_vertlevels_4_vertlap_2_full_timestep_1' + !model_parameters%trial_name = '4000_20_20_20_beta_res0.01_beta_model_1.0_prior_0.0_overlap1_vertlevels_4_vertlap_2_full_test_climate_all_tisr_longer' + + model_parameters%discardlength = 24*10!7 + model_parameters%traininglength = 227760 - 24*10!166440 - 24*10 !87600*2+24*10!3+24*10!188280 !254040 !81600!188280!0!0!0!166600!81600 !00!58000!67000!77000 + model_parameters%predictionlength = 8760*31 + 24*5!8760*30 + 24*5!504!8760*11 + 24*5 !504!0 + model_parameters%synclength = 24*14 !24*14*2 !+ 180*24 + model_parameters%timestep = 6!1 !6 + model_parameters%timestep_slab = 24*7!24*7!*14!*2!*7 + + global_time_step = model_parameters%timestep + + model_parameters%slab_ocean_model_bool = .False. + model_parameters%train_on_sst_anomalies = .False. + + model_parameters%precip_bool = .True. !.True. + model_parameters%precip_epsilon = 0.001!0.0005 + + model_parameters%timeofday_bool = .False. + + model_parameters%full_predictvars = 4 + model_parameters%full_heightlevels = 8 + + model_parameters%num_vert_levels = 1 + model_parameters%vert_loc_overlap = 0!6!1!2 + + model_parameters%overlap = 1 + + model_parameters%irank = processor + model_parameters%numprocs = num_of_procs + + model_parameters%noisy = .True. + + model_parameters%regional_vary = .True. + + model_parameters%using_prior = .True. + + model_parameters%model_noise = 0.0_dp + + call distribute_prediction_marker(model_parameters) + +end subroutine + + +subroutine allocate_res_new(reservoir,grid,model_parameters) + !Routine to allocate all of the reservoir arrays + + use resdomain, only : set_reservoir_by_region + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + integer :: nodes_per_input + + reservoir%m = 6000!6000 + + reservoir%deg = 6 + reservoir%radius = 0.9 + reservoir%beta_res = 0.001_dp + reservoir%beta_model = 1.0_dp + reservoir%sigma = 0.5_dp!/6.0_dp + + reservoir%leakage = 1.0_dp!/3.0_dp!1.0!1.0_dp/12.0_dp!6.0_dp + + reservoir%prior_val = 0.0_dp + + reservoir%density = reservoir%deg/reservoir%m + + call set_reservoir_by_region(reservoir,grid) + + if(reservoir%logp_bool) then + reservoir%logp_size_input = grid%inputxchunk*grid%inputychunk !((grid%resxchunk+grid%overlap*2)*(grid%resychunk+1*grid%overlap)) + else + reservoir%logp_size_input = 0 + endif + + if(reservoir%sst_bool_input) then + reservoir%sst_size_input = grid%inputxchunk*grid%inputychunk + else + reservoir%sst_size_input = 0 + endif + + if(reservoir%logp_bool) then + reservoir%logp_size_res = grid%resxchunk*grid%resychunk + else + reservoir%logp_size_res = 0 + endif + + if(reservoir%precip_input_bool) then + reservoir%precip_size_res = grid%resxchunk*grid%resychunk + else + reservoir%precip_size_res = 0 + endif + + if(reservoir%precip_input_bool) then + reservoir%precip_size_input = grid%inputxchunk*grid%inputychunk + else + reservoir%precip_size_input = 0 + endif + + if(reservoir%sst_bool_input) then + reservoir%sst_size_res = grid%resxchunk*grid%resychunk + else + reservoir%sst_size_res = 0 + endif + + if(reservoir%tisr_input_bool) then + reservoir%tisr_size_res = grid%resxchunk*grid%resychunk + else + reservoir%tisr_size_res = 0 + endif + + if(reservoir%tisr_input_bool) then + reservoir%tisr_size_input = grid%inputxchunk*grid%inputychunk!((grid%resxchunk+grid%overlap*2)*(grid%resychunk+1*grid%overlap)) + else + reservoir%tisr_size_input = 0 + endif + + reservoir%chunk_size = grid%resxchunk*grid%resychunk*reservoir%local_predictvars*grid%reszchunk + reservoir%logp_size_res + reservoir%precip_size_res + reservoir%chunk_size_prediction = grid%resxchunk*grid%resychunk*reservoir%local_predictvars*grid%reszchunk + reservoir%logp_size_res + reservoir%precip_size_res + reservoir%chunk_size_speedy = grid%resxchunk*grid%resychunk*reservoir%local_predictvars*grid%reszchunk + reservoir%logp_size_res + + if(model_parameters%ml_only) then + reservoir%chunk_size_speedy = 0 + endif + + reservoir%locality = 0 + + reservoir%locality = grid%inputxchunk*grid%inputychunk*grid%inputzchunk*reservoir%local_predictvars + reservoir%logp_size_input + reservoir%precip_size_input + reservoir%tisr_size_input + reservoir%sst_size_input - reservoir%chunk_size + + nodes_per_input = NINT(dble(reservoir%m)/(dble(reservoir%chunk_size)+dble(reservoir%locality))) + reservoir%n = nodes_per_input*(reservoir%chunk_size+reservoir%locality) + reservoir%k = reservoir%density*reservoir%n*reservoir%n + reservoir%reservoir_numinputs = reservoir%chunk_size+reservoir%locality + + allocate(reservoir%vals(reservoir%k)) + allocate(reservoir%win(reservoir%n,reservoir%reservoir_numinputs)) + allocate(reservoir%wout(reservoir%chunk_size_prediction,reservoir%n+reservoir%chunk_size_speedy)) + allocate(reservoir%rows(reservoir%k)) + allocate(reservoir%cols(reservoir%k)) +end subroutine + +subroutine gen_res(reservoir) + use mod_linalg, only : mklsparse, sparse_eigen, makesparse + + type(reservoir_type) :: reservoir + + real(kind=dp) :: eigs,average + real(kind=dp), allocatable :: newvals(:) + + call makesparse(reservoir) + + call sparse_eigen(reservoir,reservoir%n*10,6,eigs) + + allocate(newvals(reservoir%k)) + newvals = (reservoir%vals/eigs)*reservoir%radius + reservoir%vals = newvals + + call mklsparse(reservoir) + + if(reservoir%assigned_region == 0) then + print *, 'region num', reservoir%assigned_region + print *, 'radius', reservoir%radius + print *, 'degree', reservoir%deg + print *, 'max res', maxval(reservoir%vals) + print *, 'min res', minval(reservoir%vals) + print *, 'average', sum(reservoir%vals)/size(reservoir%vals) + print *, 'k',reservoir%k + print *, 'eig',eigs + endif + + return +end subroutine + +subroutine train_reservoir(reservoir,grid,model_parameters) + use mod_utilities, only : init_random_seed + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer :: q,i,num_inputs,j,k + integer :: un_noisy_sync + integer :: betas_res, betas_model,priors + integer :: vert_loop + + real(kind=dp), allocatable :: ip(:),rand(:),average + real(kind=dp), allocatable :: test_beta_res(:), test_beta_model(:), test_priors(:) + real(kind=dp), allocatable :: states_x_states_original_copy(:,:) + + character(len=:), allocatable :: base_trial_name + character(len=50) :: beta_res_char,beta_model_char,prior_char + + if(grid%bottom) then + reservoir%logp_bool = .True. + reservoir%tisr_input_bool = .True. + grid%logp_bool = .True. + + reservoir%sst_bool = model_parameters%slab_ocean_model_bool + reservoir%sst_climo_bool = .True. !.False. + + reservoir%precip_input_bool = model_parameters%precip_bool + reservoir%precip_bool = model_parameters%precip_bool + + reservoir%m = 6000 + + else + reservoir%sst_climo_bool = .False. + reservoir%logp_bool = .False. + reservoir%tisr_input_bool = .True. + reservoir%sst_bool = .False. + reservoir%precip_input_bool = .False. + reservoir%precip_bool = .False. + endif + + call get_training_data(reservoir,model_parameters,grid,1) + + !NOTE moving this to get_training_data + !call allocate_res_new(reservoir,grid,model_parameters) + + call gen_res(reservoir) + + q = reservoir%n/reservoir%reservoir_numinputs + + if(reservoir%assigned_region == 0) print *, 'q',q,'n',reservoir%n,'num inputs',reservoir%reservoir_numinputs + + allocate(ip(q)) + allocate(rand(q)) + + reservoir%win = 0.0_dp + + do i=1,reservoir%reservoir_numinputs + + call random_number(rand) + + ip = (-1d0 + 2*rand) + + reservoir%win((i-1)*q+1:i*q,i) = reservoir%sigma*ip + enddo + + deallocate(rand) + deallocate(ip) + + print *,'starting reservoir_layer' + + call initialize_chunk_training(reservoir,model_parameters) + + do i=1,model_parameters%timestep + print *, 'loop number',i + !if(reservoir%assigned_region == 954) print *, 'reservoir%trainingdata(eservoir_numinputs,1:40)',reservoir%trainingdata(reservoir%reservoir_numinputs,1:40) + if(reservoir%assigned_region == 954 .and. .not. model_parameters%ml_only) print *, 'reservoir%imperfect_model_states(:,i)',reservoir%imperfect_model_states(:,i) + if(reservoir%assigned_region == 954) print *, 'reservoir%trainingdata(:,i)', reservoir%trainingdata(:,i) + + if(model_parameters%ml_only) then + call reservoir_layer_chunking_ml(reservoir,model_parameters,grid,reservoir%trainingdata(:,i:model_parameters%traininglength:model_parameters%timestep)) + else + call reservoir_layer_chunking_hybrid(reservoir,model_parameters,grid,reservoir%trainingdata(:,i:model_parameters%traininglength:model_parameters%timestep),reservoir%imperfect_model_states(:,i:model_parameters%traininglength:model_parameters%timestep)) + endif + + enddo + + if((model_parameters%slab_ocean_model_bool).and.(grid%bottom)) then + if(allocated(reservoir%imperfect_model_states)) deallocate(reservoir%imperfect_model_states) + else + deallocate(reservoir%trainingdata) + if(allocated(reservoir%imperfect_model_states)) deallocate(reservoir%imperfect_model_states) + endif + + print *, 'fitting',reservoir%assigned_region + + if(model_parameters%ml_only) then + call fit_chunk_ml(reservoir,model_parameters,grid) + else + call fit_chunk_hybrid(reservoir,model_parameters,grid) + endif + print *, 'cleaning up', reservoir%assigned_region + call clean_batch(reservoir) + +end subroutine + +subroutine get_training_data(reservoir,model_parameters,grid,loop_index) + use mod_utilities, only : era_data_type, speedy_data_type, & + standardize_sst_data_3d, & + standardize_data_given_pars_5d_logp_tisr, & + standardize_data_given_pars_5d_logp, & + standardize_data_given_pars5d, & + standardize_data, & + total_precip_over_a_period, & + standardize_data_3d, & + unstandardize_data_2d, & + e_constant, & + rolling_average_over_a_period + + use mod_calendar + use speedy_res_interface, only : read_era, read_model_states + use resdomain, only : standardize_speedy_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer, intent(in) :: loop_index + + type(era_data_type) :: era_data + type(speedy_data_type) :: speedy_data + + integer :: mean_std_length + + reservoir%local_predictvars = model_parameters%full_predictvars + reservoir%local_heightlevels_input = grid%inputzchunk + + reservoir%local_heightlevels_res = grid%reszchunk + + call initialize_calendar(calendar,1981,1,1,0) + + call get_current_time_delta_hour(calendar,model_parameters%discardlength+model_parameters%traininglength+model_parameters%synclength) + + print *, 'reading era states' + + !Read data in stride and whats only needed for this loop of training + call read_era(reservoir,grid,model_parameters,calendar%startyear,calendar%currentyear,era_data) + + !Match units for specific humidity + era_data%eravariables(4,:,:,:,:) = era_data%eravariables(4,:,:,:,:)*1000.0_dp + where (era_data%eravariables(4,:,:,:,:) < 0.000001) + era_data%eravariables(4,:,:,:,:) = 0.000001_dp + end where + !print *, 'shape(era_data%eravariables)',shape(era_data%eravariables) + !print *, 'era_data',era_data%eravariables(1,:,:,:,10:11) + !Make sure tisr doesnt have zeroes + if(reservoir%tisr_input_bool) then + where(era_data%era_tisr < 0.0_dp) + era_data%era_tisr = 0.0_dp + end where + endif + + if(reservoir%precip_bool) then + !era_data%era_precip = era_data%era_precip * 39.3701 + where(era_data%era_precip < 0.0_dp) + era_data%era_precip = 0.0_dp + end where + if(reservoir%assigned_region == 954) print *, 'era_data%era_precip(1,1,100) before',era_data%era_precip(1,1,100:150) + call total_precip_over_a_period(era_data%era_precip,model_parameters%timestep) + if(reservoir%assigned_region == 954) print *, 'era_data%era_precip(1,1,100) after average',era_data%era_precip(1,1,100:150) + if(reservoir%assigned_region == 954) print *, 'era_data%era_precip/model_parameters%precip_epsilon',era_data%era_precip(1,1,100:150)/model_parameters%precip_epsilon + era_data%era_precip = log(1 + era_data%era_precip/model_parameters%precip_epsilon) + if(reservoir%assigned_region == 954) print *, 'era_data%era_precip(1,1,100:150) after',era_data%era_precip(1,1,100:150) + endif + + !NOTE TODO change back + if(reservoir%sst_bool .and. .not. model_parameters%train_on_sst_anomalies) then + where(era_data%era_sst < 272.0_dp) + era_data%era_sst = 272.0_dp + end where + endif + + !if(reservoir%assigned_region == 954) print *, 'era_data%eravariables(4,2,2,:,1)', era_data%eravariables(4,2,2,:,1) + !if(reservoir%assigned_region == 954) print *, ' era_data%era_tisr(:,1:6)',era_data%era_tisr(4,4,1:6) + + if(reservoir%assigned_region == 954) then + print *, 'era max min temp before',maxval(era_data%eravariables(1,:,:,:,:)),minval(era_data%eravariables(1,:,:,:,:)) + print *, 'era max min u-wind before',maxval(era_data%eravariables(2,:,:,:,:)),minval(era_data%eravariables(2,:,:,:,:)) + print *, 'era max min v-wind before',maxval(era_data%eravariables(3,:,:,:,:)),minval(era_data%eravariables(3,:,:,:,:)) + print *, 'era max min sp before',maxval(era_data%eravariables(4,:,:,:,:)),minval(era_data%eravariables(4,:,:,:,:)) + if(reservoir%logp_bool) print *, 'era max min logp before',maxval(era_data%era_logp),minval(era_data%era_logp) + + if(reservoir%tisr_input_bool) print *, 'era max min tisr before',maxval(era_data%era_tisr),minval(era_data%era_tisr) + if(reservoir%sst_bool) print *, 'era max min sst before',maxval(era_data%era_sst),minval(era_data%era_sst) + if(reservoir%precip_bool) print *, 'era max min precip rate before',maxval(era_data%era_precip), minval(era_data%era_precip) + endif + !Get mean and standard deviation for the first stride of data and use those + !values for the rest of the program + if(loop_index == 1) then + !Standardize each variable using local std and mean and save the std and + !mean + + !Get number of height levels * vars + 2d variables + mean_std_length = model_parameters%full_predictvars*grid%inputzchunk + if(reservoir%logp_bool) then + mean_std_length = mean_std_length + 1 + grid%logp_mean_std_idx = mean_std_length + endif + + if(reservoir%tisr_input_bool) then + mean_std_length = mean_std_length + 1 + grid%tisr_mean_std_idx = mean_std_length + endif + + if(reservoir%precip_bool) then + mean_std_length = mean_std_length + 1 + grid%precip_mean_std_idx = mean_std_length + endif + + if(reservoir%sst_bool) then + mean_std_length = mean_std_length + 1 + grid%sst_mean_std_idx = mean_std_length + endif + + allocate(grid%mean(mean_std_length),grid%std(mean_std_length)) + + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + !grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+2 + !grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + + print *, 'mean_std_length',mean_std_length + call standardize_data(reservoir,era_data%eravariables,era_data%era_logp,era_data%era_tisr,grid%mean,grid%std) + elseif(reservoir%logp_bool) then + !grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + + call standardize_data(reservoir,era_data%eravariables,era_data%era_logp,grid%mean,grid%std) + elseif(reservoir%tisr_input_bool) then + !grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + + call standardize_data(reservoir,era_data%eravariables,era_data%era_tisr,grid%mean,grid%std) + else + call standardize_data(reservoir,era_data%eravariables,grid%mean,grid%std) + endif + + if(reservoir%sst_bool) then + !grid%sst_mean_std_idx = mean_std_length + call standardize_sst_data_3d(era_data%era_sst,grid%mean(grid%sst_mean_std_idx),grid%std(grid%sst_mean_std_idx),reservoir%sst_bool_input) + else + reservoir%sst_bool_input = .False. + endif + + if(reservoir%precip_bool) then + ! if(reservoir%assigned_region == 954) print *, 'era_data%era_precip before',era_data%era_precip(1,1,1:100) + !call total_precip_over_a_period(era_data%era_precip,model_parameters%timestep) + !if(reservoir%assigned_region == 954) print *, 'era max min precip rate after summing',maxval(era_data%era_precip), minval(era_data%era_precip) + !if(reservoir%assigned_region == 954) print *, 'era_data%era_precip after',era_data%era_precip(1,1,1:100) + call standardize_data_3d(era_data%era_precip,grid%mean(grid%precip_mean_std_idx),grid%std(grid%precip_mean_std_idx)) + if(reservoir%assigned_region == 954) print *, 'precip mean and std',grid%mean(grid%precip_mean_std_idx),grid%std(grid%precip_mean_std_idx) + endif + else + !Standardize the data from the first stride's std and mean + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + call standardize_data_given_pars_5d_logp_tisr(grid%mean,grid%std,era_data%eravariables,era_data%era_logp,era_data%era_tisr) + elseif(reservoir%logp_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_logp) + elseif(reservoir%tisr_input_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_tisr) + else + call standardize_data_given_pars5d(grid%mean,grid%std,era_data%eravariables) + endif + endif + + if(reservoir%assigned_region == 954) then + print *, 'era max min temp after',maxval(era_data%eravariables(1,:,:,:,:)),minval(era_data%eravariables(1,:,:,:,:)) + print *, 'era max min u-wind after',maxval(era_data%eravariables(2,:,:,:,:)),minval(era_data%eravariables(2,:,:,:,:)) + print *, 'era max min v-wind after',maxval(era_data%eravariables(3,:,:,:,:)),minval(era_data%eravariables(3,:,:,:,:)) + print *, 'era max min sp after',maxval(era_data%eravariables(4,:,:,:,:)),minval(era_data%eravariables(4,:,:,:,:)) + if(reservoir%logp_bool) print *, 'era max min logp after',maxval(era_data%era_logp),minval(era_data%era_logp) + + if(reservoir%tisr_input_bool) print *, 'era max min tisr after',maxval(era_data%era_tisr),minval(era_data%era_tisr) + if(reservoir%sst_bool) print *, 'era max min sst after',maxval(era_data%era_sst),minval(era_data%era_sst) + if(reservoir%precip_bool) print *, 'era max min precip rate after',maxval(era_data%era_precip), minval(era_data%era_precip) + print *, 'res%mean,res%std',grid%mean,grid%std + endif + + !NOTE moving this here to we can get the training data + call allocate_res_new(reservoir,grid,model_parameters) + + !Lets get some training data + allocate(reservoir%trainingdata(reservoir%reservoir_numinputs,size(era_data%eravariables,5))) + + print *, 'reservoir%reservoir_numinputs',reservoir%reservoir_numinputs,reservoir%assigned_region,grid%level_index + + grid%logp_start = 0 + grid%logp_end = 0 + grid%sst_start = 0 + grid%sst_end = 0 + + grid%atmo3d_start = 1 + grid%atmo3d_end = model_parameters%full_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk + + grid%predict_start = 1 + grid%predict_end = grid%atmo3d_end + print *, 'grid%atmo3d_start,grid%atmo3d_end',grid%atmo3d_start,grid%atmo3d_end + print *, 'shape(reservoir%trainingdata(grid%atmo3d_start:grid%atmo3d_end,:))',shape(reservoir%trainingdata(grid%atmo3d_start:grid%atmo3d_end,:)) + print *, 'shape(reshape(era_data%eravariables,(/grid%atmo3d_end,size(era_data%eravariables,5)/)))',shape(reshape(era_data%eravariables,(/grid%atmo3d_end,size(era_data%eravariables,5)/))) + reservoir%trainingdata(grid%atmo3d_start:grid%atmo3d_end,:) = reshape(era_data%eravariables,(/grid%atmo3d_end,size(era_data%eravariables,5)/)) + + if(reservoir%logp_bool) then + grid%logp_start = grid%atmo3d_end + 1 + grid%logp_end = grid%atmo3d_end + reservoir%logp_size_input + reservoir%trainingdata(grid%logp_start:grid%logp_end,:) = reshape(era_data%era_logp,(/reservoir%logp_size_input,size(era_data%eravariables,5)/)) + + grid%predict_end = grid%logp_end + endif + + if(reservoir%precip_bool) then + grid%precip_start = grid%atmo3d_end + reservoir%logp_size_input + 1 + grid%precip_end = grid%precip_start + reservoir%precip_size_input - 1 + reservoir%trainingdata(grid%precip_start:grid%precip_end,:) = reshape(era_data%era_precip,(/reservoir%precip_size_input,size(era_data%eravariables,5)/)) + + grid%predict_end = grid%precip_end + endif + + if(reservoir%sst_bool_input) then + grid%sst_start = grid%atmo3d_end + reservoir%logp_size_input + reservoir%precip_size_input + 1 + grid%sst_end = grid%sst_start + reservoir%sst_size_input - 1 + reservoir%trainingdata(grid%sst_start:grid%sst_end,:) = reshape(era_data%era_sst,(/reservoir%sst_size_input,size(era_data%eravariables,5)/)) + endif + + if(reservoir%tisr_input_bool) then + grid%tisr_start = grid%atmo3d_end + reservoir%logp_size_input + reservoir%precip_size_input + reservoir%sst_size_input + 1 + grid%tisr_end = grid%tisr_start + reservoir%tisr_size_input - 1 + reservoir%trainingdata(grid%tisr_start:grid%tisr_end,:) = reshape(era_data%era_tisr,(/reservoir%tisr_size_input,size(era_data%eravariables,5)/)) + endif + + + if(reservoir%assigned_region == 954) print *, 'reservoir%trainingdata(:,1000)',reservoir%trainingdata(:,1000) + if(reservoir%assigned_region == 954) print *, 'reservoir%trainingdata(grid%tisr_start,1000:1100)',reservoir%trainingdata(grid%tisr_start,1000:1100) + deallocate(era_data%eravariables) + deallocate(era_data%era_logp) + + if(allocated(era_data%era_tisr)) then + deallocate(era_data%era_tisr) + endif + + if(allocated(era_data%era_sst)) then + deallocate(era_data%era_sst) + endif + + + !Portion of the routine for getting speedy (imperfect model) data + + if(.not. model_parameters%ml_only) then + print *, 'reading model states' + call read_model_states(reservoir,grid,model_parameters,calendar%startyear,calendar%currentyear,speedy_data) + + !Lets get imperfect model states + where(speedy_data%speedyvariables(4,:,:,:,:) < 0.000001) + speedy_data%speedyvariables(4,:,:,:,:) = 0.000001_dp + end where + + if(reservoir%assigned_region == 954) then + print *, 'speedy max min temp',maxval(speedy_data%speedyvariables(1,:,:,:,:)),minval(speedy_data%speedyvariables(1,:,:,:,:)) + print *, 'speedy max min u-wind',maxval(speedy_data%speedyvariables(2,:,:,:,:)),minval(speedy_data%speedyvariables(2,:,:,:,:)) + print *, 'speedy max min v-wind',maxval(speedy_data%speedyvariables(3,:,:,:,:)),minval(speedy_data%speedyvariables(3,:,:,:,:)) + print *, 'speedy max min sp',maxval(speedy_data%speedyvariables(4,:,:,:,:)),minval(speedy_data%speedyvariables(4,:,:,:,:)) + if(reservoir%logp_bool) print *, 'speedy max min logp',maxval(speedy_data%speedy_logp),minval(speedy_data%speedy_logp) + + print *, 'res%mean,res%std',grid%mean, grid%std + endif + + if(reservoir%assigned_region == 954) print *, 'speedy_data%speedyvariables(:,1,1,1,1)',speedy_data%speedyvariables(:,1,1,1,1) + + if(reservoir%assigned_region == 36) print *, 'reservoir%trainingdata(grid%tisr_start:grid%tisr_end,1000:1100)', reservoir%trainingdata(grid%tisr_start,1000:1100) + call standardize_speedy_data(reservoir,grid,speedy_data) + + if(reservoir%assigned_region == 954) print *, 'speedy_data%speedyvariables(:,1,1,1,1) after',speedy_data%speedyvariables(:,1,1,1,1) + allocate(reservoir%imperfect_model_states(reservoir%chunk_size_speedy,size(speedy_data%speedyvariables,5))) + reservoir%imperfect_model_states = 0.0_dp + + reservoir%imperfect_model_states(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,:) = reshape(speedy_data%speedyvariables,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,size(speedy_data%speedyvariables,5)/)) + + if(reservoir%logp_bool) then + reservoir%imperfect_model_states(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk+1:reservoir%chunk_size_speedy,:) = reshape(speedy_data%speedy_logp,(/grid%resxchunk*grid%resychunk,size(speedy_data%speedyvariables,5)/)) + endif + + deallocate(speedy_data%speedyvariables) + deallocate(speedy_data%speedy_logp) + endif +end subroutine + +subroutine get_prediction_data(reservoir,model_parameters,grid,start_index,length) + use mod_utilities, only : era_data_type, speedy_data_type, & + standardize_data_given_pars_5d_logp_tisr, & + standardize_data_given_pars_5d_logp, & + standardize_data_given_pars5d, & + standardize_data, & + standardize_data_given_pars3d, & + total_precip_over_a_period + + use mod_calendar + use speedy_res_interface, only : read_era, read_model_states + use resdomain, only : standardize_speedy_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer, intent(in) :: start_index,length + + integer :: hours_into_first_year, start_year + integer :: start_time_memory_index, end_time_memory_index + + type(era_data_type) :: era_data + type(speedy_data_type) :: speedy_data + + call get_current_time_delta_hour(calendar,start_index) + + call numof_hours_into_year(calendar%currentyear,calendar%currentmonth,calendar%currentday,calendar%currenthour,hours_into_first_year) + + start_year = calendar%currentyear + + call get_current_time_delta_hour(calendar,start_index+length) + + !Read data in stride and whats only needed for this loop of training + call read_era(reservoir,grid,model_parameters,start_year,calendar%currentyear,era_data,1) + + start_time_memory_index = hours_into_first_year + end_time_memory_index = start_time_memory_index + length + + !Match units for specific humidity + era_data%eravariables(4,:,:,:,:) = era_data%eravariables(4,:,:,:,:)*1000.0_dp + + where (era_data%eravariables(4,:,:,:,:) < 0.000001) + era_data%eravariables(4,:,:,:,:) = 0.000001_dp + end where + + !Make sure tisr doesnt have zeroes + if(reservoir%tisr_input_bool) then + where(era_data%era_tisr < 0.0_dp) + era_data%era_tisr = 0.0_dp + end where + endif + + if(reservoir%sst_bool .and. .not. model_parameters%train_on_sst_anomalies) then + where(era_data%era_sst < 272.0_dp) + era_data%era_sst = 272.0_dp + end where + era_data%era_sst = era_data%era_sst !+ 4.0_dp + endif + + if(reservoir%precip_bool) then + !era_data%era_precip = era_data%era_precip * 39.3701 + where(era_data%era_precip < 0.0_dp) + era_data%era_precip = 0.0_dp + end where + call total_precip_over_a_period(era_data%era_precip,model_parameters%timestep) + if(reservoir%assigned_region == 954) print *, 'era_data%era_precip(1,1,100) before',era_data%era_precip(1,1,100:150) + if(reservoir%assigned_region == 954) print *, 'era_data%era_precip/model_parameters%precip_epsilon',era_data%era_precip(1,1,100:150)/model_parameters%precip_epsilon + era_data%era_precip = log(1 + era_data%era_precip/model_parameters%precip_epsilon) + if(reservoir%assigned_region == 954) print *, 'era_data%era_precip(1,1,100:150) after',era_data%era_precip(1,1,100:150) + endif + !grid%mean(:) = 0 + !grid%std(:) = 1 + !Standardize the data from mean and std of training data + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + call standardize_data_given_pars_5d_logp_tisr(grid%mean,grid%std,era_data%eravariables,era_data%era_logp,era_data%era_tisr) + elseif(reservoir%logp_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_logp) + elseif(reservoir%tisr_input_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_tisr) + else + call standardize_data_given_pars5d(grid%mean,grid%std,era_data%eravariables) + endif + + if(reservoir%sst_bool_input) then + call standardize_data_given_pars3d(era_data%era_sst,grid%mean(grid%sst_mean_std_idx),grid%std(grid%sst_mean_std_idx)) + endif + + if(reservoir%precip_bool) then + call standardize_data_given_pars3d(era_data%era_precip,grid%mean(grid%precip_mean_std_idx),grid%std(grid%precip_mean_std_idx)) + endif + + if(allocated(reservoir%predictiondata)) then + deallocate(reservoir%predictiondata) + endif + + !Lets get some prediction data + allocate(reservoir%predictiondata(reservoir%reservoir_numinputs,length/model_parameters%timestep)) + + reservoir%predictiondata(grid%atmo3d_start:grid%atmo3d_end,:) = reshape(era_data%eravariables(:,:,:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[grid%atmo3d_end,length/model_parameters%timestep]) + + if(reservoir%logp_bool) then + reservoir%predictiondata(grid%logp_start:grid%logp_end,:) = reshape(era_data%era_logp(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[reservoir%logp_size_input,length/model_parameters%timestep]) + endif + + if(reservoir%precip_bool) then + reservoir%predictiondata(grid%precip_start:grid%precip_end,:) = reshape(era_data%era_precip(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[reservoir%precip_size_input,length/model_parameters%timestep]) + endif + + if(reservoir%sst_bool_input) then + reservoir%predictiondata(grid%sst_start:grid%sst_end,:) = reshape(era_data%era_sst(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[reservoir%sst_size_input,length/model_parameters%timestep]) + endif + + if(reservoir%tisr_input_bool) then + reservoir%predictiondata(grid%tisr_start:grid%tisr_end,:) = reshape(era_data%era_tisr(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[reservoir%tisr_size_input,length/model_parameters%timestep]) + endif + + deallocate(era_data%eravariables) + deallocate(era_data%era_logp) + + if(allocated(era_data%era_tisr)) then + deallocate(era_data%era_tisr) + endif + + if(allocated(era_data%era_sst)) then + deallocate(era_data%era_sst) + endif + + if(allocated(era_data%era_precip)) then + deallocate(era_data%era_precip) + endif + + print *, 'shape(reservoir%predictiondata) mod_res',shape(reservoir%predictiondata) + + !print *, 'reservoir%predictiondata(:,5)',reservoir%predictiondata(:,5) + + if(.not. model_parameters%ml_only) then + !Portion of the routine for getting speedy (imperfect model) data + print *, 'reading model states' + call read_model_states(reservoir,grid,model_parameters,start_year,calendar%currentyear,speedy_data,1) + + !Lets get imperfect model states + where(speedy_data%speedyvariables(4,:,:,:,:) < 0.000001) + speedy_data%speedyvariables(4,:,:,:,:) = 0.000001_dp + end where + + call standardize_speedy_data(reservoir,grid,speedy_data) + + if(allocated(reservoir%imperfect_model_states)) then + deallocate(reservoir%imperfect_model_states) + endif + + allocate(reservoir%imperfect_model_states(reservoir%chunk_size_speedy,length/model_parameters%timestep)) + + reservoir%imperfect_model_states = 0.0_dp + + reservoir%imperfect_model_states(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,:) = reshape(speedy_data%speedyvariables(:,:,:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,length/model_parameters%timestep]) + + if(reservoir%logp_bool) then + reservoir%imperfect_model_states(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk+1:reservoir%chunk_size_speedy,:) = reshape(speedy_data%speedy_logp(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[grid%resxchunk*grid%resychunk,length/model_parameters%timestep]) + endif + deallocate(speedy_data%speedyvariables) + deallocate(speedy_data%speedy_logp) + endif + +end subroutine + +subroutine initialize_prediction(reservoir,model_parameters,grid) + use mod_calendar + use mpires, only : mpi_res + use mod_io, only : read_netcdf_3d + use mod_utilities, only : xgrid, ygrid + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(inout) :: model_parameters + + integer :: q,i,num_inputs,j,k + integer :: un_noisy_sync + integer :: betas_res, betas_model,priors + integer :: vert_loop + + real(kind=dp), allocatable :: ip(:),rand(:),average + real(kind=dp), allocatable :: test_beta_res(:), test_beta_model(:), test_priors(:) + real(kind=dp), allocatable :: states_x_states_original_copy(:,:) + real(kind=dp), allocatable :: temp3d(:,:,:), temp3d_2(:,:,:) + + character(len=:), allocatable :: base_trial_name, file_path, sst_file + character(len=50) :: beta_res_char,beta_model_char,prior_char + character(len=4) :: year + + !Try syncing on un-noisy data + if(.not.(allocated(reservoir%saved_state))) allocate(reservoir%saved_state(reservoir%n)) + reservoir%saved_state = 0 + un_noisy_sync = 2160!700 + + !From this point on reservoir%trainingdata and reservoir%imperfect_model have a temporal resolution of 1 + !hour instead of a resolution of model_parameters%timestep + call get_prediction_data(reservoir,model_parameters,grid,model_parameters%traininglength-un_noisy_sync,un_noisy_sync) + + call synchronize(reservoir,reservoir%predictiondata,reservoir%saved_state,un_noisy_sync/model_parameters%timestep-1) + + if(reservoir%tisr_input_bool) then + call get_full_tisr(reservoir,model_parameters,grid) + endif + + if(.not.((model_parameters%slab_ocean_model_bool).and.(grid%bottom))) then + deallocate(reservoir%predictiondata) + endif + + allocate(reservoir%local_model(reservoir%chunk_size_speedy)) + allocate(reservoir%outvec(reservoir%chunk_size_prediction)) + allocate(reservoir%feedback(reservoir%reservoir_numinputs)) + + if(model_parameters%slab_ocean_model_bool .and. mpi_res%is_root .and. grid%bottom) then + print *, 'doing sea mask and default values' + allocate(model_parameters%base_sst_grid(xgrid, ygrid)) + allocate(model_parameters%sea_mask(xgrid, ygrid)) + + write(year,'(I4)') calendar%currentyear + + file_path = '/scratch/user/troyarcomano/ERA_5/'//year//'/' + sst_file = file_path//'era_5_y'//year//'_sst_regridded_fixed_var_gcc.nc' !'_sst_regridded_mpi_fixed_var_gcc.nc' + + call read_netcdf_3d('sst',sst_file,temp3d) + + if(model_parameters%train_on_sst_anomalies) then + call read_netcdf_3d('sst','/scratch/user/troyarcomano/ERA_5/regridded_era_sst_climatology1981_1999_gcc.nc',temp3d_2) + endif + + if(.not. model_parameters%train_on_sst_anomalies) then + where(temp3d < 272.0_dp) + temp3d = 272.0_dp + end where + endif + + model_parameters%base_sst_grid = temp3d(:,:,1) + + if(model_parameters%train_on_sst_anomalies) then + model_parameters%base_sst_grid = model_parameters%base_sst_grid - temp3d_2(:,:,1) + endif + + print *, 'shape(temp3d)',shape(temp3d) + do i=1,xgrid + do j=1, ygrid + if(all(temp3d(i,j,:) < 273.1)) then + print *, 'land/permanent ice at',i,j,model_parameters%base_sst_grid(i,j) + model_parameters%sea_mask(i,j) = 1.0 + else + model_parameters%sea_mask(i,j) = 0.0 + endif + enddo + enddo + deallocate(temp3d) + endif +end subroutine + +subroutine get_full_tisr(reservoir,model_parameters,grid) + use mpires, only : mpi_res + use mod_io, only : read_3d_file_parallel + use mod_utilities, only : standardize_data_given_pars3d + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(inout) :: model_parameters + + character(len=:), allocatable :: file_path + character(len=:), allocatable :: tisr_file + + file_path = '/scratch/user/troyarcomano/ERA_5/2012/' + tisr_file = file_path//'toa_incident_solar_radiation_2012_regridded_classic4.nc' + + call read_3d_file_parallel(tisr_file,'tisr',mpi_res,grid,reservoir%full_tisr,1,1) + print *, 'isr_mean_std_idx,grid%mean(grid%tisr_mean_std_idx),grid%std(grid%tisr_mean_std_idx)',grid%tisr_mean_std_idx,grid%mean(grid%tisr_mean_std_idx),grid%std(grid%tisr_mean_std_idx) + call standardize_data_given_pars3d(reservoir%full_tisr,grid%mean(grid%tisr_mean_std_idx),grid%std(grid%tisr_mean_std_idx)) + +end subroutine + +subroutine start_prediction(reservoir,model_parameters,grid,prediction_number) + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(inout) :: model_parameters + + integer, intent(in) :: prediction_number + + model_parameters%current_trial_number = prediction_number + + call get_prediction_data(reservoir,model_parameters,grid,model_parameters%traininglength+model_parameters%prediction_markers(prediction_number),model_parameters%synclength+100) + + call synchronize_print(reservoir,grid,reservoir%predictiondata(:,1:model_parameters%synclength/model_parameters%timestep-1),reservoir%saved_state,model_parameters%synclength/model_parameters%timestep-1) + + if(reservoir%assigned_region == 36) print *, 'reservoir%predictiondata(:,model_parameters%synclength/model_parameters%timestep)',reservoir%predictiondata(:,model_parameters%synclength/model_parameters%timestep) + if(reservoir%assigned_region == 36 .and. .not. model_parameters%ml_only) print *, 'reservoir%imperfect_model_states(:,model_parameters%synclength/model_parameters%timestep-1)',reservoir%imperfect_model_states(:,model_parameters%synclength/model_parameters%timestep-1) + + reservoir%feedback = reservoir%predictiondata(:,model_parameters%synclength/model_parameters%timestep) + + if(.not. model_parameters%ml_only) then + reservoir%local_model = reservoir%imperfect_model_states(:,model_parameters%synclength/model_parameters%timestep-1) + endif +end subroutine + +subroutine reservoir_layer_chunking_ml(reservoir,model_parameters,grid,trainingdata) + use mpires + use mod_utilities, only : gaussian_noise_1d_function, gaussian_noise_1d_function_precip + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type) , intent(in) :: model_parameters + type(grid_type) , intent(in) :: grid + + real(kind=dp), intent(in) :: trainingdata(:,:) + + integer :: i,info + integer :: training_length, batch_number + + real(kind=dp), allocatable :: temp(:), x(:), x_(:), y(:) + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + real(kind=dp), allocatable :: gaussian_noise + + allocate(temp(reservoir%n),x(reservoir%n),x_(reservoir%n),y(reservoir%n)) + + x = 0 + y = 0 + do i=1, model_parameters%discardlength/model_parameters%timestep + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + + x = (1_dp-reservoir%leakage)*x + reservoir%leakage*x_ + + y = 0 + enddo + + !call initialize_chunk_training() + + reservoir%states(:,1) = x + batch_number = 0 + + training_length = size(trainingdata,2) - model_parameters%discardlength/model_parameters%timestep + + do i=1, training_length-1 + if(mod(i+1,reservoir%batch_size).eq.0) then + print *,'chunking',i, 'region',reservoir%assigned_region + batch_number = batch_number + 1 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,reservoir%batch_size) = x + + reservoir%saved_state = reservoir%states(:,reservoir%batch_size) + + reservoir%states(2:reservoir%n:2,:) = reservoir%states(2:reservoir%n:2,:)**2 + + call chunking_matmul_ml(reservoir,model_parameters,grid,batch_number,trainingdata) + + elseif (mod(i,reservoir%batch_size).eq.0) then + print *,'new state',i, 'region',reservoir%assigned_region + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,reservoir%batch_size),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,1) = x + else + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,mod(i+1,reservoir%batch_size)) = x + endif + + y = 0 + enddo + + return +end subroutine + +subroutine reservoir_layer_chunking_hybrid(reservoir,model_parameters,grid,trainingdata,imperfect_model) + use mpires + use mod_utilities, only : gaussian_noise_1d_function,gaussian_noise_1d_function_precip + + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type) , intent(in) :: model_parameters + type(grid_type) , intent(in) :: grid + + real(kind=dp), intent(in) :: trainingdata(:,:) + real(kind=dp), intent(in) :: imperfect_model(:,:) + + integer :: i,info + integer :: training_length, batch_number + + real(kind=dp), allocatable :: temp(:), x(:), x_(:), y(:) + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + real(kind=dp), allocatable :: gaussian_noise + + allocate(temp(reservoir%n),x(reservoir%n),x_(reservoir%n),y(reservoir%n)) + + x = 0 + y = 0 + do i=1, model_parameters%discardlength/model_parameters%timestep + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1_dp-reservoir%leakage)*x + reservoir%leakage*x_ + + y = 0 + enddo + + !call initialize_chunk_training() + + reservoir%states(:,1) = x + batch_number = 0 + + training_length = size(trainingdata,2) - model_parameters%discardlength/model_parameters%timestep + + do i=1, training_length-1 + if(mod(i+1,reservoir%batch_size).eq.0) then + print *,'chunking',i, 'region',reservoir%assigned_region + batch_number = batch_number + 1 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,reservoir%batch_size) = x + + reservoir%saved_state = reservoir%states(:,reservoir%batch_size) + + reservoir%states(2:reservoir%n:2,:) = reservoir%states(2:reservoir%n:2,:)**2 + + call chunking_matmul(reservoir,model_parameters,grid,batch_number,trainingdata,imperfect_model) + + elseif (mod(i,reservoir%batch_size).eq.0) then + print *,'new state',i, 'region',reservoir%assigned_region + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%saved_state,beta,y) !reservoir%states(:,reservoir%batch_size),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,1) = x + else + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,mod(i+1,reservoir%batch_size)) = x + endif + + y = 0 + enddo + + return +end subroutine + +subroutine fit_chunk_ml(reservoir,model_parameters,grid) + !This solves for Wout using least squared solver for the ml only version + !This should be called only if you are chunking the training + !There is an option to train using a Prior + !The prior would try to force the weights of Wout + !for the numerical model to be near reservoir%prior_val + + use mod_linalg, only : pinv_svd, mldivide + use mpires + use mod_io, only : write_netcdf_2d_non_met_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer :: i + + real(kind=dp), allocatable :: a_trans(:,:), b_trans(:,:), invstates(:,:) + real(kind=dp), allocatable :: prior(:,:), temp_beta(:,:) + + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + character(len=2) :: level_char + + !Do regularization + + do i=1, reservoir%n + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_res + enddo + + !NOTE moving to mldivide not using pinv anymore + print *, 'trying mldivide' + allocate(a_trans(size(reservoir%states_x_states_aug,2),size(reservoir%states_x_states_aug,1))) + allocate(b_trans(size(reservoir%states_x_trainingdata_aug,2),size(reservoir%states_x_trainingdata_aug,1))) + a_trans = transpose(reservoir%states_x_states_aug) + b_trans = transpose(reservoir%states_x_trainingdata_aug) + + if(reservoir%assigned_region == 954) print *, 'a_trans(1:20,1:20)',a_trans(1:20,1:20) + if(reservoir%assigned_region == 954) print *, 'b_trans(1:20,1:20)',b_trans(1:20,1:20) + + call mldivide(a_trans,b_trans) + reservoir%wout = transpose(b_trans) + + if(reservoir%assigned_region == 954) print *, 'worker',reservoir%assigned_region,'wout(1,1:20)',reservoir%wout(1,1:20) + + deallocate(a_trans) + deallocate(b_trans) + + write(level_char,'(i0.2)') grid%level_index + if(reservoir%assigned_region == 954) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_954_level_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 217) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_217_level_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 218) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_218_level_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + + !call write_trained_res(reservoir,model_parameters,grid) + + print *, 'finish fit' +end subroutine +subroutine fit_chunk_hybrid(reservoir,model_parameters,grid) + !This solves for Wout using least squared solver + !This should be called only if you are chunking the training + !There is an option to train using a Prior + !The prior would try to force the weights of Wout + !for the numerical model to be near reservoir%prior_val + + use mod_linalg, only : pinv_svd, mldivide + use mpires + use mod_io, only : write_netcdf_2d_non_met_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer :: i + + real(kind=dp), allocatable :: a_trans(:,:), b_trans(:,:), invstates(:,:) + real(kind=dp), allocatable :: prior(:,:), temp_beta(:,:) + + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + character(len=2) :: level_char + + + + !If we have a prior we need to make the prior matrix + if(model_parameters%using_prior) then + allocate(prior(size(reservoir%states_x_trainingdata_aug,1),size(reservoir%states_x_trainingdata_aug,2))) + + prior = 0.0_dp + + do i=1, reservoir%chunk_size_speedy!reservoir%chunk_size_prediction + prior(i,i) = reservoir%prior_val*reservoir%beta_model**2.0_dp + enddo + + endif + + !Do regularization + + !If we are doing a prior we need beta^2 + if(model_parameters%using_prior) then + do i=1, reservoir%n+reservoir%chunk_size_speedy!prediction + if(i <= reservoir%chunk_size_speedy) then!_prediction) then + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_model**2.0_dp + else + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_res**2.0_dp + endif + enddo + else + do i=1, reservoir%n+reservoir%chunk_size_speedy!prediction + if(i <= reservoir%chunk_size_speedy) then!prediction) then + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_model + else + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_res + endif + enddo + endif + + !NOTE moving to mldivide not using pinv anymore + print *, 'trying mldivide' + allocate(a_trans(size(reservoir%states_x_states_aug,2),size(reservoir%states_x_states_aug,1))) + allocate(b_trans(size(reservoir%states_x_trainingdata_aug,2),size(reservoir%states_x_trainingdata_aug,1))) + a_trans = transpose(reservoir%states_x_states_aug) + b_trans = transpose(reservoir%states_x_trainingdata_aug) + + if(reservoir%assigned_region == 954) print *, 'a_trans(1:20,1:20)',a_trans(1:20,1:20) + if(reservoir%assigned_region == 954) print *, 'b_trans(1:20,1:20)',b_trans(1:20,1:20) + !if(any(IEEE_IS_NAN(reservoir%states_x_states_aug))) print *, 'reservoir%states_x_states_aug nan', reservoir%assigned_region + !if(any(IEEE_IS_NAN(reservoir%states_x_trainingdata_aug))) print *, 'reservoir%states_x_states_aug nan', reservoir%assigned_region + !if(any(IEEE_IS_NAN(a_trans))) print *, 'a_trans has nan',reservoir%assigned_region + !if(any(IEEE_IS_NAN(b_trans))) print *, 'b_trans has nan',reservoir%assigned_region + + !If we are trying a prior then we need to add it to b_trans + if(model_parameters%using_prior) then + b_trans = b_trans + transpose(prior) + endif + + call mldivide(a_trans,b_trans) + reservoir%wout = transpose(b_trans) + + !if(any(IEEE_IS_NAN(reservoir%wout))) print *, 'wout has nan', reservoir%assigned_region + !if(IEEE_IS_NAN(reservoir%wout(1,1))) print *, 'wout element 1 has nan', reservoir%assigned_region + + + if(reservoir%assigned_region == 954) print *, 'worker',reservoir%assigned_region,'wout(1,1:20)',reservoir%wout(1,1:20) + + deallocate(a_trans) + deallocate(b_trans) + + write(level_char,'(i0.2)') grid%level_index + if(reservoir%assigned_region == 954) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_954_level_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 217) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_217_level_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 218) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_218_level_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + + !call write_trained_res(reservoir,model_parameters,grid) + + print *, 'finish fit' +end subroutine + +subroutine predictcontroller(reservoir,model_parameters,grid,imperfect_model_in) + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: imperfect_model_in(:) + + real(kind=dp), allocatable :: x(:) + + allocate(x(reservoir%n)) + + x = reservoir%saved_state + + call synchronize(reservoir,reservoir%predictiondata(:,1:model_parameters%synclength/model_parameters%timestep),x,model_parameters%synclength/model_parameters%timestep) + + call predict(reservoir,model_parameters,grid,x,imperfect_model_in) +end subroutine + +subroutine synchronize(reservoir,input,x,length) + type(reservoir_type), intent(inout) :: reservoir + + real(kind=dp), intent(in) :: input(:,:) + real(kind=dp), intent(inout) :: x(:) + + integer, intent(in) :: length + + real(kind=dp), allocatable :: y(:), temp(:), x_(:) + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + + integer :: info,i + + allocate(y(reservoir%n)) + allocate(temp(reservoir%n)) + allocate(x_(reservoir%n)) + + y=0 + do i=1, length + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + temp = matmul(reservoir%win,input(:,i)) + + x_ = tanh(y+temp) + x = (1.0_dp-reservoir%leakage)*x + reservoir%leakage*x_ + enddo + + return +end subroutine + +subroutine synchronize_print(reservoir,grid,input,x,length) + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + + real(kind=dp), intent(in) :: input(:,:) + real(kind=dp), intent(inout) :: x(:) + + integer, intent(in) :: length + + real(kind=dp), allocatable :: y(:), temp(:), x_(:) + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + + integer :: info,i + + allocate(y(reservoir%n)) + allocate(temp(reservoir%n)) + allocate(x_(reservoir%n)) + + y=0 + + print *, 'shape(input) sync',reservoir%assigned_region,shape(input) + print *, 'length sync',reservoir%assigned_region,length + do i=1, length + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + if(reservoir%assigned_region == 36) print *, 'i',i + temp = matmul(reservoir%win,input(:,i)) + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + enddo + + return +end subroutine + +subroutine predict(reservoir,model_parameters,grid,x,local_model_in) + use mpires, only : predictionmpicontroller + use resdomain, only : unstandardize_state_vec_res + use mod_utilities, only : e_constant + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: x(:) + real(kind=dp), intent(inout) :: local_model_in(:) + + real(kind=dp), allocatable :: y(:), temp(:), x_(:) + real(kind=dp), allocatable :: local_model_temp(:) + real(kind=dp), allocatable :: x_temp(:),x_augment(:) + + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + + integer :: info,i,j + + allocate(y(reservoir%n),temp(reservoir%n),x_(reservoir%n)) + allocate(x_augment(reservoir%n+reservoir%chunk_size_speedy))!reservoir%chunk_size_prediction)) + + y = 0 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + temp = matmul(reservoir%win,reservoir%feedback) + + x_ = tanh(y + temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + x_temp = x + x_temp(2:reservoir%n:2) = x_temp(2:reservoir%n:2)**2 + + x_augment(1:reservoir%chunk_size_speedy) = reservoir%local_model !prediction) = reservoir%local_model + x_augment(reservoir%chunk_size_speedy+1:reservoir%chunk_size_speedy+reservoir%n) = x_temp !prediction+1:reservoir%chunk_size_prediction+reservoir%n) = x_temp + + reservoir%outvec = matmul(reservoir%wout,x_augment) + + call unstandardize_state_vec_res(reservoir,grid,reservoir%outvec) + + if((reservoir%assigned_region == 954).and.(mod(i,24) == 0)) then + print *, '*******' + print *, 'feedback',reservoir%feedback + print *, '*******' + print *, 'local_model',reservoir%local_model + print *, '*******' + print *, 'outvec atmo',reservoir%outvec + print *, '*******' + !print *, 'precip',model_parameters%precip_epsilon * (e_constant**reservoir%outvec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk+1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk*2) - 1) + !print *, 'feedback',reservoir%feedback + endif +end subroutine + +subroutine predict_ml(reservoir,model_parameters,grid,x) + use mpires, only : predictionmpicontroller + use resdomain, only : unstandardize_state_vec_res + use mod_utilities, only : e_constant + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: x(:) + + real(kind=dp), allocatable :: y(:), temp(:), x_(:) + real(kind=dp), allocatable :: x_temp(:),x_augment(:) + + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + + integer :: info,i,j + + allocate(y(reservoir%n),temp(reservoir%n),x_(reservoir%n)) + allocate(x_augment(reservoir%n+reservoir%chunk_size_speedy))!reservoir%chunk_size_prediction)) + + y = 0 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + temp = matmul(reservoir%win,reservoir%feedback) + + x_ = tanh(y + temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + x_temp = x + x_temp(2:reservoir%n:2) = x_temp(2:reservoir%n:2)**2 + + x_augment(1:reservoir%chunk_size_speedy+reservoir%n) = x_temp !prediction+1:reservoir%chunk_size_prediction+reservoir%n) = x_temp + + reservoir%outvec = matmul(reservoir%wout,x_augment) + + call unstandardize_state_vec_res(reservoir,grid,reservoir%outvec) + + if((reservoir%assigned_region == 954).and.(mod(i,1) == 0)) then + print *, '*******' + print *, 'feedback',reservoir%feedback + print *, '*******' + print *, 'outvec atmo',reservoir%outvec + endif +end subroutine + +subroutine clean_sparse(reservoir) + type(reservoir_type), intent(inout) :: reservoir + + deallocate(reservoir%vals) + deallocate(reservoir%rows) + deallocate(reservoir%cols) +end subroutine + +subroutine clean_batch(reservoir) + type(reservoir_type), intent(inout) :: reservoir + + deallocate(reservoir%states_x_trainingdata_aug) + deallocate(reservoir%states_x_states_aug) +end subroutine + +subroutine clean_prediction(reservoir) + type(reservoir_type), intent(inout) :: reservoir + + deallocate(reservoir%local_model) + deallocate(reservoir%outvec) + deallocate(reservoir%feedback) + +end subroutine + +subroutine initialize_chunk_training(reservoir,model_parameters) + use mod_utilities, only : find_closest_divisor + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + + integer :: num_of_batches !the number of chunks we want + integer :: approx_batch_size !approximate size of the batch + + num_of_batches = 20!10*6!2!10!*5!0!10*6 !20*6 + approx_batch_size = (model_parameters%traininglength - model_parameters%discardlength)/(num_of_batches*model_parameters%timestep) + + !routine to get the closest reservoir%batch_size to num_of_batches that + !divides into reservoir%traininglength + call find_closest_divisor(approx_batch_size,(model_parameters%traininglength - model_parameters%discardlength)/model_parameters%timestep,reservoir%batch_size) + print *, 'num_of_batches,approx_batch_size,reservoir%traininglength,reservoir%batch_size',num_of_batches,approx_batch_size,model_parameters%traininglength-model_parameters%discardlength,reservoir%batch_size + + !Should be reservoir%n+ reservoir%chunk_size + allocate(reservoir%states_x_trainingdata_aug(reservoir%chunk_size_prediction,reservoir%n+reservoir%chunk_size_speedy))!prediction)) + allocate(reservoir%states_x_states_aug(reservoir%n+reservoir%chunk_size_speedy,reservoir%n+reservoir%chunk_size_speedy))!prediction,reservoir%n+reservoir%chunk_size_prediction)) + allocate(reservoir%states(reservoir%n,reservoir%batch_size)) + allocate(reservoir%augmented_states(reservoir%n+reservoir%chunk_size_speedy,reservoir%batch_size))!prediction,reservoir%batch_size)) + allocate(reservoir%saved_state(reservoir%n)) + + reservoir%states_x_trainingdata_aug = 0.0_dp + reservoir%states_x_states_aug = 0.0_dp + reservoir%states = 0.0_dp + reservoir%augmented_states = 0.0_dp + +end subroutine + +subroutine chunking_matmul_ml(reservoir,model_parameters,grid,batch_number,trainingdata) + use mod_utilities, only : gaussian_noise + use resdomain, only : tile_full_input_to_target_data + use mpires + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + integer, intent(in) :: batch_number + + real(kind=dp), intent(in) :: trainingdata(:,:) + + real(kind=dp), allocatable :: temp(:,:), targetdata(:,:) + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + integer :: n, m, l + + n = size(reservoir%augmented_states,1) + m = size(reservoir%augmented_states,2) + + reservoir%augmented_states(reservoir%chunk_size_speedy+1:reservoir%n+reservoir%chunk_size_speedy,:) = reservoir%states + + print *, 'grid%predict_end',grid%predict_end,model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1,batch_number*m+model_parameters%discardlength/model_parameters%timestep + + call tile_full_input_to_target_data(reservoir,grid,trainingdata(1:grid%predict_end,model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep),targetdata) + + if(reservoir%assigned_region == 954) print *, 'shape(trainingdata)',shape(trainingdata) + if(reservoir%assigned_region == 954) print *, 'shape(targetdata)',shape(targetdata) + + allocate(temp(reservoir%chunk_size_prediction,n)) + temp = 0.0_dp + + temp = matmul(targetdata,transpose(reservoir%augmented_states)) + !TODO make this matmul DGEMM + + reservoir%states_x_trainingdata_aug = reservoir%states_x_trainingdata_aug + temp + deallocate(temp) + deallocate(targetdata) + + allocate(temp(n,n)) + call DGEMM('N','N',n,n,m,alpha,reservoir%augmented_states,n,transpose(reservoir%augmented_states),m,beta,temp,n) + !call + !DGEMM('N','T',n,n,m,alpha,reservoir%augmented_states,n,reservoir%augmented_states,m,beta,temp,n) + reservoir%states_x_states_aug = reservoir%states_x_states_aug + temp + deallocate(temp) + + return +end subroutine + + +subroutine chunking_matmul(reservoir,model_parameters,grid,batch_number,trainingdata,imperfect_model) + use mod_utilities, only : gaussian_noise + use resdomain, only : tile_full_input_to_target_data + use mpires + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + integer, intent(in) :: batch_number + + real(kind=dp), intent(in) :: trainingdata(:,:) + real(kind=dp), intent(in) :: imperfect_model(:,:) + + real(kind=dp), allocatable :: temp(:,:), targetdata(:,:) + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + integer :: n, m, l + + n = size(reservoir%augmented_states,1) + m = size(reservoir%augmented_states,2) + + !reservoir%augmented_states(1:reservoir%chunk_size_prediction,:) = imperfect_model(:,model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep) + reservoir%augmented_states(1:reservoir%chunk_size_speedy,:) = imperfect_model(:,model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep) + !if(any(IEEE_IS_NAN(imperfect_model))) print *, 'imperfect_model has nan',reservoir%assigned_region,batch_number + + !reservoir%augmented_states(reservoir%chunk_size_prediction+1:reservoir%n+reservoir%chunk_size_prediction,:) = reservoir%states + reservoir%augmented_states(reservoir%chunk_size_speedy+1:reservoir%n+reservoir%chunk_size_speedy,:) = reservoir%states + !if(any(IEEE_IS_NAN(reservoir%states))) print *, 'reservoir%states has nan',reservoir%assigned_region,batch_number + + print *, 'grid%predict_end',grid%predict_end,model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1,batch_number*m+model_parameters%discardlength/model_parameters%timestep + + call tile_full_input_to_target_data(reservoir,grid,trainingdata(1:grid%predict_end,model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep),targetdata) + if(any(IEEE_IS_NAN(targetdata))) print *, 'targetdata has nan',reservoir%assigned_region,batch_number + !if(reservoir%assigned_region == 954) print *, 'model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep',model_parameters%discardlength/model_parameters%timestep+(batch_number-1)*m+1,batch_number*m+model_parameters%discardlength/model_parameters%timestep + !if(reservoir%assigned_region == 954) print *, 'model_parameters%discardlength',model_parameters%discardlength,'batch_number',batch_number,'m',m + if(reservoir%assigned_region == 954) print *, 'shape(trainingdata)',shape(trainingdata) + if(reservoir%assigned_region == 954) print *, 'shape(targetdata)',shape(targetdata) + + allocate(temp(reservoir%chunk_size_prediction,n)) + temp = 0.0_dp + + temp = matmul(targetdata,transpose(reservoir%augmented_states)) + !TODO make this matmul DGEMM + + reservoir%states_x_trainingdata_aug = reservoir%states_x_trainingdata_aug + temp + deallocate(temp) + deallocate(targetdata) + + allocate(temp(n,n)) + call DGEMM('N','N',n,n,m,alpha,reservoir%augmented_states,n,transpose(reservoir%augmented_states),m,beta,temp,n) + !call DGEMM('N','T',n,n,m,alpha,reservoir%augmented_states,n,reservoir%augmented_states,m,beta,temp,n) + reservoir%states_x_states_aug = reservoir%states_x_states_aug + temp + deallocate(temp) + + return +end subroutine + +subroutine write_trained_res(reservoir,model_parameters,grid) + use mod_io, only : write_netcdf_2d_non_met_data, write_netcdf_1d_non_met_data_int, write_netcdf_1d_non_met_data_real + + type(reservoir_type), intent(in) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + character(len=:), allocatable :: file_path + character(len=4) :: worker_char + character(len=1) :: height_char + + file_path = '/scratch/user/troyarcomano/ML_SPEEDY_WEIGHTS/' + + write(worker_char,'(i0.4)') reservoir%assigned_region + write(height_char,'(i0.1)') grid%level_index + + if((reservoir%assigned_region == 0).and.(grid%level_index == 1)) then + call write_controller_file(model_parameters) + endif + + call write_netcdf_2d_non_met_data(reservoir%win,'win',file_path//'worker_'//worker_char//'_level_'//height_char//'_win_'//trim(model_parameters%trial_name)//'.nc','unitless') + call write_netcdf_2d_non_met_data(reservoir%wout,'wout',file_path//'worker_'//worker_char//'_level_'//height_char//'_wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + + call write_netcdf_1d_non_met_data_int(reservoir%rows,'rows',file_path//'worker_'//worker_char//'_level_'//height_char//'_rows_'//trim(model_parameters%trial_name)//'.nc','unitless') + call write_netcdf_1d_non_met_data_int(reservoir%cols,'cols',file_path//'worker_'//worker_char//'_level_'//height_char//'_cols_'//trim(model_parameters%trial_name)//'.nc','unitless') + + call write_netcdf_1d_non_met_data_real(reservoir%vals,'vals',file_path//'worker_'//worker_char//'_level_'//height_char//'_vals_'//trim(model_parameters%trial_name)//'.nc','unitless') + + call write_netcdf_1d_non_met_data_real(grid%mean,'mean',file_path//'worker_'//worker_char//'_level_'//height_char//'_mean_'//trim(model_parameters%trial_name)//'.nc','unitless') + call write_netcdf_1d_non_met_data_real(grid%std,'std',file_path//'worker_'//worker_char//'_level_'//height_char//'_std_'//trim(model_parameters%trial_name)//'.nc','unitless') + +end subroutine + +subroutine write_controller_file(model_parameters) + type(model_parameters_type), intent(in) :: model_parameters + + character(len=:), allocatable :: file_path + + file_path = '/scratch/user/troyarcomano/ML_SPEEDY_WEIGHTS/'//trim(model_parameters%trial_name)//'_controller_file.txt' + + open (10, file=file_path, status='unknown') + + ! write to file + write(10,*)"-----------------------------------------------------------" + write(10,*) + write(10,*)"num_vert_levels:",model_parameters%num_vert_levels + write(10,*)"-----------------------------------------------------------" + + ! close file + close(10) + +end subroutine + +subroutine trained_reservoir_prediction(reservoir,model_parameters,grid) + use mod_linalg, only : mklsparse + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(inout) :: grid + + call read_trained_res(reservoir,model_parameters,grid) + + call mklsparse(reservoir) + + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+2 + grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + elseif(reservoir%logp_bool) then + grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + elseif(reservoir%tisr_input_bool) then + grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + endif +end subroutine + +subroutine read_trained_res(reservoir,model_parameters,grid) + use mod_io, only : read_netcdf_2d_dp, read_netcdf_1d_int, read_netcdf_1d_dp + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(inout) :: grid + + character(len=:), allocatable :: file_path + character(len=4) :: worker_char + character(len=1) :: height_char + + file_path = '/scratch/user/troyarcomano/ML_SPEEDY_WEIGHTS/' + + write(worker_char,'(i0.4)') reservoir%assigned_region + print *, 'reservoir%assigned_region',reservoir%assigned_region + write(height_char,'(i0.1)') grid%level_index + + print *, 'reading win' + call read_netcdf_2d_dp('win',file_path//'worker_'//worker_char//'_level_'//height_char//'_win_'//trim(model_parameters%trial_name)//'.nc',reservoir%win) + + print *, 'reading wout' + call read_netcdf_2d_dp('wout',file_path//'worker_'//worker_char//'_level_'//height_char//'_wout_'//trim(model_parameters%trial_name)//'.nc',reservoir%wout) + + print *, 'reading rows',file_path//'worker_'//worker_char//'_level_'//height_char//'_rows_'//trim(model_parameters%trial_name)//'.nc' + call read_netcdf_1d_int('rows',file_path//'worker_'//worker_char//'_level_'//height_char//'_rows_'//trim(model_parameters%trial_name)//'.nc',reservoir%rows) + print *, 'reading cols',file_path//'worker_'//worker_char//'_level_'//height_char//'_cols_'//trim(model_parameters%trial_name)//'.nc' + call read_netcdf_1d_int('cols',file_path//'worker_'//worker_char//'_level_'//height_char//'_cols_'//trim(model_parameters%trial_name)//'.nc',reservoir%cols) + + call read_netcdf_1d_dp('vals',file_path//'worker_'//worker_char//'_level_'//height_char//'_vals_'//trim(model_parameters%trial_name)//'.nc',reservoir%vals) + + call read_netcdf_1d_dp('mean',file_path//'worker_'//worker_char//'_level_'//height_char//'_mean_'//trim(model_parameters%trial_name)//'.nc',grid%mean) + call read_netcdf_1d_dp('std',file_path//'worker_'//worker_char//'_level_'//height_char//'_std_'//trim(model_parameters%trial_name)//'.nc',grid%std) + +end subroutine + +end module diff --git a/src/mod_sflcon.f90 b/src/mod_sflcon.f90 new file mode 100755 index 0000000..bb7d5c9 --- /dev/null +++ b/src/mod_sflcon.f90 @@ -0,0 +1,62 @@ +module mod_sflcon + use mod_atparam + + implicit none + + private + public fwind0, ftemp0, fhum0, cdl, cds, chl, chs, vgust, ctday, dtheta,& + & fstab, hdrag, fhdrag, clambda, clambsn, forog + + ! Constants for surface fluxes + ! Ratio of near-sfc wind to lowest-level wind + real :: fwind0 = 0.95 + + ! Weight for near-sfc temperature extrapolation (0-1) : + ! 1 : linear extrapolation from two lowest levels + ! 0 : constant potential temperature ( = lowest level) + real :: ftemp0 = 1.0 + + ! Weight for near-sfc specific humidity extrapolation (0-1) : + ! 1 : extrap. with constant relative hum. ( = lowest level) + ! 0 : constant specific hum. ( = lowest level) + real :: fhum0 = 0.0 + + ! Drag coefficient for momentum over land + real :: cdl = 2.4e-3 + + ! Drag coefficient for momentum over sea + real :: cds = 1.0e-3 + + ! Heat exchange coefficient over land + real :: chl = 1.2e-3 + + ! Heat exchange coefficient over sea + real :: chs = 0.9e-3 + + ! Wind speed for sub-grid-scale gusts + real :: vgust = 5.0 + + ! Daily-cycle correction (dTskin/dSSRad) + real :: ctday = 1.0e-2 + + ! Potential temp. gradient for stability correction + real :: dtheta = 3.0 + + ! Amplitude of stability correction (fraction) + real :: fstab = 0.67 + + ! Height scale for orographic correction + real :: hdrag = 2000.0 + + ! Amplitude of orographic correction (fraction) + real :: fhdrag = 0.5 + + ! Heat conductivity in skin-to-root soil layer + real :: clambda = 7.0 + + ! Heat conductivity in soil for snow cover = 1 + real :: clambsn = 7.0 + + ! Time-invariant fields (initial. in SFLSET) + real :: forog(ix*il) +end module diff --git a/src/mod_slab_ocean_reservoir.f90 b/src/mod_slab_ocean_reservoir.f90 new file mode 100755 index 0000000..9875282 --- /dev/null +++ b/src/mod_slab_ocean_reservoir.f90 @@ -0,0 +1,1625 @@ +module mod_slab_ocean_reservoir + USE, INTRINSIC :: IEEE_ARITHMETIC + use MKL_SPBLAS + use mod_utilities, only : dp, main_type, reservoir_type, grid_type, model_parameters_type + + implicit none +contains + +subroutine initialize_slab_ocean_model(reservoir,grid,model_parameters) + !Routine to allocate the special slab ocean model reservoir and + !variables needed for that + + use resdomain, only : set_reservoir_by_region + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(inout) :: model_parameters + + integer :: nodes_per_input + + reservoir%local_predictvars = model_parameters%full_predictvars + reservoir%local_heightlevels_input = grid%inputzchunk + + reservoir%local_heightlevels_res = grid%reszchunk + + model_parameters%ml_only_ocean = .True. + + reservoir%m = 4000!6000 + + reservoir%deg = 6 + reservoir%radius = 0.9 + reservoir%beta_res = 0.0001_dp + reservoir%beta_model = 1.0_dp + reservoir%sigma = 0.6_dp !0.5_dp + + reservoir%prior_val = 0.0_dp + + reservoir%density = reservoir%deg/reservoir%m + + reservoir%noisemag = 0.10 + + reservoir%leakage = 1.0_dp!/14.0_dp !/4.0_dp !12.0_dp + + !call set_reservoir_by_region(reservoir,grid) + + reservoir%sst_bool = .True. + reservoir%sst_bool_prediction = .True. + reservoir%sst_bool_input = .True. + + reservoir%tisr_input_bool = .True. + reservoir%atmo_to_ocean_coupled = .True. + + reservoir%ohtc_input = .False. + reservoir%ohtc_prediction = .False. + + reservoir%num_atmo_levels = 1!grid%inputzchunk + + if(reservoir%sst_bool_input) then + reservoir%sst_size_res = grid%resxchunk*grid%resychunk + else + reservoir%sst_size_res = 0 + endif + + if(reservoir%sst_bool_input) then + reservoir%sst_size_input = grid%inputxchunk*grid%inputychunk + else + reservoir%sst_size_input = 0 + endif + + if(reservoir%sst_climo_input) then + reservoir%sst_climo_res = grid%inputxchunk*grid%inputychunk + else + reservoir%sst_climo_res = 0 + endif + + if(reservoir%tisr_input_bool) then + reservoir%tisr_size_res = grid%resxchunk*grid%resychunk + else + reservoir%tisr_size_res = 0 + endif + + if(reservoir%tisr_input_bool) then + reservoir%tisr_size_input = grid%inputxchunk*grid%inputychunk + else + reservoir%tisr_size_input = 0 + endif + + if(reservoir%atmo_to_ocean_coupled) then + reservoir%atmo_size_input = grid%inputxchunk*grid%inputychunk*reservoir%local_predictvars + grid%inputxchunk*grid%inputychunk!*reservoir%num_atmo_levels + grid%inputxchunk*grid%inputychunk + if(reservoir%precip_input_bool) then + print *, 'reservoir%precip_input_bool slab',reservoir%precip_input_bool + reservoir%atmo_size_input = reservoir%atmo_size_input + grid%inputxchunk*grid%inputychunk + endif + !reservoir%atmo_size_input = grid%resxchunk*grid%resychunk*reservoir%local_predictvars*reservoir%num_atmo_levels + grid%resxchunk*grid%resychunk + else + reservoir%atmo_size_input = 0 + endif + + if(reservoir%ohtc_input) then + reservoir%ohtc_input_size = grid%inputxchunk*grid%inputychunk + else + reservoir%ohtc_input_size = 0 + endif + + if(reservoir%ohtc_prediction) then + reservoir%ohtc_res_size = grid%resxchunk*grid%resychunk + else + reservoir%ohtc_res_size = 0 + endif + + + if(model_parameters%ml_only_ocean) then + reservoir%chunk_size_speedy = 0 + endif + + reservoir%chunk_size = reservoir%sst_size_res + reservoir%ohtc_res_size + + reservoir%chunk_size_prediction = reservoir%sst_size_res + reservoir%ohtc_res_size + + reservoir%locality = 0 + + reservoir%locality = reservoir%atmo_size_input + reservoir%sst_size_input + reservoir%sst_climo_res + reservoir%tisr_size_input - reservoir%chunk_size + + nodes_per_input = NINT(dble(reservoir%m)/(dble(reservoir%chunk_size)+dble(reservoir%locality))) + reservoir%n = nodes_per_input*(reservoir%chunk_size+reservoir%locality) + reservoir%k = reservoir%density*reservoir%n*reservoir%n + reservoir%reservoir_numinputs = reservoir%chunk_size+reservoir%locality + + allocate(reservoir%vals(reservoir%k)) + allocate(reservoir%win(reservoir%n,reservoir%reservoir_numinputs)) + allocate(reservoir%wout(reservoir%chunk_size_prediction,reservoir%n+reservoir%chunk_size_speedy)) + allocate(reservoir%rows(reservoir%k)) + allocate(reservoir%cols(reservoir%k)) +end subroutine + + +subroutine gen_res(reservoir) + use mod_linalg, only : mklsparse, sparse_eigen, makesparse + + type(reservoir_type) :: reservoir + + real(kind=dp) :: eigs,average + real(kind=dp), allocatable :: newvals(:) + + + print *,'makesparse' + call makesparse(reservoir) + + print *,'sparse_eigen' + call sparse_eigen(reservoir,reservoir%n*10,6,eigs) + + allocate(newvals(reservoir%k)) + newvals = (reservoir%vals/eigs)*reservoir%radius + reservoir%vals = newvals + + print *,'remake' + call mklsparse(reservoir) + + if(reservoir%assigned_region == 0) then + print *, 'region num', reservoir%assigned_region + print *, 'radius', reservoir%radius + print *, 'degree', reservoir%deg + print *, 'max res', maxval(reservoir%vals) + print *, 'min res', minval(reservoir%vals) + print *, 'average', sum(reservoir%vals)/size(reservoir%vals) + print *, 'k',reservoir%k + print *, 'eig',eigs + endif + + return +end subroutine + +subroutine train_slab_ocean_model(reservoir,grid,model_parameters) + use mod_utilities, only : init_random_seed + use resdomain, only : tile_full_input_to_target_data_ocean_model + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer :: q,i,num_inputs,j,k + integer :: un_noisy_sync + integer :: betas_res, betas_model,priors + integer :: vert_loop + + real(kind=dp), allocatable :: ip(:),rand(:),average + real(kind=dp), allocatable :: targetdata_1d(:) + real(kind=dp), allocatable :: targetdata_2d(:,:) + + character(len=:), allocatable :: base_trial_name + character(len=50) :: beta_res_char,beta_model_char,prior_char + + call gen_res(reservoir) + + q = reservoir%n/reservoir%reservoir_numinputs + + if(reservoir%assigned_region == 0) print *, 'q',q,'n',reservoir%n,'num inputs',reservoir%reservoir_numinputs + + allocate(ip(q)) + allocate(rand(q)) + + reservoir%win = 0.0_dp + + do i=1,reservoir%reservoir_numinputs + + call random_number(rand) + + ip = (-1d0 + 2*rand) + + reservoir%win((i-1)*q+1:i*q,i) = reservoir%sigma*ip + enddo + + deallocate(rand) + deallocate(ip) + + print *,'starting reservoir_layer' + + call initialize_chunk_training(reservoir,model_parameters) + + if(.not. model_parameters%ml_only_ocean) then + allocate(reservoir%imperfect_model_states(reservoir%chunk_size_prediction,size(reservoir%trainingdata,2))) + + call tile_full_input_to_target_data_ocean_model(reservoir,grid,reservoir%trainingdata(:,1:model_parameters%timestep_slab),targetdata_2d) + reservoir%imperfect_model_states(:,1:model_parameters%timestep_slab) = targetdata_2d + + deallocate(targetdata_2d) + + call tile_full_input_to_target_data_ocean_model(reservoir,grid,reservoir%trainingdata(:,1:size(reservoir%trainingdata,2)-model_parameters%timestep_slab),targetdata_2d) + reservoir%imperfect_model_states(:,model_parameters%timestep_slab+1:size(reservoir%trainingdata,2)) = targetdata_2d + + deallocate(targetdata_2d) + endif + + do i=1,model_parameters%timestep_slab + print *, 'loop number',i + !if(reservoir%assigned_region == 954) print *, 'reservoir%trainingdata(eservoir_numinputs,1:40)',reservoir%trainingdata(reservoir%reservoir_numinputs,1:40) + !if(reservoir%assigned_region == 690) print *, 'reservoir%imperfect_model_states(:,i) slab',reservoir%imperfect_model_states(:,i) + if(reservoir%assigned_region == 690) print *, 'reservoir%trainingdata(:,i) slab', reservoir%trainingdata(:,i) + if(reservoir%assigned_region == 690) print *, 'shape(reservoir%trainingdata) slab',shape(reservoir%trainingdata) + if(reservoir%assigned_region == 690) print *, 'shape(reservoir%trainingdata(:,i:model_parameters%traininglength:model_parameters%timestep_slab))',shape(reservoir%trainingdata(:,i:model_parameters%traininglength:model_parameters%timestep_slab)) + + if(reservoir%assigned_region == 690) print *, 'reservoir%trainingdata(grid_atmo%sst_start,i:model_parameters%traininglength:model_parameters%timestep_slab)',reservoir%trainingdata(grid%sst_start,i:model_parameters%traininglength:model_parameters%timestep_slab) + + if(model_parameters%ml_only_ocean) then + call reservoir_layer_chunking_ml(reservoir,model_parameters,grid,reservoir%trainingdata(:,i:model_parameters%traininglength:model_parameters%timestep_slab)) + else + call reservoir_layer_chunking_hybrid(reservoir,model_parameters,grid,reservoir%trainingdata(:,i:model_parameters%traininglength:model_parameters%timestep_slab),reservoir%imperfect_model_states(:,i:model_parameters%traininglength:model_parameters%timestep_slab)) + endif + + enddo + + + !TODO NOTE need to change this !deallocate(reservoir%trainingdata) + + if(.not. model_parameters%ml_only_ocean) then + deallocate(reservoir%imperfect_model_states) + endif + + print *, 'fitting slab',reservoir%assigned_region + + if(model_parameters%ml_only_ocean) then + call fit_chunk_ml(reservoir,model_parameters,grid) + else + call fit_chunk_hybrid(reservoir,model_parameters,grid) + endif + + print *, 'cleaning up', reservoir%assigned_region + call clean_batch(reservoir) + +end subroutine + +subroutine get_training_data_from_atmo(reservoir,model_parameters,grid,reservoir_atmo,grid_atmo) + use mod_utilities, only : rolling_average_over_a_period_2d + use mod_calendar + use speedy_res_interface, only : read_era, read_model_states + use resdomain, only : standardize_speedy_data + + type(reservoir_type), intent(inout) :: reservoir, reservoir_atmo + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid, grid_atmo + + integer :: sst_res_input_size, i, counter + real(kind=dp), allocatable :: ohtc_var(:,:,:) + + allocate(grid%mean,source=grid_atmo%mean) + allocate(grid%std, source=grid_atmo%std) + + print *, 'slab grid%mean',grid%mean + print *, 'slab grid%std', grid%std + if(reservoir_atmo%sst_bool_input) then + print *, 'atmo has sst' + reservoir%sst_bool_input = .True. + reservoir%sst_bool_prediction = .True. + else + reservoir%sst_bool_input = .False. + reservoir%sst_bool_prediction = .False. + endif + + if(reservoir%sst_bool_prediction) then + + if((reservoir_atmo%sst_climo_bool).and.(reservoir_atmo%sst_bool_prediction)) then + reservoir%sst_climo_input = .False.!.True. + else + reservoir%sst_climo_input = .False. + endif + + if(reservoir_atmo%precip_bool) then + reservoir%precip_input_bool = .False. + else + reservoir%precip_input_bool = .False. + endif + + sst_res_input_size = grid_atmo%inputxchunk*grid_atmo%inputychunk*reservoir_atmo%local_predictvars + grid_atmo%inputxchunk*grid_atmo%inputychunk + grid_atmo%inputxchunk*grid_atmo%inputychunk + grid_atmo%inputxchunk*grid_atmo%inputychunk + + print *, 'grid_atmo%sst_start,grid_atmo%sst_end',grid_atmo%sst_start,grid_atmo%sst_end + + grid%atmo3d_start = grid_atmo%atmo3d_start + grid%atmo3d_end = grid_atmo%inputxchunk*grid_atmo%inputychunk*reservoir_atmo%local_predictvars!grid_atmo%atmo3d_end + + grid%logp_start = grid%atmo3d_end + 1!grid_atmo%logp_start + grid%logp_end = grid_atmo%inputxchunk*grid_atmo%inputychunk*reservoir_atmo%local_predictvars + grid_atmo%inputxchunk*grid_atmo%inputychunk!grid_atmo%logp_end + + grid%sst_start = grid%logp_end + 1!grid_atmo%sst_start + grid%sst_end = grid%sst_start + grid_atmo%inputxchunk*grid_atmo%inputychunk - 1!grid_atmo%sst_end + + grid%tisr_start = grid%sst_end + 1 + grid%tisr_end = grid%tisr_start + grid_atmo%inputxchunk*grid_atmo%inputychunk - 1 + + grid%sst_mean_std_idx = grid_atmo%sst_mean_std_idx + + print *, 'slab grid%sst_mean_std_idx',grid%sst_mean_std_idx + print *, 'slab grid%mean(grid%sst_mean_std_idx)',grid%mean(grid%sst_mean_std_idx) + print *, 'slab grid%std(grid%sst_mean_std_idx)', grid%std(grid%sst_mean_std_idx) + + allocate(reservoir%trainingdata(sst_res_input_size,size(reservoir_atmo%trainingdata,2))) + + allocate(reservoir%atmo_training_data_idx(sst_res_input_size)) + + counter = 0 + do i=grid_atmo%atmo3d_end-grid_atmo%inputxchunk*grid_atmo%inputychunk*reservoir_atmo%local_predictvars+1,grid_atmo%logp_end + counter = counter + 1 + reservoir%atmo_training_data_idx(counter) = i + enddo + do i=grid_atmo%sst_start,grid_atmo%sst_end + counter = counter + 1 + reservoir%atmo_training_data_idx(counter) = i + enddo + do i=grid_atmo%tisr_start,grid_atmo%tisr_end + counter = counter + 1 + reservoir%atmo_training_data_idx(counter) = i + enddo + + print *, 'counter',counter + print *, 'shape(reservoir%trainingdata)',shape(reservoir%trainingdata) + print *, 'grid%atmo3d_start,grid%logp_end',grid%atmo3d_start,grid%logp_end + print *, 'tisr_end',grid%tisr_end + + reservoir%ohtc_input = .False. + if(reservoir%ohtc_input) then + call read_ohtc_parallel_training(reservoir,model_parameters,grid,ohtc_var) + endif + + reservoir%trainingdata(grid%atmo3d_start:grid%logp_end,:) = reservoir_atmo%trainingdata(grid_atmo%atmo3d_end - grid_atmo%inputxchunk*grid_atmo%inputychunk*reservoir_atmo%local_predictvars+1:grid_atmo%logp_end,:) + print *, 'grid_atmo%sst_start:grid_atmo%sst_end,',grid_atmo%sst_start,grid_atmo%sst_end + print *, '(grid%sst_start:grid%sst_end',grid%sst_start,grid%sst_end + reservoir%trainingdata(grid%sst_start:grid%sst_end,:) = reservoir_atmo%trainingdata(grid_atmo%sst_start:grid_atmo%sst_end,:) + reservoir%trainingdata(grid%tisr_start:grid%tisr_end,:) = reservoir_atmo%trainingdata(grid_atmo%tisr_start:grid_atmo%tisr_end,:) + + if(reservoir%assigned_region == 10) print *, 'before reservoir%trainingdata(grid%sst_start,1:100)',reservoir%trainingdata(grid%sst_start,1:100) + call rolling_average_over_a_period_2d(reservoir%trainingdata,model_parameters%timestep_slab) + if(reservoir%assigned_region == 10) print *, 'after reservoir%trainingdata(grid%sst_start,1:100)',reservoir%trainingdata(grid%sst_start,1:100) + !print *, 'better slab training data',reservoir%trainingdata(:,1000) + endif + + deallocate(reservoir_atmo%trainingdata) +end subroutine + +subroutine get_prediction_data_from_atmo(reservoir,model_parameters,grid,reservoir_atmo,grid_atmo,delete_atmo_data) + use mod_utilities, only : rolling_average_over_a_period_2d + use mod_calendar + use speedy_res_interface, only : read_era, read_model_states + use resdomain, only : standardize_speedy_data + + type(reservoir_type), intent(inout) :: reservoir, reservoir_atmo + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid, grid_atmo + + logical, optional :: delete_atmo_data + + integer :: atmo_ocean_tstep_ratio + integer :: num_syncs + + real(kind=dp), allocatable :: temp(:,:) + + atmo_ocean_tstep_ratio = model_parameters%timestep_slab/model_parameters%timestep + + num_syncs = size(reservoir_atmo%predictiondata(:,1:size(reservoir_atmo%predictiondata,2):atmo_ocean_tstep_ratio),2) + allocate(reservoir%predictiondata(reservoir%reservoir_numinputs,num_syncs)) + + print *, 'num_syncs',num_syncs + print *, 'size(reservoir_atmo%predictiondata,2)',size(reservoir_atmo%predictiondata,2) + print *, 'atmo_ocean_tstep_ratio',atmo_ocean_tstep_ratio + print *, 'model_parameters%timestep_slab,model_parameters%timestep',model_parameters%timestep_slab,model_parameters%timestep + + print *, 'shape(reservoir%predictiondate)',shape(reservoir%predictiondata) + print *, 'shape(reservoir_atmo%predictiondata(,1:size(reservoir_atmo%predictiondata,2):atmo_ocean_tstep_ratio))',shape(reservoir_atmo%predictiondata(grid_atmo%atmo3d_end - grid_atmo%inputxchunk*grid_atmo%inputychunk*reservoir_atmo%local_predictvars+1:grid_atmo%logp_end,1:size(reservoir_atmo%predictiondata,2):atmo_ocean_tstep_ratio)) + + !Remember reservoir_atmo%predictiondata has a time resolution of + !model_parameters%timestep so its not hourly (probably) + allocate(temp,source = reservoir_atmo%predictiondata) + call rolling_average_over_a_period_2d(temp,atmo_ocean_tstep_ratio) + + reservoir%predictiondata(grid%atmo3d_start:grid%logp_end,:) = temp(grid_atmo%atmo3d_end - grid_atmo%inputxchunk*grid_atmo%inputychunk*reservoir_atmo%local_predictvars+1:grid_atmo%logp_end,1:size(reservoir_atmo%predictiondata,2):atmo_ocean_tstep_ratio) + reservoir%predictiondata(grid%sst_start:grid%sst_end,:) = temp(grid_atmo%sst_start:grid_atmo%sst_end,1:size(reservoir_atmo%predictiondata,2):atmo_ocean_tstep_ratio) + reservoir%predictiondata(grid%tisr_start:grid%tisr_end,:) = temp(grid_atmo%tisr_start:grid_atmo%tisr_end,1:size(reservoir_atmo%predictiondata,2):atmo_ocean_tstep_ratio) + + deallocate(temp) + + print *, 'shape(reservoir%predictiondata) slab',shape(reservoir%predictiondata) + if(.not.(present(delete_atmo_data))) then + deallocate(reservoir_atmo%predictiondata) + endif +end subroutine + +subroutine get_training_data(reservoir,model_parameters,grid,loop_index) + use mod_utilities, only : era_data_type, speedy_data_type, & + standardize_data_given_pars_5d_logp_tisr, & + standardize_data_given_pars_5d_logp, & + standardize_data_given_pars5d, & + standardize_data + use mod_calendar + use speedy_res_interface, only : read_era, read_model_states + use resdomain, only : standardize_speedy_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer, intent(in) :: loop_index + + type(era_data_type) :: era_data + type(speedy_data_type) :: speedy_data + + call initialize_calendar(calendar,1990,1,1,0) + call get_current_time_delta_hour(calendar,model_parameters%discardlength+model_parameters%traininglength+model_parameters%synclength) + + print *, 'reading era states' + + !Read data in stride and whats only needed for this loop of training + call read_era(reservoir,grid,model_parameters,1990,calendar%currentyear,era_data) + + !Match units for specific humidity + era_data%eravariables(4,:,:,:,:) = era_data%eravariables(4,:,:,:,:)*1000.0_dp + where (era_data%eravariables(4,:,:,:,:) < 0.0) + era_data%eravariables(4,:,:,:,:) = 0.0_dp + end where + !print *, 'shape(era_data%eravariables)',shape(era_data%eravariables) + !print *, 'era_data',era_data%eravariables(1,:,:,:,10:11) + !Make sure tisr doesnt have zeroes + if(reservoir%tisr_input_bool) then + where(era_data%era_tisr < 0.0_dp) + era_data%era_tisr = 0.0_dp + end where + endif + + !if(reservoir%assigned_region == 954) print *, 'era_data%eravariables(4,2,2,:,1)', era_data%eravariables(4,2,2,:,1) + !if(reservoir%assigned_region == 954) print *, ' era_data%era_tisr(:,1:6)',era_data%era_tisr(4,4,1:6) + + if(reservoir%assigned_region == 690) then + print *, 'era max min temp before',maxval(era_data%eravariables(1,:,:,:,:)),minval(era_data%eravariables(1,:,:,:,:)) + print *, 'era max min u-wind before',maxval(era_data%eravariables(2,:,:,:,:)),minval(era_data%eravariables(2,:,:,:,:)) + print *, 'era max min v-wind before',maxval(era_data%eravariables(3,:,:,:,:)),minval(era_data%eravariables(3,:,:,:,:)) + print *, 'era max min sp before',maxval(era_data%eravariables(4,:,:,:,:)),minval(era_data%eravariables(4,:,:,:,:)) + if(reservoir%logp_bool) print *, 'era max min logp before',maxval(era_data%era_logp),minval(era_data%era_logp) + + if(reservoir%tisr_input_bool) print *, 'era max min tisr before',maxval(era_data%era_tisr),minval(era_data%era_tisr) + endif + !Get mean and standard deviation for the first stride of data and use those + !values for the rest of the program + if(loop_index == 1) then + !Standardize each variable using local std and mean and save the std and + !mean + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + allocate(grid%mean(reservoir%local_predictvars*reservoir%local_heightlevels_input+2),grid%std(reservoir%local_predictvars*reservoir%local_heightlevels_input+2)) + + grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+2 + grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + + call standardize_data(reservoir,era_data%eravariables,era_data%era_logp,era_data%era_tisr,grid%mean,grid%std) + elseif(reservoir%logp_bool) then + allocate(grid%mean(reservoir%local_predictvars*reservoir%local_heightlevels_input+1),grid%std(reservoir%local_predictvars*reservoir%local_heightlevels_input+1)) + grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + + call standardize_data(reservoir,era_data%eravariables,era_data%era_logp,grid%mean,grid%std) + elseif(reservoir%tisr_input_bool) then + allocate(grid%mean(reservoir%local_predictvars*reservoir%local_heightlevels_input+1),grid%std(reservoir%local_predictvars*reservoir%local_heightlevels_input+1)) + + grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + + call standardize_data(reservoir,era_data%eravariables,era_data%era_tisr,grid%mean,grid%std) + else + allocate(grid%mean(reservoir%local_predictvars*reservoir%local_heightlevels_input),grid%std(reservoir%local_predictvars*reservoir%local_heightlevels_input)) + call standardize_data(reservoir,era_data%eravariables,grid%mean,grid%std) + endif + else + !Standardize the data from the first stride's std and mean + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + call standardize_data_given_pars_5d_logp_tisr(grid%mean,grid%std,era_data%eravariables,era_data%era_logp,era_data%era_tisr) + elseif(reservoir%logp_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_logp) + elseif(reservoir%tisr_input_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_tisr) + else + call standardize_data_given_pars5d(grid%mean,grid%std,era_data%eravariables) + endif + endif + + if(reservoir%assigned_region == 954) then + print *, 'era max min temp after',maxval(era_data%eravariables(1,:,:,:,:)),minval(era_data%eravariables(1,:,:,:,:)) + print *, 'era max min u-wind after',maxval(era_data%eravariables(2,:,:,:,:)),minval(era_data%eravariables(2,:,:,:,:)) + print *, 'era max min v-wind after',maxval(era_data%eravariables(3,:,:,:,:)),minval(era_data%eravariables(3,:,:,:,:)) + print *, 'era max min sp after',maxval(era_data%eravariables(4,:,:,:,:)),minval(era_data%eravariables(4,:,:,:,:)) + if(reservoir%logp_bool) print *, 'era max min logp after',maxval(era_data%era_logp),minval(era_data%era_logp) + + if(reservoir%tisr_input_bool) print *, 'era max min tisr after',maxval(era_data%era_tisr),minval(era_data%era_tisr) + print *, 'res%mean,res%std',grid%mean,grid%std + endif + !Lets get some training data + allocate(reservoir%trainingdata(reservoir%reservoir_numinputs,size(era_data%eravariables,5))) + + print *, 'reservoir%reservoir_numinputs',reservoir%assigned_region,grid%level_index + reservoir%trainingdata(1:reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk,:) = reshape(era_data%eravariables,(/reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk,size(era_data%eravariables,5)/)) + + if(reservoir%logp_bool) then + reservoir%trainingdata(reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk+1:reservoir%reservoir_numinputs-reservoir%tisr_size_input,:) = reshape(era_data%era_logp,(/grid%inputxchunk*grid%inputychunk,size(era_data%eravariables,5)/)) + endif + + if(reservoir%tisr_input_bool) then + reservoir%trainingdata(reservoir%reservoir_numinputs-reservoir%tisr_size_input+1:reservoir%reservoir_numinputs,:) = reshape(era_data%era_tisr,(/grid%inputxchunk*grid%inputychunk,size(era_data%eravariables,5)/)) + endif + + print *, 'reservoir%trainingdata(:,500)',reservoir%trainingdata(:,500) + + + deallocate(era_data%eravariables) + deallocate(era_data%era_logp) + + if(allocated(era_data%era_tisr)) then + deallocate(era_data%era_tisr) + endif + + !Portion of the routine for getting speedy (imperfect model) data + print *, 'reading model states' + call read_model_states(reservoir,grid,model_parameters,1990,calendar%currentyear,speedy_data) + + !Lets get imperfect model states + where(speedy_data%speedyvariables(4,:,:,:,:) < 0.0) + speedy_data%speedyvariables(4,:,:,:,:) = 0.0_dp + end where + + if(reservoir%assigned_region == 954) then + print *, 'speedy max min temp',maxval(speedy_data%speedyvariables(1,:,:,:,:)),minval(speedy_data%speedyvariables(1,:,:,:,:)) + print *, 'speedy max min u-wind',maxval(speedy_data%speedyvariables(2,:,:,:,:)),minval(speedy_data%speedyvariables(2,:,:,:,:)) + print *, 'speedy max min v-wind',maxval(speedy_data%speedyvariables(3,:,:,:,:)),minval(speedy_data%speedyvariables(3,:,:,:,:)) + print *, 'speedy max min sp',maxval(speedy_data%speedyvariables(4,:,:,:,:)),minval(speedy_data%speedyvariables(4,:,:,:,:)) + if(reservoir%logp_bool) print *, 'speedy max min logp',maxval(speedy_data%speedy_logp),minval(speedy_data%speedy_logp) + + print *, 'res%mean,res%std',grid%mean, grid%std + endif + + if(reservoir%assigned_region == 954) print *, 'speedy_data%speedyvariables(:,1,1,1,1)',speedy_data%speedyvariables(:,1,1,1,1) + + call standardize_speedy_data(reservoir,grid,speedy_data) + + if(reservoir%assigned_region == 954) print *, 'speedy_data%speedyvariables(:,1,1,1,1) after',speedy_data%speedyvariables(:,1,1,1,1) + allocate(reservoir%imperfect_model_states(reservoir%chunk_size_prediction,size(speedy_data%speedyvariables,5))) + reservoir%imperfect_model_states = 0.0_dp + + reservoir%imperfect_model_states(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,:) = reshape(speedy_data%speedyvariables,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,size(speedy_data%speedyvariables,5)/)) + + if(reservoir%logp_bool) then + reservoir%imperfect_model_states(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk+1:reservoir%chunk_size_prediction,:) = reshape(speedy_data%speedy_logp,(/grid%resxchunk*grid%resychunk,size(speedy_data%speedyvariables,5)/)) + endif + + deallocate(speedy_data%speedyvariables) + deallocate(speedy_data%speedy_logp) +end subroutine + +subroutine get_prediction_data(reservoir,model_parameters,grid,start_index,length) + use mod_utilities, only : era_data_type, speedy_data_type, & + standardize_data_given_pars_5d_logp_tisr, & + standardize_data_given_pars_5d_logp, & + standardize_data_given_pars5d, & + standardize_data + use mod_calendar + use speedy_res_interface, only : read_era, read_model_states + use resdomain, only : standardize_speedy_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer, intent(in) :: start_index,length + + integer :: hours_into_first_year, start_year + integer :: start_time_memory_index, end_time_memory_index + + type(era_data_type) :: era_data + type(speedy_data_type) :: speedy_data + + call get_current_time_delta_hour(calendar,start_index) + + call numof_hours_into_year(calendar%currentyear,calendar%currentmonth,calendar%currentday,calendar%currenthour,hours_into_first_year) + + start_year = calendar%currentyear + + call get_current_time_delta_hour(calendar,start_index+length) + + !Read data in stride and whats only needed for this loop of training + call read_era(reservoir,grid,model_parameters,start_year,calendar%currentyear,era_data,1) + + start_time_memory_index = hours_into_first_year + end_time_memory_index = start_time_memory_index + length + + !Match units for specific humidity + era_data%eravariables(4,:,:,:,:) = era_data%eravariables(4,:,:,:,:)*1000.0_dp + + where (era_data%eravariables(4,:,:,:,:) < 0.0) + era_data%eravariables(4,:,:,:,:) = 0.0_dp + end where + + !Make sure tisr doesnt have zeroes + if(reservoir%tisr_input_bool) then + where(era_data%era_tisr < 0.0_dp) + era_data%era_tisr = 0.0_dp + end where + endif + + !Standardize the data from mean and std of training data + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + call standardize_data_given_pars_5d_logp_tisr(grid%mean,grid%std,era_data%eravariables,era_data%era_logp,era_data%era_tisr) + elseif(reservoir%logp_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_logp) + elseif(reservoir%tisr_input_bool) then + call standardize_data_given_pars_5d_logp(grid%mean,grid%std,era_data%eravariables,era_data%era_tisr) + else + call standardize_data_given_pars5d(grid%mean,grid%std,era_data%eravariables) + endif + + + if(allocated(reservoir%predictiondata)) then + deallocate(reservoir%predictiondata) + endif + + !Lets get some prediction data + allocate(reservoir%predictiondata(reservoir%reservoir_numinputs,length/model_parameters%timestep_slab)) + + reservoir%predictiondata(1:reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk,:) = reshape(era_data%eravariables(:,:,:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep_slab),[reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk,length/model_parameters%timestep_slab]) + + if(reservoir%logp_bool) then + reservoir%predictiondata(reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk+1:reservoir%reservoir_numinputs-reservoir%tisr_size_input,:) = reshape(era_data%era_logp(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep_slab),[grid%inputxchunk*grid%inputychunk,length/model_parameters%timestep_slab]) + endif + + if(reservoir%tisr_input_bool) then + reservoir%predictiondata(reservoir%reservoir_numinputs-reservoir%tisr_size_input+1:reservoir%reservoir_numinputs,:) = reshape(era_data%era_tisr(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep),[grid%inputxchunk*grid%inputychunk,length/model_parameters%timestep]) + endif + + deallocate(era_data%eravariables) + deallocate(era_data%era_logp) + + if(allocated(era_data%era_tisr)) then + deallocate(era_data%era_tisr) + endif + + !Portion of the routine for getting speedy (imperfect model) data + print *, 'reading model states' + call read_model_states(reservoir,grid,model_parameters,start_year,calendar%currentyear,speedy_data,1) + + !Lets get imperfect model states + where(speedy_data%speedyvariables(4,:,:,:,:) < 0.0) + speedy_data%speedyvariables(4,:,:,:,:) = 0.0_dp + end where + + call standardize_speedy_data(reservoir,grid,speedy_data) + + if(allocated(reservoir%imperfect_model_states)) then + deallocate(reservoir%imperfect_model_states) + endif + + allocate(reservoir%imperfect_model_states(reservoir%chunk_size_prediction,length/model_parameters%timestep_slab)) + + reservoir%imperfect_model_states = 0.0_dp + + reservoir%imperfect_model_states(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,:) = reshape(speedy_data%speedyvariables(:,:,:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep_slab),[reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk,length/model_parameters%timestep_slab]) + + if(reservoir%logp_bool) then + reservoir%imperfect_model_states(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*grid%reszchunk+1:reservoir%chunk_size_prediction,:) = reshape(speedy_data%speedy_logp(:,:,start_time_memory_index:end_time_memory_index:model_parameters%timestep_slab),[grid%resxchunk*grid%resychunk,length/model_parameters%timestep_slab]) + endif + deallocate(speedy_data%speedyvariables) + deallocate(speedy_data%speedy_logp) +end subroutine + +subroutine initialize_prediction_slab(reservoir,model_parameters,grid,atmo_reservoir,atmo_grid) + use mod_calendar + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(reservoir_type), intent(inout) :: atmo_reservoir + type(grid_type), intent(inout) :: atmo_grid + + type(model_parameters_type), intent(inout) :: model_parameters + + integer :: q,i,num_inputs,j,k + integer :: un_noisy_sync + integer :: betas_res, betas_model,priors + integer :: vert_loop + + real(kind=dp), allocatable :: ip(:),rand(:),average + real(kind=dp), allocatable :: test_beta_res(:), test_beta_model(:), test_priors(:) + real(kind=dp), allocatable :: states_x_states_original_copy(:,:) + + character(len=:), allocatable :: base_trial_name + character(len=50) :: beta_res_char,beta_model_char,prior_char + + !Try syncing on un-noisy data + if(.not.(allocated(reservoir%saved_state))) allocate(reservoir%saved_state(reservoir%n)) + reservoir%saved_state = 0 + un_noisy_sync = 2160!700 + + !From this point on reservoir%trainingdata and reservoir%imperfect_model have a temporal resolution model_parameters%timestep_slab + !instead of 1 hour resolution and atmo_reservoir%trainingdata has a temporal + !resolution model_parameters%timestep + call get_prediction_data_from_atmo(reservoir,model_parameters,grid,atmo_reservoir,atmo_grid) + + call synchronize(reservoir,reservoir%predictiondata,reservoir%saved_state,un_noisy_sync/(model_parameters%timestep_slab)-1) + + if(reservoir%tisr_input_bool) then + allocate(reservoir%full_tisr,source=atmo_reservoir%full_tisr) + endif + + deallocate(reservoir%predictiondata) + + allocate(reservoir%local_model(reservoir%chunk_size_prediction)) + allocate(reservoir%outvec(reservoir%chunk_size_prediction)) + allocate(reservoir%feedback(reservoir%reservoir_numinputs)) + allocate(reservoir%averaged_atmo_input_vec(reservoir%reservoir_numinputs,model_parameters%timestep_slab/model_parameters%timestep-1)) + reservoir%averaged_atmo_input_vec = 0.0_dp +end subroutine + +subroutine get_full_tisr(reservoir,model_parameters,grid) + use mpires, only : mpi_res + use mod_io, only : read_3d_file_parallel + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(inout) :: model_parameters + + character(len=:), allocatable :: file_path + character(len=:), allocatable :: tisr_file + + file_path = '/scratch/user/troyarcomano/ERA_5/2012/' + tisr_file = file_path//'toa_incident_solar_radiation_2012_regridded_classic4.nc' + + call read_3d_file_parallel(tisr_file,'tisr',mpi_res,grid,reservoir%full_tisr,1,1) + +end subroutine + +subroutine start_prediction_slab(reservoir,model_parameters,grid,atmo_reservoir,atmo_grid,prediction_number) + use resdomain, only : tile_full_input_to_target_data_ocean_model + + type(reservoir_type), intent(inout) :: reservoir, atmo_reservoir + type(grid_type), intent(inout) :: grid, atmo_grid + type(model_parameters_type), intent(inout) :: model_parameters + + integer, intent(in) :: prediction_number + + model_parameters%current_trial_number = prediction_number + + call get_prediction_data_from_atmo(reservoir,model_parameters,grid,atmo_reservoir,atmo_grid,.False.) + + call synchronize(reservoir,reservoir%predictiondata(:,1:model_parameters%synclength/model_parameters%timestep_slab),reservoir%saved_state,model_parameters%synclength/model_parameters%timestep_slab) + + print *, 'model_parameters%synclength/model_parameters%timestep_slab',model_parameters%synclength/model_parameters%timestep_slab + print *, 'shape(reservoir%predictiondata)',shape(reservoir%predictiondata) + reservoir%feedback = reservoir%predictiondata(:,model_parameters%synclength/model_parameters%timestep_slab) + + !This is a trick so that we can store the last sst era5 data for plotting + !when the hybrid model intergration step is less than the slab_timestep + !e.g. the first x days of whole model sst are those from the era5 data where + !x == model_parameters%timestep_slab + call tile_full_input_to_target_data_ocean_model(reservoir,grid,reservoir%predictiondata(:,model_parameters%synclength/model_parameters%timestep_slab),reservoir%outvec) + + reservoir%outvec = reservoir%outvec*grid%std(grid%sst_mean_std_idx) + grid%mean(grid%sst_mean_std_idx) + + if(.not. model_parameters%ml_only_ocean) then + call tile_full_input_to_target_data_ocean_model(reservoir,grid,reservoir%predictiondata(:,model_parameters%synclength/model_parameters%timestep_slab),reservoir%local_model) + print *, 'start_prediction_slab local_model',reservoir%local_model + endif +end subroutine + +subroutine reservoir_layer_chunking_ml(reservoir,model_parameters,grid,trainingdata) + use mpires + use mod_utilities, only : gaussian_noise_1d_function + + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type) , intent(in) :: model_parameters + type(grid_type) , intent(in) :: grid + + real(kind=dp), intent(in) :: trainingdata(:,:) + + integer :: i,info + integer :: training_length, batch_number + + real(kind=dp), allocatable :: temp(:),x(:),y(:),x_(:) + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + real(kind=dp), allocatable :: gaussian_noise + + allocate(temp(reservoir%n),x(reservoir%n),x_(reservoir%n),y(reservoir%n)) + + x = 0 + y = 0 + do i=1, model_parameters%discardlength/model_parameters%timestep_slab + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + print *, 'shape(reservoir%win)',shape(reservoir%win),'shape(trainingdata(:,i))',shape(trainingdata(:,i)), 'worker',reservoir%assigned_region + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,i),reservoir%noisemag)) + + x_ = tanh(y+temp) + + x = (1_dp-reservoir%leakage)*x + reservoir%leakage*x_ + + y = 0 + enddo + + !call initialize_chunk_training() + + reservoir%states(:,1) = x + batch_number = 0 + + training_length = size(trainingdata,2) - model_parameters%discardlength/model_parameters%timestep_slab + + do i=1, training_length-1 + if(reservoir%assigned_region == 1) print *, 'i',i,'batch size',reservoir%batch_size, 'training_length-1',training_length-1,'ize(trainingdata,2)',size(trainingdata,2) + if(mod(i+1,reservoir%batch_size).eq.0) then + print *,'chunking slab',i,'region',reservoir%assigned_region + batch_number = batch_number + 1 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep_slab+i),reservoir%noisemag)) + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,reservoir%batch_size) = x + + reservoir%saved_state = reservoir%states(:,reservoir%batch_size) + + reservoir%states(2:reservoir%n:2,:) = reservoir%states(2:reservoir%n:2,:)**2 + + call chunking_matmul_ml(reservoir,model_parameters,grid,batch_number,trainingdata) + + elseif (mod(i,reservoir%batch_size).eq.0) then + print *,'new state',i, 'region',reservoir%assigned_region + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,reservoir%batch_size),beta,y) + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep_slab+i),reservoir%noisemag)) + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,1) = x + else + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep_slab+i),reservoir%noisemag)) + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,mod(i+1,reservoir%batch_size)) = x + endif + + y = 0 + enddo + + return +end subroutine + +subroutine reservoir_layer_chunking_hybrid(reservoir,model_parameters,grid,trainingdata,imperfect_model) + use mpires + use mod_utilities, only : gaussian_noise_1d_function,gaussian_noise_1d_function_precip + + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type) , intent(in) :: model_parameters + type(grid_type) , intent(in) :: grid + + real(kind=dp), intent(in) :: trainingdata(:,:) + real(kind=dp), intent(in) :: imperfect_model(:,:) + + integer :: i,info + integer :: training_length, batch_number + + real(kind=dp), allocatable :: temp(:), x(:), x_(:), y(:) + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + real(kind=dp), allocatable :: gaussian_noise + + allocate(temp(reservoir%n),x(reservoir%n),x_(reservoir%n),y(reservoir%n)) + + x = 0 + y = 0 + do i=1, model_parameters%discardlength/model_parameters%timestep + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1_dp-reservoir%leakage)*x + reservoir%leakage*x_ + + y = 0 + enddo + + !call initialize_chunk_training() + + reservoir%states(:,1) = x + batch_number = 0 + + training_length = size(trainingdata,2) - model_parameters%discardlength/model_parameters%timestep + + do i=1, training_length-1 + if(mod(i+1,reservoir%batch_size).eq.0) then + print *,'chunking',i, 'region',reservoir%assigned_region + batch_number = batch_number + 1 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,reservoir%batch_size) = x + + reservoir%saved_state = reservoir%states(:,reservoir%batch_size) + + reservoir%states(2:reservoir%n:2,:) = reservoir%states(2:reservoir%n:2,:)**2 + + call chunking_matmul_hybrid(reservoir,model_parameters,grid,batch_number,trainingdata,imperfect_model) + + elseif (mod(i,reservoir%batch_size).eq.0) then + print *,'new state',i, 'region',reservoir%assigned_region + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%saved_state,beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,1) = x + else + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,reservoir%states(:,mod(i,reservoir%batch_size)),beta,y) + + if(model_parameters%precip_bool) then + temp = matmul(reservoir%win,gaussian_noise_1d_function_precip(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag,grid,model_parameters)) + else + temp = matmul(reservoir%win,gaussian_noise_1d_function(trainingdata(:,model_parameters%discardlength/model_parameters%timestep+i),reservoir%noisemag)) + endif + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + reservoir%states(:,mod(i+1,reservoir%batch_size)) = x + endif + + y = 0 + enddo + + return +end subroutine + +subroutine fit_chunk_ml(reservoir,model_parameters,grid) + !This solves for Wout using least squared solver for the ml only version + !This should be called only if you are chunking the training + !There is an option to train using a Prior + !The prior would try to force the weights of Wout + !for the numerical model to be near reservoir%prior_val + + use mod_linalg, only : pinv_svd, mldivide + use mpires + use mod_io, only : write_netcdf_2d_non_met_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer :: i + + real(kind=dp), allocatable :: a_trans(:,:), b_trans(:,:), invstates(:,:) + real(kind=dp), allocatable :: prior(:,:), temp_beta(:,:) + + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + character(len=2) :: level_char + + !Do regularization + + do i=1, reservoir%n + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_res + enddo + + !NOTE moving to mldivide not using pinv anymore + print *, 'trying mldivide' + allocate(a_trans(size(reservoir%states_x_states_aug,2),size(reservoir%states_x_states_aug,1))) + allocate(b_trans(size(reservoir%states_x_trainingdata_aug,2),size(reservoir%states_x_trainingdata_aug,1))) + a_trans = transpose(reservoir%states_x_states_aug) + b_trans = transpose(reservoir%states_x_trainingdata_aug) + + if(reservoir%assigned_region == 954) print *, 'a_trans(1:20,1:20)',a_trans(1:4,1:4) + if(reservoir%assigned_region == 954) print *, 'b_trans(1:20,1:20)',b_trans(1:4,1:4) + + call mldivide(a_trans,b_trans) + reservoir%wout = transpose(b_trans) + + if(reservoir%assigned_region == 954) print *, 'worker',reservoir%assigned_region,'wout(1,1:20)',reservoir%wout(1,1:20) + + deallocate(a_trans) + deallocate(b_trans) + + write(level_char,'(i0.2)') grid%level_index + if(reservoir%assigned_region == 954) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_954_ocean_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 217) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_217_ocean_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 218) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_218_ocean_'//level_char//'wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + + !call write_trained_res(reservoir,model_parameters,grid) + + print *, 'finish fit' +end subroutine + +subroutine fit_chunk_hybrid(reservoir,model_parameters,grid) + !This solves for Wout using least squared solver + !This should be called only if you are chunking the training + !There is an option to train using a Prior + !The prior would try to force the weights of Wout + !for the numerical model to be near reservoir%prior_val + + use mod_linalg, only : pinv_svd, mldivide + use mpires + use mod_io, only : write_netcdf_2d_non_met_data + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(inout) :: model_parameters + type(grid_type), intent(inout) :: grid + + integer :: i + + real(kind=dp), allocatable :: a_trans(:,:), b_trans(:,:), invstates(:,:) + real(kind=dp), allocatable :: prior(:,:), temp_beta(:,:) + + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + character(len=2) :: level_char + + + + !If we have a prior we need to make the prior matrix + if(model_parameters%using_prior) then + allocate(prior(size(reservoir%states_x_trainingdata_aug,1),size(reservoir%states_x_trainingdata_aug,2))) + + prior = 0.0_dp + + do i=1, reservoir%chunk_size_prediction + prior(i,i) = reservoir%prior_val*reservoir%beta_model**2.0_dp + enddo + + endif + + !Do regularization + + !If we are doing a prior we need beta^2 + if(model_parameters%using_prior) then + do i=1, reservoir%n+reservoir%chunk_size_prediction + if(i <= reservoir%chunk_size_prediction) then + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_model**2.0_dp + else + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_res**2.0_dp + endif + enddo + else + do i=1, reservoir%n+reservoir%chunk_size_prediction + if(i <= reservoir%chunk_size_prediction) then + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_model + else + reservoir%states_x_states_aug(i,i) = reservoir%states_x_states_aug(i,i) + reservoir%beta_res + endif + enddo + endif + + !NOTE moving to mldivide not using pinv anymore + print *, 'trying mldivide' + allocate(a_trans(size(reservoir%states_x_states_aug,2),size(reservoir%states_x_states_aug,1))) + allocate(b_trans(size(reservoir%states_x_trainingdata_aug,2),size(reservoir%states_x_trainingdata_aug,1))) + a_trans = transpose(reservoir%states_x_states_aug) + b_trans = transpose(reservoir%states_x_trainingdata_aug) + + if(reservoir%assigned_region == 690) print *, 'slab a_trans(1:4,1:4)',a_trans(1:4,1:4) + if(reservoir%assigned_region == 690) print *, 'slab b_trans(1:4,1:4)',b_trans(1:4,1:4) + if(any(IEEE_IS_NAN(reservoir%states_x_states_aug))) print *, 'reservoir%states_x_states_aug nan', reservoir%assigned_region + if(any(IEEE_IS_NAN(reservoir%states_x_trainingdata_aug))) print *, 'reservoir%states_x_states_aug nan', reservoir%assigned_region + if(any(IEEE_IS_NAN(a_trans))) print *, 'a_trans has nan',reservoir%assigned_region + if(any(IEEE_IS_NAN(b_trans))) print *, 'b_trans has nan',reservoir%assigned_region + + !If we are trying a prior then we need to add it to b_trans + if(model_parameters%using_prior) then + b_trans = b_trans + transpose(prior) + endif + + call mldivide(a_trans,b_trans) + reservoir%wout = transpose(b_trans) + + if(any(IEEE_IS_NAN(reservoir%wout))) print *, 'wout has nan', reservoir%assigned_region + if(IEEE_IS_NAN(reservoir%wout(1,1))) print *, 'wout element 1 has nan', reservoir%assigned_region + + + if(reservoir%assigned_region == 690) print *, 'worker',reservoir%assigned_region,'slab wout(1,1:4)',reservoir%wout(1,1:4) + + deallocate(a_trans) + deallocate(b_trans) + + write(level_char,'(i0.2)') grid%level_index + if(reservoir%assigned_region == 690) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_690_slab_ocean_wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 217) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_217_slab_ocean_wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + if(reservoir%assigned_region == 218) call write_netcdf_2d_non_met_data(reservoir%wout,'wout','region_218_slab_ocean_wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + + !call write_trained_res(reservoir,model_parameters,grid) + + print *, 'finish fit' +end subroutine + +subroutine predictcontroller(reservoir,model_parameters,grid,imperfect_model_in) + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: imperfect_model_in(:) + + real(kind=dp), allocatable :: x(:) + + allocate(x(reservoir%n)) + + x = reservoir%saved_state + + call synchronize(reservoir,reservoir%predictiondata(:,1:model_parameters%synclength/model_parameters%timestep_slab),x,model_parameters%synclength/model_parameters%timestep_slab) + + call predict_slab(reservoir,model_parameters,grid,x,imperfect_model_in) +end subroutine + +subroutine synchronize(reservoir,input,x,length) + type(reservoir_type), intent(inout) :: reservoir + + real(kind=dp), intent(in) :: input(:,:) + real(kind=dp), intent(inout) :: x(:) + + integer, intent(in) :: length + + real(kind=dp), allocatable :: y(:), temp(:), x_(:) + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + + integer :: info,i + + allocate(y(reservoir%n)) + allocate(temp(reservoir%n)) + allocate(x_(reservoir%n)) + + y=0 + do i=1, length + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + + temp = matmul(reservoir%win,input(:,i)) + + x_ = tanh(y+temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + enddo + + return +end subroutine + +subroutine predict_slab(reservoir,model_parameters,grid,x,local_model_in) + use mpires, only : predictionmpicontroller + use resdomain, only : unstandardize_state_vec_res + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: x(:) + real(kind=dp), intent(inout) :: local_model_in(:) + + real(kind=dp), allocatable :: y(:), temp(:) + real(kind=dp), allocatable :: local_model_temp(:) + real(kind=dp), allocatable :: x_temp(:),x_augment(:) + + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + + integer :: info,i,j + + allocate(y(reservoir%n),temp(reservoir%n)) + allocate(x_augment(reservoir%n+reservoir%chunk_size_prediction)) + + y = 0 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + temp = matmul(reservoir%win,reservoir%feedback) + + x = tanh(y + temp) + + x_temp = x + x_temp(2:reservoir%n:2) = x_temp(2:reservoir%n:2)**2 + + x_augment(1:reservoir%chunk_size_prediction) = reservoir%local_model + x_augment(reservoir%chunk_size_prediction+1:reservoir%chunk_size_prediction+reservoir%n) = x_temp + + reservoir%outvec = matmul(reservoir%wout,x_augment) + reservoir%local_model = reservoir%outvec + !call unstandardize_state_vec_res(reservoir,grid,reservoir%outvec) + reservoir%outvec = reservoir%outvec*grid%std(grid%sst_mean_std_idx) + grid%mean(grid%sst_mean_std_idx) + + if((reservoir%assigned_region == 954).and.(mod(i,14*24) == 0)) then + print *, '*******' + print *, 'reservoir%predictiondata(grid%sst_start:grid%sst_end,model_parameters%synclength/model_parameters%timestep_slab+10)',reservoir%predictiondata(grid%sst_start:grid%sst_end,model_parameters%synclength/model_parameters%timestep_slab+10) + print *, 'local_model slab region', reservoir%assigned_region, reservoir%local_model + print *, 'outvec slab region', reservoir%assigned_region, reservoir%outvec + print *, '*******' + print *, 'slab feedback',reservoir%feedback + endif +end subroutine + +subroutine predict_slab_ml(reservoir,model_parameters,grid,x) + use mpires, only : predictionmpicontroller + use resdomain, only : unstandardize_state_vec_res + use mod_utilities, only : e_constant + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: x(:) + + real(kind=dp), allocatable :: y(:), temp(:), x_(:) + real(kind=dp), allocatable :: x_temp(:),x_augment(:) + + real(kind=dp), parameter :: alpha=1.0,beta=0.0 + + integer :: info,i,j + + allocate(y(reservoir%n),temp(reservoir%n),x_(reservoir%n)) + allocate(x_augment(reservoir%n))!reservoir%chunk_size_prediction)) + + y = 0 + + info = MKL_SPARSE_D_MV(SPARSE_OPERATION_NON_TRANSPOSE,alpha,reservoir%cooA,reservoir%descrA,x,beta,y) + temp = matmul(reservoir%win,reservoir%feedback) + + x_ = tanh(y + temp) + x = (1-reservoir%leakage)*x + reservoir%leakage*x_ + + x_temp = x + x_temp(2:reservoir%n:2) = x_temp(2:reservoir%n:2)**2 + + x_augment(1:reservoir%n) = x_temp + + reservoir%outvec = matmul(reservoir%wout,x_augment) + + reservoir%outvec = reservoir%outvec*grid%std(grid%sst_mean_std_idx) + grid%mean(grid%sst_mean_std_idx) + + if((reservoir%assigned_region == 954).and.(mod(i,14*24) == 0)) then + print *, '*******' + print *, 'reservoir%predictiondata(grid%sst_start:grid%sst_end,model_parameters%synclength/model_parameters%timestep_slab+10)',reservoir%predictiondata(grid%sst_start:grid%sst_end,model_parameters%synclength/model_parameters%timestep_slab+10) + print *, 'outvec slab region', reservoir%assigned_region, reservoir%outvec + print *, '*******' + print *, 'slab feedback',reservoir%feedback + endif +end subroutine + +subroutine clean_sparse(reservoir) + type(reservoir_type), intent(inout) :: reservoir + + deallocate(reservoir%vals) + deallocate(reservoir%rows) + deallocate(reservoir%cols) +end subroutine + +subroutine clean_batch(reservoir) + type(reservoir_type), intent(inout) :: reservoir + + deallocate(reservoir%states_x_trainingdata_aug) + deallocate(reservoir%states_x_states_aug) +end subroutine + +subroutine clean_prediction(reservoir) + type(reservoir_type), intent(inout) :: reservoir + + deallocate(reservoir%local_model) + deallocate(reservoir%outvec) + deallocate(reservoir%feedback) + +end subroutine + +subroutine initialize_chunk_training(reservoir,model_parameters) + use mod_utilities, only : find_closest_divisor + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + + integer :: num_of_batches !the number of chunks we want + integer :: approx_batch_size !approximate size of the batch + + num_of_batches = 1!*2!2 !20*6 + approx_batch_size = (model_parameters%traininglength - model_parameters%discardlength)/(num_of_batches*model_parameters%timestep_slab) + + !routine to get the closest reservoir%batch_size to num_of_batches that + !divides into reservoir%traininglength + call find_closest_divisor(approx_batch_size,(model_parameters%traininglength - model_parameters%discardlength)/model_parameters%timestep_slab,reservoir%batch_size) + print *, 'num_of_batches,reservoir%traininglength,reservoir%batch_size slab',num_of_batches,model_parameters%traininglength,reservoir%batch_size + + !Should be reservoir%n+ reservoir%chunk_size + allocate(reservoir%states_x_trainingdata_aug(reservoir%chunk_size_prediction,reservoir%n+reservoir%chunk_size_speedy)) + allocate(reservoir%states_x_states_aug(reservoir%n+reservoir%chunk_size_speedy,reservoir%n+reservoir%chunk_size_speedy)) + allocate(reservoir%states(reservoir%n,reservoir%batch_size)) + allocate(reservoir%augmented_states(reservoir%n+reservoir%chunk_size_speedy,reservoir%batch_size)) + allocate(reservoir%saved_state(reservoir%n)) + + reservoir%states_x_trainingdata_aug = 0.0_dp + reservoir%states_x_states_aug = 0.0_dp + reservoir%states = 0.0_dp + reservoir%augmented_states = 0.0_dp + +end subroutine + +subroutine chunking_matmul_ml(reservoir,model_parameters,grid,batch_number,trainingdata) + use mod_utilities, only : gaussian_noise + use resdomain, only : tile_full_input_to_target_data_ocean_model + use mpires + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + integer, intent(in) :: batch_number + + real(kind=dp), intent(in) :: trainingdata(:,:) + + real(kind=dp), allocatable :: temp(:,:), targetdata(:,:) + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + integer :: n, m, l + + n = size(reservoir%augmented_states,1) + m = size(reservoir%augmented_states,2) + + reservoir%augmented_states(1:reservoir%n,:) = reservoir%states + + call tile_full_input_to_target_data_ocean_model(reservoir,grid,trainingdata(:,model_parameters%discardlength/model_parameters%timestep_slab+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep_slab),targetdata) + + allocate(temp(reservoir%chunk_size_prediction,n)) + temp = 0.0_dp + + temp = matmul(targetdata,transpose(reservoir%augmented_states)) + !TODO make this matmul DGEMM + + reservoir%states_x_trainingdata_aug = reservoir%states_x_trainingdata_aug + temp + + deallocate(temp) + deallocate(targetdata) + + allocate(temp(n,n)) + + call DGEMM('N','N',n,n,m,alpha,reservoir%augmented_states,n,transpose(reservoir%augmented_states),m,beta,temp,n) + reservoir%states_x_states_aug = reservoir%states_x_states_aug + temp + + deallocate(temp) + + return +end subroutine + +subroutine chunking_matmul_hybrid(reservoir,model_parameters,grid,batch_number,trainingdata,imperfect_model) + use mod_utilities, only : gaussian_noise + use resdomain, only : tile_full_input_to_target_data_ocean_model + use mpires + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + integer, intent(in) :: batch_number + + real(kind=dp), intent(in) :: trainingdata(:,:) + real(kind=dp), intent(in) :: imperfect_model(:,:) + + real(kind=dp), allocatable :: temp(:,:), targetdata(:,:) + real(kind=dp), parameter :: alpha=1.0, beta=0.0 + + integer :: n, m, l + + n = size(reservoir%augmented_states,1) + m = size(reservoir%augmented_states,2) + + reservoir%augmented_states(1:reservoir%chunk_size_prediction,:) = imperfect_model(:,model_parameters%discardlength/model_parameters%timestep_slab+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep_slab) + reservoir%augmented_states(reservoir%chunk_size_prediction+1:reservoir%n+reservoir%chunk_size_prediction,:) = reservoir%states + + call tile_full_input_to_target_data_ocean_model(reservoir,grid,trainingdata(:,model_parameters%discardlength/model_parameters%timestep_slab+(batch_number-1)*m+1:batch_number*m+model_parameters%discardlength/model_parameters%timestep_slab),targetdata) + + allocate(temp(reservoir%chunk_size_prediction,n)) + temp = 0.0_dp + + temp = matmul(targetdata,transpose(reservoir%augmented_states)) + !TODO make this matmul DGEMM + + reservoir%states_x_trainingdata_aug = reservoir%states_x_trainingdata_aug + temp + deallocate(temp) + deallocate(targetdata) + + allocate(temp(n,n)) + call DGEMM('N','N',n,n,m,alpha,reservoir%augmented_states,n,transpose(reservoir%augmented_states),m,beta,temp,n) + !call DGEMM('N','T',n,n,m,alpha,reservoir%augmented_states,n,reservoir%augmented_states,m,beta,temp,n) + !print *, 'slab shape(reservoir%states_x_states_aug),shape(temp)',shape(reservoir%states_x_states_aug),shape(temp) + reservoir%states_x_states_aug = reservoir%states_x_states_aug + temp + deallocate(temp) + + return +end subroutine + +subroutine write_trained_res(reservoir,model_parameters,grid) + use mod_io, only : write_netcdf_2d_non_met_data, write_netcdf_1d_non_met_data_int, write_netcdf_1d_non_met_data_real + + type(reservoir_type), intent(in) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(in) :: grid + + character(len=:), allocatable :: file_path + character(len=4) :: worker_char + character(len=1) :: height_char + + file_path = '/scratch/user/troyarcomano/ML_SPEEDY_WEIGHTS/' + + write(worker_char,'(i0.4)') reservoir%assigned_region + write(height_char,'(i0.1)') grid%level_index + + if((reservoir%assigned_region == 0).and.(grid%level_index == 1)) then + call write_controller_file(model_parameters) + endif + + call write_netcdf_2d_non_met_data(reservoir%win,'win',file_path//'worker_'//worker_char//'_level_'//height_char//'_win_'//trim(model_parameters%trial_name)//'.nc','unitless') + call write_netcdf_2d_non_met_data(reservoir%wout,'wout',file_path//'worker_'//worker_char//'_level_'//height_char//'_wout_'//trim(model_parameters%trial_name)//'.nc','unitless') + + call write_netcdf_1d_non_met_data_int(reservoir%rows,'rows',file_path//'worker_'//worker_char//'_level_'//height_char//'_rows_'//trim(model_parameters%trial_name)//'.nc','unitless') + call write_netcdf_1d_non_met_data_int(reservoir%cols,'cols',file_path//'worker_'//worker_char//'_level_'//height_char//'_cols_'//trim(model_parameters%trial_name)//'.nc','unitless') + + call write_netcdf_1d_non_met_data_real(reservoir%vals,'vals',file_path//'worker_'//worker_char//'_level_'//height_char//'_vals_'//trim(model_parameters%trial_name)//'.nc','unitless') + + call write_netcdf_1d_non_met_data_real(grid%mean,'mean',file_path//'worker_'//worker_char//'_level_'//height_char//'_mean_'//trim(model_parameters%trial_name)//'.nc','unitless') + call write_netcdf_1d_non_met_data_real(grid%std,'std',file_path//'worker_'//worker_char//'_level_'//height_char//'_std_'//trim(model_parameters%trial_name)//'.nc','unitless') + +end subroutine + +subroutine write_controller_file(model_parameters) + type(model_parameters_type), intent(in) :: model_parameters + + character(len=:), allocatable :: file_path + + file_path = '/scratch/user/troyarcomano/ML_SPEEDY_WEIGHTS/'//trim(model_parameters%trial_name)//'_controller_file.txt' + + open (10, file=file_path, status='unknown') + + ! write to file + write(10,*)"-----------------------------------------------------------" + write(10,*) + write(10,*)"num_vert_levels:",model_parameters%num_vert_levels + write(10,*)"-----------------------------------------------------------" + + ! close file + close(10) + +end subroutine + +subroutine trained_reservoir_prediction(reservoir,model_parameters,grid) + use mod_linalg, only : mklsparse + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(inout) :: grid + + call read_trained_res(reservoir,model_parameters,grid) + + call mklsparse(reservoir) + + if((reservoir%tisr_input_bool).and.(reservoir%logp_bool)) then + grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+2 + grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + elseif(reservoir%logp_bool) then + grid%logp_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + elseif(reservoir%tisr_input_bool) then + grid%tisr_mean_std_idx = reservoir%local_predictvars*reservoir%local_heightlevels_input+1 + endif +end subroutine + +subroutine read_trained_res(reservoir,model_parameters,grid) + use mod_io, only : read_netcdf_2d_dp, read_netcdf_1d_int, read_netcdf_1d_dp + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(inout) :: grid + + character(len=:), allocatable :: file_path + character(len=4) :: worker_char + character(len=1) :: height_char + + file_path = '/scratch/user/troyarcomano/ML_SPEEDY_WEIGHTS/' + + write(worker_char,'(i0.4)') reservoir%assigned_region + print *, 'reservoir%assigned_region',reservoir%assigned_region + write(height_char,'(i0.1)') grid%level_index + + print *, 'reading win' + call read_netcdf_2d_dp('win',file_path//'worker_'//worker_char//'_level_'//height_char//'_win_'//trim(model_parameters%trial_name)//'.nc',reservoir%win) + + print *, 'reading wout' + call read_netcdf_2d_dp('wout',file_path//'worker_'//worker_char//'_level_'//height_char//'_wout_'//trim(model_parameters%trial_name)//'.nc',reservoir%wout) + + print *, 'reading rows',file_path//'worker_'//worker_char//'_level_'//height_char//'_rows_'//trim(model_parameters%trial_name)//'.nc' + call read_netcdf_1d_int('rows',file_path//'worker_'//worker_char//'_level_'//height_char//'_rows_'//trim(model_parameters%trial_name)//'.nc',reservoir%rows) + print *, 'reading cols',file_path//'worker_'//worker_char//'_level_'//height_char//'_cols_'//trim(model_parameters%trial_name)//'.nc' + call read_netcdf_1d_int('cols',file_path//'worker_'//worker_char//'_level_'//height_char//'_cols_'//trim(model_parameters%trial_name)//'.nc',reservoir%cols) + + call read_netcdf_1d_dp('vals',file_path//'worker_'//worker_char//'_level_'//height_char//'_vals_'//trim(model_parameters%trial_name)//'.nc',reservoir%vals) + + call read_netcdf_1d_dp('mean',file_path//'worker_'//worker_char//'_level_'//height_char//'_mean_'//trim(model_parameters%trial_name)//'.nc',grid%mean) + call read_netcdf_1d_dp('std',file_path//'worker_'//worker_char//'_level_'//height_char//'_std_'//trim(model_parameters%trial_name)//'.nc',grid%std) + +end subroutine + +subroutine read_ohtc_parallel_training(reservoir,model_parameters,grid,ohtc_var) + use mpires, only : mpi_res + use mod_io, only : read_3d_file_parallel + use mod_calendar + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(inout) :: grid + + real(kind=dp), allocatable, intent(out) :: ohtc_var(:,:,:) + + !Local + type(calendar_type) :: ohtc_calendar + + + integer :: start_index, end_index + + character :: ohtc_file + + ohtc_file = '/scratch/user/troyarcomano/ORAS5/regridded_sohtc300_control_monthly_highres_2D_CONS_v0.1_hourly.nc' + + !Starting date of the ohtc data + call initialize_calendar(ohtc_calendar,1979,1,16,0) + + call get_current_time_delta_hour(ohtc_calendar,0) + + call get_current_time_delta_hour(calendar,model_parameters%traininglength+model_parameters%synclength) + + call time_delta_between_two_dates_datetime_type(ohtc_calendar,calendar,start_index) + + allocate(ohtc_var(grid%inputxchunk,grid%inputychunk,model_parameters%traininglength+model_parameters%synclength+100)) + + call read_3d_file_parallel(ohtc_file,'sohtc300',mpi_res,grid,ohtc_var,start_index,1,model_parameters%traininglength+model_parameters%synclength+100) +end subroutine + +subroutine read_ohtc_parallel_prediction(reservoir,model_parameters,grid,ohtc_var) + use mpires, only : mpi_res + use mod_io, only : read_3d_file_parallel + use mod_calendar + + type(reservoir_type), intent(inout) :: reservoir + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(inout) :: grid + + real(kind=dp), allocatable, intent(out) :: ohtc_var(:,:,:) + + !Local + type(calendar_type) :: ohtc_calendar + + + integer :: start_index, end_index + + character :: ohtc_file + + ohtc_file = '/scratch/user/troyarcomano/ORAS5/regridded_sohtc300_control_monthly_highres_2D_CONS_v0.1_hourly.nc' + + !Starting date of the ohtc data + call initialize_calendar(ohtc_calendar,1979,1,16,0) + + call get_current_time_delta_hour(ohtc_calendar,0) + + call get_current_time_delta_hour(calendar,model_parameters%traininglength+model_parameters%prediction_markers(model_parameters%current_trial_number)) + + call time_delta_between_two_dates_datetime_type(ohtc_calendar,calendar,start_index) + + allocate(ohtc_var(grid%inputxchunk,grid%inputychunk,model_parameters%synclength+100)) + + call read_3d_file_parallel(ohtc_file,'sohtc300',mpi_res,grid,ohtc_var,start_index,1,model_parameters%synclength+100) + +end subroutine + +end module diff --git a/src/mod_spectral.f90 b/src/mod_spectral.f90 new file mode 100755 index 0000000..fd53eb2 --- /dev/null +++ b/src/mod_spectral.f90 @@ -0,0 +1,36 @@ +module mod_spectral + use mod_atparam + + implicit none + + private + public el2, elm2, el4, trfilt, l2, ll, mm, nsh2, sia, coa, wt, wght, cosg,& + & cosgr, cosgr2, gradx, gradym, gradyp, sqrhlf, consq, epsi, repsi,& + & emm, ell, poly, cpol, uvdx, uvdym, uvdyp, vddym, vddyp + + ! Initial. in parmtr + real, dimension(mx,nx) :: el2, elm2, el4, trfilt + integer :: l2(mx,nx), ll(mx,nx), mm(mx), nsh2(nx) + + ! Initial. in parmtr + real, dimension(iy) :: sia, coa, wt, wght + real, dimension(il) :: cosg, cosgr, cosgr2 + + ! Initial. in parmtr + real :: gradx(mx), gradym(mx,nx), gradyp(mx,nx) + + ! Initial. in parmtr + real :: sqrhlf, consq(mxp), epsi(mxp,nxp), repsi(mxp,nxp), emm(mxp), ell(mxp,nxp) + + ! Initial. in parmtr + real :: poly(mx,nx) + + ! Initial. in parmtr + real :: cpol(mx2,nx,iy) + + ! Initial. in parmtr + real, dimension(mx,nx) :: uvdx, uvdym, uvdyp + + ! Initial. in parmtr + real, dimension(mx,nx) :: vddym, vddyp +end module diff --git a/src/mod_sppt.f90 b/src/mod_sppt.f90 new file mode 100755 index 0000000..56ee429 --- /dev/null +++ b/src/mod_sppt.f90 @@ -0,0 +1,133 @@ +!> @author +!> Sam Hatfield, AOPP, University of Oxford +!> @brief +!> A module for computing SPPT patterns to be used as multiplicative noise applied to physical tendencies +!> Stochastically Perturbed Parametrization Tendencies (SPPT) is a parametrization of model error. +!> See ECMWF Tech. Memo. #598 (Palmer et al. 2009) +module mod_sppt + use mod_atparam + use mod_tsteps, only: nsteps + use mod_dyncon1, only: rearth + use mod_spectral, only: el2 + + implicit none + + private + public mu, gen_sppt + + ! Array for tapering value of SPPT in the different layers of the atmosphere + ! A value of 1 means the tendency is not tapered at that level + real :: mu(kx) = (/ 1, 1, 1, 1, 1, 1, 1, 1 /) + + complex :: sppt_spec(mx,nx,kx) + logical :: first = .true. + + ! Decorrelation time of SPPT perturbation (in hours) + real, parameter :: time_decorr = 6.0 + + ! Time autocorrelation of spectral AR(1) signals + real :: phi = exp(-(24/real(nsteps))/time_decorr) + + ! Correlation length scale of SPPT perturbation (in metres) + real, parameter :: len_decorr = 500000.0 + + ! Standard deviation of SPPT perturbation (in grid point space) + real, parameter :: stddev = 0.33 + + ! Total wavenumber-wise standard deviation of spectral signals + real :: sigma(mx,nx,kx) + + contains + !> @brief + !> Generate grid point space SPPT pattern + !> distribution. + !> @return sppt_grid the generated grid point pattern + function gen_sppt() result(sppt_grid_out) + integer :: m, n, k + real :: sppt_grid(ix,il,kx), sppt_grid_out(ix*il,kx) + complex :: eta(mx,nx,kx) + real :: f0, randreal, randimag, twn + + ! Seed RNG if first use of SPPT + if (first) call time_seed() + + ! Generate Gaussian noise + do m = 1,mx + do n = 1,nx + do k = 1,kx + randreal = randn(0.0, 1.0) + randimag = randn(0.0, 1.0) + + ! Clip noise to +- 10 standard deviations + eta(m,n,k) = cmplx(& + & min(10.0, abs(randreal)) * sign(1.0,randreal),& + & min(10.0, abs(randimag)) * sign(1.0,randimag)) + end do + end do + end do + + ! If first timestep + if (first) then + ! Generate spatial amplitude pattern and time correlation + f0 = sum((/ ((2*n+1)*exp(-0.5*(len_decorr/rearth)**2*n*(n+1)),n=1,ntrun) /)) + f0 = sqrt((stddev**2*(1-phi**2))/(2*f0)) + + do k = 1,kx + sigma(:,:,k) = f0 * exp(-0.25*len_decorr**2 * el2) + end do + + ! First AR(1) step + sppt_spec = (1 - phi**2)**(-0.5) * sigma * eta + + first = .false. + else + ! Subsequent AR(1) steps + sppt_spec = phi*sppt_spec + sigma*eta + end if + + ! Convert to grid point space + do k=1,kx + call grid(sppt_spec(:,:,k),sppt_grid(:,:,k),1) + sppt_grid_out(:,k) = reshape(sppt_grid(:,:,k), (/ix*il/)) + end do + + ! Clip to +/- 1.0 + sppt_grid_out = min(1.0, abs(sppt_grid_out)) * sign(1.0,sppt_grid_out) + end function + + !> @brief + !> Generates a random number drawn for the specified normal + !> distribution. + !> @param mean the mean of the distribution to draw from + !> @param stdev the standard deviation of the distribution to draw from + !> @return randn the generated random number + function randn(mean, stdev) + real, intent(in) :: mean, stdev + real :: u, v, randn + real :: rand(2) + + call random_number(rand) + + ! Box-Muller method + u = (-2.0 * log(rand(1))) ** 0.5 + v = 2.0 * 6.28318530718 * rand(2) + randn = mean + stdev * u * sin(v) + end function + + !> @brief + !> Seeds RNG from system clock. + subroutine time_seed() + integer :: i, n, clock + integer, allocatable :: seed(:) + + call random_seed(size = n) + allocate(seed(n)) + + call system_clock(count=clock) + + seed = clock + 37 * (/ (i - 1, i = 1, n) /) + call random_seed(put = seed) + + deallocate(seed) + end subroutine +end module diff --git a/src/mod_surfcon.f90 b/src/mod_surfcon.f90 new file mode 100755 index 0000000..1e76680 --- /dev/null +++ b/src/mod_surfcon.f90 @@ -0,0 +1,35 @@ +module mod_surfcon + use mod_atparam + + implicit none + + private + public fmask, fmask1, phi0, phis0, alb0, swcap, swwil, sd2sc + + ! Land-sea masks (initial. in INBCON) + ! Original (fractional) land-sea mask + real :: fmask(ix,il) + ! Model-defined land fraction + real :: fmask1(ix,il) + + ! Time invariant surface fields + ! (initial. in INBCON, phis0 initial. in INVARS) + ! Unfiltered surface geopotential + real :: phi0(ix,il) + + ! Spectrally-filtered sfc. geopotential + real :: phis0(ix,il) + + ! Bare-land annual-mean albedo + real :: alb0(ix,il) + + ! Soil moisture parameters + ! Soil wetness at field capacity (volume fraction) + real :: swcap = 0.30 + + ! Soil wetness at wilting point (volume fraction) + real :: swwil = 0.17 + + ! Snow depth (mm water) corresponding to snow cover = 1 + real :: sd2sc = 60.0 +end module diff --git a/src/mod_tmean.f90 b/src/mod_tmean.f90 new file mode 100755 index 0000000..f108588 --- /dev/null +++ b/src/mod_tmean.f90 @@ -0,0 +1,45 @@ +module mod_tmean + use mod_atparam + + implicit none + + private + public ns2d_1, ns2d_2, ns2d_d1, ns2d_d2, ns3d1, ns3d2, ns3d3, ns3d, save3d,& + & save2d_1, save2d_2, rnsave, save2d_d1, save2d_d2 + + ! Post-processing and output parameters (time-mean and variance fields) + ! No. of 2-d time-mean fields, incremented at post-proc. steps + integer, parameter :: ns2d_1 = 18 + + ! No. of 2-d time-mean fields, incremented every step (fluxes) + integer, parameter :: ns2d_2 = 12 + + ! No. of 2-d daily-mean fields, incremented at post-proc. steps + integer, parameter :: ns2d_d1 = 8 + + ! No. of 2-d daily-mean fields, incremented every step (fluxes) + integer, parameter :: ns2d_d2 = 7 + + ! No. of 3-d time-mean model variables + integer, parameter :: ns3d1 = 9 + + ! No. of 3-d time-mean variances and covariances + integer, parameter :: ns3d2 = 6 + + ! No. of 3-d time-mean diabatic heating fields + integer, parameter :: ns3d3 = 5 + + integer, parameter :: ns3d = ns3d1 + ns3d2 + ns3d3 + + ! Arrays for the computation of time-means + ! (initial./used by tmout, updated in tminc and dmflux) + real :: save3d (ix*il,kx,ns3d) ! 3-D fields saved every post-proc. step + real :: save2d_1(ix*il,ns2d_1) ! 2-D fields saved every post-proc. step + real :: save2d_2(ix*il,ns2d_2) ! 2-D fields saved every step (fluxes) + real :: rnsave ! post-processing counter + + ! Arrays for the computation of daily-means + ! (initial./used by DMOUT, updated in TMINC and DMFLUX) + real :: save2d_d1(ix*il,ns2d_d1) ! Daily output saved every post-proc step + real :: save2d_d2(ix*il,ns2d_d2) ! Daily output saved every step (fluxes) +end module diff --git a/src/mod_tsteps.f90 b/src/mod_tsteps.f90 new file mode 100755 index 0000000..ab37fc5 --- /dev/null +++ b/src/mod_tsteps.f90 @@ -0,0 +1,100 @@ +!> @brief +!> Length of the integration and time stepping constants. +module mod_tsteps + implicit none + + private + public nmonts, ndaysl, nsteps, nstdia, nstppr, nstout, idout, nmonrs, ihout, sixhrrun + public iseasc, istart, iyear0, imont0, ipout, nstrad, sppt_on, nstrdf, indrdf, issty0 + public isst0, delt, delt2, rob, wil, alph + public currentstep, onehr_run, era_start, era_file, era_hour, era_hour_plus_one, onehr_hybrid + + ! Integration length in months + integer :: nmonts = 1 + + ! No. of days in the last month of int. (max=30) + integer :: ndaysl = 0 + + ! No. of time steps in one day + integer, parameter :: nsteps = 96!*100 + + ! Period (no. of steps) for diagnostic print-out + integer, parameter :: nstdia = 36*50 + + ! Period (no. of steps) for post-processing + integer, parameter :: nstppr = 6 + + ! Period (no. of steps) for time-mean output + integer :: nstout = -1 + + ! Daily output flag (0=no, 1=basic (Z500,PREC,MSLP,TEMP0), 2=full) + integer, parameter :: idout = 0 + + ! Period (no. of months) for restart file update + integer, parameter :: nmonrs = 0 + + ! 6-hourly output flags + logical, parameter :: ihout = .False. + logical, parameter :: ipout = .False. + logical, parameter :: sixhrrun = .False. + + !Hourly flag + logical, parameter :: onehr_run = .False. + logical, parameter :: onehr_hybrid = .True. + + ! Seasonal cycle flag (0=no, 1=yes) + integer, parameter :: iseasc = 1 + + ! Start flag (0: from rest, 1: from restart file, 2:era related stuff (see + ! next section) + integer :: istart + + !ERA_5 data stuff + integer :: era_start !Start from file or regrid ERA data + character(len=100) :: era_file !File to read in ERA data + integer :: era_hour !Number of hours into the month (1 == 00UTC of the first day of the month) + integer :: era_hour_plus_one + + ! Year of initial date (4-digit, eg 1900) + integer :: iyear0 + + ! Month of initial date (1 to 12) + integer :: imont0 + + ! Period (no. of steps) for shortwave radiation + integer, parameter :: nstrad = 3 + + ! Turn on SPPT? + logical, parameter :: sppt_on = .false. + + ! Duration of random diabatic forcing ( 0 : no forcing, > 0 : no. of + ! initial steps, < 0 : whole integration) + integer, parameter :: nstrdf = 0 + + ! Initialization index for random diabatic forcing + integer, parameter :: indrdf = -1 + + integer, parameter :: issty0 = 1979 + + ! Record in SST anomaly file corr. to the initial month + ! Initialized in agcm_init + integer :: isst0 + + ! Time step in seconds + real, parameter :: delt = 86400.0 / nsteps + + ! 2 * time step in seconds + real, parameter :: delt2 = 2 * delt + + ! Damping factor in Robert time filter + real, parameter :: rob = 0.05 + + ! Parameter of Williams filter + real, parameter :: wil = 0.53 + + ! Coefficient for semi-implicit computations + real :: alph + + !Variable that contains the current time step integer + integer :: currentstep +end module diff --git a/src/mod_utilities.f90 b/src/mod_utilities.f90 new file mode 100755 index 0000000..3637c16 --- /dev/null +++ b/src/mod_utilities.f90 @@ -0,0 +1,1646 @@ +module mod_utilities + use iso_fortran_env + use MKL_SPBLAS + !use mpi_f08 + use mpi + + implicit none + + integer, parameter :: dp=selected_real_kind(14) !Double precision (64 bit) + integer, parameter :: sp = selected_real_kind(6, 37) !Single precison (32 bit) + integer, parameter :: int_32 = int32 + + real(kind=dp), parameter :: e_constant = 2.7182818284590452353602874_dp + + !every processor needs this and its static + !Layers out the model grid + integer :: speedygridnum=96*48 + integer(kind=int32) :: xgrid=96 + integer(kind=int32) :: ygrid=48 + integer(kind=int32) :: zgrid=8 + + !SPEEDY lat and lons + real(kind=dp) :: speedylat(48) = (/-87.159, -83.479, -79.777, -76.070, -72.362, -68.652, & + -64.942, -61.232, -57.521, -53.810, -50.099, -46.389, -42.678, -38.967, & + -35.256, -31.545 , -27.833, -24.122, -20.411, -16.700, -12.989, -9.278, & + -5.567, -1.856, 1.856, 5.567, 9.278, 12.989, 16.700, 20.411, & + 24.122, 27.833, 31.545, 35.256, 38.967, 42.678, 46.389, 50.099, & + 53.810, 57.521, 61.232, 64.942, 68.652, 72.362, 76.070, 79.777, & + 83.479, 87.159/) + + + type grid_type + !Grid derived type for a specific reservoir + + !i j indices in 2d space of the data that the reservoir is fitted for the processor (wholegrid) + integer :: res_xstart + integer :: res_xend + integer :: res_ystart + integer :: res_yend + integer :: res_zstart + integer :: res_zend + integer :: resxchunk + integer :: resychunk + integer :: reszchunk + + !Memory space 2d indices for the fitting data (not the wholegrid just local + !grid) + integer :: tdata_xstart + integer :: tdata_xend + integer :: tdata_ystart + integer :: tdata_yend + integer :: tdata_zstart + integer :: tdata_zend + + !ij indices for the input data for the processor (wholegrid indices) + integer :: input_xstart + integer :: input_xend + integer :: input_ystart + integer :: input_yend + integer :: input_zstart + integer :: input_zend + integer :: inputxchunk + integer :: inputychunk + integer :: inputzchunk + + !helpful logical flags + logical :: pole + logical :: periodicboundary + logical :: top_vert_level + logical :: bottom_vert_level + + + !overlap + integer :: overlap + + !Vertical localization + integer :: num_vert_levels + integer :: vert_overlap + + !Descriptor of geographical region (options for now are tropics, + !extratropics, and polar) + character(len=:), allocatable :: region_char + + !scale factors when we standardize + real(kind=dp), allocatable :: mean(:) !has length n where n=number of + real(kind=dp), allocatable :: std(:) !physical components in the state + !vector + + !Index of tisr in the mean and std arrays + integer :: tisr_mean_std_idx + + !Index of logp in the mean and std arrays + integer :: logp_mean_std_idx + + !Index of sst in the mean and std arrays + integer :: sst_mean_std_idx + + !Index of precip in the mean and std arrays + integer :: precip_mean_std_idx + + !Number of regions + integer :: number_of_regions + + !Logical flag to indicate if the grid is the top or bottom of the + !atmosphere + logical :: top + logical :: bottom + + !Integer to tell the grid which level it is could be 1 ... n n=number of + !vertical levels + integer :: level_index + + !Boolean whether this reservoir associated with this grid type has the logp + !variable + logical :: logp_bool + + !Where the 3-d atmosphere start and stop indices in u(t) where u looks something like u(atmos...logp...sst...sst_climo...tisr) + !start and end will depend if the variable is from the input region u(t) or + !just + !the prediction region v(t) + integer :: atmo3d_start + integer :: atmo3d_end + + !SST indices in u(t) where u(atmos...logp...sst...sst_climo...tisr) + !start and end will depend if the variable is from the input region u(t) or just + !the prediction region v(t) + integer :: sst_start + integer :: sst_end + + !logp indices in u(t) where u(atmos...logp...sst...sst_climo...tisr) + !start and end will depend if the variable is from the input region u(t) or just + !the prediction region v(t) + integer :: logp_start + integer :: logp_end + + !precipitation indices in u(t) where u(atmos...logp...precip...sst...sst_climo...tisr) + !start and end will depend if the variable is from the input region u(t) or + !just + !the prediction region v(t) + integer :: precip_start + integer :: precip_end + + !tisr indices in u(t) where u(atmos...logp...sst...sst_climo...tisr) + !start and end will depend if the variable is from the input region u(t) or + !just the prediction region v(t) + integer :: tisr_start + integer :: tisr_end + + !variables that need predicting indices in u(t) where u(atmos...logp...sst...sst_climo...tisr) + !so if its a region that only predicts the atmosphere then it will be + !predict_start = 1, predict_end = atmo3d_end + !if the reservoir predicts the atmos, logp and sst then predict_start = 1, + !predict_end = sst_end + !start and end will depend if the variable is from the input region u(t) or + !just the prediction region v(t) + integer :: predict_start + integer :: predict_end + + !ocean heat content (ohtc) indices in u(t) where + !u(atmos...logp...sst...sst_climo...tisr...othc) + !This will only be for ocean reservoirs + integer :: othc_start + integer :: othc_end + end type grid_type + + type reservoir_type + !Reservoir derived type that holds all of the variables needed to run a + !reservoir routine including the training data, reservoir hyper-parameters, + !and the matrices for fitting the reservoir + + !Integer that is used to index which region this specific reservoir is + !assigned. For example 512 processors and 1152 regions and this was + !processor 1 and region 2 on that processor that assigned_region == 4 + integer :: assigned_region + + !Holds the indices of the sigma levels for this specific reservoir + integer, allocatable :: vert_indices_res(:) + integer, allocatable :: vert_indices_input(:) + + + !Training data for this specific reservior + real(kind=dp), allocatable :: trainingdata(:,:) + + !reservoir stuff relating to the adjancency matrix + type(SPARSE_MATRIX_T) cooA + type(MATRIX_DESCR) descrA + + + real(kind=dp) :: deg + real(kind=dp) :: radius + real(kind=dp) :: beta_res !reservoir ridge regression parameter + real(kind=dp) :: beta_model !model ridge regression parameter + real(kind=dp) :: density + + !Sigma for input into reservoir + real(kind=dp) :: sigma + + !Leakage + real(kind=dp) :: leakage + + !COO sparse matrix holds row and col indexs + integer, allocatable :: rows(:) + integer, allocatable :: cols(:) + real(kind=dp), allocatable :: vals(:) + + integer :: k + + integer :: reservoir_numinputs + + integer :: locality + + !reservoir node size m=what you want n=closest possible num of nodes to m + integer :: m + integer :: n + + !Reservoir components Win, Wout, etc + real(kind=dp), allocatable :: win(:,:) + real(kind=dp), allocatable :: wout(:,:) + real(kind=dp), allocatable :: states(:,:) + real(kind=dp), allocatable :: augmented_states(:,:) + + !Batch stuff + integer :: batch_size + real(kind=dp), allocatable :: states_x_states(:,:) + real(kind=dp), allocatable :: states_x_trainingdata(:,:) + + !batch hybrid stuff + real(kind=dp), allocatable :: states_x_states_aug(:,:) + real(kind=dp), allocatable :: states_x_trainingdata_aug(:,:) + + + !Local num of height levels and variables predicted per level + !may change on level and processor. + !NOTE full_heightlevels /= local_heightlevels possible + integer :: local_heightlevels_res + integer :: local_heightlevels_input + integer :: local_predictvars + + !Becase logp is a special 2d variable its is complicated + !and needs its own parameters + integer :: logp_size_res + integer :: logp_size_input + + !LOGP bool gotta set this to false for vertical reservoirs away from the + !surface + logical :: logp_bool + + !Save reservoir state for later use + real(kind=dp), allocatable :: saved_state(:) + + !TISR relievent + logical :: tisr_input_bool !This is the actual variable that determines + !which reservoir gets tisr. Just because + !model_parameter%toa_isr_bool is true doesnt + !mean tisr_input_bool is true. It will depend on + !what part of the atmosphere the reservoir + !predicts + + integer :: tisr_size_input !Saves the size of the tisr input length + integer :: tisr_size_res !size of non overlap tisr length + + + + !Variables related to precipitation + logical :: precip_bool + + + logical :: precip_input_bool + + integer :: precip_size_res + integer :: precip_size_input + + + + !Becase sst is a special 2d variable its is complicated + !and needs its own parameters + logical :: sst_bool !Whether this reservoir should even have SST as a + !possible input + + logical :: sst_bool_input !Whether this reservoir has sst data as an input + !If there isnt any variance in the domain + !this is set to false even if sst_bool is + !true + + logical :: sst_bool_prediction !The slab ocean model reservoir should be the + !only one predicting sst data + + integer :: sst_size_res + integer :: sst_size_input + + + !Input SST climatology + logical :: sst_climo_bool + + logical :: sst_climo_input + integer :: sst_climo_res + + !Atmosphere to ocean coupling parameters + logical :: atmo_to_ocean_coupled + + integer :: atmo_size_input + integer :: num_atmo_levels + + !Variables related to inputting the 0-300 meter oceanic heat content + logical :: ohtc_input + logical :: ohtc_prediction + + integer :: ohtc_res_size + integer :: ohtc_input_size + + integer, allocatable :: atmo_training_data_idx(:) + + !A 2d var to hold the atmospheric inputs to the ocean model during the + !prediction phase that then gets averaged over + !This will be held by the ocean reservoirs not the atmo ones + real(kind=dp), allocatable :: averaged_atmo_input_vec(:,:) !shape = (num_inputs of atmo variables into ml ocean model,timestep_slab) + + !Standard variables needed for the reservoir and hybrid related to length of + !the predicted vector + integer :: chunk_size + integer :: chunk_size_prediction + integer :: chunk_size_speedy !When prognostic variables + !of the hybrid model arent + !in speedy + + !Chunk size and chunk size prediction are the same unless toa_isr_bool is + !TruA + + + !Contains the imperfect model states + !e.g. feeding the training data through speedy and saving the output + real(kind=dp), allocatable :: imperfect_model_states(:,:) + + !Holds predictions by reservoir + real(kind=dp), allocatable :: predictiondata(:,:) + + !stuff related to noise + real(kind=dp) :: noisemag !magnitude of gaussian noise + + !The value of the prior [0,1] + real(kind=dp) :: prior_val + + !Current local speedy state + real(kind=dp), allocatable :: local_model(:) + + !Current outvec (prediction) for this reservoir + real(kind=dp), allocatable :: outvec(:) + + !Current feedback for this reservoir + real(kind=dp), allocatable :: feedback(:) + + !TISR for the full year to save time reading and writing during prediction + real(kind=dp), allocatable :: full_tisr(:,:,:) + + integer :: predictvars2d + end type reservoir_type + + type model_parameters_type + !Holds the static variables for a specific processor + + !ML-only Atmo Model Setup + logical :: ml_only + + !If this is a ocean reservoir make it ml only if true + logical :: ml_only_ocean + + !Vars for vertical localization and domain decomposition + integer :: num_vert_levels + integer :: vert_loc_overlap + integer :: number_of_regions + integer :: num_of_regions_on_proc + + !array that holds the indices of which regions this processor has + !e.g. 1152 regions and 576 processors then res%irank 0 will have regions 0 + !and 1 + integer, allocatable :: region_indices(:) + + !Various parameters global variables of the global model state + !e.g. when set to the main_type these are the max number and are static + !however each reservoir in the vertical may have a different number than + !these + integer :: full_heightlevels + integer :: full_predictvars + + !data for reservoir + integer :: traininglength + + integer :: discardlength + integer :: synclength + + integer :: predictionlength + + integer :: overlap + integer, allocatable :: prediction_markers(:) + integer :: num_predictions + integer :: current_trial_number + + !mpi stuff + integer :: irank + integer :: numprocs + + !prediction + real(kind=dp), allocatable :: prediction(:,:) + + logical :: specific_humidity_log_bool + real(kind=dp) :: specific_humidity_epsilon=0.3_dp !we are + !saving specific as log(sp + epsilon) + + !Pole model forecast only + logical :: pole_only + + !File writing strings + character(len=3) :: trial_number + character(len=10) :: trial_date + character(len=:), allocatable :: trial_name + + !Make sure SPEEDY code doesnt break ours + logical :: run_speedy + + !Input time of day into reservoir + logical :: timeofday_bool + + !Vary the hyper-parameters by region in hopes of getting better results + logical :: regional_vary + + !Number of reading and training chunks + !This is independent of the batch training stuff + !The memory limitation will not allow us to read in + !multiple decades of era and speedy data + !instead we will chunk the reading and training into parts + !while also batching the training + + !---Section for variables related to using a prior for the LS solver---! + + !Boolean saying if we are using a prior or not + logical :: using_prior + + !Noise to be added to the imperfect model states + real(kind=dp) :: model_noise + + !Time step of the reservoir + integer :: timestep + + !Time step of the ocean model + integer :: timestep_slab + + !Input top of atmosphere incident solar radiation into reservoir + logical :: toa_isr_bool + + !Input and predict precipitation + logical :: precip_bool + + !Transforming Precip into log space see Pathek et al 2022 + real :: precip_epsilon + + !stuff related to noise + logical :: noisy !Flag to add noise + + character(len=:), allocatable :: prediction_file + + !We can assume "special" reservoirs that are different than our main reservoirs + !which predict the 3d prognostic variables (T,U,V,R) at each height level + !and grid point + ! + !These reservoirs and the associated grid object (if present) also wont be defined on the usual xyz grid + !Things like precip and SST and their grids are significantly different + !enough to have there own designation of these special reservoirs + ! + !They can also have there own completely different hyper-parameters such as + !time step etc + logical :: special_reservoirs + + !Num of these special reservoirs (e.g. if using precip + SST then + !num_special_reservoirs == 2) + integer :: num_special_reservoirs + + logical :: slab_ocean_model_bool + + logical :: train_on_sst_anomalies + + real(kind=dp), allocatable :: base_sst_grid(:,:) + real(kind=dp), allocatable :: sea_mask(:,:) + + end type model_parameters_type + + type main_type + !The main derive type of the program. This holds basically everything needed + !to run the program including the model parameters, grid type for each + !reservoir, and each reservoir it self + + !The shape of grid and reservoir are equal and grid(i,j) is the grid type for + !reservoir(i,j). Shape(reservoir) is (num_regions_per_processor,num_vertical_levels) + + + !Allocatable grid type for multiple sub-domains per processor + type(grid_type), allocatable :: grid(:,:) + + !Allocatable reservoir type for vert loc + type(reservoir_type), allocatable :: reservoir(:,:) + + !Allocatable grid type for multiple sub-domains per processor + type(grid_type), allocatable :: grid_special(:,:) + + !Allocatable reservoir type for vert loc + type(reservoir_type), allocatable :: reservoir_special(:,:) + + !A simple derived type to hold the static parameters of the model + !needed to passing to subroutines were reservoir and or grid are also passed + type(model_parameters_type) :: model_parameters + + end type main_type + + type speedy_data_type + !Holds all of the 4d speedy variables in one 5d array + real(kind=dp), allocatable :: speedyvariables(:,:,:,:,:) + + !LogP is a special speedy variable + real(kind=dp), allocatable :: speedy_logp(:,:,:) + end type speedy_data_type + + type era_data_type + !Holds all of the 4d era variables in one 5d array + real(kind=dp), allocatable :: eravariables(:,:,:,:,:) + + !LogP is a special era variable + real(kind=dp), allocatable :: era_logp(:,:,:) + + !TISR + real(kind=dp), allocatable :: era_tisr(:,:,:) + + !SST + real(kind=dp), allocatable :: era_sst(:,:,:) + + !Climatological SST (hourly average iof ERA5 from 1981 - 2000) + real(kind=dp), allocatable :: era_sst_climo(:,:,:) + + !hourly Precip + real(kind=dp), allocatable :: era_precip(:,:,:) + end type era_data_type + + type state_vector_type + !Holds all of the 3d variables in one 4d array + real(kind=dp), allocatable :: variables3d(:,:,:,:) + + !LogP is a special variable + real(kind=dp), allocatable :: logp(:,:) + + !Lets also keep some meta data in this type to make SPEEDY run + integer :: istart !from rest=0, from restartfile=1, from era=2 + integer :: era_start !start from grid initial condition=0, Start from grid=1 + character(len=100) :: era_file + + integer :: era_hour !era hour of the month 1 = 00UTC of the first day of + integer :: era_hour_plus_one !So I dont have to do calendar stuff in + + !Speedy internal calenadr stuff + integer :: iyear0 + integer :: imont0 + integer :: iday + integer :: ihour + + !A logical flag to see if it is safe to run speedy anymore + logical :: is_safe_to_run_speedy + + logical :: hybrid_slab + + real(kind=dp), allocatable :: sst_hybrid(:,:) + + real(kind=dp) :: sst_bias = 0.0_dp + end type state_vector_type + + type mpi_type + !Holds the necessary mpi stuff one per processor + integer(kind=int32) :: ierr + integer(kind=int32) :: numprocs + integer(kind=int32) :: proc_num + integer :: mpi_world + !type(MPI_Comm) :: mpi_world + + logical :: is_root = .False. + + logical :: is_serial = .False. + end type mpi_type + + type calendar_type + !Calendar derived type to do calendar calculations and keep track of + !current and starting times + + !Initialize calendar_type with start date + integer :: startyear + integer :: startmonth + integer :: startday + integer :: starthour + + !Current date + integer :: currentyear + integer :: currentmonth + integer :: currentday + integer :: currenthour + + end type calendar_type + + !Overload the standardize_data routine + interface standardize_data + module procedure standardize_data_1d + module procedure standardize_data_2d + module procedure standardize_data_3d + module procedure standardize_data_4d + module procedure standardize_data_5d + module procedure standardize_data_5d_logp + module procedure standardize_data_5d_logp_tisr + end interface + + !Overload unstandardize_data routine + interface unstandardize_data + module procedure unstandardize_data_4d + module procedure unstandardize_data_4d_logp + module procedure unstandardize_data_4d_multi_2d + end interface + + !Overloads gaussian_noise routine + interface gaussian_noise + module procedure gaussian_noise_2d + module procedure gaussian_noise_1d + end interface + + contains + + subroutine unstandardize_data_4d(reservoir,inputdata,mean,std) + !Unstandardize inputdata + !mean and std needs to be the same length as the first dimension of + !inputdata + type(reservoir_type), intent(in) :: reservoir + real(kind=dp), intent(inout) :: inputdata(:,:,:,:) + real(kind=dp), intent(in) :: mean(:), std(:) + + integer :: i, j, k + integer :: n, m, l + + n = size(inputdata,1) + + k = size(inputdata,4) !Number of height variables + + !If we are doing log(specific_humidity) no need to unstandardize because + !we didnt standardize it + !if(res%specific_humidity_log_bool) then + !For plotting and regional variety lets make sure we are out of log + !space + !inputdata(4,:,:,:) = e_constant**inputdata(4,:,:,:) - res%specific_humidity_epsilon + !endif + + l = 1 + do i=1, n + do j=1, k + inputdata(i,:,:,j) = inputdata(i,:,:,j)*std(l) + inputdata(i,:,:,j) = inputdata(i,:,:,j) + mean(l) + l = l + 1 + enddo + end do + + return + end subroutine + + subroutine unstandardize_data_4d_logp(reservoir,inputdata,logp,mean,std) + !Unstandardize inputdata + !mean and std needs to be the same length as the first dimension of + !inputdata + type(reservoir_type), intent(in) :: reservoir + + real(kind=dp), intent(inout) :: inputdata(:,:,:,:) + real(kind=dp), intent(inout) :: logp(:,:) + real(kind=dp), intent(in) :: mean(:), std(:) + + integer :: i, j, k + integer :: n, m, l + + n = size(inputdata,1) + + k = size(inputdata,4) !Number of height variables + + l = 1 + do i=1, n + do j=1, k + inputdata(i,:,:,j) = inputdata(i,:,:,j)*std(l) + inputdata(i,:,:,j) = inputdata(i,:,:,j) + mean(l) + l = l + 1 + enddo + end do + + logp = logp*std(l) + logp = logp + mean(l) + return + end subroutine + + subroutine unstandardize_data_4d_logp_2d(reservoir,inputdata,logp,mean,std) + !Unstandardize inputdata + !mean and std needs to be the same length as the first dimension of + !inputdata + type(reservoir_type), intent(in) :: reservoir + + real(kind=dp), intent(inout) :: inputdata(:,:,:,:,:) + real(kind=dp), intent(inout) :: logp(:,:,:) + real(kind=dp), intent(in) :: mean(:), std(:) + + integer :: i, j, k + integer :: n, m, l + + n = size(inputdata,1) + + k = size(inputdata,4) !Number of height variables + + l = 1 + do i=1, n + do j=1, k + inputdata(i,:,:,j,:) = inputdata(i,:,:,j,:)*std(l) + inputdata(i,:,:,j,:) = inputdata(i,:,:,j,:) + mean(l) + l = l + 1 + enddo + end do + + logp = logp*std(l) + logp = logp + mean(l) + return + end subroutine + + subroutine unstandardize_data_4d_multi_2d(reservoir,inputdata,inputdata2d,mean,std) + !Unstandardize inputdata + !mean and std needs to be the same length as the first dimension of + !inputdata + type(reservoir_type), intent(in) :: reservoir + real(kind=dp), intent(inout) :: inputdata(:,:,:,:) + real(kind=dp), intent(inout) :: inputdata2d(:,:,:) + real(kind=dp), intent(in) :: mean(:), std(:) + + integer :: i, j, k + integer :: n, m, l + + n = size(inputdata,1) + + k = size(inputdata,4) !Number of height variables + + + l = 1 + do i=1, n + do j=1, k + inputdata(i,:,:,j) = inputdata(i,:,:,j)*std(l) + inputdata(i,:,:,j) = inputdata(i,:,:,j) + mean(l) + l = l + 1 + enddo + end do + + do i=1, reservoir%predictvars2d + !print *, 'i',i,'l',l,'mean,std',std(l),mean(l) + inputdata2d(i,:,:) = inputdata2d(i,:,:)*std(l) + inputdata2d(i,:,:) = inputdata2d(i,:,:) + mean(l) + l = l + 2 + enddo + return + end subroutine + + subroutine unstandardize_data_2d(inputdata,mean,std) + !Unstandardize 2-dimensional inputdata + !mean and std needs to be the same length as the first dimension of + !inputdata + + real(kind=dp), intent(inout) :: inputdata(:,:) + real(kind=dp), intent(in) :: mean, std + + integer :: i, j, k + integer :: n, m, l + + inputdata = inputdata*std + inputdata = inputdata + mean + + return + end subroutine + + subroutine unstandardize_data_1d(inputdata,mean,std) + !Unstandardize 2-dimensional inputdata + !mean and std needs to be the same length as the first dimension of + !inputdata + + real(kind=dp), intent(inout) :: inputdata(:) + real(kind=dp), intent(in) :: mean, std + + integer :: i, j, k + integer :: n, m, l + + inputdata = inputdata*std + inputdata = inputdata + mean + + return + end subroutine + + subroutine standardize_data_2d(inputdata,mean,std) + !Standardizes the input data by subtracting the mean out + !and then dividing by the std + real(kind=dp), intent(inout) :: inputdata(:,:) !2d var with data being 1st and 2nd being time + real(kind=dp), intent(out) :: mean, std + + real(kind=dp) :: mean_, std_ + + mean_ = sum(inputdata)/size(inputdata) + std_ = sqrt((sum(inputdata**2)-sum(inputdata)**2/size(inputdata))/size(inputdata)) + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean_ + inputdata = inputdata/std_ + + mean = mean_ + std = std_ + return + end subroutine + + subroutine standardize_sst_data_3d(inputdata,mean,std,any_change) + !Standardizes the input data by subtracting the mean out + !and then dividing by the std + real(kind=dp), intent(inout) :: inputdata(:,:,:) !3d var with data being 1st and 3nd being time + real(kind=dp), intent(out) :: mean, std + + logical, intent(out) :: any_change + + real(kind=dp) :: mean_, std_ + + + if((sum(inputdata**2)-sum(inputdata)**2/size(inputdata)) > 0) then + mean_ = sum(inputdata)/size(inputdata) + !sqrt(sum((inputdata(i,:,:,j,:) - mean_)**2)/size(inputdata(i,:,:,j,:))) + std_ = sqrt(sum((inputdata-mean_)**2)/size(inputdata)) + print *, 'std_',std_ + if(std_ > 0.2) then + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean_ + inputdata = inputdata/std_ + + mean = mean_ + std = std_ + any_change = .True. + else + mean = 0 + std = 0 + any_change = .False. + endif + else + mean = 0 + std = 0 + any_change = .False. + endif + return + end subroutine + + subroutine standardize_data_3d(inputdata,mean,std) + !Standardizes the input data by subtracting the mean out + !and then dividing by the std + real(kind=dp), intent(inout) :: inputdata(:,:,:) !3d var with data being 1st and 3nd being time + real(kind=dp), intent(out) :: mean, std + + real(kind=dp) :: mean_, std_ + + mean_ = sum(inputdata)/size(inputdata) + std_ = sqrt((sum(inputdata**2)-sum(inputdata)**2/size(inputdata))/size(inputdata)) + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean_ + inputdata = inputdata/std_ + + mean = mean_ + std = std_ + return + end subroutine + + subroutine standardize_data_4d(inputdata,mean,std) + !Standardizes the input data by subtracting the mean out + !and then dividing by the std + real(kind=dp), intent(inout) :: inputdata(:,:,:,:) !4d var with data being 1-3 and 4th being time + real(kind=dp), intent(out) :: mean, std + + real(kind=dp) :: mean_, std_ + + mean_ = sum(inputdata)/size(inputdata) + std_ = sqrt((sum(inputdata**2)-sum(inputdata)**2/size(inputdata))/size(inputdata)) + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean_ + inputdata = inputdata/std_ + + mean = mean_ + std = std_ + return + end subroutine + + subroutine standardize_data_5d(reservoir,inputdata,mean,std) + type(reservoir_type), intent(in) :: reservoir + + real(kind=dp), intent(inout) :: inputdata(:,:,:,:,:) !5d var with data being 1 being a variable type 2-4 xyz and 5th being time + real(kind=dp), intent(out) :: mean(:), std(:) + + real(kind=dp) :: mean_, std_ + + integer :: length, height + integer :: i, j, l + + length = size(inputdata,1) + height = size(inputdata,4) + + l = 1 + do i=1, length + do j=1, height + mean_ = sum(inputdata(i,:,:,j,:))/size(inputdata(i,:,:,j,:)) + std_ = sqrt(sum((inputdata(i,:,:,j,:) - mean_)**2)/size(inputdata(i,:,:,j,:))) + + call standardize_data_given_pars3d(inputdata(i,:,:,j,:),mean_,std_) + + mean(l) = mean_ + std(l) = std_ + l = l + 1 + enddo + end do + + return + end subroutine + + subroutine standardize_data_1d(inputdata,mean,std) + !Standardizes the input data by subtracting the mean out + !and then dividing by std + real(kind=dp), intent(inout) :: inputdata(:) !1d var data var + real(kind=dp), intent(out) :: mean, std + + real(kind=dp) :: mean_, std_ + + mean_ = sum(inputdata)/size(inputdata) + std_ = sqrt((sum(inputdata**2)-sum(inputdata)**2/size(inputdata))/size(inputdata)) + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean_ + inputdata = inputdata/std_ + + mean = mean_ + std = std_ + return + end subroutine + + subroutine standardize_data_5d_logp(reservoir,inputdata,logp,mean,std) + type(reservoir_type), intent(in) :: reservoir + + real(kind=dp), intent(inout) :: inputdata(:,:,:,:,:) !5d var with data being 1 being a variable type 2-4 xyz and 5th being time + real(kind=dp), intent(inout) :: logp(:,:,:) + real(kind=dp), intent(out) :: mean(:), std(:) + + real(kind=dp) :: mean_, std_ + + integer :: length, height + integer :: i, j, l + + length = size(inputdata,1) + height = size(inputdata,4) + + l = 1 + do i=1, length + do j=1, height + mean_ = sum(inputdata(i,:,:,j,:))/size(inputdata(i,:,:,j,:)) + std_ = sqrt(sum((inputdata(i,:,:,j,:) - mean_)**2)/size(inputdata(i,:,:,j,:))) + + call standardize_data_given_pars3d(inputdata(i,:,:,j,:),mean_,std_) + + mean(l) = mean_ + std(l) = std_ + l = l + 1 + enddo + end do + + mean_ = sum(logp)/size(logp) + std_ = sqrt(sum((logp - mean_)**2)/size(logp)) + + call standardize_data_given_pars3d(logp,mean_,std_) + + mean(l) = mean_ + std(l) = std_ + + return + end subroutine + + subroutine standardize_data_5d_logp_tisr(reservoir,inputdata,logp,tisr,mean,std) + type(reservoir_type), intent(in) :: reservoir + + real(kind=dp), intent(inout) :: inputdata(:,:,:,:,:) !5d var with data being 1 being a variable type 2-4 xyz and 5th being time + real(kind=dp), intent(inout) :: logp(:,:,:), tisr(:,:,:) + real(kind=dp), intent(out) :: mean(:), std(:) + + real(kind=dp) :: mean_, std_ + + integer :: length, height + integer :: i, j, l + + length = size(inputdata,1) + height = size(inputdata,4) + + l = 1 + do i=1, length + do j=1, height + mean_ = sum(inputdata(i,:,:,j,:))/size(inputdata(i,:,:,j,:)) + std_ = sqrt(sum((inputdata(i,:,:,j,:) - mean_)**2)/size(inputdata(i,:,:,j,:))) + + call standardize_data_given_pars3d(inputdata(i,:,:,j,:),mean_,std_) + + mean(l) = mean_ + std(l) = std_ + l = l + 1 + enddo + end do + + !logp + mean_ = sum(logp)/size(logp) + std_ = sqrt(sum((logp - mean_)**2)/size(logp)) + + call standardize_data_given_pars3d(logp,mean_,std_) + + mean(l) = mean_ + std(l) = std_ + + !Tisr + l = l + 1 + + mean_ = sum(tisr)/size(tisr) + std_ = sqrt(sum((tisr - mean_)**2)/size(tisr)) + + call standardize_data_given_pars3d(tisr,mean_,std_) + + mean(l) = mean_ + std(l) = std_ + return + end subroutine + + subroutine standardize_data_given_pars_5d_logp_tisr(mean,std,input_data,input_logp,input_tisr) + real(kind=dp), intent(in) :: mean(:), std(:) + + real(kind=dp), intent(inout) :: input_data(:,:,:,:,:) !5d var with data being 1 being a variable type 2-4 xyz and 5th being time + real(kind=dp), intent(inout) :: input_logp(:,:,:), input_tisr(:,:,:) + + integer :: length, height + integer :: i, j, l + + length = size(input_data,1) + height = size(input_data,4) + + l = 1 + do i=1, length + do j=1, height + + call standardize_data_given_pars3d(input_data(i,:,:,j,:),mean(l),std(l)) + + l = l + 1 + enddo + end do + + !Logp + call standardize_data_given_pars3d(input_logp,mean(l),std(l)) + + !Tisr + l = l + 1 + + call standardize_data_given_pars3d(input_tisr,mean(l),std(l)) + + return + end subroutine + + subroutine standardize_data_given_pars_5d_logp(mean,std,input_data,input_logp,mean_logp,std_logp) + real(kind=dp), intent(in) :: mean(:), std(:) + real(kind=dp), intent(in), optional :: mean_logp, std_logp + + real(kind=dp), intent(inout) :: input_data(:,:,:,:,:) !5d var with data being 1 being a variable type 2-4 xyz and 5th being time + real(kind=dp), intent(inout) :: input_logp(:,:,:) + + integer :: length, height + integer :: i, j, l + + length = size(input_data,1) + height = size(input_data,4) + + l = 1 + do i=1, length + do j=1, height + + call standardize_data_given_pars3d(input_data(i,:,:,j,:),mean(l),std(l)) + + l = l + 1 + enddo + end do + + if((present(mean_logp).and.present(std_logp))) then + call standardize_data_given_pars3d(input_logp,mean_logp,std_logp) + else + call standardize_data_given_pars3d(input_logp,mean(l),std(l)) + endif + return + end subroutine + + subroutine standardize_data_given_pars5d(mean,std,input_data) + real(kind=dp), intent(in) :: mean(:), std(:) + + real(kind=dp), intent(inout) :: input_data(:,:,:,:,:) !5d var with data being 1 being a variable type 2-4 xyz and 5th being time + + integer :: length, height + integer :: i, j, l + + length = size(input_data,1) + height = size(input_data,4) + + l = 1 + do i=1, length + do j=1, height + + call standardize_data_given_pars3d(input_data(i,:,:,j,:),mean(l),std(l)) + + l = l + 1 + enddo + end do + + return + end subroutine + + subroutine standardize_data_given_pars4d(inputdata,mean,std) + !Standardizes input data by the given std and mean + real(kind=dp), intent(inout) :: inputdata(:,:,:,:) + real(kind=dp), intent(in) :: mean, std + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean + inputdata = inputdata/std + + return + end subroutine + + subroutine standardize_data_given_pars3d(inputdata,mean,std) + !Standardizes input data by the given std and mean + real(kind=dp), intent(inout) :: inputdata(:,:,:) + real(kind=dp), intent(in) :: mean, std + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean + inputdata = inputdata/std + + return + end subroutine + + subroutine standardize_data_given_pars2d(inputdata,mean,std) + !Standardizes input data by the given std and mean + real(kind=dp), intent(inout) :: inputdata(:,:) + real(kind=dp), intent(in) :: mean, std + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean + inputdata = inputdata/std + + return + end subroutine + + subroutine standardize_data_given_pars1d(inputdata,mean,std) + !Standardizes input data by the given std and mean + real(kind=dp), intent(inout) :: inputdata(:) + real(kind=dp), intent(in) :: mean, std + + !Subtracts the mean out and then divides by the std + inputdata = inputdata - mean + inputdata = inputdata/std + + return + end subroutine + + subroutine normalize_data(inputdata,min_data,max_data) + !normalize the input data (inputdata-min)/(max-min) + real(kind=dp), intent(inout) :: inputdata(:,:) + real(kind=dp), intent(out) :: min_data,max_data + + min_data = minval(inputdata) + max_data = maxval(inputdata) + + inputdata = (inputdata - min_data)/(max_data-min_data) + + return + end subroutine + + + subroutine gaussian_noise_2d(inputdata,noisemag) + !Adds gaussian noise to the input data + real(kind=dp), intent(inout) :: inputdata(:,:) + real(kind=dp), intent(in) :: noisemag + + real(kind=dp), allocatable :: gaussnoise(:,:) + real(kind=dp), parameter :: sigma=1.0, mean=0.0 + + allocate(gaussnoise(size(inputdata,1),size(inputdata,2))) + + !call init_random_seed(33) + + call random_gaussian_gen_2d(gaussnoise,sigma,mean) + + inputdata = inputdata+gaussnoise*noisemag*inputdata + + deallocate(gaussnoise) + + return + end subroutine + + subroutine gaussian_noise_1d(inputdata,noisemag) + !Adds gaussian noise to the input data + real(kind=dp), intent(inout) :: inputdata(:) + real(kind=dp), intent(in) :: noisemag + + real(kind=dp), allocatable :: gaussnoise(:) + real(kind=dp), parameter :: sigma=1.0, mean=0.0 + + allocate(gaussnoise(size(inputdata,1))) + + !call init_random_seed(33) + + call random_gaussian_gen_1d(gaussnoise,sigma,mean) + + inputdata = inputdata+gaussnoise*noisemag*inputdata + + deallocate(gaussnoise) + + return + end subroutine + + function gaussian_noise_1d_function(inputdata,noisemag) result(noisy_data) + !Adds gaussian noise to the input data + real(kind=dp), intent(in) :: inputdata(:) + real(kind=dp), intent(in) :: noisemag + real(kind=dp), allocatable :: noisy_data(:) + + real(kind=dp), allocatable :: gaussnoise(:) + real(kind=dp), parameter :: sigma=1.0, mean=0.0 + + allocate(gaussnoise(size(inputdata,1))) + allocate(noisy_data(size(inputdata,1))) + + !call init_random_seed(33) + + call random_gaussian_gen_1d(gaussnoise,sigma,mean) + + noisy_data = inputdata+gaussnoise*noisemag*inputdata + + deallocate(gaussnoise) + + return + end function + + function gaussian_noise_1d_function_precip(inputdata,noisemag,grid,model_parameters) result(noisy_data) + !Adds gaussian noise to the input data and makes sure the noise to + !precipitation is not done in log space + real(kind=dp), intent(in) :: inputdata(:) + real(kind=dp), intent(in) :: noisemag + + type(grid_type), intent(in) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), allocatable :: noisy_data(:) + + real(kind=dp), allocatable :: gaussnoise(:) + real(kind=dp), allocatable :: temp(:) + + real(kind=dp), parameter :: sigma=1.0, mean=0.0 + + allocate(gaussnoise(size(inputdata,1))) + allocate(noisy_data(size(inputdata,1))) + + call random_gaussian_gen_1d(gaussnoise,sigma,mean) + + noisy_data(1:grid%precip_start-1) = inputdata(1:grid%precip_start-1)+gaussnoise(1:grid%precip_start-1)*noisemag*inputdata(1:grid%precip_start-1) + + allocate(temp(grid%precip_end - grid%precip_start)) + + temp = inputdata(grid%precip_start:grid%precip_end) + + temp = temp*grid%std(grid%precip_mean_std_idx) + grid%mean(grid%precip_mean_std_idx) + + temp = model_parameters%precip_epsilon * (e_constant**temp - 1) + + temp = temp + gaussnoise(grid%precip_start:grid%precip_end)*noisemag*temp + + temp = abs(temp) !NOTE make sure we dont get any negative numbers + + temp = log(1 + temp/model_parameters%precip_epsilon) + + temp = temp - grid%mean(grid%precip_mean_std_idx) + + temp = temp/grid%std(grid%precip_mean_std_idx) + + noisy_data(grid%precip_start:grid%precip_end) = temp + + noisy_data(grid%precip_end + 1:size(inputdata,1)) = inputdata(grid%precip_end + 1:size(inputdata,1))+gaussnoise(grid%precip_end + 1:size(inputdata,1))*noisemag*inputdata(grid%precip_end + 1:size(inputdata,1)) + + deallocate(gaussnoise) + + return + end function + + subroutine random_gaussian_gen_2d(array,sigma,mean) + !Returns a 2d array of normally distributed + !random numbers and gives you control over sigma + !mean + real(kind=dp), intent(inout) :: array(:,:) + real(kind=dp), intent(in) :: sigma, mean + + integer :: n, m, i, j + real(kind=dp) :: noise + + + !dims of array + n = size(array,1) + m = size(array,2) + + do i=1,n + do j=1,m + + noise = gaussian_noise_maker(mean,sigma) + + !make sure its not greater than 2 sigma away + !if((noise > 2.0).or.(noise < -2.0)) then + ! noise = gaussian_noise_maker(mean,sigma) + !endif + + array(i,j) = noise + enddo + enddo + return + end subroutine + + subroutine random_gaussian_gen_1d(array,sigma,mean) + !Returns a 2d array of normally distributed + !random numbers and gives you control over sigma + !mean + real(kind=dp), intent(inout) :: array(:) + real(kind=dp), intent(in) :: sigma, mean + + integer :: n, m, i, j + real(kind=dp) :: noise + + + !dims of array + n = size(array,1) + + do i=1,n + noise = gaussian_noise_maker(mean,sigma) + + array(i) = noise + enddo + return + end subroutine + + function gaussian_noise_maker(mean,sigma) result(noise) + !Box-mueller method to get gaussian distributed noise + + real(kind=dp), intent(in) :: sigma, mean + real(kind=dp) :: noise + + real(kind=dp) :: u1, u2 + real(kind=dp), parameter :: twopi=8.0_dp*atan(1.0_dp) + + call random_number(u1) + call random_number(u2) + + noise = mean + sigma*sqrt(-2.0_dp*log(u1))*cos(twopi*u2) + return + end function + + subroutine init_random_seed(worker) + !Get random seed not thread safe!! + integer :: i, n, clock, worker + integer, dimension(:), allocatable :: seed + + call random_seed(size = n) + allocate(seed(n)) + + call system_clock(count=clock) + + seed = clock + (18+worker*12) * (/ (i - 1, i = 1, n) /) + call random_seed(put = seed) + + deallocate(seed) + + return + end + + subroutine init_random_marker(input) + !Get random seed thats thread safe + integer :: i, n, clock, input + integer, dimension(:), allocatable :: seed + + call random_seed(size = n) + allocate(seed(n)) + + seed = (3+input*2) * (/ (i - 1, i = 1, n) /) + call random_seed(put = seed) + + deallocate(seed) + + return + end + + subroutine shuffle(n,returnsize,shufflereturn) + !K-shuffle used to get random choice + integer, intent(in) :: n, returnsize + + integer, dimension(1:n) :: choices, choiceshuffle + integer, dimension(returnsize), intent(out):: shufflereturn + real :: a + + integer :: n_chosen + integer :: this + integer :: tmp + integer :: i + + choices = (/ ( i, i = 1, n ) /) + n_chosen = 0 + do i = 1, n + call random_number( a ) + this = a * ( n - n_chosen ) + 1 + tmp = choices( this ) + choiceshuffle(i) = tmp + choices( this ) = choices( n - n_chosen ) + choices( n - n_chosen ) = tmp + n_chosen = n_chosen + 1 + enddo + shufflereturn = choiceshuffle(1:returnsize) + + return + end subroutine + + subroutine find_closest_divisor(target_,number_,divisor) + !Find closest divisor to target_ for number_ + !Example target_ = 7 number_= 64 then divisor = 8 + + integer, intent(in) :: target_,number_ + integer, intent(out) :: divisor + + integer :: i, radius + + logical :: not_found + + if(modulo(number_,target_) == 0) then + !Horray number_ is divisible by target_ + divisor = target_ + + else + !While loop until divisor is found + !We loop through potential divisors + !until we find one + + not_found = .True. + radius = 2 + + do while(not_found) + + do i=target_-radius,target_+radius + if(mod(number_,i) == 0) then + divisor = i + not_found = .False. + exit + endif + enddo + radius = radius + 1 + enddo + + endif + + return + end subroutine + + subroutine lorenz63(stepcount,dt,xp,yp,zp) + integer, intent(in) :: stepcount + integer :: i + real(kind=dp), intent(in) :: dt + real(kind=dp), parameter :: xi=0.0_dp, yi=1.0_dp, zi=1.05_dp, alpha=0.0_dp + real(kind=dp) :: xdot, ydot, zdot + real(kind=dp), intent(out) :: xp(stepcount+1), yp(stepcount+1),zp(stepcount+1) + + xp(1) = xi + yp(1) = yi + zp(1) = zi + + do i=1,stepcount + call advancelorenz(xp(i),yp(i),zp(i),xdot,ydot,zdot,alpha) + + xp(i+1) = xp(i) + (xdot * dt) + yp(i+1) = yp(i) + (ydot * dt) + zp(i+1) = zp(i) + (zdot * dt) + enddo + return + + end subroutine + + subroutine advancelorenz(x,y,z,xdot,ydot,zdot,alpha) + real(kind=dp), parameter :: s=10.0_dp, r=28.0_dp, b=2.66667_dp + real(kind=dp), intent(in) :: x, y, z, alpha + real(kind=dp), intent(out) :: xdot, ydot, zdot + xdot = s*(y - x) + ydot = (r+alpha)*x - y - x*z + zdot = x*y - b*z + return + + end subroutine + + subroutine tick(t) + integer, intent(OUT) :: t + + call system_clock(t) + end subroutine tick + + ! returns time in seconds from now to time described by t + real function tock(t) + integer, intent(in) :: t + integer :: now, clock_rate + + call system_clock(now,clock_rate) + + tock = real(now - t)/real(clock_rate) + end function tock + + subroutine total_precip_over_a_period(precip_grid,period) + !This routine takes hourly precip and will compute the total precip + !between i-period to i. Will assume the first period elements of precip + !will be padded with 0 + ! + !Period should equal timestep of the hybrid model + ! + !Example precip_grid = [1,0,0,0,0,0,0,1,1,0,0,0,0,0,0] and period = 6 + !hours + !This routine will output precip_grid = [1,1,1,1,1,1,1,0,2,2,2,2,2,2,1,0] + real(kind=dp), intent(inout) :: precip_grid(:,:,:) !Hourly precip data (x,y,t) that + !at exit will be total + !precip over a period + + integer, intent(in) :: period + + !local vars + real(kind=dp), allocatable :: copy(:,:,:) + + integer :: i, j, t + integer :: x_len, y_len, t_len + + x_len = size(precip_grid,1) + y_len = size(precip_grid,2) + t_len = size(precip_grid,3) + + allocate(copy,source=precip_grid) + + print *, 'shape(precip_grid)',shape(precip_grid) + do i=1, x_len + do j=1, y_len + do t=1, t_len + if(t-period < 1) then + precip_grid(i,j,t) = sum(copy(i,j,1:t)) + else + precip_grid(i,j,t) = sum(copy(i,j,t-period:t)) + endif + enddo + enddo + enddo + deallocate(copy) + end subroutine + + subroutine rolling_average_over_a_period(grid,period) + !This routine takes hourly 2d variable and will compute the running + !average. Will assume the first period elements will be + !will be padded with 0 + ! + !Period should equal timestep of the hybrid model + ! + !Example precip_grid = [1,0,0,0,0,0,0,1,1,0,0,0,0,0,0] and period = 6 + !hours + !This routine will output grid = [1,0.5,0.33,0.25,0.2,0.03125,0,0.166,0.333,0.333,0.333,0.333,0.166,0,0] + real(kind=dp), intent(inout) :: grid(:,:,:) !Hourly data (x,y,t) that + !at exit will be + !averag over a period + + integer, intent(in) :: period + + !local vars + real(kind=dp), allocatable :: copy(:,:,:) + + integer :: i, j, t + integer :: x_len, y_len, t_len + + x_len = size(grid,1) + y_len = size(grid,2) + t_len = size(grid,3) + + allocate(copy,source=grid) + + do i=1, x_len + do j=1, y_len + do t=1, t_len + if(t-period < 1) then + grid(i,j,t) = sum(copy(i,j,1:t))/t + else + grid(i,j,t) = sum(copy(i,j,t-period:t))/period + endif + enddo + enddo + enddo + deallocate(copy) + end subroutine + + subroutine rolling_average_over_a_period_2d(grid,period) + !This routine takes hourly 2d variable and will compute the running + !average. Will assume the first period elements will be + !will be padded with 0 + ! + !Period should equal timestep of the hybrid model + ! + !Example precip_grid = [1,0,0,0,0,0,0,1,1,0,0,0,0,0,0] and period = 6 + !hours + !This routine will output grid = + ![1,0.5,0.33,0.25,0.2,0.03125,0,0.166,0.333,0.333,0.333,0.333,0.166,0,0] + real(kind=dp), intent(inout) :: grid(:,:) !Hourly data (x,y,t) that + !at exit will be + !averag over a period + + integer, intent(in) :: period + + !local vars + real(kind=dp), allocatable :: copy(:,:) + + integer :: i, j, t + integer :: x_len, y_len, t_len + + x_len = size(grid,1) + t_len = size(grid,2) + + allocate(copy,source=grid) + + do i=1, x_len + do t=1, t_len + if(t-period < 1) then + grid(i,t) = sum(copy(i,1:t))/t + else + grid(i,t) = sum(copy(i,t-period:t))/period + endif + enddo + enddo + deallocate(copy) + end subroutine + +end module mod_utilities diff --git a/src/mod_var_land.f90 b/src/mod_var_land.f90 new file mode 100755 index 0000000..d7b49f0 --- /dev/null +++ b/src/mod_var_land.f90 @@ -0,0 +1,21 @@ +module mod_var_land + use mod_atparam + + implicit none + + private + public stlcl_ob, snowdcl_ob, soilwcl_ob, stl_am, snowd_am, soilw_am, stl_lm + + ! Daily observed climatological fields over land + real :: stlcl_ob(ix*il) ! clim. land sfc. temperature + real :: snowdcl_ob(ix*il) ! clim. snow depth (water equiv) + real :: soilwcl_ob(ix*il) ! clim. soil water availability + + ! Land sfc. fields used by atmospheric model + real :: stl_am(ix*il) ! land sfc. temperature + real :: snowd_am(ix*il) ! snow depth (water equiv) + real :: soilw_am(ix*il) ! soil water availability + + ! Land sfc. fields from land model + real :: stl_lm(ix*il) ! land-model sfc. temperature +end module diff --git a/src/mod_var_sea.f90 b/src/mod_var_sea.f90 new file mode 100755 index 0000000..385edab --- /dev/null +++ b/src/mod_var_sea.f90 @@ -0,0 +1,57 @@ +module mod_var_sea + use mod_atparam + + implicit none + + private + public sstcl_ob, sicecl_ob, ticecl_ob, sstan_ob, sstcl_om, sst_am, sstan_am + public sice_am, tice_am, sst_om, sice_om, tice_om, ssti_om, wsst_ob + + ! Daily observed climatological fields over sea + ! Observed clim. SST + real :: sstcl_ob(ix*il) + + ! Clim. sea ice fraction + real :: sicecl_ob(ix*il) + + ! Clim. sea ice temperature + real :: ticecl_ob(ix*il) + + ! Daily observed SST anomaly + ! Observed SST anomaly + real :: sstan_ob(ix*il) + + ! Daily climatological fields from ocean model + ! Ocean model clim. SST + real :: sstcl_om(ix*il) + + ! Sea sfc. fields used by atmospheric model + ! SST (full-field) + real :: sst_am(ix*il) + + ! SST anomaly + real :: sstan_am(ix*il) + + ! Sea ice fraction + real :: sice_am(ix*il) + + ! Sea ice temperature + real :: tice_am(ix*il) + + ! Sea sfc. fields from ocean/sea-ice model + ! Ocean model SST + real :: sst_om(ix*il) + + ! Model sea ice fraction + real :: sice_om(ix*il) + + ! Model sea ice temperature + real :: tice_om(ix*il) + + ! Model SST + sea ice temp. + real :: ssti_om(ix*il) + + ! Weight for obs. SST anomaly in coupled runs + ! Weight mask for obs. SST + real :: wsst_ob(ix*il) +end module diff --git a/src/mod_vdicon.f90 b/src/mod_vdicon.f90 new file mode 100755 index 0000000..84c4746 --- /dev/null +++ b/src/mod_vdicon.f90 @@ -0,0 +1,26 @@ +!> @brief +!> Constants for vertical diffusion and shallow convection. +module mod_vdicon + implicit none + + private + public trshc, trvdi, trvds, redshc, rhgrad, segrad + + ! Relaxation time (in hours) for shallow convection + real, parameter :: trshc = 6.0 + + ! Relaxation time (in hours) for moisture diffusion + real, parameter :: trvdi = 24.0 + + ! Relaxation time (in hours) for super-adiab. conditions + real, parameter :: trvds = 6.0 + + ! Reduction factor of shallow conv. in areas of deep conv. + real, parameter :: redshc = 0.5 + + ! Maximum gradient of relative humidity (d_RH/d_sigma) + real, parameter :: rhgrad = 0.5 + + ! Minimum gradient of dry static energy (d_DSE/d_phi) + real, parameter :: segrad = 0.1 +end module diff --git a/src/mpires.f90 b/src/mpires.f90 new file mode 100755 index 0000000..95da9ee --- /dev/null +++ b/src/mpires.f90 @@ -0,0 +1,1226 @@ +module mpires + use iso_fortran_env + + !use mpi_f08 + + use mpi + + use mod_utilities, only : dp, main_type, mpi_type, state_vector_type, & + speedygridnum, xgrid, ygrid, & + zgrid, speedylat, model_parameters_type + use resdomain, only : getxyresextent,getoverlapindices,tileoverlapgrid4d + use mod_io, only : write_netcdf + use mod_calendar, only : calendar, get_current_time_delta_hour + implicit none + + type(mpi_type) :: mpi_res + type(state_vector_type) :: internal_state_vector + + + contains + subroutine startmpi() + !Your basic mpi starting routine for fortran + + call mpi_init(mpi_res%ierr) + call mpi_comm_size(MPI_COMM_WORLD,mpi_res%numprocs,mpi_res%ierr) + call mpi_comm_rank(MPI_COMM_WORLD, mpi_res%proc_num,mpi_res%ierr) + + mpi_res%mpi_world = MPI_COMM_WORLD + + if(mpi_res%proc_num == 0) then + mpi_res%is_root = .true. + endif + + if(mpi_res%numprocs == 1) then + mpi_res%is_serial = .True. + endif + end subroutine + + subroutine killmpi() + if (mpi_res%is_root) print *, 'cleaning up mpi' + + !call MPI_Abort(mpi_res%mpi_world,0, mpi_res%ierr) + call mpi_finalize(mpi_res%ierr) + if(mpi_res%is_root) then + print *, 'killing program' + endif + stop + end subroutine + + subroutine stop_mpi_safe() + if(mpi_res%is_root) print *, 'safely cleaning up mpi' + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + call mpi_finalize(mpi_res%ierr) + stop + end subroutine + + subroutine predictionmpicontroller(res,timestep) + !main routine to do all of the reading and writing for a single time + !step prediction. Also runs the SPEEDY componement of the hybrid + + use mod_io, only : write_truth_local_region_vert_level_mpi, & + write_prediction_local_region_vert_level_mpi, & + read_prediction_local_region_vert_level_mpi, & + read_prediction_local_model_vert_level_mpi, & + write_netcdf_speedy_full_mpi + use resdomain, only : unstandardize_state_vec_res_and_tile_grids, & + input_grid_to_input_statevec_and_standardization, & + unstandardize_state_vec_input_to_grid, & + standardize_grid_res_tile_statevec + use mod_calendar + + integer, intent(in) :: timestep + type(main_type), intent(inout) :: res + + !local variables + integer :: i, j + + real(kind=dp), allocatable :: grid4d(:,:,:,:), grid2d(:,:) + + ! + character(len=21) :: hybrid_out_root + character(len=3) :: file_end + character(len=6) :: trial_word + character(len=2) :: month + character(len=4) :: year + character(len=2) :: day + character(len=2) :: hour + character(len=:), allocatable :: date_file + character(len=:), allocatable :: hybrid_out_file_name + + character(len=9) :: truth_out_root + character(len=:), allocatable :: truth_out_file_name + + character(len=:), allocatable :: speedy_file + + character(len=:), allocatable :: file_path + + logical :: make_file + + file_path = '/scratch/user/troyarcomano/Predictions/Hybrid/' + speedy_file = file_path//'hybrid_speedy_out.nc' + hybrid_out_root='hybrid_prediction_era' + truth_out_root = 'era_truth' + trial_word = 'trial_' + file_end = '.nc' + + + + call get_current_time_delta_hour(calendar,res%model_parameters%traininglength+res%model_parameters%synclength+res%model_parameters%prediction_markers(res%model_parameters%current_trial_number))!*res%model_parameters%timestep+timestep*res%model_parameters%timestep) + + write(year,'(I4.4)') calendar%currentyear + write(month,'(I2.2)') calendar%currentmonth + write(day,'(I2.2)') calendar%currentday + write(hour,'(I2.2)') calendar%currenthour + + date_file = month//'_'//day//'_'//year//'_'//hour + hybrid_out_file_name = file_path//hybrid_out_root//res%model_parameters%trial_name//trial_word//date_file//file_end + + truth_out_file_name = file_path//truth_out_root//res%model_parameters%trial_name//trial_word//date_file//file_end + + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + !print *, 'calling write_prediction_local_region_vert_level_mpi' + call unstandardize_state_vec_res_and_tile_grids(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%outvec,grid4d,grid2d) + !print *, 'grid4d',grid4d(:,1,1,1),'region',res%model_parameters%region_indices(i) + if((timestep == 1).and.(i == 1).and.(j == 1)) then + !print *, 'timestep',timestep,'i',i,'j',j + make_file = .True. + else + make_file = .False. + endif + call write_prediction_local_region_vert_level_mpi(res%grid(i,j),res%model_parameters,mpi_res,grid4d,grid2d,timestep,hybrid_out_file_name,make_file) + + deallocate(grid4d) + deallocate(grid2d) + enddo + enddo + + if(timestep == 1) then + make_file = .True. + else + make_file = .False. + endif + + !if(make_file) then + !call write_netcdf_speedy_full_mpi(timestep,res%model_parameters,speedy_file,mpi_res,make_file) + !endif + + !if(mpi_res%is_root) then + !call run_model(res%model_parameters,timestep,hybrid_out_file_name,grid4d,grid2d) + !endif + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + !if(mpi_res%is_root) then + !call write_netcdf_speedy_full_mpi(timestep,res%model_parameters,speedy_file,mpi_res,.False.,grid4d=grid4d,grid3d=grid2d) + ! deallocate(grid4d) + ! deallocate(grid2d) + !else + !call write_netcdf_speedy_full_mpi(timestep,res%model_parameters,speedy_file,mpi_res,.False.) + !endif + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + call read_prediction_local_region_vert_level_mpi(res%grid(i,j),res%model_parameters,mpi_res,grid4d,grid2d,timestep,hybrid_out_file_name) + call input_grid_to_input_statevec_and_standardization(res%reservoir(i,j),res%grid(i,j),grid4d,grid2d,res%reservoir(i,j)%feedback) + if(res%reservoir(i,j)%tisr_input_bool) then + call get_tisr_by_date(res%reservoir(i,j),res%grid(i,j),res%model_parameters,timestep-1,res%reservoir(i,j)%feedback(res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%tisr_size_input+1:res%reservoir(i,j)%reservoir_numinputs)) + endif + deallocate(grid4d) + deallocate(grid2d) + enddo + enddo + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + print *, 'read_prediction_local_model_vert_level_mpi' + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + call read_prediction_local_model_vert_level_mpi(res%grid(i,j),res%model_parameters,mpi_res,grid4d,grid2d,timestep,speedy_file) + call standardize_grid_res_tile_statevec(res%reservoir(i,j),res%grid(i,j),grid4d,grid2d,res%reservoir(i,j)%local_model) + deallocate(grid4d) + deallocate(grid2d) + enddo + enddo + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + print *, 'write_truth_local_region_vert_level_mpi' + if(timestep == 1) then + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + !Unstandardize here + call unstandardize_state_vec_input_to_grid(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%predictiondata(:,res%model_parameters%synclength/res%model_parameters%timestep),grid4d,grid2d) + call write_truth_local_region_vert_level_mpi(res%grid(i,j),res%model_parameters,mpi_res,grid4d,grid2d,timestep,truth_out_file_name) + enddo + enddo + + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + !Unstandardize here + call unstandardize_state_vec_input_to_grid(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%predictiondata(:,res%model_parameters%synclength/res%model_parameters%timestep+timestep),grid4d,grid2d) + call write_truth_local_region_vert_level_mpi(res%grid(i,j),res%model_parameters,mpi_res,grid4d,grid2d,timestep+1,truth_out_file_name) + enddo + enddo + else!elseif(timestep == -99 ) then + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + call unstandardize_state_vec_input_to_grid(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%predictiondata(:,res%model_parameters%synclength/res%model_parameters%timestep+timestep),grid4d,grid2d) + call write_truth_local_region_vert_level_mpi(res%grid(i,j),res%model_parameters,mpi_res,grid4d,grid2d,timestep+1,truth_out_file_name) + enddo + enddo + endif + + end subroutine + + subroutine sendrecievegrid(res,timestep,ocean_model) + use resdomain, only : tile_4d_and_logp_to_local_state_input, tile_4d_and_logp_state_vec_res1d, unstandardize_state_vec_input, tile_4d_and_logp_full_grid_to_local_res_vec, & + processor_decomposition_manual, getxyresextent, tile_full_grid_with_local_state_vec_res1d, standardize_state_vec_input, standardize_state_vec_res, & + tile_4d_to_local_state_input, tile_full_2d_grid_with_local_res, tile_4d_and_logp_to_local_state_input_slab + + use mod_utilities, only : unstandardize_data, standardize_data_given_pars3d, standardize_data_given_pars1d + + type(main_type), intent(inout) :: res + + integer, intent(in) :: timestep + + logical, intent(in) :: ocean_model + + real(kind=dp), allocatable :: wholegrid4d(:,:,:,:), wholegrid2d(:,:) + real(kind=dp), allocatable :: wholegrid_sst(:,:), wholegrid_precip(:,:) + + real(kind=dp), allocatable :: forecast_4d(:,:,:,:), forecast_2d(:,:) + real(kind=dp), allocatable :: sendreceivedata(:), temp4d(:,:,:,:), temp2d(:,:), temp3d(:,:,:), temp1d(:) + + integer, parameter :: root=0 + integer :: i,j, recieverequest, sendrequest, local_domain_size, receive_size + + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk + integer :: localres_zstart,localres_zend,localreszchunk + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk + integer :: to, from, tag, tag2 + integer :: status(MPI_STATUS_SIZE) + integer :: counter + integer :: proc_num, number_of_regions + integer :: full_grid_num_2ds + + integer, allocatable :: region_indices(:) + + logical, parameter :: setflag=.False. + logical :: localpole,localperiodicboundary + logical, allocatable :: local_sst_flag(:) + + character(len=3) :: file_end + character(len=6) :: trial_word + character(len=2) :: month + character(len=4) :: year + character(len=2) :: day + character(len=2) :: hour + character(len=:), allocatable :: date_file + character(len=:), allocatable :: hybrid_out_file_name + character(len=:), allocatable :: file_path + character(len=:), allocatable :: hybrid_out_root + + !The receiving part of the routine + !Gets all of the outvecs from each worker + !and gives it to the master node (worker == 0) + !Master node reconstructs the whole global set vector and + !then writes it out to the disk + + !print *, "starting receivesend", res%model_parameters%irank + if(mpi_res%is_root) then + allocate(wholegrid4d(res%model_parameters%full_predictvars,xgrid,ygrid,zgrid)) + allocate(wholegrid2d(xgrid,ygrid)) + + allocate(forecast_4d(res%model_parameters%full_predictvars,xgrid,ygrid,zgrid)) + allocate(forecast_2d(xgrid,ygrid)) + + if(ocean_model) then + allocate(wholegrid_sst(xgrid,ygrid)) + wholegrid_sst = res%model_parameters%base_sst_grid + print *, 'allocated local_sst_flag' + allocate(local_sst_flag(mpi_res%numprocs)) + endif + + if(res%model_parameters%precip_bool) then + allocate(wholegrid_precip(xgrid,ygrid)) + wholegrid_precip = 0.0_dp + endif + + !print *, 'root allocated full grids',res%model_parameters%irank + wholegrid4d = 0 + wholegrid2d = 0 + + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + + !print *, 'i,j,root,outvec',i,j,res%reservoir(i,j)%outvec + + call tile_full_grid_with_local_state_vec_res1d(res%model_parameters,res%model_parameters%region_indices(i),j,res%reservoir(i,j)%outvec,wholegrid4d,wholegrid2d,wholegrid_precip) + + enddo + enddo + endif + + tag = 11 + tag2 = 12 + + if(ocean_model) then + if(.not. allocated(local_sst_flag)) allocate(local_sst_flag(1)) + + !print *, 'shape(res%reservoir_special(:,1)%sst_bool_prediction)',shape(res%reservoir_special(:,1)%sst_bool_prediction) + !print *, 'res%reservoir_special(:,1)%sst_bool_prediction',res%reservoir_special(:,1)%sst_bool_prediction + call MPI_Gather(res%reservoir_special(1,1)%sst_bool_prediction, 1, MPI_LOGICAL,local_sst_flag, 1, MPI_LOGICAL, 0 ,mpi_res%mpi_world,mpi_res%ierr) + endif + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + counter = 1 + if(.not.(mpi_res%is_root)) then + !print *, 'sending outvec',res%model_parameters%irank + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + local_domain_size = size(res%reservoir(i,j)%outvec) + + allocate(sendreceivedata(local_domain_size)) + + sendreceivedata = res%reservoir(i,j)%outvec + to = root + + tag = counter + + call MPI_SEND(sendreceivedata,local_domain_size,MPI_DOUBLE_PRECISION,to,tag,mpi_res%mpi_world,mpi_res%ierr) + + deallocate(sendreceivedata) + + counter = counter + 1 + enddo + + if(ocean_model) then + + if(res%reservoir_special(i,1)%sst_bool_prediction) then + local_domain_size = size(res%reservoir_special(i,1)%outvec) + + allocate(sendreceivedata(local_domain_size)) + + sendreceivedata = res%reservoir_special(i,1)%outvec + else + local_domain_size = res%grid_special(i,1)%resxchunk * res%grid_special(i,1)%resychunk + + allocate(sendreceivedata(local_domain_size)) + + sendreceivedata = 272.0_dp + endif + to = root + + tag = counter + + !print *, 'worker',mpi_res%proc_num,'tag',tag,'sending sst_data',sendreceivedata + call MPI_SEND(sendreceivedata,local_domain_size,MPI_DOUBLE_PRECISION,to,tag,mpi_res%mpi_world,mpi_res%ierr) + + deallocate(sendreceivedata) + + counter = counter + 1 + endif + enddo + endif + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + if((mpi_res%is_root)) then + do proc_num=1,mpi_res%numprocs-1 + + !print *, 'root receiving from data from processor',proc_num + call processor_decomposition_manual(proc_num,mpi_res%numprocs,res%model_parameters%number_of_regions,region_indices) + + number_of_regions = size(region_indices) + + counter = 1 + do i=1, number_of_regions + do j=1, res%model_parameters%num_vert_levels + + !print *, 'root i,j',i,j + call getsend_receive_size_res(res%model_parameters,region_indices(i),j,receive_size) + + allocate(sendreceivedata(receive_size)) + + from = proc_num + + tag = counter + + !print *, 'from',from,'tag',tag + call MPI_RECV(sendreceivedata,receive_size,MPI_DOUBLE_PRECISION,from,tag,mpi_res%mpi_world,MPI_STATUS_IGNORE,mpi_res%ierr) + + !print *, 'successfully received from',from,'tag',tag + call tile_full_grid_with_local_state_vec_res1d(res%model_parameters,region_indices(i),j,sendreceivedata,wholegrid4d,wholegrid2d,wholegrid_precip) + + deallocate(sendreceivedata) + + counter = counter + 1 + enddo + if(ocean_model) then + !print *, 'root i,j',i,j + call getsend_receive_size_res_slab(res%model_parameters,region_indices(i),j,receive_size) + + allocate(sendreceivedata(receive_size)) + + from = proc_num + + tag = counter + + call MPI_RECV(sendreceivedata,receive_size,MPI_DOUBLE_PRECISION,from,tag,mpi_res%mpi_world,MPI_STATUS_IGNORE,mpi_res%ierr) + + !print *, 'from',from,'tag',tag,'sst data',sendreceivedata + !print *, 'region_indices(i)',region_indices(i),i + call tile_full_2d_grid_with_local_res(res%model_parameters,region_indices(i),sendreceivedata,wholegrid_sst) + + deallocate(sendreceivedata) + + counter = counter + 1 + endif + enddo + enddo + endif + + if(mpi_res%is_root) then + !Make sure we dont wander too far away from realistic values of + !specific humidity + + where(wholegrid4d(4,:,:,:) < 0.000001) + wholegrid4d(4,:,:,:) = 0.000001 + endwhere + + !where(wholegrid4d(4,:,:,:) > 22) + ! wholegrid4d(4,:,:,:) = 22 + !endwhere + + !print *, 'root starting writing hybrid prediction' + + if(ocean_model) then + do i=1, xgrid + do j=1, ygrid + if(res%model_parameters%sea_mask(i,j) > 0.0) then + wholegrid_sst(i,j) = res%model_parameters%base_sst_grid(i,j) + endif + enddo + enddo + endif + + !NOTE TODO change back + if(ocean_model .and. .not. res%model_parameters%train_on_sst_anomalies) then + where(wholegrid_sst < 272.0) + wholegrid_sst = 272.0_dp + endwhere + endif + + if(res%model_parameters%precip_bool) then + where(wholegrid_precip < 0.00001 ) + wholegrid_precip = 0.0_dp + endwhere + endif + + if(.not. res%model_parameters%ml_only) then + hybrid_out_root='hybrid_prediction_era' + else + hybrid_out_root='ml_prediction_era' + endif + + trial_word = 'trial_' + file_end = '.nc' + + call get_current_time_delta_hour(calendar,res%model_parameters%traininglength+res%model_parameters%synclength+res%model_parameters%prediction_markers(res%model_parameters%current_trial_number)) + write(year,'(I4.4)') calendar%currentyear + write(month,'(I2.2)') calendar%currentmonth + write(day,'(I2.2)') calendar%currentday + write(hour,'(I2.2)') calendar%currenthour + + file_path = '/scratch/user/troyarcomano/Predictions/Hybrid/' + date_file = month//'_'//day//'_'//year//'_'//hour + hybrid_out_file_name = file_path//hybrid_out_root//res%model_parameters%trial_name//trial_word//date_file//file_end + + if(timestep == 1) then + res%model_parameters%prediction_file = hybrid_out_file_name + endif + if(timestep > 1) then + hybrid_out_file_name = res%model_parameters%prediction_file + endif + !Write the hybrid prediction out + print *, 'writing hybrid to', hybrid_out_file_name + print *, 'res%model_parameters%traininglength+res%model_parameters%synclength+res%model_parameters%prediction_markers(res%model_parameters%current_trial_number)',res%model_parameters%traininglength,res%model_parameters%synclength,res%model_parameters%prediction_markers(res%model_parameters%current_trial_number),res%model_parameters%current_trial_number + + full_grid_num_2ds = 1 + if(ocean_model) then + full_grid_num_2ds = full_grid_num_2ds + 1 + endif + + if(res%model_parameters%precip_bool) then + full_grid_num_2ds = full_grid_num_2ds + 1 + endif + + full_grid_num_2ds = 3 + + allocate(temp3d(full_grid_num_2ds,xgrid,ygrid)) + + temp3d = 0.0_dp + + temp3d(1,:,:) = wholegrid2d + + if(ocean_model) then + temp3d(2,:,:) = wholegrid_sst + endif + + if(res%model_parameters%precip_bool) then + temp3d(3,:,:) = wholegrid_precip + endif + + !print *, 'wholegrid_sst',wholegrid_sst + if(ocean_model .or. res%model_parameters%precip_bool) then + call write_netcdf(res%model_parameters,wholegrid4d,temp3d,timestep,hybrid_out_file_name,ocean_model) + !elseif(res%model_parameters%precip_bool .and. .not. ocean_model) then + ! call write_netcdf(res%model_parameters,wholegrid4d,temp3d,timestep,hybrid_out_file_name) + !elseif( .not. res%model_parameters%precip_bool .and. ocean_model) then + ! call write_netcdf_4d_multi_2d_sst_only(res%model_parameters,wholegrid4d,temp3d,timestep,hybrid_out_file_name) + else + call write_netcdf(res%model_parameters,wholegrid4d,wholegrid2d,timestep,hybrid_out_file_name) + endif + deallocate(temp3d) + + !Run SPEEDY in hybrid configuration + if(.not. res%model_parameters%ml_only) then + print *, 'root running model' + call run_model(res%model_parameters,timestep,wholegrid4d,wholegrid2d,wholegrid_sst,forecast_4d,forecast_2d) + endif + endif + + if(timestep == 1) then + !print *, 'calling write_truth_data', res%model_parameters%irank + call write_truth_data(res,timestep) + call write_truth_data(res,timestep+1) + elseif(timestep == -99) then !else + call write_truth_data(res,timestep+1) + endif + + + if(mpi_res%is_root) then + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + + !print *, 'tile_4d_and_logp_to_local_state_input root' + + call tile_4d_and_logp_to_local_state_input(res%model_parameters,res%model_parameters%region_indices(i),j,wholegrid4d,wholegrid2d,wholegrid_precip,res%reservoir(i,j)%feedback(1:res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%tisr_size_input-res%reservoir(i,j)%sst_size_input)) + + if(.not. res%model_parameters%ml_only) then + call tile_4d_and_logp_full_grid_to_local_res_vec(res%model_parameters,res%model_parameters%region_indices(i),j,forecast_4d,forecast_2d,res%reservoir(i,j)%local_model) + + call standardize_state_vec_res(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%local_model) + endif + enddo + enddo + + do proc_num=1,mpi_res%numprocs-1 + + call processor_decomposition_manual(proc_num,mpi_res%numprocs,res%model_parameters%number_of_regions,region_indices) + + number_of_regions = size(region_indices) + + counter = 1 + do i=1, number_of_regions + do j=1, res%model_parameters%num_vert_levels + + call getsend_receive_size_input(res%model_parameters,region_indices(i),j,receive_size) + !print *, 'sending from root to',proc_num,'region num',region_indices(i),receive_size + + allocate(sendreceivedata(receive_size)) + + call tile_4d_and_logp_to_local_state_input(res%model_parameters,region_indices(i),j,wholegrid4d,wholegrid2d,wholegrid_precip,sendreceivedata) + + to = proc_num + + tag = counter + + call MPI_SEND(sendreceivedata,size(sendreceivedata),MPI_DOUBLE_PRECISION,to,tag,mpi_res%mpi_world,mpi_res%ierr) + + counter = counter + 1 + + deallocate(sendreceivedata) + + !Only send speedy data if this is hybrid + if(.not. res%model_parameters%ml_only) then + call getsend_receive_size_speedy(res%model_parameters,region_indices(i),j,receive_size) + + allocate(sendreceivedata(receive_size)) + + call tile_4d_and_logp_full_grid_to_local_res_vec(res%model_parameters,region_indices(i),j,forecast_4d,forecast_2d,sendreceivedata) + + tag = counter + + call MPI_SEND(sendreceivedata,size(sendreceivedata),MPI_DOUBLE_PRECISION,to,tag,mpi_res%mpi_world,mpi_res%ierr) + + deallocate(sendreceivedata) + + counter = counter + 1 + endif + + enddo + if(ocean_model) then + !print *, 'sending slab from root to',proc_num,'region num',region_indices(i) + call getsend_receive_size_input_slab(res%model_parameters,region_indices(i),receive_size) + + allocate(sendreceivedata(receive_size)) + + call tile_4d_and_logp_to_local_state_input_slab(res%model_parameters,region_indices(i),wholegrid_sst,sendreceivedata) + + to = proc_num + + tag = counter + + call MPI_SEND(sendreceivedata,size(sendreceivedata),MPI_DOUBLE_PRECISION,to,tag,mpi_res%mpi_world,mpi_res%ierr) + + counter = counter + 1 + + deallocate(sendreceivedata) + endif + enddo + enddo + endif + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + if(.not.(mpi_res%is_root)) then + counter = 1 + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + call getsend_receive_size_input(res%model_parameters,res%model_parameters%region_indices(i),j,receive_size) + + allocate(sendreceivedata(receive_size)) + + from = root + + tag = counter + + call MPI_RECV(sendreceivedata,receive_size,MPI_DOUBLE_PRECISION,from,tag,mpi_res%mpi_world,MPI_STATUS_IGNORE,mpi_res%ierr) + + res%reservoir(i,j)%feedback(1:res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%tisr_size_input-res%reservoir(i,j)%sst_size_input) = sendreceivedata + !print *, res%model_parameters%irank,'receiving feedback from root for region, level',res%model_parameters%region_indices(i),j,res%reservoir(i,j)%feedback(res%grid(i,j)%precip_start:res%grid(i,j)%precip_end) + + deallocate(sendreceivedata) + + counter = counter + 1 + + if(.not. res%model_parameters%ml_only) then + allocate(sendreceivedata(res%reservoir(i,j)%chunk_size_speedy))!prediction)) + + tag = counter + + call MPI_RECV(sendreceivedata,res%reservoir(i,j)%chunk_size_speedy,MPI_DOUBLE_PRECISION,from,tag,mpi_res%mpi_world,MPI_STATUS_IGNORE,mpi_res%ierr) !prediction,MPI_DOUBLE_PRECISION,from,tag,mpi_res%mpi_world,MPI_STATUS_IGNORE,mpi_res%ierr) + + res%reservoir(i,j)%local_model = sendreceivedata + deallocate(sendreceivedata) + + call standardize_state_vec_res(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%local_model) + counter = counter + 1 + endif + enddo + + if(ocean_model) then + call getsend_receive_size_input_slab(res%model_parameters,res%model_parameters%region_indices(i),receive_size) + + allocate(sendreceivedata(receive_size)) + allocate(temp1d(receive_size)) !Holds input sst data for this + !process from here until the end of the routine + + from = root + + tag = counter + + !print *, res%model_parameters%irank,'receiving slab feedback from root for region, level',res%model_parameters%region_indices(i),j + call MPI_RECV(sendreceivedata,receive_size,MPI_DOUBLE_PRECISION,from,tag,mpi_res%mpi_world,MPI_STATUS_IGNORE,mpi_res%ierr) + + if(res%reservoir_special(i,1)%sst_bool_prediction) then + call standardize_data_given_pars1d(sendreceivedata,res%grid_special(i,1)%mean(res%grid_special(i,1)%sst_mean_std_idx),res%grid_special(i,1)%std(res%grid_special(i,1)%sst_mean_std_idx)) + + res%reservoir_special(i,1)%feedback(res%grid_special(i,1)%sst_start:res%grid_special(i,1)%sst_end) = sendreceivedata + endif + + deallocate(sendreceivedata) + + counter = counter + 1 + endif + enddo + endif + + !Distribute the logical flag to let all workers know if we are going to + !try to make the next prediction + + call MPI_Bcast(res%model_parameters%run_speedy,1,MPI_LOGICAl,0,mpi_res%mpi_world,mpi_res%ierr) + + !Stupid parallel netcdf requires all works so we cannot do it during the + !sending and receiving loops because the root will not be able to + !call get_tisr_by_date + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + if(res%reservoir(i,j)%tisr_input_bool) then + call get_tisr_by_date(res%reservoir(i,j),res%grid(i,j),res%model_parameters,timestep-1,res%reservoir(i,j)%feedback(res%grid(i,j)%tisr_start:res%grid(i,j)%tisr_end)) + if(res%reservoir(i,j)%assigned_region == 36) print *, 'tisr in prediction,level',res%grid(i,j)%level_index,res%reservoir(i,j)%feedback(res%grid(i,j)%tisr_start) + endif + + if(ocean_model) then + if(res%reservoir(i,j)%sst_bool_input) then + res%reservoir(i,j)%feedback(res%grid(i,j)%sst_start:res%grid(i,j)%sst_end) = res%reservoir_special(i,1)%feedback(res%grid_special(i,1)%sst_start:res%grid_special(i,1)%sst_end) + endif + endif + + if(res%reservoir(i,j)%logp_bool) then + call standardize_state_vec_input(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%feedback(1:res%grid(i,j)%logp_end)) + else + call standardize_state_vec_input(res%reservoir(i,j),res%grid(i,j),res%reservoir(i,j)%feedback(1:res%grid(i,j)%atmo3d_end)) + endif + + if(res%reservoir(i,j)%precip_bool) then + call standardize_data_given_pars1d(res%reservoir(i,j)%feedback(res%grid(i,j)%precip_start:res%grid(i,j)%precip_end),res%grid(i,j)%mean(res%grid(i,j)%precip_mean_std_idx),res%grid(i,j)%std(res%grid(i,j)%precip_mean_std_idx)) + endif + + enddo + if(ocean_model) then + if(res%reservoir_special(i,1)%sst_bool_prediction) then + res%reservoir_special(i,1)%averaged_atmo_input_vec(:,mod(timestep-1,res%model_parameters%timestep_slab/res%model_parameters%timestep-1)+1) = res%reservoir(i,j-1)%feedback(res%reservoir_special(i,1)%atmo_training_data_idx) + if(res%reservoir_special(i,1)%assigned_region == 10) print *,'averaged_atmo_input_vec(1,:)',res%reservoir_special(i,1)%averaged_atmo_input_vec(1,:) + res%reservoir_special(i,1)%feedback = sum(res%reservoir_special(i,1)%averaged_atmo_input_vec,dim=2)/(res%model_parameters%timestep_slab/res%model_parameters%timestep-1) !res%reservoir(i,j-1)%feedback(res%reservoir_special(i,1)%atmo_training_data_idx) + if(res%reservoir_special(i,1)%assigned_region == 10) print *,'res%reservoir_special(i,1)%feedback(1)',res%reservoir_special(i,1)%feedback(1) + endif + endif + enddo + return + end subroutine + + subroutine getsend_receive_size_res(model_parameters,region,vert_level,arraysize) + use resdomain, only : get_z_res_extent, getxyresextent + + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: region, vert_level + integer, intent(out) :: arraysize + + !local stuff + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk + integer :: localres_zstart,localres_zend,localreszchunk + + call getxyresextent(model_parameters%number_of_regions,region,localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk) + + call get_z_res_extent(model_parameters%num_vert_levels,vert_level,localres_zstart,localres_zend,localreszchunk) + + arraysize = localresxchunk*localresychunk*localreszchunk*model_parameters%full_predictvars + + if(localres_zend == zgrid) then + arraysize = arraysize + localresxchunk*localresychunk + if(model_parameters%precip_bool) then + arraysize = arraysize + localresxchunk*localresychunk + endif + endif + end subroutine + + subroutine getsend_receive_size_speedy(model_parameters,region,vert_level,arraysize) + use resdomain, only : get_z_res_extent, getxyresextent + + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: region, vert_level + integer, intent(out) :: arraysize + + !local stuff + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk + integer :: localres_zstart,localres_zend,localreszchunk + + call getxyresextent(model_parameters%number_of_regions,region,localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk) + + call get_z_res_extent(model_parameters%num_vert_levels,vert_level,localres_zstart,localres_zend,localreszchunk) + + arraysize = localresxchunk*localresychunk*localreszchunk*model_parameters%full_predictvars + + if(localres_zend == zgrid) then + arraysize = arraysize + localresxchunk*localresychunk + endif + end subroutine + + subroutine getsend_receive_size_res_slab(model_parameters,region,vert_level,arraysize) + use resdomain, only : get_z_res_extent, getxyresextent + + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: region, vert_level + integer, intent(out) :: arraysize + + !local stuff + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk + integer :: localres_zstart,localres_zend,localreszchunk + + call getxyresextent(model_parameters%number_of_regions,region,localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk) + + arraysize = localresxchunk*localresychunk + + end subroutine + + subroutine getsend_receive_size_input(model_parameters,region,vert_level,arraysize) + use resdomain, only : getoverlapindices_vert, getoverlapindices + + type(model_parameters_type), intent(in) :: model_parameters + integer, intent(in) :: region, vert_level + integer, intent(out) :: arraysize + + !local stuff + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk + integer :: localinput_zstart,localinput_zend,localinputzchunk + logical :: localpole,localperiodicboundary,localtop,localbottom + + call getoverlapindices(model_parameters%number_of_regions,region,model_parameters%overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk,localpole,localperiodicboundary,.False.) + + call getoverlapindices_vert(model_parameters%num_vert_levels,vert_level,model_parameters%vert_loc_overlap,localinput_zstart,localinput_zend,localinputzchunk,localtop,localbottom,.False.) + + arraysize = localinputxchunk*localinputychunk*localinputzchunk*model_parameters%full_predictvars + + if(localbottom) then + arraysize = arraysize + localinputxchunk*localinputychunk + if(model_parameters%precip_bool) then + arraysize = arraysize + localinputxchunk*localinputychunk + endif + endif + !print *, 'arraysize',arraysize + end subroutine + + subroutine getsend_receive_size_input_slab(model_parameters,region,arraysize) + use resdomain, only : getoverlapindices_vert, getoverlapindices + + type(model_parameters_type), intent(in) :: model_parameters + integer, intent(in) :: region + integer, intent(out) :: arraysize + + !local stuff + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk + integer :: localinput_zstart,localinput_zend,localinputzchunk + logical :: localpole,localperiodicboundary,localtop,localbottom + + call getoverlapindices(model_parameters%number_of_regions,region,model_parameters%overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk,localpole,localperiodicboundary,.False.) + + + arraysize = localinputxchunk*localinputychunk + + end subroutine + + + subroutine distribute_prediction_marker(model_parameters) + !Routine to get random prediction marker and distribute to the network + use mod_utilities, only : init_random_seed, shuffle, model_parameters_type + + type(model_parameters_type), intent(inout) :: model_parameters + + integer :: i, markertag, status, root + integer :: cycle_length !cylc forecast ever x number of hours + + markertag = 2 + root = 0 + cycle_length = model_parameters%synclength + + allocate(model_parameters%prediction_markers(model_parameters%num_predictions)) + + do i=0,model_parameters%num_predictions-1 + model_parameters%prediction_markers(i+1) = cycle_length*i + enddo + + return + end subroutine + + subroutine write_truth_data(res,timestep) + !subroutine to write the true data to a file + + use resdomain, only : tile_4d_and_logp_state_vec_res1d,tile_4d_and_logp_state_vec_input_to_local_grids,get_trainingdataindices, & + processor_decomposition_manual, get_z_res_extent, unstandardize_state_vec_input + + !input variables + integer, intent(in) :: timestep + + type(main_type), intent(in) :: res + + !local variables + real(kind=dp), allocatable :: wholegrid4d(:,:,:,:), wholegrid2d(:,:) + real(kind=dp), allocatable :: sendreceivedata(:), temp4d(:,:,:,:), temp2d(:,:) + real(kind=dp), allocatable :: copy_truth_vec(:) + + !mpi and grid local variables + integer, parameter :: root=0 + integer :: i, recieverequest, sendrequest + integer(kind=int32) :: from, to, tag, tag2 + integer :: local_domain_size, receive_size + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk + integer :: local_res_zstart,local_res_zend,local_reszchunk + integer :: status(MPI_STATUS_SIZE) + + integer :: counter, proc_num, j, number_of_regions + + integer, allocatable :: region_indices(:) + + logical, parameter :: setflag=.False. + logical :: localpole,localperiodicboundary + + !Filename stuff + character(len=9) :: truth_out_root + character(len=3) :: file_end + character(len=6) :: trial_word + character(len=2) :: month + character(len=4) :: year + character(len=2) :: day + character(len=2) :: hour + character(len=:), allocatable :: date_file + character(len=:), allocatable :: truth_out_file_name + character(len=:), allocatable :: file_path + + + !The receiving part of the routine + !Gets all of the outvecs from each worker + !and gives it to the master node (worker == 0) + !Master node reconstructs the whole global set vector and + !then writes it out to the disk + if(mpi_res%is_root) then + allocate(wholegrid4d(res%model_parameters%full_predictvars,xgrid,ygrid,zgrid)) + allocate(wholegrid2d(xgrid,ygrid)) + + wholegrid4d = 0 + wholegrid2d = 0 + + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + + allocate(temp4d(res%reservoir(i,j)%local_predictvars,res%grid(i,j)%resxchunk,res%grid(i,j)%resychunk,res%reservoir(i,j)%local_heightlevels_res)) + allocate(temp2d(res%grid(i,j)%resxchunk,res%grid(i,j)%resychunk)) + + allocate(copy_truth_vec(res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%tisr_size_input)) + + !print *, 'shape(res%reservoir(i,j)%predictiondata)',shape(res%reservoir(i,j)%predictiondata) + !print *, 'res%model_parameters%synclength/res%model_parameters%timestep+timestep',res%model_parameters%synclength/res%model_parameters%timestep+timestep + copy_truth_vec = res%reservoir(i,j)%predictiondata(1:res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%sst_size_input-res%reservoir(i,j)%tisr_size_input,res%model_parameters%synclength/res%model_parameters%timestep+timestep) + call unstandardize_state_vec_input(res%reservoir(i,j),res%grid(i,j),copy_truth_vec) + + call tile_4d_and_logp_state_vec_input_to_local_grids(res%model_parameters,copy_truth_vec,res%model_parameters%region_indices(i),j,temp4d,temp2d) + + wholegrid4d(:,res%grid(i,j)%res_xstart:res%grid(i,j)%res_xend,res%grid(i,j)%res_ystart:res%grid(i,j)%res_yend,res%grid(i,j)%res_zstart:res%grid(i,j)%res_zend) = temp4d + if(res%reservoir(i,j)%logp_bool) then + wholegrid2d(res%grid(i,j)%res_xstart:res%grid(i,j)%res_xend,res%grid(i,j)%res_ystart:res%grid(i,j)%res_yend) = temp2d + endif + deallocate(temp4d) + deallocate(temp2d) + deallocate(copy_truth_vec) + enddo + enddo + endif + + tag = 11 + tag2 = 12 + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + !TODO instead of doing the do loop then the if statement try + !if(mpi_res%is_root) loop over all workers + !else send data + + counter = 1 + if(.not.(mpi_res%is_root)) then + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + local_domain_size = size(res%reservoir(i,j)%predictiondata(1:res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%tisr_size_input-res%reservoir(i,j)%sst_size_input,res%model_parameters%synclength/res%model_parameters%timestep+timestep)) + + allocate(copy_truth_vec(res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%tisr_size_input-res%reservoir(i,j)%sst_size_input)) + + copy_truth_vec = res%reservoir(i,j)%predictiondata(1:res%reservoir(i,j)%reservoir_numinputs-res%reservoir(i,j)%tisr_size_input-res%reservoir(i,j)%sst_size_input,res%model_parameters%synclength/res%model_parameters%timestep+timestep) + call unstandardize_state_vec_input(res%reservoir(i,j),res%grid(i,j),copy_truth_vec) + + allocate(sendreceivedata(local_domain_size)) + + sendreceivedata = copy_truth_vec + + deallocate(copy_truth_vec) + + !if(res%model_parameters%irank == 1) then + !print *,'proc_num,i,j,local_domain_size,counter',res%model_parameters%irank,i,j,local_domain_size,counter + !print *,'sendreceivedata(1:10)',sendreceivedata(1:10) + !endif + to = root + + tag = counter + + call MPI_SEND(sendreceivedata,local_domain_size,MPI_DOUBLE_PRECISION,to,tag,mpi_res%mpi_world,mpi_res%ierr) + + deallocate(sendreceivedata) + + counter = counter + 1 + enddo + enddo + endif + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + if((mpi_res%is_root)) then + do proc_num=1,mpi_res%numprocs-1 + call processor_decomposition_manual(proc_num,mpi_res%numprocs,res%model_parameters%number_of_regions,region_indices) + + number_of_regions = size(region_indices) + + counter = 1 + do i=1, number_of_regions + do j=1, res%model_parameters%num_vert_levels + call getxyresextent(res%model_parameters%number_of_regions,region_indices(i),localres_xstart,localres_xend,localres_ystart,localres_yend,localresxchunk,localresychunk) + + call get_z_res_extent(res%model_parameters%num_vert_levels,j,local_res_zstart,local_res_zend,local_reszchunk) + + call getsend_receive_size_input(res%model_parameters,region_indices(i),j,receive_size) + + allocate(sendreceivedata(receive_size)) + allocate(temp4d(res%model_parameters%full_predictvars,localresxchunk,localresychunk,local_reszchunk)) + allocate(temp2d(localresxchunk,localresychunk)) + + from = proc_num + + tag = counter + + !print *, 'root receiving from',region_indices(i),'j',j,'receive_size',receive_size + + call MPI_RECV(sendreceivedata,receive_size,MPI_DOUBLE_PRECISION,from,tag,mpi_res%mpi_world,MPI_STATUS_IGNORE,mpi_res%ierr) + + call tile_4d_and_logp_state_vec_input_to_local_grids(res%model_parameters,sendreceivedata,region_indices(i),j,temp4d,temp2d) + + wholegrid4d(:,localres_xstart:localres_xend,localres_ystart:localres_yend,local_res_zstart:local_res_zend) = temp4d + + if(local_res_zend == zgrid) then + wholegrid2d(localres_xstart:localres_xend,localres_ystart:localres_yend) = temp2d + endif + + deallocate(sendreceivedata) + deallocate(temp4d) + deallocate(temp2d) + + counter = counter + 1 + enddo + enddo + enddo + endif + + if(mpi_res%is_root) then + print *, 'root writing truth' + truth_out_root = 'era_truth' + file_end = '.nc' + trial_word = 'trial_' + file_path = '/scratch/user/troyarcomano/Predictions/Hybrid/' + + call get_current_time_delta_hour(calendar,res%model_parameters%traininglength+res%model_parameters%synclength+res%model_parameters%prediction_markers(res%model_parameters%current_trial_number)) + write(year,'(I4.4)') calendar%currentyear + write(month,'(I2.2)') calendar%currentmonth + write(day,'(I2.2)') calendar%currentday + write(hour,'(I2.2)') calendar%currenthour + + date_file = month//'_'//day//'_'//year//'_'//hour + truth_out_file_name = file_path//truth_out_root//res%model_parameters%trial_name//trial_word//date_file//file_end + + print *, 'writing truth to',truth_out_file_name + call write_netcdf(res%model_parameters,wholegrid4d,wholegrid2d,timestep,truth_out_file_name) + endif + + return + end subroutine + + subroutine run_model(model_parameters,timestep,grid4d,grid2d,sst_grid,speedy_grid4d,speedy_grid2d) + use mod_utilities, only : unstandardize_data, standardize_data_given_pars3d, e_constant, model_parameters_type + use mod_io, only : write_netcdf_speedy_full_mpi, read_full_file_4d + use speedy_main + + integer, intent(in) :: timestep + + type(model_parameters_type), intent(inout) :: model_parameters + + real(kind=dp), intent(in) :: grid4d(:,:,:,:) + real(kind=dp), intent(in) :: grid2d(:,:) + real(kind=dp), intent(in), optional :: sst_grid(:,:) + + real(kind=dp), allocatable, intent(out) :: speedy_grid4d(:,:,:,:), speedy_grid2d(:,:) + + !local stuff + real(kind=dp), allocatable :: copy(:,:,:,:) + + integer :: num_of_vars, size_x, size_y, size_z, num_of_standardized_vars + integer :: i + + character(len=:), allocatable :: file_path + character(len=:), allocatable :: speedy_file + + logical :: make_file + + file_path = '/scratch/user/troyarcomano/Predictions/Hybrid/' + speedy_file = file_path//'hybrid_speedy_out.nc' + + call get_current_time_delta_hour(calendar,model_parameters%traininglength+model_parameters%prediction_markers(model_parameters%current_trial_number)+model_parameters%synclength+timestep*model_parameters%timestep) + + print *,'before speedy hour forecast specific humidity',minval(grid4d(4,:,:,:)),maxval(grid4d(4,:,:,:)) + + allocate(copy,source=grid4d) + + where(copy(4,:,:,:) < 0.000001) + copy(4,:,:,:) = 0.000001 + endwhere + + !where(grid4d(4,:,:,:) > 25.0) + ! grid4d(4,:,:,:) = 25.0 + !endwhere + + if(.not. allocated(internal_state_vector%variables3d)) then + num_of_vars = size(grid4d,1) + size_x = size(grid4d,2) + size_y = size(grid4d,3) + size_z = size(grid4d,4) + + allocate(internal_state_vector%variables3d(num_of_vars,size_x,size_y,size_z)) + endif + if(.not. allocated(internal_state_vector%logp)) then + size_x = size(grid4d,2) + size_y = size(grid4d,3) + allocate(internal_state_vector%logp(size_x,size_y)) + endif + + internal_state_vector%is_safe_to_run_speedy = .True. + model_parameters%run_speedy = .True. + + internal_state_vector%hybrid_slab = model_parameters%slab_ocean_model_bool !Doesnt do anything yet + + if(model_parameters%slab_ocean_model_bool) then + if(.not. allocated(internal_state_vector%sst_hybrid)) then + allocate(internal_state_vector%sst_hybrid(size_x,size_y)) + endif + internal_state_vector%sst_hybrid = sst_grid + print *, 'mean hybrid sst',sum(sst_grid)/size(sst_grid) + endif + + internal_state_vector%variables3d = copy !grid4d + internal_state_vector%logp = grid2d + + internal_state_vector%era_hour = 1 !era hour of the month 1 = 00UTC of the first day of + internal_state_vector%era_hour_plus_one = 2!So I dont have to do calendar stuff in + + internal_state_vector%istart = 2 + internal_state_vector%era_start = 3 + + internal_state_vector%iyear0 = calendar%currentyear + internal_state_vector%imont0 = calendar%currentmonth + internal_state_vector%iday = calendar%currentday + internal_state_vector%ihour = calendar%currenthour + + !Slowly adding sst_bias over the whole run + internal_state_vector%sst_bias = (2.0/(model_parameters%predictionlength/3))*(model_parameters%timestep*timestep) + print *, 'timestep, internal_state_vector%sst_bias',timestep, internal_state_vector%sst_bias + + call agcm_main(1,1,internal_state_vector) + + call clean_up_speedy() + + print *, 'after speedy specific humidity',minval(internal_state_vector%variables3d(4,:,:,:)),maxval(internal_state_vector%variables3d(4,:,:,:)) + print *, 'speedy_file',speedy_file + + !call write_netcdf(model_parameters,internal_state_vector%variables3d,internal_state_vector%logp,timestep,speedy_file) + !call write_netcdf_speedy_full_mpi(timestep,model_parameters,speedy_file,mpi_res,internal_state_vector%variables3d,internal_state_vector%logp) + + allocate(speedy_grid4d, source=internal_state_vector%variables3d) + allocate(speedy_grid2d, source=internal_state_vector%logp) + + where(internal_state_vector%variables3d(4,:,:,:) < 0.000001) + internal_state_vector%variables3d(4,:,:,:) = 0.000001_dp + endwhere + + if(internal_state_vector%is_safe_to_run_speedy .eqv. .False.) then + model_parameters%run_speedy = .False. + else + model_parameters%run_speedy = .True. + endif + end subroutine + + subroutine clean_up_speedy() + rewind(21) + rewind(22) + rewind(23) + rewind(24) + rewind(26) + rewind(30) + rewind(2) + rewind(10) + rewind(11) + rewind(13) + rewind(15) + end subroutine + + subroutine get_tisr_by_date(reservoir,grid,model_parameters,timestep,var1d) + use mod_utilities, only : standardize_data_given_pars1d, reservoir_type, grid_type, model_parameters_type + + use mod_calendar, only : numof_hours_into_year,get_current_time_delta_hour + + use mod_io, only : read_3d_file_parallel + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: timestep + + real(kind=dp), intent(inout) :: var1d(:) + + !local + integer :: date_into_year_index + + call get_current_time_delta_hour(calendar,(model_parameters%traininglength+model_parameters%prediction_markers(model_parameters%current_trial_number)+model_parameters%synclength+timestep*model_parameters%timestep)) + call numof_hours_into_year(calendar%currentyear,calendar%currentmonth,calendar%currentday,calendar%currenthour,date_into_year_index) + + if(reservoir%assigned_region == 0) print *,'current date plus timestep',calendar%currentyear,calendar%currentmonth,calendar%currentday,calendar%currenthour,'date_into_year_index',date_into_year_index + + var1d = reshape(reservoir%full_tisr(:,:,date_into_year_index),(/grid%inputxchunk*grid%inputychunk/)) + + !call standardize_data_given_pars1d(var1d,grid%mean(grid%tisr_mean_std_idx),grid%std(grid%tisr_mean_std_idx)) + end subroutine +end module mpires + diff --git a/src/parallelmain.f90 b/src/parallelmain.f90 new file mode 100755 index 0000000..53295a3 --- /dev/null +++ b/src/parallelmain.f90 @@ -0,0 +1,263 @@ +program main + !use mpi_f08 + use mpi + use, intrinsic :: ieee_arithmetic + + use mpires, only : mpi_res, startmpi, distribute_prediction_marker, killmpi, predictionmpicontroller, sendrecievegrid + use mod_reservoir, only : initialize_model_parameters, allocate_res_new, train_reservoir, start_prediction, initialize_prediction, predict, trained_reservoir_prediction, predict_ml + use mod_slab_ocean_reservoir, only : initialize_slab_ocean_model, train_slab_ocean_model, get_training_data_from_atmo, initialize_prediction_slab, start_prediction_slab, predict_slab, predict_slab_ml + use speedy_res_interface, only : startspeedy + use resdomain, only : processor_decomposition, initializedomain, set_reservoir_by_region + use mod_utilities, only : main_type, init_random_seed, dp, gaussian_noise, standardize_data_given_pars4d, standardize_data_given_pars3d, standardize_data, init_random_marker + use mod_calendar + !use mod_unit_tests, only : test_linalg, test_res_domain #TODO not working yet + + implicit none + + integer :: standardizing_vars, i, j, k , t, prediction_num + + logical :: runspeedy = .False. + logical :: trained_model = .False. + logical :: slab_model + + real(kind=dp), allocatable :: test_state(:), test_feedback(:) + + type(main_type) :: res + + !Fortran has command line augs TODO + + !Starts the MPI stuff and initializes mpi_res + call startmpi() + + mpi_res%numprocs = 1152 + + !Makes the object called res and declares all of the main parameters + call initialize_model_parameters(res%model_parameters,mpi_res%proc_num,mpi_res%numprocs) + + !Do domain decomposition based off processors and do vertical localization of + !reservoir + call processor_decomposition(res%model_parameters) + + !Need this for each worker gets a new random seed + call init_random_marker(33) + + !print *, 'model_parameters%region_indices',res%model_parameters%irank,res%model_parameters%region_indices + !print *, 'irank, size(model_parameters%region_indices',res%model_parameters%irank, size(res%model_parameters%region_indices) + + allocate(res%reservoir(res%model_parameters%num_of_regions_on_proc,res%model_parameters%num_vert_levels)) + allocate(res%grid(res%model_parameters%num_of_regions_on_proc,res%model_parameters%num_vert_levels)) + + if(res%model_parameters%slab_ocean_model_bool) then + res%model_parameters%special_reservoirs = .True. + res%model_parameters%num_special_reservoirs = 1 + endif + + !NOTE one day may make precip its own special reservoir + !if(res%model_parameters%precip_bool) then + ! res%model_parameters%num_special_reservoirs = res%model_parameters%num_special_reservoirs + 1 + !endif + + if(res%model_parameters%special_reservoirs) then + allocate(res%reservoir_special(res%model_parameters%num_of_regions_on_proc,res%model_parameters%num_special_reservoirs)) + allocate(res%grid_special(res%model_parameters%num_of_regions_on_proc,res%model_parameters%num_special_reservoirs)) + endif + + !if(res%model_parameters%irank == 4) res%model_parameters%region_indices(1) = 954 + !if(res%model_parameters%irank == 2) res%model_parameters%region_indices(1) = 552 + !if(res%model_parameters%irank == 3) res%model_parameters%region_indices(1) = 36 + + if(.not.(trained_model)) then + !-----------Main Training Loop-------------! + !Main training loop we loop through each region and each level at that region + !for each processor. Every processor has its specific regions + ! + !First we initialize the domain by calling initializedomain which populates + !grid(i,j) with the necessary information about the grid + ! + !Second we initialize the derived type called reservoir by call + !allocate_res_new and makes reservoir(i,j) + ! + !Finally we train the reservoir in the subroutine train_reservoir + + !Loop 1: Loop over all sub domains (regions) on each processor + do i=1,res%model_parameters%num_of_regions_on_proc + + !Loop 2: Loop over each vertical level for a particular sub domain + do j=1,res%model_parameters%num_vert_levels + + call initializedomain(res%model_parameters%number_of_regions,res%model_parameters%region_indices(i), & + res%model_parameters%overlap,res%model_parameters%num_vert_levels,j,res%model_parameters%vert_loc_overlap, & + res%grid(i,j)) + + + res%grid(i,j)%level_index = j + + print *,'region,level,input_zstart,nput_zend,inputzchunk,b,t',res%model_parameters%region_indices(i),j,res%grid(i,j)%input_zstart,res%grid(i,j)%input_zend,res%grid(i,j)%inputzchunk,res%grid(i,j)%bottom,res%grid(i,j)%top + print *,'region,level,resxchunk,resychunk,reszchunk',res%model_parameters%region_indices(i),j,res%grid(i,j)%resxchunk,res%grid(i,j)%resychunk,res%grid(i,j)%reszchunk + print *,'region,level,res_zstart,res_zend',res%model_parameters%region_indices(i),j,res%grid(i,j)%res_zstart,res%grid(i,j)%res_zend + print *,'region,level,input_ystart,input_yend,inputychunk',res%model_parameters%region_indices(i),j,res%grid(i,j)%input_ystart,res%grid(i,j)%input_yend,res%grid(i,j)%inputychunk + print *, 'region,level,tdata_yend',res%grid(i,j)%tdata_yend + + res%reservoir(i,j)%assigned_region = res%model_parameters%region_indices(i) + + !print *, 'res%reservoir(i,j):reservoir_numinputs,chunk_size_prediction',res%reservoir(i,j)%reservoir_numinputs, res%reservoir(i,j)%chunk_size_prediction + call train_reservoir(res%reservoir(i,j),res%grid(i,j),res%model_parameters) + enddo + + !Lets do all of the training for these special reservoirs for each sub + !region + if(res%model_parameters%slab_ocean_model_bool) then + call initializedomain(res%model_parameters%number_of_regions,res%model_parameters%region_indices(i), & + res%model_parameters%overlap,res%model_parameters%num_vert_levels,j-1,res%model_parameters%vert_loc_overlap, & + res%grid_special(i,1)) + + + res%grid_special(i,1)%level_index = j-1 + + res%reservoir_special(i,1)%assigned_region = res%model_parameters%region_indices(i) + + print *, 'i,j',i,j,res%grid(i,j-1)%level_index,res%grid(i,j-1)%bottom,res%reservoir(i,j-1)%sst_bool_input + print *, 'shape(res%reservoir(i,j-1)%trainingdata)',shape(res%reservoir(i,j-1)%trainingdata) + + call get_training_data_from_atmo(res%reservoir_special(i,1),res%model_parameters,res%grid_special(i,1),res%reservoir(i,j-1),res%grid(i,j-1)) + !We only want to train regions with oceans and or lakes + if(res%reservoir_special(i,1)%sst_bool_prediction) then + call initialize_slab_ocean_model(res%reservoir_special(i,1),res%grid_special(i,1),res%model_parameters) + call train_slab_ocean_model(res%reservoir_special(i,1),res%grid_special(i,1),res%model_parameters) + + test_feedback = res%reservoir_special(i,1)%trainingdata(:,res%model_parameters%traininglength) + test_state = res%reservoir_special(i,1)%saved_state + deallocate(res%reservoir_special(i,1)%trainingdata) + else + print *, 'i,j not training slab ocean',i,j + endif + endif + + enddo + endif + + !If we already trained and are just reading in files then we go here + if(trained_model) then + !Loop 1: Loop over all sub domains (regions) on each processor + print *, 'res%model_parameters%num_of_regions_on_proc',res%model_parameters%num_of_regions_on_proc + do i=1, res%model_parameters%num_of_regions_on_proc + print *, 'i', i + !Loop 2: Loop over each vertical level for a particular sub domain + do j=1,res%model_parameters%num_vert_levels + print *, 'j', j + print *, 'doing initializedomain' + call initializedomain(res%model_parameters%number_of_regions,res%model_parameters%region_indices(i), & + res%model_parameters%overlap,res%model_parameters%num_vert_levels,j,res%model_parameters%vert_loc_overlap, & + res%grid(i,j)) + + + res%reservoir(i,j)%assigned_region = res%model_parameters%region_indices(i) + res%grid(i,j)%level_index = j + + print *, 'doing allocate_res_new' + call allocate_res_new(res%reservoir(i,j),res%grid(i,j),res%model_parameters) + + print *, 'doing trained_reservoir_prediction' + + call initialize_calendar(calendar,1990,1,1,0) + + call trained_reservoir_prediction(res%reservoir(i,j),res%model_parameters,res%grid(i,j)) + + enddo + enddo + print *, 'done reading trained model' + endif + + !Initialize Prediction + !Loop through all of the regions and vertical levels + do i=1,res%model_parameters%num_of_regions_on_proc + do j=1,res%model_parameters%num_vert_levels + print *,'region,level',res%reservoir(i,j)%assigned_region,res%grid(i,j)%level_index + call initialize_prediction(res%reservoir(i,j),res%model_parameters,res%grid(i,j)) + enddo + + if(res%model_parameters%slab_ocean_model_bool) then + if(res%reservoir_special(i,1)%sst_bool_prediction) then + call initialize_prediction_slab(res%reservoir_special(i,1),res%model_parameters,res%grid_special(i,1),res%reservoir(i,j-1),res%grid(i,j-1)) + endif + endif + enddo + + !Main prediction loop. + !Loop 1 through the user specified number of predictions + !Loop 2 through time for a specific prediction + !Loop 3/4 over the number of regions on the processor and all of the vertical + !levels for a region + do prediction_num=1, res%model_parameters%num_predictions + do t=1, res%model_parameters%predictionlength/res%model_parameters%timestep + if(t == 1) then + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1,res%model_parameters%num_vert_levels + if(res%reservoir(i,j)%assigned_region == 954) print *, 'starting start_prediction region',res%model_parameters%region_indices(i),'prediction_num prediction_num',prediction_num + call start_prediction(res%reservoir(i,j),res%model_parameters,res%grid(i,j),prediction_num) + enddo + if(res%model_parameters%slab_ocean_model_bool) then + if(res%reservoir_special(i,1)%sst_bool_prediction) then + call start_prediction_slab(res%reservoir_special(i,1),res%model_parameters,res%grid_special(i,1),res%reservoir(i,j-1),res%grid(i,j-1),prediction_num) + endif + endif + enddo + endif + do i=1, res%model_parameters%num_of_regions_on_proc + do j=1, res%model_parameters%num_vert_levels + if(res%reservoir(i,j)%assigned_region == 954) print *, 'calling predict' + if(res%model_parameters%ml_only) then + call predict_ml(res%reservoir(i,j),res%model_parameters,res%grid(i,j),res%reservoir(i,j)%saved_state) + res%model_parameters%run_speedy = .True. + else + call predict(res%reservoir(i,j),res%model_parameters,res%grid(i,j),res%reservoir(i,j)%saved_state,res%reservoir(i,j)%local_model) + endif + enddo + !print *, 'mod((t-1)*res%model_parameters%timestep,res%model_parameters%timestep_slab)',mod((t-1)*res%model_parameters%timestep,res%model_parameters%timestep_slab) + if(res%model_parameters%slab_ocean_model_bool) then + if(mod((t)*res%model_parameters%timestep,res%model_parameters%timestep_slab) == 0 .and. res%reservoir_special(i,1)%sst_bool_prediction) then + if(res%reservoir_special(i,1)%assigned_region == 954) print *, 'calling predict slab' + !TODO rolling_average_over_a_period(grid,period) + !if( t > 28) then + ! res%reservoir_special(i,1)%local_model = res%reservoir_special(i,1)%outvec + !endif + if(res%model_parameters%ml_only_ocean) then + !if(t*res%model_parameters%timestep < res%model_parameters%timestep_slab*2) then + ! res%reservoir_special(i,1)%saved_state = test_state!res%reservoir_special(i,1)%saved_state!test_state + ! res%reservoir_special(i,1)%feedback = test_feedback!res%reservoir_special(i,1)%feedback!test_feedback + !endif + call predict_slab_ml(res%reservoir_special(i,1),res%model_parameters,res%grid_special(i,1),res%reservoir_special(i,1)%saved_state) + else + call predict_slab(res%reservoir_special(i,1),res%model_parameters,res%grid_special(i,1),res%reservoir_special(i,1)%saved_state,res%reservoir_special(i,1)%local_model) + endif + endif + endif + enddo + + + if(res%model_parameters%slab_ocean_model_bool) then !if(mod(t*res%model_parameters%timestep,res%model_parameters%timestep_slab) == 0) then + slab_model = .True. + else + slab_model = .False. + endif + + if(mpi_res%is_root) print *, 'sending data and writing predictions','prediction_num prediction_num',prediction_num,'time',t + + call sendrecievegrid(res,t,slab_model) + + if(res%model_parameters%run_speedy .eqv. .False.) then + exit + endif + enddo + enddo + + call MPI_Barrier(mpi_res%mpi_world, mpi_res%ierr) + + call mpi_finalize(mpi_res%ierr) + + if(res%model_parameters%irank == 0) then + print *, 'program finished correctly' + endif + +end program + diff --git a/src/phy_convmf.f90 b/src/phy_convmf.f90 new file mode 100755 index 0000000..ef4c0ec --- /dev/null +++ b/src/phy_convmf.f90 @@ -0,0 +1,238 @@ +!fk#if !defined(KNMI) +subroutine convmf (psa,se,qa,qsat,itop,cbmf,precnv,dfse,dfqa) +!fk#else +!fkSUBROUTINE CONVMF (PSA,SE,QA,QSAT,TS,ITOP,CBMF,PRECNV,SNOWCV,DFSE,DFQA) +!fk#endif + ! SUBROUTINE CONVMF (PSA,SE,QA,QSAT, + ! * ITOP,CBMF,PRECNV,DFSE,DFQA) + ! + ! Purpose: Compute convective fluxes of dry static energy and moisture + ! using a simplified mass-flux scheme + ! Input: PSA = norm. surface pressure [p/p0] (2-dim) + ! SE = dry static energy (3-dim) + ! QA = specific humidity [g/kg] (3-dim) + ! QSAT = saturation spec. hum. [g/kg] (3-dim) + ! Output: ITOP = top of convection (layer index) (2-dim) + ! CBMF = cloud-base mass flux (2-dim) + ! PRECNV = convective precipitation [g/(m^2 s)] (2-dim) + ! DFSE = net flux of d.s.en. into each atm. layer (3-dim) + ! DFQA = net flux of sp.hum. into each atm. layer (3-dim) + ! + + use mod_cnvcon + use mod_atparam + use mod_physcon, only: p0, gg, alhc, alhs, sig, dsig, wvi + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real, intent(in) :: psa(ngp), se(ngp,nlev), qa(ngp,nlev), qsat(ngp,nlev) + + integer, intent(inout) :: itop(ngp) + real, intent(inout) :: cbmf(ngp), precnv(ngp), dfse(ngp,nlev), dfqa(ngp,nlev) + !fk#if defined(KNMI) + !fkreal :: ts(ngp),snowcv(ngp) + !fk#endif + + integer :: j, k, k1, ktop1, ktop2, nl1, nlp + real :: mss(ngp,2:nlev), mse0, mse1, mss0, mss2, msthr, qdif(ngp) + real :: entr(2:nlev-1), delq, enmass, fdq, fds, fm0, fmass, fpsa, fqmax + real :: fsq, fuq, fus, qb, qmax, qsatb, qthr0, qthr1, rdps, rlhc, sb, sentr + logical :: lqthr + + ! 1. Initialization of output and workspace arrays + nl1=nlev-1 + nlp=nlev+1 + fqmax=5. + + fm0=p0*dsig(nlev)/(gg*trcnv*3600) + rdps=2./(1.-psmin) + + ! Used in exp 566 to 604: + ! psmin=0.8 + ! rdps=1./(1.-psmin) + + dfse = 0.0 + dfqa = 0.0 + + cbmf = 0.0 + precnv = 0.0 + !fk#if defined(KNMI) + !fksnowcv=0.0 + !fk#endif + + ! Saturation moist static energy + do k=2,nlev + do j=1,ngp + !fk#if !defined(KNMI) + mss(j,k)=se(j,k)+alhc*qsat(j,k) + !fk#else + !fkif (ts(j).gt.273.15) then + !fk mss(j,k)=se(j,k)+alhc*qsat(j,k) + !fkelse + !fk mss(j,k)=se(j,k)+alhs*qsat(j,k) + !fkend if + !fk#endif + end do + end do + + ! Entrainment profile (up to sigma = 0.5) + sentr=0. + do k=2,nl1 + entr(k)=(max(0.,sig(k)-0.5))**2 + sentr=sentr+entr(k) + end do + + sentr=entmax/sentr + entr(2:nl1) = entr(2:nl1) * sentr + + ! 2. Check of conditions for convection + rlhc=1./alhc + + do j=1,ngp + itop(j)=nlp + + if (psa(j).gt.psmin) then + ! Minimum of moist static energy in the lowest two levels + mse0=se(j,nlev)+alhc*qa(j,nlev) + mse1=se(j,nl1) +alhc*qa(j,nl1) + mse1=min(mse0,mse1) + + ! Saturation (or super-saturated) moist static energy in PBL + mss0=max(mse0,mss(j,nlev)) + + ktop1=nlev + ktop2=nlev + + do k=nlev-3,3,-1 + mss2=mss(j,k)+wvi(k,2)*(mss(j,k+1)-mss(j,k)) + + ! Check 1: conditional instability + ! (MSS in PBL > MSS at top level) + if (mss0.gt.mss2) then + ktop1=k + end if + + ! Check 2: gradient of actual moist static energy + ! between lower and upper troposphere + if (mse1.gt.mss2) then + ktop2=k + msthr=mss2 + end if + end do + + if (ktop1.lt.nlev) then + ! Check 3: RH > RH_c at both k=NLEV and k=NL1 + qthr0=rhbl*qsat(j,nlev) + qthr1=rhbl*qsat(j,nl1) + lqthr=(qa(j,nlev).gt.qthr0.and.qa(j,nl1).gt.qthr1) + + if (ktop2.lt.nlev) then + itop(j)=ktop1 + qdif(j)=max(qa(j,nlev)-qthr0,(mse0-msthr)*rlhc) + else if (lqthr) then + itop(j)=ktop1 + qdif(j)=qa(j,nlev)-qthr0 + end if + end if + end if + end do + + ! 3. Convection over selected grid-points + do j=1,ngp + if (itop(j).eq.nlp) cycle + + ! 3.1 Boundary layer (cloud base) + k =nlev + k1=k-1 + + ! Maximum specific humidity in the PBL + qmax=max(1.01*qa(j,k),qsat(j,k)) + + ! Dry static energy and moisture at upper boundary + sb=se(j,k1)+wvi(k1,2)*(se(j,k)-se(j,k1)) + qb=qa(j,k1)+wvi(k1,2)*(qa(j,k)-qa(j,k1)) + qb=min(qb,qa(j,k)) + + ! Cloud-base mass flux, computed to satisfy: + ! fmass*(qmax-qb)*(g/dp)=qdif/trcnv + fpsa=psa(j)*min(1.,(psa(j)-psmin)*rdps) + fmass=fm0*fpsa*min(fqmax,qdif(j)/(qmax-qb)) + cbmf(j)=fmass + + ! Upward fluxes at upper boundary + fus=fmass*se(j,k) + fuq=fmass*qmax + + ! Downward fluxes at upper boundary + fds=fmass*sb + fdq=fmass*qb + + ! Net flux of dry static energy and moisture + dfse(j,k)=fds-fus + dfqa(j,k)=fdq-fuq + + ! 3.2 Intermediate layers (entrainment) + do k=nlev-1,itop(j)+1,-1 + k1=k-1 + + ! Fluxes at lower boundary + dfse(j,k)=fus-fds + dfqa(j,k)=fuq-fdq + + ! Mass entrainment + enmass=entr(k)*psa(j)*cbmf(j) + fmass=fmass+enmass + + ! Upward fluxes at upper boundary + fus=fus+enmass*se(j,k) + fuq=fuq+enmass*qa(j,k) + + ! Downward fluxes at upper boundary + sb=se(j,k1)+wvi(k1,2)*(se(j,k)-se(j,k1)) + qb=qa(j,k1)+wvi(k1,2)*(qa(j,k)-qa(j,k1)) + fds=fmass*sb + fdq=fmass*qb + + ! Net flux of dry static energy and moisture + dfse(j,k)=dfse(j,k)+fds-fus + dfqa(j,k)=dfqa(j,k)+fdq-fuq + + ! Secondary moisture flux + delq=rhil*qsat(j,k)-qa(j,k) + if (delq.gt.0.0) then + fsq=smf*cbmf(j)*delq + dfqa(j,k) =dfqa(j,k) +fsq + dfqa(j,nlev)=dfqa(j,nlev)-fsq + end if + end do + + ! 3.3 Top layer (condensation and detrainment) + k=itop(j) + + ! Flux of convective precipitation + qsatb=qsat(j,k)+wvi(k,2)*(qsat(j,k+1)-qsat(j,k)) + + !fk#if !defined(KNMI) + precnv(j)=max(fuq-fmass*qsatb,0.0) + + ! Net flux of dry static energy and moisture + dfse(j,k)=fus-fds+alhc*precnv(j) + dfqa(j,k)=fuq-fdq-precnv(j) + !fk#else + !fkif (ts(j).gt.273.15) then + !fk precnv(j)=max(fuq-fmass*qsatb,0.0) + !fk ! Net flux of dry static energy and moisture + !fk dfse(j,k)=fus-fds+alhc*precnv(j) + !fk dfqa(j,k)=fuq-fdq-precnv(j) + !fkelse + !fk snowcv(j)=max(fuq-fmass*qsatb,0.0) + !fk precnv(j)=snowcv(j) + !fk ! Net flux of dry static energy and moisture + !fk dfse(j,k)=fus-fds+alhs*snowcv(j) + !fk dfqa(j,k)=fuq-fdq-snowcv(j) + !fkend if + !fk#endif + end do +end diff --git a/src/phy_lscond.f90 b/src/phy_lscond.f90 new file mode 100755 index 0000000..e75fa41 --- /dev/null +++ b/src/phy_lscond.f90 @@ -0,0 +1,109 @@ +!fk#if !defined(KNMI) +subroutine lscond(psa,qa,qsat,itop,precls,dtlsc,dqlsc) +!fk#else +!fksubroutine lscond (psa,qa,qsat,ts,itop,precls,snowls,dtlsc,dqlsc) +!fk#endif + ! subroutine lscond (psa,qa,qsat, + ! * itop,precls,dtlsc,dqlsc) + ! + ! Purpose: Compute large-scale precipitation and + ! associated tendencies of temperature and moisture + ! Input: psa = norm. surface pressure [p/p0] (2-dim) + ! qa = specific humidity [g/kg] (3-dim) + ! qsat = saturation spec. hum. [g/kg] (3-dim) + ! itop = top of convection (layer index) (2-dim) + ! Output: itop = top of conv+l.s.condensat.(layer index) (2-dim) + ! precls = large-scale precipitation [g/(m^2 s)] (2-dim) + ! dtlsc = temperature tendency from l.s. cond (3-dim) + ! dqlsc = hum. tendency [g/(kg s)] from l.s. cond (3-dim) + + use mod_lsccon + use mod_atparam + use mod_physcon, only: p0, gg, cp, alhc, alhs, sig, dsig + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real, intent(in) :: psa(ngp), qa(ngp,nlev), qsat(ngp,nlev) + + integer, intent(inout) :: itop(ngp) + real, intent(inout) :: precls(ngp), dtlsc(ngp,nlev), dqlsc(ngp,nlev) + !fk#if defined(KNMI) + !fkreal, intent(in) :: ts(ngp) + !fkreal, intent(inout) :: snowls(ngp) + !fk#endif + + integer :: j, k + real :: psa2(ngp), dqa, dqmax, pfact, prg, qsmax, rhref, rtlsc, sig2, tfact + + ! 1. Initialization + qsmax = 10. + + rtlsc = 1./(trlsc*3600.) + tfact = alhc/cp + !fk#if defined(KNMI) + !fktfacts= alhs/cp + !fk#endif + prg = p0/gg + + dtlsc(:,1) = 0. + dqlsc(:,1) = 0. + precls = 0. + !fk#if defined(KNMI) + !fksnowls = 0. + !fk#endif + do j=1,ngp + psa2(j) = psa(j)*psa(j) + end do + + ! 2. Tendencies of temperature and moisture + ! NB. A maximum heating rate is imposed to avoid + ! grid-point-storm instability + do k=2,nlev + sig2=sig(k)*sig(k) + rhref = rhlsc+drhlsc*(sig2-1.) + if (k.eq.nlev) rhref = max(rhref,rhblsc) + dqmax = qsmax*sig2*rtlsc + + do j=1,ngp + dqa = rhref*qsat(j,k)-qa(j,k) + if (dqa.lt.0.0) then + itop(j) = min(k,itop(j)) + dqlsc(j,k) = dqa*rtlsc + !fk#if !defined(KNMI) + dtlsc(j,k) = tfact*min(-dqlsc(j,k),dqmax*psa2(j)) + !fk#else + !fkif (ts(j).gt.273.15) then + !fk dtlsc(j,k) = tfact*min(-dqlsc(j,k),dqmax*psa2(j)) + !fkelse + !fk dtlsc(j,k) = tfacts*min(-dqlsc(j,k),dqmax*psa2(j)) + !fkend if + !fk#endif + else + dqlsc(j,k) = 0. + dtlsc(j,k) = 0. + endif + end do + end do + + ! 3. Large-scale precipitation + do k=2,nlev + pfact = dsig(k)*prg + do j=1,ngp + precls(j) = precls(j)-pfact*dqlsc(j,k) + !fk#if defined(KNMI) + !fkif (ts(j).lt.273.15) then + !fk snowls(j) = snowls(j)-pfact*dqlsc(j,k) + !fkendif + !fk#endif + end do + end do + + do j=1,ngp + precls(j) = precls(j)*psa(j) + !fk#if defined(KNMI) + !fksnowls(j) = snowls(j)*psa(j) + !fk#endif + end do +end diff --git a/src/phy_phypar.f90 b/src/phy_phypar.f90 new file mode 100755 index 0000000..c214554 --- /dev/null +++ b/src/phy_phypar.f90 @@ -0,0 +1,332 @@ +subroutine phypar(vor1,div1,t1,q1,phi1,psl1,utend,vtend,ttend,qtend) + ! subroutine phypar(vor1,div1,t1,q1,phi1,psl1, + ! & utend,vtend,ttend,qtend) + ! + ! Purpose: compute physical parametrization tendencies for u, v, t, q + ! and add them to dynamical grid-point tendencies + ! Input-only arguments: vor1 : vorticity (sp) + ! div1 : divergence (sp) + ! t1 : temperature (sp) + ! q1 : specific humidity (sp) + ! phi1 : geopotential (sp) + ! psl1 : log of sfc pressure (sp) + ! Input-output arguments: utend : u-wind tendency (gp) + ! vtend : v-wind tendency (gp) + ! ttend : temp. tendency (gp) + ! qtend : spec. hum. tendency (gp) + ! Modified common blocks: phygr1, phygr2, phygr3, phyten, fluxes + + use mod_cpl_flags, only: icsea + use mod_lflags, only: lradsw, lrandf + use mod_atparam + use mod_physcon, only: sig, sigh, grdsig, grdscp, cp + use mod_surfcon, only: fmask1, phis0 + use mod_var_land, only: stl_am, soilw_am + use mod_var_sea, only: sst_am, ssti_om + use mod_physvar + use mod_sppt, only: mu, gen_sppt + use mod_tsteps, only: sppt_on + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + complex, dimension(mx,nx,nlev) :: vor1, div1, t1, q1, phi1 + complex, dimension(mx,nx) :: psl1, ucos, vcos + + real, dimension(ngp,nlev) :: utend, vtend, ttend, qtend + real, dimension(ngp,nlev) :: utend_dyn, vtend_dyn, ttend_dyn, qtend_dyn + + integer :: iptop(ngp), icltop(ngp,2), icnv(ngp), iitest=0, j, k + real, dimension(ngp) :: rps, gse + real :: sppt(ngp,kx) + + ! Keep a copy of the original (dynamics only) tendencies + utend_dyn = utend + vtend_dyn = vtend + ttend_dyn = ttend + qtend_dyn = qtend + + ! 1. Compute grid-point fields + ! 1.1 Convert model spectral variables to grid-point variables + if (iitest.eq.1) print *, ' 1.1 in phypar' + + do k=1,nlev + call uvspec(vor1(1,1,k),div1(1,1,k),ucos,vcos) + call grid(ucos,ug1(1,k),2) + call grid(vcos,vg1(1,k),2) + end do + + do k=1,nlev + call grid(t1(1,1,k), tg1(1,k), 1) + call grid(q1(1,1,k), qg1(1,k), 1) + call grid(phi1(1,1,k),phig1(1,k),1) + end do + + call grid(psl1,pslg1,1) + + + ! Remove negative humidity values + !call qneg () + !where(qg1 < 0.0) + ! qg1 = 0.0 + !end where + + print *, 'min max qp1',minval(qg1),maxval(qg1) + ! 1.2 Compute thermodynamic variables + if (iitest.eq.1) print *, ' 1.2 in phypar' + + do j=1,ngp + psg(j)=exp(pslg1(j)) + rps(j)=1./psg(j) + end do + + do k=1,nlev + do j=1,ngp + ! Remove when qneg is implemented + qg1(j,k)=max(qg1(j,k),0.) + se(j,k)=cp*tg1(j,k)+phig1(j,k) + end do + end do + + do k=1,nlev + call shtorh(1,ngp,tg1(1,k),psg,sig(k),qg1(1,k),rh(1,k),qsat(1,k)) + end do + + ! 2. Precipitation + ! 2.1 Deep convection + call convmf(psg,se,qg1,qsat,iptop,cbmf,precnv,tt_cnv,qt_cnv) + + do k=2,nlev + do j=1,ngp + tt_cnv(j,k) = tt_cnv(j,k)*rps(j)*grdscp(k) + qt_cnv(j,k) = qt_cnv(j,k)*rps(j)*grdsig(k) + end do + end do + + do j=1,ngp + icnv(j)=nlev-iptop(j) + end do + + ! 2.2 Large-scale condensation +!fk#if !defined(KNMI) + call lscond(psg,qg1,qsat,iptop,precls,tt_lsc,qt_lsc) +!fk#else +!fk call lscond (psg,qg1,qsat,ts,iptop,precls,snowls,tt_lsc,qt_lsc) +!fk#end if + + ttend = ttend + tt_cnv + tt_lsc + qtend = qtend + qt_cnv + qt_lsc + + ! 3. Radiation (shortwave and longwave) and surface fluxes + ! 3.1 Compute shortwave tendencies and initialize lw transmissivity + if (iitest.eq.1) print *, ' 3.1 in PHYPAR' + + ! The sw radiation may be called at selected time steps + if (lradsw) then + do j=1,ngp + gse(j) = (se(j,nlev-1)-se(j,nlev))/(phig1(j,nlev-1)-phig1(j,nlev)) + end do + + call cloud(qg1,rh,precnv,precls,iptop,gse,fmask1,icltop,cloudc,clstr) + + do j=1,ngp + cltop(j)=sigh(icltop(j,1)-1)*psg(j) + prtop(j)=float(iptop(j)) + end do + + call radsw(psg,qg1,icltop,cloudc,clstr,ssrd,ssr,tsr,tt_rsw) + + do k=1,nlev + do j=1,ngp + tt_rsw(j,k)=tt_rsw(j,k)*rps(j)*grdscp(k) + end do + end do + end if + + ! 3.2 Compute downward longwave fluxes + call radlw(-1,tg1,ts,slrd,slru(1,3),slr,olr,tt_rlw) + + ! 3.3. Compute surface fluxes and land skin temperature + if (iitest.eq.1) then + print *, ' 3.3 in PHYPAR' + print *, 'mean(STL_AM) =', sum(STL_AM(:))/ngp + print *, 'mean(SST_AM) =', sum(SST_AM(:))/ngp + end if + + call suflux(psg,ug1,vg1,tg1,qg1,rh,phig1,phis0,fmask1,stl_am,sst_am,& + & soilw_am,ssrd,slrd,ustr,vstr,shf,evap,slru,hfluxn,ts,tskin,u0,v0,t0,& + & q0,.true.) + + ! 3.3.1. Recompute sea fluxes in case of anomaly coupling + if (icsea .gt. 0) then + call suflux(psg,ug1,vg1,tg1,qg1,rh,phig1,phis0,fmask1,stl_am,ssti_om,& + & soilw_am,ssrd,slrd,ustr,vstr,shf,evap,slru,hfluxn,ts,tskin,u0,v0,& + & t0,q0,.false.) + end if + + ! 3.4 Compute upward longwave fluxes, convert them to tendencies + ! and add shortwave tendencies + if (iitest.eq.1) print *, ' 3.4 in PHYPAR' + + call radlw (1,tg1,ts,slrd,slru(1,3),slr,olr,tt_rlw) + + do k=1,nlev + do j=1,ngp + tt_rlw(j,k) = tt_rlw(j,k)*rps(j)*grdscp(k) + ttend(j,k) = ttend(j,k)+tt_rsw(j,k)+tt_rlw(j,k) + end do + end do + + ! 4. PBL interactions with lower troposphere + ! 4.1 Vertical diffusion and shallow convection + call vdifsc(ug1,vg1,se,rh,qg1,qsat,phig1,icnv,ut_pbl,vt_pbl,tt_pbl,qt_pbl) + + ! 4.2 Add tendencies due to surface fluxes + do j=1,ngp + ut_pbl(j,nlev)=ut_pbl(j,nlev)+ustr(j,3)*rps(j)*grdsig(nlev) + vt_pbl(j,nlev)=vt_pbl(j,nlev)+vstr(j,3)*rps(j)*grdsig(nlev) + tt_pbl(j,nlev)=tt_pbl(j,nlev)+ shf(j,3)*rps(j)*grdscp(nlev) + qt_pbl(j,nlev)=qt_pbl(j,nlev)+evap(j,3)*rps(j)*grdsig(nlev) + end do + + utend = utend + ut_pbl + vtend = vtend + vt_pbl + ttend = ttend + tt_pbl + qtend = qtend + qt_pbl + + ! 5. Store all fluxes for coupling and daily-mean output + call dmflux(1) + + ! 6. Random diabatic forcing + if (lrandf) then + ! 6.1 Compute zonal-mean cross sections of diabatic forcing + if (lradsw) then + call xs_rdf(tt_lsc,tt_cnv,1) + call xs_rdf(tt_rsw,tt_rlw,2) + end if + + ! 6.2 Compute and store 3-D pattern of random diabatic forcing + tt_cnv = tt_cnv + tt_lsc + + call setrdf(tt_lsc) + + ttend = ttend + tt_lsc + end if + + ! Add SPPT noise + if (sppt_on) then + sppt = gen_sppt() + + ! The physical contribution to the tendency is *tend - *tend_dyn, where * is u, v, t, q + do k = 1,kx + utend(:,k) = (1 + sppt(:,k)*mu(k)) * (utend(:,k) - utend_dyn(:,k)) + utend_dyn(:,k) + vtend(:,k) = (1 + sppt(:,k)*mu(k)) * (vtend(:,k) - vtend_dyn(:,k)) + vtend_dyn(:,k) + ttend(:,k) = (1 + sppt(:,k)*mu(k)) * (ttend(:,k) - ttend_dyn(:,k)) + ttend_dyn(:,k) + qtend(:,k) = (1 + sppt(:,k)*mu(k)) * (qtend(:,k) - qtend_dyn(:,k)) + qtend_dyn(:,k) + end do + end if +end + +subroutine xs_rdf(tt1,tt2,ivm) + ! subroutine xs_rdf (tt1,tt2,ivm) + ! + ! Purpose: compute zonal-mean cross-sec. of random diabatic forcing + ! Input: tt1, tt2 = diabatic heating fields + ! ivm = index of vertical mode (1 or 2) + + use mod_atparam + use mod_physcon, only: sig + use mod_randfor, only: randfv + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real, dimension(nlon,nlat,nlev), intent(in) :: tt1, tt2 + integer, intent(in) :: ivm + + real :: rand1(0:nlat+1), pigr2, rnlon, rnsig + integer :: i, j, k, nsmooth + + rnlon = 1./float(nlon) + pigr2 = 4.*asin(1.) + + ! 1. Compute cross sections + do k=1,nlev + if (ivm.eq.1) then + rnsig = rnlon + else + rnsig = rnlon*sin(pigr2*sig(k)) + endif + + do j=1,nlat + randfv(j,k,ivm) = 0. + do i=1,nlon + randfv(j,k,ivm) = randfv(j,k,ivm)+tt1(i,j,k)+tt2(i,j,k) + end do + randfv(j,k,ivm) = randfv(j,k,ivm)*rnsig + end do + end do + + ! 2. Perform smoothing in latitude + do nsmooth=1,2 + do k=1,nlev + + do j=1,nlat + rand1(j) = randfv(j,k,ivm) + end do + rand1(0) = rand1(2) + rand1(nlat+1) = rand1(nlat-1) + + do j=1,nlat + randfv(j,k,ivm) = 0.5*rand1(j)+0.25*(rand1(j-1)+rand1(j+1)) + end do + end do + end do +end + +subroutine setrdf(tt_rdf) + ! subroutine setrdf (tt_rdf) + ! + ! Purpose: compute 3-D pattern of random diabatic forcing + ! Output: tt_rdf = random diabatic forcing + + use mod_atparam + use mod_randfor + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real :: tt_rdf(nlon,nlat,nlev) + integer :: i, j, k + + do k=1,nlev + do j=1,nlat + do i=1,nlon + tt_rdf(i,j,k) = randfh(i,j,1)*randfv(j,k,1)& + & +randfh(i,j,2)*randfv(j,k,2) + end do + end do + end do +end + +subroutine qneg() + !Troy's subroutine to get rid of negative specific humidity values + use mod_atparam + use mod_physvar, only : qg1 + implicit none + + integer :: i, j + + print *, 'max',maxval(qg1) + do i=1,ix*il + do j=1,kx + if(qg1(i,j) < 0.0) then + qg1 = 0.0 + endif + enddo + enddo + return +end subroutine diff --git a/src/phy_radiat.f90 b/src/phy_radiat.f90 new file mode 100755 index 0000000..2783b29 --- /dev/null +++ b/src/phy_radiat.f90 @@ -0,0 +1,692 @@ +subroutine sol_oz(tyear) + ! subroutine sol_oz (tyear) + ! + ! Purpose: Compute zonally-averaged fields to be used + ! in the computation of SW absorption: + ! fsol = flux of incoming solar radiation + ! ozone = flux absorbed by ozone (lower stratos.) + ! ozupp = flux absorbed by ozone (upper stratos.) + ! zenit = function of solar zenith angle + ! Input: tyear = time as fraction of year (0-1, 0 = 1jan.h00) + ! Updated common blocks: radzon + + use mod_atparam + use mod_physcon, only: slat, clat + use mod_radcon, only: solc, epssw, fsol, ozone, ozupp, zenit, stratz + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real, intent(in) :: tyear + real :: topsr(nlat), alpha, azen, coz1, coz2, czen, dalpha, flat2, fs0 + real :: nzen, rzen, szen + integer :: i, j, j0 + + ! alpha = year phase ( 0 - 2pi, 0 = winter solstice = 22dec.h00 ) + alpha=4.*asin(1.)*(tyear+10./365.) + dalpha=0. + !DALPHA=ASIN(0.5) + + coz1= 1.0*max(0.,cos(alpha-dalpha)) + coz2= 1.8 + + azen=1.0 + nzen=2 + + rzen=-cos(alpha)*23.45*asin(1.)/90. + czen=cos(rzen) + szen=sin(rzen) + + fs0=6. + + ! Solar radiation at the top + call solar(tyear,4.*solc,nlat,clat,slat,topsr) + + do j=1,nlat + j0=1+nlon*(j-1) + flat2=1.5*slat(j)**2-0.5 + + ! Solar radiation at the top + fsol(j0)=topsr(j) + + ! Ozone depth in upper and lower stratosphere + ozupp(j0)=0.5*epssw + ozone(j0)=0.4*epssw*(1.0+coz1*slat(j)+coz2*flat2) + + ! Zenith angle correction to (downward) absorptivity + zenit(j0)=1.+azen*(1.-(clat(j)*czen+slat(j)*szen))**nzen + + ! Ozone absorption in upper and lower stratosphere + ozupp(j0)=fsol(j0)*ozupp(j0)*zenit(j0) + ozone(j0)=fsol(j0)*ozone(j0)*zenit(j0) + + ! Polar night cooling in the stratosphere + stratz(j0)=max(fs0-fsol(j0),0.) + + do i=1,nlon-1 + fsol (i+j0) = fsol (j0) + ozone (i+j0) = ozone (j0) + ozupp (i+j0) = ozupp (j0) + zenit (i+j0) = zenit (j0) + stratz(i+j0) = stratz(j0) + end do + end do +end + +subroutine solar(tyear,csol,nlat,clat,slat,topsr) + ! Average daily flux of solar radiation, from Hartmann (1994) + + implicit none + + real, intent(in) :: tyear, csol + integer, intent(in) :: nlat + real, dimension(nlat), intent(in) :: clat, slat + real, intent(inout) :: topsr(nlat) + + integer :: j + real :: ca1, ca2, ca3, cdecl, ch0, csolp, decl, fdis, h0, alpha, pigr, sa1 + real :: sa2, sa3, sdecl, sh0, tdecl + + ! 1. Compute declination angle and Earth-Sun distance factor + pigr = 2.*asin(1.) + alpha = 2.*pigr*tyear + + ca1 = cos(alpha) + sa1 = sin(alpha) + ca2 = ca1*ca1-sa1*sa1 + sa2 = 2.*sa1*ca1 + ca3 = ca1*ca2-sa1*sa2 + sa3 = sa1*ca2+sa2*ca1 + + decl = 0.006918-0.399912*ca1+0.070257*sa1-0.006758*ca2+0.000907*sa2& + & -0.002697*ca3+0.001480*sa3 + + fdis = 1.000110+0.034221*ca1+0.001280*sa1+0.000719*ca2+0.000077*sa2 + + cdecl = cos(decl) + sdecl = sin(decl) + tdecl = sdecl/cdecl + + ! 2. Compute daily-average insolation at the atm. top + csolp=csol/pigr + + do j=1,nlat + ch0 = min(1.,max(-1.,-tdecl*slat(j)/clat(j))) + h0 = acos(ch0) + sh0 = sin(h0) + + topsr(j) = csolp*fdis*(h0*slat(j)*sdecl+sh0*clat(j)*cdecl) + end do +end + +subroutine cloud(qa,rh,precnv,precls,iptop,gse,fmask,icltop,cloudc,clstr) + ! subroutine cloud (qa,rh,precnv,precls,iptop,gse,fmask, + ! & icltop,cloudc,clstr) + ! + ! Purpose: Compute cloud-top level and cloud cover + ! Input: qa = specific humidity [g/kg] (3-dim) + ! rh = relative humidity (3-dim) + ! precnv = convective precipitation (2-dim) + ! precls = large-scale precipitation (2-dim) + ! iptop = top level of precipitating cloud (2-dim) + ! gse = gradient of dry st. energy (dSE/dPHI) (2-dim) + ! fmask = fractional land-sea mask (2-dim) + ! Output: icltop = cloud top level (all clouds) (2-dim) + ! cloudc = total cloud cover (2-dim) + ! clstr = stratiform cloud cover (2-dim) + + use mod_atparam + use mod_radcon, only: rhcl1, rhcl2, qacl, wpcl, pmaxcl, clsmax, clsminl,& + & gse_s0, gse_s1, albcl, qcloud + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + integer :: iptop(ngp) + real, intent(in) :: qa(ngp,nlev), rh(ngp,nlev), precnv(ngp), precls(ngp), gse(ngp),& + & fmask(ngp) + real, intent(inout) :: cloudc(ngp), clstr(ngp) + integer, intent(inout) :: icltop(ngp) + + integer :: inew, j, k, nl1, nlp + real :: albcor, cl1, clfact, clstrl, drh, fstab, pr1, rgse, rrcl + + nl1 = nlev-1 + nlp = nlev+1 + rrcl = 1./(rhcl2-rhcl1) + + ! 1. Cloud cover, defined as the sum of: + ! - a term proportional to the square-root of precip. rate + ! - a quadratic function of the max. relative humidity + ! in tropospheric layers above PBL where Q > QACL : + ! ( = 0 for RHmax < RHCL1, = 1 for RHmax > RHCL2 ) + ! Cloud-top level: defined as the highest (i.e. least sigma) + ! between the top of convection/condensation and + ! the level of maximum relative humidity. + + do j=1,ngp + if (rh(j,nl1).gt.rhcl1) then + cloudc(j) = rh(j,nl1)-rhcl1 + icltop(j) = nl1 + else + cloudc(j) = 0. + icltop(j) = nlp + end if + end do + + do k=3,nlev-2 + do j=1,ngp + drh = rh(j,k)-rhcl1 + if (drh.gt.cloudc(j).and.qa(j,k).gt.qacl) then + cloudc(j) = drh + icltop(j) = k + end if + end do + end do + + do j=1,ngp + cl1 = min(1.,cloudc(j)*rrcl) + pr1 = min(pmaxcl,86.4*(precnv(j)+precls(j))) + cloudc(j) = min(1.,wpcl*sqrt(pr1)+cl1*cl1) + icltop(j) = min(iptop(j),icltop(j)) + end do + + ! 2. Equivalent specific humidity of clouds + qcloud = qa(:,nl1) + + ! 3. Stratiform clouds at the top of PBL + inew = 1 + + if (inew.gt.0) then + ! CLSMAX = 0.6 + ! CLSMINL = 0.15 + ! GSE_S0 = 0.25 + ! GSE_S1 = 0.40 + + clfact = 1.2 + rgse = 1./(gse_s1-gse_s0) + + do j=1,ngp + ! Stratocumulus clouds over sea + fstab = max(0.,min(1.,rgse*(gse(j)-gse_s0))) + clstr(j) = fstab*max(clsmax-clfact*cloudc(j),0.) + ! Stratocumulus clouds over land + clstrl = max(clstr(j),clsminl)*rh(j,nlev) + clstr(j) = clstr(j)+fmask(j)*(clstrl-clstr(j)) + end do + else + clsmax = 0.3 + clsminl = 0.1 + albcor = albcl/0.5 + + do j=1,ngp + ! stratocumulus clouds over sea + clstr(j) = max(clsmax-cloudc(j),0.) + ! rescale for consistency with previous albedo values + clstr(j) = clstr(j)*albcor + ! correction for aerosols over land + clstr(j) = clstr(j)+fmask(j)*(clsminl-clstr(j)) + end do + end if +end + +subroutine radsw(psa,qa,icltop,cloudc,clstr,fsfcd,fsfc,ftop,dfabs) + ! subroutine radsw (psa,qa,icltop,cloudc,clstr, + ! & fsfcd,fsfc,ftop,dfabs) + ! + ! purpose: compute the absorption of shortwave radiation and + ! initialize arrays for longwave-radiation routines + ! input: psa = norm. surface pressure [p/p0] (2-dim) + ! qa = specific humidity [g/kg] (3-dim) + ! icltop = cloud top level (2-dim) + ! cloudc = total cloud cover (2-dim) + ! clstr = stratiform cloud cover (2-dim) + ! output: fsfcd = downward-only flux of sw rad. at the surface (2-dim) + ! fsfc = net (downw.) flux of sw rad. at the surface (2-dim) + ! ftop = net (downw.) flux of sw rad. at the atm. top (2-dim) + ! dfabs = flux of sw rad. absorbed by each atm. layer (3-dim) + + use mod_atparam + use mod_physcon, only: sig, dsig + use mod_radcon + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + integer, intent(in) :: icltop(ngp) + real, intent(in) :: psa(ngp), qa(ngp,nlev), cloudc(ngp), clstr(ngp) + real, intent(inout) :: ftop(ngp), fsfc(ngp), fsfcd(ngp), dfabs(ngp,nlev) + + integer :: j, k, nl1 + real :: acloud(ngp), psaz(ngp), abs1, acloud1, deltap, eps1 + real :: fband1, fband2 + + nl1 = nlev-1 + + fband2 = 0.05 + fband1 = 1.-fband2 + + ! ALBMINL=0.05 + ! ALBCLS = 0.5 + + ! 1. Initialization + tau2 = 0.0 + + do j=1,ngp + !fk-- change to ensure only icltop <= nlev used + if(icltop(j) .le. nlev) then + tau2(j,icltop(j),3)= albcl*cloudc(j) + endif + !fk-- end change + tau2(j,nlev,3) = albcls*clstr(j) + end do + + ! 2. Shortwave transmissivity: + ! function of layer mass, ozone (in the statosphere), + ! abs. humidity and cloud cover (in the troposphere) + + do j=1,ngp + psaz(j)=psa(j)*zenit(j) + acloud(j)=cloudc(j)*min(abscl1*qcloud(j),abscl2) + end do + + do j=1,ngp + deltap=psaz(j)*dsig(1) + tau2(j,1,1)=exp(-deltap*absdry) + end do + + do k=2,nl1 + abs1=absdry+absaer*sig(k)**2 + do j=1,ngp + deltap=psaz(j)*dsig(k) + if (k.ge.icltop(j)) then + tau2(j,k,1)=exp(-deltap*(abs1+abswv1*qa(j,k)+acloud(j))) + else + tau2(j,k,1)=exp(-deltap*(abs1+abswv1*qa(j,k))) + endif + end do + end do + + abs1=absdry+absaer*sig(nlev)**2 + do j=1,ngp + deltap=psaz(j)*dsig(nlev) + tau2(j,nlev,1)=exp(-deltap*(abs1+abswv1*qa(j,nlev))) + end do + + do k=2,nlev + do j=1,ngp + deltap=psaz(j)*dsig(k) + tau2(j,k,2)=exp(-deltap*abswv2*qa(j,k)) + end do + end do + + ! 3. Shortwave downward flux + ! 3.1 Initialization of fluxes + ftop = fsol + flux(:,1) = fsol * fband1 + flux(:,2) = fsol * fband2 + + ! 3.2 Ozone and dry-air absorption in the stratosphere + K=1 + do j=1,ngp + dfabs(j,k)=flux(j,1) + flux (j,1)=tau2(j,k,1)*(flux(j,1)-ozupp(j)*psa(j)) + dfabs(j,k)=dfabs(j,k)-flux(j,1) + end do + + k=2 + do j=1,ngp + dfabs(j,k)=flux(j,1) + flux (j,1)=tau2(j,k,1)*(flux(j,1)-ozone(j)*psa(j)) + dfabs(j,k)=dfabs(j,k)-flux(j,1) + end do + + ! 3.3 Absorption and reflection in the troposphere + do k=3,nlev + do j=1,ngp + tau2(j,k,3)=flux(j,1)*tau2(j,k,3) + flux (j,1)=flux(j,1)-tau2(j,k,3) + dfabs(j,k)=flux(j,1) + flux (j,1)=tau2(j,k,1)*flux(j,1) + dfabs(j,k)=dfabs(j,k)-flux(j,1) + end do + end do + + do k=2,nlev + do j=1,ngp + dfabs(j,k)=dfabs(j,k)+flux(j,2) + flux (j,2)=tau2(j,k,2)*flux(j,2) + dfabs(j,k)=dfabs(j,k)-flux(j,2) + end do + end do + + ! 4. Shortwave upward flux + ! 4.1 Absorption and reflection at the surface + do j=1,ngp + fsfcd(j) = flux(j,1)+flux(j,2) + flux(j,1) = flux(j,1)*albsfc(j) + fsfc(j) = fsfcd(j)-flux(j,1) + end do + + ! 4.2 Absorption of upward flux + do k=nlev,1,-1 + do j=1,ngp + dfabs(j,k)=dfabs(j,k)+flux(j,1) + flux (j,1)=tau2(j,k,1)*flux(j,1) + dfabs(j,k)=dfabs(j,k)-flux(j,1) + flux (j,1)=flux(j,1)+tau2(j,k,3) + end do + end do + + ! 4.3 Net solar radiation = incoming - outgoing + ftop = ftop - flux(:,1) + + ! 5. Initialization of longwave radiation model + ! 5.1 Longwave transmissivity: + ! function of layer mass, abs. humidity and cloud cover. + + ! Cloud-free levels (stratosphere + PBL) + k=1 + do j=1,ngp + deltap=psa(j)*dsig(k) + tau2(j,k,1)=exp(-deltap*ablwin) + tau2(j,k,2)=exp(-deltap*ablco2) + tau2(j,k,3)=1. + tau2(j,k,4)=1. + end do + + do k=2,nlev,nlev-2 + do j=1,ngp + deltap=psa(j)*dsig(k) + tau2(j,k,1)=exp(-deltap*ablwin) + tau2(j,k,2)=exp(-deltap*ablco2) + tau2(j,k,3)=exp(-deltap*ablwv1*qa(j,k)) + tau2(j,k,4)=exp(-deltap*ablwv2*qa(j,k)) + end do + end do + + ! Cloudy layers (free troposphere) + acloud = cloudc * ablcl2 + + do k=3,nl1 + do j=1,ngp + deltap=psa(j)*dsig(k) + if (k.lt.icltop(j)) then + acloud1=acloud(j) + else + acloud1=ablcl1*cloudc(j) + endif + tau2(j,k,1)=exp(-deltap*(ablwin+acloud1)) + tau2(j,k,2)=exp(-deltap*ablco2) + tau2(j,k,3)=exp(-deltap*max(ablwv1*qa(j,k),acloud(j))) + tau2(j,k,4)=exp(-deltap*max(ablwv2*qa(j,k),acloud(j))) + end do + end do + + ! 5.2 Stratospheric correction terms + eps1=epslw/(dsig(1)+dsig(2)) + do j=1,ngp + stratc(j,1)=stratz(j)*psa(j) + stratc(j,2)=eps1*psa(j) + end do +end + +subroutine radlw(imode,ta,ts,fsfcd,fsfcu,fsfc,ftop,dfabs) + ! subroutine radlw(imode,ta,ts, + ! & fsfcd,fsfcu, + ! & fsfc,ftop,dfabs) + ! + ! Purpose: Compute the absorption of longwave radiation + ! Input: imode = index for operation mode + ! -1 : downward flux only + ! 0 : downward + upward flux + ! +1 : upward flux only + ! ta = absolute temperature (3-dim) + ! ts = surface temperature [if imode=0] + ! fsfcd = downward flux of lw rad. at the sfc. [if imode=1] + ! fsfcu = surface blackbody emission (upward) [if imode=1] + ! dfabs = DFABS output from RADLW(-1,... ) [if imode=1] + ! Output: fsfcd = downward flux of lw rad. at the sfc.[if imode=-1,0] + ! fsfcu = surface blackbody emission (upward) [if imode= 0] + ! fsfc = net upw. flux of lw rad. at the sfc. [if imode=0,1] + ! ftop = outgoing flux of lw rad. at the top [if imode=0,1] + ! dfabs = flux of lw rad. absorbed by each atm. layer (3-dim) + ! + + use mod_atparam + use mod_physcon, only: sbc, dsig, wvi + use mod_radcon, only: epslw, emisfc, fband, tau2, st4a, stratc, flux + + implicit none + + integer, intent(in) :: imode + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + ! Number of radiation bands with tau < 1 + integer, parameter :: nband=4 + + real, intent(in) :: ta(ngp,nlev), ts(ngp) + real, intent(inout) :: fsfcd(ngp), fsfcu(ngp), ftop(ngp), fsfc(ngp) + real, intent(inout) :: dfabs(ngp,nlev) + + integer :: j, jb, k, nl1 + real :: anis, anish, brad, corlw, corlw1, corlw2, emis, eps1, esbc, refsfc + real :: st3a, tsq + + nl1=nlev-1 + + refsfc=1.-emisfc + + if (imode.eq.1) go to 410 + ! 1. Blackbody emission from atmospheric levels. + ! The linearized gradient of the blakbody emission is computed + ! from temperatures at layer boundaries, which are interpolated + ! assuming a linear dependence of T on log_sigma. + ! Above the first (top) level, the atmosphere is assumed isothermal. + + ! Temperature at level boundaries + do k=1,nl1 + do j=1,ngp + st4a(j,k,1)=ta(j,k)+wvi(k,2)*(ta(j,k+1)-ta(j,k)) + end do + end do + + ! Mean temperature in stratospheric layers + do j=1,ngp + st4a(j,1,2)=0.75*ta(j,1)+0.25* st4a(j,1,1) + st4a(j,2,2)=0.50*ta(j,2)+0.25*(st4a(j,1,1)+st4a(j,2,1)) + end do + + ! Temperature gradient in tropospheric layers + anis =1.0 + anish=0.5*anis + + do k=3,nl1 + do j=1,ngp + st4a(j,k,2)=anish*max(st4a(j,k,1)-st4a(j,k-1,1),0.) + end do + end do + + do j=1,ngp + st4a(j,nlev,2)=anis*max(ta(j,nlev)-st4a(j,nl1,1),0.) + end do + + ! Blackbody emission in the stratosphere + do k=1,2 + do j=1,ngp + st4a(j,k,1)=sbc*st4a(j,k,2)**4 + st4a(j,k,2)=0. + end do + end do + + ! Blackbody emission in the troposphere + do k=3,nlev + do j=1,ngp + st3a=sbc*ta(j,k)**3 + st4a(j,k,1)=st3a*ta(j,k) + st4a(j,k,2)=4.*st3a*st4a(j,k,2) + end do + end do + + ! 2. Initialization of fluxes + fsfcd = 0.0 + dfabs = 0.0 + + ! 3. Emission ad absorption of longwave downward flux. + ! For downward emission, a correction term depending on the + ! local temperature gradient and on the layer transmissivity is + ! added to the average (full-level) emission of each layer. + + ! 3.1 Stratosphere + k=1 + do jb=1,2 + do j=1,ngp + emis=1.-tau2(j,k,jb) + brad=fband(nint(ta(j,k)),jb)*(st4a(j,k,1)+emis*st4a(j,k,2)) + flux(j,jb)=emis*brad + dfabs(j,k)=dfabs(j,k)-flux(j,jb) + end do + end do + + flux(:,3:nband) = 0.0 + + ! 3.2 Troposphere + do jb=1,nband + do k=2,nlev + do j=1,ngp + emis=1.-tau2(j,k,jb) + brad=fband(nint(ta(j,k)),jb)*(st4a(j,k,1)+emis*st4a(j,k,2)) + dfabs(j,k)=dfabs(j,k)+flux(j,jb) + flux(j,jb)=tau2(j,k,jb)*flux(j,jb)+emis*brad + dfabs(j,k)=dfabs(j,k)-flux(j,jb) + end do + end do + end do + + ! 3.3 Surface downward flux + do jb=1,nband + do j=1,ngp + fsfcd(j)=fsfcd(j)+emisfc*flux(j,jb) + end do + end do + + ! 3.4 Correction for "black" band (incl. surface reflection) + eps1=epslw*emisfc + do j=1,ngp + corlw=eps1*st4a(j,nlev,1) + dfabs(j,nlev)=dfabs(j,nlev)-corlw + fsfcd(j) =fsfcd(j) +corlw + end do + + if (imode.eq.-1) return + + ! 4. Emission ad absorption of longwave upward flux. + ! For upward emission, a correction term depending on the + ! local temperature gradient and on the layer transmissivity is + ! subtracted from the average (full-level) emission of each layer. + + ! 4.1 Surface + + ! Black-body (or grey-body) emission + esbc=emisfc*sbc + do j=1,ngp + tsq=ts(j)*ts(j) + fsfcu(j)=esbc*tsq*tsq + end do + + ! Entry point for upward-only mode (IMODE=1) + 410 continue + + fsfc = fsfcu - fsfcd + + do jb=1,nband + do j=1,ngp + flux(j,jb)=fband(nint(ts(j)),jb)*fsfcu(j)+refsfc*flux(j,jb) + end do + end do + + ! 4.2 Troposphere + + ! Correction for "black" band + do j=1,ngp + dfabs(j,nlev)=dfabs(j,nlev)+epslw*fsfcu(j) + end do + + do jb=1,nband + do k=nlev,2,-1 + do j=1,ngp + emis=1.-tau2(j,k,jb) + brad=fband(nint(ta(j,k)),jb)*(st4a(j,k,1)-emis*st4a(j,k,2)) + dfabs(j,k)=dfabs(j,k)+flux(j,jb) + flux(j,jb)=tau2(j,k,jb)*flux(j,jb)+emis*brad + dfabs(j,k)=dfabs(j,k)-flux(j,jb) + end do + end do + end do + + ! 4.3 Stratosphere + k=1 + do jb=1,2 + do j=1,ngp + emis=1.-tau2(j,k,jb) + brad=fband(nint(ta(j,k)),jb)*(st4a(j,k,1)-emis*st4a(j,k,2)) + dfabs(j,k)=dfabs(j,k)+flux(j,jb) + flux(j,jb)=tau2(j,k,jb)*flux(j,jb)+emis*brad + dfabs(j,k)=dfabs(j,k)-flux(j,jb) + end do + end do + + ! Correction for "black" band and polar night cooling + do j=1,ngp + corlw1=dsig(1)*stratc(j,2)*st4a(j,1,1)+stratc(j,1) + corlw2=dsig(2)*stratc(j,2)*st4a(j,2,1) + dfabs(j,1)=dfabs(j,1)-corlw1 + dfabs(j,2)=dfabs(j,2)-corlw2 + ftop(j) =corlw1+corlw2 + end do + + ! 4.4 Outgoing longwave radiation + do jb=1,nband + do j=1,ngp + ftop(j)=ftop(j)+flux(j,jb) + end do + end do +end + +subroutine radset + ! subroutine radset + ! + ! Purpose: compute energy fractions in LW bands + ! as a function of temperature + + use mod_atparam + use mod_radcon, only: epslw, fband + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + integer :: jb, jtemp + real :: eps1 + + eps1=1.-epslw + + do jtemp=200,320 + fband(jtemp,2)=(0.148-3.0e-6*(jtemp-247)**2)*eps1 + fband(jtemp,3)=(0.356-5.2e-6*(jtemp-282)**2)*eps1 + fband(jtemp,4)=(0.314+1.0e-5*(jtemp-315)**2)*eps1 + fband(jtemp,1)=eps1-(fband(jtemp,2)+fband(jtemp,3)+fband(jtemp,4)) + end do + + do jb=1,4 + do jtemp=100,199 + fband(jtemp,jb)=fband(200,jb) + end do + do jtemp=321,400 + fband(jtemp,jb)=fband(320,jb) + end do + end do +end diff --git a/src/phy_shtorh.f90 b/src/phy_shtorh.f90 new file mode 100755 index 0000000..0705a83 --- /dev/null +++ b/src/phy_shtorh.f90 @@ -0,0 +1,91 @@ +subroutine shtorh(imode,ngp,ta,ps,sig,qa,rh,qsat) + ! subroutine shtorh (imode,ngp,ta,ps,sig,qa,rh,qsat) + ! + ! Purpose: compute saturation specific humidity and + ! relative hum. from specific hum. (or viceversa) + ! Input: imode : mode of operation + ! ngp : no. of grid-points + ! ta : abs. temperature + ! ps : normalized pressure (= p/1000_hPa) [if sig < 0] + ! : normalized sfc. pres. (= ps/1000_hPa) [if sig > 0] + ! sig : sigma level + ! qa : specific humidity in g/kg [if imode > 0] + ! rh : relative humidity [if imode < 0] + ! qsat : saturation spec. hum. in g/kg + ! Output: rh : relative humidity [if imode > 0] + ! qa : specific humidity in g/kg [if imode < 0] + ! + + implicit none + + integer, intent(in) :: imode, ngp + real, intent(in) :: ta(ngp), ps(*), sig + real :: qsat(ngp), e0, c1, c2, t0, t1, t2 + real, intent(inout) :: qa(ngp), rh(ngp) + + integer :: j + + ! 1. Compute Qsat (g/kg) from T (degK) and normalized pres. P (= p/1000_hPa) + ! If sig > 0, P = Ps * sigma, otherwise P = Ps(1) = const. + e0 = 6.108e-3 + c1 = 17.269 + c2 = 21.875 + t0 = 273.16 + t1 = 35.86 + t2 = 7.66 + + do j=1,ngp + if (ta(j).ge.t0) then + qsat(j)=e0*exp(c1*(ta(j)-t0)/(ta(j)-t1)) + else + qsat(j)=e0*exp(c2*(ta(j)-t0)/(ta(j)-t2)) + end if + end do + + if (sig.le.0.0) then + do j=1,ngp + qsat(j)=622.*qsat(j)/(ps(1)-0.378*qsat(j)) + end do + else + do j=1,ngp + qsat(j)=622.*qsat(j)/(sig*ps(j)-0.378*qsat(j)) + end do + end if + + ! 2. Compute rel.hum. RH=Q/Qsat (imode>0), or Q=RH*Qsat (imode<0) + if (imode.gt.0) then + do j=1,ngp + rh(j)=qa(j)/qsat(j) + end do + else if (imode.lt.0) then + do j=1,ngp + qa(j)=rh(j)*qsat(j) + end do + end if +end + +subroutine zmeddy(nlon,nlat,ff,zm,eddy) + ! Decompose a field into zonal-mean and eddy component + + implicit none + + integer, intent(in) :: nlon, nlat + real, intent(in) :: ff(nlon,nlat) + real, intent(inout) :: zm(nlat), eddy(nlon,nlat) + integer :: i, j + real :: rnlon + + rnlon=1./nlon + + do j=1,nlat + zm(j)=0. + do i=1,nlon + zm(j)=zm(j)+ff(i,j) + end do + zm(j)=zm(j)*rnlon + + do i=1,nlon + eddy(i,j)=ff(i,j)-zm(j) + end do + end do +end diff --git a/src/phy_suflux.f90 b/src/phy_suflux.f90 new file mode 100755 index 0000000..720e5ea --- /dev/null +++ b/src/phy_suflux.f90 @@ -0,0 +1,382 @@ +subroutine suflux (psa,ua,va,ta,qa,rh,phi,phi0,fmask,tland,tsea,swav,ssrd,slrd,& + & ustr,vstr,shf,evap,slru,hfluxn,tsfc,tskin,u0,v0,t0,q0,lfluxland) + ! subroutine suflux (psa,ua,va,ta,qa,rh,phi, + ! & phi0,fmask,tland,tsea,swav,ssrd,slrd, + ! & ustr,vstr,shf,evap,slru,hfluxn, + ! & tsfc,tskin,u0,v0,t0,q0,lfluxland) + ! + ! Purpose: Compute surface fluxes of momentum, energy and moisture, + ! and define surface skin temperature from energy balance + ! Input: PSA = norm. surface pressure [p/p0] (2-dim) + ! UA = u-wind (3-dim) + ! VA = v-wind (3-dim) + ! TA = temperature (3-dim) + ! QA = specific humidity [g/kg] (3-dim) + ! RH = relative humidity [0-1] (3-dim) + ! PHI = geopotential (3-dim) + ! PHI0 = surface geopotential (2-dim) + ! FMASK = fractional land-sea mask (2-dim) + ! TLAND = land-surface temperature (2-dim) + ! TSEA = sea-surface temperature (2-dim) + ! SWAV = soil wetness availability [0-1] (2-dim) + ! SSRD = sfc sw radiation (downw. flux) (2-dim) + ! SLRD = sfc lw radiation (downw. flux) (2-dim) + ! LFLUXLAND = Logical related ti flux-correction + ! Output: USTR = u stress (2-dim) + ! VSTR = v stress (2-dim) + ! SHF = sensible heat flux (2-dim) + ! EVAP = evaporation [g/(m^2 s)] (2-dim) + ! SLRU = sfc lw radiation (upward flux) (2-dim) + ! HFLUXN = net heat flux into land/sea (2-dim) + ! TSFC = surface temperature (clim.) (2-dim) + ! TSKIN = skin surface temperature (2-dim) + ! U0 = near-surface u-wind (2-dim) + ! V0 = near-surface v-wind (2-dim) + ! T0 = near-surface air temperature (2-dim) + ! Q0 = near-surface sp. humidity [g/kg](2-dim) + + use mod_atparam + use mod_sflcon + use mod_physcon, only: p0, rd, cp, alhc, sbc, sigl, wvi, clat + use mod_radcon, only: emisfc, alb_l, alb_s, snowc + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real, dimension(ngp,nlev), intent(in) :: ua, va, ta, qa, rh, phi + real, dimension(ngp), intent(in) :: phi0, fmask, tland, tsea, swav, ssrd,& + & slrd + + real, dimension(ngp,3), intent(inout) :: ustr, vstr, shf, evap, slru + real, intent(inout) :: hfluxn(ngp,2) + real, dimension(ngp), intent(inout) :: tsfc, tskin, u0, v0, t0, q0 + + integer :: j, j0, jlat, ks, nl1 + real, dimension(ngp,2), save :: t1, q1 + real, dimension(ngp,2) :: t2, qsat0 + real, save :: denvvs(ngp,0:2) + real :: dslr(ngp), dtskin(ngp), clamb(ngp), astab, cdldv, cdsdv, chlcp + real :: chscp, dhfdt, dlambda, dt1, dthl, dths, esbc, esbc4, ghum0, gtemp0 + real :: prd, qdummy, rcp, rdphi0, rdth, rdummy, sqclat, tsk3, vg2 + + logical lscasym, lscdrag, lskineb + logical lfluxland + + real :: psa(ngp) + + lscasym = .true. ! true : use an asymmetric stability coefficient + lscdrag = .true. ! true : use stability coef. to compute drag over sea + lskineb = .true. ! true : redefine skin temp. from energy balance + + !clambda = 7. ! Heat conductivity in skin layer + !clambsn = 7. ! Heat conductivity for snow cover = 1 + + esbc = emisfc*sbc + esbc4 = 4.*esbc + + ghum0 = 1.-fhum0 + + dlambda = clambsn-clambda + + if (lfluxland) then + ! 1. Extrapolation of wind, temp, hum. and density to the surface + + ! 1.1 Wind components + u0 = fwind0 * ua(:,nlev) + v0 = fwind0 * va(:,nlev) + + ! 1.2 Temperature + gtemp0 = 1.-ftemp0 + rcp = 1./cp + rdphi0 =-1./(rd*288.*sigl(nlev)) + nl1=nlev-1 + + do j=1,ngp + ! Temperature difference between lowest level and sfc + dt1 = wvi(nlev,2)*(ta(j,nlev)-ta(j,nl1)) + ! Extrapolated temperature using actual lapse rate (1:land, 2:sea) + t1(j,1) = ta(j,nlev)+dt1 + t1(j,2) = t1(j,1)+phi0(j)*dt1*rdphi0 + ! Extrapolated temperature using dry-adiab. lapse rate (1:land, 2:sea) + t2(j,2) = ta(j,nlev)+rcp*phi(j,nlev) + t2(j,1) = t2(j,2)-rcp*phi0(j) + end do + + do j=1,ngp + if (ta(j,nlev).gt.ta(j,nl1)) then + ! Use extrapolated temp. if dT/dz < 0 + t1(j,1) = ftemp0*t1(j,1)+gtemp0*t2(j,1) + t1(j,2) = ftemp0*t1(j,2)+gtemp0*t2(j,2) + else + ! Use temp. at lowest level if dT/dz > 0 + t1(j,1) = ta(j,nlev) + t1(j,2) = ta(j,nlev) + endif + t0(j) = t1(j,2)+fmask(j)*(t1(j,1)-t1(j,2)) + end do + + ! 1.3 Spec. humidity + !ghum0 = 1.-fhum0 + + !call shtorh(-1,ngp,t0,psa,1.,q0,rh(1,nlev),qsat0) + + !do j=1,ngp + ! q0(j)=fhum0*q0(j)+ghum0*qa(j,nlev) + !end do + + ! 1.3 Density * wind speed (including gustiness factor) + prd = p0/rd + vg2 = vgust*vgust + + do j=1,ngp + denvvs(j,0)=(prd*psa(j)/t0(j))*sqrt(u0(j)*u0(j)+v0(j)*v0(j)+vg2) + end do + + ! 2. Compute land-sfc. fluxes using prescribed skin temperature + + ! 2.1 Define effective skin temperature to compensate for + ! non-linearity of heat/moisture fluxes during the daily cycle + do jlat=1,nlat + j0=nlon*(jlat-1) + sqclat=sqrt(clat(jlat)) + do j=j0+1,j0+nlon + tskin(j)=tland(j)+ctday*sqclat*ssrd(j)*(1.-alb_l(j))*psa(j) + end do + end do + + ! 2.2 Stability correction = f[pot.temp.(sfc)-pot.temp.(air)] + rdth = fstab/dtheta + astab = 1. + if (lscasym) astab = 0.5 ! to get smaller ds/dt in stable conditions + + do j=1,ngp + ! Potential temp. difference (land+sea average) + !fkdth0 = tsea(j)-t2(j,2) + !fkdth0 = dth0+fmask(j)*((tskin(j)-t2(j,1))-dth0) + + !fkif (dth0.gt.0.0) then + !fk dthl=min(dtheta,dth0) + !fkelse + !fk dthl=max(-dtheta,astab*dth0) + !fkendif + + !fkdenvvs(j,1)=denvvs(j,0)*(1.+dthl*rdth) + + if (tskin(j).gt.t2(j,1)) then + dthl=min(dtheta,tskin(j)-t2(j,1)) + else + dthl=max(-dtheta,astab*(tskin(j)-t2(j,1))) + endif + denvvs(j,1)=denvvs(j,0)*(1.+dthl*rdth) + end do + + ! 2.3 Wind stress + do j=1,ngp + cdldv = cdl*denvvs(j,0)*forog(j) + ustr(j,1) = -cdldv*ua(j,nlev) + vstr(j,1) = -cdldv*va(j,nlev) + end do + + ! 2.4 Sensible heat flux + chlcp = chl*cp + + do j=1,ngp + shf(j,1) = chlcp*denvvs(j,1)*(tskin(j)-t1(j,1)) + end do + + ! 2.5 Evaporation + if (fhum0.gt.0.) then + call shtorh(-1,ngp,t1(1,1),psa,1.,q1(1,1),rh(1,nlev),qsat0(1,1)) + + do j=1,ngp + q1(j,1) = fhum0*q1(j,1)+ghum0*qa(j,nlev) + end do + else + q1(:,1) = qa(:,nlev) + end if + + call shtorh(0,ngp,tskin,psa,1.,qdummy,rdummy,qsat0(1,1)) + + do j=1,ngp + !evap(j,1) = chl*denvvs(j,1)*swav(j)*max(0.,qsat0(j,1)-q1(j,1)) + evap(j,1) = chl*denvvs(j,1)*max(0.,swav(j)*qsat0(j,1)-q1(j,1)) + end do + + ! 3. Compute land-surface energy balance; + ! adjust skin temperature and heat fluxes + + ! 3.1. Emission of lw radiation from the surface + ! and net heat fluxes into land surface + do j=1,ngp + tsk3 = tskin(j)**3 + dslr(j) = esbc4*tsk3 + slru(j,1) = esbc *tsk3*tskin(j) + hfluxn(j,1) = ssrd(j)*(1.-alb_l(j))+slrd(j)-& + & (slru(j,1)+shf(j,1)+alhc*evap(j,1)) + end do + + ! 3.2 Re-definition of skin temperature from energy balance + if (lskineb) then + ! Compute net heat flux including flux into ground + do j=1,ngp + clamb(j) = clambda+snowc(j)*dlambda + hfluxn(j,1) = hfluxn(j,1)-clamb(j)*(tskin(j)-tland(j)) + dtskin(j) = tskin(j)+1. + end do + + ! Compute d(Evap) for a 1-degree increment of Tskin + call shtorh(0,ngp,dtskin,psa,1.,qdummy,rdummy,qsat0(1,2)) + + do j=1,ngp + if (evap(j,1).gt.0) then + qsat0(j,2) = swav(j)*(qsat0(j,2)-qsat0(j,1)) + else + qsat0(j,2) = 0. + endif + end do + + ! Redefine skin temperature to balance the heat budget + do j=1,ngp + dhfdt = clamb(j)+dslr(j)+chl*denvvs(j,1)*(cp+alhc*qsat0(j,2)) + dtskin(j) = hfluxn(j,1)/dhfdt + tskin(j) = tskin(j)+dtskin(j) + end do + + ! Add linear corrections to heat fluxes + do j=1,ngp + shf(j,1) = shf(j,1) +chlcp*denvvs(j,1)*dtskin(j) + evap(j,1) = evap(j,1)+chl*denvvs(j,1)*qsat0(j,2)*dtskin(j) + slru(j,1) = slru(j,1)+dslr(j)*dtskin(j) + hfluxn(j,1) = clamb(j)*(tskin(j)-tland(j)) + end do + end if +! ENDIF + + ! 4. Compute sea surface fluxes: + ! Note: stability terms and wind stress are NOT re-defined + ! if LFLUXLAND = .false. + + ! 4.1 Correct near-sfc. air temperature over coastal sea points + ! and compute near-sfc. humidity + !fkdo j=1,ngp + !fk if (fmask(j).gt.0.) then + !fk dtsea = tsea(j) -t1(j,2) + !fk dtland = tskin(j)-t1(j,1) + !fk if (dtsea.gt.0.0.and.dtland.lt.0.0) then + !fk dtsea = dtsea*(1.-fmask(j)**2) + !fk t1(j,2) = tsea(j)-dtsea + !fk endif + !fk endif + !fkend do + + rdth = fstab/dtheta + astab = 1. + if (lscasym) astab = 0.5 ! to get smaller dS/dT in stable conditions + + do j=1,ngp + if (tsea(j).gt.t2(j,2)) then + dths=min(dtheta,tsea(j)-t2(j,2)) + else + dths=max(-dtheta,astab*(tsea(j)-t2(j,2))) + end if + denvvs(j,2)=denvvs(j,0)*(1.+dths*rdth) + end do + + if (fhum0.gt.0.) then + call shtorh(-1,ngp,t1(1,2),psa,1.,q1(1,2),rh(1,nlev),qsat0(1,2)) + + do j=1,ngp + q1(j,2) = fhum0*q1(j,2)+ghum0*qa(j,nlev) + end do + else + q1(:,2) = qa(:,nlev) + end if + + ! 4.2 Wind stress + !fkks = 0 + ks=2 + !fkif (lscdrag) ks = 1 + if (lscdrag) ks = 2 + + do j=1,ngp + cdsdv = cds*denvvs(j,ks) + ustr(j,2) = -cdsdv*ua(j,nlev) + vstr(j,2) = -cdsdv*va(j,nlev) + end do + + ! End of 'land-mode' computation + end if + + ! Start of sea-sfc. heat fluxes computation + ! 4.3 Sensible heat flux + !fkks = 1 + ks=2 + chscp = chs*cp + + do j=1,ngp + shf(j,2) = chscp*denvvs(j,ks)*(tsea(j)-t1(j,2)) + end do + + ! 4.4 Evaporation + call shtorh(0,ngp,tsea,psa,1.,qdummy,rdummy,qsat0(1,2)) + + do j=1,ngp + evap(j,2) = chs*denvvs(j,ks)*(qsat0(j,2)-q1(j,2)) + end do + + ! 4.5 Emission of lw radiation from the surface + ! and net heat fluxes into sea surface + do j=1,ngp + slru(j,2) = esbc*tsea(j)**4 + hfluxn(j,2) = ssrd(j)*(1.-alb_s(j))+slrd(j)-& + & (slru(j,2)+shf(j,2)+alhc*evap(j,2)) + end do + + ! End of sea-sfc. heat fluxes computation + + ! 3. Weighted average of surface fluxes and temperatures + ! according to land-sea mask + if (lfluxland) then + do j=1,ngp + ustr(j,3) = ustr(j,2)+fmask(j)*(ustr(j,1)-ustr(j,2)) + vstr(j,3) = vstr(j,2)+fmask(j)*(vstr(j,1)-vstr(j,2)) + shf(j,3) = shf(j,2)+fmask(j)*( shf(j,1)- shf(j,2)) + evap(j,3) = evap(j,2)+fmask(j)*(evap(j,1)-evap(j,2)) + slru(j,3) = slru(j,2)+fmask(j)*(slru(j,1)-slru(j,2)) + end do + + do j=1,ngp + tsfc(j) = tsea(j)+fmask(j)*(tland(j)-tsea(j)) + tskin(j) = tsea(j)+fmask(j)*(tskin(j)-tsea(j)) + t0(j) = t1(j,2)+fmask(j)*(t1(j,1)- t1(j,2)) + q0(j) = q1(j,2)+fmask(j)*(q1(j,1)- q1(j,2)) + end do + end if +end + +subroutine sflset(phi0) + ! subroutine sflset (phi0) + ! + ! Purpose: compute orographic factor for land surface drag + ! Input: phi0 = surface geopotential (2-dim) + ! Initialized common blocks: sflfix + + use mod_atparam + use mod_sflcon + use mod_physcon, only: gg + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real, intent(in) :: phi0(ngp) + integer :: j + real :: rhdrag + + rhdrag = 1./(gg*hdrag) + + do j=1,ngp + forog(j)=1.+fhdrag*(1.-exp(-max(phi0(j),0.)*rhdrag)) + end do +end diff --git a/src/phy_vdifsc.f90 b/src/phy_vdifsc.f90 new file mode 100755 index 0000000..c345af8 --- /dev/null +++ b/src/phy_vdifsc.f90 @@ -0,0 +1,124 @@ +subroutine vdifsc(ua,va,se,rh,qa,qsat,phi,icnv,utenvd,vtenvd,ttenvd,qtenvd) + ! subroutine vdifsc (ua,va,se,rh,qa,qsat,phi,icnv, + ! & utenvd,vtenvd,ttenvd,qtenvd) + ! + ! Purpose: Compute tendencies of momentum, energy and moisture + ! due to vertical diffusion and shallow convection + ! Input: ua = u-wind (3-dim) + ! va = v-wind (3-dim) + ! se = dry static energy (3-dim) + ! rh = relative humidity [0-1] (3-dim) + ! qa = specific humidity [g/kg] (3-dim) + ! qsat = saturation sp. humidity [g/kg] (3-dim) + ! phi = geopotential (3-dim) + ! icnv = index of deep convection (2-dim) + ! Output: utenvd = u-wind tendency (3-dim) + ! vtenvd = v-wind tendency (3-dim) + ! ttenvd = temperature tendency (3-dim) + ! qtenvd = sp. humidity tendency [g/(kg s)] (3-dim) + ! + + use mod_atparam + use mod_vdicon + use mod_physcon, only: cp, alhc, sig, sigh, dsig + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real, dimension(ngp,nlev), intent(in) :: ua, va, se, rh, qa, qsat, phi + integer, intent(in) :: icnv(ngp) + real, dimension(ngp,nlev), intent(inout) :: utenvd, vtenvd, ttenvd, qtenvd + + integer :: nl1, j, k, k1 + real :: cshc, cvdi, fshcq, fshcse, fvdiq, fvdise, drh0, fvdiq2, dmse, drh + real :: fluxse, fluxq, fcnv, se0 + real, dimension(nlev) :: rsig, rsig1 + + ! 1. Initalization + + ! N.B. In this routine, fluxes of dry static energy and humidity + ! are scaled in such a way that: + ! d_T/dt = d_F'(SE)/d_sigma, d_Q/dt = d_F'(Q)/d_sigma + + nl1 = nlev-1 + cshc = dsig(nlev)/3600. + cvdi = (sigh(nl1)-sigh(1))/((nl1-1)*3600.) + + fshcq = cshc/trshc + fshcse = cshc/(trshc*cp) + + fvdiq = cvdi/trvdi + fvdise = cvdi/(trvds*cp) + + do k=1,nl1 + rsig(k)=1./dsig(k) + rsig1(k)=1./(1.-sigh(k)) + end do + rsig(nlev)=1./dsig(nlev) + + utenvd = 0.0 + vtenvd = 0.0 + ttenvd = 0.0 + qtenvd = 0.0 + + ! 2. Shallow convection + drh0 = rhgrad*(sig(nlev)-sig(nl1)) + fvdiq2 = fvdiq*sigh(nl1) + + do j=1,ngp + dmse = (se(j,nlev)-se(j,nl1))+alhc*(qa(j,nlev)-qsat(j,nl1)) + drh = rh(j,nlev)-rh(j,nl1) + fcnv = 1. + + if (dmse.ge.0.0) then + if (icnv(j).gt.0) fcnv = redshc + + fluxse = fcnv*fshcse*dmse + ttenvd(j,nl1) = fluxse*rsig(nl1) + ttenvd(j,nlev) =-fluxse*rsig(nlev) + + if (drh.ge.0.0) then + fluxq = fcnv*fshcq*qsat(j,nlev)*drh + qtenvd(j,nl1) = fluxq*rsig(nl1) + qtenvd(j,nlev) =-fluxq*rsig(nlev) + end if + else if (drh.ge.drh0) then + fluxq = fvdiq2*qsat(j,nl1)*drh + qtenvd(j,nl1) = fluxq*rsig(nl1) + qtenvd(j,nlev) =-fluxq*rsig(nlev) + end if + end do + + ! 3. Vertical diffusion of moisture above the PBL + do k=3,nlev-2 + if (sigh(k).gt.0.5) then + drh0 = rhgrad*(sig(k+1)-sig(k)) + fvdiq2 = fvdiq*sigh(k) + + do j=1,ngp + drh=rh(j,k+1)-rh(j,k) + if (drh.ge.drh0) then + fluxq = fvdiq2*qsat(j,k)*drh + qtenvd(j,k) = qtenvd(j,k) +fluxq*rsig(k) + qtenvd(j,k+1)= qtenvd(j,k+1)-fluxq*rsig(k+1) + end if + end do + end if + end do + + ! 4. Damping of super-adiabatic lapse rate + do k=1,nl1 + do j=1,ngp + se0 = se(j,k+1)+segrad*(phi(j,k)-phi(j,k+1)) + + if (se(j,k).lt.se0) then + fluxse = fvdise*(se0-se(j,k)) + ttenvd(j,k) = ttenvd(j,k)+fluxse*rsig(k) + do k1=k+1,nlev + ttenvd(j,k1) = ttenvd(j,k1)-fluxse*rsig1(k) + end do + end if + end do + end do +end diff --git a/src/ppo_diagns.f90 b/src/ppo_diagns.f90 new file mode 100755 index 0000000..6ef7bf4 --- /dev/null +++ b/src/ppo_diagns.f90 @@ -0,0 +1,78 @@ +subroutine diagns(jj,istep) + ! subroutine diagns(jj,istep) + + ! Purpose: print global means of eddy kinetic energy and temperature + ! Input : jj = time level index (1 or 2) + ! istep = time step index + + + use mod_tsteps, only: nstdia, nstppr, nstout, ihout + use mod_atparam + use mod_dynvar + + implicit none + + integer, intent(in) :: jj, istep + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + integer :: k, m, n, kk + complex :: temp(mx,nx) + real :: diag(kx,3), sqhalf + + ! 1. Get global-mean temperature and compute eddy kinetic energy + sqhalf = sqrt(0.5) + + do k=1,kx + diag(k,1)=0. + diag(k,2)=0. + diag(k,3)=sqhalf*real(t(1,1,k,jj)) + + call invlap(vor(1,1,k,jj),temp) + + do m=2,mx + do n=1,nx + diag(k,1)=diag(k,1)-real(temp(m,n)*conjg(vor(m,n,k,jj))) + end do + end do + + call invlap(div(1,1,k,jj),temp) + + do m=2,mx + do n=1,nx + diag(k,2)=diag(k,2)-real(temp(m,n)*conjg(div(m,n,k,jj))) + end do + end do + end do + + ! 2. Print results to screen + if (mod(istep,nstdia).eq.0) then + print 2001, istep, (diag(k,1),k=1,kx) + print 2002, (diag(k,2),k=1,kx) + print 2003, (diag(k,3),k=1,kx) + end if + + ! 3. Stop integration if model variables are out of range + do k=1,kx + if (diag(k,1).gt.500.or.diag(k,2).gt.500.or.diag(k,3).lt.180.or.& + & diag(k,3).gt.320.) then + + print 2001, istep, (diag(kk,1),kk=1,kx) + print 2002, (diag(kk,2),kk=1,kx) + print 2003, (diag(kk,3),kk=1,kx) + + ! Write model fields at t-1 on output file + if (ihout .eqv. .false.) then !Only when no hourly output + call tmout(0) + call tminc + nstout=nstppr + call tmout(1) + end if + + !stop '*** model variables out of accepted range ***' + end if + end do + + 2001 format(' step =',i6,' reke =',(10f8.2)) + 2002 format (13x,' deke =',(10f8.2)) + 2003 format (13x,' temp =',(10f8.2)) +end diff --git a/src/ppo_dmflux.f90 b/src/ppo_dmflux.f90 new file mode 100755 index 0000000..21f1fb8 --- /dev/null +++ b/src/ppo_dmflux.f90 @@ -0,0 +1,163 @@ +subroutine dmflux(iadd) + ! subroutine dmflux (iadd) + ! + ! Purpose: Add up fluxes to provide daily averages + ! used in sea/land models and daily/time-mean output + ! Input: IADD = 0 to initialize storage arrays to 0 + ! > 0 to increment arrays with current flux values + + use mod_tsteps, only: nsteps, istart + use mod_atparam + use mod_tmean, only: save2d_2, save2d_d2 + use mod_flx_land + use mod_flx_sea + use mod_physcon, only: alhc, sbc + use mod_surfcon, only: fmask, fmask1 + use mod_var_sea, only: tice_am, sice_am + use mod_physvar + use mod_radcon, only: albsea, albice, emisfc + use mod_date, only: ihour + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + integer, intent(in) :: iadd + integer :: j + + real :: prec(ngp), difice(ngp) + + real :: fland(ngp), esbc, rstep1, rstep2, rsteps, sstfr, sstfr4 + + fland = reshape(fmask1,(/ngp/)) + + ! 1. Initialization + if (iadd.le.0) then + if (ihour /= 0 .and. istart /= 0) then + ! Read from flux file + print *, '*************READING Flux',ngp + open (100,file='fluxes.grd',form='unformatted',access='direct',recl=8*ngp) + read (100,rec=1) (prec_l(j),j=1,ngp) + read (100,rec=2) (snowf_l(j),j=1,ngp) + read (100,rec=3) (evap_l(j),j=1,ngp) + read (100,rec=4) (hflux_l(j),j=1,ngp) + + read (100,rec=5) (prec_s(j),j=1,ngp) + read (100,rec=6) (snowf_s(j),j=1,ngp) + read (100,rec=7) (evap_s(j),j=1,ngp) + read (100,rec=8) (ustr_s(j),j=1,ngp) + read (100,rec=9) (vstr_s(j),j=1,ngp) + read (100,rec=10) (ssr_s(j),j=1,ngp) + read (100,rec=11) (slr_s(j),j=1,ngp) + read (100,rec=12) (shf_s(j),j=1,ngp) + read (100,rec=13) (ehf_s(j),j=1,ngp) + read (100,rec=14) (hflux_s(j),j=1,ngp) + read (100,rec=15) (hflux_i(j),j=1,ngp) + close (100) + else + ! Set all daily-mean arrays to zero + ! NB storage arrays for time-mean output are re-initialized + ! by subroutines TMOUT and DMOUT after write-up + + prec_l(:) = 0. + snowf_l(:) = 0. + evap_l(:) = 0. + hflux_l(:) = 0. + + prec_s(:) = 0. + snowf_s(:) = 0. + evap_s(:) = 0. + ustr_s(:) = 0. + vstr_s(:) = 0. + ssr_s(:) = 0. + slr_s(:) = 0. + shf_s(:) = 0. + ehf_s(:) = 0. + hflux_s(:) = 0. + hflux_i(:) = 0. + end if + return + end if + + rsteps = 1./real(nsteps) + rstep1 = rsteps*0.001 + rstep2 = rsteps*alhc + + ! SST at freezing point + sstfr = 273.2-1.8 + + sstfr4 = sstfr**4 + esbc = emisfc*sbc + + ! Total precipitation + prec(:) = precls(:)+precnv(:) + + ! 2. Store fluxes over land (SI units, all heat fluxes downw.) + prec_l(:) = prec_l(:) + prec(:) *rstep1 + evap_l(:) = evap_l(:) + evap(:,1)*rstep1 + + hflux_l(:) = hflux_l(:) + hfluxn(:,1)*rsteps + + ! 3. Store fluxes over sea (SI units, all heat fluxes downw.) + prec_s(:) = prec_s(:) + prec(:) *rstep1 + evap_s(:) = evap_s(:) + evap(:,2)*rstep1 + + ustr_s(:) = ustr_s(:) - ustr(:,2)*rsteps + vstr_s(:) = vstr_s(:) - vstr(:,2)*rsteps + + ssr_s(:) = ssr_s(:) + ssr(:) *rsteps + slr_s(:) = slr_s(:) - slr(:) *rsteps + shf_s(:) = shf_s(:) - shf(:,2) *rsteps + ehf_s(:) = ehf_s(:) - evap(:,2)*rstep2 + + ! Difference in net (downw.) heat flux between ice and sea surface + difice(:) = (albsea-albice)*ssrd(:)+ esbc*(sstfr4-tice_am(:)**4)& + & + shf(:,2)+evap(:,2)*alhc + + hflux_s(:) = hflux_s(:) + rsteps* hfluxn(:,2) + hflux_i(:) = hflux_i(:) + rsteps*(hfluxn(:,2)+difice(:)*(1.-sice_am(:))) + + ! 4.1 Store fluxes for daily-mean output + + ! Multiply net heat fluxes by land or sea fractions + hfluxn(:,1) = hfluxn(:,1)*fland(:) + hfluxn(:,2) = hfluxn(:,2)*(1.-fland(:)) + + ! Surface water budget (in mm/day) + save2d_d2(:,1) = save2d_d2(:,1) + prec(:) *86.400 + save2d_d2(:,2) = save2d_d2(:,2) + evap(:,3)*86.400 + + ! Surface momentum budget + save2d_d2(:,3) = save2d_d2(:,3) - ustr(:,3) + save2d_d2(:,4) = save2d_d2(:,4) - vstr(:,3) + + ! OLR + save2d_d2(:,5) = save2d_d2(:,5) + olr(:) + + ! Surface energy budget + save2d_d2(:,6) = save2d_d2(:,6) + hfluxn(:,1) + save2d_d2(:,7) = save2d_d2(:,7) + hfluxn(:,2) + + ! 4.2 Store fluxes for time-mean output + ! Surface water budget (in mm/day) + save2d_2(:,1) = save2d_2(:,1) + precls(:)*86.400 + save2d_2(:,2) = save2d_2(:,2) + precnv(:)*86.400 + save2d_2(:,3) = save2d_2(:,3) + evap(:,3)*86.400 + + ! Surface momentum budget + save2d_2(:,4) = save2d_2(:,4) - ustr(:,3) + save2d_2(:,5) = save2d_2(:,5) - vstr(:,3) + + ! Top-of-atmosphere energy budget + save2d_2(:,6) = save2d_2(:,6) + tsr(:) + save2d_2(:,7) = save2d_2(:,7) + olr(:) + + ! Surface energy budget + save2d_2(:,8) = save2d_2(:,8) + ssr(:) + save2d_2(:,9) = save2d_2(:,9) + slr(:) + save2d_2(:,10) = save2d_2(:,10) + shf(:,3) + save2d_2(:,11) = save2d_2(:,11) + hfluxn(:,1) + save2d_2(:,12) = save2d_2(:,12) + hfluxn(:,2) + + ! End of flux increment +end diff --git a/src/ppo_dmout.f90 b/src/ppo_dmout.f90 new file mode 100755 index 0000000..857dcce --- /dev/null +++ b/src/ppo_dmout.f90 @@ -0,0 +1,67 @@ +subroutine dmout(imode) + ! subroutine dmout(imode) + + ! Purpose : write daily-means into output files + ! Input : imode = 0 initialize daily-mean arrays to 0 + ! imode > 0 write daily-means and reset arrays to 0 + ! Modified common blocks : tmsave + + use mod_tsteps, only: nsteps, nstppr, idout + use mod_atparam + use mod_tmean, only: ns2d_d1, ns2d_d2, save2d_d1, save2d_d2 + + implicit none + + integer, intent(in) :: imode + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real*4 :: r4out(ngp), fmean + integer :: iitest=0, n, nout_d1, nout_d2 + + if (iitest.eq.1) print *, 'inside DMOUT' + + if (imode /= 0) then + ! 1. Divide the accumulated fields to get the means + ! Fields saved at post-processing steps + fmean = real(nstppr)/real(nsteps) + + save2d_d1(:,:) = save2d_d1(:,:)*fmean + + ! Fields saved at every step (fluxes) + fmean = 1./real(nsteps) + + save2d_d2(:,:) = save2d_d2(:,:)*fmean + + ! 2. Write daily-mean output file + if (idout.eq.1) then + nout_d1 = 3 + nout_d2 = 1 + else if (idout.eq.2) then + nout_d1 = ns2d_d1 + nout_d2 = 1 + else + nout_d1 = ns2d_d1 + nout_d2 = ns2d_d2 + end if + + do n=1,nout_d1 + r4out(:) = save2d_d1(:,n) + write (17) r4out + end do + + do n=1,nout_d2 + r4out(:) = save2d_d2(:,n) + write (17) r4out + end do + end if + + ! 3. Reset arrays to zero for the next daily-mean + + if (iitest.eq.1) print*,' reset to zero' + + save2d_d1(:,:) = 0. + + save2d_d2(:,:) = 0. + + if (iitest.eq.1) print *, 'end of DMOUT' +end diff --git a/src/ppo_iogrid.f90 b/src/ppo_iogrid.f90 new file mode 100755 index 0000000..f9a1d7f --- /dev/null +++ b/src/ppo_iogrid.f90 @@ -0,0 +1,619 @@ +subroutine iogrid(imode) + ! SUBROUTINE IOGRID (IMODE) + ! Created by Takemasa Miyoshi + ! Converted to FORTRAN 90 by Sam Hatfield + ! + ! Purpose : read or write a gridded file in sigma coordinate + ! Input : IMODE = 1 : read model variables from a gridded file (sigma) + ! = 2 : write model variables to a gridded file (p) + ! = 3 : write a GrADS control file (for p) + ! = 4 : write model variables to a gridded file (sigma) + ! = 5 : write a GrADS control file (for sigma) + ! Initialized common blocks (if IMODE = 1) : DYNSP1, SFCANOM + ! + + use mod_atparam, only: ix, iy, nx, mx, il, kx + use mod_physcon, only: p0, gg, rd, sig, sigl, pout + use mod_dynvar + use mod_dyncon1 + use mod_date + use mod_tsteps + use mod_tmean + use mod_flx_land + use mod_flx_sea + + use mod_io, only : read_netcdf_4d, read_netcdf_3d, write_netcdf_speedy_full + use speedy_res_interface, only : write_restart_new, truncate_letkf_code_version + use mpires, only : internal_state_vector + + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + integer, intent(in) :: imode + + ! Check what this file corresponds to in my version +! include "com_anomvar.h" + + complex, dimension(mx,nx) :: ucostmp, vcostmp + real, dimension(ngp,kx) :: ugr, vgr, tgr, qgr, phigr + real :: psgr(ngp) + real, dimension(ngp,kx) :: ugr1, vgr1, tgr1, qgr1, phigr1 + real :: rrgr1(ngp), aref, phi1, phi2, textr, tref + real(4), dimension(ngp,kx) :: ugr4, vgr4, tgr4, qgr4, phigr4 + real(4), dimension(ngp) :: psgr4(ngp), rrgr4(ngp) + + !TROY STUFF + real, allocatable :: temp4d(:,:,:,:), temp3d(:,:,:), temp2d(:,:) + + ! For vertical interpolation !adapted from ppo_tminc.f + integer :: k0(ngp) + real :: w0(ngp), zout(ngp), zinp(nlev), rdzinp(nlev) + + + complex, dimension(mx,nx) :: psl1, ucos, vcos + ! File names etc. + character(len=14) :: filename='yyyymmddhh.grd' + character(len=14) :: ctlname='yyyymmddhh.ctl' + character(len=16) :: filenamep='yyyymmddhh_p.grd' + character(len=16) :: ctlnamep='yyyymmddhh_p.ctl' + character(len=3) :: cmon3='JAN' + + character(len=6) :: nc_filename + character(len=:), allocatable :: file_path + character(len=:), allocatable :: full_filename + character(len=3) :: nc_file_end + + integer :: irec + integer :: iitest=1 + integer :: j, k + + if (imode.eq.1) then + print '(A,I4.4,A,I2.2,A,I2.2,A,I2.2)',& + & 'Read gridded dataset for year/month/date/hour: ',& + & iyear,'/',imonth,'/',iday,'/',ihour + + open (90,form='unformatted',access='direct',recl=4*ngp) + irec=1 + do k=kx,1,-1 + read (90,rec=irec) (ugr4(j,k),j=1,ngp) + irec=irec+1 + end do + do k=kx,1,-1 + read (90,rec=irec) (vgr4(j,k),j=1,ngp) + irec=irec+1 + end do + do k=kx,1,-1 + read (90,rec=irec) (tgr4(j,k),j=1,ngp) + irec=irec+1 + end do + do k=kx,1,-1 + read (90,rec=irec) (qgr4(j,k),j=1,ngp) + irec=irec+1 + end do + read (90,rec=irec) (psgr4(j),j=1,ngp) + close (90) + + ugr = ugr4 + vgr = vgr4 + tgr = tgr4 + qgr = qgr4 *1.0d3 + psgr = psgr4 + psgr = log(psgr/p0) + if(iitest==1) print *,' UGR :',minval(ugr),maxval(ugr) + if(iitest==1) print *,' VGR :',minval(vgr),maxval(vgr) + if(iitest==1) print *,' TGR :',minval(tgr),maxval(tgr) + if(iitest==1) print *,' QGR :',minval(qgr),maxval(qgr) + if(iitest==1) print *,' PSGR :',minval(psgr),maxval(psgr) + + ! Conversion from gridded variable to spectral variable + do k=1,kx + call vdspec(ugr(1,k),vgr(1,k),vor(1,1,k,1),div(1,1,k,1),2) + call spec(tgr(1,k),t(1,1,k,1)) + call spec(qgr(1,k),tr(1,1,k,1,1)) + if(ix.eq.iy*4) then + call trunct(vor(1,1,k,1)) + call trunct(div(1,1,k,1)) + call trunct(t(1,1,k,1)) + call trunct(tr(1,1,k,1,1)) + end if + end do + call spec(psgr(1),ps(1,1,1)) + if (ix.eq.iy*4) call trunct(ps(1,1,1)) + else if (imode.eq.2.or.imode.eq.4) then + ! 2. Write date and model variables to the gridded file (2:P,4:sigma) + + ! Conversion from spectral model variable to gridded variable + do k=1,kx + call uvspec(vor(1,1,k,1),div(1,1,k,1),ucostmp,vcostmp) + call grid(ucostmp,ugr(1,k),2) + call grid(vcostmp,vgr(1,k),2) + end do + + do k=1,kx + call grid(t(1,1,k,1),tgr(1,k),1) + call grid(tr(1,1,k,1,1),qgr(1,k),1) + call grid(phi(1,1,k),phigr(1,k),1) + end do + + call grid(ps(1,1,1),psgr(1),1) + + ! Vertical interpolation from sigma level to pressure level (ppo_tminc.f) + if (imode.eq.2) then ! p-level output + zinp(1) = -sigl(1) + do k=2,nlev + zinp(k) = -sigl(k) + rdzinp(k) = 1.0d0/(zinp(k-1)-zinp(k)) + end do + + do k=1,kx + do j=1,ngp + zout(j) = psgr(j) - log(pout(k)) + end do + + call setvin(zinp,rdzinp,zout,ngp,kx,k0,w0) + + call verint(tgr1(1,k),tgr,ngp,kx,k0,w0) + + do j=1,ngp + if(zout(j).lt.zinp(nlev)) then + textr = max(tgr1(j,k),tgr(j,nlev)) + aref = rd*0.006d0/gg * (zinp(nlev)-zout(j)) + tref = tgr(j,nlev)*(1.0d0+aref+0.5*aref*aref) + tgr1(j,k) = textr + 0.7d0*(tref-textr) + end if + end do + + do j=1,ngp + w0(j) = max(w0(j),0.0) + end do + + call verint(ugr1(1,k),ugr,ngp,kx,k0,w0) + call verint(vgr1(1,k),vgr,ngp,kx,k0,w0) + call verint(qgr1(1,k),qgr,ngp,kx,k0,w0) + + do j=1,ngp + phi1 = phigr(j,k0(j))& + & +0.5*rd*(tgr1(j,k)+tgr(j,k0(j)))*(zout(j)-zinp(k0(j))) + phi2 = phigr(j,k0(j)-1)& + & +0.5*rd*(tgr1(j,k)+tgr(j,k0(j)-1))*(zout(j)-zinp(k0(j)-1)) + phigr1(j,k) = phi1 + w0(j)*(phi2-phi1) + end do + + do j=1,ngp + rrgr1(j) = save2d_d2(j,1)& ! g/m^2/s + &*3.6*4.0/real(nsteps)*6.0 ! mm/6hr + end do + end do + else ! sigma-level output + ugr1 = ugr + vgr1 = vgr + tgr1 = tgr + qgr1 = qgr + phigr1 = phigr + end if + + ! Output + print '(A,I4.4,A,I2.2,A,I2.2,A,I2.2)',& + & 'Write gridded dataset for year/month/date/hour: ',& + & iyear,'/',imonth,'/',iday,'/',ihour + + ugr4 = ugr1 + vgr4 = vgr1 + tgr4 = tgr1 + qgr4 = qgr1*1.0d-3 ! kg/kg + phigr4 = phigr1/gg ! m + psgr4 = p0*exp(psgr)! Pa + rrgr4 = rrgr1 + + if (imode.eq.2) then + write (filenamep(1:4),'(i4.4)') iyear + write (filenamep(5:6),'(i2.2)') imonth + write (filenamep(7:8),'(i2.2)') iday + write (filenamep(9:10),'(i2.2)') ihour + open (99,file=filenamep,form='unformatted',access='direct',& + & recl=4*ix*il) + else + write (filename(1:4),'(i4.4)') iyear + write (filename(5:6),'(i2.2)') imonth + write (filename(7:8),'(i2.2)') iday + write (filename(9:10),'(i2.2)') ihour + open (99,file=filename,form='unformatted',access='direct',& + & recl=4*ix*il) + end if + irec=1 + do k=kx,1,-1 + write (99,rec=irec) (ugr4(j,k),j=1,ngp) + irec=irec+1 + end do + do k=kx,1,-1 + write (99,rec=irec) (vgr4(j,k),j=1,ngp) + irec=irec+1 + end do + do k=kx,1,-1 + write (99,rec=irec) (tgr4(j,k),j=1,ngp) + irec=irec+1 + end do + do k=kx,1,-1 + write (99,rec=irec) (qgr4(j,k),j=1,ngp) + irec=irec+1 + end do + if (imode.eq.2) then !Z output is only for p-level + do k=kx,1,-1 + write (99,rec=irec) (phigr4(j,k),j=1,ngp) + irec=irec+1 + end do + end if + write (99,rec=irec) (psgr4(j),j=1,ngp) + irec=irec+1 + write (99,rec=irec) (rrgr4(j),j=1,ngp) + close (99) + if(iitest==1) print *,' UGR :',minval(ugr4),maxval(ugr4) + if(iitest==1) print *,' VGR :',minval(vgr4),maxval(vgr4) + if(iitest==1) print *,' TGR :',minval(tgr4),maxval(tgr4) + if(iitest==1) print *,' QGR :',minval(qgr4),maxval(qgr4) + if(iitest==1) print *,' PHIGR:',minval(phigr4),maxval(phigr4) + if(iitest==1) print *,' PSGR :',minval(psgr4),maxval(psgr4) + if(iitest==1) print *,' RRGR :',minval(rrgr4),maxval(rrgr4) + + open (100,file='fluxes.grd',form='unformatted',access='direct',recl=8*ix*il) + write (100,rec=1) (prec_l(j),j=1,ngp) + write (100,rec=2) (snowf_l(j),j=1,ngp) + write (100,rec=3) (evap_l(j),j=1,ngp) + write (100,rec=4) (hflux_l(j),j=1,ngp) + + write (100,rec=5) (prec_s(j),j=1,ngp) + write (100,rec=6) (snowf_s(j),j=1,ngp) + write (100,rec=7) (evap_s(j),j=1,ngp) + write (100,rec=8) (ustr_s(j),j=1,ngp) + write (100,rec=9) (vstr_s(j),j=1,ngp) + write (100,rec=10) (ssr_s(j),j=1,ngp) + write (100,rec=11) (slr_s(j),j=1,ngp) + write (100,rec=12) (shf_s(j),j=1,ngp) + write (100,rec=13) (ehf_s(j),j=1,ngp) + write (100,rec=14) (hflux_s(j),j=1,ngp) + write (100,rec=15) (hflux_i(j),j=1,ngp) + close (100) + else if (imode.eq.3.or.imode.eq.5) then + ! 3. Write a GrADS control file (3:p,5:sigma) + if (imonth.eq.1) then + cmon3='JAN' + else if (imonth.eq.2) then + cmon3='FEB' + else if (imonth.eq.3) then + cmon3='MAR' + else if (imonth.eq.4) then + cmon3='APR' + else if (imonth.eq.5) then + cmon3='MAY' + else if (imonth.eq.6) then + cmon3='JUN' + else if (imonth.eq.7) then + cmon3='JUL' + else if (imonth.eq.8) then + cmon3='AUG' + else if (imonth.eq.9) then + cmon3='SEP' + else if (imonth.eq.10) then + cmon3='OCT' + else if (imonth.eq.11) then + cmon3='NOV' + else if (imonth.eq.12) then + cmon3='DEC' + end if + + if (imode.eq.3) then !p-level + write (ctlnamep(1:4),'(I4.4)') iyear + write (ctlnamep(5:6),'(I2.2)') imonth + write (ctlnamep(7:8),'(I2.2)') iday + write (ctlnamep(9:10),'(I2.2)') ihour + open (11,file=ctlnamep,form='formatted') + write (11,'(A)') 'DSET ^%y4%m2%d2%h2_p.grd' + else !sigma-level + write (ctlname(1:4),'(I4.4)') iyear + write (ctlname(5:6),'(I2.2)') imonth + write (ctlname(7:8),'(I2.2)') iday + write (ctlname(9:10),'(I2.2)') ihour + open (11,file=ctlname,form='formatted') + write (11,'(A)') 'DSET ^%y4%m2%d2%h2.grd' + end if + write (11,'(A)') 'TITLE SPEEDY MODEL OUTPUT' + write (11,'(A)') 'UNDEF -9.99E33' + write (11,'(A)') 'OPTIONS template big_endian' + write (11,'(A)') 'XDEF 96 LINEAR 0.0 3.75' + write (11,'(A,48F8.3)') 'YDEF 48 LEVELS ',& + & (RADANG(J)*90.0d0/ASIN(1.0d0),J=1,48) + if (imode.eq.3) then + write (11,'(A)') 'ZDEF 8 LEVELS 925 850 700 500 300 200 100 30' + else + write (11,'(A,7F6.3)') 'ZDEF 8 LEVELS ',(sig(k),k=8,1,-1) + end if + if (ndaysl.ne.0) then + write (11,'(A,I4,A,I2.2,A,I2.2,A,I4.4,A)') 'TDEF ',& + & ndaysl*4+1,' LINEAR ',ihour,'Z',iday,cmon3,iyear,' 6HR' + else + write (11,'(A,I4,A,I2.2,A,I2.2,A,I4.4,A)') 'TDEF ',& + & 2,' LINEAR ',ihour,'Z',iday,cmon3,iyear,' 6HR' + end if + if (imode.eq.3) then !p-level + write (11,'(A)') 'VARS 7' + else !sigma-level + write (11,'(A)') 'VARS 6' + end if + write (11,'(A)') 'U 8 99 U-wind [m/s]' + write (11,'(A)') 'V 8 99 V-wind [m/s]' + write (11,'(A)') 'T 8 99 Temperature [K]' + write (11,'(A)') 'Q 8 99 Specific Humidity [kg/kg]' + if (imode.eq.3) then + write (11,'(A)') 'Z 8 99 Geopotential Height [m]' + end if + write (11,'(A)') 'PS 0 99 Surface Pressure [Pa]' + write (11,'(A)') 'RAIN 0 99 Precipitation [mm/6hr]' + write (11,'(A)') 'ENDVARS' + close (11) + elseif(imode == 27) then + print *, 'Starting from a netcdf restart file' + call read_netcdf_4d('Temperature','restart.nc',temp4d) + tgr4 = reshape(temp4d(:,:,:,1),(/ngp,nlev/)) + deallocate(temp4d) + + call read_netcdf_4d('U-wind','restart.nc',temp4d) + ugr4 = reshape(temp4d(:,:,:,1),(/ngp,nlev/)) + + deallocate(temp4d) + call read_netcdf_4d('V-wind','restart.nc',temp4d) + vgr4 = reshape(temp4d(:,:,:,1),(/ngp,nlev/)) + + deallocate(temp4d) + call read_netcdf_4d('Specific_Humidity','restart.nc',temp4d) + qgr4 = reshape(temp4d(:,:,:,1),(/ngp,nlev/)) + + call read_netcdf_3d('logp','restart.nc',temp3d) + psgr4 = reshape(temp3d(:,:,1),(/ngp/)) + + ugr = ugr4 + vgr = vgr4 + tgr = tgr4 + qgr = qgr4 !*1.0d3 + psgr = psgr4 + !psgr = !log(psgr/p0) + if(iitest==1) print *,' UGR :',minval(ugr),maxval(ugr) + if(iitest==1) print *,' VGR :',minval(vgr),maxval(vgr) + if(iitest==1) print *,' TGR :',minval(tgr),maxval(tgr) + if(iitest==1) print *,' QGR :',minval(qgr),maxval(qgr) + if(iitest==1) print *,' PSGR :',minval(psgr),maxval(psgr) + + ! Conversion from gridded variable to spectral variable + do k=1,kx + call vdspec(ugr(1,k),vgr(1,k),vor(1,1,k,1),div(1,1,k,1),2) + call spec(tgr(1,k),t(1,1,k,1)) + call spec(qgr(1,k),tr(1,1,k,1,1)) + if(ix.eq.iy*4) then + call trunct(vor(1,1,k,1)) + call trunct(div(1,1,k,1)) + call trunct(t(1,1,k,1)) + call trunct(tr(1,1,k,1,1)) + end if + end do + call spec(psgr(1),ps(1,1,1)) + if (ix.eq.iy*4) call trunct(ps(1,1,1)) + elseif(imode == 69) then + write (nc_filename(1:4),'(i4.4)') iyear + write (nc_filename(5:6),'(i2.2)') imonth + + do k=1,kx + call uvspec(vor(1,1,k,1),div(1,1,k,1),ucostmp,vcostmp) + call grid(ucostmp,ugr(1,k),2) + call grid(vcostmp,vgr(1,k),2) + end do + + do k=1,kx + call grid(t(1,1,k,1),tgr(1,k),1) + call grid(tr(1,1,k,1,1),qgr(1,k),1) + call grid(phi(1,1,k),phigr(1,k),1) + end do + + call grid(ps(1,1,1),psgr(1),1) + + allocate(temp4d(4,ix,il,kx)) + allocate(temp2d(ix,il)) + + temp4d(1,:,:,:) = reshape(tgr,(/ix,il,kx/)) + temp4d(2,:,:,:) = reshape(ugr,(/ix,il,kx/)) + temp4d(3,:,:,:) = reshape(vgr,(/ix,il,kx/)) + temp4d(4,:,:,:) = reshape(qgr,(/ix,il,kx/)) + + temp2d = reshape(psgr,(/ix,il/)) + nc_file_end = '.nc' + file_path = '/scratch/user/troyarcomano/FortranReservoir/hybridspeedy/' + + full_filename = file_path//'restart_y'//nc_filename(1:4)//'_m'//nc_filename(5:6)//nc_file_end + print *,full_filename + + call write_restart_new(full_filename,era_hour_plus_one,temp4d,temp2d) + deallocate(temp4d) + deallocate(temp2d) + elseif(imode == 28) then + print *, 'starting from era 5 reanalysis from file',era_file + + call read_netcdf_4d('Temperature',era_file,temp4d) + tgr4 = reshape(temp4d(:,:,:,era_hour),(/ngp,nlev/)) + + deallocate(temp4d) + call read_netcdf_4d('U-wind',era_file,temp4d) + ugr4 = reshape(temp4d(:,:,:,era_hour),(/ngp,nlev/)) + + deallocate(temp4d) + call read_netcdf_4d('V-wind',era_file,temp4d) + vgr4 = reshape(temp4d(:,:,:,era_hour),(/ngp,nlev/)) + + deallocate(temp4d) + call read_netcdf_4d('Specific_Humidity',era_file,temp4d) + qgr4 = reshape(temp4d(:,:,:,era_hour),(/ngp,nlev/)) + + deallocate(temp4d) + + call read_netcdf_3d('logp',era_file,temp3d) + psgr4 = reshape(temp3d(:,:,era_hour),(/ngp/)) + + deallocate(temp3d) + + ugr = ugr4 + vgr = vgr4 + tgr = tgr4 + qgr = qgr4 * 1.0d3 !kg/kg --> g/kg + + where(qgr < 0.0) + qgr = 0.0 + end where + + psgr = psgr4 + + if(iitest==1) print *,' UGR :',minval(ugr),maxval(ugr) + if(iitest==1) print *,' VGR :',minval(vgr),maxval(vgr) + if(iitest==1) print *,' TGR :',minval(tgr),maxval(tgr) + if(iitest==1) print *,' QGR :',minval(qgr),maxval(qgr) + if(iitest==1) print *,' PSGR :',minval(psgr),maxval(psgr) + + ! Conversion from gridded variable to spectral variable + do k=1,kx + call vdspec(ugr(1,k),vgr(1,k),vor(1,1,k,1),div(1,1,k,1),2) + call spec(tgr(1,k),t(1,1,k,1)) + call spec(qgr(1,k),tr(1,1,k,1,1)) + if(ix.eq.iy*4) then + call trunct(vor(1,1,k,1)) + call trunct(div(1,1,k,1)) + call trunct(t(1,1,k,1)) + call trunct(tr(1,1,k,1,1)) + end if + end do + call spec(psgr(1),ps(1,1,1)) + if (ix.eq.iy*4) call trunct(ps(1,1,1)) + elseif(imode == 29) then + !call regrid_era_spectral() + print *, 'you chose to regrid era date so Im killing SPEEDY' + stop + + elseif(imode == 30) then + print *, 'starting speedy using hybrid configuration' + + tgr4 = reshape(internal_state_vector%variables3d(1,:,:,:),(/ngp,nlev/)) + + ugr4 = reshape(internal_state_vector%variables3d(2,:,:,:),(/ngp,nlev/)) + + vgr4 = reshape(internal_state_vector%variables3d(3,:,:,:),(/ngp,nlev/)) + + qgr4 = reshape(internal_state_vector%variables3d(4,:,:,:),(/ngp,nlev/)) + + psgr4 = reshape(internal_state_vector%logp,(/ngp/)) + + ugr = ugr4 + vgr = vgr4 + tgr = tgr4 + where(qgr4 < 0.0) + qgr4 = 0.0 + end where + qgr = qgr4 + psgr = psgr4 + + if(iitest==1) print *,' UGR :',minval(ugr),maxval(ugr) + if(iitest==1) print *,' VGR :',minval(vgr),maxval(vgr) + if(iitest==1) print *,' TGR :',minval(tgr),maxval(tgr) + if(iitest==1) print *,' QGR :',minval(qgr),maxval(qgr) + if(iitest==1) print *,' PSGR :',minval(psgr),maxval(psgr) + + ! Conversion from gridded variable to spectral variable + do k=1,kx + call vdspec(ugr(1,k),vgr(1,k),vor(1,1,k,1),div(1,1,k,1),2) + call spec(tgr(1,k),t(1,1,k,1)) + call spec(qgr(1,k),tr(1,1,k,1,1)) + if(ix.eq.iy*4) then + call trunct(vor(1,1,k,1)) + call trunct(div(1,1,k,1)) + call trunct(t(1,1,k,1)) + call trunct(tr(1,1,k,1,1)) + end if + !tr(:,:,k,1,1) = truncate_letkf_code_version(tr(:,:,k,1,1), 20) + end do + call spec(psgr(1),ps(1,1,1)) + if (ix.eq.iy*4) call trunct(ps(1,1,1)) + + !TODO Major bug with taking gridded variables to spectral variables + do k=1,kx + call uvspec(vor(1,1,k,1),div(1,1,k,1),ucostmp,vcostmp) + call grid(ucostmp,ugr(1,k),2) + call grid(vcostmp,vgr(1,k),2) + end do + + do k=1,kx + call grid(t(1,1,k,1),tgr(1,k),1) + call grid(tr(1,1,k,1,1),qgr(1,k),1) + call grid(phi(1,1,k),phigr(1,k),1) + end do + + call grid(ps(1,1,1),psgr(1),1) + + if(iitest==1) print *,' UGR after :',minval(ugr),maxval(ugr) + if(iitest==1) print *,' VGR after :',minval(vgr),maxval(vgr) + if(iitest==1) print *,' TGR after :',minval(tgr),maxval(tgr) + if(iitest==1) print *,' QGR after :',minval(qgr),maxval(qgr) + if(iitest==1) print *,' PSGR after:',minval(psgr),maxval(psgr) + + !Check to make sure SPEEDY is safe to run + if((minval(ugr) < -150.0).or.maxval(ugr) > 150.0) then + print *, 'u-wind is unsafe for SPEEDY, stopping hybrid prediction' + internal_state_vector%is_safe_to_run_speedy = .False. + elseif((minval(vgr) < -120.0).or.maxval(vgr) > 120.0) then + print *,'v-wind is unsafe for SPEEDY, stopping hybrid prediction' + internal_state_vector%is_safe_to_run_speedy = .False. + elseif((minval(tgr) < 160.0).or.maxval(tgr) > 330.0) then + print *,'Temperature is unsafe for SPEEDY, stopping hybrid prediction' + internal_state_vector%is_safe_to_run_speedy = .False. + elseif((minval(qgr) < -6.0).or.maxval(qgr) > 26.0) then + print *,'Specific is unsafe for SPEEDY, stopping hybrid prediction' + internal_state_vector%is_safe_to_run_speedy = .False. + else + internal_state_vector%is_safe_to_run_speedy = .True. + endif + + else if(imode == 31) then + !Lets get out the model output and put it into interal_state_vector and + !pass back to the mpi routine + ! Conversion from spectral model variable to gridded variable + do k=1,kx + call uvspec(vor(1,1,k,1),div(1,1,k,1),ucostmp,vcostmp) + call grid(ucostmp,ugr(1,k),2) + call grid(vcostmp,vgr(1,k),2) + end do + + do k=1,kx + call grid(t(1,1,k,1),tgr(1,k),1) + call grid(tr(1,1,k,1,1),qgr(1,k),1) + call grid(phi(1,1,k),phigr(1,k),1) + end do + + call grid(ps(1,1,1),psgr(1),1) + internal_state_vector%variables3d(1,:,:,:) = reshape(tgr,(/ix,il,kx/)) + internal_state_vector%variables3d(2,:,:,:) = reshape(ugr,(/ix,il,kx/)) + internal_state_vector%variables3d(3,:,:,:) = reshape(vgr,(/ix,il,kx/)) + internal_state_vector%variables3d(4,:,:,:) = reshape(qgr,(/ix,il,kx/)) + + internal_state_vector%logp = reshape(psgr,(/ix,il/)) + + else + print *,'Hey, look at the usage! (IOGRID)' + stop + end if + + return + + ! 4. Stop integration if gridded file is not found + 200 continue + + print*, ' Hey, what are you doing?',& + & ' fort.2 should contain time setting' + + stop 'invalid gridded data input' + +end + diff --git a/src/ppo_restart.f90 b/src/ppo_restart.f90 new file mode 100755 index 0000000..bdfcb67 --- /dev/null +++ b/src/ppo_restart.f90 @@ -0,0 +1,85 @@ +subroutine restart(jday) + ! subroutine restart (jday) + ! + ! Purpose : read or write a restart file + ! Input : JDAY = 0 : read model variables from a restart file + ! > 0 : write model variables to a restart file + ! at selected dates and at the end of run + ! + + use mod_tsteps, only: nmonrs, iyear0, imont0 + use mod_atparam + use mod_dynvar + use mod_date, only: iyear, imonth, iday, ndaytot, ihour + + implicit none + + integer, intent(in) :: jday + integer :: jrec + real :: adummy + + if (jday.eq.0) then + 100 CONTINUE + + ! 1. Read the restart dataset corresponding to the specified initial date + ! [Modified:] Read the restart dataset for any initial date +! read (3,end=200) iyear, imonth + read (3,end=200) iyear, imonth, iday, ihour + +! if (iyear.eq.iyear0.and.imonth.eq.imont0) then +! print*, 'read restart dataset for year/month: ', iyear,imonth + print '(A,I4.4,A,I2.2,A,I2.2,A,I2.2)',& + & 'Read restart dataset for year/month/date/hour: ', & + & iyear,'/',imonth,'/',iday,'/',ihour + + read (3) vor + read (3) div + read (3) t + read (3) ps + read (3) tr + + call rest_land(0) + call rest_sea(0) +! else +! print *, 'Skip restart dataset for year/month: ', iyear,imonth +! +! do jrec=1,5 +! read (3) adummy +! end do +! +! CALL REST_LAND(0) +! CALL REST_SEA(0) +! +! go to 100 +! end if + ! Check for write-up dates +! else if ( (iday.eq.1) .and.& +! & (mod(imonth-1,nmonrs).eq.0.or.jday.eq.ndaytot) ) then + else + ! 2. Write date and model variables to the restart file +! print*, 'Write restart dataset for year/month: ', IYEAR,IMONTH + print*, 'Write restart dataset for year/month/date/hour: ', & + & iyear,'/',imonth,'/',iday,'/',ihour + +! write (10) iyear, imonth + write (10) iyear, imonth, iday, ihour + + write (10) vor + write (10) div + write (10) t + write (10) ps + write (10) tr + + call rest_land(1) + call rest_sea(1) + end if + + return + + ! 4. Stop integration if restart file is not found + 200 continue + + print*, ' No restart dataset for the specified initial date' + + stop 'invalid restart' +end diff --git a/src/ppo_setctl.f90 b/src/ppo_setctl.f90 new file mode 100755 index 0000000..c351886 --- /dev/null +++ b/src/ppo_setctl.f90 @@ -0,0 +1,271 @@ +subroutine setctl(iunit,nlon,nlat,nlev,ntm,ndtm,i3d,n3d,n2d_1,n2d_2,rlat,rlev,& + & name,norun,iyear0,imont0) + ! Aux. routine setctl : write descriptor (.ctl) output file + ! + + implicit none + + integer, intent(in) :: iunit, nlon, nlat, nlev, ntm, ndtm, i3d, n3d, n2d_1,& + & n2d_2, iyear0, imont0 + real, intent(in) :: rlat(nlat), rlev(nlev) + character(len=80) :: line(10), ln3d(30), ln2d_1(20), ln2d_2(15) + character(len=4) :: lmon(12), name + character(len=3) :: norun + character(len=11) :: ctlname + integer :: ilev(30), j, jline, k + real :: c1 + + ! 1. Initialization + lmon = (/'1jan','1feb','1mar','1apr','1may','1jun',& + & '1jul','1aug','1sep','1oct','1nov','1dec'/) + + ln3d(:20) = (/& + & 'GH n 99 geopotential height [m]',& + & 'TEMP n 99 abs. temperature [degK]',& + & 'U n 99 zonal (u) wind [m/s]',& + & 'V n 99 meridional (v) wind [m/s]',& + & 'Q n 99 specific humidity [g/Kg]',& + & 'RH n 99 relative humidity [%]',& + & 'OMEGA n 99 pressure vertical velocity [Pa/s]',& + & 'PSI n 99 streamfunction [10^6 m^2/s]',& + & 'CHI n 99 velocity potential [10^6 m^2/s]',& + + & 'VARGH n 99 variance of geop. height [m^2]',& + & 'VART n 99 variance of temperature [degK^2]',& + & 'VARU n 99 variance of u-wind [J/Kg]',& + & 'VARV n 99 variance of v-wind [J/Kg]',& + & "COVUV n 99 u'v' covariance (trans.) [J/Kg]",& + & "COVVT n 99 v't' covariance (trans.) [degK m/s]",& + + & 'DTLSC n 99 dt/dt by large-scale cond. [degK/day]',& + & 'DTCNV n 99 dt/dt by convection [degK/day]',& + & 'DTRSW n 99 dt/dt by shortwave rad. [degK/day]',& + & 'DTRLW n 99 dt/dt by longwave rad. [degK/day]',& + & 'DTPBL n 99 dt/dt by pbl processes [degK/day]'/) + ln3d(21:) = ' ' + + ln2d_1(:18) = (/& + & 'SP 0 99 surface pressure [hPa]',& + & 'MSLP 0 99 mean-sea-level pressure [hPa]',& + & 'ST 0 99 surface temperature [degK]',& + & 'SKINT 0 99 skin temperature [degK]',& + & 'SWAV 0 99 soil wetness availability [%]',& + & 'ALB 0 99 surface albedo [%]',& + & 'U0 0 99 near-surface u-wind [m/s]',& + & 'V0 0 99 near-surface v-wind [m/s]',& + & 'TEMP0 0 99 near-surface air temperature [degK]',& + & 'RH0 0 99 near-surface relative humidity [%]',& + & 'CLC 0 99 cloud cover (deep clouds) [%]',& + & 'CLSTR 0 99 cloud cover (strat. clouds) [%]',& + & 'CLTOP 0 99 pressure at cloud top [hPa]',& + & 'IPTOP 0 99 highest precipitation level index []',& + & 'LST 0 99 land-surface temp. [degK]',& + & 'SST 0 99 sea-surface temp. [degK]',& + & 'SSTOM 0 99 ocean model sea-surface temp. [degK]',& + & 'SSTA 0 99 sst anomaly w.r.t. obs. clim. [degK]'/) + ln2d_1(19:) = ' ' + + ln2d_2(:12) = (/& + & 'PRECLS 0 99 large-scale precipitation [mm/day]',& + & 'PRECNV 0 99 convective precipitation [mm/day]',& + & 'EVAP 0 99 evaporation [mm/day]',& + & 'USTR 0 99 u-stress (dw.) [N/m^2]',& + & 'VSTR 0 99 v-stress (dw.) [M/m^2]',& + & 'TSR 0 99 top shortwave rad. (dw.) [W/m^2]',& + & 'OLR 0 99 outgoing longwave rad. (uw.) [W/m^2]',& + & 'SSR 0 99 surface shortwave rad. (dw.) [W/m^2]',& + & 'SLR 0 99 surface longwave rad. (uw.) [W/m^2]',& + & 'SHF 0 99 sensible heat flux (uw.) [W/m^2]',& + & 'LSHF 0 99 heat flux into land sfc (dw.) [W/m^2]',& + & 'SSHF 0 99 heat flux into sea sfc (dw.) [W/m^2]'/) + ln2d_2(13:) = ' ' + + line( 1)='dset ^attmxxx_%y4.grd' + line( 2)='title means/variances from run no. xxx' + line( 3)='undef 9.999e+19' + line( 4)='options sequential template big_endian 365_day_calendar' + line( 5)='xdef nnn linear 0.000 x.xxx' + line( 6)='ydef nnn levels' + line( 7)='zdef nn levels 950' + line( 8)='tdef nnnn linear 1jan1900 nnnndy' + line( 9)='vars nn' + line(10)='endvars' + + ctlname=name//norun//'.ctl' + open ( unit=iunit, file=ctlname, form='formatted' ) + c1=90./asin(1.) + + do k=1,nlev + ilev(k)=nint(1000.*rlev(k)) + end do + + ! 2. Insert parameters in strings + line(1)( 9:12)= name(1:4) + line(1)(13:15)=norun(1:3) + line(2)(43:45)=norun(1:3) + + write (line(5)(10:12),'(i3)') nlon + write (line(5)(31:40),'(f10.3)') (360./nlon) + write (line(6)(10:12),'(i3)') nlat + write (line(7)(10:12),'(i3)') nlev + + write (line(8) (7:12),'(i6)') ntm + line(8)(23:26) = lmon(imont0)(1:4) + write (line(8)(27:30),'(i4)') iyear0 + + if (ndtm.lt.0) then + write (line(8)(35:38),'(i4)') -ndtm + line(8)(39:40) = 'mo' + else if (mod(ndtm,1440).eq.0) then + write (line(8)(35:38),'(i4)') ndtm/1440 + line(8)(39:40) = 'dy' + else if (mod(ndtm,60).eq.0) then + write (line(8)(35:38),'(i4)') ndtm/60 + line(8)(39:40) = 'hr' + else + write (line(8)(35:38),'(i4)') ndtm + line(8)(39:40) = 'mn' + endif + + write (line(9)(11:12),'(i2)') n3d+n2d_1+n2d_2 + + ! 3. Write ASCII control file + do jline=1,5 + write (iunit,1000) line(jline) + end do + + write (iunit,1010) line(6)(1:20), (c1*rlat(j),j=1,nlat) + write (iunit,1020) line(7)(1:20), (ilev(k),k=nlev,1,-1) + + do jline=8,9 + write (iunit,1000) line(jline) + end do + + do jline=i3d,i3d+n3d-1 + write (ln3d(jline)(10:12),'(i3)') nlev + write (iunit,1000) ln3d(jline) + end do + + do jline=1,n2d_1 + write (iunit,1000) ln2d_1(jline) + end do + + do jline=1,n2d_2 + write (iunit,1000) ln2d_2(jline) + end do + + write (iunit,1000) line(10) + + close ( unit=iunit ) + + 1000 format (a80) + 1010 format (a20,6f10.3/(8f10.3)) + 1020 format (a20,10i6) +end + +subroutine setctl_d(iunit,nlon,nlat,nlev,ntm,ndtm,n2d_1,n2d_2,rlat,rlev,name,& + & norun,iyear0,imont0) + ! Aux. routine setctl_d : write descriptor (.ctl) output file + + implicit none + + integer, intent(in) :: iunit, nlon, nlat, nlev, ntm, ndtm, n2d_1, n2d_2,& + & iyear0, imont0 + real, intent(in) :: rlat(nlat), rlev(nlev) + character(len=80) :: line(10), ln2d_1(10), ln2d_2(10) + character(len=4) :: lmon(12) + character(len=5) :: name + character(len=3) :: norun + character(len=12) :: ctlname + integer :: ilev(30), ncount, j, jline, k + real :: c1 + + ! 1. Initialization + lmon = (/'1jan','1feb','1mar','1apr','1may','1jun',& + & '1jul','1aug','1sep','1oct','1nov','1dec'/) + + ln2d_1(:8) = (/& + & 'MSLP 0 99 mean-sea-level pressure [hPa]',& + & 'TEMP0 0 99 near-surface air temperature [degK]',& + & 'GH_500 0 99 geopotential height at 500 hPa [m]',& + & 'U_850 0 99 zonal (u) wind at 850 hPa [m/s]',& + & 'V_850 0 99 meridional (v) wind at 850 hPa [m/s]',& + & 'Q_850 0 99 specific humidity at 850 hPa [g/Kg]',& + & 'U_200 0 99 zonal (u) wind at 200 hPa [m/s]',& + & 'V_200 0 99 meridional (v) wind at 200 hPa [m/s]'/) + ln2d_1(9:) = ' ' + + ln2d_2(:7) = (/& + & 'PREC 0 99 precipitation [mm/day]',& + & 'EVAP 0 99 evaporation [mm/day]',& + & 'USTR 0 99 u-stress (dw.) [N/m^2]',& + & 'VSTR 0 99 v-stress (dw.) [N/m^2]',& + & 'OLR 0 99 outgoing longwave rad. (uw.) [W/m^2]',& + & 'LSHF 0 99 heat flux into land sfc (dw.) [W/m^2]',& + & 'SSHF 0 99 heat flux into sea sfc (dw.) [W/m^2]'/) + ln2d_2(8:) = ' ' + + line( 1)='dset ^attmdxxx_%y4.grd' + line( 2)='title daily means from run no. xxx' + line( 3)='undef 9.999e+19' + line( 4)='options sequential template big_endian 365_day_calendar' + line( 5)='xdef nnn linear 0.000 x.xxx' + line( 6)='ydef nnn levels' + line( 7)='zdef nn levels 950' + line( 8)='tdef nnnnnn linear 1jan1900 nndy' + line( 9)='vars nn' + line(10)='endvars' + + ctlname=name//norun//'.ctl' + open ( unit=iunit, file=ctlname, form='formatted' ) + c1=90./asin(1.) + + do k=1,nlev + ilev(k)=nint(1000.*rlev(k)) + end do + + ! 2. Insert parameters in strings + line(1)( 9:13)= name(1:5) + line(1)(14:16)=norun(1:3) + line(2)(39:41)=norun(1:3) + + write (line(5)(10:12),'(i3)') nlon + write (line(5)(31:40),'(f10.3)') (360./nlon) + write (line(6)(10:12),'(i3)') nlat + write (line(7)(10:12),'(i3)') nlev + + write (line(8) (7:12),'(i6)') ntm + line(8)(23:26) = lmon(imont0)(1:4) + write (line(8)(27:30),'(i4)') iyear0 + write (line(8)(37:38),'(i2)') ndtm + line(8)(39:40) = 'dy' + + write (line(9)(11:12),'(i2)') n2d_1+n2d_2 + + ! 3. Write ASCII control file + do jline=1,5 + write (iunit,1000) line(jline) + end do + + write (iunit,1010) line(6)(1:20), (c1*rlat(j),j=1,nlat) + write (iunit,1020) line(7)(1:20), (ilev(k),k=nlev,1,-1) + + do jline=8,9 + write (iunit,1000) line(jline) + end do + + do jline=1,n2d_1 + write (iunit,1000) ln2d_1(jline) + end do + + do jline=1,n2d_2 + write (iunit,1000) ln2d_2(jline) + end do + + write (iunit,1000) line(10) + close ( unit=iunit ) + + 1000 format (a80) + 1010 format (a20,6f10.3/(8f10.3)) + 1020 format (a20,10i6) +end diff --git a/src/ppo_setgrd.f90 b/src/ppo_setgrd.f90 new file mode 100755 index 0000000..d7f14a4 --- /dev/null +++ b/src/ppo_setgrd.f90 @@ -0,0 +1,58 @@ +subroutine setgrd(ind,norun) + ! subroutine setgrd (ind) + ! Purpose : open and close output files (.grd) + ! + ! Input : ind = 0 for initialization, 1 otherwise + ! : norun = run identifier + + use mod_tsteps, only: idout + use mod_date, only: iyear + + implicit none + + integer, intent(in) :: ind + character(len=3), intent(in) :: norun + character(len=16), save :: ofile11, ofile13, ofile15 + character(len=17), save :: ofile17 + + if (ind.eq.0) then + ofile11='attmNNN_YYYY.grd' + ofile13='atvaNNN_YYYY.grd' + ofile15='atdfNNN_YYYY.grd' + + ofile11(5:7)=norun + ofile13(5:7)=norun + ofile15(5:7)=norun + + if (IDOUT .gt. 0) then + ofile17='daytmNNN_YYYY.grd' + ofile17(6:8)=norun + end if + end if + + write (ofile11(9:12),'(i4)') iyear + write (ofile13(9:12),'(i4)') iyear + write (ofile15(9:12),'(i4)') iyear + + if (idout.gt.0) write (ofile17(10:13),'(i4)') iyear + + if (ind.ne.0) then + close( unit=11 ) + close( unit=13 ) + close( unit=15 ) + + if (idout.gt.0) close( unit=17 ) + end if + + open ( unit=11, file=ofile11, status='new', form='unformatted',& + & access='sequential' ) + open ( unit=13, file=ofile13, status='new', form='unformatted',& + & access='sequential' ) + open ( unit=15, file=ofile15, status='new', form='unformatted',& + access='sequential' ) + + if (idout.gt.0) then + open ( unit=17, file=ofile17, status='new', form='unformatted',& + & access='sequential' ) + end if +end diff --git a/src/ppo_tminc.f90 b/src/ppo_tminc.f90 new file mode 100755 index 0000000..edd7483 --- /dev/null +++ b/src/ppo_tminc.f90 @@ -0,0 +1,356 @@ +subroutine tminc + ! subroutine tminc + ! + ! Purpose : perform post-processing on pressure levels + ! and increment time-mean arrays + ! Modified common blocks : TMSAVE + ! + + use mod_lflags, only: lppres + use mod_atparam + use mod_tmean, only: ns3d1, ns3d2, ns3d3, save3d, save2d_1, rnsave,& + & save2d_d1 + use mod_physcon, only: gg, rd, sigl, pout + use mod_surfcon, only: phis0 + use mod_cli_land, only: bmask_l + use mod_var_land, only: stl_am, soilw_am + use mod_cli_sea, only: bmask_s + use mod_var_sea, only: sst_am, sstan_am, sst_om, ssti_om + use mod_physvar + use mod_radcon, only: albsfc + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + real :: adsave(ngp,6), phisg(ngp), pmsl(ngp), qsatpl(ngp), st0(ngp) + + ! Fields for vertical interpolation + integer :: k0(ngp), iitest, nv, nvt, nuv, n0, n, kmid, klow, kj1, j, k, kj + integer :: khigh + real :: w0(ngp), zout(ngp), zinp(nlev), rdzinp(nlev) + real :: rg, rdr2, gam0, rgam, zmin, tsg, wref, tref, textr, rrgam, plog + real :: phi1, phi2, fwind, aref + + phisg = reshape(phis0, (/ngp/)) + + ! Level indices for daily-mean storage of upper-air fields + ! Upper tropos. u, v : + khigh = 3 + ! Mid-tropos. geopotential height : + kmid = 5 + ! Lower tropos. u, v, q : + klow = 7 + + iitest=0 + if (iitest.eq.1) print *, ' inside tminc' + + rg = 1./gg + rdr2 = 0.5*rd + gam0 = 0.006*rg + rgam = rd*gam0 + rrgam = 1./rgam + + ! 0. Increment post-processing counter + rnsave = rnsave +1 + + ! 1. Store 2-d time-mean fields + + ! 1.1 Compute additional surface fields + if (iitest.eq.1) print*,' store 2d fields' + + ! Mean-sea-level pressure + do j=1,ngp + tsg=0.5*(t0(j)+max(255.,min(295.,t0(j)))) + pmsl(j)=psg(j)*(1.+gam0*phisg(j)/tsg)**rrgam + end do + + ! 1.2 Increment time-mean arrays + n0=0 + call add1f(save2d_1,psg, ngp,n0,1000) + call add1f(save2d_1,pmsl, ngp,n0,1000) + call add1f(save2d_1,ts, ngp,n0,1) + call add1f(save2d_1,tskin, ngp,n0,1) + call add1f(save2d_1,soilw_am, ngp,n0,100) + call add1f(save2d_1,albsfc, ngp,n0,100) + call add1f(save2d_1,u0, ngp,n0,1) + call add1f(save2d_1,v0, ngp,n0,1) + call add1f(save2d_1,t0, ngp,n0,1) + call add1f(save2d_1,rh(1,nlev),ngp,n0,100) + call add1f(save2d_1,cloudc, ngp,n0,100) + call add1f(save2d_1,clstr, ngp,n0,100) + call add1f(save2d_1,cltop, ngp,n0,1000) + call add1f(save2d_1,prtop, ngp,n0,1) + + ! Land and sea surface temperatures + call maskout(stl_am,st0,bmask_l,ngp) + call add1f(save2d_1,st0,ngp,n0,1) + call maskout(sst_am,st0,bmask_s,ngp) + call add1f(save2d_1,st0,ngp,n0,1) + ! Ocean model SST + !call maskout(sst_om,st0,bmask_s,ngp) + ! Ocean model SST + T_ice + call maskout(ssti_om,st0,bmask_s,ngp) + call add1f(save2d_1,st0,ngp,n0,1) + ! SST anomaly (wrt obs. clim.) + call maskout(sstan_am,st0,bmask_s,ngp) + call add1f(save2d_1,st0,ngp,n0,1) + + ! NB Fluxes of water, energy and momentum are stored + ! every time step by subroutine fluxinc + + ! 1.3 Increment daily-mean arrays + do j=1,ngp + save2d_d1(j,1)=save2d_d1(j,1)+pmsl(j)*1000 + save2d_d1(j,2)=save2d_d1(j,2)+t0(j) + end do + + ! 2. Perform vertical interpolation from sigma to pressure levels + ! and increment time-mean fields + if (iitest.eq.1) print*, ' store 3d fields' + + zinp(1) =-sigl(1) + do k=2,nlev + zinp(k) =-sigl(k) + rdzinp(k)= 1./(zinp(k-1)-zinp(k)) + end do + + zmin = zinp(nlev) + + do k=1,kx + ! 2.1 Set coefficients for vertical interpolation + ! using coordinate Z = log (p_s/p) + if (lppres) then + plog=log(pout(k)) + do j=1,ngp + zout(j)=pslg1(j)-plog + end do + else + ! Set zout=zinp(k) to do post-proc. on sigma levels + do j=1,ngp + zout(j)=zinp(k) + end do + end if + + call setvin(zinp,rdzinp,zout,ngp,kx,k0,w0) + + ! 2.2 Interpolate 3-d fields + ! Temperature (extrapolated below the lowest level when W0(j)<0) + call verint(adsave(1,2),tg1,ngp,kx,k0,w0) + + ! Remove extrapolation of temperature inversions + ! and correct extrap. values using a reference lapse rate + wref = 0.7 + + do j=1,ngp + if (zout(j).lt.zmin) then + textr = max(adsave(j,2),tg1(j,nlev)) + aref = rgam*(zmin-zout(j)) + tref = tg1(j,nlev)*(1.+aref+0.5*aref*aref) + adsave(j,2) = textr+wref*(tref-textr) + end if + end do + + ! Geopotential (computed from the closest levels + ! using the hydrostatic equation) + do j=1,ngp + w0(j)=max(w0(j),0.) + end do + + if (lppres) then + do j=1,ngp + kj=k0(j) + kj1=kj-1 + phi1=phig1(j,kj)+rdr2*(adsave(j,2)+tg1(j,kj ))& + & *(zout(j)-zinp(kj)) + phi2=phig1(j,kj1)+rdr2*(adsave(j,2)+tg1(j,kj1))& + & *(zout(j)-zinp(kj1)) + adsave(j,1)=phi1+w0(j)*(phi2-phi1) + end do + else + call verint(adsave(1,1),phig1,ngp,kx,k0,w0) + end if + + ! Wind and relative humidity + ! a) Interpolate above the lowest level + call verint(adsave(1,3),ug1,ngp,kx,k0,w0) + call verint(adsave(1,4),vg1,ngp,kx,k0,w0) + call verint(adsave(1,6),rh, ngp,kx,k0,w0) + + ! b) Decrease wind speed below the lowest level + do j=1,ngp + if (zout(j).lt.zmin) then + fwind=adsave(j,1)/phig1(j,nlev) + adsave(j,3)=adsave(j,3)*fwind + adsave(j,4)=adsave(j,4)*fwind + end if + end do + + ! Estimate specific humidity using interpolated rel.hum. and + ! sat. spec.hum. at interpolated temperature + if (lppres) then + call shtorh(-1,ngp,adsave(1,2),pout(k),-1.,adsave(1,5),adsave(1,6),& + & qsatpl) + + ! Below the surface, set spec.hum. = near-surface value + do j=1,ngp + if (zout(j).lt.0.0) then + adsave(j,5)=q0(j) + adsave(j,6)=q0(j)/qsatpl(j) + end if + end do + else + call verint(adsave(1,5),qg1,ngp,kx,k0,w0) + end if + + ! Rescale geopotential and rel. humidity + do j=1,ngp + adsave(j,1)=adsave(j,1)*rg + adsave(j,6)=adsave(j,6)*100. + end do + + ! 2.3 Save upper-air fields + + ! 2.3.1 Add 3d upper-air fields to time-mean arrays + do n=1,6 + do j=1,ngp + save3d(j,k,n)=save3d(j,k,n)+adsave(j,n) + end do + end do + + ! 2.3.2 Add upper-air fields fields at selected levels to daily-means + ! arrays + if (k.eq.kmid) then + do j=1,ngp + save2d_d1(j,3)=save2d_d1(j,3)+adsave(j,1) + end do + end if + + if (k.eq.klow) then + do j=1,ngp + save2d_d1(j,4)=save2d_d1(j,4)+adsave(j,3) + save2d_d1(j,5)=save2d_d1(j,5)+adsave(j,4) + save2d_d1(j,6)=save2d_d1(j,6)+adsave(j,5) + end do + else if (k.eq.khigh) then + do j=1,ngp + save2d_d1(j,7)=save2d_d1(j,7)+adsave(j,3) + save2d_d1(j,8)=save2d_d1(j,8)+adsave(j,4) + end do + end if + + ! 2.4 Store variances on pressure levels + if (ns3d2.gt.0) then + do n=1,4 + nv=ns3d1+n + do j=1,ngp + save3d(j,k,nv)=save3d(j,k,nv)+adsave(j,n)*adsave(j,n) + end do + end do + + nuv=ns3d1+5 + nvt=ns3d1+6 + do j=1,ngp + save3d(j,k,nuv)=save3d(j,k,nuv)+adsave(j,3)*adsave(j,4) + save3d(j,k,nvt)=save3d(j,k,nvt)+adsave(j,2)*adsave(j,4) + end do + end if + ! end-of-loop over pressure levels + end do + + ! 3. Store diabatic forcing terms on model levels + if (ns3d3.gt.0) then + n0=ns3d1+ns3d2 + call add1f(save3d,tt_lsc,ngp*nlev,n0,1) + call add1f(save3d,tt_cnv,ngp*nlev,n0,1) + call add1f(save3d,tt_rsw,ngp*nlev,n0,1) + call add1f(save3d,tt_rlw,ngp*nlev,n0,1) + call add1f(save3d,tt_pbl,ngp*nlev,n0,1) + end if + + if (iitest.eq.1) print *, 'end of tminc' +end + +subroutine setvin(zinp,rdzinp,zout,ngp,nlev,k0,w0) + implicit none + + real, intent(in) :: zinp(nlev), rdzinp(nlev), zout(ngp) + integer, intent(in) :: ngp, nlev + real, intent(inout) :: w0(ngp) + integer, intent(inout) :: k0(ngp) + integer :: j, k + + ! *** 1. Select closest vertical levels + do j=1,ngp + k0(j)=2 + end do + + do k=2,nlev-1 + do j=1,ngp + if (zout(j).lt.zinp(k)) k0(j)=k+1 + end do + end do + + ! *** 2. Compute interpolation weight + do j=1,ngp + w0(j)=(zout(j)-zinp(k0(j)))*rdzinp(k0(j)) + end do +end + +subroutine verint(f2d,f3d,ngp,nlev,k0,w0) + implicit none + + ! *** 1. Perform vertical interpolation + integer, intent(in) :: ngp, nlev, k0(ngp) + real, intent(in) :: f3d(ngp,nlev), w0(ngp) + real, intent(inout) :: f2d(ngp) + integer :: j + + do j=1,ngp + f2d(j)=f3d(j,k0(j))+w0(j)*(f3d(j,k0(j)-1)-f3d(j,k0(j))) + end do +end + +subroutine add1f(fsave,fadd,ngp,nf,ifact) + implicit none + + ! *** Add one field to storage array + real, intent(in) :: fadd(ngp) + integer, intent(in) :: ngp, ifact + real, intent(inout) :: fsave(ngp,*) + integer, intent(inout) :: nf + integer :: j + + nf=nf+1 + + if (ifact.eq.1) then + do j=1,ngp + fsave(j,nf)=fsave(j,nf)+fadd(j) + end do + else + do j=1,ngp + fsave(j,nf)=fsave(j,nf)+fadd(j)*ifact + end do + end if +end + +subroutine maskout(finp,fout,fmask,ngp) + implicit none + + ! *** Set undefined values according to binary land-sea mask + real, intent(in) :: finp(ngp), fmask(ngp) + integer, intent(in) :: ngp + real, intent(inout) :: fout(ngp) + integer :: j + real :: xundef + + xundef = 9.999e+19 + + do j=1,ngp + if (fmask(j).le.0.) then + fout(j) = xundef + else + fout(j) = finp(j) + end if + end do +end diff --git a/src/ppo_tmout.f90 b/src/ppo_tmout.f90 new file mode 100755 index 0000000..5616ff6 --- /dev/null +++ b/src/ppo_tmout.f90 @@ -0,0 +1,140 @@ +subroutine tmout(imode) + ! subroutine tmout (imode) + ! + ! Purpose : write time-means and variances into output files + ! Input : imode = 0 initialize time-mean arrays to 0 + ! imode > 0 write time-means and reset arrays to 0 + ! Modified common blocks : TMSAVE + ! + + use mod_tsteps, only: nstppr + use mod_atparam + use mod_tmean + use mod_physcon, only: p0, pout + + implicit none + + integer, parameter :: nlon=ix, nlat=il, nlev=kx, ngp=nlon*nlat + + integer, intent(in) :: imode + + ! Fields used to compute omega, psi and chi + complex :: vorsp(mx,nx), divsp(mx,nx), psisp(mx,nx) + + real :: div3d(ngp,nlev), dpr2, fmean + real*4 :: r4out(ngp) + + integer :: iitest=1, k, n, nuv, nv, nvt + if (iitest.eq.1) print *, 'inside TMOUT' + + if (imode.eq.0) go to 700 + + ! 1. Divide the accumulated fields to get the means + ! Fields saved at post-processing steps + fmean = 1./rnsave + + save3d(:,:,:) = save3d(:,:,:)*fmean + save2d_1(:,:) = save2d_1(:,:)*fmean + + ! Fields saved at every step (fluxes) + fmean = fmean/real(nstppr) + + save2d_2(:,:) = save2d_2(:,:)*fmean + + ! 2. Compute omega, psi and chi on p surfaces from wind + do k=1,kx + call vdspec (save3d(1,k,3),save3d(1,k,4),vorsp,divsp,2) + if (ix.eq.iy*4) then + call TRUNCT (VORSP) + call TRUNCT (DIVSP) + end if + + call invlap (vorsp,psisp) + call grid (psisp,save3d(1,k,8),1) + call invlap (divsp,psisp) + call grid (psisp,save3d(1,k,9),1) + call grid (divsp,div3d(1,k),1) + end do + + dpr2 = 0.5*pout(1)*p0 + save3d(:,1,7) = -div3d(:,1)*dpr2 + + do k=2,kx + dpr2 = 0.5*(POUT(k)-POUT(k-1))*p0 + save3d(:,k,7) = save3d(:,k-1,7)-(div3d(:,k)+div3d(:,k-1))*dpr2 + end do + + save3d(:,:,8) = save3d(:,:,8)*1.e-6 + save3d(:,:,9) = save3d(:,:,9)*1.e-6 + + ! 3. Write time-mean output file including 3-d and 2-d fields + if (iitest.eq.1) print*,' write model output' + + do n=1,ns3d1 + do k=kx,1,-1 + r4out(:) = save3d(:,k,n) + write (11) r4out + end do + end do + + do n=1,ns2d_1 + r4out(:) = save2d_1(:,n) + write (11) r4out + end do + + do n=1,ns2d_2 + r4out(:) = save2d_2(:,n) + write (11) r4out + end do + + !---------------------------------------------------------------- + + if (ns3d2.gt.0) then + ! 4. Compute variances and covariances + do n=1,4 + nv=n+ns3d1 + save3d(:,:,nv) = save3d(:,:,nv)-save3d(:,:,n)**2 + end do + + nuv=ns3d1+5 + save3d(:,:,nuv) = save3d(:,:,nuv)-save3d(:,:,3)*save3d(:,:,4) + + nvt=ns3d1+6 + save3d(:,:,nvt) = save3d(:,:,nvt)-save3d(:,:,2)*save3d(:,:,4) + + ! 5. Write 2-nd order moments + do n=ns3d1+1,ns3d1+ns3d2 + do k=kx,1,-1 + r4out(:) = save3d(:,k,n) + write (13) r4out + end do + end do + end if + + !---------------------------------------------------------------- + + if (ns3d3.gt.0) then + ! 6. Write diabatic forcing fields (in degK/day) + do n=ns3d1+ns3d2+1,ns3d + do k=kx,1,-1 + r4out(:) = save3d(:,k,n)*86400. + write (15) r4out + end do + end do + end if + + !---------------------------------------------------------------- + + ! 7. Reset arrays to zero for the next time-mean + 700 continue + + if (iitest.eq.1) print*,' reset to zero' + + rnsave = 0. + + SAVE3D(:,:,:) = 0. + SAVE2D_1(:,:) = 0. + SAVE2D_2(:,:) = 0. + + if (iitest.eq.1) print *, 'end of TMOUT' +end diff --git a/src/res_domain.f90 b/src/res_domain.f90 new file mode 100755 index 0000000..46ff531 --- /dev/null +++ b/src/res_domain.f90 @@ -0,0 +1,1600 @@ +module resdomain + use mod_utilities, only : dp, grid_type, main_type, & + speedygridnum, xgrid, ygrid, zgrid, & + speedylat, reservoir_type, & + model_parameters_type + + implicit none + + integer, parameter :: one=1 + + !Interface to the tiler function + interface tileoverlapgrid + module procedure tileoverlapgrid5d + module procedure tileoverlapgrid4d + module procedure tileoverlapgrid3d + module procedure tileoverlapgrid2d + end interface tileoverlapgrid + + interface tile_full_input_to_target_data + module procedure tile_full_input_to_target_data2d + module procedure tile_full_input_to_target_data1d + end interface tile_full_input_to_target_data + + interface tile_full_input_to_target_data_ocean_model + module procedure tile_full_input_to_target_data2d_ocean_model + module procedure tile_full_input_to_target_data1d_ocean_model + end interface tile_full_input_to_target_data_ocean_model + + contains + + subroutine processor_decomposition(model_parameters) + type(model_parameters_type), intent(inout) :: model_parameters + + integer :: num_regions_per_processor, left_over + integer :: i + + num_regions_per_processor = model_parameters%number_of_regions/model_parameters%numprocs + + left_over = mod(model_parameters%number_of_regions,model_parameters%numprocs) + + if((model_parameters%irank >= left_over+1).and.(model_parameters%irank > 0)) then + allocate(model_parameters%region_indices(num_regions_per_processor)) + model_parameters%num_of_regions_on_proc = num_regions_per_processor + do i=1,num_regions_per_processor + model_parameters%region_indices(i) = num_regions_per_processor*model_parameters%irank + i - 1 + enddo + elseif(model_parameters%irank == 0) then + allocate(model_parameters%region_indices(num_regions_per_processor)) + model_parameters%num_of_regions_on_proc = num_regions_per_processor + do i=1,num_regions_per_processor + model_parameters%region_indices(i) = i - 1 + enddo + else + allocate(model_parameters%region_indices(num_regions_per_processor+1)) + model_parameters%num_of_regions_on_proc = num_regions_per_processor + 1 + do i=1,num_regions_per_processor + model_parameters%region_indices(i) = num_regions_per_processor*model_parameters%irank + i - 1 + enddo + model_parameters%region_indices(i) = model_parameters%number_of_regions - left_over + model_parameters%irank - 1 + endif + + end subroutine + + subroutine processor_decomposition_manual(proc_number,numprocs,number_of_regions,region_indices) + integer, intent(in) :: proc_number, numprocs, number_of_regions + + integer, allocatable, intent(out) :: region_indices(:) + + integer :: num_regions_per_processor, left_over + integer :: i + + num_regions_per_processor = number_of_regions/numprocs + + left_over = mod(number_of_regions,numprocs) + + if((proc_number >= left_over+1).and.(proc_number > 0)) then + allocate(region_indices(num_regions_per_processor)) + do i=1,num_regions_per_processor + region_indices(i) = num_regions_per_processor*proc_number + i - 1 + enddo + elseif(proc_number == 0) then + allocate(region_indices(num_regions_per_processor)) + do i=1,num_regions_per_processor + region_indices(i) = i - 1 + enddo + else + allocate(region_indices(num_regions_per_processor+1)) + do i=1,num_regions_per_processor + region_indices(i) = num_regions_per_processor*proc_number + i - 1 + enddo + region_indices(i) = number_of_regions - left_over + proc_number - 1 + endif + + end subroutine + + subroutine initializedomain(num_regions,region_num,overlap,num_vert_levels,vert_level,vert_overlap,grid) + !Initializes the object grid with the processors domain info + type(grid_type), intent(inout) :: grid + + integer, intent(in) :: num_regions,region_num,overlap + integer, intent(in) :: num_vert_levels,vert_level,vert_overlap + + logical, parameter :: setpole=.True. + + call getxyresextent(num_regions,region_num,grid%res_xstart,grid%res_xend, grid%res_ystart, grid%res_yend, grid%resxchunk,grid%resychunk) + + call get_z_res_extent(num_vert_levels,vert_level,grid%res_zstart,grid%res_zend,grid%reszchunk) + + call getoverlapindices(num_regions,region_num,overlap,grid%input_xstart,grid%input_xend,grid%input_ystart,grid%input_yend,grid%inputxchunk,grid%inputychunk,grid%pole,grid%periodicboundary,setpole) + call getoverlapindices_vert(num_vert_levels,vert_level,vert_overlap,grid%input_zstart,grid%input_zend,grid%inputzchunk,grid%top,grid%bottom,setpole) + + call get_trainingdataindices(num_regions,region_num,overlap,grid%tdata_xstart,grid%tdata_xend,grid%tdata_ystart,grid%tdata_yend) + + call get_trainingdataindices_vert(num_vert_levels,vert_level,vert_overlap,grid%tdata_zstart,grid%tdata_zend) + + grid%overlap = overlap + grid%num_vert_levels = num_vert_levels + grid%vert_overlap = vert_overlap + grid%number_of_regions = num_regions + + end subroutine + + subroutine getxyresextent(num_regions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk) + !Get the ij indices on the global for the local processor of just the + !data that is fitted by the reservoir + + integer, intent(in) :: num_regions,region_num + integer, intent(out) :: localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk + integer :: cornerx,cornery + + call domaindecomposition(num_regions,localxchunk,localychunk) + + call getworkerlower_leftcorner(region_num,localychunk,cornerx,cornery) + + localres_xstart = cornerx*localxchunk + 1 + localres_xend = (cornerx+1)*localxchunk + + localres_ystart = cornery*localychunk + 1 + localres_yend = (cornery+1)*localychunk + return + end subroutine + + subroutine get_z_res_extent(num_vert_levels,vert_level,local_res_zstart,local_res_zend,local_reszchunk) + integer, intent(in) :: num_vert_levels,vert_level + integer, intent(out) :: local_res_zstart,local_res_zend,local_reszchunk + + local_reszchunk = zgrid/num_vert_levels + + local_res_zstart = (vert_level - 1)*local_reszchunk + 1 + local_res_zend = (vert_level)*local_reszchunk + + return + end subroutine + + subroutine getoverlapindices(numregions,region_num,overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk,localpole,localperiodicboundary,setflag) + !Gets the ij indices in 2d on the global for the overlapping (input) + !region of each sub-domain + + integer, intent(in) :: region_num, numregions, overlap + integer, intent(out) :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinputxchunk,localinputychunk + logical, intent(out) :: localpole, localperiodicboundary + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk + logical, optional :: setflag + + call getxyresextent(numregions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk) + localinputxchunk = localxchunk + 2*overlap !There will always be a set number from this because there is always a left and right worker + localinputychunk = localychunk + 2*overlap !Start with the max and work your way down if the conditions are meet + + + localperiodicboundary = .False. + localpole = .False. + + if((localres_xstart - overlap).lt.one) then + localinput_xstart = xgrid - overlap + 1 + localperiodicboundary = .True. + else + localinput_xstart = localres_xstart - overlap + endif + + if((localres_xend + overlap).gt.xgrid) then + localinput_xend = overlap + localperiodicboundary = .True. + else + + localinput_xend = overlap + localres_xend + endif + + if((localres_ystart - overlap).lt.one) then + localinput_ystart = one !localres_ystart + localinputychunk = localychunk + overlap + (localres_ystart - 1)!localinputychunk - overlap + localpole = .True. + else + localinput_ystart = localres_ystart - overlap + endif + + if((localres_yend + overlap).gt.ygrid) then + localinput_yend = ygrid !localres_yend + localinputychunk = localychunk + overlap + (ygrid - localres_yend) !localinputychunk - overlap + localpole = .True. + else + localinput_yend = overlap + localres_yend + endif + return + end subroutine + + subroutine getoverlapindices_vert(num_vert_levels,vert_level,vert_overlap,input_zstart,input_zend,inputzchunk,top,bottom,setflag) + integer, intent(in) :: num_vert_levels, vert_level, vert_overlap + integer, intent(out) :: input_zstart,input_zend,inputzchunk + logical, intent(out) :: top, bottom + logical, optional :: setflag + + integer :: local_res_zstart,local_res_zend,local_reszchunk + + + call get_z_res_extent(num_vert_levels,vert_level,local_res_zstart,local_res_zend,local_reszchunk) + + top = .false. + bottom = .false. + + + if(local_res_zstart == one) then + top = .true. + endif + + if(local_res_zend == zgrid) then + bottom = .true. + endif + + if((local_res_zstart - vert_overlap >= one).and.(local_res_zend + vert_overlap <= zgrid)) then + input_zstart = local_res_zstart - vert_overlap + input_zend = local_res_zend + vert_overlap + + inputzchunk = local_reszchunk + 2*vert_overlap + elseif(local_res_zstart - vert_overlap < one) then + input_zstart = one + input_zend = local_res_zend + vert_overlap + + inputzchunk = local_reszchunk + vert_overlap + (local_res_zstart - 1) + + elseif(local_res_zend + vert_overlap > zgrid) then + input_zstart = local_res_zstart - vert_overlap + input_zend = zgrid + + inputzchunk = local_reszchunk + vert_overlap + (zgrid - local_res_zend) !(local_res_zend - zgrid) + + else + print *, 'something is wrong' + print *, 'vert_level,local_res_zstart,local_res_zend,vert_overlap',vert_level,local_res_zstart,local_res_zend,vert_overlap + endif + + !if(inputzchunk > zgrid .or. input_zstart < 1 .or. input_zend > zgrid) then + ! inputzchunk = min(inputzchunk,zgrid) + ! input_zstart = max(input_zstart,one) + ! input_zend = min(input_zend,zgrid) + !endif + end subroutine + + subroutine domaindecomposition(numregions,factorx,factory) + !Breaks the global in 2d into each grid point rectangles based + !on the number of regions (sub-domains) + integer, intent(in) :: numregions + integer, intent(out) :: factorx,factory + integer :: i,n,factorMax,check + + n = speedygridnum/numregions + factorMax = floor(SQRT(real(n))) + + do i=factorMax,0, -1 + if(MOD(ygrid,i).eq.0) then + factory = i + if(mod(n,factory).eq.0) then + factorx = n/factory + if(mod(xgrid,factorx).eq.0) then + exit + endif + endif + endif + enddo + return + end subroutine + + subroutine getworkerlower_leftcorner(region_num,factory,row,col) + !Gets lower left corner ij index for a specific region + + integer, intent(in) :: region_num, factory + integer, intent(out) :: row,col + + col = mod(region_num,ygrid/factory) + row = floor(real(region_num)/(real(ygrid)/real(factory))) + + return + end subroutine + + subroutine tileoverlapgrid5d(grid,numregions,region_num,overlap,localgrid) + !tiler for the full grid and time dimension + real(kind=dp), intent(in) :: grid(:,:,:,:,:) + integer, intent(in) :: numregions,region_num,overlap + real(kind=dp), intent(out), allocatable :: localgrid(:,:,:,:,:) + + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk + integer :: i,counter + integer :: gridshape(5) + logical :: localpole, localperiodicboundary + + gridshape = shape(grid) + call getxyresextent(numregions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk) + call getoverlapindices(numregions,region_num,overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary,.FALSE.) + + !Lets get the reservoir extent + if(.NOT.localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid,MOLD=grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:,:)) + localgrid = grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:,:) + endif + if(localperiodicboundary) then + allocate(localgrid(gridshape(1),localinput_xchunk,localinput_ychunk,gridshape(4),gridshape(5))) + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart:xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(:,1:(xgrid-(localinput_xstart-1)),:,:,:) = grid(:,localinput_xstart:xgrid,localinput_ystart:localinput_yend,:,:) + localgrid(:,(xgrid-(localinput_xstart-1))+1:localinput_xchunk,:,:,:) = grid(:,1:localinput_xend,localinput_ystart:localinput_yend,:,:) + else + localgrid = grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:,:) + endif + endif + elseif(localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid(gridshape(1),localinput_xchunk,localinput_ychunk,gridshape(4),gridshape(5))) + localgrid = grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:,:) + elseif(localperiodicboundary) then + allocate(localgrid(gridshape(1),localinput_xchunk,localinput_ychunk,gridshape(4),gridshape(5))) + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart:xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(:,1:(xgrid-(localinput_xstart-1)),:,:,:) = grid(:,localinput_xstart:xgrid,localinput_ystart:localinput_yend,:,:) + localgrid(:,(xgrid-(localinput_xstart-1))+1:localinput_xchunk,:,:,:) = grid(:,1:localinput_xend,localinput_ystart:localinput_yend,:,:) + else + !This means something is wrong or there is no overlap + localgrid = grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:,:) + endif + endif + endif + end subroutine + + subroutine tileoverlapgrid4d(grid,numregions,region_num,overlap,num_vert_levels,vert_level,vert_overlap,localgrid) + !tiler that gets the full grid and gives back the local grid when there + !is overlap + !NOTE only for one time step + !NOTE Im almost 100% this works + + real(kind=dp), intent(in) :: grid(:,:,:,:) + integer, intent(in) :: numregions,region_num,overlap,num_vert_levels,vert_level,vert_overlap + real(kind=dp), intent(out),allocatable :: localgrid(:,:,:,:) + + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk + + integer :: localinput_zstart,localinput_zend,localinput_zchunk + integer :: localres_zstart,localres_zend,localreszchunk + + integer :: i,counter + integer :: gridshape(4) + logical :: localpole,localperiodicboundary + logical :: top, bottom + + gridshape = shape(grid) + + call getxyresextent(numregions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk) + + call get_z_res_extent(num_vert_levels,vert_level,localres_zstart,localres_zend,localreszchunk) + + call getoverlapindices(numregions,region_num,overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary,.FALSE.) + + call getoverlapindices_vert(num_vert_levels,vert_level,vert_overlap,localinput_zstart,localinput_zend,localinput_zchunk,top,bottom,.False.) + + + !Lets get the reservoir extent + if(.NOT.localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid,source=grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend)) + endif + if(localperiodicboundary) then + allocate(localgrid(gridshape(1),localinput_xchunk,localinput_ychunk,localinput_zchunk)) + + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart:xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(:,1:(xgrid-(localinput_xstart-1)),:,:) = grid(:,localinput_xstart:xgrid,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend) + localgrid(:,(xgrid-(localinput_xstart-1))+1:localinput_xchunk,:,:) = grid(:,1:localinput_xend,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend) + else + !This means something is wrong or there is no overlap + print *,'This means something is wrong not pole',region_num + localgrid = grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend) + endif + endif + elseif(localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid,source=grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend)) + elseif(localperiodicboundary) then + allocate(localgrid(gridshape(1),localinput_xchunk,localinput_ychunk,localinput_zchunk)) + + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart:xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(:,1:(xgrid-(localinput_xstart-1)),:,:) = grid(:,localinput_xstart:xgrid,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend) + localgrid(:,(xgrid-(localinput_xstart-1))+1:localinput_xchunk,:,:) = grid(:,1:localinput_xend,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend) + else + !This means something is wrong or there is no overlap + print *,'This means something is wrong pole',region_num + localgrid = grid(:,localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,localinput_zstart:localinput_zend) + endif + endif + endif + return + end subroutine + + subroutine tileoverlapgrid3d(speedygrid,numprocs,worker,overlap,localgrid) + !tiler that gets the full grid and gives back the local grid when there + !is overlap + !NOTE 3d grid x y time + + real(kind=dp), intent(in) :: speedygrid(:,:,:) + integer, intent(in) :: numprocs,worker,overlap + real(kind=dp), intent(out),allocatable :: localgrid(:,:,:) + + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk + integer :: i,counter + integer :: speedygridshape(3) + logical :: localpole,localperiodicboundary + + speedygridshape = shape(speedygrid) + call getxyresextent(numprocs,worker,localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk) + call getoverlapindices(numprocs,worker,overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary,.FALSE.) + !Lets get the reservoir extent + if(.NOT.localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid,MOLD=speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:)) + localgrid = speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:) + endif + if(localperiodicboundary) then + allocate(localgrid(localinput_xchunk,localinput_ychunk,speedygridshape(3))) + + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(1:(xgrid-(localinput_xstart-1)),:,:) = speedygrid(localinput_xstart:xgrid,localinput_ystart:localinput_yend,:) + localgrid((xgrid-(localinput_xstart-1))+1:localinput_xchunk,:,:) = speedygrid(1:localinput_xend,localinput_ystart:localinput_yend,:) + else + !This means something is wrong or there is no overlap + print *,'This means something is wrong not pole',worker + localgrid = speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:) + endif + endif + elseif(localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid(localinput_xchunk,localinput_ychunk,speedygridshape(3))) + localgrid = speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:) + elseif(localperiodicboundary) then + allocate(localgrid(localinput_xchunk,localinput_ychunk,speedygridshape(3))) + + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart:xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(1:(xgrid-(localinput_xstart-1)),:,:) = speedygrid(localinput_xstart:xgrid,localinput_ystart:localinput_yend,:) + localgrid((xgrid-(localinput_xstart-1))+1:localinput_xchunk,:,:) = speedygrid(1:localinput_xend,localinput_ystart:localinput_yend,:) + else + !This means something is wrong or there is no overlap + print *,'This means something is wrong pole',worker + localgrid = speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend,:) + endif + endif + endif + return + end subroutine + + subroutine tileoverlapgrid2d(speedygrid,numregions,region_num,overlap,localgrid) + !tiler that gets the full grid and gives back the local grid when there + !is overlap + !NOTE 2d grid x y time + + real(kind=dp), intent(in) :: speedygrid(:,:) + integer, intent(in) :: numregions,region_num,overlap + real(kind=dp), intent(out),allocatable :: localgrid(:,:) + + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk + integer :: i,counter + integer :: speedygridshape(2) + logical :: localpole,localperiodicboundary + + speedygridshape = shape(speedygrid) + + call getxyresextent(numregions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk) + call getoverlapindices(numregions,region_num,overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary,.FALSE.) + + !Lets get the reservoir extent + if(.NOT.localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid,source=speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend)) + endif + if(localperiodicboundary) then + allocate(localgrid(localinput_xchunk,localinput_ychunk)) + + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart:xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(1:(xgrid-(localinput_xstart-1)),:) = speedygrid(localinput_xstart:xgrid,localinput_ystart:localinput_yend) + localgrid((xgrid-(localinput_xstart-1))+1:localinput_xchunk,:) = speedygrid(1:localinput_xend,localinput_ystart:localinput_yend) + else + !This means something is wrong or there is no overlap + print *,'This means something is wrong not pole',region_num + localgrid = speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend) + endif + endif + elseif(localpole) then + if(.NOT.localperiodicboundary) then + allocate(localgrid(localinput_xchunk,localinput_ychunk)) + localgrid = speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend) + elseif(localperiodicboundary) then + allocate(localgrid(localinput_xchunk,localinput_ychunk)) + + !Now lets determine if localinput_xstart>localinput_xend because + !if so we need to tile localgrid from localinput_xstart:xgrid + !first + if(localres_xend.gt.localinput_xend.or.localinput_xstart.gt.localres_xstart) then + localgrid(1:(xgrid-(localinput_xstart-1)),:) = speedygrid(localinput_xstart:xgrid,localinput_ystart:localinput_yend) + localgrid((xgrid-(localinput_xstart-1))+1:localinput_xchunk,:) = speedygrid(1:localinput_xend,localinput_ystart:localinput_yend) + else + !This means something is wrong or there is no overlap + print *,'This means something is wrong pole',region_num + localgrid = speedygrid(localinput_xstart:localinput_xend,localinput_ystart:localinput_yend) + endif + endif + endif + return + end subroutine + + subroutine get_trainingdataindices(num_regions,region_num,overlap,xstart,xend,ystart,yend) + !Get the fitting data indices in memory space + + integer, intent(in) :: region_num, num_regions, overlap + integer, intent(out) :: xstart,xend,ystart,yend + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,local_resxchunk,local_resychunk + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + logical :: localpole,localperiodicboundary + + call getxyresextent(num_regions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,local_resxchunk,local_resychunk) + call getoverlapindices(num_regions,region_num,overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary,.FALSE.) + + xstart = 1 + overlap + xend = localinput_xchunk - overlap + + !print *,worker,xstart,xend,localinput_xchunk + if((localres_ystart - overlap).lt.one) then + ystart = 1 + (localres_ystart - 1) + yend = localinput_ychunk - overlap + elseif((localres_yend + overlap).gt.ygrid) then + ystart = 1 + overlap + yend = localinput_ychunk - (ygrid - localres_yend) + else + ystart= 1 + overlap + yend = localinput_ychunk - overlap + endif + return + end subroutine + + subroutine get_trainingdataindices_vert(num_vert_levels,vert_level,vert_overlap,zstart,zend) + !Get the fitting data indices in memory space + + integer, intent(in) :: num_vert_levels,vert_level,vert_overlap + integer, intent(out) :: zstart,zend + integer :: localres_zstart,localres_zend,local_reszchunk + integer :: localinput_zstart,localinput_zend,localinput_zchunk + logical :: top,bottom + + call get_z_res_extent(num_vert_levels,vert_level,localres_zstart,localres_zend,local_reszchunk) + + call getoverlapindices_vert(num_vert_levels,vert_level,vert_overlap,localinput_zstart,localinput_zend,localinput_zchunk,top,bottom,.false.) + + if((localres_zstart - vert_overlap).lt.one) then + zstart = 1 + (localres_zstart - 1) + zend = localinput_zchunk - vert_overlap + elseif((localres_zend + vert_overlap).gt.zgrid) then + zstart = 1 + vert_overlap + zend = localinput_zchunk - (zgrid - localres_zend) + else + zstart= 1 + vert_overlap + zend = localinput_zchunk - vert_overlap + endif + return + end subroutine + + subroutine tile_full_input_to_target_data2d(reservoir,grid,statevec,tiledstatevec) + !Takes 2d input array and tiles it to a 2d target (res) array + !Second dimension is time. Dimension of statevec(reservoir_numinputs,time) + real(kind=dp), intent(in) :: statevec(:,:) + type(reservoir_type) :: reservoir + type(grid_type) :: grid + + real(kind=dp), allocatable, intent(out) :: tiledstatevec(:,:) + + real(kind=dp), allocatable :: temp5d(:,:,:,:,:), temp3d(:,:,:) + integer :: i, j + + i = size(statevec,1) + j = size(statevec,2) + + if(reservoir%logp_bool) then + allocate(temp5d(reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input,j)) + allocate(temp3d(grid%inputxchunk,grid%inputychunk,j)) + allocate(tiledstatevec(reservoir%chunk_size_prediction,j)) + + temp5d = reshape(statevec(1:reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*reservoir%local_heightlevels_input,:),(/reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input,j/)) + + temp3d = reshape(statevec(grid%logp_start:grid%logp_end,:),(/grid%inputxchunk,grid%inputychunk,j/)) + + tiledstatevec(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res,:) = reshape(temp5d(:,grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,grid%tdata_zstart:grid%tdata_zend,:),(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res,j/)) + tiledstatevec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk,:) = reshape(temp3d(grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,:),(/grid%resxchunk*grid%resychunk,j/)) + + deallocate(temp5d) + deallocate(temp3d) + else + allocate(temp5d(reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input,j)) + allocate(tiledstatevec(reservoir%chunk_size_prediction,j)) + + temp5d = reshape(statevec,(/reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input,j/)) + tiledstatevec = reshape(temp5d(:,grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,grid%tdata_zstart:grid%tdata_zend,:),(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res,j/)) + + deallocate(temp5d) + endif + + if(reservoir%precip_bool) then + allocate(temp3d(grid%inputxchunk,grid%inputychunk,j)) + + temp3d = reshape(statevec(grid%precip_start:grid%precip_end,:),(/grid%inputxchunk,grid%inputychunk,j/)) + + tiledstatevec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk+1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk*2,:) = reshape(temp3d(grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,:),(/grid%resxchunk*grid%resychunk,j/)) + endif + + return + + end subroutine + + subroutine tile_full_input_to_target_data1d(reservoir,grid,statevec,tiledstatevec) + !Takes 1d input array and tiles it to a 1d target (res) array + real(kind=dp), intent(in) :: statevec(:) + + type(reservoir_type) :: reservoir + type(grid_type) :: grid + + real(kind=dp), allocatable, intent(out) :: tiledstatevec(:) + + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + integer :: i, j + + i = size(statevec,1) + + if(reservoir%logp_bool) then + allocate(temp4d(reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input)) + allocate(temp2d(grid%inputxchunk,grid%inputychunk)) + allocate(tiledstatevec(reservoir%chunk_size_prediction)) + + temp4d = reshape(statevec(1:reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*reservoir%local_heightlevels_input),(/reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input/)) + + temp2d = reshape(statevec(reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*reservoir%local_heightlevels_input+1:reservoir%reservoir_numinputs-reservoir%tisr_size_input),(/grid%inputxchunk,grid%inputychunk/)) + + tiledstatevec(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res) = reshape(temp4d(:,grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,grid%tdata_zstart:grid%tdata_zend),(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + tiledstatevec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+1:reservoir%chunk_size_prediction) = reshape(temp2d(grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend),(/grid%resxchunk*grid%resychunk/)) + + else + allocate(temp4d(reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input)) + allocate(tiledstatevec(reservoir%chunk_size_prediction)) + + temp4d = reshape(statevec,(/reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,reservoir%local_heightlevels_input/)) + tiledstatevec = reshape(temp4d(1:reservoir%local_predictvars,grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,grid%tdata_zstart:grid%tdata_zend),(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + endif + + return + + end subroutine + + subroutine tile_full_input_to_target_data2d_ocean_model(reservoir,grid,statevec,tiledstatevec) + !Takes 2d input array and tiles it to a 2d target (res) array + !Second dimension is time. Dimension of + !statevec(reservoir_numinputs,time) + real(kind=dp), intent(in) :: statevec(:,:) + type(reservoir_type) :: reservoir + type(grid_type) :: grid + + real(kind=dp), allocatable, intent(out) :: tiledstatevec(:,:) + + real(kind=dp), allocatable :: temp3d(:,:,:) + integer :: i, j + + i = size(statevec,1) + j = size(statevec,2) + + allocate(temp3d(grid%inputxchunk,grid%inputychunk,j)) + allocate(tiledstatevec(reservoir%chunk_size_prediction,j)) + + temp3d = reshape(statevec(grid%sst_start:grid%sst_end,:),(/grid%inputxchunk,grid%inputychunk,j/)) + + tiledstatevec = reshape(temp3d(grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,:),(/grid%resxchunk*grid%resychunk,j/)) + + return + + end subroutine + + subroutine tile_full_input_to_target_data1d_ocean_model(reservoir,grid,statevec,tiledstatevec) + !Takes 1d input array and tiles it to a 1d target (res) array + real(kind=dp), intent(in) :: statevec(:) + + type(reservoir_type) :: reservoir + type(grid_type) :: grid + + real(kind=dp), allocatable, intent(out) :: tiledstatevec(:) + + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + integer :: i + + i = size(statevec,1) + + allocate(temp2d(grid%inputxchunk,grid%inputychunk)) + allocate(tiledstatevec(reservoir%chunk_size_prediction)) + + temp2d = reshape(statevec(grid%sst_start:grid%sst_end),(/grid%inputxchunk,grid%inputychunk/)) + + tiledstatevec = reshape(temp2d(grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend),(/grid%resxchunk*grid%resychunk/)) + + return + end subroutine + + subroutine tile_4d_and_logp_state_vec_res1d(reservoir,num_regions,statevec,worker,grid4d,grid2d) + !Takes the 1d res vector and converts it to the 4d and 2d grid target + !(res) grid + real(kind=dp), intent(in) :: statevec(:) + integer, intent(in) :: worker,num_regions + type(reservoir_type), intent(in) :: reservoir + + real(kind=dp), intent(inout) :: grid4d(:,:,:,:), grid2d(:,:) + + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk + integer :: length + + length = size(statevec,1) + + call getxyresextent(num_regions,worker,localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk) + + if(reservoir%logp_bool) then + grid4d = reshape(statevec(1:reservoir%local_predictvars*localres_xchunk*localres_ychunk*reservoir%local_heightlevels_res),(/reservoir%local_predictvars,localres_xchunk,localres_ychunk,reservoir%local_heightlevels_res/)) + grid2d = reshape(statevec(reservoir%local_predictvars*localres_xchunk*localres_ychunk*reservoir%local_heightlevels_res+1:length),(/localres_xchunk,localres_ychunk/)) + else + grid4d = reshape(statevec,(/reservoir%local_predictvars,localres_xchunk,localres_ychunk,reservoir%local_heightlevels_res/)) + grid2d = 0 + endif + + return + end subroutine + + subroutine tile_full_grid_with_local_state_vec_res1d(model_parameters,region_num,vert_level,statevec,wholegrid4d,wholegrid2d,wholegrid_precip) + !Takes the 1d res vector and converts it to the 4d and 2d grid target + !(res) grid + real(kind=dp), intent(in) :: statevec(:) + integer, intent(in) :: region_num, vert_level + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), intent(inout) :: wholegrid4d(:,:,:,:), wholegrid2d(:,:), wholegrid_precip(:,:) + + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk + integer :: localres_zstart,localres_zend,localres_zchunk + integer :: atmo3d_length + integer :: length + + length = size(statevec,1) + + call getxyresextent(model_parameters%number_of_regions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk) + + call get_z_res_extent(model_parameters%num_vert_levels,vert_level,localres_zstart,localres_zend,localres_zchunk) + + if(localres_zend == zgrid) then + wholegrid4d(:,localres_xstart:localres_xend,localres_ystart:localres_yend,localres_zstart:localres_zend) = reshape(statevec(1:model_parameters%full_predictvars*localres_xchunk*localres_ychunk*localres_zchunk),(/model_parameters%full_predictvars,localres_xchunk,localres_ychunk,localres_zchunk/)) + wholegrid2d(localres_xstart:localres_xend,localres_ystart:localres_yend) = reshape(statevec(model_parameters%full_predictvars*localres_xchunk*localres_ychunk*localres_zchunk+1:model_parameters%full_predictvars*localres_xchunk*localres_ychunk*localres_zchunk+localres_xchunk*localres_ychunk),(/localres_xchunk,localres_ychunk/)) + if(model_parameters%precip_bool) then + atmo3d_length = model_parameters%full_predictvars*localres_xchunk*localres_ychunk*localres_zchunk + wholegrid_precip(localres_xstart:localres_xend,localres_ystart:localres_yend) = reshape(statevec(atmo3d_length+localres_xchunk*localres_ychunk+1:length),(/localres_xchunk,localres_ychunk/)) + endif + else + wholegrid4d(:,localres_xstart:localres_xend,localres_ystart:localres_yend,localres_zstart:localres_zend) = reshape(statevec,(/model_parameters%full_predictvars,localres_xchunk,localres_ychunk,localres_zchunk/)) + wholegrid2d(localres_xstart:localres_xend,localres_ystart:localres_yend) = 0 + endif + + + + return + end subroutine + + subroutine tile_full_2d_grid_with_local_res(model_parameters,region_num,statevec,wholegrid2d) + !Takes the 1d res vector and converts it to the 4d and 2d grid target + !(res) grid + real(kind=dp), intent(in) :: statevec(:) + integer, intent(in) :: region_num + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), intent(inout) :: wholegrid2d(:,:) + + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk + integer :: localres_zstart,localres_zend,localres_zchunk + integer :: length + + length = size(statevec,1) + + call getxyresextent(model_parameters%number_of_regions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk) + + !print *, 'localres_xstart:localres_xend,localres_ystart:localres_yend',localres_xstart,localres_xend,localres_ystart,localres_yend + !print *, 'statevec(1:length)',statevec(1:length) + wholegrid2d(localres_xstart:localres_xend,localres_ystart:localres_yend) = reshape(statevec(1:length),(/localres_xchunk,localres_ychunk/)) + + return + end subroutine + + subroutine tile_4d_and_logp_state_vec_input1d(reservoir,grid,statevec,grid4d,grid2d) + !Tiler that takes a 1d local state vector and returns the 4d grid and + !1d input grid + real(kind=dp), intent(in) :: statevec(:) + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), allocatable, intent(inout) :: grid4d(:,:,:,:), grid2d(:,:) + + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + integer :: localinput_zstart,localinput_zend,localinput_zchunk + + integer :: length + + logical :: localpole,localperiodicboundary,top,bottom + + length = size(statevec,1) + + call getoverlapindices_vert(grid%num_vert_levels,grid%level_index,grid%vert_overlap,localinput_zstart,localinput_zend,localinput_zchunk,top,bottom) + call getoverlapindices(grid%number_of_regions,reservoir%assigned_region,grid%overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary) + + if(.not.allocated(grid4d)) then + allocate(grid4d(reservoir%local_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk)) + endif + + if(.not.allocated(grid2d)) then + allocate(grid2d(localinput_xchunk,localinput_ychunk)) + endif + + if(reservoir%logp_bool) then + grid4d = reshape(statevec(grid%atmo3d_start:grid%atmo3d_end),(/reservoir%local_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk/)) + grid2d = reshape(statevec(grid%logp_start:grid%logp_end),(/localinput_xchunk,localinput_ychunk/)) + else + grid4d = reshape(statevec,(/reservoir%local_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk/)) + grid2d = 0 + endif + return + end subroutine + + subroutine tile_4d_and_logp_state_vec_input1d_precip(reservoir,grid,statevec,grid4d,grid2d,grid_precip) + !Tiler that takes a 1d local state vector and returns the 4d grid and + !1d input grid + real(kind=dp), intent(in) :: statevec(:) + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), allocatable, intent(inout) :: grid4d(:,:,:,:), grid2d(:,:), grid_precip(:,:) + + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + integer :: localinput_zstart,localinput_zend,localinput_zchunk + + integer :: length + + logical :: localpole,localperiodicboundary,top,bottom + + length = size(statevec,1) + + call getoverlapindices_vert(grid%num_vert_levels,grid%level_index,grid%vert_overlap,localinput_zstart,localinput_zend,localinput_zchunk,top,bottom) + call getoverlapindices(grid%number_of_regions,reservoir%assigned_region,grid%overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary) + + if(.not.allocated(grid4d)) then + allocate(grid4d(reservoir%local_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk)) + endif + + if(.not.allocated(grid2d)) then + allocate(grid2d(localinput_xchunk,localinput_ychunk)) + endif + + if(.not.allocated(grid2d)) then + allocate(grid_precip(localinput_xchunk,localinput_ychunk)) + endif + + if(reservoir%logp_bool) then + grid4d = reshape(statevec(grid%atmo3d_start:grid%atmo3d_end),(/reservoir%local_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk/)) + grid2d = reshape(statevec(grid%logp_start:grid%logp_end),(/localinput_xchunk,localinput_ychunk/)) + else + grid4d = reshape(statevec,(/reservoir%local_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk/)) + grid2d = 0 + endif + + if(reservoir%precip_bool) then + grid_precip = reshape(statevec(grid%precip_start:grid%precip_end),(/localinput_xchunk,localinput_ychunk/)) + endif + return + end subroutine + + subroutine tile_4d_and_logp_state_vec_input1d_global(model_parameters,region_num,vert_level,statevec,grid4d,grid2d) + !Tiler that takes a 1d local state vector and returns the 4d grid and + !1d input grid + !For a specific reservoir it can by called by any processor just takes + !a little longer than using tile_4d_and_logp_state_vec_input1d + real(kind=dp), intent(in) :: statevec(:) + + integer, intent(in) :: region_num,vert_level + + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), allocatable, intent(inout) :: grid4d(:,:,:,:), grid2d(:,:) + + integer :: localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk + integer :: localinput_zstart,localinput_zend,localinput_zchunk + + integer :: length + + logical :: localpole,localperiodicboundary,top,bottom + + length = size(statevec,1) + + call getoverlapindices_vert(model_parameters%num_vert_levels,vert_level,model_parameters%vert_loc_overlap,localinput_zstart,localinput_zend,localinput_zchunk,top,bottom) + call getoverlapindices(model_parameters%number_of_regions,region_num,model_parameters%overlap,localinput_xstart,localinput_xend,localinput_ystart,localinput_yend,localinput_xchunk,localinput_ychunk,localpole,localperiodicboundary) + + if(.not.allocated(grid4d)) then + allocate(grid4d(model_parameters%full_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk)) + endif + + if(.not.allocated(grid2d)) then + allocate(grid2d(localinput_xchunk,localinput_ychunk)) + endif + + if(bottom) then + grid4d = reshape(statevec(1:model_parameters%full_predictvars*localinput_xchunk*localinput_ychunk*localinput_zchunk),(/model_parameters%full_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk/)) + grid2d = reshape(statevec(model_parameters%full_predictvars*localinput_xchunk*localinput_ychunk*localinput_zchunk+1:length),(/localinput_xchunk,localinput_ychunk/)) + else + grid4d = reshape(statevec,(/model_parameters%full_predictvars,localinput_xchunk,localinput_ychunk,localinput_zchunk/)) + grid2d = 0 + endif + return + end subroutine + + subroutine tile_4d_and_logp_res_state_vec_res1d(reservoir,numregions,region_num,statevec,grid4d,grid2d) + !Tiler that takes a 1d local (res) state vector and returns the 4d grid and + !2d res grid + real(kind=dp), intent(in) :: statevec(:) + + integer, intent(in) :: numregions,region_num + + type(reservoir_type), intent(in) :: reservoir + + real(kind=dp), allocatable, intent(inout) :: grid4d(:,:,:,:), grid2d(:,:) + + !local variables + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk + + integer :: length + + logical :: localpole,localperiodicboundary + + call getxyresextent(numregions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk) + length = size(statevec,1) + + if(.not.allocated(grid4d)) then + allocate(grid4d(reservoir%local_predictvars,localres_xchunk,localres_ychunk,reservoir%local_heightlevels_res)) + endif + + if(.not.allocated(grid2d)) then + allocate(grid2d(localres_xchunk,localres_ychunk)) + endif + + if(reservoir%logp_bool) then + grid4d = reshape(statevec(1:reservoir%local_predictvars*localres_xchunk*localres_ychunk*reservoir%local_heightlevels_res),(/reservoir%local_predictvars,localres_xchunk,localres_ychunk,reservoir%local_heightlevels_res/)) + grid2d = reshape(statevec(reservoir%local_predictvars*localres_xchunk*localres_ychunk*reservoir%local_heightlevels_res+1:length),(/localres_xchunk,localres_ychunk/)) + else + grid4d = reshape(statevec,(/reservoir%local_predictvars,localres_xchunk,localres_ychunk,reservoir%local_heightlevels_res/)) + grid2d = 0 + endif + return + end subroutine + + subroutine tile_4d_and_logp_full_grid_to_local_res_vec(model_parameters,region_num,vert_level,grid4d,grid2d,statevec) + !Tiler that takes the global 4d and 2d grid to local state res vec + real(kind=dp), intent(in) :: grid4d(:,:,:,:), grid2d(:,:) + integer, intent(in) :: vert_level, region_num + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), intent(out) :: statevec(:) + + !local variables + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk + integer :: localres_zstart,localres_zend,localres_zchunk + integer :: numvars + + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + + numvars = size(grid4d,1) + + call getxyresextent(model_parameters%number_of_regions,region_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localres_xchunk,localres_ychunk) + call get_z_res_extent(model_parameters%num_vert_levels,vert_level,localres_zstart,localres_zend,localres_zchunk) + + allocate(temp4d(numvars,localres_xchunk,localres_ychunk,localres_zchunk),temp2d(localres_xchunk,localres_ychunk)) + + temp4d = grid4d(:,localres_xstart:localres_xend,localres_ystart:localres_yend,localres_zstart:localres_zend) + temp2d = grid2d(localres_xstart:localres_xend,localres_ystart:localres_yend) + + statevec(1:numvars*localres_xchunk*localres_ychunk*localres_zchunk) = reshape(temp4d,(/numvars*localres_xchunk*localres_ychunk*localres_zchunk/)) + + if(localres_zend == zgrid) then + statevec(numvars*localres_xchunk*localres_ychunk*localres_zchunk+1:numvars*localres_xchunk*localres_ychunk*localres_zchunk+localres_xchunk*localres_ychunk) = reshape(temp2d,(/localres_xchunk*localres_ychunk/)) + endif + + end subroutine + + subroutine tile_4d_and_logp_state_vec_input_to_local_grids(model_parameters,statevec,region_num,vert_level,grid4d,grid2d) + !Tiler that takes a 1d local state vector and returns the 4d grid and + !2d grid but only for the data with out any overlap + real(kind=dp), intent(in) :: statevec(:) + integer, intent(in) :: region_num, vert_level + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), intent(inout) :: grid4d(:,:,:,:), grid2d(:,:) + + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + + integer :: local_tdata_xstart,local_tdata_xend,local_tdata_ystart,local_tdata_yend + integer :: local_tdata_zstart,local_tdata_zend + + call tile_4d_and_logp_state_vec_input1d_global(model_parameters,region_num,vert_level,statevec,temp4d,temp2d) + + call get_trainingdataindices(model_parameters%number_of_regions,region_num,model_parameters%overlap,local_tdata_xstart,local_tdata_xend,local_tdata_ystart,local_tdata_yend) + + call get_trainingdataindices_vert(model_parameters%num_vert_levels,vert_level,model_parameters%vert_loc_overlap,local_tdata_zstart,local_tdata_zend) + + grid4d = temp4d(:,local_tdata_xstart:local_tdata_xend,local_tdata_ystart:local_tdata_yend,local_tdata_zstart:local_tdata_zend) + grid2d = temp2d(local_tdata_xstart:local_tdata_xend,local_tdata_ystart:local_tdata_yend) + + return + end subroutine + + subroutine tile_4d_and_logp_to_local_state_input(model_parameters,region_num,vert_level,grid4d,grid2d,precip_grid,inputvec) + !Takes the 4d and 2d grids and makes an input vector + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), intent(in) :: grid4d(:,:,:,:), grid2d(:,:), precip_grid(:,:) + + integer, intent(in) :: region_num, vert_level + + real(kind=dp) , intent(inout) :: inputvec(:) + + real(kind=dp), allocatable :: localgrid4d(:,:,:,:) + real(kind=dp), allocatable :: localgrid2d(:,:) + real(kind=dp), allocatable :: localprecipgrid(:,:) + + integer :: numvars, x, y, z, veclength + integer :: localres_zstart,localres_zend,localreszchunk + + call get_z_res_extent(model_parameters%num_vert_levels,vert_level,localres_zstart,localres_zend,localreszchunk) + + call tileoverlapgrid(grid4d,model_parameters%number_of_regions,region_num,model_parameters%overlap,model_parameters%num_vert_levels,vert_level,model_parameters%vert_loc_overlap,localgrid4d) + + if(localres_zend == zgrid) then + call tileoverlapgrid(grid2d,model_parameters%number_of_regions,region_num,model_parameters%overlap,localgrid2d) + if(model_parameters%precip_bool) then + call tileoverlapgrid(precip_grid,model_parameters%number_of_regions,region_num,model_parameters%overlap,localprecipgrid) + endif + endif + + numvars = size(localgrid4d,1) + x = size(localgrid4d,2) + y = size(localgrid4d,3) + z = size(localgrid4d,4) + + veclength = size(inputvec) + + inputvec(1:numvars*x*y*z) = reshape(localgrid4d,(/numvars*x*y*z/)) + if(localres_zend == zgrid) then + inputvec(numvars*x*y*z+1:numvars*x*y*z+x*y) = reshape(localgrid2d,(/x*y/)) + if(model_parameters%precip_bool) then + inputvec(numvars*x*y*z+x*y+1:numvars*x*y*z+x*y*2) = reshape(localprecipgrid,(/x*y/)) + endif + endif + + return + end subroutine + + subroutine tile_4d_and_logp_to_local_state_input_slab(model_parameters,region_num,grid2d,inputvec) + !Takes the 4d and 2d grids and makes an input vector + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), intent(in) :: grid2d(:,:) + + integer, intent(in) :: region_num + + real(kind=dp) , intent(inout) :: inputvec(:) + + real(kind=dp), allocatable :: localgrid2d(:,:) + + integer :: numvars, x, y, z, veclength + integer :: localres_zstart,localres_zend,localreszchunk + + call tileoverlapgrid(grid2d,model_parameters%number_of_regions,region_num,model_parameters%overlap,localgrid2d) + + x = size(localgrid2d,1) + y = size(localgrid2d,2) + + veclength = size(inputvec) + + inputvec(1:x*y) = reshape(localgrid2d,(/x*y/)) + + return + end subroutine + + subroutine tile_4d_to_local_state_input(model_parameters,region_num,vert_level,grid4d,grid2d,inputvec) + !Takes the 4d and 2d grids and makes an input vector + type(model_parameters_type), intent(in) :: model_parameters + + real(kind=dp), intent(in) :: grid4d(:,:,:,:), grid2d(:,:) + + integer, intent(in) :: region_num, vert_level + + real(kind=dp) , intent(inout) :: inputvec(:) + + real(kind=dp), allocatable :: localgrid4d(:,:,:,:) + real(kind=dp), allocatable :: localgrid2d(:,:) + + integer :: numvars, x, y, z, veclength + + call tileoverlapgrid(grid4d,model_parameters%number_of_regions,region_num,model_parameters%overlap,model_parameters%num_vert_levels,vert_level,model_parameters%vert_loc_overlap,localgrid4d) + + + numvars = size(localgrid4d,1) + x = size(localgrid4d,2) + y = size(localgrid4d,3) + z = size(localgrid4d,4) + + veclength = size(inputvec) + + inputvec(1:numvars*x*y*z) = reshape(localgrid4d,(/numvars*x*y*z/)) + + return + end subroutine + + subroutine tile_4d_and_logp_to_local_state_res(worker,grid4d,grid2d,inputvec) + !Takes the 4d and 2d grids and makes a res vector + real(kind=dp), intent(in) :: grid4d(:,:,:,:), grid2d(:,:) + integer, intent(in) :: worker + + real(kind=dp) , intent(inout) :: inputvec(:) + + real(kind=dp), allocatable :: localgrid4d(:,:,:,:) + real(kind=dp), allocatable :: localgrid2d(:,:) + + integer :: numvars, x, y, z, veclength + + + numvars = size(localgrid4d,1) + x = size(localgrid4d,2) + y = size(localgrid4d,3) + z = size(localgrid4d,4) + + veclength = size(inputvec) + + inputvec(1:numvars*x*y*z) = reshape(localgrid4d,(/numvars*x*y*z/)) + inputvec(numvars*x*y*z+1:veclength) = reshape(localgrid2d,(/x*y/)) + + return + end subroutine + + + subroutine standardize_state_vec_input(reservoir,grid,state_vec) + !Subroutine to take state vector input and standardize the data + !returns input state_vec standardized upon completetion + + type(reservoir_type) :: reservoir + type(grid_type) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + !Local stuff + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:), temp_precip(:,:) + + integer :: num_of_standardized_vars, num_of_heights + integer :: i, j, l + + call tile_4d_and_logp_state_vec_input1d(reservoir,grid,state_vec,temp4d,temp2d) + + call input_grid_to_input_statevec_and_standardization(reservoir,grid,temp4d,temp2d,state_vec) + end subroutine + + subroutine input_grid_to_input_statevec_and_standardization(reservoir,grid,temp4d,temp2d,state_vec) + !Subroutine to take state vector input and standardize the data + !returns input state_vec standardized upon completetion + use mod_utilities, only : standardize_data_given_pars3d, standardize_data_given_pars2d + + type(reservoir_type) :: reservoir + type(grid_type) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + real(kind=dp), intent(inout) :: temp4d(:,:,:,:), temp2d(:,:) + + !Local stuff + integer :: num_of_standardized_vars, num_of_heights + integer :: i, j, l + + num_of_standardized_vars = size(temp4d,1) + num_of_heights = size(temp4d,4) + + l = 1 + do i=1, num_of_standardized_vars + do j=1, num_of_heights + call standardize_data_given_pars2d(temp4d(i,:,:,j),grid%mean(l),grid%std(l)) + l = l + 1 + enddo + enddo + + if(reservoir%logp_bool) then + call standardize_data_given_pars2d(temp2d,grid%mean(l),grid%std(l)) + endif + + if(reservoir%logp_bool) then + state_vec(grid%atmo3d_start:grid%atmo3d_end) = reshape(temp4d,(/reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk/)) + state_vec(grid%logp_start:grid%logp_end) = reshape(temp2d,(/grid%inputxchunk*grid%inputychunk/)) + else + state_vec = reshape(temp4d,(/reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk/)) + endif + end subroutine + + subroutine standardize_state_vec_res(reservoir,grid,state_vec) + !Subroutine to take state vector input and standardize the data + !returns input state_vec standardized upon completetion + use mod_utilities, only : standardize_data_given_pars3d, standardize_data_given_pars2d + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + !Local stuff + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + + integer :: num_of_standardized_vars, num_of_heights + integer :: i, j, l, data_height, length, height + + call tile_4d_and_logp_res_state_vec_res1d(reservoir,grid%number_of_regions,reservoir%assigned_region,state_vec,temp4d,temp2d) + + num_of_standardized_vars = size(temp4d,1) + num_of_heights = size(temp4d,4) + + length = reservoir%local_predictvars + height = reservoir%local_heightlevels_input + l = 1 + do i=1, length + data_height = 1 + do j=1, height + if((j >= grid%tdata_zstart).and.(j <= grid%tdata_zend)) then + call standardize_data_given_pars2d(temp4d(i,:,:,data_height),grid%mean(l),grid%std(l)) + data_height = data_height + 1 + endif + l = l + 1 + enddo + end do + + if(reservoir%logp_bool) then + call standardize_data_given_pars2d(temp2d,grid%mean(l),grid%std(l)) + endif + + if(reservoir%logp_bool) then + state_vec(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res) = reshape(temp4d,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + state_vec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res + grid%resxchunk*grid%resychunk) = reshape(temp2d,(/grid%resxchunk*grid%resychunk/)) + else + state_vec = reshape(temp4d,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + endif + end subroutine + + subroutine standardize_speedy_data(reservoir,grid,speedy_data) + use mod_utilities, only : standardize_data_given_pars3d, speedy_data_type + + type(reservoir_type), intent(inout) :: reservoir + type(speedy_data_type), intent(inout) :: speedy_data + type(grid_type), intent(inout) :: grid + + integer :: length, height, speedy_height + integer :: i, j, l + + length = reservoir%local_predictvars + height = reservoir%local_heightlevels_input + l = 1 + do i=1, length + speedy_height = 1 + do j=1, height + if((j >= grid%tdata_zstart).and.(j <= grid%tdata_zend)) then + call standardize_data_given_pars3d(speedy_data%speedyvariables(i,:,:,speedy_height,:),grid%mean(l),grid%std(l)) + speedy_height = speedy_height + 1 + endif + l = l + 1 + enddo + end do + + if(reservoir%logp_bool) then + call standardize_data_given_pars3d(speedy_data%speedy_logp,grid%mean(l),grid%std(l)) + endif + return + end subroutine + + subroutine standardize_grid_res_tile_statevec(reservoir,grid,temp4d,temp2d,state_vec) + !Subroutine to take state vector input and standardize the data + !returns input state_vec standardized upon completetion + use mod_utilities, only : standardize_data_given_pars3d, standardize_data_given_pars2d + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + real(kind=dp), intent(inout) :: temp4d(:,:,:,:), temp2d(:,:) + + !local vars + integer :: num_of_standardized_vars, num_of_heights + integer :: i, j, l + + num_of_standardized_vars = size(temp4d,1) + num_of_heights = size(temp4d,4) + + l = 1 + do i=1, num_of_standardized_vars + do j=1, num_of_heights + call standardize_data_given_pars2d(temp4d(i,:,:,j),grid%mean(l),grid%std(l)) + l = l + 1 + enddo + enddo + + call standardize_data_given_pars2d(temp2d,grid%mean(l),grid%std(l)) + + if(reservoir%logp_bool) then + state_vec(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res) = reshape(temp4d,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + state_vec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+1:reservoir%chunk_size_prediction) = reshape(temp2d,(/grid%resxchunk*grid%resychunk/)) + else + state_vec = reshape(temp4d,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + endif + end subroutine + + subroutine unstandardize_state_vec_res(reservoir,grid,state_vec) + !Subroutine to take state vector and unstandardize the data + !returns state_vec unstandardized upon completetion + use mod_utilities, only : unstandardize_data, unstandardize_data_2d, unstandardize_data_1d + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + !Local stuff + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + + integer :: num_of_unstandardized_vars, i, j, data_height, l, length, height + + allocate(temp4d(reservoir%local_predictvars,grid%resxchunk,grid%resychunk,reservoir%local_heightlevels_res)) + allocate(temp2d(grid%resxchunk,grid%resychunk)) + + call tile_4d_and_logp_state_vec_res1d(reservoir,grid%number_of_regions,state_vec,reservoir%assigned_region,temp4d,temp2d) + + length = reservoir%local_predictvars + height = reservoir%local_heightlevels_input + l = 1 + do i=1, length + data_height = 1 + do j=1, height + if((j >= grid%tdata_zstart).and.(j <= grid%tdata_zend)) then + call unstandardize_data_2d(temp4d(i,:,:,data_height),grid%mean(l),grid%std(l)) + data_height = data_height + 1 + endif + l = l + 1 + enddo + end do + + if(reservoir%logp_bool) then + call unstandardize_data_2d(temp2d,grid%mean(grid%logp_mean_std_idx),grid%std(grid%logp_mean_std_idx)) + endif + + if(reservoir%logp_bool) then + state_vec(1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res) = reshape(temp4d,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + state_vec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk) = reshape(temp2d,(/grid%resxchunk*grid%resychunk/)) + else + state_vec = reshape(temp4d,(/reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res/)) + endif + + if(reservoir%precip_bool) then + call unstandardize_data_1d(state_vec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk+1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk*2),grid%mean(grid%precip_mean_std_idx),grid%std(grid%precip_mean_std_idx)) + + !state_vec(reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk+1:reservoir%local_predictvars*grid%resxchunk*grid%resychunk*reservoir%local_heightlevels_res+grid%resxchunk*grid%resychunk*2) = reshape(temp2d,(/grid%resxchunk*grid%resychunk/)) + endif + + end subroutine + + + subroutine unstandardize_state_vec_res_and_tile_grids(reservoir,grid,state_vec,grid4d,grid2d) + !Subroutine to take state vector and unstandardize the data + !returns state_vec unstandardized upon completetion + use mod_utilities, only : unstandardize_data + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + real(kind=dp), intent(out), allocatable :: grid4d(:,:,:,:), grid2d(:,:) + + allocate(grid4d(reservoir%local_predictvars,grid%resxchunk,grid%resychunk,reservoir%local_heightlevels_res)) + allocate(grid2d(grid%resxchunk,grid%resychunk)) + + call tile_4d_and_logp_state_vec_res1d(reservoir,grid%number_of_regions,state_vec,reservoir%assigned_region,grid4d,grid2d) + + call unstandardize_data(reservoir,grid4d,grid2d,grid%mean,grid%std) + + end subroutine + + subroutine unstandardize_state_vec_input(reservoir,grid,state_vec) + !Subroutine to take state vector and standardize the data + !returns state_vec standardized upon completetion + use mod_utilities, only : unstandardize_data + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + !Local stuff + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + + integer :: num_of_unstandardized_vars, i + + allocate(temp4d(reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,grid%inputzchunk)) + allocate(temp2d(grid%inputxchunk,grid%inputychunk)) + + call tile_4d_and_logp_state_vec_input1d(reservoir,grid,state_vec,temp4d,temp2d) + + if(reservoir%logp_bool) then + call unstandardize_data(reservoir,temp4d,temp2d,grid%mean,grid%std) + else + call unstandardize_data(reservoir,temp4d,grid%mean,grid%std) + endif + + if(reservoir%logp_bool) then + state_vec(grid%atmo3d_start:grid%atmo3d_end) = reshape(temp4d,(/reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk/)) + state_vec(grid%logp_start:grid%logp_end) = reshape(temp2d,(/grid%inputxchunk*grid%inputychunk/)) + else + state_vec = reshape(temp4d,(/reservoir%local_predictvars*grid%inputxchunk*grid%inputychunk*grid%inputzchunk/)) + endif + end subroutine + + subroutine unstandardize_state_vec_input_to_grid(reservoir,grid,state_vec,grid4d,grid2d) + !Subroutine to take state vector and standardize the data + !returns state_vec standardized upon completetion + use mod_utilities, only : unstandardize_data + + type(reservoir_type), intent(in) :: reservoir + type(grid_type), intent(in) :: grid + + real(kind=dp), intent(inout) :: state_vec(:) + + real(kind=dp), intent(out), allocatable :: grid4d(:,:,:,:), grid2d(:,:) + + !Local stuff + real(kind=dp), allocatable :: temp4d(:,:,:,:), temp2d(:,:) + + integer :: num_of_unstandardized_vars, i + + allocate(temp4d(reservoir%local_predictvars,grid%inputxchunk,grid%inputychunk,grid%inputzchunk)) + allocate(temp2d(grid%inputxchunk,grid%inputychunk)) + + call tile_4d_and_logp_state_vec_input1d(reservoir,grid,state_vec,temp4d,temp2d) + + call unstandardize_data(reservoir,temp4d,temp2d,grid%mean,grid%std) + + allocate(grid4d(reservoir%local_predictvars,grid%resxchunk,grid%resychunk,reservoir%local_heightlevels_res)) + allocate(grid2d(grid%resxchunk,grid%resychunk)) + + grid4d = temp4d(:,grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend,grid%tdata_zstart:grid%tdata_zend) + grid2d = temp2d(grid%tdata_xstart:grid%tdata_xend,grid%tdata_ystart:grid%tdata_yend) + end subroutine + + subroutine set_region(grid) + !Determines which region this worker is (tropics, extratropics, or + !polar region) + !This routine changes the local copy of grid so this can only be called + !by the processor with is grid object and not from any other processor + + !We are calling tropics (25S to 25N) + !Extratropics (25N to 60N and 25S to 60S) + !Polar region (60N to 90N and 60S to 90S) + + type(grid_type), intent(inout) :: grid + + real(kind=dp), parameter :: pole_lat_N = 60, pole_lat_S = -60 + real(kind=dp), parameter :: extra_lat_N = 30, extra_lat_S = -30 + + real(kind=dp) :: starting_lat, ending_lat + + !Lets determine whats the smallest and largest latitude that is inputted + !into the reservoir + starting_lat = speedylat(grid%res_ystart) + ending_lat = speedylat(grid%res_yend) + + if((starting_lat <= pole_lat_S).or.(ending_lat >= pole_lat_N)) then + grid%region_char = 'polar' + elseif((starting_lat <= extra_lat_S).and.(starting_lat > pole_lat_S)) then + grid%region_char = 'extratropic' + elseif((starting_lat >= extra_lat_N).and.(starting_lat < pole_lat_N)) then + grid%region_char = 'extratropic' + else + grid%region_char = 'tropic' + endif + + end subroutine + + subroutine set_reservoir_by_region(reservoir,grid) + !Set reservoir parameters such as noise, spectral radius, etc by + !geographic regions : tropics, extratropics, and polar regions + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + + call set_region(grid) + + if(grid%region_char == 'tropic') then + !res%specific_humidity_log_bool = .True. + reservoir%noisemag = 0.20!0 + elseif(grid%region_char == 'extratropic') then + !res%specific_humidity_log_bool = .True. + reservoir%noisemag = 0.20 + elseif(grid%region_char == 'polar') then + !res%specific_humidity_log_bool = .False. + reservoir%noisemag = 0.20 + else + print *, 'something is wrong worker',reservoir%assigned_region,'doesnt have a region' + endif + + reservoir%radius = get_radius_by_lat(speedylat(grid%res_ystart),speedylat(grid%res_yend)) + end subroutine + + function get_radius_by_lat(startlat,endlat) result(radius) + !First attempt at continuously increasing spectral radius from tropics + !to extratropics. We keep the radius for areas above the highest_lat as + !the poles and extra tropics seem to like spectral radius around 0.9 and + !tropics like 0.3ish + real(kind=dp), intent(in) :: startlat, endlat + real(kind=dp) :: radius + + !descriptors to define how the function looks + !Currently looks like this: + ! r | ___ ____ max_radius + ! a | \ / + ! d | \ / + ! i | \/ + ! u | min_radius + ! s ---------------------- + ! -90 0 90 + ! lat + real(kind=dp), parameter :: highest_lat = 45.0_dp !Latitude where you want + !the spectral radius to be constant for any reservoir above this latitude + real(kind=dp), parameter :: max_radius = 0.7_dp!0.7_dp !Max spectral radius + real(kind=dp), parameter :: min_radius = 0.3_dp !Min spectral radius + + !Local stuff + real(kind=dp) :: smallest_lat + real(kind=dp) :: largest_lat + + smallest_lat = abs(min(startlat,endlat)) + largest_lat = abs(max(startlat,endlat)) + + if(smallest_lat >= highest_lat) then + radius = max_radius + else + radius = (max_radius - min_radius)/highest_lat + min_radius + endif + + return + end function get_radius_by_lat + +end module resdomain diff --git a/src/spe_matinv.f90 b/src/spe_matinv.f90 new file mode 100755 index 0000000..89a6fa5 --- /dev/null +++ b/src/spe_matinv.f90 @@ -0,0 +1,129 @@ +subroutine ludcmp(a,n,np,indx,d) + implicit none + + real, intent(inout) :: a(np,np), d + integer, intent(inout) :: indx(n) + integer, intent(in) :: n, np + integer, parameter :: nmax = 100, tiny = 1.0e-20 + integer :: i, j, k, imax + real :: vv(nmax), aamax, dum, sum + + d = 1.0 + + do i=1,n + aamax=0. + do j=1,n + if(abs(a(i,j)).gt.aamax) aamax=abs(a(i,j)) + end do + if(aamax.eq.0.) stop 'singular' + vv(i)=1./aamax + end do + + do j=1,n + if(j.gt.1) then + do i=1,j-1 + sum=a(i,j) + if(i.gt.1) then + do k=1,i-1 + sum=sum-a(i,k)*a(k,j) + end do + a(i,j)=sum + end if + end do + end if + + aamax=0. + do i=j,n + sum=a(i,j) + if(j.gt.1) then + do k=1,j-1 + sum=sum-a(i,k)*a(k,j) + end do + a(i,j)=sum + end if + dum=vv(i)*abs(sum) + if(dum.ge.aamax) then + imax=i + aamax=dum + end if + end do + + if(j.ne.imax) then + do k=1,n + dum=a(imax,k) + a(imax,k)=a(j,k) + a(j,k)=dum + end do + d=-d + vv(imax)=vv(j) + end if + + indx(j)=imax + if(j.ne.n) then + if(a(j,j).eq.0) a(j,j)=tiny + dum=1./a(j,j) + do i=j+1,n + a(i,j)=a(i,j)*dum + end do + end if + end do + + if(a(n,n).eq.0.) a(n,n)=tiny +end + +subroutine lubksb(a,n,np,indx,b) + implicit none + + real, intent(inout) :: a(np,np), b(n) + integer, intent(in) :: n, np, indx(n) + integer :: ii, i, ll, j + real :: sum + + ii=0 + + do i=1,n + ll=indx(i) + sum=b(ll) + b(ll)=b(i) + if(ii.ne.0) then + do j=ii,i-1 + sum=sum-a(i,j)*b(j) + end do + else if(sum.ne.0) then + ii=i + end if + b(i)=sum + end do + + do i=n,1,-1 + sum=b(i) + if(i.lt.n) then + do j=i+1,n + sum=sum-a(i,j)*b(j) + end do + end if + b(i)=sum/a(i,i) + end do +end + +subroutine inv(a,y,indx,n) + implicit none + + real, intent(inout) :: a(n,n), y(n,n) + integer, intent(inout) :: indx(n) + integer, intent(in) :: n + integer :: i + real :: d + + y = 0.0 + + do i=1,n + y(i,i)=1. + end do + + call ludcmp(a,n,n,indx,d) + + do i=1,n + call lubksb(a,n,n,indx,y(1,i)) + end do +end diff --git a/src/spe_spectral.f90 b/src/spe_spectral.f90 new file mode 100755 index 0000000..4de1e0b --- /dev/null +++ b/src/spe_spectral.f90 @@ -0,0 +1,551 @@ +!****************************************************************** +subroutine gaussl(x,w,m) + ! a slightly modified version of a program in Numerical Recipes + ! (Cambridge Univ. Press, 1989) + ! input: + ! m = number of gaussian latitudes between pole and equator + ! output: + ! x(m) = sin(gaussian latitude) + ! w(m) = weights in gaussian quadrature (sum should equal 1.0) + + implicit none + + real, intent(inout) :: x(m),w(m) + integer, intent(in) :: m + double precision :: z,z1,p1,p2,p3,pp + double precision, parameter :: eps=3.d-14 + integer :: n, j, i + + n = 2*m + + z1 = 2.0 + + do i=1,m + z=cos(3.141592654d0*(i-.25d0)/(n+.5d0)) + do while (abs(z-z1).gt.eps) + p1=1.d0 + p2=0.d0 + + do j=1,n + p3=p2 + p2=p1 + p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j + end do + + pp=n*(z*p1-p2)/(z*z-1.d0) + z1=z + z=z1-p1/pp + end do + + x(i)=z + w(i)=2.d0/((1.d0-z*z)*pp*pp) + end do +end +!**************************************************************** +subroutine parmtr(a) + use mod_atparam + use mod_spectral + + implicit none + + !include "param1spec.h" + + real, intent(in) :: a + real :: am1, am2, cosqr, el1, ell2, emm2 + + integer :: j, jj, m, m1, m2, n + + ! initializes Legendre transforms and constants used for other + ! subroutines that manipulate spherical harmonics + ! + ! input: A = radius of the sphere + ! first compute Gaussian latitudes and weights at the IY points from + ! pole to equator + ! SIA(IY) is sin of latitude, WT(IY) are Gaussian weights for quadratures, + ! saved in mod_spectral + call gaussl(sia,wt,iy) + am1 = 1./a + am2= 1./(a*a) + + ! COA(IY) = cos(lat); WGHT needed for transforms, + ! saved in mod_spectral + do j=1,iy + cosqr = 1.0-sia(j)**2 + coa(j)=sqrt(cosqr) + wght(j)=wt(j)/(a*cosqr) + end do + + ! expand cosine and its reciprocal to cover both hemispheres, + ! saved in mod_spectral + do j=1,iy + jj=il+1-j + cosg(j)=coa(j) + cosg(jj)=coa(j) + cosgr(j)=1./coa(j) + cosgr(jj)=1./coa(j) + cosgr2(j)=1./(coa(j)*coa(j)) + cosgr2(jj)=1./(coa(j)*coa(j)) + end do + + ! MM = zonal wavenumber = m + ! ISC=3 implies that only wavenumber 0,3,6,9,etc are included in model + ! LL = total wavenumber of spherical harmonic = l + ! L2 = l*(l+1) + ! EL2 = l*(l+1)/(a**2) + ! EL4 = EL2*EL2 ; for biharmonic diffusion + ! ELM2 = 1./EL2 + ! TRFILT used to filter out "non-triangular" part of rhomboidal truncation + ! saved in mod_spectral + do n=1,nx + nsh2(n)=0 + do m=1,mx + mm(m)=isc*(m-1) + ll(m,n)=mm(m)+n-1 + l2(m,n)=ll(m,n)*(ll(m,n)+1) + el2(m,n)=float(l2(m,n))*am2 + el4(m,n)=el2(m,n)*el2(m,n) + if (ll(m,n).le.ntrun1.or.ix.ne.4*iy) nsh2(n)=nsh2(n)+2 + if (ll(m,n).le.ntrun) then + trfilt(m,n)=1. + else + trfilt(m,n)=0. + end if + end do + end do + + elm2(1,1)=0. + do m=2,mx + do n=1,nx + elm2(m,n)=1./el2(m,n) + end do + end do + + do n=2,nx + elm2(1,n)=1./el2(1,n) + end do + + ! quantities needed to generate and differentiate Legendre polynomials + ! all m values up to MXP = ISC*MTRUN+1 are needed by recursion relation + ! saved in mod_spectral + do m=1,mxp + do n=1,nxp + emm(m)=float(m-1) + ell(m,n)=float(n+m-2) + emm2=emm(m)**2 + ell2=ell(m,n)**2 + if(n.eq.nxp) then + epsi(m,n)=0.0 + else if(n.eq.1.and.m.eq.1) then + epsi(m,n)=0.0 + else + epsi(m,n)=sqrt((ell2-emm2)/(4.*ell2-1.)) + end if + repsi(m,n)=0.0 + if(epsi(m,n).gt.0.) repsi(m,n)=1./epsi(m,n) + end do + end do + + sqrhlf=sqrt(.5) + do m=2,mxp + consq(m) = sqrt(.5*(2.*emm(m)+1.)/emm(m)) + end do + + ! quantities required by subroutines GRAD, UVSPEC, and VDS + ! saved in mod_spectral + do m=1,mx + do n=1,nx + m1=mm(m) + m2=m1+1 + el1=float(ll(m,n)) + if(n.eq.1) then + gradx(m)=float(m1)/a + uvdx(m,1)=-a/float(m1+1) + uvdym(m,1)=0.0 + vddym(m,1)=0.0 + else + uvdx(m,n)=-a*float(m1)/(el1*(el1+1)) + gradym(m,n)=(el1-1.)*epsi(m2,n)/a + uvdym(m,n)=-a*epsi(m2,n)/el1 + vddym(m,n)=(el1+1)*epsi(m2,n)/a + end if + gradyp(m,n)=(el1+2.)*epsi(m2,n+1)/a + uvdyp(m,n)=-a*epsi(m2,n+1)/(el1+1.) + vddyp(m,n)=el1*epsi(m2,n+1)/a + end do + end do + + ! generate associated Legendre polynomial + ! LGNDRE computes the polynomials at a particular latitiude, POLY(MX,NX), and stores + ! them in mod_spectral + ! polynomials and 'clones' stored in mod_spectral + do j=1,iy + call lgndre(j) + do n=1,nx + do m=1,mx + m1=2*m-1 + m2=2*m + cpol(m1,n,j)=poly(m,n) + cpol(m2,n,j)=poly(m,n) + end do + end do + end do +end +!**************************************************************** +subroutine lgndre(j) + ! follows Leith Holloways code + + use mod_atparam + use mod_spectral, only: sia, coa, sqrhlf, consq, repsi, epsi, poly + + implicit none + + !include "param1spec.h" + integer, intent(in) :: j + real, parameter :: small = 1.e-30 + + integer :: m, n, mm2 + real :: alp(mxp,nx), x, y + y = coa(j) + x = sia(j) + + ! start recursion with N=1 (M=L) diagonal + alp(1,1) = sqrhlf + do m=2,mxp + alp(m,1) = consq(m)*y*alp(m-1,1) + end do + + ! continue with other elements + do m=1,mxp + alp(m,2)=(x*alp(m,1))*repsi(m,2) + end do + + do n=3,nx + do m=1,mxp + alp(m,n)=(x*alp(m,n-1)-epsi(m,n-1)*alp(m,n-2))*repsi(m,n) + end do + end do + + ! zero polynomials with absolute values smaller than 10**(-30) + do n=1,nx + do m=1,mxp + if(abs(alp(m,n)) .le. small) alp(m,n)=0.0 + end do + end do + + ! pick off the required polynomials + do n=1,nx + do m=1,mx + mm2=isc*(m-1)+1 + poly(m,n)=alp(mm2,n) + end do + end do +end +!*************************************************************** +subroutine lap(strm,vorm) + use mod_atparam + use mod_spectral, only: el2 + + implicit none + + + complex, intent(in) :: strm(mx,nx) + complex, intent(inout) :: vorm(mx,nx) + vorm = -strm * el2 +end +!******************************************************************* +subroutine invlap(vorm,strm) + use mod_atparam + use mod_spectral, only: elm2 + + ! include "param1spec.h" + + complex, intent(in) :: vorm(mx,nx) + complex, intent(inout) :: strm(mx,nx) + strm = -vorm * elm2 + + !do m=1,mxnx + ! strm(m,1)=-vorm(m,1)*elm2(m,1) + !end do +end +!********************************************************************* +subroutine grad(psi,psdx,psdy) + use mod_atparam + use mod_spectral, only: gradx, gradyp, gradym + + implicit none + + !include "param1spec.h" + + real, dimension(2,mx,nx), intent(inout) :: psi + real, dimension(2,mx,nx), intent(inout) :: psdx, psdy + + integer :: k, n, m + + do n=1,nx + do m=1,mx + psdx(2,m,n)=gradx(m)*psi(1,m,n) + psdx(1,m,n)=-gradx(m)*psi(2,m,n) + end do + end do + + do k=1,2 + do m=1,mx + psdy(k,m,1)=gradyp(m,1)*psi(k,m,2) + psdy(k,m,nx)=-gradym(m,nx)*psi(k,m,ntrun1) + end do + end do + + do k=1,2 + do n=2,ntrun1 + do m=1,mx + psdy(k,m,n)=-gradym(m,n)*psi(k,m,n-1)+gradyp(m,n)*psi(k,m,n+1) + end do + end do + end do +end +!****************************************************************** +subroutine vds(ucosm,vcosm,vorm,divm) + use mod_atparam + use mod_spectral, only: gradx, vddyp, vddym + + implicit none + + !include "param1spec.h" + + real, dimension(2,mx,nx) :: ucosm, vcosm + real, dimension(2,mx,nx), intent(inout) :: vorm, divm + real, dimension(2,mx,nx) :: zc, zp + + integer :: n, m, k + + do n=1,nx + do m=1,mx + zp(2,m,n)=gradx(m)*ucosm(1,m,n) + zp(1,m,n)=-gradx(m)*ucosm(2,m,n) + zc(2,m,n)=gradx(m)*vcosm(1,m,n) + zc(1,m,n)=-gradx(m)*vcosm(2,m,n) + end do + end do + + do k=1,2 + do m=1,mx + vorm(k,m,1)=zc(k,m,1)-vddyp(m,1)*ucosm(k,m,2) + vorm(k,m,nx)=vddym(m,nx)*ucosm(k,m,ntrun1) + divm(k,m,1)=zp(k,m,1)+vddyp(m,1)*vcosm(k,m,2) + divm(k,m,nx)=-vddym(m,nx)*vcosm(k,m,ntrun1) + end do + end do + + do k=1,2 + do n=2,ntrun1 + do m=1,mx + vorm(k,m,n)=vddym(m,n)*ucosm(k,m,n-1)-vddyp(m,n)*& + & ucosm(k,m,n+1)+zc(k,m,n) + divm(k,m,n)=-vddym(m,n)*vcosm(k,m,n-1)+vddyp(m,n)*& + & vcosm(k,m,n+1)+zp(k,m,n) + end do + end do + end do +end +!****************************************************************** +subroutine uvspec(vorm,divm,ucosm,vcosm) + use mod_atparam + use mod_spectral, only: uvdx, uvdyp, uvdym + + !include "param1spec.h" + + real, dimension(2,mx,nx), intent(in) :: vorm,divm + real, dimension(2,mx,nx), intent(inout) :: ucosm,vcosm + real, dimension(2,mx,nx) :: zc,zp + + integer :: k, n, m + + zp(2,:,:) = uvdx*vorm(1,:,:) + zp(1,:,:) = -uvdx*vorm(2,:,:) + zc(2,:,:) = uvdx*divm(1,:,:) + zc(1,:,:) = -uvdx*divm(2,:,:) + + do k=1,2 + do m=1,mx + ucosm(k,m,1)=zc(k,m,1)-uvdyp(m,1)*vorm(k,m,2) + ucosm(k,m,nx)=uvdym(m,nx)*vorm(k,m,ntrun1) + vcosm(k,m,1)=zp(k,m,1)+uvdyp(m,1)*divm(k,m,2) + vcosm(k,m,nx)=-uvdym(m,nx)*divm(k,m,ntrun1) + end do + end do + + do k=1,2 + do n=2,ntrun1 + do m=1,mx + vcosm(k,m,n)=-uvdym(m,n)*divm(k,m,n-1)+uvdyp(m,n)*& + & divm(k,m,n+1)+zp(k,m,n) + ucosm(k,m,n)= uvdym(m,n)*vorm(k,m,n-1)-uvdyp(m,n)*& + & vorm(k,m,n+1)+zc(k,m,n) + end do + end do + end do +end +!******************************************************************* +subroutine grid(vorm,vorg,kcos) + use mod_atparam + + implicit none + + !include "param1spec.h" + + real, intent(inout) :: vorg(ix,il), vorm(mx2,nx) + integer, intent(in) :: kcos + real :: varm(mx2,il) + call gridy(vorm,varm) + call gridx(varm,vorg,kcos) +end +!********************************************************************* +subroutine spec(vorg,vorm) + use mod_atparam + + implicit none + + !include "param1spec.h" + + real, intent(inout) :: vorg(ix,il), vorm(mx2,nx) + real :: varm(mx2,il) + call specx(vorg,varm) + call specy(varm,vorm) +end +!********************************************************************* +subroutine vdspec(ug,vg,vorm,divm,kcos) + use mod_atparam + use mod_spectral, only: cosgr, cosgr2 + + implicit none + + !include "param1spec.h" + + real, intent(in) :: ug(ix,il), vg(ix,il) + real, intent(inout) :: vorm(mx2,nx), divm(mx2,nx) + integer, intent(in) :: kcos + integer :: i, j + real :: ug1(ix,il), vg1(ix,il), um(mx2,il), vm(mx2,il) + real :: dumc1(mx2,nx), dumc2(mx2,nx) + + if (kcos.eq.2) then + do j=1,il + do i=1,ix + ug1(i,j)=ug(i,j)*cosgr(j) + vg1(i,j)=vg(i,j)*cosgr(j) + end do + end do + else + do j=1,il + do i=1,ix + ug1(i,j)=ug(i,j)*cosgr2(j) + vg1(i,j)=vg(i,j)*cosgr2(j) + end do + end do + end if + + call specx(ug1,um) + call specx(vg1,vm) + call specy(um,dumc1) + call specy(vm,dumc2) + call vds(dumc1,dumc2,vorm,divm) +end +!********************************************************************* +subroutine gridy(v,varm) + use mod_atparam + use mod_spectral, only: cpol, nsh2 + + implicit none + + !include "param1spec.h" + + real, intent(in) :: v(mx2,nx) + real, intent(inout) :: varm(mx2,il) + real :: vm1(mx2),vm2(mx2) + + integer :: j, j1, m, n + + do j=1,iy + j1=il+1-j + + do m=1,mx2 + vm1(m)=0. + vm2(m)=0. + end do + + do n=1,nx,2 + !do m=1,mx2 + do m=1,nsh2(n) + vm1(m)=vm1(m)+v(m,n)*cpol(m,n,j) + end do + end do + + do n=2,nx,2 + !do m=1,mx2 + do m=1,nsh2(n) + vm2(m)=vm2(m)+v(m,n)*cpol(m,n,j) + end do + end do + + do m=1,mx2 + varm(m,j1)=vm1(m)+vm2(m) + varm(m,j) =vm1(m)-vm2(m) + end do + end do +end +!****************************************************************** +subroutine specy(varm,vorm) + use mod_atparam + use mod_spectral, only: wt, cpol, nsh2 + + implicit none + + !include "param1spec.h" + + real, intent(in) :: varm(mx2,il) + real, intent(inout) :: vorm(mx2,nx) + real :: svarm(mx2,iy), dvarm(mx2,iy) + + integer :: j, j1, m, n + + vorm = 0.0 + + do j=1,iy + j1=il+1-j + do m=1,mx2 + svarm(m,j)=(varm(m,j1)+varm(m,j))*wt(j) + dvarm(m,j)=(varm(m,j1)-varm(m,j))*wt(j) + end do + end do + + do j=1,iy + j1=il+1-j + + do n=1,ntrun1,2 + !do m=1,mx2 + do m=1,nsh2(n) + vorm(m,n) = vorm(m,n)+cpol(m,n,j)*svarm(m,j) + end do + end do + + do n=2,ntrun1,2 + !do m=1,mx2 + do m=1,nsh2(n) + vorm(m,n) = vorm(m,n)+cpol(m,n,j)*dvarm(m,j) + end do + end do + end do +end +!****************************************************************** +subroutine trunct(vor) + use mod_atparam + use mod_spectral, only: trfilt + + implicit none + + !include "param1spec.h" + + complex, intent(inout) :: vor(mx,nx) + + vor = vor * trfilt +end diff --git a/src/spe_subfft_fftpack.f90 b/src/spe_subfft_fftpack.f90 new file mode 100755 index 0000000..eb790c3 --- /dev/null +++ b/src/spe_subfft_fftpack.f90 @@ -0,0 +1,89 @@ +subroutine inifft + ! Initialize FFTs + + use mod_atparam, only: ix + use mod_fft + + implicit none + + call rffti(ix,wsave) + !call dffti (ix,wsave) +end + +!********************************************************************* + +subroutine gridx(varm,vorg,kcos) + ! From Fourier coefficients to grid-point data + + use mod_atparam + use mod_spectral, only: cosgr + use mod_fft + + implicit none + + real, intent(in) :: varm(mx2,il) + real, intent(inout) :: vorg(ix,il) + integer, intent(in) :: kcos + integer :: j, m + real :: fvar(ix) + + do j = 1,il + fvar(1) = varm(1,j) + + do m=3,mx2 + fvar(m-1)=varm(m,j) + end do + do m=mx2,ix + fvar(m)=0.0 + end do + + ! Inverse FFT + call rfftb(ix,fvar,wsave) + !call dfftb(ix,fvar,wsave) + + ! Copy output into grid-point field, scaling by cos(lat) if needed + if (kcos.eq.1) then + vorg(:,j) = fvar + else + vorg(:,j) = fvar * cosgr(j) + end if + end do +end + +!****************************************************************** + +subroutine specx(vorg,varm) + ! From grid-point data to Fourier coefficients + + use mod_atparam + use mod_fft + + implicit none + + real, intent(in) :: vorg(ix,il) + real, intent(inout) :: varm(mx2,il) + integer :: j, m + real :: fvar(ix), scale + + ! Copy grid-point data into working array + do j=1,il + fvar = vorg(:,j) + + ! Direct FFT + CALL RFFTF (IX,FVAR,WSAVE) + !CALL DFFTF (IX,FVAR,WSAVE) + + ! Copy output into spectral field, dividing by no. of long. + scale=1./float(ix) + + ! Mean value (a(0)) + varm(1,j)=fvar(1)*scale + varm(2,j)=0.0 + + do m=3,mx2 + varm(m,j)=fvar(m-1)*scale + end do + end do +end + +include "spe_subfft_fftpack2.f90" diff --git a/src/spe_subfft_fftpack2.f90 b/src/spe_subfft_fftpack2.f90 new file mode 100755 index 0000000..a861ffb --- /dev/null +++ b/src/spe_subfft_fftpack2.f90 @@ -0,0 +1,1241 @@ +subroutine rffti(n, wsave) + implicit none + + integer, intent(in) :: n + real, intent(inout) :: wsave(*) + + !***first executable statement rffti + if (n .eq. 1) return + call rffti1(n,wsave(n+1),wsave(2*n+1)) + return +end + +subroutine rfftb(n, r, wsave) + implicit none + + integer, intent(in) :: n + real, intent(inout) :: r(*), wsave(*) + + !***first executable statement rfftb + if (n .eq. 1) return + call rfftb1 (n,r,wsave,wsave(n+1),wsave(2*n+1)) +end + +subroutine rfftf(n, r, wsave) + implicit none + + integer, intent(in) :: n + real, intent(inout) :: r(*), wsave(*) + + !***first executable statement rfftf + if (n .eq. 1) return + call rfftf1 (n,r,wsave,wsave(n+1),wsave(2*n+1)) + return +end + +subroutine rffti1(n, wa, ifac) + implicit none + + integer, intent(in) :: n + real, intent(inout) :: wa(*) + integer, intent(inout) :: ifac(*) + integer, save :: ntryh(4) = (/ 4, 2, 3, 5 /) + integer :: nl, nf, i, j, ib, ido, ii, ip, ipm, is, k1, l1, l2, ld, nfm1,& + & nq, nr, ntry + real :: arg, argh, argld, fi, tpi + + !***first executable statement rffti1 + nl = n + nf = 0 + j = 0 + 101 j = j+1 + if (j-4) 102,102,103 + 102 ntry = ntryh(j) + go to 104 + 103 ntry = ntry+2 + 104 nq = nl/ntry + nr = nl-ntry*nq + if (nr) 101,105,101 + 105 nf = nf+1 + ifac(nf+2) = ntry + nl = nq + if (ntry .ne. 2) go to 107 + if (nf .eq. 1) go to 107 + do 106 i=2,nf + ib = nf-i+2 + ifac(ib+2) = ifac(ib+1) + 106 continue + ifac(3) = 2 + 107 if (nl .ne. 1) go to 104 + ifac(1) = n + ifac(2) = nf + tpi = 8.*atan(1.) + argh = tpi/n + is = 0 + nfm1 = nf-1 + l1 = 1 + if (nfm1 .eq. 0) return + do 110 k1=1,nfm1 + ip = ifac(k1+2) + ld = 0 + l2 = l1*ip + ido = n/l2 + ipm = ip-1 + do 109 j=1,ipm + ld = ld+l1 + i = is + argld = ld*argh + fi = 0. + do 108 ii=3,ido,2 + i = i+2 + fi = fi+1. + arg = fi*argld + wa(i-1) = cos(arg) + wa(i) = sin(arg) + 108 continue + is = is+ido + 109 continue + l1 = l2 + 110 continue +end + +subroutine rfftb1(n, c, ch, wa, ifac) + implicit none + + integer, intent(in) :: n, ifac(*) + real, intent(inout) :: ch(*), c(*), wa(*) + integer :: nf, na, l1, iw, ip, l2, ido, idl1, ix2, ix3, ix4, i, k1 + + !***first executable statement rfftb1 + nf = ifac(2) + na = 0 + l1 = 1 + iw = 1 + do 116 k1=1,nf + ip = ifac(k1+2) + l2 = ip*l1 + ido = n/l2 + idl1 = ido*l1 + if (ip .ne. 4) go to 103 + ix2 = iw+ido + ix3 = ix2+ido + if (na .ne. 0) go to 101 + call radb4(ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) + go to 102 + 101 call radb4(ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) + 102 na = 1-na + go to 115 + 103 if (ip .ne. 2) go to 106 + if (na .ne. 0) go to 104 + call radb2(ido,l1,c,ch,wa(iw)) + go to 105 + 104 call radb2(ido,l1,ch,c,wa(iw)) + 105 na = 1-na + go to 115 + 106 if (ip .ne. 3) go to 109 + ix2 = iw+ido + if (na .ne. 0) go to 107 + call radb3(ido,l1,c,ch,wa(iw),wa(ix2)) + go to 108 + 107 call radb3(ido,l1,ch,c,wa(iw),wa(ix2)) + 108 na = 1-na + go to 115 + 109 if (ip .ne. 5) go to 112 + ix2 = iw+ido + ix3 = ix2+ido + ix4 = ix3+ido + if (na .ne. 0) go to 110 + call radb5(ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + go to 111 + 110 call radb5(ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + 111 na = 1-na + go to 115 + 112 if (na .ne. 0) go to 113 + call radbg(ido,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) + go to 114 + 113 call radbg(ido,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) + 114 if (ido .eq. 1) na = 1-na + 115 l1 = l2 + iw = iw+(ip-1)*ido + 116 continue + if (na .eq. 0) return + do 117 i=1,n + c(i) = ch(i) + 117 continue +end + +subroutine rfftf1 (n, c, ch, wa, ifac) + implicit none + + integer, intent(in) :: n, ifac(*) + real, intent(inout) :: ch(*), wa(*) + real, intent(inout) :: c(*) + integer :: nf, na, l2, iw, k1, kh, ip, l1, ido, idl1, ix2, ix3, ix4, i + + !***FIRST EXECUTABLE STATEMENT RFFTF1 + nf = ifac(2) + na = 1 + l2 = n + iw = n + do 111 k1=1,nf + kh = nf-k1 + ip = ifac(kh+3) + l1 = l2/ip + ido = n/l2 + idl1 = ido*l1 + iw = iw-(ip-1)*ido + na = 1-na + if (ip .ne. 4) go to 102 + ix2 = iw+ido + ix3 = ix2+ido + if (na .ne. 0) go to 101 + call radf4 (ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) + go to 110 + 101 call radf4 (ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) + go to 110 + 102 if (ip .ne. 2) go to 104 + if (na .ne. 0) go to 103 + call radf2 (ido,l1,c,ch,wa(iw)) + go to 110 + 103 call radf2 (ido,l1,ch,c,wa(iw)) + go to 110 + 104 if (ip .ne. 3) go to 106 + ix2 = iw+ido + if (na .ne. 0) go to 105 + call radf3 (ido,l1,c,ch,wa(iw),wa(ix2)) + go to 110 + 105 call radf3 (ido,l1,ch,c,wa(iw),wa(ix2)) + go to 110 + 106 if (ip .ne. 5) go to 108 + ix2 = iw+ido + ix3 = ix2+ido + ix4 = ix3+ido + if (na .ne. 0) go to 107 + call radf5 (ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + go to 110 + 107 call radf5 (ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + go to 110 + 108 if (ido .eq. 1) na = 1-na + if (na .ne. 0) go to 109 + call radfg (ido,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) + na = 1 + go to 110 + 109 call radfg (ido,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) + na = 0 + 110 l2 = l1 + 111 continue + if (na .eq. 1) return + do 112 i=1,n + c(i) = ch(i) + 112 continue +end + +subroutine radb2 (ido, l1, cc, ch, wa1) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,2,*) + real, intent(inout) :: ch(ido,l1,2), wa1(*) + integer :: k, idp2, ic, i + real :: tr2, ti2 + + !***FIRST EXECUTABLE STATEMENT RADB2 + do 101 k=1,l1 + ch(1,k,1) = cc(1,1,k)+cc(ido,2,k) + ch(1,k,2) = cc(1,1,k)-cc(ido,2,k) + 101 continue + if (ido-2) 107,105,102 + 102 idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 108 + do 104 k=1,l1 +!dir$ ivdep + do 103 i=3,ido,2 + ic = idp2-i + ch(i-1,k,1) = cc(i-1,1,k)+cc(ic-1,2,k) + tr2 = cc(i-1,1,k)-cc(ic-1,2,k) + ch(i,k,1) = cc(i,1,k)-cc(ic,2,k) + ti2 = cc(i,1,k)+cc(ic,2,k) + ch(i-1,k,2) = wa1(i-2)*tr2-wa1(i-1)*ti2 + ch(i,k,2) = wa1(i-2)*ti2+wa1(i-1)*tr2 + 103 continue + 104 continue + go to 111 + 108 do 110 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 109 k=1,l1 + ch(i-1,k,1) = cc(i-1,1,k)+cc(ic-1,2,k) + tr2 = cc(i-1,1,k)-cc(ic-1,2,k) + ch(i,k,1) = cc(i,1,k)-cc(ic,2,k) + ti2 = cc(i,1,k)+cc(ic,2,k) + ch(i-1,k,2) = wa1(i-2)*tr2-wa1(i-1)*ti2 + ch(i,k,2) = wa1(i-2)*ti2+wa1(i-1)*tr2 + 109 continue + 110 continue + 111 if (mod(ido,2) .eq. 1) return + 105 do 106 k=1,l1 + ch(ido,k,1) = cc(ido,1,k)+cc(ido,1,k) + ch(ido,k,2) = -(cc(1,2,k)+cc(1,2,k)) + 106 continue + 107 return +end + +subroutine radb3(ido, l1, cc, ch, wa1, wa2) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,3,*), wa1(*), wa2(*) + real, intent(inout) :: ch(ido,l1,3) + integer :: idp2, ic, i, k + real :: taur, taui, tr2, cr2, ci3, ti2, ci2, cr3, dr2, dr3, di2, di3 + + !***FIRST EXECUTABLE STATEMENT RADB3 + taur = -.5 + taui = .5*sqrt(3.) + do 101 k=1,l1 + tr2 = cc(ido,2,k)+cc(ido,2,k) + cr2 = cc(1,1,k)+taur*tr2 + ch(1,k,1) = cc(1,1,k)+tr2 + ci3 = taui*(cc(1,3,k)+cc(1,3,k)) + ch(1,k,2) = cr2-ci3 + ch(1,k,3) = cr2+ci3 + 101 continue + if (ido .eq. 1) return + idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 104 + do 103 k=1,l1 +!dir$ ivdep + do 102 i=3,ido,2 + ic = idp2-i + tr2 = cc(i-1,3,k)+cc(ic-1,2,k) + cr2 = cc(i-1,1,k)+taur*tr2 + ch(i-1,k,1) = cc(i-1,1,k)+tr2 + ti2 = cc(i,3,k)-cc(ic,2,k) + ci2 = cc(i,1,k)+taur*ti2 + ch(i,k,1) = cc(i,1,k)+ti2 + cr3 = taui*(cc(i-1,3,k)-cc(ic-1,2,k)) + ci3 = taui*(cc(i,3,k)+cc(ic,2,k)) + dr2 = cr2-ci3 + dr3 = cr2+ci3 + di2 = ci2+cr3 + di3 = ci2-cr3 + ch(i-1,k,2) = wa1(i-2)*dr2-wa1(i-1)*di2 + ch(i,k,2) = wa1(i-2)*di2+wa1(i-1)*dr2 + ch(i-1,k,3) = wa2(i-2)*dr3-wa2(i-1)*di3 + ch(i,k,3) = wa2(i-2)*di3+wa2(i-1)*dr3 + 102 continue + 103 continue + return + 104 do 106 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 105 k=1,l1 + tr2 = cc(i-1,3,k)+cc(ic-1,2,k) + cr2 = cc(i-1,1,k)+taur*tr2 + ch(i-1,k,1) = cc(i-1,1,k)+tr2 + ti2 = cc(i,3,k)-cc(ic,2,k) + ci2 = cc(i,1,k)+taur*ti2 + ch(i,k,1) = cc(i,1,k)+ti2 + cr3 = taui*(cc(i-1,3,k)-cc(ic-1,2,k)) + ci3 = taui*(cc(i,3,k)+cc(ic,2,k)) + dr2 = cr2-ci3 + dr3 = cr2+ci3 + di2 = ci2+cr3 + di3 = ci2-cr3 + ch(i-1,k,2) = wa1(i-2)*dr2-wa1(i-1)*di2 + ch(i,k,2) = wa1(i-2)*di2+wa1(i-1)*dr2 + ch(i-1,k,3) = wa2(i-2)*dr3-wa2(i-1)*di3 + ch(i,k,3) = wa2(i-2)*di3+wa2(i-1)*dr3 + 105 continue + 106 continue +end + +subroutine radb4(ido, l1, cc, ch, wa1, wa2, wa3) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,4,*), wa1(*), wa2(*), wa3(*) + real, intent(inout) :: ch(ido,l1,4) + real :: sqrt2, tr1, tr2, tr3, tr4, ti1, ti2, ti3, ti4, cr3, ci3, cr2, cr4,& + & ci2, di4, ci4 + integer :: i, k, idp2, ic + + !***First executable statement radb4 + sqrt2 = sqrt(2.) + do 101 k=1,l1 + tr1 = cc(1,1,k)-cc(ido,4,k) + tr2 = cc(1,1,k)+cc(ido,4,k) + tr3 = cc(ido,2,k)+cc(ido,2,k) + tr4 = cc(1,3,k)+cc(1,3,k) + ch(1,k,1) = tr2+tr3 + ch(1,k,2) = tr1-tr4 + ch(1,k,3) = tr2-tr3 + ch(1,k,4) = tr1+tr4 + 101 continue + if (ido-2) 107,105,102 + 102 idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 108 + do 104 k=1,l1 + !dir$ ivdep + do 103 i=3,ido,2 + ic = idp2-i + ti1 = cc(i,1,k)+cc(ic,4,k) + ti2 = cc(i,1,k)-cc(ic,4,k) + ti3 = cc(i,3,k)-cc(ic,2,k) + tr4 = cc(i,3,k)+cc(ic,2,k) + tr1 = cc(i-1,1,k)-cc(ic-1,4,k) + tr2 = cc(i-1,1,k)+cc(ic-1,4,k) + ti4 = cc(i-1,3,k)-cc(ic-1,2,k) + tr3 = cc(i-1,3,k)+cc(ic-1,2,k) + ch(i-1,k,1) = tr2+tr3 + cr3 = tr2-tr3 + ch(i,k,1) = ti2+ti3 + ci3 = ti2-ti3 + cr2 = tr1-tr4 + cr4 = tr1+tr4 + ci2 = ti1+ti4 + ci4 = ti1-ti4 + ch(i-1,k,2) = wa1(i-2)*cr2-wa1(i-1)*ci2 + ch(i,k,2) = wa1(i-2)*ci2+wa1(i-1)*cr2 + ch(i-1,k,3) = wa2(i-2)*cr3-wa2(i-1)*ci3 + ch(i,k,3) = wa2(i-2)*ci3+wa2(i-1)*cr3 + ch(i-1,k,4) = wa3(i-2)*cr4-wa3(i-1)*ci4 + ch(i,k,4) = wa3(i-2)*ci4+wa3(i-1)*cr4 + 103 continue + 104 continue + go to 111 + 108 do 110 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 109 k=1,l1 + ti1 = cc(i,1,k)+cc(ic,4,k) + ti2 = cc(i,1,k)-cc(ic,4,k) + ti3 = cc(i,3,k)-cc(ic,2,k) + tr4 = cc(i,3,k)+cc(ic,2,k) + tr1 = cc(i-1,1,k)-cc(ic-1,4,k) + tr2 = cc(i-1,1,k)+cc(ic-1,4,k) + ti4 = cc(i-1,3,k)-cc(ic-1,2,k) + tr3 = cc(i-1,3,k)+cc(ic-1,2,k) + ch(i-1,k,1) = tr2+tr3 + cr3 = tr2-tr3 + ch(i,k,1) = ti2+ti3 + ci3 = ti2-ti3 + cr2 = tr1-tr4 + cr4 = tr1+tr4 + ci2 = ti1+ti4 + ci4 = ti1-ti4 + ch(i-1,k,2) = wa1(i-2)*cr2-wa1(i-1)*ci2 + ch(i,k,2) = wa1(i-2)*ci2+wa1(i-1)*cr2 + ch(i-1,k,3) = wa2(i-2)*cr3-wa2(i-1)*ci3 + ch(i,k,3) = wa2(i-2)*ci3+wa2(i-1)*cr3 + ch(i-1,k,4) = wa3(i-2)*cr4-wa3(i-1)*ci4 + ch(i,k,4) = wa3(i-2)*ci4+wa3(i-1)*cr4 + 109 continue + 110 continue + 111 if (mod(ido,2) .eq. 1) return + 105 do 106 k=1,l1 + ti1 = cc(1,2,k)+cc(1,4,k) + ti2 = cc(1,4,k)-cc(1,2,k) + tr1 = cc(ido,1,k)-cc(ido,3,k) + tr2 = cc(ido,1,k)+cc(ido,3,k) + ch(ido,k,1) = tr2+tr2 + ch(ido,k,2) = sqrt2*(tr1-ti1) + ch(ido,k,3) = ti2+ti2 + ch(ido,k,4) = -sqrt2*(tr1+ti1) + 106 continue + 107 return +end + +subroutine radb5(ido, l1, cc, ch, wa1, wa2, wa3, wa4) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,5,*), wa1(*), wa2(*), wa3(*), wa4(*) + real, intent(inout) :: ch(ido,l1,5) + real :: pi, tr11, ti11, tr12, ti12, ti5, ti4, tr2, tr3, cr2, cr3, ci5, ci4,& + & ti2, ti3, tr5, tr4, ci2, ci3, cr5, cr4, dr3, dr4, di3, di4, dr5,& + & dr2, di5, di2 + integer :: i, k, ic, idp2 + + !***First executable statement radb5 + pi = 4.*atan(1.) + tr11 = sin(.1*pi) + ti11 = sin(.4*pi) + tr12 = -sin(.3*pi) + ti12 = sin(.2*pi) + do 101 k=1,l1 + ti5 = cc(1,3,k)+cc(1,3,k) + ti4 = cc(1,5,k)+cc(1,5,k) + tr2 = cc(ido,2,k)+cc(ido,2,k) + tr3 = cc(ido,4,k)+cc(ido,4,k) + ch(1,k,1) = cc(1,1,k)+tr2+tr3 + cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 + cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 + ci5 = ti11*ti5+ti12*ti4 + ci4 = ti12*ti5-ti11*ti4 + ch(1,k,2) = cr2-ci5 + ch(1,k,3) = cr3-ci4 + ch(1,k,4) = cr3+ci4 + ch(1,k,5) = cr2+ci5 + 101 continue + if (ido .eq. 1) return + idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 104 + do 103 k=1,l1 +!dir$ ivdep + do 102 i=3,ido,2 + ic = idp2-i + ti5 = cc(i,3,k)+cc(ic,2,k) + ti2 = cc(i,3,k)-cc(ic,2,k) + ti4 = cc(i,5,k)+cc(ic,4,k) + ti3 = cc(i,5,k)-cc(ic,4,k) + tr5 = cc(i-1,3,k)-cc(ic-1,2,k) + tr2 = cc(i-1,3,k)+cc(ic-1,2,k) + tr4 = cc(i-1,5,k)-cc(ic-1,4,k) + tr3 = cc(i-1,5,k)+cc(ic-1,4,k) + ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 + ch(i,k,1) = cc(i,1,k)+ti2+ti3 + cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + dr3 = cr3-ci4 + dr4 = cr3+ci4 + di3 = ci3+cr4 + di4 = ci3-cr4 + dr5 = cr2+ci5 + dr2 = cr2-ci5 + di5 = ci2-cr5 + di2 = ci2+cr5 + ch(i-1,k,2) = wa1(i-2)*dr2-wa1(i-1)*di2 + ch(i,k,2) = wa1(i-2)*di2+wa1(i-1)*dr2 + ch(i-1,k,3) = wa2(i-2)*dr3-wa2(i-1)*di3 + ch(i,k,3) = wa2(i-2)*di3+wa2(i-1)*dr3 + ch(i-1,k,4) = wa3(i-2)*dr4-wa3(i-1)*di4 + ch(i,k,4) = wa3(i-2)*di4+wa3(i-1)*dr4 + ch(i-1,k,5) = wa4(i-2)*dr5-wa4(i-1)*di5 + ch(i,k,5) = wa4(i-2)*di5+wa4(i-1)*dr5 + 102 continue + 103 continue + return + 104 do 106 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 105 k=1,l1 + ti5 = cc(i,3,k)+cc(ic,2,k) + ti2 = cc(i,3,k)-cc(ic,2,k) + ti4 = cc(i,5,k)+cc(ic,4,k) + ti3 = cc(i,5,k)-cc(ic,4,k) + tr5 = cc(i-1,3,k)-cc(ic-1,2,k) + tr2 = cc(i-1,3,k)+cc(ic-1,2,k) + tr4 = cc(i-1,5,k)-cc(ic-1,4,k) + tr3 = cc(i-1,5,k)+cc(ic-1,4,k) + ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 + ch(i,k,1) = cc(i,1,k)+ti2+ti3 + cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + dr3 = cr3-ci4 + dr4 = cr3+ci4 + di3 = ci3+cr4 + di4 = ci3-cr4 + dr5 = cr2+ci5 + dr2 = cr2-ci5 + di5 = ci2-cr5 + di2 = ci2+cr5 + ch(i-1,k,2) = wa1(i-2)*dr2-wa1(i-1)*di2 + ch(i,k,2) = wa1(i-2)*di2+wa1(i-1)*dr2 + ch(i-1,k,3) = wa2(i-2)*dr3-wa2(i-1)*di3 + ch(i,k,3) = wa2(i-2)*di3+wa2(i-1)*dr3 + ch(i-1,k,4) = wa3(i-2)*dr4-wa3(i-1)*di4 + ch(i,k,4) = wa3(i-2)*di4+wa3(i-1)*dr4 + ch(i-1,k,5) = wa4(i-2)*dr5-wa4(i-1)*di5 + ch(i,k,5) = wa4(i-2)*di5+wa4(i-1)*dr5 + 105 continue + 106 continue + return +end + +subroutine radbg(ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa) + implicit none + + integer, intent(in) :: ido, ip, l1, idl1 + real, intent(in) :: cc(ido,ip,*), wa(*) + real, intent(inout) :: ch(ido,l1,*), c1(ido,l1,*), c2(idl1,*),& + & ch2(idl1,*) + real :: tpi, arg, dcp, dsp, ar1, ai1, ar1h, ds2, dc2, ar2, ai2, ar2h + integer :: idp2, nbd, ipp2, ipph, i, j, k, jc, j2, lca, is, idij, ic, ik,& + & l, lc + + !***First executable statement radbg + tpi = 8.*atan(1.) + arg = tpi/ip + dcp = cos(arg) + dsp = sin(arg) + idp2 = ido+2 + nbd = (ido-1)/2 + ipp2 = ip+2 + ipph = (ip+1)/2 + if (ido .lt. l1) go to 103 + do 102 k=1,l1 + do 101 i=1,ido + ch(i,k,1) = cc(i,1,k) + 101 continue + 102 continue + go to 106 + 103 do 105 i=1,ido + do 104 k=1,l1 + ch(i,k,1) = cc(i,1,k) + 104 continue + 105 continue + 106 do 108 j=2,ipph + jc = ipp2-j + j2 = j+j + do 107 k=1,l1 + ch(1,k,j) = cc(ido,j2-2,k)+cc(ido,j2-2,k) + ch(1,k,jc) = cc(1,j2-1,k)+cc(1,j2-1,k) + 107 continue + 108 continue + if (ido .eq. 1) go to 116 + if (nbd .lt. l1) go to 112 + do 111 j=2,ipph + jc = ipp2-j + do 110 k=1,l1 +!dir$ ivdep + do 109 i=3,ido,2 + ic = idp2-i + ch(i-1,k,j) = cc(i-1,2*j-1,k)+cc(ic-1,2*j-2,k) + ch(i-1,k,jc) = cc(i-1,2*j-1,k)-cc(ic-1,2*j-2,k) + ch(i,k,j) = cc(i,2*j-1,k)-cc(ic,2*j-2,k) + ch(i,k,jc) = cc(i,2*j-1,k)+cc(ic,2*j-2,k) + 109 continue + 110 continue + 111 continue + go to 116 + 112 do 115 j=2,ipph + jc = ipp2-j +!dir$ ivdep + do 114 i=3,ido,2 + ic = idp2-i + do 113 k=1,l1 + ch(i-1,k,j) = cc(i-1,2*j-1,k)+cc(ic-1,2*j-2,k) + ch(i-1,k,jc) = cc(i-1,2*j-1,k)-cc(ic-1,2*j-2,k) + ch(i,k,j) = cc(i,2*j-1,k)-cc(ic,2*j-2,k) + ch(i,k,jc) = cc(i,2*j-1,k)+cc(ic,2*j-2,k) + 113 continue + 114 continue + 115 continue + 116 ar1 = 1. + ai1 = 0. + do 120 l=2,ipph + lc = ipp2-l + ar1h = dcp*ar1-dsp*ai1 + ai1 = dcp*ai1+dsp*ar1 + ar1 = ar1h + do 117 ik=1,idl1 + c2(ik,l) = ch2(ik,1)+ar1*ch2(ik,2) + c2(ik,lc) = ai1*ch2(ik,ip) + 117 continue + dc2 = ar1 + ds2 = ai1 + ar2 = ar1 + ai2 = ai1 + do 119 j=3,ipph + jc = ipp2-j + ar2h = dc2*ar2-ds2*ai2 + ai2 = dc2*ai2+ds2*ar2 + ar2 = ar2h + do 118 ik=1,idl1 + c2(ik,l) = c2(ik,l)+ar2*ch2(ik,j) + c2(ik,lc) = c2(ik,lc)+ai2*ch2(ik,jc) + 118 continue + 119 continue + 120 continue + do 122 j=2,ipph + do 121 ik=1,idl1 + ch2(ik,1) = ch2(ik,1)+ch2(ik,j) + 121 continue + 122 continue + do 124 j=2,ipph + jc = ipp2-j + do 123 k=1,l1 + ch(1,k,j) = c1(1,k,j)-c1(1,k,jc) + ch(1,k,jc) = c1(1,k,j)+c1(1,k,jc) + 123 continue + 124 continue + if (ido .eq. 1) go to 132 + if (nbd .lt. l1) go to 128 + do 127 j=2,ipph + jc = ipp2-j + do 126 k=1,l1 +!dir$ ivdep + do 125 i=3,ido,2 + ch(i-1,k,j) = c1(i-1,k,j)-c1(i,k,jc) + ch(i-1,k,jc) = c1(i-1,k,j)+c1(i,k,jc) + ch(i,k,j) = c1(i,k,j)+c1(i-1,k,jc) + ch(i,k,jc) = c1(i,k,j)-c1(i-1,k,jc) + 125 continue + 126 continue + 127 continue + go to 132 + 128 do 131 j=2,ipph + jc = ipp2-j + do 130 i=3,ido,2 + do 129 k=1,l1 + ch(i-1,k,j) = c1(i-1,k,j)-c1(i,k,jc) + ch(i-1,k,jc) = c1(i-1,k,j)+c1(i,k,jc) + ch(i,k,j) = c1(i,k,j)+c1(i-1,k,jc) + ch(i,k,jc) = c1(i,k,j)-c1(i-1,k,jc) + 129 continue + 130 continue + 131 continue + 132 continue + if (ido .eq. 1) return + do 133 ik=1,idl1 + c2(ik,1) = ch2(ik,1) + 133 continue + do 135 j=2,ip + do 134 k=1,l1 + c1(1,k,j) = ch(1,k,j) + 134 continue + 135 continue + if (nbd .gt. l1) go to 139 + is = -ido + do 138 j=2,ip + is = is+ido + idij = is + do 137 i=3,ido,2 + idij = idij+2 + do 136 k=1,l1 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) + 136 continue + 137 continue + 138 continue + go to 143 + 139 is = -ido + do 142 j=2,ip + is = is+ido + do 141 k=1,l1 + idij = is +!dir$ ivdep + do 140 i=3,ido,2 + idij = idij+2 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) + 140 continue + 141 continue + 142 continue + 143 return + end + +subroutine radf2(ido, l1, cc, ch, wa1) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,l1,2), wa1(*) + real, intent(inout) :: ch(ido,2,*) + real :: tr2, ti2 + integer :: i, k, idp2, ic + + !***First executable statement radf2 + do 101 k=1,l1 + ch(1,1,k) = cc(1,k,1)+cc(1,k,2) + ch(ido,2,k) = cc(1,k,1)-cc(1,k,2) + 101 continue + if (ido-2) 107,105,102 + 102 idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 108 + do 104 k=1,l1 +!dir$ ivdep + do 103 i=3,ido,2 + ic = idp2-i + tr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + ti2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + ch(i,1,k) = cc(i,k,1)+ti2 + ch(ic,2,k) = ti2-cc(i,k,1) + ch(i-1,1,k) = cc(i-1,k,1)+tr2 + ch(ic-1,2,k) = cc(i-1,k,1)-tr2 + 103 continue + 104 continue + go to 111 + 108 do 110 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 109 k=1,l1 + tr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + ti2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + ch(i,1,k) = cc(i,k,1)+ti2 + ch(ic,2,k) = ti2-cc(i,k,1) + ch(i-1,1,k) = cc(i-1,k,1)+tr2 + ch(ic-1,2,k) = cc(i-1,k,1)-tr2 + 109 continue + 110 continue + 111 if (mod(ido,2) .eq. 1) return + 105 do 106 k=1,l1 + ch(1,2,k) = -cc(ido,k,2) + ch(ido,1,k) = cc(ido,k,1) + 106 continue + 107 return +end + +subroutine radf3(ido, l1, cc, ch, wa1, wa2) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,l1,3), wa1(*), wa2(*) + real, intent(inout) :: ch(ido,3,*) + real :: taur, taui, cr2, dr2, di2, dr3, di3, ci2, tr2, ti2, tr3, ti3 + integer :: i, k, idp2, ic + + !***First executable statement radf3 + taur = -.5 + taui = .5*sqrt(3.) + do 101 k=1,l1 + cr2 = cc(1,k,2)+cc(1,k,3) + ch(1,1,k) = cc(1,k,1)+cr2 + ch(1,3,k) = taui*(cc(1,k,3)-cc(1,k,2)) + ch(ido,2,k) = cc(1,k,1)+taur*cr2 + 101 continue + if (ido .eq. 1) return + idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 104 + do 103 k=1,l1 +!dir$ ivdep + do 102 i=3,ido,2 + ic = idp2-i + dr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + di2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + dr3 = wa2(i-2)*cc(i-1,k,3)+wa2(i-1)*cc(i,k,3) + di3 = wa2(i-2)*cc(i,k,3)-wa2(i-1)*cc(i-1,k,3) + cr2 = dr2+dr3 + ci2 = di2+di3 + ch(i-1,1,k) = cc(i-1,k,1)+cr2 + ch(i,1,k) = cc(i,k,1)+ci2 + tr2 = cc(i-1,k,1)+taur*cr2 + ti2 = cc(i,k,1)+taur*ci2 + tr3 = taui*(di2-di3) + ti3 = taui*(dr3-dr2) + ch(i-1,3,k) = tr2+tr3 + ch(ic-1,2,k) = tr2-tr3 + ch(i,3,k) = ti2+ti3 + ch(ic,2,k) = ti3-ti2 + 102 continue + 103 continue + return + 104 do 106 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 105 k=1,l1 + dr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + di2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + dr3 = wa2(i-2)*cc(i-1,k,3)+wa2(i-1)*cc(i,k,3) + di3 = wa2(i-2)*cc(i,k,3)-wa2(i-1)*cc(i-1,k,3) + cr2 = dr2+dr3 + ci2 = di2+di3 + ch(i-1,1,k) = cc(i-1,k,1)+cr2 + ch(i,1,k) = cc(i,k,1)+ci2 + tr2 = cc(i-1,k,1)+taur*cr2 + ti2 = cc(i,k,1)+taur*ci2 + tr3 = taui*(di2-di3) + ti3 = taui*(dr3-dr2) + ch(i-1,3,k) = tr2+tr3 + ch(ic-1,2,k) = tr2-tr3 + ch(i,3,k) = ti2+ti3 + ch(ic,2,k) = ti3-ti2 + 105 continue + 106 continue +end + +subroutine radf4(ido, l1, cc, ch, wa1, wa2, wa3) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,l1,4), wa1(*), wa2(*), wa3(*) + real, intent(inout) :: ch(ido,4,*) + real :: hsqt2, tr1, tr2, tr3, tr4, cr2, ci2, cr3, ci3, cr4, ci4, ti1, ti2,& + & ti3, ti4 + integer :: i, k, ic, idp2 + + !***First executable statement radf4 + hsqt2 = .5*sqrt(2.) + do 101 k=1,l1 + tr1 = cc(1,k,2)+cc(1,k,4) + tr2 = cc(1,k,1)+cc(1,k,3) + ch(1,1,k) = tr1+tr2 + ch(ido,4,k) = tr2-tr1 + ch(ido,2,k) = cc(1,k,1)-cc(1,k,3) + ch(1,3,k) = cc(1,k,4)-cc(1,k,2) + 101 continue + if (ido-2) 107,105,102 + 102 idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 111 + do 104 k=1,l1 +!dir$ ivdep + do 103 i=3,ido,2 + ic = idp2-i + cr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + ci2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + cr3 = wa2(i-2)*cc(i-1,k,3)+wa2(i-1)*cc(i,k,3) + ci3 = wa2(i-2)*cc(i,k,3)-wa2(i-1)*cc(i-1,k,3) + cr4 = wa3(i-2)*cc(i-1,k,4)+wa3(i-1)*cc(i,k,4) + ci4 = wa3(i-2)*cc(i,k,4)-wa3(i-1)*cc(i-1,k,4) + tr1 = cr2+cr4 + tr4 = cr4-cr2 + ti1 = ci2+ci4 + ti4 = ci2-ci4 + ti2 = cc(i,k,1)+ci3 + ti3 = cc(i,k,1)-ci3 + tr2 = cc(i-1,k,1)+cr3 + tr3 = cc(i-1,k,1)-cr3 + ch(i-1,1,k) = tr1+tr2 + ch(ic-1,4,k) = tr2-tr1 + ch(i,1,k) = ti1+ti2 + ch(ic,4,k) = ti1-ti2 + ch(i-1,3,k) = ti4+tr3 + ch(ic-1,2,k) = tr3-ti4 + ch(i,3,k) = tr4+ti3 + ch(ic,2,k) = tr4-ti3 + 103 continue + 104 continue + go to 110 + 111 do 109 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 108 k=1,l1 + cr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + ci2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + cr3 = wa2(i-2)*cc(i-1,k,3)+wa2(i-1)*cc(i,k,3) + ci3 = wa2(i-2)*cc(i,k,3)-wa2(i-1)*cc(i-1,k,3) + cr4 = wa3(i-2)*cc(i-1,k,4)+wa3(i-1)*cc(i,k,4) + ci4 = wa3(i-2)*cc(i,k,4)-wa3(i-1)*cc(i-1,k,4) + tr1 = cr2+cr4 + tr4 = cr4-cr2 + ti1 = ci2+ci4 + ti4 = ci2-ci4 + ti2 = cc(i,k,1)+ci3 + ti3 = cc(i,k,1)-ci3 + tr2 = cc(i-1,k,1)+cr3 + tr3 = cc(i-1,k,1)-cr3 + ch(i-1,1,k) = tr1+tr2 + ch(ic-1,4,k) = tr2-tr1 + ch(i,1,k) = ti1+ti2 + ch(ic,4,k) = ti1-ti2 + ch(i-1,3,k) = ti4+tr3 + ch(ic-1,2,k) = tr3-ti4 + ch(i,3,k) = tr4+ti3 + ch(ic,2,k) = tr4-ti3 + 108 continue + 109 continue + 110 if (mod(ido,2) .eq. 1) return + 105 do 106 k=1,l1 + ti1 = -hsqt2*(cc(ido,k,2)+cc(ido,k,4)) + tr1 = hsqt2*(cc(ido,k,2)-cc(ido,k,4)) + ch(ido,1,k) = tr1+cc(ido,k,1) + ch(ido,3,k) = cc(ido,k,1)-tr1 + ch(1,2,k) = ti1-cc(ido,k,3) + ch(1,4,k) = ti1+cc(ido,k,3) + 106 continue + 107 return +end + +subroutine radf5(ido, l1, cc, ch, wa1, wa2, wa3, wa4) + implicit none + + integer, intent(in) :: ido, l1 + real, intent(in) :: cc(ido,l1,5), wa1(*), wa2(*), wa3(*), wa4(*) + real, intent(inout) :: ch(ido,5,*) + real :: pi, tr11, ti11, tr12, ti12, cr2, cr3, cr4, cr5, ci2, ci3, ci4, ci5,& + & dr2, dr3, dr4, dr5, di2, di3, di4, di5, tr2, tr3, tr4, tr5, ti2, ti3,& + & ti4, ti5 + integer :: i, k, idp2, ic + + !***First executable statement radf5 + pi = 4.*atan(1.) + tr11 = sin(.1*pi) + ti11 = sin(.4*pi) + tr12 = -sin(.3*pi) + ti12 = sin(.2*pi) + do 101 k=1,l1 + cr2 = cc(1,k,5)+cc(1,k,2) + ci5 = cc(1,k,5)-cc(1,k,2) + cr3 = cc(1,k,4)+cc(1,k,3) + ci4 = cc(1,k,4)-cc(1,k,3) + ch(1,1,k) = cc(1,k,1)+cr2+cr3 + ch(ido,2,k) = cc(1,k,1)+tr11*cr2+tr12*cr3 + ch(1,3,k) = ti11*ci5+ti12*ci4 + ch(ido,4,k) = cc(1,k,1)+tr12*cr2+tr11*cr3 + ch(1,5,k) = ti12*ci5-ti11*ci4 + 101 continue + if (ido .eq. 1) return + idp2 = ido+2 + if((ido-1)/2.lt.l1) go to 104 + do 103 k=1,l1 +!dir$ ivdep + do 102 i=3,ido,2 + ic = idp2-i + dr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + di2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + dr3 = wa2(i-2)*cc(i-1,k,3)+wa2(i-1)*cc(i,k,3) + di3 = wa2(i-2)*cc(i,k,3)-wa2(i-1)*cc(i-1,k,3) + dr4 = wa3(i-2)*cc(i-1,k,4)+wa3(i-1)*cc(i,k,4) + di4 = wa3(i-2)*cc(i,k,4)-wa3(i-1)*cc(i-1,k,4) + dr5 = wa4(i-2)*cc(i-1,k,5)+wa4(i-1)*cc(i,k,5) + di5 = wa4(i-2)*cc(i,k,5)-wa4(i-1)*cc(i-1,k,5) + cr2 = dr2+dr5 + ci5 = dr5-dr2 + cr5 = di2-di5 + ci2 = di2+di5 + cr3 = dr3+dr4 + ci4 = dr4-dr3 + cr4 = di3-di4 + ci3 = di3+di4 + ch(i-1,1,k) = cc(i-1,k,1)+cr2+cr3 + ch(i,1,k) = cc(i,k,1)+ci2+ci3 + tr2 = cc(i-1,k,1)+tr11*cr2+tr12*cr3 + ti2 = cc(i,k,1)+tr11*ci2+tr12*ci3 + tr3 = cc(i-1,k,1)+tr12*cr2+tr11*cr3 + ti3 = cc(i,k,1)+tr12*ci2+tr11*ci3 + tr5 = ti11*cr5+ti12*cr4 + ti5 = ti11*ci5+ti12*ci4 + tr4 = ti12*cr5-ti11*cr4 + ti4 = ti12*ci5-ti11*ci4 + ch(i-1,3,k) = tr2+tr5 + ch(ic-1,2,k) = tr2-tr5 + ch(i,3,k) = ti2+ti5 + ch(ic,2,k) = ti5-ti2 + ch(i-1,5,k) = tr3+tr4 + ch(ic-1,4,k) = tr3-tr4 + ch(i,5,k) = ti3+ti4 + ch(ic,4,k) = ti4-ti3 + 102 continue + 103 continue + return + 104 do 106 i=3,ido,2 + ic = idp2-i +!dir$ ivdep + do 105 k=1,l1 + dr2 = wa1(i-2)*cc(i-1,k,2)+wa1(i-1)*cc(i,k,2) + di2 = wa1(i-2)*cc(i,k,2)-wa1(i-1)*cc(i-1,k,2) + dr3 = wa2(i-2)*cc(i-1,k,3)+wa2(i-1)*cc(i,k,3) + di3 = wa2(i-2)*cc(i,k,3)-wa2(i-1)*cc(i-1,k,3) + dr4 = wa3(i-2)*cc(i-1,k,4)+wa3(i-1)*cc(i,k,4) + di4 = wa3(i-2)*cc(i,k,4)-wa3(i-1)*cc(i-1,k,4) + dr5 = wa4(i-2)*cc(i-1,k,5)+wa4(i-1)*cc(i,k,5) + di5 = wa4(i-2)*cc(i,k,5)-wa4(i-1)*cc(i-1,k,5) + cr2 = dr2+dr5 + ci5 = dr5-dr2 + cr5 = di2-di5 + ci2 = di2+di5 + cr3 = dr3+dr4 + ci4 = dr4-dr3 + cr4 = di3-di4 + ci3 = di3+di4 + ch(i-1,1,k) = cc(i-1,k,1)+cr2+cr3 + ch(i,1,k) = cc(i,k,1)+ci2+ci3 + tr2 = cc(i-1,k,1)+tr11*cr2+tr12*cr3 + ti2 = cc(i,k,1)+tr11*ci2+tr12*ci3 + tr3 = cc(i-1,k,1)+tr12*cr2+tr11*cr3 + ti3 = cc(i,k,1)+tr12*ci2+tr11*ci3 + tr5 = ti11*cr5+ti12*cr4 + ti5 = ti11*ci5+ti12*ci4 + tr4 = ti12*cr5-ti11*cr4 + ti4 = ti12*ci5-ti11*ci4 + ch(i-1,3,k) = tr2+tr5 + ch(ic-1,2,k) = tr2-tr5 + ch(i,3,k) = ti2+ti5 + ch(ic,2,k) = ti5-ti2 + ch(i-1,5,k) = tr3+tr4 + ch(ic-1,4,k) = tr3-tr4 + ch(i,5,k) = ti3+ti4 + ch(ic,4,k) = ti4-ti3 + 105 continue + 106 continue +end + +subroutine radfg(ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa) + implicit none + + integer, intent(in) :: ido, ip, l1, idl1 + real, intent(in) :: wa(*) + real, intent(inout) :: ch(ido,l1,*), cc(ido,ip,*), c1(ido,l1,*),& + & c2(idl1,*), ch2(idl1,*) + real :: tpi, arg, dcp, dsp, ar1h, ar2h, ai1, ai2, ar1, ar2, dc2, ds2 + integer :: ipph, ipp2, idp2, nbd, is, idif, ik, j, j2, jc, i, ic, idij, k,& + & l, lc + + !***First executable statement radfg + tpi = 8.*atan(1.) + arg = tpi/ip + dcp = cos(arg) + dsp = sin(arg) + ipph = (ip+1)/2 + ipp2 = ip+2 + idp2 = ido+2 + nbd = (ido-1)/2 + if (ido .eq. 1) go to 119 + do 101 ik=1,idl1 + ch2(ik,1) = c2(ik,1) + 101 continue + do 103 j=2,ip + do 102 k=1,l1 + ch(1,k,j) = c1(1,k,j) + 102 continue + 103 continue + if (nbd .gt. l1) go to 107 + is = -ido + do 106 j=2,ip + is = is+ido + idij = is + do 105 i=3,ido,2 + idij = idij+2 + do 104 k=1,l1 + ch(i-1,k,j) = wa(idij-1)*c1(i-1,k,j)+wa(idij)*c1(i,k,j) + ch(i,k,j) = wa(idij-1)*c1(i,k,j)-wa(idij)*c1(i-1,k,j) + 104 continue + 105 continue + 106 continue + go to 111 + 107 is = -ido + do 110 j=2,ip + is = is+ido + do 109 k=1,l1 + idij = is +!dir$ ivdep + do 108 i=3,ido,2 + idij = idij+2 + ch(i-1,k,j) = wa(idij-1)*c1(i-1,k,j)+wa(idij)*c1(i,k,j) + ch(i,k,j) = wa(idij-1)*c1(i,k,j)-wa(idij)*c1(i-1,k,j) + 108 continue + 109 continue + 110 continue + 111 if (nbd .lt. l1) go to 115 + do 114 j=2,ipph + jc = ipp2-j + do 113 k=1,l1 +!dir$ ivdep + do 112 i=3,ido,2 + c1(i-1,k,j) = ch(i-1,k,j)+ch(i-1,k,jc) + c1(i-1,k,jc) = ch(i,k,j)-ch(i,k,jc) + c1(i,k,j) = ch(i,k,j)+ch(i,k,jc) + c1(i,k,jc) = ch(i-1,k,jc)-ch(i-1,k,j) + 112 continue + 113 continue + 114 continue + go to 121 + 115 do 118 j=2,ipph + jc = ipp2-j + do 117 i=3,ido,2 + do 116 k=1,l1 + c1(i-1,k,j) = ch(i-1,k,j)+ch(i-1,k,jc) + c1(i-1,k,jc) = ch(i,k,j)-ch(i,k,jc) + c1(i,k,j) = ch(i,k,j)+ch(i,k,jc) + c1(i,k,jc) = ch(i-1,k,jc)-ch(i-1,k,j) + 116 continue + 117 continue + 118 continue + go to 121 + 119 do 120 ik=1,idl1 + c2(ik,1) = ch2(ik,1) + 120 continue + 121 do 123 j=2,ipph + jc = ipp2-j + do 122 k=1,l1 + c1(1,k,j) = ch(1,k,j)+ch(1,k,jc) + c1(1,k,jc) = ch(1,k,jc)-ch(1,k,j) + 122 continue + 123 continue +! + ar1 = 1. + ai1 = 0. + do 127 l=2,ipph + lc = ipp2-l + ar1h = dcp*ar1-dsp*ai1 + ai1 = dcp*ai1+dsp*ar1 + ar1 = ar1h + do 124 ik=1,idl1 + ch2(ik,l) = c2(ik,1)+ar1*c2(ik,2) + ch2(ik,lc) = ai1*c2(ik,ip) + 124 continue + dc2 = ar1 + ds2 = ai1 + ar2 = ar1 + ai2 = ai1 + do 126 j=3,ipph + jc = ipp2-j + ar2h = dc2*ar2-ds2*ai2 + ai2 = dc2*ai2+ds2*ar2 + ar2 = ar2h + do 125 ik=1,idl1 + ch2(ik,l) = ch2(ik,l)+ar2*c2(ik,j) + ch2(ik,lc) = ch2(ik,lc)+ai2*c2(ik,jc) + 125 continue + 126 continue + 127 continue + do 129 j=2,ipph + do 128 ik=1,idl1 + ch2(ik,1) = ch2(ik,1)+c2(ik,j) + 128 continue + 129 continue +! + if (ido .lt. l1) go to 132 + do 131 k=1,l1 + do 130 i=1,ido + cc(i,1,k) = ch(i,k,1) + 130 continue + 131 continue + go to 135 + 132 do 134 i=1,ido + do 133 k=1,l1 + cc(i,1,k) = ch(i,k,1) + 133 continue + 134 continue + 135 do 137 j=2,ipph + jc = ipp2-j + j2 = j+j + do 136 k=1,l1 + cc(ido,j2-2,k) = ch(1,k,j) + cc(1,j2-1,k) = ch(1,k,jc) + 136 continue + 137 continue + if (ido .eq. 1) return + if (nbd .lt. l1) go to 141 + do 140 j=2,ipph + jc = ipp2-j + j2 = j+j + do 139 k=1,l1 +!dir$ ivdep + do 138 i=3,ido,2 + ic = idp2-i + cc(i-1,j2-1,k) = ch(i-1,k,j)+ch(i-1,k,jc) + cc(ic-1,j2-2,k) = ch(i-1,k,j)-ch(i-1,k,jc) + cc(i,j2-1,k) = ch(i,k,j)+ch(i,k,jc) + cc(ic,j2-2,k) = ch(i,k,jc)-ch(i,k,j) + 138 continue + 139 continue + 140 continue + return + 141 do 144 j=2,ipph + jc = ipp2-j + j2 = j+j + do 143 i=3,ido,2 + ic = idp2-i + do 142 k=1,l1 + cc(i-1,j2-1,k) = ch(i-1,k,j)+ch(i-1,k,jc) + cc(ic-1,j2-2,k) = ch(i-1,k,j)-ch(i-1,k,jc) + cc(i,j2-1,k) = ch(i,k,j)+ch(i,k,jc) + cc(ic,j2-2,k) = ch(i,k,jc)-ch(i,k,j) + 142 continue + 143 continue + 144 continue + return + end diff --git a/src/speedy_res_interface.f90 b/src/speedy_res_interface.f90 new file mode 100755 index 0000000..981e4de --- /dev/null +++ b/src/speedy_res_interface.f90 @@ -0,0 +1,646 @@ +module speedy_res_interface + + use mod_utilities, only : dp, speedy_data_type, era_data_type, state_vector_type, & + reservoir_type, grid_type, model_parameters_type + use mod_atparam, only : ix,il,kx + use mod_physvar, only : ug1, vg1, tg1, qg1, phig1, pslg1 + use mod_tsteps, only : currentstep + use mod_calendar, only : calendar, initialize_calendar + + implicit none + + integer, parameter :: numoftimestep=17, stride=1, & !13140*6 !18300*4 this is for 50 time step days + vartime=numoftimestep/stride, & + numofspeedyvars=4, numoflevels=8 + + type(state_vector_type) :: internal_state_vector + + contains + subroutine startspeedy(model_parameters,grid,runspeedy) + use mpires, only : mpi_res + use mod_io, only : write_netcdf_speedy_full, read_era_data_parallel + use resdomain, only : initializedomain + use speedy_main + + type(model_parameters_type), intent(in) :: model_parameters + type(grid_type), intent(inout) :: grid + + logical, intent(in) :: runspeedy + + integer, parameter :: root=0 + + integer :: speedydays + integer :: vert_level + + call initializedomain(mpi_res%numprocs,mpi_res%proc_num,model_parameters%overlap,grid%num_vert_levels,vert_level,grid%vert_overlap,grid) + + call initialize_calendar(calendar,1981,1,1,0)!call initialize_calendar(calendar,1982,1,1,0) + end subroutine startspeedy + + !subroutine write_restart(filename,timestep) + ! use mod_io, only : write_netcdf_speedy_full_mpi + ! use mpires, only : mpi_res + + ! character(len=*), intent(in) :: filename + ! integer, intent(in) :: timestep + + ! call write_netcdf_speedy_full_mpi(speedy_data%speedyvariables(:,:,:,:,currentstep/stride),speedy_data%speedy_logp(:,:,currentstep/stride),timestep,filename,mpi_res) + !end subroutine + + subroutine write_restart_new(filename,timestep,grid4d,grid2d) + use mod_io, only : write_netcdf_speedy_full_mpi + use mpires, only : mpi_res + + character(len=*), intent(in) :: filename + integer, intent(in) :: timestep + real(kind=dp), intent(in) :: grid4d(:,:,:,:) + real(kind=dp), intent(in) :: grid2d(:,:) + + !call write_netcdf_speedy_full_mpi(grid4d,grid2d,timestep,filename,mpi_res) + end subroutine + + subroutine getspeedyvariable() + use mod_io, only : write_netcdf_speedy_full + + integer :: nlon, nlat, nlev + + nlon = ix + nlat = il + nlev = kx + + if(MOD(currentstep,stride).eq.0) then + print *, currentstep,'step' + + !speedy_data%speedyvariables(1,:,:,:,currentstep/stride) = reshape(tg1,(/nlon,nlat,nlev/)) + + !speedy_data%speedyvariables(2,:,:,:,currentstep/stride) = reshape(ug1,(/nlon,nlat,nlev/)) + + !speedy_data%speedyvariables(3,:,:,:,currentstep/stride) = reshape(vg1,(/nlon,nlat,nlev/)) + + !speedy_data%speedyvariables(4,:,:,:,currentstep/stride) = reshape(qg1,(/nlon,nlat,nlev/)) + + !speedy_data%speedy_logp(:,:,currentstep/stride) = reshape(PSLG1,(/nlon,nlat/)) + !print *, speedy_data%speedyvariables(1,20,:,7,currentstep/stride) + + !if(mod(currentstep,4).eq.0) then + ! print *, 'writing',currentstep/4 + ! call write_restart('stratosphere_run_speedy_only.nc',currentstep/4) + ! endif + endif + end subroutine getspeedyvariable + + !subroutine spectral_inverse_regridding_and_write(tgrid,ugrid,vgrid,qgrid,psgrid,filename,timestep) + !Subroutine to make a guassian grid transform to spectral space + !then perform an inverse transform to get back a lat/lon gaussian grid + + ! use mod_atparam + ! use mod_io, only : write_netcdf_speedy_full, write_netcdf_speedy_full_mpi + ! use mpires, only : mpi_res + + ! real(kind=dp), intent(in) :: tgrid(:,:,:),ugrid(:,:,:),vgrid(:,:,:),qgrid(:,:,:) + ! real(kind=dp), intent(in) :: psgrid(:,:) + ! integer, intent(in) :: timestep + ! character(len=*), intent(in) :: filename + + !Local stuff + ! real(kind=dp), allocatable :: regrid4d(:,:,:,:), regrid2d(:,:) + + ! complex, allocatable :: divcom(:,:,:), vorcom(:,:,:), tcom(:,:,:), pcom(:,:), qcom(:,:,:) + ! complex, dimension(mx,nx) :: ucos, vcos + ! integer :: k, nlevs + + ! allocate(regrid4d(4,ix,iy*2,kx)) + ! allocate(regrid2d(ix,iy*2)) + ! allocate(divcom(mx,nx,kx)) + ! allocate(vorcom(mx,nx,kx)) + ! allocate(tcom(mx,nx,kx)) + ! allocate(qcom(mx,nx,kx)) + ! allocate(pcom(mx,nx)) + + ! nlevs = kx + ! do k=1,nlevs + ! call vdspec(ugrid(:,:,k),vgrid(:,:,k),vorcom(:,:,k),divcom(:,:,k),2) + ! call spec(tgrid(:,:,k),tcom(:,:,k)) + ! call spec(qgrid(:,:,k),qcom(:,:,k)) + ! if(ix.eq.iy*4) then + ! call trunct(divcom(:,:,k)) + ! call trunct(vorcom(:,:,k)) + ! call trunct(tcom(:,:,k)) + ! call trunct(qcom(:,:,k)) + ! end if + ! end do + ! call spec(psgrid,pcom) + ! if (ix.eq.iy*4) call trunct(pcom) + + ! do k=1,nlevs + ! call uvspec(vorcom(:,:,k),divcom(:,:,k),ucos,vcos) + ! call grid(ucos,regrid4d(2,:,:,k),2) + ! call grid(vcos,regrid4d(3,:,:,k),2) + ! end do + + ! do k=1,nlevs + ! call grid(tcom(:,:,k),regrid4d(1,:,:,k), 1) + ! call grid(qcom(:,:,k),regrid4d(4,:,:,k), 1) + ! end do + + ! call grid(pcom,regrid2d,1) + + !call write_netcdf_speedy_full(regrid4d,regrid2d,timestep,filename) + ! call write_netcdf_speedy_full_mpi(regrid4d,regrid2d,timestep,filename,mpi_res) + !end subroutine + + !subroutine regrid_era_spectral() + !Subroutine to regrid an already spacially regridded era data set to speedy + !spectral domain + !E.G takes regridded ERA data then converts that grid into spectal space + !using speedy routines and then inverse transforms the spectral data back + !into xy space and then saves that data + + !Troy local vars + ! integer :: year_i, month_i, start_year,end_year,start_month,end_month + + ! character(len=3) :: file_end='.nc' + ! character(len=7) :: file_begin = 'era_5_m' + ! character(len=10) :: regrid_file = '_regridded' + ! character(len=23) :: spectral_regrid_file = '_regridded_spectral_mpi' + ! character(len=2) :: mid_file='_y' + ! character(len=1) :: month_1 + ! character(len=2) :: month_2 + ! character(len=4) :: year + ! character(len=:), allocatable :: file_path + ! character(len=:), allocatable :: regrid_file_name + ! character(len=:), allocatable :: spectral_regrid_file_name + ! character(len=:), allocatable :: format_month + ! character(len=:), allocatable :: month + + !-----------Troy stuff ---------------! + + !start_year = 1986 + !end_year = 1986 + ! start_month = 1 + ! end_month = 1 + + ! do year_i=start_year,end_year + ! do month_i=start_month,end_month + ! if(month_i >= 10) then + ! format_month = '(I2)' + + ! write(year,'(I4)') year_i + ! write(month_2,'(I2)') month_i + + ! month = month_2 + + ! file_path = '/scratch/user/troyarcomano/ERA_5/'//year//'/' + + ! regrid_file_name = file_path//file_begin//month//mid_file//year//regrid_file//file_end + ! spectral_regrid_file_name = file_path//file_begin//month//mid_file//year//spectral_regrid_file//file_end + ! else + ! format_month = '(I1)' + + ! write(year,'(I4)') year_i + ! write(month_1,'(I1)') month_i + + ! month = month_1 + + ! file_path = '/scratch/user/troyarcomano/ERA_5/'//year//'/' + + ! regrid_file_name = file_path//file_begin//month//mid_file//year//regrid_file//file_end + ! spectral_regrid_file_name = file_path//file_begin//month//mid_file//year//spectral_regrid_file//file_end + ! endif + + ! print *,regrid_file_name + ! print *, spectral_regrid_file_name + ! call regrid_month_era(regrid_file_name,spectral_regrid_file_name) + ! enddo + ! enddo + !end subroutine + + !subroutine regrid_month_era(filename,newfilename) + ! use mod_io, only : read_netcdf_4d, read_netcdf_3d + ! character(len=*), intent(in) :: filename,newfilename + + !Local stuff + ! real(kind=dp), allocatable :: tgrid(:,:,:,:),ugrid(:,:,:,:),vgrid(:,:,:,:),qgrid(:,:,:,:) + ! real(kind=dp), allocatable :: psgrid(:,:,:) + + ! integer :: t, time_len + + ! print *, 'Regridding ERA 5 data' + ! call read_netcdf_4d('Temperature',filename,tgrid) + + ! call read_netcdf_4d('U-wind',filename,ugrid) + + ! call read_netcdf_4d('V-wind',filename,vgrid) + + ! call read_netcdf_4d('Specific_Humidity',filename,qgrid) + + ! call read_netcdf_3d('logp',filename,psgrid) + + ! time_len = size(tgrid,4) + + ! do t=1,time_len + ! call spectral_inverse_regridding_and_write(tgrid(:,:,:,t),ugrid(:,:,:,t),vgrid(:,:,:,t),qgrid(:,:,:,t),psgrid(:,:,t),newfilename,t) + ! enddo + !end subroutine + + + subroutine read_era(reservoir,grid,model_parameters,start_year,end_year,era_data,timestep_arg) + use mpires, only : mpi_res + use mod_io, only : read_era_data_parallel,read_3d_file_parallel, read_era_data_parallel_old, & + read_3d_file_parallel_res + use mod_calendar, only : numof_hours + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: start_year, end_year + + type(era_data_type), intent(inout) :: era_data + + integer, intent(in), optional :: timestep_arg + + integer :: year_i, month_i,start_month,end_month + integer :: numofhours, hour_counter, temp_length, temp_file_length + integer :: start_index, timestep + + type(era_data_type) :: era_data_temp + + character(len=3) :: file_end='.nc' + character(len=7) :: file_begin = 'era_5_y' + !character(len=23) :: spectral_regrid_file = '_regridded_spectral_mpi' + !character(len=14) :: regrid_mpi = '_regridded_mpi' + !character(len=18) :: regrid_mpi = '_regridded_mpi_new' + !character(len=24) :: regrid_mpi = '_regridded_mpi_fixed_var' + character(len=28) :: regrid_mpi = '_regridded_mpi_fixed_var_gcc' + character(len=2) :: mid_file='_y' + character(len=1) :: month_1 + character(len=2) :: month_2 + character(len=4) :: year + character(len=:), allocatable :: file_path + character(len=:), allocatable :: regrid_file_name + character(len=:), allocatable :: spectral_regrid_file_name + character(len=:), allocatable :: format_month + character(len=:), allocatable :: month + character(len=:), allocatable :: tisr_file + character(len=:), allocatable :: sst_file + character(len=:), allocatable :: sst_climo_file + character(len=:), allocatable :: precip_file + + !-----------Troy stuff ---------------! + + if(present(timestep_arg)) then + timestep = timestep_arg + else + timestep = model_parameters%timestep + endif + + start_month = 1 + end_month = 12 + + call numof_hours(start_year,end_year,numofhours) + + + allocate(era_data%eravariables(numofspeedyvars,grid%inputxchunk,grid%inputychunk,grid%inputzchunk,numofhours)) + allocate(era_data%era_logp(grid%inputxchunk,grid%inputychunk,numofhours)) + + + if(reservoir%tisr_input_bool) then + allocate(era_data%era_tisr(grid%inputxchunk,grid%inputychunk,numofhours)) + endif + + if(reservoir%sst_bool) then + allocate(era_data%era_sst(grid%inputxchunk,grid%inputychunk,numofhours+1)) + endif + + if(reservoir%sst_climo_bool) then + !allocate(era_data%era_sst_climo(grid%resxchunk,grid%resychunk,numofhours)) + allocate(era_data%era_sst_climo(grid%inputxchunk,grid%inputychunk,numofhours+1)) + endif + + if(reservoir%precip_bool) then + allocate(era_data%era_precip(grid%inputxchunk,grid%inputychunk,numofhours)) + endif + + + !print *, numofhours + hour_counter = 1 + + print *, 'herhe' + print *, 'start_year,end_year',start_year,end_year + do year_i=start_year,end_year + write(year,'(I4)') year_i + + if(allocated(era_data_temp%era_sst_climo)) print *, 'top loop temp climo allocated',year_i + file_path = '/scratch/user/troyarcomano/ERA_5/'//year//'/' + regrid_file_name = file_path//file_begin//year//regrid_mpi//file_end + + !if(model_parameters%irank == 1) print *, 'regrid_file_name',regrid_file_name + print *, 'regrid_file_name',regrid_file_name + print *, 'callimng read_era_data_parallel' + if(allocated(era_data_temp%era_sst_climo)) print *, 'before read_era_data_parallel loop temp climo allocated',year_i + call read_era_data_parallel(regrid_file_name,model_parameters,mpi_res,grid,era_data_temp,1,1) + if(allocated(era_data_temp%era_sst_climo)) print *, 'after read_era_data_parallel loop temp climo allocated',year_i + !call read_era_data_parallel_old(regrid_file_name,mpi_res,grid,era_data_temp) + + if(reservoir%assigned_region == 954) print *, 'era_data_temp%eravariables(4,2,2,:,1)', era_data_temp%eravariables(4,2,2,:,1) + + temp_length = size(era_data_temp%eravariables,5)!/timestep + !temp_file_length = temp_length * timestep + + !print *, 'shape(era_data%eravariables(:,:,:,:,hour_counter:temp_length+hour_counter-1)', shape(era_data%eravariables(:,:,:,:,hour_counter:temp_length+hour_counter-1)) + !print *, 'shape( era_data_temp%eravariables(:,:,:,:,start_index:temp_file_length:model_parameters%timestep))',shape(era_data_temp%eravariables(:,:,:,:,start_index:temp_file_length:timestep)) + !print *, 'grid%input_zstart:grid%input_zend',grid%input_zstart,grid%input_zend + era_data%eravariables(:,:,:,:,hour_counter:temp_length+hour_counter-1) = era_data_temp%eravariables(:,:,:,grid%input_zstart:grid%input_zend,:)!,start_index:temp_file_length:timestep) + era_data%era_logp(:,:,hour_counter:temp_length+hour_counter-1) = era_data_temp%era_logp(:,:,:)!,start_index:temp_file_length:timestep) + + if(allocated(era_data_temp%era_sst_climo)) print *, 'before tisr loop temp climo allocated',year_i + + !if(reservoir%assigned_region == 954) print *, 'read parallel era_data%eravariables(4,2,2,:,1)', era_data%eravariables(4,2,2,:,1) + if(reservoir%tisr_input_bool) then + !tisr_file = file_path//'toa_incident_solar_radiation_'//year//'_regridded_mpi_fixed_var.nc' + !tisr_file = file_path//'toa_incident_solar_radiation_'//year//'_regridded_mpi.nc' + tisr_file = file_path//'toa_incident_solar_radiation_'//year//'_regridded_classic4.nc' + if(model_parameters%irank == 0) print *, tisr_file + call read_3d_file_parallel(tisr_file,'tisr',mpi_res,grid,era_data_temp%era_tisr,1,1) + era_data%era_tisr(:,:,hour_counter:temp_length+hour_counter-1) = era_data_temp%era_tisr(:,:,:)!,start_index:temp_file_length:timestep) + !print *, 'era_data%era_tisr(1,1,400:500) in speedy_res_inferface',era_data%era_tisr(1,1,400:500) + endif + if(allocated(era_data_temp%era_sst_climo)) print *, 'after era_tisr loop temp climo allocated',year_i + print *, 'reservoir%precip_bool',reservoir%precip_bool,reservoir%assigned_region + if(reservoir%precip_bool) then + precip_file = file_path//'era_5_y'//year//'_precip_regridded_mpi_fixed_var_gcc.nc' + if(model_parameters%irank == 0) print *, precip_file + call read_3d_file_parallel(precip_file,'tp',mpi_res,grid,era_data_temp%era_precip,1,1) + !print *, 'era_data_temp%era_precip(1,1,10:12)',era_data_temp%era_precip(1,1,10:12) + print *, 'hour_counter:temp_length+hour_counter-1',hour_counter,temp_length+hour_counter-1, shape(era_data%era_precip) + era_data%era_precip(:,:,hour_counter:temp_length+hour_counter-1) = era_data_temp%era_precip + endif + + !print *, 'reservoir%sst_bool',reservoir%sst_bool,reservoir%assigned_region + if(reservoir%sst_bool) then + sst_file = file_path//'era_5_y'//year//'_sst_regridded_fixed_var_gcc.nc' !'_sst_regridded_mpi_fixed_var_gcc.nc' + if(model_parameters%irank == 0) print *, sst_file + call read_3d_file_parallel(sst_file,'sst',mpi_res,grid,era_data_temp%era_sst,1,1) + era_data%era_sst(:,:,hour_counter:temp_length+hour_counter-1) = era_data_temp%era_sst + endif + + print *, 'reservoir%sst_climo_bool',reservoir%sst_climo_bool, reservoir%assigned_region + if(reservoir%sst_climo_bool) then + sst_climo_file = '/scratch/user/troyarcomano/ERA_5/regridded_era_sst_climatology1981_1999_gcc.nc' + if(year_i == start_year) then + if(model_parameters%irank == 0) print *, sst_climo_file + !call read_3d_file_parallel_res(sst_climo_file,'sst',mpi_res,grid,era_data_temp%era_sst_climo) + call read_3d_file_parallel(sst_climo_file,'sst',mpi_res,grid,era_data_temp%era_sst_climo,1,1) + endif + if(temp_length == 8784) then + era_data%era_sst_climo(:,:,hour_counter:hour_counter+1440 - 1) = era_data_temp%era_sst_climo(:,:,1:1440) + era_data%era_sst_climo(:,:,hour_counter+1441:hour_counter+1440+24) = era_data_temp%era_sst_climo(:,:,1441-24:1440) + era_data%era_sst_climo(:,:,hour_counter+1465:hour_counter+8784) = era_data_temp%era_sst_climo(:,:,1441:8760) + else + print *, 'shape(era_data%era_sst_climo(:,:,hour_counter:temp_length+hour_counter-1)) era_temp',shape(era_data%era_sst_climo(:,:,hour_counter:temp_length+hour_counter-1)),shape(era_data_temp%era_sst_climo) + if(allocated(era_data_temp%era_sst_climo)) print *, 'right before' + era_data%era_sst_climo(:,:,hour_counter:temp_length+hour_counter-1) = era_data_temp%era_sst_climo + endif + endif + + if(model_parameters%train_on_sst_anomalies .and. reservoir%sst_bool) then + if(temp_length == 8784) then + era_data%era_sst(:,:,hour_counter:hour_counter+1440 - 1) = era_data%era_sst(:,:,hour_counter:hour_counter+1440 - 1) - era_data%era_sst_climo(:,:,hour_counter:hour_counter+1440 - 1) + era_data%era_sst(:,:,hour_counter+1441:hour_counter+1440+24) = era_data%era_sst(:,:,hour_counter+1441:hour_counter+1440+24) - era_data%era_sst_climo(:,:,hour_counter+1441:hour_counter+1440+24) + era_data%era_sst(:,:,hour_counter+1465:hour_counter+8784) = era_data%era_sst(:,:,hour_counter+1465:hour_counter+8784) - era_data%era_sst_climo(:,:,hour_counter+1465:hour_counter+8784) + else + print *, 'shape,era_sst, era_sst_climo',shape(era_data%era_sst(:,:,hour_counter:temp_length+hour_counter-1)),shape(era_data%era_sst_climo(:,:,hour_counter:temp_length+hour_counter-1)) + era_data%era_sst(:,:,hour_counter:temp_length+hour_counter-1) = era_data%era_sst(:,:,hour_counter:temp_length+hour_counter-1) - era_data%era_sst_climo(:,:,hour_counter:temp_length+hour_counter-1) + endif + endif + + hour_counter = temp_length+hour_counter + + deallocate(era_data_temp%eravariables) + deallocate(era_data_temp%era_logp) + + if(allocated(era_data_temp%era_tisr)) then + deallocate(era_data_temp%era_tisr) + endif + + if(allocated(era_data_temp%era_sst)) then + deallocate(era_data_temp%era_sst) + endif + + if(allocated(era_data_temp%era_precip)) then + deallocate(era_data_temp%era_precip) + endif + + if(allocated(era_data_temp%era_sst_climo)) print *, 'bottom loop temp climo allocated',year_i + enddo + if(allocated(era_data_temp%era_sst_climo)) then + deallocate(era_data_temp%era_sst_climo) + endif + end subroutine + + subroutine read_model_states(reservoir,grid,model_parameters,start_year,end_year,speedy_data,timestep_arg) + use mpires, only : mpi_res + use mod_io, only : read_speedy_data_parallel, read_speedy_data_parallel_old + use mod_calendar, only : numof_hours + + type(reservoir_type), intent(inout) :: reservoir + type(grid_type), intent(inout) :: grid + type(model_parameters_type), intent(in) :: model_parameters + + integer, intent(in) :: start_year,end_year ! ,loop_index + + type(speedy_data_type), intent(inout) :: speedy_data + + integer, intent(in), optional :: timestep_arg + + integer :: year_i, month_i,start_month,end_month + integer :: numofhours, hour_counter, temp_length, temp_file_length + integer :: start_time, timestep + + type(speedy_data_type) :: speedy_data_temp + + character(len=3) :: file_end='.nc' + !character(len=9) :: file_begin = 'restart_y' + character(len=15) :: file_begin = 'restart_6hour_y' + !character(len=13) :: file_begin = 'restart_1hr_y' + !character(len=15) :: file_begin = 'restart_3hour_y' + !character(len=24) :: file_begin = 'restart_1hr_more_steps_y' + character(len=2) :: mid_file='_m' + character(len=1) :: month_1 + character(len=2) :: month_2 + character(len=4) :: year + character(len=:), allocatable :: file_path + character(len=:), allocatable :: restart_file_name + character(len=:), allocatable :: format_month + character(len=:), allocatable :: month + + !-----------Troy stuff ---------------! + + if(present(timestep_arg)) then + timestep = timestep_arg + else + timestep = model_parameters%timestep + endif + + start_month = 1 + end_month = 12 + + call numof_hours(start_year,end_year,numofhours) + + !numofhours = numofhours/res%timestep + + allocate(speedy_data%speedyvariables(numofspeedyvars,grid%resxchunk,grid%resychunk,grid%reszchunk,numofhours)) + allocate(speedy_data%speedy_logp(grid%resxchunk,grid%resychunk,numofhours)) + + hour_counter = 1 + + print *, 'herhe' + !start_time = loop_index + do year_i=start_year,end_year + write(year,'(I4)') year_i + + file_path = '/scratch/user/troyarcomano/SPEEDY_STATES/' + !restart_file_name = file_path//file_begin//year//'_fixed_var'//file_end + !restart_file_name = file_path//file_begin//year//'_chunked_time'//file_end + !restart_file_name = file_path//file_begin//year//'_new'//file_end + !restart_file_name = file_path//file_begin//year//'_gcc'//file_end + restart_file_name = file_path//file_begin//year//file_end + + if(model_parameters%irank == 0) print *, 'restart_file_name',restart_file_name + print *, 'restart_file_name',restart_file_name + call read_speedy_data_parallel(restart_file_name,mpi_res,grid,speedy_data_temp,1,1) + !call read_speedy_data_parallel_old(restart_file_name,mpi_res,grid,speedy_data_temp) + + temp_length = size(speedy_data_temp%speedyvariables,5)!/timestep + temp_file_length = temp_length !* timestep + + + speedy_data%speedyvariables(:,:,:,:,hour_counter:temp_length+hour_counter-1) = speedy_data_temp%speedyvariables(:,:,:,grid%res_zstart:grid%res_zend,:)!start_time:temp_file_length:timestep) + speedy_data%speedy_logp(:,:,hour_counter:temp_length+hour_counter-1) = speedy_data_temp%speedy_logp(:,:,:)!start_time:temp_file_length:timestep) + + hour_counter = temp_length+hour_counter + + deallocate(speedy_data_temp%speedyvariables) + deallocate(speedy_data_temp%speedy_logp) + + enddo + end subroutine + + subroutine test_hybrid_speedy_component() + use speedy_main + use mod_io, only : write_netcdf_speedy_full, read_netcdf_4d, read_netcdf_3d + use mpires, only : clean_up_speedy + use mod_calendar, only : get_current_time_delta_hour + + integer :: timestep + + !local stuff + real(kind=dp), allocatable :: temp4d(:,:,:,:) + real(kind=dp), allocatable :: temp3d(:,:,:) + + integer :: num_of_vars, size_x, size_y, size_z, num_of_standardized_vars + integer :: i + + character(len=:), allocatable :: era_file + + era_file = '/scratch/user/troyarcomano/ERA_5/1990/era_5_m11_y1990_regridded_spectral_mpi.nc' + + print *, 'here' + + if(.not. allocated(internal_state_vector%variables3d)) then + num_of_vars = 4 + size_x = 96 + size_y = 48 + size_z = 8 + + allocate(internal_state_vector%variables3d(num_of_vars,size_x,size_y,size_z)) + endif + if(.not. allocated(internal_state_vector%logp)) then + size_x = 96 + size_y = 48 + allocate(internal_state_vector%logp(size_x,size_y)) + endif + + call read_netcdf_4d('Temperature',era_file,temp4d) + internal_state_vector%variables3d(1,:,:,:) = temp4d(:,:,:,1) + deallocate(temp4d) + + call read_netcdf_4d('U-wind',era_file,temp4d) + internal_state_vector%variables3d(2,:,:,:) = temp4d(:,:,:,1) + deallocate(temp4d) + + call read_netcdf_4d('V-wind',era_file,temp4d) + internal_state_vector%variables3d(3,:,:,:) = temp4d(:,:,:,1) + deallocate(temp4d) + + call read_netcdf_4d('Specific_Humidity',era_file,temp4d) + internal_state_vector%variables3d(4,:,:,:) = temp4d(:,:,:,1)*1000.0_dp + deallocate(temp4d) + + call read_netcdf_3d('logp',era_file,temp3d) + internal_state_vector%logp = temp3d(:,:,1) + deallocate(temp3d) + + do i=1, 500 + call get_current_time_delta_hour(calendar,86184+i) + + + where(internal_state_vector%variables3d(4,:,:,:) < 0.0) + internal_state_vector%variables3d(4,:,:,:) = 0.0 + endwhere + + where(internal_state_vector%variables3d(4,:,:,:) > 25.0) + internal_state_vector%variables3d(4,:,:,:) = 25.0 + endwhere + + internal_state_vector%is_safe_to_run_speedy = .True. + + internal_state_vector%era_hour = 1 !era hour of the month 1 = 00UTC of the first day of + internal_state_vector%era_hour_plus_one = 2!So I dont have to do calendar stuff in + + internal_state_vector%istart = 2 + internal_state_vector%era_start = 3 + + internal_state_vector%iyear0 = calendar%currentyear + internal_state_vector%imont0 = calendar%currentmonth + internal_state_vector%iday = calendar%currentday + internal_state_vector%ihour = calendar%currenthour + + call agcm_main(1,1,internal_state_vector) + + call clean_up_speedy() + + print *, 'after speedy specific humidity',minval(internal_state_vector%variables3d(4,:,:,:)),maxval(internal_state_vector%variables3d(4,:,:,:)) + call write_netcdf_speedy_full(internal_state_vector%variables3d,internal_state_vector%logp,i,'hybrid_speedy_out.nc') + + where(internal_state_vector%variables3d(4,:,:,:) < 0.0) + internal_state_vector%variables3d(4,:,:,:) = 0.0_dp + endwhere + + enddo + end subroutine + + + function truncate_letkf_code_version(field_orig, trunc_twn) result(field_new) + complex, intent(in) :: field_orig(:,:) + integer, intent(in) :: trunc_twn + complex, allocatable :: field_new(:,:) + + integer :: mx_lr, nx_lr, m, n + + allocate(field_new,mold=field_orig) + mx_lr = size(field_orig,1) + nx_lr = size(field_orig,2) + + do m = 1,mx_lr + do n = 1,nx_lr + field_new(m,n) = field_orig(m,n) + + if (m+n-2 > trunc_twn) then + field_new(m,n) = (0.0,0.0) + end if + end do + end do + end function +end module speedy_res_interface diff --git a/src/stringtype.f90 b/src/stringtype.f90 new file mode 100755 index 0000000..b0b3f29 --- /dev/null +++ b/src/stringtype.f90 @@ -0,0 +1,9 @@ +module stringtype + + type string + + character(len=:), allocatable :: str + + end type string + +end module stringtype diff --git a/tests/mod_unit_test.f90 b/tests/mod_unit_test.f90 new file mode 100755 index 0000000..5f71a98 --- /dev/null +++ b/tests/mod_unit_test.f90 @@ -0,0 +1,130 @@ +module mod_unit_tests + !We need something to test varies stuff + + use mod_utilities, only : dp + + contains + !------------Linear Algebra Tests-------------! + subroutine test_linalg() + !Main routine to test various linear algebra functions + logical :: passer + + call test_pinv(passer) + + end subroutine + + subroutine test_pinv(passer) + !Just tests pinv + use mod_linalg, only : pinv_svd + + real(kind=dp) :: A(10,10) + real(kind=dp) :: Ainv(10,10) + real(kind=dp) :: realinv(10,10) + real(kind=dp) :: threshold = 1e-10 + + integer :: i + + logical, intent(out) :: passer + + passer = .false. + + A = 0 + Ainv = 0 + realinv = 0 + + do i=1, 10 + A(i,i) = i + realinv(i,i) = 1_dp/i + enddo + + call pinv_svd(A,n,n,Ainv) + + if(sum(Ainv-realinv) < threshold) then + passer = .true. + endif + + return + end subroutine + + !-----------End of Linear Algebra Tests ----! + + + + !---------Grid and Tiling Tests ------------! + + subroutine test_res_domain() + !Main routine to test various + logical :: passer + + call test_getxyresextent(passer) + + end subroutine + + subroutine test_getxyresextent(passer) + integer :: numprocs,proc_num + integer :: localres_xstart,localres_xend,localres_ystart,localres_yend + integer :: localxchunk,localychunk + + integer :: truth_xstart, truth_xend, truth_ystart, truth_yend + integer :: truth_xchunk, truth_ychunk + + logical :: passer + + passer = .false. + + truth_xchunk = 4 + truth_ychunk = 4 + + truth_xstart = 49 + truth_xend = 52 + + truth_ystart = 9 + truth_yend = 12 + + numprocs = 288 + proc_num = 145 + + call getxyresextent(numprocs,proc_num,localres_xstart,localres_xend,localres_ystart,localres_yend,localxchunk,localychunk) + + if((truth_xchunk==localxchunk).and.(truth_ychunk==localychunk).and.(truth_xstart==localres_xstart).and.(truth_xend==localres_xend).and.(truth_ystart==localres_ystart).and.(truth_yend==localres_yend)) then + passer = .true. + else + print *, truth_xchunk,localxchunk,truth_ychunk,localychunk,truth_xstart,localres_xstart,truth_xend,localres_xend,truth_ystart,localres_ystart,truth_yend,localres_yend + endif + + return + end subroutine + + !---------End Grid and Tiling Tests ------------! + + !---------MPI Tests ------------! + + subroutine test_mpi(dat) + !Main routine to test mpi stuff + !A higher level test needs real data to work as well + !as the things like mpi_type, grid type, and res type + !Call this routine after type initialization and reading in the data + + !Input dat which is a single time step of speedy full grid + + real(kind=dp), intent(in) :: dat(:,:,:,:,:) + + logical :: passer + end subroutine + + subroutine test_predictionmpicontroller(dat,passer) + use mod_reservoir, only : res + + real(kind=dp), intent(in) :: dat(:,:,:,:,:) + real(kind=dp), allocatable :: outvec(:,:), feedbackvec(:,:) + + integer :: timestep + + logical, intent(out) :: passer + + timestep = 1 + + call predictionmpicontroller(res,timestep,outvec,feedbackvec) + + end subroutine +end module diff --git a/tests/test_at_main.f90 b/tests/test_at_main.f90 new file mode 100755 index 0000000..d9f1ef9 --- /dev/null +++ b/tests/test_at_main.f90 @@ -0,0 +1,66 @@ +program main + use mod_calendar + use mod_utilities, only : dp, state_vector_type + use speedy_res_interface, only : read_era, era_data + use mpires, only : startmpi, mpi_res, internal_state_vector + use resdomain, only : initializedomain + implicit none + integer :: i + !type(state_vector_type) :: internal_state_vector + + call startmpi() + + call initialize_calendar(calendar,1981,1,1,0) + + call initializedomain(mpi_res%numprocs,mpi_res%proc_num,0) + + call get_current_time_delta_hour(calendar,51000) + call read_era(calendar%currentyear,calendar%currentyear) + + print *, shape(era_data%era_logp) + !print *, 'logp',era_data%era_logp(:,:,3) + where (era_data%eravariables(4,:,:,:,:) < 0.0) + era_data%eravariables(4,:,:,:,:) = 0.0_dp + end where + era_data%eravariables(4,:,:,:,:) = era_data%eravariables(4,:,:,:,:)*1000.0_dp + do i=1, 100 + call get_current_time_delta_hour(calendar,26305+i)!+i) + + print *, calendar + + if(i == 1) then + internal_state_vector%variables3d = era_data%eravariables(:,:,:,:,3) + internal_state_vector%logp = era_data%era_logp(:,:,3) + print *,'logp',minval(internal_state_vector%logp),maxval(internal_state_vector%logp) + endif + + print *,'before speedy', minval(internal_state_vector%variables3d(4,:,:,:)), maxval(internal_state_vector%variables3d(4,:,:,:)) + + internal_state_vector%era_hour = 1 !era hour of the month 1 = 00UTC of the first day of + internal_state_vector%era_hour_plus_one = 2!So I dont have to do calendar stuff in + + internal_state_vector%istart = 2 + internal_state_vector%era_start = 3 + + internal_state_vector%iyear0 = calendar%currentyear + internal_state_vector%imont0 = calendar%currentmonth + internal_state_vector%iday = calendar%currentday + internal_state_vector%ihour = calendar%currenthour + + call agcm_main(1,1,internal_state_vector) + print *, 'after speedy',minval(internal_state_vector%variables3d(4,:,:,:)), maxval(internal_state_vector%variables3d(4,:,:,:)) + + rewind(21) + rewind(22) + rewind(23) + rewind(24) + rewind(26) + rewind(30) + rewind(2) + rewind(10) + rewind(11) + rewind(13) + rewind(15) + enddo +end program main + diff --git a/tests/test_calendar.f90 b/tests/test_calendar.f90 new file mode 100644 index 0000000..8c22e5e --- /dev/null +++ b/tests/test_calendar.f90 @@ -0,0 +1,37 @@ +program main + + use mod_calendar + + implicit none + + integer :: discardlength, synclength, traininglength, prediction_length, prediction_num, cycle_length, timestep, i, num_predictions, j + + integer, allocatable :: prediction_markers(:) + + discardlength = 150 + synclength = 24*4 + traininglength = 188280 + prediction_length = 504 + timestep = 6 + num_predictions = 100 + + call initialize_calendar(calendar,1990,1,1,0) + call get_current_time_delta_hour(calendar,discardlength+traininglength+synclength) + + cycle_length = synclength + + allocate(prediction_markers(num_predictions)) + + do i=0,num_predictions-1 + prediction_markers(i+1) = cycle_length*i + enddo + + print *, 'prediction_markers',prediction_markers + + do i=1,num_predictions + do j=1, prediction_length + call get_current_time_delta_hour(calendar,traininglength+synclength+prediction_markers(i)) + print *,'prediction file date',calendar%currentmonth,calendar%currentday,calendar%currentyear,calendar%currenthour + enddo + enddo +end program main diff --git a/tests/test_dgemm_transpose.f90 b/tests/test_dgemm_transpose.f90 new file mode 100755 index 0000000..f8e22f0 --- /dev/null +++ b/tests/test_dgemm_transpose.f90 @@ -0,0 +1,20 @@ +program main + use mod_utilities, only : dp + use blas95 + implicit none + + real(kind=dp), allocatable :: states(:,:) + real(kind=dp), allocatable :: temp(:,:) + + real(kind=dp), parameter :: beta=0.0_dp, alpha = 1.0_dp + + integer :: n,m + + n = 7000+136 + m = n + allocate(states(n,m)) + allocate(temp(n,m)) + call random_number(states) + call DGEMM('N','T',n,n,m,alpha,states,n,states,m,beta,temp,n) + +end program main diff --git a/tests/test_pinv.f90 b/tests/test_pinv.f90 new file mode 100755 index 0000000..947c423 --- /dev/null +++ b/tests/test_pinv.f90 @@ -0,0 +1,32 @@ +program main + use mod_linalg + use mod_utilities, only : dp + + implicit none + + real(kind=dp), allocatable :: a(:,:), b(:,:), a_trans(:,:), b_trans(:,:) + + real(kind=dp), allocatable :: invstates(:,:) + integer :: n,m,workernuminputs + + n=5000 + m=5000 + + workernuminputs = 640 + + allocate(a(n+workernuminputs,m+workernuminputs)) + allocate(b(400,n+workernuminputs)) + + allocate(a_trans(n+workernuminputs,m+workernuminputs)) + allocate(b_trans(n+workernuminputs,400)) + call random_number(a) + call random_number(b) + + a_trans = transpose(a) + b_trans = transpose(b) + + call mldivide(a_trans,b_trans) + !call pinv_svd(a,n+workernuminputs,n+workernuminputs,invstates) + print *, shape(b_trans), shape(transpose(b_trans)) + !print *, invstates(300:310,800:810) +end program