From 151b9af69cccee792197ebdb5f497bab51bf5ce4 Mon Sep 17 00:00:00 2001 From: Elizabeth Hunke Date: Mon, 28 Apr 2008 21:59:36 +0000 Subject: [PATCH] --- cice/bld/Macros.Linux.LANL.coyote | 8 +- cice/drivers/ccsm_concurrent/ice_step_mod.F90 | 47 +- cice/drivers/ccsm_sequential/ice_step_mod.F90 | 47 +- cice/drivers/cice4/CICE_RunMod.F90 | 420 +++- cice/drivers/hadgem3/CICE.F90 | 244 +++ cice/drivers/hadgem3/CICE_ComponentMod.F90 | 146 ++ cice/drivers/hadgem3/CICE_FinalMod.F90 | 131 ++ cice/drivers/hadgem3/CICE_InitMod.F90 | 255 +++ cice/drivers/hadgem3/CICE_RunMod.F90 | 1685 +++++++++++++++++ cice/input_templates/gx1/ice_in | 29 +- cice/input_templates/gx3/ice_in | 25 +- cice/mpi/ice_communicate.F90 | 26 +- cice/source/ice_constants.F90 | 27 +- cice/source/ice_diagnostics.F90 | 173 +- cice/source/ice_domain.F90 | 6 +- cice/source/ice_dyn_evp.F90 | 40 +- cice/source/ice_flux.F90 | 174 +- cice/source/ice_forcing.F90 | 788 +++++++- cice/source/ice_grid.F90 | 376 +++- cice/source/ice_history.F90 | 607 ++++-- cice/source/ice_init.F90 | 217 ++- cice/source/ice_itd.F90 | 222 ++- cice/source/ice_read_write.F90 | 44 +- cice/source/ice_restart.F90 | 5 +- cice/source/ice_shortwave.F90 | 58 +- cice/source/ice_therm_itd.F90 | 48 +- cice/source/ice_therm_vertical.F90 | 1253 +++++++++--- cice/source/ice_work.F90 | 3 +- 28 files changed, 6372 insertions(+), 732 deletions(-) create mode 100644 cice/drivers/hadgem3/CICE.F90 create mode 100644 cice/drivers/hadgem3/CICE_ComponentMod.F90 create mode 100644 cice/drivers/hadgem3/CICE_FinalMod.F90 create mode 100644 cice/drivers/hadgem3/CICE_InitMod.F90 create mode 100644 cice/drivers/hadgem3/CICE_RunMod.F90 diff --git a/cice/bld/Macros.Linux.LANL.coyote b/cice/bld/Macros.Linux.LANL.coyote index 0e78267..72005a9 100755 --- a/cice/bld/Macros.Linux.LANL.coyote +++ b/cice/bld/Macros.Linux.LANL.coyote @@ -31,10 +31,10 @@ endif ifeq ($(NETCDF), yes) CPPDEFS := $(CPPDEFS) -Dncdf -# INCLDIR := $(INCLDIR) -I/usr/projects/climate/maltrud/local/include -# SLIBS := $(SLIBS) -L/usr/projects/climate/maltrud/local/lib -lnetcdf - INCLDIR := $(INCLDIR) -I/scratch2/bzhao/netcdf-3.6.1/include - SLIBS := $(SLIBS) -L/scratch2/bzhao/netcdf-3.6.1/lib -lnetcdf +# INCLDIR := $(INCLDIR) -I/usr/projects/climate/maltrud/local/include_coyote +# SLIBS := $(SLIBS) -L/usr/projects/climate/maltrud/local/lib_coyote -lnetcdf + INCLDIR := $(INCLDIR) -I/usr/projects/climate/bzhao/netcdf-3.6.1/include + SLIBS := $(SLIBS) -L/usr/projects/climate/bzhao/netcdf-3.6.1/lib -lnetcdf endif ifeq ($(USE_ESMF), yes) diff --git a/cice/drivers/ccsm_concurrent/ice_step_mod.F90 b/cice/drivers/ccsm_concurrent/ice_step_mod.F90 index 126b562..5e83bd7 100644 --- a/cice/drivers/ccsm_concurrent/ice_step_mod.F90 +++ b/cice/drivers/ccsm_concurrent/ice_step_mod.F90 @@ -118,7 +118,6 @@ subroutine step_therm1 (dt) real (kind=dbl_kind), dimension (nx_block,ny_block) :: & fsensn , & ! surface downward sensible heat (W/m^2) - flatn , & ! surface downward latent heat (W/m^2) fswabsn , & ! shortwave absorbed by ice (W/m^2) flwoutn , & ! upward LW at surface (W/m^2) evapn , & ! flux of vapor, atmos to ice (kg m-2 s-1) @@ -309,7 +308,8 @@ subroutine step_therm1 (dt) fswthrun(:,:,n,iblk), & Sswabsn(:,:,sl1:sl2,iblk), & Iswabsn(:,:,il1:il2,iblk), & - fsensn, flatn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & fswabsn, flwoutn, & evapn, freshn, & fsaltn, fhocnn, & @@ -365,7 +365,8 @@ subroutine step_therm1 (dt) alvdrn(:,:,n,iblk), alidrn(:,:,n,iblk), & alvdfn(:,:,n,iblk), alidfn(:,:,n,iblk), & strairxn, strairyn, & - fsensn, flatn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & fswabsn, flwoutn, & evapn, & Trefn, Qrefn, & @@ -374,6 +375,7 @@ subroutine step_therm1 (dt) alvdr (:,:,iblk), alidr (:,:,iblk), & alvdf (:,:,iblk), alidf (:,:,iblk), & strairxT(:,:,iblk), strairyT (:,:,iblk), & + fsurf (:,:,iblk), fcondtop (:,:,iblk), & fsens (:,:,iblk), flat (:,:,iblk), & fswabs (:,:,iblk), flwout (:,:,iblk), & evap (:,:,iblk), & @@ -599,18 +601,22 @@ subroutine step_therm2 (dt) call add_new_ice (nx_block, ny_block, & icells, & indxi, indxj, & - tmask (:,:, iblk), dt, & - aicen (:,:,:,iblk), & - trcrn (:,:,:,:,iblk), & - vicen (:,:,:,iblk), & - eicen (:,:,:,iblk), & - aice0 (:,:, iblk), & - aice (:,:, iblk), & - frzmlt (:,:, iblk), & - frazil (:,:, iblk), & - frz_onset(:,:, iblk), yday, & - Tf (:,:, iblk), l_stop, & - istop, jstop) + tmask (:,:, iblk), dt, & + aicen (:,:,:,iblk), & + trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), & + eicen (:,:,:,iblk), & + aice0 (:,:, iblk), & + aice (:,:, iblk), & + frzmlt (:,:, iblk), & + frazil (:,:, iblk), & + frz_onset (:,:, iblk), yday, & + fresh (:,:, iblk), & + fresh_hist(:,:, iblk), & + fsalt (:,:, iblk), & + fsalt_hist(:,:, iblk), & + Tf (:,:, iblk), l_stop, & + istop , jstop) if (l_stop) then write (nu_diag,*) 'istep1, my_task, iblk =', & @@ -676,7 +682,7 @@ subroutine step_therm2 (dt) fresh (:,:, iblk), fresh_hist(:,:,iblk), & fsalt (:,:, iblk), fsalt_hist(:,:,iblk), & fhocn (:,:, iblk), fhocn_hist(:,:,iblk), & - l_stop, & + heat_capacity, l_stop, & istop, jstop) if (l_stop) then @@ -1379,6 +1385,15 @@ subroutine step_rad2 (dt) enddo ! iblk + !---------------------------------------------------------------- + ! Store grid box mean fluxes before scaled by aice_init + !---------------------------------------------------------------- + + fresh_hist_gbm (:,:,:) = fresh_hist (:,:,:) + fsalt_hist_gbm (:,:,:) = fsalt_hist (:,:,:) + fhocn_hist_gbm (:,:,:) = fhocn_hist (:,:,:) + fswthru_hist_gbm(:,:,:) = fswthru_hist(:,:,:) + call scale_hist_fluxes ! to match coupler fluxes end subroutine step_rad2 diff --git a/cice/drivers/ccsm_sequential/ice_step_mod.F90 b/cice/drivers/ccsm_sequential/ice_step_mod.F90 index 126b562..5e83bd7 100644 --- a/cice/drivers/ccsm_sequential/ice_step_mod.F90 +++ b/cice/drivers/ccsm_sequential/ice_step_mod.F90 @@ -118,7 +118,6 @@ subroutine step_therm1 (dt) real (kind=dbl_kind), dimension (nx_block,ny_block) :: & fsensn , & ! surface downward sensible heat (W/m^2) - flatn , & ! surface downward latent heat (W/m^2) fswabsn , & ! shortwave absorbed by ice (W/m^2) flwoutn , & ! upward LW at surface (W/m^2) evapn , & ! flux of vapor, atmos to ice (kg m-2 s-1) @@ -309,7 +308,8 @@ subroutine step_therm1 (dt) fswthrun(:,:,n,iblk), & Sswabsn(:,:,sl1:sl2,iblk), & Iswabsn(:,:,il1:il2,iblk), & - fsensn, flatn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & fswabsn, flwoutn, & evapn, freshn, & fsaltn, fhocnn, & @@ -365,7 +365,8 @@ subroutine step_therm1 (dt) alvdrn(:,:,n,iblk), alidrn(:,:,n,iblk), & alvdfn(:,:,n,iblk), alidfn(:,:,n,iblk), & strairxn, strairyn, & - fsensn, flatn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & fswabsn, flwoutn, & evapn, & Trefn, Qrefn, & @@ -374,6 +375,7 @@ subroutine step_therm1 (dt) alvdr (:,:,iblk), alidr (:,:,iblk), & alvdf (:,:,iblk), alidf (:,:,iblk), & strairxT(:,:,iblk), strairyT (:,:,iblk), & + fsurf (:,:,iblk), fcondtop (:,:,iblk), & fsens (:,:,iblk), flat (:,:,iblk), & fswabs (:,:,iblk), flwout (:,:,iblk), & evap (:,:,iblk), & @@ -599,18 +601,22 @@ subroutine step_therm2 (dt) call add_new_ice (nx_block, ny_block, & icells, & indxi, indxj, & - tmask (:,:, iblk), dt, & - aicen (:,:,:,iblk), & - trcrn (:,:,:,:,iblk), & - vicen (:,:,:,iblk), & - eicen (:,:,:,iblk), & - aice0 (:,:, iblk), & - aice (:,:, iblk), & - frzmlt (:,:, iblk), & - frazil (:,:, iblk), & - frz_onset(:,:, iblk), yday, & - Tf (:,:, iblk), l_stop, & - istop, jstop) + tmask (:,:, iblk), dt, & + aicen (:,:,:,iblk), & + trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), & + eicen (:,:,:,iblk), & + aice0 (:,:, iblk), & + aice (:,:, iblk), & + frzmlt (:,:, iblk), & + frazil (:,:, iblk), & + frz_onset (:,:, iblk), yday, & + fresh (:,:, iblk), & + fresh_hist(:,:, iblk), & + fsalt (:,:, iblk), & + fsalt_hist(:,:, iblk), & + Tf (:,:, iblk), l_stop, & + istop , jstop) if (l_stop) then write (nu_diag,*) 'istep1, my_task, iblk =', & @@ -676,7 +682,7 @@ subroutine step_therm2 (dt) fresh (:,:, iblk), fresh_hist(:,:,iblk), & fsalt (:,:, iblk), fsalt_hist(:,:,iblk), & fhocn (:,:, iblk), fhocn_hist(:,:,iblk), & - l_stop, & + heat_capacity, l_stop, & istop, jstop) if (l_stop) then @@ -1379,6 +1385,15 @@ subroutine step_rad2 (dt) enddo ! iblk + !---------------------------------------------------------------- + ! Store grid box mean fluxes before scaled by aice_init + !---------------------------------------------------------------- + + fresh_hist_gbm (:,:,:) = fresh_hist (:,:,:) + fsalt_hist_gbm (:,:,:) = fsalt_hist (:,:,:) + fhocn_hist_gbm (:,:,:) = fhocn_hist (:,:,:) + fswthru_hist_gbm(:,:,:) = fswthru_hist(:,:,:) + call scale_hist_fluxes ! to match coupler fluxes end subroutine step_rad2 diff --git a/cice/drivers/cice4/CICE_RunMod.F90 b/cice/drivers/cice4/CICE_RunMod.F90 index 6ee7f11..837041f 100644 --- a/cice/drivers/cice4/CICE_RunMod.F90 +++ b/cice/drivers/cice4/CICE_RunMod.F90 @@ -359,7 +359,6 @@ subroutine step_therm1 (dt) real (kind=dbl_kind), dimension (nx_block,ny_block) :: & fsensn , & ! surface downward sensible heat (W/m^2) - flatn , & ! surface downward latent heat (W/m^2) fswabsn , & ! shortwave absorbed by ice (W/m^2) flwoutn , & ! upward LW at surface (W/m^2) evapn , & ! flux of vapor, atmos to ice (kg m-2 s-1) @@ -638,12 +637,12 @@ subroutine step_therm1 (dt) ! Melting does not alter the ice age. !----------------------------------------------------------------- - if (tr_iage) then - call increment_age (nx_block, ny_block, & - dt, icells, & - indxi, indxj, & - trcrn(:,:,nt_iage,n,iblk)) - endif + if (tr_iage) then + call increment_age (nx_block, ny_block, & + dt, icells, & + indxi, indxj, & + trcrn(:,:,nt_iage,n,iblk)) + endif !----------------------------------------------------------------- ! Vertical thermodynamics: Heat conduction, growth and melting. @@ -657,6 +656,31 @@ subroutine step_therm1 (dt) melts_old = melts(:,:,iblk) meltt_old = meltt(:,:,iblk) +!lipscomb - Temporary subroutine to compute fsurfn and fcondtopn. +! Used for testing the option calc_Tsfc = F + + if (.not. calc_Tsfc) then + + call explicit_calc_Tsfc (nx_block, ny_block, & + my_task, icells, & + indxi, indxj, & + trcrn(:,:,nt_Tsfc,n,iblk), & + aicen(:,:,n,iblk), & + vicen(:,:,n,iblk), & + vsnon(:,:,n,iblk), & + eicen (:,:,il1:il2,iblk), & + esnon (:,:,sl1:sl2,iblk), & + rhoa(:,:,iblk), flw(:,:,iblk),& + potT(:,:,iblk), Qa (:,:,iblk),& + shcoef, lhcoef, & + fswsfcn, flwoutn, & + fsensn, & + flatn(:,:,n,iblk), & + fsurfn(:,:,n,iblk), & + fcondtopn(:,:,n,iblk)) + + endif + call thermo_vertical & (nx_block, ny_block, & dt, icells, & @@ -674,7 +698,8 @@ subroutine step_therm1 (dt) fswsfcn, fswintn, & fswthrun, & Sswabsn, Iswabsn, & - fsensn, flatn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & fswabsn, flwoutn, & evapn, freshn, & fsaltn, fhocnn, & @@ -729,7 +754,8 @@ subroutine step_therm1 (dt) alvdrn(:,:,n,iblk), alidrn(:,:,n,iblk), & alvdfn(:,:,n,iblk), alidfn(:,:,n,iblk), & strairxn, strairyn, & - fsensn, flatn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & fswabsn, flwoutn, & evapn, & Trefn, Qrefn, & @@ -738,6 +764,7 @@ subroutine step_therm1 (dt) alvdr (:,:,iblk), alidr (:,:,iblk), & alvdf (:,:,iblk), alidf (:,:,iblk), & strairxT(:,:,iblk), strairyT (:,:,iblk), & + fsurf (:,:,iblk), fcondtop (:,:,iblk), & fsens (:,:,iblk), flat (:,:,iblk), & fswabs (:,:,iblk), flwout (:,:,iblk), & evap (:,:,iblk), & @@ -957,18 +984,22 @@ subroutine step_therm2 (dt) call add_new_ice (nx_block, ny_block, & icells, & indxi, indxj, & - tmask (:,:, iblk), dt, & - aicen (:,:,:,iblk), & - trcrn (:,:,:,:,iblk), & - vicen (:,:,:,iblk), & - eicen (:,:,:,iblk), & - aice0 (:,:, iblk), & - aice (:,:, iblk), & - frzmlt (:,:, iblk), & - frazil (:,:, iblk), & - frz_onset(:,:, iblk), yday, & - Tf (:,:, iblk), l_stop, & - istop, jstop) + tmask (:,:, iblk), dt, & + aicen (:,:,:,iblk), & + trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), & + eicen (:,:,:,iblk), & + aice0 (:,:, iblk), & + aice (:,:, iblk), & + frzmlt (:,:, iblk), & + frazil (:,:, iblk), & + frz_onset (:,:, iblk), yday, & + fresh (:,:, iblk), & + fresh_hist(:,:, iblk), & + fsalt (:,:, iblk), & + fsalt_hist(:,:, iblk), & + Tf (:,:, iblk), l_stop, & + istop , jstop) if (l_stop) then write (nu_diag,*) 'istep1, my_task, iblk =', & @@ -1034,7 +1065,7 @@ subroutine step_therm2 (dt) fresh (:,:, iblk), fresh_hist(:,:,iblk), & fsalt (:,:, iblk), fsalt_hist(:,:,iblk), & fhocn (:,:, iblk), fhocn_hist(:,:,iblk), & - l_stop, & + heat_capacity, l_stop, & istop, jstop) if (l_stop) then @@ -1253,7 +1284,7 @@ subroutine step_dynamics (dt) fresh (:,:, iblk), fresh_hist(:,:,iblk), & fsalt (:,:, iblk), fsalt_hist(:,:,iblk), & fhocn (:,:, iblk), fhocn_hist(:,:,iblk), & - l_stop, & + heat_capacity, l_stop, & istop, jstop) if (l_stop) then @@ -1297,10 +1328,353 @@ subroutine step_dynamics (dt) call ice_timer_stop(timer_column) + !---------------------------------------------------------------- + ! Store grid box mean fluxes before scaled by aice_init + !---------------------------------------------------------------- + + fresh_hist_gbm (:,:,:) = fresh_hist (:,:,:) + fsalt_hist_gbm (:,:,:) = fsalt_hist (:,:,:) + fhocn_hist_gbm (:,:,:) = fhocn_hist (:,:,:) + fswthru_hist_gbm(:,:,:) = fswthru_hist(:,:,:) + call scale_hist_fluxes ! to match coupler fluxes end subroutine step_dynamics +!======================================================================= +!BOP +! +! !ROUTINE: explicit_calc_Tsfc - temporary subroutine to compute sfc fluxes +! +! !DESCRIPTION: +! +! Compute fsurfn and fcondtopn, given temperature, thickness, and +! conductivity of top ice or snow layer. +! +! !REVISION HISTORY: +! +! authors William H. Lipscomb, LANL +! +! !INTERFACE: +! + subroutine explicit_calc_Tsfc (nx_block, ny_block, & + my_task, icells, & + indxi, indxj, & + Tsfcn, aicen, & + vicen, vsnon, & + eicen, esnon, & + rhoa, flw, & + potT, Qa, & + shcoef, lhcoef, & + fswsfcn, flwoutn, & + fsensn, flatn, & + fsurfn, fcondtopn) +! +! !USES: +! + use ice_therm_vertical, only: hs_min, betak, kimin +! +! !INPUT/OUTPUT PARAMETERS: +! + integer (kind=int_kind), intent(in) :: & + nx_block, ny_block, & ! block dimensions + my_task , & ! process ID + icells ! number of cells with ice present + + integer (kind=int_kind), dimension(icells), intent(in) :: & + indxi, indxj ! compressed indices for ice cells + + real (kind=dbl_kind), dimension (nx_block,ny_block), & + intent(inout) :: & + Tsfcn ! temperature of ice/snow top surface (C) + + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & + aicen , & ! concentration of ice + vicen , & ! volume per unit area of ice (m) + vsnon ! volume per unit area of snow (m) + + real (kind=dbl_kind), dimension(nx_block,ny_block,nilyr), & + intent(in) :: & + eicen ! energy of melting for each ice layer (J/m^2) + + real (kind=dbl_kind), dimension(nx_block,ny_block,nslyr), & + intent(in) :: & + esnon ! energy of melting for each snow layer (J/m^2) + + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & + fswsfcn , & ! SW absorbed at ice/snow surface (W m-2) + rhoa , & ! air density (kg/m^3) + flw , & ! incoming longwave radiation (W/m^2) + potT , & ! air potential temperature (K) + Qa , & ! specific humidity (kg/kg) + shcoef , & ! transfer coefficient for sensible heat + lhcoef ! transfer coefficient for latent heat + + real (kind=dbl_kind), dimension (nx_block,ny_block), & + intent(out) :: & + flwoutn , & ! upward LW at surface (W m-2) + fsensn , & ! surface downward sensible heat (W m-2) + flatn , & ! surface downward latent heat (W m-2) + fsurfn , & ! net flux to top surface, excluding fcondtopn + fcondtopn ! conductive flux to top surface +! +!EOP +! + integer (kind=int_kind) :: & + isolve ! number of cells with temps not converged (same as icells) + + integer (kind=int_kind), dimension(icells) :: & + indxii, indxjj,& ! compressed indices for cells not converged + indxij ! compressed 1D index for cells not converged + + real (kind=dbl_kind), dimension (icells) :: & + Tsf , & ! surface temperature + khis , & ! 2*k/h for top ice or snow layer + Tis ! temperature of top ice or snow layer + + real (kind=dbl_kind), dimension (icells) :: & + dfsens_dT , & ! deriv of fsens wrt Tsf (W m-2 deg-1) + dflat_dT , & ! deriv of flat wrt Tsf (W m-2 deg-1) + dflwout_dT , & ! deriv of flwout wrt Tsf (W m-2 deg-1) + dfsurf_dT ! derivative of fsurf wrt Tsf + + integer :: i, j, ij, k + + real (kind=dbl_kind) :: & + dTsf , & ! change in Tsf + aa1, bb1, cc1, & ! + hslyr, hilyr , & ! snow and ice layer thickness + qsn, qin , & ! snow and ice layer enthalpy + kilyr , & ! ice layer conductivity + khmax , & ! max allowed value of kh + ci + + logical (kind=log_kind) :: & + l_snow ! true if hsno > hs_min + +!lipscomb - for testing - remove later + if (my_task == mtest) then + i = itest + j = jtest + print*, '' + print*, 'Beginning Tsf calc, my_task, i, j =', mtest, i ,j + endif + + ! Initialize fluxes + + fsurfn (:,:) = c0 + fcondtopn(:,:) = c0 + flwoutn (:,:) = c0 + fsensn (:,:) = c0 + flatn (:,:) = c0 + + ! initialize surface temperature + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + Tsf(ij) = Tsfcn(i,j) + enddo + + !----------------------------------------------------------------- + ! Initialize isolve and related indices to be identical to icells + ! and related indices + !----------------------------------------------------------------- + + isolve = icells + do ij = 1, icells + indxii(ij) = indxi(ij) + indxjj(ij) = indxj(ij) + indxij(ij) = ij + enddo + + ! Compute temperature of top layer and conductivity at upper interface. + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + k = 1 ! top layer of ice or snow + + ! Check if snow layer thickness hsno > hs_min + + hslyr = vsnon(i,j) / aicen(i,j) + if (hslyr*nslyr > hs_min) then + l_snow = .true. + else + l_snow = .false. + endif + + ! Temperature and heat capacity of top layer + + if (l_snow) then + + ! Compute enthalpy of top ice layer + qsn = esnon(i,j,k)*real(nslyr,kind=dbl_kind) / vsnon(i,j) + + ! Compute snow temperature from enthalpy + Tis(ij) = (Lfresh + qsn/rhos)/cp_ice + Tis(ij) = min(Tis(ij), c0) + + else + + ! Compute enthalpy of top ice layer + qin = eicen(i,j,k)*real(nilyr,kind=dbl_kind) / vicen(i,j) + + ! Compute ice temperature from enthalpy using quadratic formula + + if (l_brine) then + aa1 = cp_ice + bb1 = (cp_ocn-cp_ice)*Tmlt(k) - qin/rhoi - Lfresh + cc1 = Lfresh * Tmlt(k) + Tis(ij) = (-bb1 - sqrt(bb1*bb1 - c4*aa1*cc1)) / & + (c2*aa1) + Tis(ij) = min(Tis(ij),Tmlt(k)) + else ! fresh ice + Tis(ij) = (Lfresh + qin/rhoi) / cp_ice + Tis(ij) = min(Tis(ij),c0) + endif + + ! Compute heat capacity of the ice layer + if (l_brine) then + ci = cp_ice - Lfresh*Tmlt(k) / (Tis(ij)*Tis(ij)) + else + ci = cp_ice + endif + endif + + ! Conductivity (k/h) at upper interface + ! Limit to satisfy diffusive CFL condition + + if (l_snow) then + khis(ij) = c2*ksno / hslyr + khmax = rhos*cp_ice*hslyr / dt + else + k = 1 + + kilyr = kice + betak*salin(k)/min(-puny,Tis(ij)) + kilyr = max (kilyr, kimin) + + hilyr = vicen(i,j) / aicen(i,j) + khis(ij) = c2*kilyr / hilyr + khmax = rhoi*ci*hilyr / dt + endif + + khis(ij) = min(khis(ij), khmax) + + enddo ! ij + +!lipscomb - Remove later + + if (my_task==mtest) then + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (i==itest .and. j==jtest) then + print*, '' + print*, 'kh =', khis(ij) + print*, 'Tis =', Tis(ij) + print*, '' + print*, 'fswsfc =', fswsfcn(i,j) + print*, 'flwdn =', emissivity*flw(i,j) + print*, 'potT =', potT(i,j) - Tffresh + endif + enddo + endif ! my_task + + !----------------------------------------------------------------- + ! Compute radiative and turbulent fluxes and their derivatives + ! with respect to Tsf. + !----------------------------------------------------------------- + + call surface_fluxes (nx_block, ny_block, & + isolve, icells, & + indxii, indxjj, indxij, & + Tsf, fswsfcn, & + rhoa, flw, & + potT, Qa, & + shcoef, lhcoef, & + flwoutn, fsensn, & + flatn, fsurfn, & + dflwout_dT, dfsens_dT, & + dflat_dT, dfsurf_dT) + +!lipscomb - for testing - remove later + + if (my_task == mtest) then + i = itest + j = jtest + print*, '' + print*, 'Got surface fluxes' + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (i==itest .and. j==jtest) then + print*, '' + print*, 'flwout =', flwoutn(i,j) + print*, 'fsens =', fsensn(i,j) + print*, 'flat =', flatn(i,j) + print*, 'fsurf =', fsurfn(i,j) + print*, 'dfsurf_dT =', dfsurf_dT(ij) + endif + enddo + endif + + !----------------------------------------------------------------- + ! Solve for the new surface temperature and fluxes + !----------------------------------------------------------------- + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + dTsf = (fsurfn(i,j) - khis(ij)*(Tsf(ij) - Tis(ij))) / & + (khis(ij) - dfsurf_dT(ij)) + + Tsf(ij) = Tsf(ij) + dTsf + + if (Tsf(ij) > c0) then + dTsf = dTsf - Tsf(ij) + Tsf(ij) = c0 + endif + + Tsfcn(i,j) = Tsf(ij) ! for output + + fsensn (i,j) = fsensn (i,j) + dTsf*dfsens_dT(ij) + flatn (i,j) = flatn (i,j) + dTsf*dflat_dT(ij) + flwoutn(i,j) = flwoutn(i,j) + dTsf*dflwout_dT(ij) + fsurfn (i,j) = fsurfn (i,j) + dTsf*dfsurf_dT(ij) + + fcondtopn(i,j) = khis(ij) * (Tsf(ij) - Tis(ij)) + + enddo + +!lipscomb - for testing - remove later + + if (my_task == mtest) then + i = itest + j = jtest + print*, '' + print*, 'New temp and fluxes:' + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (i==itest .and. j==jtest) then + print*, '' + print*, 'Tsf =', Tsf(ij) + print*, 'fct =', fcondtopn(i,j) + print*, '' + print*, 'flwout =', flwoutn(i,j) + print*, 'fsens =', fsensn(i,j) + print*, 'flat =', flatn(i,j) + print*, 'fsurf =', fsurfn(i,j) + print*, 'dfsurf_dT =', dfsurf_dT(ij) + endif + enddo + endif + + end subroutine explicit_calc_Tsfc + !======================================================================= end module CICE_RunMod diff --git a/cice/drivers/hadgem3/CICE.F90 b/cice/drivers/hadgem3/CICE.F90 new file mode 100644 index 0000000..80b03f0 --- /dev/null +++ b/cice/drivers/hadgem3/CICE.F90 @@ -0,0 +1,244 @@ +!======================================================================= +! Copyright 2006, LANSLLC. All rights reserved. +! Unless otherwise indicated, this information has been authored by an +! employee or employees of the Los Alamos National Security, LLC (LANS), +! operator of the Los Alamos National Laboratory under Contract No. +! DE-AC52-06NA25396 with the U.S. Department of Energy. The U.S. Government +! has rights to use, reproduce, and distribute this information. The public +! may copy and use this information without charge, provided that this +! Notice and any statement of authorship are reproduced on all copies. +! Neither the Government nor LANS makes any warranty, express or implied, +! or assumes any liability or responsibility for the use of this +! information. +! +! CICE is developed and maintained by Elizabeth C. Hunke (eclare@lanl.gov) +! and William H. Lipscomb (lipscomb@lanl.gov) of Group T-3 (Fluid +! Dynamics), Los Alamos National Laboratory, with support from the +! Climate Change Prediction Program (CCPP) and the Scientific +! Discovery through Advanced Computing (SciDAC) program of the U.S. +! Department of Energy. We thank John Dukowicz (T-3), Phil Jones (T-3), +! and Robert Malone (CCS-2) for their support of the sea ice modeling +! effort at LANL. +! +! CICE has been developed in close collaboration with the NCAR CCSM +! climate modeling project and includes ideas and efforts from +! members the CCSM Polar Climate Working Group (PCWG). We especially +! thank the following members of the PCWG code development team: +! +! Cecilia Bitz, UW +! Bruce Briegleb, NCAR +! Tony Craig, NCAR +! Marika Holland, NCAR +! Julie Schramm, NCAR +! David Bailey, NCAR +! +! Numerous others have contributed to this effort--thanks to all! +!======================================================================= +#ifndef popcice +! +!BOP +! +! !MODULE: icemodel - main ice model program +! +! !DESCRIPTION: +! +! Main driver routine for CICE. Initializes and steps through the model. +! This program should be compiled if CICE is run as a separate executable, +! but not if CICE subroutines are called from another program (e.g., CAM). +! +! !REVISION HISTORY: +! SVN:$Id: CICE.F90 56 2007-03-15 14:42:35Z dbailey $ +! +! authors Elizabeth C. Hunke and William H. Lipscomb, LANL +! +! 2006: Converted to free form source (F90) by Elizabeth Hunke +! +! !INTERFACE: +! + program icemodel +! +! !USES: +! + use ice_kinds_mod +#ifdef USE_ESMF + use esmf_mod + use CICE_ComponentMod +#else + use CICE_InitMod + use CICE_RunMod + use CICE_FinalMod +#endif + +! +!EOP +! + implicit none + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + +#ifdef USE_ESMF + type (ESMF_GridComp) :: & + CICE_Comp ! CICE as an ESMF component + + type (ESMF_VM) :: & + worldVM ! ESMF VM describing processor world + + type (ESMF_Clock) :: & + synchClock ! clock used to synchronize model in coupled + ! mode - used as arguments to init,run,final + + type (ESMF_State) :: & + ciceImportState, ! CICE import state + ciceExportState ! CICE export state + + integer (int_kind) :: & + errorCode ! error code from method calls + +#else +! declare as integer dummy arguments + + integer (int_kind) :: & + CICE_Comp , & ! dummy argument + worldVM , & ! dummy argument + synchClock , & ! dummy argument + ciceimportState , & ! dummy argument + ciceexportState , & ! dummy argument + errorCode ! dummy argument + +#endif + +#ifdef USE_ESMF + !-------------------------------------------------------------------- + ! initialize ESMF and retrieve the global VM + !-------------------------------------------------------------------- + + errorCode = ESMF_Success + + call ESMF_Initialize(rc=errorCode) + if (errorCode /= ESMF_SUCCESS) & + stop 'CICE: Error initializing ESMF' + + call ESMF_VMGetGlobal(worldVM, rc=errorCode) + if (errorCode /= ESMF_SUCCESS) stop 'CICE: Error getting ESMF VM' + + !-------------------------------------------------------------------- + ! create the mostly empty CICE component and register methods + ! clock and grid info will be added during initialize + !-------------------------------------------------------------------- + + CICE_Comp = ESMF_GridCompCreate(worldVM, & + name = 'CICE Sea Ice Component', & + gridcomptype = ESMF_SEAICE, & + rc=errorCode) + + if (errorCode /= ESMF_SUCCESS) & + stop 'CICE: Error creating CICE comp' + + call ESMF_GridCompSetServices(CICE_Comp, CICE_SetServices, & + errorCode) + + if (errorCode /= ESMF_SUCCESS) & + stop 'CICE: Error registering CICE methods' +#endif + + !----------------------------------------------------------------- + ! Initialize CICE + !----------------------------------------------------------------- + +#ifdef USE_ESMF + call ESMF_GridCompInitialize(CICE_Comp, ciceImportState, & + ciceExportState, synchClock, errorCode) + + if (errorCode /= ESMF_Success) stop 'CICE: Error in init method' & +#else + call CICE_Initialize(CICE_Comp, ciceImportState, & + ciceExportState, synchClock, errorCode) +#endif + + !----------------------------------------------------------------- + ! Run CICE + !----------------------------------------------------------------- + +#ifdef USE_ESMF + call ESMF_GridCompRun(CICE_Comp, ciceImportState, ciceExportState, & + synchClock, errorCode) + + if (errorCode /= ESMF_Success) stop 'CICE: Error in run method' +#else + call CICE_Run(CICE_Comp, ciceImportState, ciceExportState, & + synchClock, errorCode) +#endif + + !----------------------------------------------------------------- + ! Finalize CICE and exit ESMF + !----------------------------------------------------------------- + +#ifdef USE_ESMF + call ESMF_GridCompFinalize(CICE_Comp, ciceImportState, & + ciceExportState, & + synchClock, errorCode) + + if (errorCode /= ESMF_Success) & + stop 'CICE: Error in finalize method' + +#else + call CICE_Finalize(CICE_Comp, ciceImportState, ciceExportState, & + synchClock, errorCode) +#endif + + +#ifdef USE_ESMF + call ESMF_Finalize(rc=errorCode) +#endif + + end program icemodel + +#endif +!======================================================================= +!BOP +! +! !ROUTINE: debug_ice - wrapper for print_state +! +! !DESCRIPTION: +! +! Wrapper for the print_state debugging routine. +! Useful for debugging in the main driver (see ice.F_debug) +! ip, jp, mtask are set in ice_diagnostics.F +! +! !REVISION HISTORY: +! +! author Elizabeth C. Hunke, LANL +! +! !INTERFACE: +! + subroutine debug_ice(plabeld) +! +! !USES: +! + use ice_kinds_mod + use ice_diagnostics + use ice_domain, only: nblocks + use ice_blocks, only: nx_block, ny_block +! +! !INPUT/OUTPUT PARAMETERS: +! + character (char_len), intent(in) :: plabeld +! +!EOP +! + integer (kind=int_kind) :: i, j, iblk + + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (iblk==iblkp .and. i==ip .and. j==jp .and. my_task==mtask) & + call print_state(plabeld,i,j,iblk) + enddo + enddo + enddo + + end subroutine debug_ice + +!======================================================================= diff --git a/cice/drivers/hadgem3/CICE_ComponentMod.F90 b/cice/drivers/hadgem3/CICE_ComponentMod.F90 new file mode 100644 index 0000000..17f2849 --- /dev/null +++ b/cice/drivers/hadgem3/CICE_ComponentMod.F90 @@ -0,0 +1,146 @@ +!======================================================================= +!BOP +! +! !MODULE: CICE_ComponentMod - ESMF component module for CICE +! +! !DESCRIPTION: +! +! This module contains the routines for making CICE a component, +! particularly for the Earth System Modeling Framework (ESMF). +! It primarily makes public a routine for registering the init, +! finalize and run methods for CICE. +! +! !REVISION HISTORY: +! SVN:$Id: CICE_ComponentMod.F90 56 2007-03-15 14:42:35Z dbailey $ +! +! authors: Philip W. Jones, LANL +! +! 2005: Introduced module for ESMF compliance +! 2006: Converted to free source form (F90) by Elizabeth Hunke +! +! !INTERFACE: +! + module CICE_ComponentMod +! +! !USES: +! + use ice_kinds_mod +#ifdef USE_ESMF + use esmf_mod + use CICE_InitMod + use CICE_RunMod + use CICE_FinalMod +#endif + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + +#ifdef USE_ESMF + public :: CICE_SetServices +#endif +! +!EOP +! + +#ifdef USE_ESMF +! entire module + +!======================================================================= + + contains + +!======================================================================= + +!BOP +! +! !IROUTINE: CICE_SetServices - registers methods with ESMF +! +! !INTERFACE: +! + subroutine CICE_SetServices(griddedComp, errorCode) + +! +! !DESCRIPTION: +! +! This routine registers the initialize, run and finalize methods +! for the CICE model in the ESMF. +! +! !REVISION HISTORY: +! +! authors: same as module +! + +! +! !INPUT/OUTPUT PARAMETERS: + + type (ESMF_GridComp) :: & + griddedComp ! ESMF gridded component to which + ! services are assigned + + integer (int_kind) :: & + errorCode ! Returns an error code if any init fails + +! +!EOP +!BOC +! + + !-------------------------------------------------------------------- + ! initialize return flag + !-------------------------------------------------------------------- + + errorCode = ESMF_Success + + !-------------------------------------------------------------------- + ! register init method + !-------------------------------------------------------------------- + + call ESMF_GridCompSetEntryPoint(griddedComp, ESMF_SETINIT, & + CICE_Initialize, 0, errorCode) + + if (errorCode /= ESMF_Success) then + ! add error message here or use ESMF error and logging facilities + return + endif + + !-------------------------------------------------------------------- + ! register run method + !-------------------------------------------------------------------- + + call ESMF_GridCompSetEntryPoint(griddedComp, ESMF_SETRUN, & + CICE_Run, 0, errorCode) + + if (errorCode /= ESMF_Success) then + ! add error message here or use ESMF error and logging facilities + return + endif + + !-------------------------------------------------------------------- + ! register finalize method + !-------------------------------------------------------------------- + + call ESMF_GridCompSetEntryPoint(griddedComp, ESMF_SETFINAL, & + CICE_Finalize, 0, errorCode) + + if (errorCode /= ESMF_Success) then + ! add error message here or use ESMF error and logging facilities + return + endif + +! +!EOC +! + + end subroutine CICE_SetServices + +#endif +!ifdef USE_ESMF + +!======================================================================= + + end module CICE_ComponentMod + +!======================================================================= diff --git a/cice/drivers/hadgem3/CICE_FinalMod.F90 b/cice/drivers/hadgem3/CICE_FinalMod.F90 new file mode 100644 index 0000000..5db48d7 --- /dev/null +++ b/cice/drivers/hadgem3/CICE_FinalMod.F90 @@ -0,0 +1,131 @@ +!======================================================================= +! +!BOP +! +! !MODULE: CICE_FinalMod - routines for final exit of CICE model +! +! !DESCRIPTION: +! +! This module contains routines for the final exit of the CICE model, +! including final output and clean exit from any message passing +! environments and frameworks. +! +! !REVISION HISTORY: +! SVN:$Id: CICE_FinalMod.F90 56 2007-03-15 14:42:35Z dbailey $ +! +! authors: Philip W. Jones, LANL +! 2006: Converted to free source form (F90) by Elizabeth Hunke +! +! !INTERFACE: +! + + module CICE_FinalMod + +! +! !USES: +! +#ifdef USE_ESMF + use esmf_mod +#endif + use ice_exit + use ice_fileunits + use ice_kinds_mod + use ice_timers + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: CICE_Finalize + +! +!EOP +! +!======================================================================= + + contains + +!======================================================================= +!BOP +! +! !ROUTINE: CICE_Finalize - final exit of CICE model +! +! !DESCRIPTION: +! +! This routine shuts down CICE by exiting all relevent environments. +! +! !REVISION HISTORY: +! +! author same as module +! +! !INTERFACE: +! + + subroutine CICE_Finalize(CICE_Comp, importState, exportState, & + synchClock, errorCode) + +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: + +#ifdef USE_ESMF + + type (ESMF_GridComp), intent(inout) :: & + CICE_Comp ! defined ESMF component for CICE + + type (ESMF_State), intent(in) :: & + importState ! CICE final import state - currently ignored + + type (ESMF_State), intent(out) :: & + exportState ! CICE final export state - currently ignored + + type (ESMF_Clock), intent(inout) :: & + synchClock ! ESMF clock to check init time + + integer (int_kind), intent(inout) :: & + errorCode ! On input, error code from Init,Run method + ! On output, status of this routine + +#else +! declare as integer dummy arguments + + integer (int_kind) , intent(inout), optional :: & + CICE_Comp , & ! dummy argument + importState, & ! dummy argument + exportState, & ! dummy argument + synchClock , & ! dummy argument + errorCode ! dummy argument + +#endif + +! +!EOP +!BOC +! + !------------------------------------------------------------------- + ! stop timers and print timer info + !------------------------------------------------------------------- + + call ice_timer_stop(timer_total) ! stop timing entire run + call ice_timer_print_all(stats=.false.) ! print timing information + +!echmod if (nu_diag /= 6) close (nu_diag) ! diagnostic output + call release_all_fileunits + +#ifndef coupled + call end_run ! quit MPI +#endif + +! +!EOC +! + end subroutine CICE_Finalize + +!======================================================================= + + end module CICE_FinalMod + +!======================================================================= diff --git a/cice/drivers/hadgem3/CICE_InitMod.F90 b/cice/drivers/hadgem3/CICE_InitMod.F90 new file mode 100644 index 0000000..a48f72d --- /dev/null +++ b/cice/drivers/hadgem3/CICE_InitMod.F90 @@ -0,0 +1,255 @@ +!======================================================================= +! +!BOP +! +! !MODULE: CICE_InitMod - performs CICE initialization +! +! !DESCRIPTION: +! +! This module contains the CICE initialization routine that sets model +! parameters and initializes the grid and CICE state variables. +! +! !REVISION HISTORY: +! SVN:$Id: CICE_InitMod.F90 56 2007-03-15 14:42:35Z dbailey $ +! +! authors Elizabeth C. Hunke, LANL +! William H. Lipscomb, LANL +! Philip W. Jones, LANL +! +! 2006: Converted to free form source (F90) by Elizabeth Hunke +! +! !INTERFACE: +! + module CICE_InitMod +! +! !USES: +! +#ifdef USE_ESMF + use esmf_mod +#endif + use ice_age + use ice_calendar + use ice_communicate + use ice_diagnostics + use ice_domain + use ice_dyn_evp + use ice_exit + use ice_fileunits + use ice_flux + use ice_forcing + use ice_grid + use ice_history + use ice_restart + use ice_init + use ice_itd + use ice_kinds_mod + use ice_mechred + use ice_meltpond + use ice_ocean + use ice_orbital + use ice_shortwave + use ice_therm_itd + use ice_therm_vertical + use ice_timers + use ice_transport_driver + use ice_transport_remap + use ice_work +#ifdef popcice + use drv_forcing, only: sst_sss +#endif + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: CICE_Initialize, cice_init + +! +!EOP +! +!======================================================================= + + contains + +!======================================================================= +!BOP +! +! !ROUTINE: CICE_Initialize - initialize CICE model +! +! !DESCRIPTION: +! +! Initialize the basic state, grid and all necessary parameters for +! running the CICE model. Return the initial state in routine +! export state. +! Note: This initialization driver is designed for standalone and +! CCSM-coupled applications, with or without ESMF. For other +! applications (e.g., standalone CAM), this driver would be +! replaced by a different driver that calls subroutine cice_init, +! where most of the work is done. +! +! !REVISION HISTORY: same as module +! +! !INTERFACE: +! + + subroutine CICE_Initialize(CICE_Comp, importState, exportState, & + synchClock, errorCode) +! +! !USES: +! +! +! !INPUT/OUTPUT PARAMETERS: +! + + !-------------------------------------------------------------------- + ! Argument types depend on whether the model is using ESMF. + !-------------------------------------------------------------------- + +#ifdef USE_ESMF + + type (ESMF_GridComp), intent(inout) :: & + CICE_Comp ! defined ESMF component for CICE + + type (ESMF_State), intent(inout) :: & + importState, & ! CICE import state + exportState ! CICE export state + + type (ESMF_Clock), intent(inout) :: & + synchClock ! ESMF clock to check init time + + integer (int_kind), intent(inout) :: & + errorCode ! returns an error code if any init fails + +#else +! declare as integer dummy arguments + + integer (int_kind) , intent(inout), optional :: & + CICE_Comp , & ! dummy argument + importState, & ! dummy argument + exportState, & ! dummy argument + synchClock , & ! dummy argument + errorCode ! dummy argument + +#endif +! +!EOP +!BOC +! + !-------------------------------------------------------------------- + ! local variables + !-------------------------------------------------------------------- + + + !-------------------------------------------------------------------- + ! initialize return flag + !-------------------------------------------------------------------- + +#ifdef USE_ESMF + errorCode = ESMF_SUCCESS +#endif + + !-------------------------------------------------------------------- + ! model initialization + !-------------------------------------------------------------------- + + call cice_init + + !-------------------------------------------------------------------- + ! coupler communication or forcing data initialization + !-------------------------------------------------------------------- +#ifndef CICE_IN_NEMO + call init_forcing_atmo ! initialize atmospheric forcing (standalone) +#endif + +#ifdef USE_ESMF + !-------------------------------------------------------------------- + ! initialize and fill the export state with initial fields + !-------------------------------------------------------------------- + + call CICE_CoupledInit(importState, exportState, errorCode) + + if (errorCode /= ESMF_Success) then + write(nu_diag,*) & + '(ice) CICE_Initialize: error filling export state' + return + endif +#endif + +! +!EOC +! + end subroutine CICE_Initialize + +!======================================================================= +!BOP +! +! !ROUTINE: cice_init - initialize CICE model +! +! !DESCRIPTION: +! +! Initialize CICE model. +! +! !REVISION HISTORY: same as module +! +! !INTERFACE: +! + subroutine cice_init +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: +! +!EOP +! + call init_communicate ! initial setup for message passing + call init_fileunits ! unit numbers + call input_data ! namelist variables + call init_work ! work arrays + + call init_domain_blocks ! set up block decomposition + call init_grid1 ! domain distribution + call init_ice_timers ! initialize all timers + call ice_timer_start(timer_total) ! start timing entire run + call init_grid2 ! grid variables + + call init_transport ! initialize horizontal transport + call init_calendar ! initialize some calendar stuff + call init_hist (dt) ! initialize output history file + call init_evp (dt) ! define evp dynamics parameters, variables + call init_coupler_flux ! initialize fluxes exchanged with coupler +#ifdef popcice + call sst_sss ! POP data for CICE initialization +#endif + call init_thermo_vertical ! initialize vertical thermodynamics + if (shortwave == 'dEdd') then + call init_orbit ! initialize orbital parameters + call init_dEdd ! initialize delta-Eddington scheme + endif + call init_itd ! initialize ice thickness distribution + call calendar(time) ! determine the initial date + +#ifndef CICE_IN_NEMO + call init_forcing_ocn(dt) ! initialize sss and sst from data +#endif + call init_state ! initialize the ice state + + if (restart) call restartfile ! start from restart file + + ! tracers + if (tr_iage) call init_age ! ice age tracer + if (tr_pond) call init_meltponds ! melt ponds + + call init_shortwave ! initialize radiative transfer + call init_diags ! initialize diagnostic output points + call init_history_therm ! initialize thermo history variables + call init_history_dyn ! initialize dynamic history variables + + end subroutine cice_init + +!======================================================================= + + end module CICE_InitMod + +!======================================================================= diff --git a/cice/drivers/hadgem3/CICE_RunMod.F90 b/cice/drivers/hadgem3/CICE_RunMod.F90 new file mode 100644 index 0000000..971fe69 --- /dev/null +++ b/cice/drivers/hadgem3/CICE_RunMod.F90 @@ -0,0 +1,1685 @@ +!======================================================================= +! +!BOP +! +! !MODULE: CICE_RunMod - contains main run method for CICE +! +! !DESCRIPTION: +! +! Contains main driver routine for time stepping of CICE. +! +! !REVISION HISTORY: +! SVN:$Id: CICE_RunMod.F90 56 2007-03-15 14:42:35Z dbailey $ +! +! authors Elizabeth C. Hunke, LANL +! Philip W. Jones, LANL +! William H. Lipscomb, LANL +! +! 2006 ECH: moved exit timeLoop to prevent execution of unnecessary timestep +! 2006 ECH: Streamlined for efficiency +! 2006 ECH: Converted to free source form (F90) +! 2007 BPB: Modified Delta-Eddington shortwave interface +! +! !INTERFACE: +! + + module CICE_RunMod +! +! !USES: +! +#ifdef USE_ESMF + use esmf_mod +#endif + use ice_age + use ice_atmo + use ice_calendar + use ice_communicate + use ice_diagnostics + use ice_domain + use ice_dyn_evp + use ice_exit + use ice_fileunits + use ice_flux + use ice_forcing + use ice_grid + use ice_history + use ice_restart + use ice_init + use ice_itd + use ice_kinds_mod + use ice_mechred + use ice_meltpond + use ice_ocean + use ice_orbital + use ice_shortwave + use ice_state + use ice_therm_itd + use ice_therm_vertical + use ice_timers + use ice_transport_driver + use ice_transport_remap + use ice_work +#ifdef popcice + use ice_to_drv, only: to_drv +#endif + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: CICE_Run, step_therm1, step_therm2, step_dynamics, ice_step +! +!EOP +! +!======================================================================= + + contains + +!======================================================================= +!BOP +! +! !ROUTINE: CICE_Run - advances CICE model forward in time +! +! !DESCRIPTION: +! +! This is the main driver routine for advancing CICE forward in time. +! Accepts forcing fields at beginning of time step and returns the +! model state at the end of the time step. +! +! The module is divided into three parts that are called independently: +! step_therm1, step_therm2, and step_dynamics. The thermodynamics is +! split up such that the fields needed for coupling are computed in +! step_therm1, and the rest of the work is done in step_therm2. +! +! !REVISION HISTORY: +! +! author Elizabeth C. Hunke, LANL +! Philip W. Jones, LANL +! William H. Lipscomb, LANL +! +! !INTERFACE: +! + + subroutine CICE_Run(CICE_Comp, importState, exportState, & + synchClock, errorCode) + +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: + +#ifdef USE_ESMF + + type (ESMF_GridComp), intent(inout) :: & + CICE_Comp ! defined ESMF component for CICE + + type (ESMF_State), intent(in) :: & + importState ! CICE import state (forcing data) + + type (ESMF_State), intent(out) :: & + exportState ! CICE export state (surface fields) + + type (ESMF_Clock), intent(inout) :: & + synchClock ! ESMF clock to check init time + + integer (int_kind), intent(inout) :: & + errorCode ! returns an error code if any init fails + +#else +! declare as integer dummy arguments + + integer (int_kind), intent(inout), optional :: & + CICE_Comp , & ! dummy argument + importState , & ! dummy argument + exportState , & ! dummy argument + synchClock , & ! dummy argument + errorCode ! dummy argument + +#endif + +! +!EOP +!BOC +! + !-------------------------------------------------------------------- + ! local variables + !-------------------------------------------------------------------- + + real (dbl_kind) :: & + coupledInterval ! time (seconds) for each coupling interval + + integer (kind=int_kind) :: k + + !-------------------------------------------------------------------- + ! initialize error code and step timer + !-------------------------------------------------------------------- + + call ice_timer_start(timer_step) ! start timing entire run + +#ifdef ESMF + errorCode = ESMF_SUCCESS + + !-------------------------------------------------------------------- + ! check clock to make sure models agree on time info + !-------------------------------------------------------------------- + ! + ! call CICE_CoupledCheckTime(synchClock, 'start', errorCode) + ! + ! if (errorCode /= ESMF_SUCCESS) then + ! write (nu_diag,*) & + ! '(ice) CICE_Run: error in clock synchronization' + ! return + ! endif + ! + !UNCOMMENT THESE TWO SECTIONS FOR COUPLED MODEL SIMULATIONS WITH ESMF + !-------------------------------------------------------------------- + ! reset timer to stop when requested by input clock + !-------------------------------------------------------------------- + ! + ! Use appropriate ESMF Clock query functions to determine the + ! coupling interval in seconds. Because this depends on how the + ! coupled model driver is using an ESMF clock, this is left to + ! the user of the coupled model. + ! + !coupledInterval = ? + ! + ! reset number of time steps based on coupling interval + ! + !npt = nint(coupledInterval/dt) + ! + !-------------------------------------------------------------------- + ! extract data from import state + !-------------------------------------------------------------------- + + call CICE_CoupledExtractImport(importState, errorCode) + + if (errorCode /= ESMF_SUCCESS) then + write(nu_diag,*) & + '(ice) CICE_Run: error extracting data from import state' + return + endif +#endif + +#ifndef CICE_IN_NEMO + !-------------------------------------------------------------------- + ! timestep loop + !-------------------------------------------------------------------- + + timeLoop: do +#endif + istep = istep + 1 ! update time step counters + istep1 = istep1 + 1 + time = time + dt ! determine the time and date + call calendar(time) ! at the end of the timestep + +#ifndef coupled + call get_forcing_atmo ! atmospheric forcing from data + call get_forcing_ocn(dt) ! ocean forcing from data +#endif +#ifndef CICE_IN_NEMO + if (stop_now >= 1) exit timeLoop +#endif + call ice_step + +#ifdef USE_ESMF + call CICE_CoupledAccumulateExport(errorCode) +#endif + +#ifndef CICE_IN_NEMO + enddo timeLoop +#endif + !-------------------------------------------------------------------- + ! end of timestep loop + !-------------------------------------------------------------------- + + call ice_timer_stop(timer_step) ! end timestepping loop timer + + +#ifdef USE_ESMF + !-------------------------------------------------------------------- + ! check clock to make sure models agree on time info + !-------------------------------------------------------------------- + ! + ! call CICE_CoupledCheckTime(synchClock, 'stop', errorCode) + ! + ! if (errorCode /= ESMF_SUCCESS) then + ! write(nu_diag,*) + ! '(ice) CICE_Run: error in stop time synchronization' + ! return + ! endif + ! + !-------------------------------------------------------------------- + ! fill the export state + !-------------------------------------------------------------------- + + call CICE_CoupledFillExport(exportState, errorCode) + + if (errorCode /= ESMF_SUCCESS) then + write(nu_diag,*) & + '(ice) CICE_Run: error filling export state' + return + endif +#endif +! +!EOC +! + + end subroutine CICE_Run + +!======================================================================= + + subroutine ice_step + + integer (kind=int_kind) :: k + + call init_mass_diags ! diagnostics per timestep + + !----------------------------------------------------------------- + ! thermodynamics + !----------------------------------------------------------------- + + call step_therm1 (dt) ! pre-coupler thermodynamics + +#ifdef popcice + call to_drv +#endif + + call step_therm2 (dt) ! post-coupler thermodynamics + + !----------------------------------------------------------------- + ! dynamics, transport, ridging + !----------------------------------------------------------------- + + do k = 1, ndyn_dt + call step_dynamics (dyn_dt) + enddo + + !----------------------------------------------------------------- + ! write data + !----------------------------------------------------------------- + + call ice_timer_start(timer_readwrite) ! reading/writing + + if (mod(istep,diagfreq) == 0) call runtime_diags(dt) ! log file + + call ice_write_hist (dt) ! history file + + if (write_restart == 1) then + call dumpfile ! core variables for restarting + if (tr_iage) call write_restart_age +! if (tr_pond) call write_restart_ponds + endif + + call ice_timer_stop(timer_readwrite) ! reading/writing + + end subroutine ice_step + +!======================================================================= +!BOP +! +! !ROUTINE: step_therm1 - step pre-coupler thermodynamics +! +! !DESCRIPTION: +! +! Driver for updating ice and snow internal temperatures and +! computing thermodynamic growth rates and coupler fluxes. +! +! !REVISION HISTORY: +! +! authors: William H. Lipscomb, LANL +! +! !INTERFACE: + + subroutine step_therm1 (dt) +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: +! + real (kind=dbl_kind), intent(in) :: & + dt ! time step +! +!EOP +! + integer (kind=int_kind) :: & + i, j, ij , & ! horizontal indices + iblk , & ! block index + ilo,ihi,jlo,jhi, & ! beginning and end of physical domain + n , & ! thickness category index + il1, il2 , & ! ice layer indices for eice + sl1, sl2 ! snow layer indices for esno + + integer (kind=int_kind), save :: & + icells ! number of cells with aicen > puny + + integer (kind=int_kind), dimension(nx_block*ny_block), save :: & + indxi, indxj ! indirect indices for cells with aicen > puny + +! 2D coupler variables (computed for each category, then aggregated) + + real (kind=dbl_kind), dimension (nx_block,ny_block) :: & + fsensn , & ! surface downward sensible heat (W/m^2) +! flatn , & ! now in ice_flux module + fswabsn , & ! shortwave absorbed by ice (W/m^2) + flwoutn , & ! upward LW at surface (W/m^2) + evapn , & ! flux of vapor, atmos to ice (kg m-2 s-1) + freshn , & ! flux of water, ice to ocean (kg/m^2/s) + fsaltn , & ! flux of salt, ice to ocean (kg/m^2/s) + fhocnn , & ! fbot corrected for leftover energy (W/m^2) + fswthrun , & ! SW through ice to ocean (W/m^2) + strairxn , & ! air/ice zonal strss, (N/m^2) + strairyn , & ! air/ice merdnl strss, (N/m^2) + Trefn , & ! air tmp reference level (K) + Qrefn ! air sp hum reference level (kg/kg) + + ! other local variables + real (kind=dbl_kind), dimension (nx_block,ny_block) :: & + Tbot , & ! ice bottom surface temperature (deg C) + fbot , & ! ice-ocean heat flux at bottom surface (W/m^2) + shcoef , & ! transfer coefficient for sensible heat + lhcoef , & ! transfer coefficient for latent heat + fswsfcn , & ! SW absorbed at ice/snow surface (W m-2) + fswintn ! SW absorbed in ice interior, below surface (W m-2) + + ! Local variables to keep track of melt for ponds + real (kind=dbl_kind), dimension (nx_block,ny_block) :: & + melts_old, & + meltt_old, & + melts_tmp, & + meltt_tmp + + real (kind=dbl_kind), dimension (nx_block,ny_block,nilyr) :: & + Iswabsn ! SW radiation absorbed in ice layers (W m-2) + + ! snow variables for Delta-Eddington shortwave + real (kind=dbl_kind), dimension (nx_block,ny_block) :: & + fsn ! snow horizontal fraction + real (kind=dbl_kind), dimension (nx_block,ny_block,nslyr) :: & + rhosnwn , & ! snow density (kg/m3) + rsnwn , & ! snow grain radius (micro-meters) + Sswabsn ! SW radiation absorbed in snow layers (W m-2) + + ! pond variables for Delta-Eddington shortwave + real (kind=dbl_kind), dimension (nx_block,ny_block) :: & + fpn , & ! pond fraction + hpn ! pond depth (m) + + type (block) :: & + this_block ! block information for current block + + logical (kind=log_kind) :: & + l_stop ! if true, abort the model + + integer (kind=int_kind) :: & + istop, jstop ! indices of grid cell where model aborts + + real (kind=dbl_kind) :: & + raice ! 1/aice + + call ice_timer_start(timer_column) ! column physics + call ice_timer_start(timer_thermo) ! thermodynamics + + call init_history_therm ! initialize thermo history variables + + if (oceanmixed_ice) & + call ocean_mixed_layer (dt) ! ocean surface fluxes and sst + + call init_flux_atm ! initialize atmosphere fluxes sent to coupler + + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + !----------------------------------------------------------------- + ! Save the ice area passed to the coupler (so that history fields + ! can be made consistent with coupler fields). + ! Save the initial ice area and volume in each category. + !----------------------------------------------------------------- + + do j = 1, ny_block + do i = 1, nx_block + aice_init (i,j, iblk) = aice (i,j, iblk) + enddo + enddo + + do n = 1, ncat + do j = 1, ny_block + do i = 1, nx_block + aicen_init(i,j,n,iblk) = aicen(i,j,n,iblk) + vicen_init(i,j,n,iblk) = vicen(i,j,n,iblk) + enddo + enddo + enddo + +#ifdef CICE_IN_NEMO + !--------------------------------------------------------------- + ! Scale frain and fsnow by ice concentration as these fields + ! are supplied by NEMO multiplied by ice concentration + !--------------------------------------------------------------- + + do j = 1, ny_block + do i = 1, nx_block + + if (aice_init(i,j,iblk) > puny) then + raice = c1 / aice_init(i,j,iblk) + frain(i,j,iblk) = frain(i,j,iblk)*raice + fsnow(i,j,iblk) = fsnow(i,j,iblk)*raice + else + frain(i,j,iblk) = c0 + fsnow(i,j,iblk) = c0 + endif + + enddo + enddo +#endif + + !----------------------------------------------------------------- + ! Adjust frzmlt to account for ice-ocean heat fluxes since last + ! call to coupler. + ! Compute lateral and bottom heat fluxes. + !----------------------------------------------------------------- + + call frzmlt_bottom_lateral & + (nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + dt, & + aice (:,:, iblk), frzmlt(:,:, iblk), & + eicen (:,:,:,iblk), esnon (:,:,:,iblk), & + sst (:,:, iblk), Tf (:,:, iblk), & + strocnxT(:,:,iblk), strocnyT(:,:,iblk), & + Tbot, fbot, & + rside (:,:, iblk) ) + + + !----------------------------------------------------------------- + ! Compute cosine of solar zenith angle. + ! This is used by the delta-Eddington shortwave module. + ! Albedos are aggregated in merge_fluxes only for cells w/ coszen > 0. + ! For basic shortwave, simply set coszen to a constant between 0 and 1. + !----------------------------------------------------------------- + + call ice_timer_start(timer_sw) + + if (trim(shortwave) == 'dEdd') then ! delta Eddington + + ! identify ice-ocean cells + icells = 0 + do j = 1, ny_block + do i = 1, nx_block + if (tmask(i,j,iblk)) then + icells = icells + 1 + indxi(icells) = i + indxj(icells) = j + endif + enddo ! i + enddo ! j + + call compute_coszen (nx_block, ny_block, & + icells, & + indxi, indxj, & + tlat (:,:,iblk), tlon(:,:,iblk), & + coszen(:,:,iblk), dt) + + else ! basic (ccsm3) shortwave + coszen(:,:,iblk) = p5 ! sun above the horizon + endif + + call ice_timer_stop(timer_sw) + + do n = 1, ncat + + !----------------------------------------------------------------- + ! Identify cells with nonzero ice area + !----------------------------------------------------------------- + + icells = 0 + do j = jlo, jhi + do i = ilo, ihi + if (aicen(i,j,n,iblk) > puny) then + icells = icells + 1 + indxi(icells) = i + indxj(icells) = j + endif + enddo ! i + enddo ! j + + if (calc_Tsfc) then + + call ice_timer_start(timer_sw) + + !----------------------------------------------------------------- + ! Solar radiation: albedo and absorbed shortwave + !----------------------------------------------------------------- + + if (trim(shortwave) == 'dEdd') then ! delta Eddington + + ! note that rhoswn, rsnw, fp, hp and Sswabs ARE NOT dimensioned with ncat + ! BPB 19 Dec 2006 + + ! set snow properties + call shortwave_dEdd_set_snow(nx_block, ny_block, & + icells, & + indxi, indxj, & + aicen(:,:,n,iblk), vsnon(:,:,n,iblk), & + trcrn(:,:,nt_Tsfc,n,iblk), fsn, & + rhosnwn, rsnwn) + + if (.not. tr_pond) then + + ! set pond properties + call shortwave_dEdd_set_pond(nx_block, ny_block, & + icells, & + indxi, indxj, & + aicen(:,:,n,iblk), & + trcrn(:,:,nt_Tsfc,n,iblk), & + fsn, fpn, & + hpn) + + else + + fpn(:,:) = apondn(:,:,n,iblk) + hpn(:,:) = hpondn(:,:,n,iblk) + + endif + + call shortwave_dEdd(nx_block, ny_block, & + icells, & + indxi, indxj, & + coszen(:,:, iblk), & + aicen(:,:,n,iblk), vicen(:,:,n,iblk), & + vsnon(:,:,n,iblk), fsn, & + rhosnwn, rsnwn, & + fpn, hpn, & + swvdr(:,:, iblk), swvdf(:,:, iblk), & + swidr(:,:, iblk), swidf(:,:, iblk), & + alvdrn(:,:,n,iblk),alvdfn(:,:,n,iblk), & + alidrn(:,:,n,iblk),alidfn(:,:,n,iblk), & + fswsfcn, fswintn, & + fswthrun, Sswabsn, & + Iswabsn) + + else + Sswabsn(:,:,:) = c0 + + call shortwave_ccsm3(nx_block, ny_block, & + icells, & + indxi, indxj, & + aicen(:,:,n,iblk), vicen(:,:,n,iblk), & + vsnon(:,:,n,iblk), & + trcrn(:,:,nt_Tsfc,n,iblk), & + swvdr(:,:, iblk), swvdf(:,:, iblk), & + swidr(:,:, iblk), swidf(:,:, iblk), & + alvdrn(:,:,n,iblk),alidrn(:,:,n,iblk), & + alvdfn(:,:,n,iblk),alidfn(:,:,n,iblk), & + fswsfcn, fswintn, & + fswthrun, Iswabsn, & + apondn(:,:,n,iblk),hpondn(:,:,n,iblk)) + + endif + + call ice_timer_stop(timer_sw) + + else ! .not. calc_Tsfc + + ! Initialise for safety + alvdrn(:,:,n,iblk) = c0 + alidrn(:,:,n,iblk) = c0 + alvdfn(:,:,n,iblk) = c0 + alidfn(:,:,n,iblk) = c0 + fswsfcn(:,:) = c0 + fswintn(:,:) = c0 + fswthrun(:,:)= c0 + Iswabsn(:,:,:) = c0 + Sswabsn(:,:,:) = c0 + + endif ! calc_Tsfc + + if (calc_Tsfc .or. calc_strair) then + + !----------------------------------------------------------------- + ! Atmosphere boundary layer calculation; compute coefficients + ! for sensible and latent heat fluxes. + ! + ! NOTE: The wind stress is computed here for later use if + ! calc_strair = .true. Otherwise, the wind stress + ! components are set to the data values. + !----------------------------------------------------------------- + + if (trim(atmbndy) == 'constant') then + call atmo_boundary_const & + (nx_block, ny_block, & + 'ice', icells, & + indxi, indxj, & + uatm(:,:,iblk), vatm(:,:,iblk), & + wind(:,:,iblk), rhoa(:,:,iblk), & + strairxn, strairyn, & + lhcoef, shcoef) + else ! default + call atmo_boundary_layer & + (nx_block, ny_block, & + 'ice', icells, & + indxi, indxj, & + trcrn(:,:,nt_Tsfc,n,iblk), & + potT(:,:,iblk), & + uatm(:,:,iblk), vatm(:,:,iblk), & + wind(:,:,iblk), zlvl(:,:,iblk), & + Qa (:,:,iblk), rhoa(:,:,iblk), & + strairxn, strairyn, & + Trefn, Qrefn, & + worka, workb, & + lhcoef, shcoef) + endif ! atmbndy + + else + + ! Initialise for safety + Trefn (:,:) = c0 + Qrefn (:,:) = c0 + lhcoef(:,:) = c0 + shcoef(:,:) = c0 + + endif ! calc_Tsfc or calc_strair + + + if (.not.(calc_strair)) then + +#ifndef CICE_IN_NEMO +! Do not do the following for CICE_IN_NEMO as wind stress is supplied on +! u grid and multipied by ice concentration and set directly in evp +! + ! Set to data values (on T points) + strairxn(:,:) = strax(:,:,iblk) + strairyn(:,:) = stray(:,:,iblk) +#else + ! Zero for safety + strairxn(:,:) = c0 + strairyn(:,:) = c0 +#endif + endif + + !----------------------------------------------------------------- + ! If not calculating surface temperature and fluxes, set surface + ! fluxes (flatn, fsurfn, and fcondtopn) to be used in + ! thickness_changes + !----------------------------------------------------------------- + + if (.not.(calc_Tsfc)) then + + call set_sfcflux(nx_block, ny_block, & + n, iblk, & + icells, & + indxi, indxj, & + aicen (:,:,n,iblk),& + flatn (:,:,n,iblk),& + fsurfn (:,:,n,iblk),& + fcondtopn(:,:,n,iblk) ) + + endif + + !----------------------------------------------------------------- + ! Update ice age + ! This is further adjusted for freezing in the thermodynamics. + ! Melting does not alter the ice age. + !----------------------------------------------------------------- + + if (tr_iage) then + call increment_age (nx_block, ny_block, & + dt, icells, & + indxi, indxj, & + trcrn(:,:,nt_iage,n,iblk)) + endif + + !----------------------------------------------------------------- + ! Vertical thermodynamics: Heat conduction, growth and melting. + !----------------------------------------------------------------- + + il1 = ilyr1(n) + il2 = ilyrn(n) + sl1 = slyr1(n) + sl2 = slyrn(n) + + melts_old = melts(:,:,iblk) + meltt_old = meltt(:,:,iblk) + + call thermo_vertical & + (nx_block, ny_block, & + dt, icells, & + indxi, indxj, & + aicen(:,:,n,iblk), & + trcrn(:,:,:,n,iblk), & + vicen(:,:,n,iblk), vsnon(:,:,n,iblk), & + eicen (:,:,il1:il2,iblk), & + esnon (:,:,sl1:sl2,iblk), & + flw (:,:,iblk), potT (:,:,iblk), & + Qa (:,:,iblk), rhoa (:,:,iblk), & + fsnow (:,:,iblk), & + fbot, Tbot, & + lhcoef, shcoef, & + fswsfcn, fswintn, & + fswthrun, & + Sswabsn, Iswabsn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & + fswabsn, flwoutn, & + evapn, freshn, & + fsaltn, fhocnn, & + meltt (:,:,iblk), melts (:,:,iblk), & + meltb (:,:,iblk), & + congel (:,:,iblk), snoice (:,:,iblk), & + mlt_onset(:,:,iblk), frz_onset(:,:,iblk), & + yday, l_stop, & + istop, jstop) + + if (l_stop) then + write (nu_diag,*) 'istep1, my_task, iblk =', & + istep1, my_task, iblk + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + write(nu_diag,*) 'Lat, Lon:', & + TLAT(istop,jstop,iblk)*rad_to_deg, & + TLON(istop,jstop,iblk)*rad_to_deg + call abort_ice ('ice: Vertical thermo error') + endif + + !----------------------------------------------------------------- + ! Melt ponds + !----------------------------------------------------------------- + + if (tr_pond) then + + melts_tmp = melts(:,:,iblk) - melts_old + meltt_tmp = meltt(:,:,iblk) - meltt_old + + call compute_ponds(nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + meltt_tmp, melts_tmp, frain(:,:,iblk), & + aicen (:,:,n,iblk), vicen (:,:,n,iblk), & + vsnon (:,:,n,iblk), trcrn (:,:,:,n,iblk),& + apondn(:,:,n,iblk), hpondn(:,:,n,iblk)) + + endif + + !----------------------------------------------------------------- + ! Increment area-weighted fluxes. + !----------------------------------------------------------------- +#ifdef CICE_IN_NEMO + !----------------------------------------------------------------- + ! Note that for CICE_IN_NEMO, strairxT/yT = 0 as wind stress + ! supplied on u grid and set directly in evp + !----------------------------------------------------------------- +#endif + call merge_fluxes (nx_block, ny_block, & + icells, & + indxi, indxj, & + aicen_init(:,:,n,iblk), & + flw(:,:,iblk), coszen(:,:,iblk), & + alvdrn(:,:,n,iblk), alidrn(:,:,n,iblk), & + alvdfn(:,:,n,iblk), alidfn(:,:,n,iblk), & + strairxn, strairyn, & + fsurfn(:,:,n,iblk), fcondtopn(:,:,n,iblk),& + fsensn, flatn(:,:,n,iblk), & + fswabsn, flwoutn, & + evapn, & + Trefn, Qrefn, & + freshn, fsaltn, & + fhocnn, fswthrun, & + alvdr (:,:,iblk), alidr (:,:,iblk), & + alvdf (:,:,iblk), alidf (:,:,iblk), & + strairxT(:,:,iblk), strairyT (:,:,iblk), & + fsurf (:,:,iblk), fcondtop (:,:,iblk), & + fsens (:,:,iblk), flat (:,:,iblk), & + fswabs (:,:,iblk), flwout (:,:,iblk), & + evap (:,:,iblk), & + Tref (:,:,iblk), Qref (:,:,iblk), & + fresh (:,:,iblk), fresh_hist(:,:,iblk), & + fsalt (:,:,iblk), fsalt_hist(:,:,iblk), & + fhocn (:,:,iblk), fhocn_hist(:,:,iblk), & + fswthru (:,:,iblk), fswthru_hist(:,:,iblk)) + + enddo ! ncat + + !----------------------------------------------------------------- + ! Update mixed layer with heat and radiation from ice. + !----------------------------------------------------------------- + + if (oceanmixed_ice) then + do j = jlo, jhi + do i = ilo, ihi + if (hmix(i,j,iblk) > puny) then + sst(i,j,iblk) = sst(i,j,iblk) & + + (fhocn(i,j,iblk) + fswthru(i,j,iblk))*dt & + / (cprho*hmix(i,j,iblk)) + endif + enddo + enddo + endif + + !----------------------------------------------------------------- + ! Divide fluxes by ice area for the coupler, which assumes fluxes + ! are per unit ice area. + !----------------------------------------------------------------- + + call scale_fluxes (nx_block, ny_block, & + tmask (:,:,iblk), & + aice_init(:,:,iblk), Tf (:,:,iblk), & + Tair (:,:,iblk), Qa (:,:,iblk), & + strairxT (:,:,iblk), strairyT(:,:,iblk), & + fsens (:,:,iblk), flat (:,:,iblk), & + fswabs (:,:,iblk), flwout (:,:,iblk), & + evap (:,:,iblk), & + Tref (:,:,iblk), Qref (:,:,iblk), & + fresh (:,:,iblk), fsalt (:,:,iblk), & + fhocn (:,:,iblk), fswthru (:,:,iblk), & + alvdr (:,:,iblk), alidr (:,:,iblk), & + alvdf (:,:,iblk), alidf (:,:,iblk)) + + if (.not. calc_Tsfc) then + + !--------------------------------------------------------------- + ! If surface fluxes were provided, conserve these fluxes at ice + ! free points by passing to ocean. + !--------------------------------------------------------------- + + call sfcflux_to_ocn & + (nx_block, ny_block, & + tmask (:,:,iblk), aice_init(:,:,iblk), & + fsurfn_f (:,:,:,iblk), flatn_f(:,:,:,iblk), & + fresh (:,:,iblk), fresh_hist(:,:,iblk), & + fhocn (:,:,iblk), fhocn_hist(:,:,iblk)) + endif + + enddo ! iblk + + call ice_timer_stop(timer_thermo) ! thermodynamics + call ice_timer_stop(timer_column) ! column physics + + end subroutine step_therm1 + +!======================================================================= +!BOP +! +! !ROUTINE: step_therm2 - step post-coupler thermodynamics +! +! !DESCRIPTION: +! +!----------------------------------------------------------------------- +! Driver for thermodynamic changes not needed for coupling: +! transport in thickness space, lateral growth and melting. +! +! NOTE: Ocean fluxes are initialized here. +! +! !REVISION HISTORY: +! +! author: William H. Lipscomb, LANL +! +! !INTERFACE: + + subroutine step_therm2 (dt) +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: +! + real (kind=dbl_kind), intent(in) :: & + dt ! time step +! +!EOP +! +!lipscomb - delete hicen later? +! real (kind=dbl_kind), & +! dimension (nx_block,ny_block,ncat,max_blocks) :: & + + integer (kind=int_kind) :: & + iblk , & ! block index + ilo,ihi,jlo,jhi, & ! beginning and end of physical domain + i, j, n + + integer (kind=int_kind), save :: & + icells ! number of ice/ocean cells + + integer (kind=int_kind), dimension(nx_block*ny_block), save :: & + indxi, indxj ! indirect indices for ice/ocean cells + + type (block) :: & + this_block ! block information for current block + + logical (kind=log_kind) :: & + l_stop ! if true, abort model + + integer (kind=int_kind) :: & + istop, jstop ! indices of grid cell where model aborts + + call ice_timer_start(timer_column) ! column physics + call ice_timer_start(timer_thermo) ! thermodynamics + + call init_flux_ocn ! initialize ocean fluxes sent to coupler + + l_stop = .false. + + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + !----------------------------------------------------------------- + ! Let rain drain through to the ocean. + !----------------------------------------------------------------- + + do j = 1, ny_block + do i = 1, nx_block + fresh (i,j,iblk) = fresh(i,j,iblk) & + + frain(i,j,iblk)*aice(i,j,iblk) + fresh_hist(i,j,iblk) = fresh_hist(i,j,iblk) & + + frain(i,j,iblk)*aice(i,j,iblk) + enddo + enddo + + !----------------------------------------------------------------- + ! Given thermodynamic growth rates, transport ice between + ! thickness categories. + !----------------------------------------------------------------- + + call ice_timer_start(timer_catconv) ! category conversions + + + if (kitd == 1) then + !----------------------------------------------------------------- + ! Compute fractional ice area in each grid cell. + !----------------------------------------------------------------- + call aggregate_area (nx_block, ny_block, & + aicen(:,:,:,iblk), & + aice (:,:, iblk), aice0(:,:,iblk)) + + !----------------------------------------------------------------- + ! Identify grid cells with ice. + !----------------------------------------------------------------- + + icells = 0 + do j = jlo,jhi + do i = ilo,ihi + if (aice(i,j,iblk) > puny) then + icells = icells + 1 + indxi(icells) = i + indxj(icells) = j + endif + enddo + enddo + + if (icells > 0) then + + call linear_itd (nx_block, ny_block, & + icells, indxi, indxj, & + trcr_depend, & + aicen_init(:,:,:,iblk), & + vicen_init(:,:,:,iblk), & + aicen (:,:,:,iblk), & + trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), & + vsnon (:,:,:,iblk), & + eicen (:,:,:,iblk), & + esnon (:,:,:,iblk), & + aice (:,:, iblk), & + aice0 (:,:, iblk), & + l_stop, & + istop, jstop) + if (l_stop) then + write (nu_diag,*) 'istep1, my_task, iblk =', & + istep1, my_task, iblk + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice ('ice: Linear ITD error') + endif + + endif + + endif + + call ice_timer_stop(timer_catconv) ! category conversions + + !----------------------------------------------------------------- + ! Add frazil ice growing in leads. + !----------------------------------------------------------------- + + ! identify ice-ocean cells + icells = 0 + do j = 1, ny_block + do i = 1, nx_block + if (tmask(i,j,iblk)) then + icells = icells + 1 + indxi(icells) = i + indxj(icells) = j + endif + enddo ! i + enddo ! j + + call add_new_ice (nx_block, ny_block, & + icells, & + indxi, indxj, & + tmask (:,:, iblk), dt, & + aicen (:,:,:,iblk), & + trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), & + eicen (:,:,:,iblk), & + aice0 (:,:, iblk), & + aice (:,:, iblk), & + frzmlt (:,:, iblk), & + frazil (:,:, iblk), & + frz_onset (:,:, iblk), yday, & + fresh (:,:, iblk), & + fresh_hist(:,:, iblk), & + fsalt (:,:, iblk), & + fsalt_hist(:,:, iblk), & + Tf (:,:, iblk), l_stop, & + istop , jstop) + + if (l_stop) then + write (nu_diag,*) 'istep1, my_task, iblk =', & + istep1, my_task, iblk + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice ('ice: add_new_ice error') + endif + + !----------------------------------------------------------------- + ! Melt ice laterally. + !----------------------------------------------------------------- + call lateral_melt (nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + dt, & + fresh (:,:, iblk), & + fsalt (:,:, iblk), & + fhocn (:,:, iblk), & + fresh_hist(:,:, iblk), & + fsalt_hist(:,:, iblk), & + fhocn_hist(:,:, iblk), & + rside (:,:, iblk), & + meltl (:,:, iblk), & + aicen (:,:,:,iblk), & + vicen (:,:,:,iblk), & + vsnon (:,:,:,iblk), & + eicen (:,:,:,iblk), & + esnon (:,:,:,iblk) ) + + !----------------------------------------------------------------- + ! For the special case of a single category, adjust the area and + ! volume (assuming that half the volume change decreases the + ! thickness, and the other half decreases the area). + !----------------------------------------------------------------- + +!NOTE - this does not work - hicen_init is not defined - ECH + +! if (ncat==1) & +! call reduce_area (nx_block, ny_block, & +! ilo, ihi, jlo, jhi, & +! tmask (:,:, iblk), & +! aicen (:,:,:,iblk), & +! vicen (:,:,:,iblk), & +! hicen_init(:,:,1,iblk), & +! hicen (:,:,1,iblk)) + + !----------------------------------------------------------------- + ! ITD cleanup: Rebin thickness categories if necessary, and remove + ! categories with very small areas. + !----------------------------------------------------------------- + + call cleanup_itd (nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + dt, & + aicen (:,:,:,iblk), trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), vsnon (:,:, :,iblk), & + eicen (:,:,:,iblk), esnon (:,:, :,iblk), & + aice0 (:,:, iblk), aice (:,:,iblk), & + trcr_depend, & + fresh (:,:, iblk), fresh_hist(:,:,iblk), & + fsalt (:,:, iblk), fsalt_hist(:,:,iblk), & + fhocn (:,:, iblk), fhocn_hist(:,:,iblk), & + heat_capacity, l_stop, & + istop, jstop) + + if (l_stop) then + write (nu_diag,*) 'istep1, my_task, iblk =', & + istep1, my_task, iblk + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice ('ice: ITD cleanup error') + endif + + enddo ! iblk + + !------------------------------------------------------------------- + ! Ghost cell updates for state variables. + !------------------------------------------------------------------- + + call ice_timer_start(timer_bound) + call bound_state (aicen, trcrn, & + vicen, vsnon, & + eicen, esnon) + call ice_timer_stop(timer_bound) + + do iblk = 1, nblocks + + !----------------------------------------------------------------- + ! Aggregate the updated state variables (includes ghost cells). + !----------------------------------------------------------------- + + call aggregate (nx_block, ny_block, & + aicen(:,:,:,iblk), trcrn(:,:,:,:,iblk), & + vicen(:,:,:,iblk), vsnon(:,:, :,iblk), & + eicen(:,:,:,iblk), esnon(:,:, :,iblk), & + aice (:,:, iblk), trcr (:,:,:, iblk), & + vice (:,:, iblk), vsno (:,:, iblk), & + eice (:,:, iblk), esno (:,:, iblk), & + aice0(:,:, iblk), tmask(:,:, iblk), & + trcr_depend) + + !----------------------------------------------------------------- + ! Compute thermodynamic area and volume tendencies. + !----------------------------------------------------------------- + + do j = 1, ny_block + do i = 1, nx_block + daidtt(i,j,iblk) = (aice(i,j,iblk) - daidtt(i,j,iblk)) / dt + dvidtt(i,j,iblk) = (vice(i,j,iblk) - dvidtt(i,j,iblk)) / dt + enddo + enddo + + enddo ! iblk + + call ice_timer_stop(timer_thermo) ! thermodynamics + call ice_timer_stop(timer_column) ! column physics + + end subroutine step_therm2 + +!======================================================================= +!BOP +! +! !ROUTINE: step_dynamics - step ice dynamics, transport, and ridging +! +! !DESCRIPTION: +! +! Run one time step of dynamics, horizontal transport, and ridging. +! NOTE: The evp and transport modules include boundary updates, so +! they cannot be done inside a single block loop. Ridging +! and cleanup, on the other hand, are single-column operations. +! They are called with argument lists inside block loops +! to increase modularity. +! +! !REVISION HISTORY: +! +! authors: William H. Lipscomb, LANL +! +! !INTERFACE: + + subroutine step_dynamics (dt) +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: +! + real (kind=dbl_kind), intent(in) :: & + dt ! time step +! +!EOP +! + type (block) :: & + this_block ! block information for current block + + integer (kind=int_kind) :: & + iblk , & ! block index + i,j , & ! horizontal indices + ilo,ihi,jlo,jhi ! beginning and end of physical domain + + integer (kind=int_kind), save :: & + icells ! number of cells with aicen > puny + + integer (kind=int_kind), dimension(nx_block*ny_block), save :: & + indxi, indxj ! indirect indices for cells with aicen > puny + + logical (kind=log_kind) :: & + l_stop ! if true, abort model + + integer (kind=int_kind) :: & + istop, jstop ! indices of grid cell where model aborts + + call init_history_dyn ! initialize dynamic history variables + + !----------------------------------------------------------------- + ! Elastic-viscous-plastic ice dynamics + !----------------------------------------------------------------- + + if (kdyn == 1) call evp (dt) + + !----------------------------------------------------------------- + ! Horizontal ice transport + !----------------------------------------------------------------- + + if (advection == 'upwind') then + call transport_upwind (dt) ! upwind + else + call transport_remap (dt) ! incremental remapping + endif + + !----------------------------------------------------------------- + ! Ridging + !----------------------------------------------------------------- + + call ice_timer_start(timer_column) + call ice_timer_start(timer_ridge) + + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk), iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + !----------------------------------------------------------------- + ! Identify ice-ocean cells. + ! Note: We can not define icells here using aice>puny because + ! aice has not yet been updated since the transport (and + ! it may be out of whack, which the ridging helps fix).-ECH + !----------------------------------------------------------------- + + icells = 0 + do j = jlo, jhi + do i = ilo, ihi + if (tmask(i,j,iblk)) then + icells = icells + 1 + indxi(icells) = i + indxj(icells) = j + endif + enddo ! i + enddo ! j + + if (icells > 0) then + + call ridge_ice (nx_block, ny_block, & + dt, icells, & + indxi, indxj, & +!! Delt (:,:, iblk), divu (:,:, iblk), & + rdg_conv(:,:, iblk), rdg_shear (:,:, iblk), & + aicen (:,:,:,iblk), trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), vsnon (:,:,:,iblk), & + eicen (:,:,:,iblk), esnon (:,:,:,iblk), & + aice0 (:,:, iblk), & + trcr_depend, l_stop, & + istop, jstop, & + dardg1dt(:,:,iblk), dardg2dt (:,:,iblk), & + dvirdgdt(:,:,iblk), opening (:,:,iblk), & + fresh (:,:,iblk), fresh_hist(:,:,iblk), & + fhocn (:,:,iblk), fhocn_hist(:,:,iblk)) + + if (l_stop) then + write (nu_diag,*) 'istep1, my_task, iblk =', & + istep1, my_task, iblk + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice ('ice: Ridging error') + endif + + endif + + enddo ! iblk + + call ice_timer_stop(timer_ridge) + + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk), iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + !----------------------------------------------------------------- + ! ITD cleanup: Rebin thickness categories if necessary, and remove + ! categories with very small areas. + !----------------------------------------------------------------- + + call cleanup_itd (nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + dt, & + aicen (:,:,:,iblk), trcrn (:,:,:,:,iblk), & + vicen (:,:,:,iblk), vsnon (:,:, :,iblk), & + eicen (:,:,:,iblk), esnon (:,:, :,iblk), & + aice0 (:,:, iblk), aice (:,:,iblk), & + trcr_depend, & + fresh (:,:, iblk), fresh_hist(:,:,iblk), & + fsalt (:,:, iblk), fsalt_hist(:,:,iblk), & + fhocn (:,:, iblk), fhocn_hist(:,:,iblk), & + heat_capacity, l_stop, & + istop, jstop) + + if (l_stop) then + write (nu_diag,*) 'istep1, my_task, iblk =', & + istep1, my_task, iblk + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice ('ice: ITD cleanup error') + endif + + enddo ! iblk + + !------------------------------------------------------------------- + ! Ghost cell updates for state variables. + !------------------------------------------------------------------- + + call ice_timer_start(timer_bound) + call bound_state (aicen, trcrn, & + vicen, vsnon, & + eicen, esnon) + call ice_timer_stop(timer_bound) + + !----------------------------------------------------------------- + ! Aggregate the updated state variables (includes ghost cells). + !----------------------------------------------------------------- + + do iblk = 1, nblocks + call aggregate (nx_block, ny_block, & + aicen(:,:,:,iblk), trcrn(:,:,:,:,iblk), & + vicen(:,:,:,iblk), vsnon(:,:, :,iblk), & + eicen(:,:,:,iblk), esnon(:,:, :,iblk), & + aice (:,:, iblk), trcr (:,:,:, iblk), & + vice (:,:, iblk), vsno (:,:, iblk), & + eice (:,:, iblk), esno (:,:, iblk), & + aice0(:,:, iblk), tmask(:,:, iblk), & + trcr_depend) + enddo + + call ice_timer_stop(timer_column) + + !---------------------------------------------------------------- + ! Store grid box mean fluxes before scaled by aice_init + !---------------------------------------------------------------- + + fresh_hist_gbm (:,:,:) = fresh_hist (:,:,:) + fsalt_hist_gbm (:,:,:) = fsalt_hist (:,:,:) + fhocn_hist_gbm (:,:,:) = fhocn_hist (:,:,:) + fswthru_hist_gbm(:,:,:) = fswthru_hist(:,:,:) + + call scale_hist_fluxes ! to match coupler fluxes + + end subroutine step_dynamics + +!======================================================================= +!BOP +! +! !ROUTINE: set_sfcflux - set surface fluxes from forcing fields +! +! !DESCRIPTION: +! +! If model is not calculating surface temperature, set the surface +! flux values using values read in from forcing data or supplied via +! coupling (stored in ice_flux). +! +! If CICE is running in NEMO environment, convert fluxes from GBM values +! to per unit ice area values. If model is not running in NEMO environment, +! the forcing is supplied as per unit ice area values. +! +! !REVISION HISTORY: +! +! authors Alison McLaren, Met Office +! +! !INTERFACE: +! + subroutine set_sfcflux (nx_block, ny_block, & + n, iblk, & + icells, & + indxi, indxj, & + aicen, & + flatn, & + fsurfn, & + fcondtopn) +! +! !USES: +! +! +! !INPUT/OUTPUT PARAMETERS: +! + integer (kind=int_kind), intent(in) :: & + nx_block, ny_block, & ! block dimensions + n, & ! thickness category index + iblk, & ! block index + icells ! number of cells with aicen > puny + + integer (kind=int_kind), dimension(nx_block*ny_block), & + intent(in) :: & + indxi, indxj ! compressed indices for cells with aicen > puny + + ! ice state variables + real (kind=dbl_kind), dimension (nx_block,ny_block), & + intent(in) :: & + aicen ! concentration of ice + + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out):: & + flatn , & ! latent heat flux (W/m^2) + fsurfn , & ! net flux to top surface, not including fcondtopn + fcondtopn ! downward cond flux at top surface (W m-2) + + integer (kind=int_kind) :: & + i, j , & ! horizontal indices + ij ! horizontal indices, combine i and j loops + +#ifdef CICE_IN_NEMO + real (kind=dbl_kind) :: & + raicen ! 1/aicen +#endif + + logical (kind=log_kind) :: & + extreme_flag ! flag for extreme forcing values + + logical (kind=log_kind), parameter :: & + extreme_test=.true. ! test and write out extreme forcing data +! +!EOP +! +#ifdef CICE_IN_NEMO + +!---------------------------------------------------------------------- +! Convert fluxes from GBM values to per ice area values when +! running in NEMO environment. (When in standalone mode, fluxes +! are input as per ice area.) +!---------------------------------------------------------------------- + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + raicen = c1 / aicen(i,j) + fsurfn(i,j) = fsurfn_f(i,j,n,iblk)*raicen + fcondtopn(i,j)= fcondtopn_f(i,j,n,iblk)*raicen + flatn(i,j) = flatn_f(i,j,n,iblk)*raicen + + enddo +#else + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + fsurfn(i,j) = fsurfn_f(i,j,n,iblk) + fcondtopn(i,j)= fcondtopn_f(i,j,n,iblk) + flatn(i,j) = flatn_f(i,j,n,iblk) + + enddo +#endif + +!---------------------------------------------------------------- +! Flag up any extreme fluxes +!--------------------------------------------------------------- + + if (extreme_test) then + extreme_flag = .false. + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + if (fcondtopn(i,j) < -100.0_dbl_kind & + .or. fcondtopn(i,j) > 20.0_dbl_kind) then + extreme_flag = .true. + endif + + if (fsurfn(i,j) < -100.0_dbl_kind & + .or. fsurfn(i,j) > 80.0_dbl_kind) then + extreme_flag = .true. + endif + + if (flatn(i,j) < -20.0_dbl_kind & + .or. flatn(i,j) > 20.0_dbl_kind) then + extreme_flag = .true. + endif + + enddo ! ij + + if (extreme_flag) then + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + if (fcondtopn(i,j) < -100.0_dbl_kind & + .or. fcondtopn(i,j) > 20.0_dbl_kind) then + write(nu_diag,*) & + 'Extreme forcing: -100 > fcondtopn > 20' + write(nu_diag,*) & + 'i,j,n,iblk,aicen,fcondtopn = ', & + i,j,n,iblk,aicen(i,j),fcondtopn(i,j) + endif + + if (fsurfn(i,j) < -100.0_dbl_kind & + .or. fsurfn(i,j) > 80.0_dbl_kind) then + write(nu_diag,*) & + 'Extreme forcing: -100 > fsurfn > 40' + write(nu_diag,*) & + 'i,j,n,iblk,aicen,fsurfn = ', & + i,j,n,iblk,aicen(i,j),fsurfn(i,j) + endif + + if (flatn(i,j) < -20.0_dbl_kind & + .or. flatn(i,j) > 20.0_dbl_kind) then + write(nu_diag,*) & + 'Extreme forcing: -20 > flatn > 20' + write(nu_diag,*) & + 'i,j,n,iblk,aicen,flatn = ', & + i,j,n,iblk,aicen(i,j),flatn(i,j) + endif + + enddo ! ij + + endif ! extreme_flag + endif ! extreme_test + + end subroutine set_sfcflux + +!======================================================================= +!BOP +! +! !IROUTINE: sfcflux_to_ocn +! +! !DESCRIPTION: +! +! If surface heat fluxes are provided to CICE instead of CICE calculating +! them internally (i.e. .not. calc_Tsfc), then these heat fluxes can +! be provided at points which do not have ice. (This is could be due to +! the heat fluxes being calculated on a lower resolution grid or the +! heat fluxes not recalculated at every CICE timestep.) At ice free points, +! conserve energy and water by passing these fluxes to the ocean. +! +! !INTERFACE: +! + subroutine sfcflux_to_ocn(nx_block, ny_block, & + tmask, aice, & + fsurfn_f, flatn_f, & + fresh, fresh_hist, & + fhocn, fhocn_hist) + +! +! !REVISION HISTORY: +! +! authors: A. McLaren, Met Office +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: + integer (kind=int_kind), intent(in) :: & + nx_block, ny_block ! block dimensions + + logical (kind=log_kind), dimension (nx_block,ny_block), & + intent(in) :: & + tmask ! land/boundary mask, thickness (T-cell) + + real (kind=dbl_kind), dimension(nx_block,ny_block), & + intent(in):: & + aice ! initial ice concentration + + real (kind=dbl_kind), dimension(nx_block,ny_block,ncat), & + intent(in) :: & + fsurfn_f, & ! net surface heat flux (provided as forcing) + flatn_f ! latent heat flux (provided as forcing) + + real (kind=dbl_kind), dimension(nx_block,ny_block), & + intent(inout):: & + fresh , & ! fresh water flux to ocean (kg/m2/s) + fhocn , & ! actual ocn/ice heat flx (W/m**2) + fresh_hist , & ! fresh water flux to ocean(history)(kg/m2/s) + fhocn_hist ! actual ocn/ice heat flx(history) (W/m**2) +! +!EOP +! +#ifdef CICE_IN_NEMO + integer (kind=int_kind) :: & + i, j, n ! horizontal indices + + real (kind=dbl_kind) :: & + rLsub ! 1/Lsub + + rLsub = c1 / Lsub + + do n = 1, ncat + do j = 1, ny_block + do i = 1, nx_block + if (tmask(i,j) .and. aice(i,j) <= puny) then + fhocn(i,j) = fhocn(i,j) & + + fsurfn_f(i,j,n) + flatn_f(i,j,n) + fhocn_hist(i,j) = fhocn_hist(i,j) & + + fsurfn_f(i,j,n) + flatn_f(i,j,n) + fresh(i,j) = fresh(i,j) & + + flatn_f(i,j,n) * rLsub + fresh_hist(i,j) = fresh_hist(i,j) & + + flatn_f(i,j,n) * rLsub + endif + enddo ! i + enddo ! j + enddo ! n + +#endif + end subroutine sfcflux_to_ocn + +!======================================================================= + + end module CICE_RunMod + +!======================================================================= diff --git a/cice/input_templates/gx1/ice_in b/cice/input_templates/gx1/ice_in index abde521..2762fe5 100644 --- a/cice/input_templates/gx1/ice_in +++ b/cice/input_templates/gx1/ice_in @@ -42,6 +42,7 @@ , albicei = 0.36 , albsnowv = 0.98 , albsnowi = 0.70 + , heat_capacity= .true. , atmbndy = 'default' , fyear_init = 1981 , ycycle = 1 @@ -49,7 +50,10 @@ , atm_data_type= 'LYq' , atm_data_dir = '/scratch2/eclare/DATA/gx1v3/LargeYeager/' , calc_strair = .true. + , calc_Tsfc = .true. , precip_units = 'mm_per_sec' + , Tfrzpt = 'linear_S' + , update_ocn_f = .false. , oceanmixed_ice = .true. , ocn_data_format = 'bin' , sss_data_type= 'default' @@ -67,8 +71,8 @@ &domain_nml nprocs = 8 - , processor_shape = 'slenderX2' - , distribution_type = 'cartesian' + , processor_shape = 'square-ice' + , distribution_type = 'rake' , distribution_wght = 'latitude' , ew_boundary_type = 'cyclic' , ns_boundary_type = 'open' @@ -82,7 +86,19 @@ / &icefields_nml - f_hi = .true. + f_tmask = .true. + , f_tarea = .true. + , f_uarea = .true. + , f_dxt = .false. + , f_dyt = .false. + , f_dxu = .false. + , f_dyu = .false. + , f_HTN = .false. + , f_HTE = .false. + , f_ANGLE = .true. + , f_ANGLET = .true. + , f_bounds = .false. + , f_hi = .true. , f_hs = .true. , f_Tsfc = .true. , f_aice = .true. @@ -129,6 +145,9 @@ , f_fhocn_ai = .true. , f_fswthru = .false. , f_fswthru_ai= .true. + , f_fsurf_ai = .false. + , f_fcondtop_ai= .false. + , f_fmeltt_ai = .false. , f_strairx = .true. , f_strairy = .true. , f_strtltx = .false. @@ -161,4 +180,8 @@ , f_iage = .false. , f_aicen = .false. , f_vicen = .false. + , f_fsurfn_ai = .false. + , f_fcondtopn_ai = .false. + , f_fmelttn_ai = .false. + , f_flatn_ai = .false. / diff --git a/cice/input_templates/gx3/ice_in b/cice/input_templates/gx3/ice_in index 61e90c9..917d971 100644 --- a/cice/input_templates/gx3/ice_in +++ b/cice/input_templates/gx3/ice_in @@ -42,6 +42,7 @@ , albicei = 0.36 , albsnowv = 0.98 , albsnowi = 0.70 + , heat_capacity= .true. , atmbndy = 'default' , fyear_init = 1997 , ycycle = 1 @@ -49,7 +50,10 @@ , atm_data_type= 'ncar' , atm_data_dir = '/scratch2/eclare/DATA/gx3v2m/atm/NCAR_bulk/' , calc_strair = .true. + , calc_Tsfc = .true. , precip_units = 'mm_per_month' + , Tfrzpt = 'linear_S' + , update_ocn_f = .false. , oceanmixed_ice = .true. , ocn_data_format = 'bin' , sss_data_type= 'clim' @@ -82,7 +86,19 @@ / &icefields_nml - f_hi = .true. + f_tmask = .true. + , f_tarea = .true. + , f_uarea = .true. + , f_dxt = .false. + , f_dyt = .false. + , f_dxu = .false. + , f_dyu = .false. + , f_HTN = .false. + , f_HTE = .false. + , f_ANGLE = .true. + , f_ANGLET = .true. + , f_bounds = .false. + , f_hi = .true. , f_hs = .true. , f_Tsfc = .true. , f_aice = .true. @@ -129,6 +145,9 @@ , f_fhocn_ai = .true. , f_fswthru = .false. , f_fswthru_ai= .true. + , f_fsurf_ai = .false. + , f_fcondtop_ai= .false. + , f_fmeltt_ai = .false. , f_strairx = .true. , f_strairy = .true. , f_strtltx = .false. @@ -161,4 +180,8 @@ , f_iage = .false. , f_aicen = .false. , f_vicen = .false. + , f_fsurfn_ai = .false. + , f_fcondtopn_ai = .false. + , f_fmelttn_ai = .false. + , f_flatn_ai = .false. / diff --git a/cice/mpi/ice_communicate.F90 b/cice/mpi/ice_communicate.F90 index 0b5913e..571867b 100644 --- a/cice/mpi/ice_communicate.F90 +++ b/cice/mpi/ice_communicate.F90 @@ -22,6 +22,14 @@ module ice_communicate use cpl_fields_mod, only : cpl_fields_icename #endif +#if defined key_oasis3 + use cpl_oasis3 +#endif + +#if defined key_oasis4 + use cpl_oasis4 +#endif + implicit none private save @@ -79,6 +87,8 @@ subroutine init_communicate integer (int_kind) :: ierr ! MPI error flag + integer (int_kind) :: ice_comm + !----------------------------------------------------------------------- ! ! initiate mpi environment and create communicator for internal @@ -86,21 +96,25 @@ subroutine init_communicate ! !----------------------------------------------------------------------- -#if (defined CCSM) || (defined SEQ_MCT) +#if (defined key_oasis3 || defined key_oasis4) + ice_comm = localComm ! communicator from NEMO/OASISn +#else + ice_comm = MPI_COMM_WORLD ! Global communicator +#endif +#if (defined CCSM) || (defined SEQ_MCT) ! CCSM standard coupled mode call cpl_interface_init(cpl_fields_icename, MPI_COMM_ICE) - #else -#ifdef popcice - ! LANL directly coupled POP and CICE: POP calls MPI_INIT +#if (defined popcice || defined CICE_IN_NEMO) + ! MPI_INIT is called elsewhere in coupled configuration #else call MPI_INIT(ierr) - call MPI_BARRIER(MPI_COMM_WORLD,ierr) #endif - call MPI_COMM_DUP(MPI_COMM_WORLD, MPI_COMM_ICE, ierr) + call MPI_BARRIER (ice_comm, ierr) + call MPI_COMM_DUP(ice_comm, MPI_COMM_ICE, ierr) #endif diff --git a/cice/source/ice_constants.F90 b/cice/source/ice_constants.F90 index de3f30f..834bd9c 100644 --- a/cice/source/ice_constants.F90 +++ b/cice/source/ice_constants.F90 @@ -92,16 +92,29 @@ module ice_constants emissivity= 0.95_dbl_kind ,&! emissivity of snow and ice cp_ice = 2106._dbl_kind ,&! specific heat of fresh ice (J/kg/K) cp_ocn = 4218._dbl_kind ,&! specific heat of ocn (J/kg/K) + ! freshwater value needed for enthalpy depressT = 0.054_dbl_kind ,&! Tf:brine salinity ratio (C/ppt) dragio = 0.00536_dbl_kind ,&! ice-ocn drag coefficient albocn = 0.06_dbl_kind ! ocean albedo #endif + + real (kind=dbl_kind), parameter :: & +#ifdef HADGEM3 + gravit = 9.80665_dbl_kind ,&! gravitational acceleration (m/s^2) + omega = 7.292116e-5_dbl_kind,&! angular velocity of earth (rad/sec) + radius = 6.371229e6_dbl_kind ! earth radius (m) +#else +! CICE default parameters + gravit = 9.80616_dbl_kind ,&! gravitational acceleration (m/s^2) + omega = 7.292e-5_dbl_kind ,&! angular velocity of earth (rad/sec) + radius = 6.37e6_dbl_kind ! earth radius (m) +#endif + real (kind=dbl_kind), parameter :: & pi = 3.14159265358979323846_dbl_kind,&! pi - gravit = 9.80616_dbl_kind ,&! gravitational acceleration (m/s^2) secday = 86400.0_dbl_kind ,&! seconds in calendar day - omega = 7.292e-5_dbl_kind,&! angular velocity of earth (rad/sec) - radius = 6.37e6_dbl_kind ,&! earth radius (m) + Tocnfrz = -1.8_dbl_kind ,&! freezing temp of seawater (C), + ! used as Tsfcn for open water rhofresh = 1000.0_dbl_kind ,&! density of fresh water (kg/m^3) zvir = 0.606_dbl_kind ,&! rh2o/rair - 1.0 vonkar = 0.4_dbl_kind ,&! von Karman constant @@ -130,10 +143,14 @@ module ice_constants kappan = 17.6_dbl_kind,&! vis extnctn coef in ice, wvlngth<700nm (1/m) kice = 2.03_dbl_kind ,&! thermal conductivity of fresh ice(W/m/deg) + kseaice= 2.00_dbl_kind ,&! thermal conductivity of sea ice (W/m/deg) + ! (used in zero layer thermodynamics option) +#ifdef HADGEM3 + ksno = 0.31_dbl_kind ,&! thermal conductivity of snow (W/m/deg) +#else ksno = 0.30_dbl_kind ,&! thermal conductivity of snow (W/m/deg) +#endif zref = 10._dbl_kind ,&! reference height for stability (m) - Tocnfrz= -34.0_dbl_kind*depressT,&! freezing temp of seawater (C), - ! used as Tsfcn for open water snowpatch = 0.02_dbl_kind ! parameter for fractional snow area (m) real (kind=dbl_kind), parameter :: & diff --git a/cice/source/ice_diagnostics.F90 b/cice/source/ice_diagnostics.F90 index 9208721..fb68528 100644 --- a/cice/source/ice_diagnostics.F90 +++ b/cice/source/ice_diagnostics.F90 @@ -45,9 +45,9 @@ module ice_diagnostics integer (kind=int_kind), parameter :: & npnt = 2 ! total number of points to be printed -!lipscomb - set to false for testing + ! Set to true to identify unstable fast-moving ice. logical (kind=log_kind), parameter :: & - check_umax = .false. ! if true, check for speed > umax_stab + check_umax = .false. ! if true, check for speed > umax_stab real (kind=dbl_kind), parameter :: & umax_stab = 1.0_dbl_kind , & ! ice speed threshold for instability (m/s) @@ -124,6 +124,7 @@ subroutine runtime_diags (dt) use ice_state use ice_grid, only: lmask_n, lmask_s, tarean, tareas, grid_type use ice_work, only: work1, work2 + use ice_therm_vertical, only: calc_Tsfc #if (defined CCSM) || (defined SEQ_MCT) use ice_prescribed_mod, only : prescribed_ice @@ -162,7 +163,7 @@ subroutine runtime_diags (dt) real (kind=dbl_kind), dimension(npnt) :: & paice, pTair, pQa, pfsnow, pfrain, pfsw, pflw, & pTsfc, pevap, pfswabs, pflwout, pflat, pfsens, & - psst, pTf, hiavg, hsavg, pfhocn, & + pfsurf, pfcondtop, psst, pTf, hiavg, hsavg, pfhocn, & pmeltt, pmeltb, pmeltl, psnoice, pfrazil, pcongel !----------------------------------------------------------------- @@ -365,8 +366,7 @@ subroutine runtime_diags (dt) !----------------------------------------------------------------- ! various fluxes !----------------------------------------------------------------- - ! evap, fsalt, fresh, fhocn, fswthru, fsens, and flwout - ! need to be multiplied by aice because + ! evap, fsens, and flwout need to be multiplied by aice because ! regrettably they have been divided by aice for the coupler !----------------------------------------------------------------- @@ -380,26 +380,26 @@ subroutine runtime_diags (dt) evps = evps*dt ! salt flux - sfsaltn = global_sum_prod(fsalt_hist, aice_init, distrb_info, & + sfsaltn = global_sum(fsalt_hist_gbm, distrb_info, & field_loc_center, tarean) - sfsalts = global_sum_prod(fsalt_hist, aice_init, distrb_info, & + sfsalts = global_sum(fsalt_hist_gbm, distrb_info, & field_loc_center, tareas) sfsaltn = sfsaltn*dt sfsalts = sfsalts*dt ! fresh water flux - sfreshn = global_sum_prod(fresh_hist, aice_init, distrb_info, & + sfreshn = global_sum(fresh_hist_gbm, distrb_info, & field_loc_center, tarean) - sfreshs = global_sum_prod(fresh_hist, aice_init, distrb_info, & + sfreshs = global_sum(fresh_hist, distrb_info, & field_loc_center, tareas) sfreshn = sfreshn*dt sfreshs = sfreshs*dt ! ocean heat ! Note: fswthru not included because it does not heat ice - fhocnn = global_sum_prod(fhocn_hist, aice_init, distrb_info, & + fhocnn = global_sum(fhocn_hist_gbm, distrb_info, & field_loc_center, tarean) - fhocns = global_sum_prod(fhocn_hist, aice_init, distrb_info, & + fhocns = global_sum(fhocn_hist, distrb_info, & field_loc_center, tareas) ! latent heat @@ -414,16 +414,33 @@ subroutine runtime_diags (dt) ! Also note: fswabs includes solar radiation absorbed in ocean, ! which must be subtracted here. - do iblk = 1, nblocks - do j = 1, ny_block - do i = 1, nx_block - work1(i,j,iblk) = & + if (calc_Tsfc) then + + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = & (fswabs(i,j,iblk) - fswthru_hist(i,j,iblk) & + flw (i,j,iblk) + flwout (i,j,iblk) & + fsens (i,j,iblk)) * aice_init(i,j,iblk) + enddo + enddo enddo + + else ! fsurf is computed by atmosphere model + + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = & + (fsurf(i,j,iblk) - flat(i,j,iblk)) & + * aice_init(i,j,iblk) + enddo + enddo enddo - enddo + + endif ! calc_Tsfc + fhatmn = global_sum(work1, distrb_info, & field_loc_center, tarean) fhatms = global_sum(work1, distrb_info, & @@ -481,18 +498,31 @@ subroutine runtime_diags (dt) delmin = mtotn - totmn delmis = mtots - totms - ! ice mass change excluding frazil ice formation - delmxn = micen - totmin - frzn - delmxs = mices - totmis - frzs + ! ice mass change including frazil ice formation + delmxn = micen - totmin + delmxs = mices - totmis + if (.not. update_ocn_f) then + ! ice mass change excluding frazil ice formation + delmxn = delmxn - frzn + delmxs = delmxs - frzs + endif ! total water flux fluxn = c0 fluxs = c0 if( arean > c0) then - fluxn = rnn + snn + evpn - sfreshn + frzn + ! water associated with frazil ice included in fresh + fluxn = rnn + snn + evpn - sfreshn + if (.not. update_ocn_f) then + fluxn = fluxn + frzn + endif endif if( areas > c0) then - fluxs = rns + sns + evps - sfreshs + frzs + ! water associated with frazil ice included in fresh + fluxs = rns + sns + evps - sfreshs + if (.not. update_ocn_f) then + fluxs = fluxs + frzs + endif endif werrn = (fluxn-delmin)/(mtotn+c1) @@ -515,7 +545,7 @@ subroutine runtime_diags (dt) msltn = micen*ice_ref_salinity*p001 mslts = mices*ice_ref_salinity*p001 - ! change in salt mass, excluding frazil + ! change in salt mass delmsltn = delmxn*ice_ref_salinity*p001 delmslts = delmxs*ice_ref_salinity*p001 @@ -558,6 +588,8 @@ subroutine runtime_diags (dt) pflwout(n) = flwout(i,j,iblk) ! outward longwave flux pflat(n) = flat(i,j,iblk) ! latent heat flux pfsens(n) = fsens(i,j,iblk) ! sensible heat flux + pfsurf(n) = fsurf(i,j,iblk) ! total sfc heat flux + pfcondtop(n) = fcondtop(i,j,iblk) ! top sfc cond flux pmeltt(n) = meltt(i,j,iblk) ! top melt pmeltb(n) = meltb(i,j,iblk) ! bottom melt pmeltl(n) = meltl(i,j,iblk) ! lateral melt @@ -574,33 +606,35 @@ subroutine runtime_diags (dt) endif ! my_task = pmloc - call broadcast_scalar(pTair (n), pmloc(n)) - call broadcast_scalar(pQa (n), pmloc(n)) - call broadcast_scalar(pfsnow (n), pmloc(n)) - call broadcast_scalar(pfrain (n), pmloc(n)) - call broadcast_scalar(pfsw (n), pmloc(n)) - call broadcast_scalar(pflw (n), pmloc(n)) - call broadcast_scalar(paice (n), pmloc(n)) - call broadcast_scalar(hsavg (n), pmloc(n)) - call broadcast_scalar(hiavg (n), pmloc(n)) - call broadcast_scalar(pTsfc (n), pmloc(n)) - call broadcast_scalar(pevap (n), pmloc(n)) - call broadcast_scalar(pfswabs (n), pmloc(n)) - call broadcast_scalar(pflwout (n), pmloc(n)) - call broadcast_scalar(pflat (n), pmloc(n)) - call broadcast_scalar(pfsens (n), pmloc(n)) - call broadcast_scalar(pmeltt (n), pmloc(n)) - call broadcast_scalar(pmeltb (n), pmloc(n)) - call broadcast_scalar(pmeltl (n), pmloc(n)) - call broadcast_scalar(psnoice (n), pmloc(n)) - call broadcast_scalar(pfrazil (n), pmloc(n)) - call broadcast_scalar(pcongel (n), pmloc(n)) - call broadcast_scalar(pdhi (n), pmloc(n)) - call broadcast_scalar(pdhs (n), pmloc(n)) - call broadcast_scalar(pde (n), pmloc(n)) - call broadcast_scalar(psst (n), pmloc(n)) - call broadcast_scalar(pTf (n), pmloc(n)) - call broadcast_scalar(pfhocn (n), pmloc(n)) + call broadcast_scalar(pTair (n), pmloc(n)) + call broadcast_scalar(pQa (n), pmloc(n)) + call broadcast_scalar(pfsnow (n), pmloc(n)) + call broadcast_scalar(pfrain (n), pmloc(n)) + call broadcast_scalar(pfsw (n), pmloc(n)) + call broadcast_scalar(pflw (n), pmloc(n)) + call broadcast_scalar(paice (n), pmloc(n)) + call broadcast_scalar(hsavg (n), pmloc(n)) + call broadcast_scalar(hiavg (n), pmloc(n)) + call broadcast_scalar(pTsfc (n), pmloc(n)) + call broadcast_scalar(pevap (n), pmloc(n)) + call broadcast_scalar(pfswabs (n), pmloc(n)) + call broadcast_scalar(pflwout (n), pmloc(n)) + call broadcast_scalar(pflat (n), pmloc(n)) + call broadcast_scalar(pfsens (n), pmloc(n)) + call broadcast_scalar(pfsurf (n), pmloc(n)) + call broadcast_scalar(pfcondtop(n), pmloc(n)) + call broadcast_scalar(pmeltt (n), pmloc(n)) + call broadcast_scalar(pmeltb (n), pmloc(n)) + call broadcast_scalar(pmeltl (n), pmloc(n)) + call broadcast_scalar(psnoice (n), pmloc(n)) + call broadcast_scalar(pfrazil (n), pmloc(n)) + call broadcast_scalar(pcongel (n), pmloc(n)) + call broadcast_scalar(pdhi (n), pmloc(n)) + call broadcast_scalar(pdhs (n), pmloc(n)) + call broadcast_scalar(pde (n), pmloc(n)) + call broadcast_scalar(psst (n), pmloc(n)) + call broadcast_scalar(pTf (n), pmloc(n)) + call broadcast_scalar(pfhocn (n), pmloc(n)) enddo ! npnt endif ! print_points @@ -646,7 +680,11 @@ subroutine runtime_diags (dt) write (nu_diag,801) 'arwt tot mass (kg) = ',mtotn write (nu_diag,801) 'arwt tot mass chng(kg) = ',delmin write (nu_diag,801) 'arwt water flux = ',fluxn - write (nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + if (update_ocn_f) then + write (nu_diag,*) '(=rain+snow+evap-fresh) ' + else + write (nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + endif write (nu_diag,801) 'water flux error = ',werrn #if (defined CCSM) || (defined SEQ_MCT) endif ! prescribed_ice @@ -699,7 +737,11 @@ subroutine runtime_diags (dt) write(nu_diag,901) 'arwt tot mass (kg) = ',mtotn,mtots write(nu_diag,901) 'arwt tot mass chng(kg) = ',delmin,delmis write(nu_diag,901) 'arwt water flux = ',fluxn,fluxs - write(nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + if (update_ocn_f) then + write (nu_diag,*) '(=rain+snow+evap-fresh) ' + else + write (nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + endif write(nu_diag,901) 'water flux error = ',werrn,werrs write(nu_diag,*) '----------------------------' @@ -744,20 +786,29 @@ subroutine runtime_diags (dt) pfsnow(2) write(nu_diag,900) 'rainfall (m) = ',pfrain(1), & pfrain(2) - write(nu_diag,900) 'shortwave radiation sum= ',pfsw(1),pfsw(2) - write(nu_diag,900) 'longwave radiation = ',pflw(1),pflw(2) + if (.not.calc_Tsfc) then + write(nu_diag,900) 'total surface heat flux= ',pfsurf(1),pfsurf(2) + write(nu_diag,900) 'top sfc conductive flux= ',pfcondtop(1), & + pfcondtop(2) + write(nu_diag,900) 'latent heat flx = ',pflat(1),pflat(2) + else + write(nu_diag,900) 'shortwave radiation sum= ',pfsw(1),pfsw(2) + write(nu_diag,900) 'longwave radiation = ',pflw(1),pflw(2) + endif write(nu_diag,*) '----------ice----------' write(nu_diag,900) 'area fraction = ',paice(1),paice(2) write(nu_diag,900) 'avg ice thickness (m) = ',hiavg(1),hiavg(2) write(nu_diag,900) 'avg snow depth (m) = ',hsavg(1),hsavg(2) - write(nu_diag,900) 'surface temperature(C) = ',pTsfc(1),pTsfc(2) - write(nu_diag,900) 'absorbed shortwave flx = ',pfswabs(1), & - pfswabs(2) - write(nu_diag,900) 'outward longwave flx = ',pflwout(1), & - pflwout(2) - write(nu_diag,900) 'sensible heat flx = ',pfsens(1), & - pfsens(2) - write(nu_diag,900) 'latent heat flx = ',pflat(1),pflat(2) + if (calc_Tsfc) then + write(nu_diag,900) 'surface temperature(C) = ',pTsfc(1),pTsfc(2) + write(nu_diag,900) 'absorbed shortwave flx = ',pfswabs(1), & + pfswabs(2) + write(nu_diag,900) 'outward longwave flx = ',pflwout(1), & + pflwout(2) + write(nu_diag,900) 'sensible heat flx = ',pfsens(1), & + pfsens(2) + write(nu_diag,900) 'latent heat flx = ',pflat(1),pflat(2) + endif write(nu_diag,900) 'subl/cond (m ice) = ',pevap(1),pevap(2) write(nu_diag,900) 'top melt (m) = ',pmeltt(1) & ,pmeltt(2) diff --git a/cice/source/ice_domain.F90 b/cice/source/ice_domain.F90 index f81a1fe..51a7004 100644 --- a/cice/source/ice_domain.F90 +++ b/cice/source/ice_domain.F90 @@ -457,7 +457,11 @@ subroutine init_domain_distribution(KMTG,ULATG) else if (nblocks_max < max_blocks) then write(outstring,*) & 'ice: no. blocks too large: decrease max to', nblocks_max - if (my_task == master_task) write(nu_diag,*) trim(outstring) + if (my_task == master_task) then + write(nu_diag,*) '********WARNING*********' + write(nu_diag,*) trim(outstring) + write(nu_diag,*) ' ' + endif endif !---------------------------------------------------------------------- diff --git a/cice/source/ice_dyn_evp.F90 b/cice/source/ice_dyn_evp.F90 index aa0f537..49e2e46 100644 --- a/cice/source/ice_dyn_evp.F90 +++ b/cice/source/ice_dyn_evp.F90 @@ -106,6 +106,13 @@ subroutine evp (dt) ! ! Elastic-viscous-plastic dynamics driver ! +#ifdef CICE_IN_NEMO +! Wind stress is set during this routine from the values supplied +! via NEMO. These values are supplied rotated on u grid and +! multiplied by aice. strairxT = 0 in this case so operations in +! evp_prep1 are pointless but carried out to minimise code changes. +#endif +! ! !REVISION HISTORY: ! ! author: Elizabeth C. Hunke, LANL @@ -229,11 +236,22 @@ subroutine evp (dt) ! convert fields from T to U grid !----------------------------------------------------------------- - call t2ugrid_vector(strairx) - call t2ugrid_vector(strairy) call to_ugrid(tmass,umass) call to_ugrid(aice, aiu) +#ifdef CICE_IN_NEMO + !---------------------------------------------------------------- + ! Set wind stress to values supplied via NEMO + ! This wind stress is rotated on u grid and multiplied by aice + !---------------------------------------------------------------- + + strairx(:,:,:) = strax(:,:,:) + strairy(:,:,:) = stray(:,:,:) +#else + call t2ugrid_vector(strairx) + call t2ugrid_vector(strairy) +#endif + do iblk = 1, nblocks !----------------------------------------------------------------- @@ -372,6 +390,7 @@ subroutine evp (dt) indxui (:,iblk), indxuj (:,iblk), & uvel (:,:,iblk), vvel (:,:,iblk), & uocn (:,:,iblk), vocn (:,:,iblk), & + aiu (:,:,iblk), & strocnx (:,:,iblk), strocny (:,:,iblk), & strocnxT(:,:,iblk), strocnyT(:,:,iblk)) @@ -1376,6 +1395,7 @@ subroutine evp_finish (nx_block, ny_block, & indxui, indxuj, & uvel, vvel, & uocn, vocn, & + aiu, & strocnx, strocny, & strocnxT, strocnyT) ! @@ -1405,7 +1425,8 @@ subroutine evp_finish (nx_block, ny_block, & uvel , & ! x-component of velocity (m/s) vvel , & ! y-component of velocity (m/s) uocn , & ! ocean current, x-direction (m/s) - vocn ! ocean current, y-direction (m/s) + vocn , & ! ocean current, y-direction (m/s) + aiu ! ice fraction on u-grid real (kind=dbl_kind), dimension (nx_block,ny_block), & intent(inout) :: & @@ -1437,6 +1458,7 @@ subroutine evp_finish (nx_block, ny_block, & !----------------------------------------------------------------- ! Prepare to convert to T grid !----------------------------------------------------------------- + do j = 1, ny_block do i = 1, nx_block strocnxT(i,j) = strocnx(i,j) @@ -1444,6 +1466,18 @@ subroutine evp_finish (nx_block, ny_block, & enddo enddo + !----------------------------------------------------------------- + ! Scale strocnx and strocny back to grid box mean value for + ! diagnostics + !----------------------------------------------------------------- + + do ij =1, icellu + i = indxui(ij) + j = indxuj(ij) + strocnx(i,j) = strocnx(i,j) * aiu(i,j) + strocny(i,j) = strocny(i,j) * aiu(i,j) + enddo + end subroutine evp_finish !======================================================================= diff --git a/cice/source/ice_flux.F90 b/cice/source/ice_flux.F90 index 7dd50d1..9b2267c 100644 --- a/cice/source/ice_flux.F90 +++ b/cice/source/ice_flux.F90 @@ -41,18 +41,22 @@ module ice_flux real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & + ! in from atmos (if .not.calc_strair) + strax , & ! wind stress components (N/m^2) + stray , & ! + ! in from ocean uocn , & ! ocean current, x-direction (m/s) vocn , & ! ocean current, y-direction (m/s) ss_tltx , & ! sea surface slope, x-direction (m/m) ss_tlty , & ! sea surface slope, y-direction - ! out to atmosphere - + ! out to atmosphere (if calc_strair) strairxT, & ! stress on ice by air, x-direction strairyT, & ! stress on ice by air, y-direction ! out to ocean T-cell (kg/m s^2) + ! Note, CICE_IN_NEMO uses strocnx and strocny for coupling strocnxT, & ! ice-ocean stress, x-direction strocnyT ! ice-ocean stress, y-direction @@ -98,15 +102,13 @@ module ice_flux ! Thermodynamic component !----------------------------------------------------------------- - ! in from atmosphere + ! in from atmosphere (if calc_Tsfc) real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & zlvl , & ! atm level height (m) uatm , & ! wind velocity components (m/s) vatm , & wind , & ! wind speed (m/s) - strax , & ! wind stress components (N/m^2) - stray , & ! potT , & ! air potential temperature (K) Tair , & ! air temperature (K) Qa , & ! specific humidity (kg/kg) @@ -115,7 +117,22 @@ module ice_flux swvdf , & ! sw down, visible, diffuse (W/m^2) swidr , & ! sw down, near IR, direct (W/m^2) swidf , & ! sw down, near IR, diffuse (W/m^2) - flw , & ! incoming longwave radiation (W/m^2) + flw ! incoming longwave radiation (W/m^2) + + ! in from atmosphere (if .not. Tsfc_calc) + ! required for coupling to HadGEM3 + ! NOTE: when in CICE_IN_NEMO mode, these are gridbox mean fields, + ! not per ice area. When in standalone mode, these are per ice area. + + real (kind=dbl_kind), & + dimension (nx_block,ny_block,ncat,max_blocks) :: & + fsurfn_f , & ! net flux to top surface, excluding fcondtop + fcondtopn_f, & ! downward cond flux at top surface (W m-2) + flatn_f ! latent heat flux (W m-2) + + ! in from atmosphere + + real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & frain , & ! rainfall rate (kg/m^2 s) fsnow ! snowfall rate (kg/m^2 s) @@ -129,7 +146,11 @@ module ice_flux qdp , & ! deep ocean heat flux (W/m^2), negative upward hmix ! mixed layer depth (m) - ! out to atmosphere + character (char_len) :: & + Tfrzpt ! ocean freezing temperature formulation + ! 'constant' (-1.8C), 'linear_S' + + ! out to atmosphere (if calc_Tsfc) ! note Tsfc is in ice_state.F real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & @@ -141,20 +162,26 @@ module ice_flux Qref , & ! 2m atm reference spec humidity (kg/kg) evap ! evaporative water flux (kg/m^2/s) - ! albedos aggregated over categories + ! albedos aggregated over categories (if calc_Tsfc) real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & alvdr , & ! visible, direct (fraction) alidr , & ! near-ir, direct (fraction) alvdf , & ! visible, diffuse (fraction) alidf ! near-ir, diffuse (fraction) - ! out to ocean + ! out to ocean + ! (Note CICE_IN_NEMO does not use these for coupling. + ! It uses fresh_hist_gbm,fsalt_hist_gbm,fhocn_hist_gbm and + ! fswthru_hist_gbm) real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & fresh , & ! fresh water flux to ocean (kg/m^2/s) fsalt , & ! salt flux to ocean (kg/m^2/s) fhocn , & ! net heat flux to ocean (W/m^2) fswthru ! shortwave penetrating to ocean (W/m^2) + logical (kind=log_kind) :: & + update_ocn_f ! if true, update fresh water and salt fluxes + !----------------------------------------------------------------- ! quantities passed from ocean mixed layer to atmosphere ! (for running with CAM) @@ -179,6 +206,8 @@ module ice_flux !----------------------------------------------------------------- real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & + fsurf , & ! net surface heat flux (excluding fcondtop)(W/m^2) + fcondtop,&! top surface conductive flux (W/m^2) congel, & ! basal ice growth (m/step-->cm/day) frazil, & ! frazil ice growth (m/step-->cm/day) snoice, & ! snow-ice formation (m/step-->cm/day) @@ -190,6 +219,12 @@ module ice_flux dvidtt, & ! ice volume tendency thermo. (m/s) mlt_onset, &! day of year that sfc melting begins frz_onset ! day of year that freezing begins (congel or frazil) + + real (kind=dbl_kind), & + dimension (nx_block,ny_block,ncat,max_blocks) :: & + fsurfn, & ! category fsurf + fcondtopn,& ! category fcondtop + flatn ! cagegory latent heat flux ! NOTE: The following ocean diagnostic fluxes measure ! the same thing as their coupler counterparts but over @@ -203,6 +238,19 @@ module ice_flux fhocn_hist, & ! net heat flux to ocean (W/m^2) fswthru_hist ! shortwave penetrating to ocean (W/m^2) + ! As above but these remain grid box mean values i.e. they are not + ! divided by aice_init at end of ice_dynamics. These are used in + ! CICE_IN_NEMO for coupling and also for generating + ! ice diagnostics and history files as these are more accurate. + ! (The others suffer from problem of incorrect values at grid boxes + ! that change from an ice free state to an icy state.) + + real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & + fresh_hist_gbm, & ! fresh water flux to ocean (kg/m^2/s) + fsalt_hist_gbm, & ! salt flux to ocean (kg/m^2/s) + fhocn_hist_gbm, & ! net heat flux to ocean (W/m^2) + fswthru_hist_gbm ! shortwave penetrating to ocean (W/m^2) + !----------------------------------------------------------------- ! internal !----------------------------------------------------------------- @@ -244,6 +292,9 @@ subroutine init_coupler_flux ! integer (kind=int_kind) :: i, j, iblk + logical (kind=log_kind), parameter :: & + l_winter = .true. ! winter/summer default switch + !----------------------------------------------------------------- ! fluxes received from atmosphere !----------------------------------------------------------------- @@ -251,28 +302,49 @@ subroutine init_coupler_flux rhoa (:,:,:) = 1.3_dbl_kind ! air density (kg/m^3) uatm (:,:,:) = c5 ! wind velocity (m/s) vatm (:,:,:) = c5 -!typical summer values -! potT (:,:,:) = 273.0_dbl_kind ! air potential temp (K) -! Tair (:,:,:) = 273.0_dbl_kind ! air temperature (K) -! Qa (:,:,:) = 0.0035_dbl_kind ! specific humidity (kg/kg) -! swvdr (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) -! swvdf (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) -! swidr (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) -! swidf (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) -! flw (:,:,:) = 280.0_dbl_kind ! incoming longwave rad (W/m^2) -! frain (:,:,:) = c0 ! rainfall rate (kg/m2/s) -! fsnow (:,:,:) = c0 ! snowfall rate (kg/m2/s) -!typical winter values - potT (:,:,:) = 253.0_dbl_kind ! air potential temp (K) - Tair (:,:,:) = 253.0_dbl_kind ! air temperature (K) - Qa (:,:,:) = 0.0006_dbl_kind ! specific humidity (kg/kg) - swvdr (:,:,:) = c0 ! shortwave radiation (W/m^2) - swvdf (:,:,:) = c0 ! shortwave radiation (W/m^2) - swidr (:,:,:) = c0 ! shortwave radiation (W/m^2) - swidf (:,:,:) = c0 ! shortwave radiation (W/m^2) - flw (:,:,:) = c180 ! incoming longwave rad (W/m^2) - frain (:,:,:) = c0 ! rainfall rate (kg/m2/s) - fsnow (:,:,:) = 4.0e-6_dbl_kind ! snowfall rate (kg/m2/s) + strax (:,:,:) = 0.05_dbl_kind + stray (:,:,:) = 0.05_dbl_kind + if (l_winter) then + !typical winter values + potT (:,:,:) = 253.0_dbl_kind ! air potential temp (K) + Tair (:,:,:) = 253.0_dbl_kind ! air temperature (K) + Qa (:,:,:) = 0.0006_dbl_kind ! specific humidity (kg/kg) + swvdr (:,:,:) = c0 ! shortwave radiation (W/m^2) + swvdf (:,:,:) = c0 ! shortwave radiation (W/m^2) + swidr (:,:,:) = c0 ! shortwave radiation (W/m^2) + swidf (:,:,:) = c0 ! shortwave radiation (W/m^2) + flw (:,:,:) = c180 ! incoming longwave rad (W/m^2) + frain (:,:,:) = c0 ! rainfall rate (kg/m2/s) + fsnow (:,:,:) = 4.0e-6_dbl_kind ! snowfall rate (kg/m2/s) + fcondtopn_f(:,:,1,:)=-50.0_dbl_kind ! conductive heat flux (W/m^2) + if (ncat>1) fcondtopn_f(:,:,2,:)=-17.0_dbl_kind + if (ncat>2) fcondtopn_f(:,:,3,:)=-12.0_dbl_kind + if (ncat>3) fcondtopn_f(:,:,4,:)=-9.0_dbl_kind + if (ncat>4) fcondtopn_f(:,:,5,:)=-7.0_dbl_kind + if (ncat>5) fcondtopn_f(:,:,6:ncat,:)=-3.0_dbl_kind + fsurfn_f=fcondtopn_f ! surface heat flux (W/m^2) + flatn_f(:,:,:,:)=c0 ! latent heat flux (kg/m2/s) + else + !typical summer values + potT (:,:,:) = 273.0_dbl_kind ! air potential temp (K) + Tair (:,:,:) = 273.0_dbl_kind ! air temperature (K) + Qa (:,:,:) = 0.0035_dbl_kind ! specific humidity (kg/kg) + swvdr (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) + swvdf (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) + swidr (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) + swidf (:,:,:) = 50._dbl_kind ! shortwave radiation (W/m^2) + flw (:,:,:) = 280.0_dbl_kind ! incoming longwave rad (W/m^2) + frain (:,:,:) = c0 ! rainfall rate (kg/m2/s) + fsnow (:,:,:) = c0 ! snowfall rate (kg/m2/s) + fsurfn_f(:,:,1,:)=0.2_dbl_kind ! surface heat flux (W/m^2) + if (ncat > 1) fsurfn_f(:,:,2,:)=0.15_dbl_kind + if (ncat > 2) fsurfn_f(:,:,3,:)=0.1_dbl_kind + if (ncat > 3) fsurfn_f(:,:,4,:)=0.05_dbl_kind + if (ncat > 4) fsurfn_f(:,:,5,:)=0.01_dbl_kind + if (ncat > 5) fsurfn_f(:,:,6:ncat,:)=0.01_dbl_kind + fcondtopn_f(:,:,:,:)=0.0_dbl_kind ! conductive heat flux (W/m^2) + flatn_f(:,:,:,:)=-2.0_dbl_kind ! latent heat flux (W/m^2) + endif ! l_winter !----------------------------------------------------------------- ! fluxes received from ocean @@ -284,9 +356,14 @@ subroutine init_coupler_flux vocn (:,:,:) = c0 frzmlt(:,:,:) = c0 ! freezing/melting potential (W/m^2) sss (:,:,:) = 34.0_dbl_kind ! sea surface salinity (o/oo) - Tf (:,:,:) = -depressT*sss(:,:,:) ! freezing temp (C) - ! (derived field) + if (trim(Tfrzpt) == 'constant') then + Tf (:,:,:) = -1.8_dbl_kind ! freezing temp (C) + else ! default: Tfrzpt = 'linear_S' + Tf (:,:,:) = -depressT*sss(:,:,:) ! freezing temp (C) + endif +#ifndef CICE_IN_NEMO sst (:,:,:) = Tf(:,:,:) ! sea surface temp (C) +#endif qdp (:,:,:) = c0 ! deep ocean heat flux (W/m^2) hmix (:,:,:) = c20 ! ocean mixed layer depth @@ -444,6 +521,8 @@ subroutine init_history_therm ! use ice_state, only: aice, vice + fsurf (:,:,:) = c0 + fcondtop(:,:,:)= c0 congel (:,:,:) = c0 frazil (:,:,:) = c0 snoice (:,:,:) = c0 @@ -455,10 +534,17 @@ subroutine init_history_therm dvidtt (:,:,:) = vice(:,:,:) ! temporary initial volume daidtd (:,:,:) = c0 dvidtd (:,:,:) = c0 + fsurfn (:,:,:,:) = c0 + fcondtopn (:,:,:,:) = c0 + flatn (:,:,:,:) = c0 fresh_hist (:,:,:) = c0 fsalt_hist (:,:,:) = c0 fhocn_hist (:,:,:) = c0 fswthru_hist(:,:,:) = c0 + fresh_hist_gbm (:,:,:) = c0 + fsalt_hist_gbm (:,:,:) = c0 + fhocn_hist_gbm (:,:,:) = c0 + fswthru_hist_gbm(:,:,:) = c0 end subroutine init_history_therm @@ -524,7 +610,8 @@ subroutine merge_fluxes (nx_block, ny_block, & flw, coszn, & alvdrn, alidrn, & alvdfn, alidfn, & - strairxn, strairyn, & + strairxn, strairyn, & + fsurfn, fcondtopn, & fsensn, flatn, & fswabsn, flwoutn, & evapn, & @@ -534,6 +621,7 @@ subroutine merge_fluxes (nx_block, ny_block, & alvdr, alidr, & alvdf, alidf, & strairxT, strairyT, & + fsurf, fcondtop, & fsens, flat, & fswabs, flwout, & evap, & @@ -542,6 +630,7 @@ subroutine merge_fluxes (nx_block, ny_block, & fsalt, fsalt_hist, & fhocn, fhocn_hist, & fswthru, fswthru_hist) + ! ! !DESCRIPTION: ! @@ -574,6 +663,8 @@ subroutine merge_fluxes (nx_block, ny_block, & alidfn , & ! near-ir diffuse albedo (fraction) strairxn, & ! air/ice zonal strss, (N/m**2) strairyn, & ! air/ice merdnl strss, (N/m**2) + fsurfn , & ! net heat flux to top surface (W/m**2) + fcondtopn,& ! downward cond flux at top sfc (W/m**2) fsensn , & ! sensible heat flx (W/m**2) flatn , & ! latent heat flx (W/m**2) fswabsn , & ! shortwave absorbed heat flx (W/m**2) @@ -585,7 +676,7 @@ subroutine merge_fluxes (nx_block, ny_block, & fsaltn , & ! salt flux to ocean (kg/m2/s) fhocnn , & ! actual ocn/ice heat flx (W/m**2) fswthrun ! sw radiation through ice bot (W/m**2) - + ! cumulative fluxes real (kind=dbl_kind), dimension(nx_block,ny_block), & intent(inout):: & @@ -595,6 +686,8 @@ subroutine merge_fluxes (nx_block, ny_block, & alidf , & ! near-ir diffuse albedo (fraction) strairxT, & ! air/ice zonal strss, (N/m**2) strairyT, & ! air/ice merdnl strss, (N/m**2) + fsurf , & ! net heat flux to top surface (W/m**2) + fcondtop, & ! downward cond flux at top sfc (W/m**2) fsens , & ! sensible heat flx (W/m**2) flat , & ! latent heat flx (W/m**2) fswabs , & ! shortwave absorbed heat flx (W/m**2) @@ -609,7 +702,7 @@ subroutine merge_fluxes (nx_block, ny_block, & fhocn , & ! actual ocn/ice heat flx (W/m**2) fhocn_hist,&! actual ocn/ice heat flx (W/m**2) fswthru , & ! sw radiation through ice bot (W/m**2) - fswthru_hist! sw radiation through ice bot (W/m**2) + fswthru_hist!sw radiation through ice bot (W/m**2) ! !EOP ! @@ -642,6 +735,8 @@ subroutine merge_fluxes (nx_block, ny_block, & strairxT (i,j) = strairxT(i,j) + strairxn(i,j)*aicen(i,j) strairyT (i,j) = strairyT(i,j) + strairyn(i,j)*aicen(i,j) + fsurf (i,j) = fsurf (i,j) + fsurfn (i,j)*aicen(i,j) + fcondtop (i,j) = fcondtop(i,j) + fcondtopn(i,j)*aicen(i,j) fsens (i,j) = fsens (i,j) + fsensn (i,j)*aicen(i,j) flat (i,j) = flat (i,j) + flatn (i,j)*aicen(i,j) fswabs (i,j) = fswabs (i,j) + fswabsn (i,j)*aicen(i,j) @@ -810,7 +905,8 @@ subroutine scale_hist_fluxes ! Divide ice fluxes by ice area used by the coupler before writing out ! diagnostics. aice\_init is the ice area saved from coupling. This ! makes the fluxes written to the history file consistent with those -! sent to the coupler. +! sent to the coupler. (Also scale fsurf and fcondtop to be +! consistent.) ! ! !REVISION HISTORY: ! @@ -839,11 +935,15 @@ subroutine scale_hist_fluxes fsalt_hist (i,j,iblk) = fsalt_hist (i,j,iblk) * ar fhocn_hist (i,j,iblk) = fhocn_hist (i,j,iblk) * ar fswthru_hist(i,j,iblk) = fswthru_hist(i,j,iblk) * ar + fsurf (i,j,iblk) = fsurf (i,j,iblk) * ar + fcondtop (i,j,iblk) = fcondtop (i,j,iblk) * ar else fresh_hist (i,j,iblk) = c0 fsalt_hist (i,j,iblk) = c0 fhocn_hist (i,j,iblk) = c0 fswthru_hist(i,j,iblk) = c0 + fsurf (i,j,iblk) = c0 + fcondtop (i,j,iblk) = c0 endif enddo enddo diff --git a/cice/source/ice_forcing.F90 b/cice/source/ice_forcing.F90 index c669e33..bf662a9 100644 --- a/cice/source/ice_forcing.F90 +++ b/cice/source/ice_forcing.F90 @@ -67,7 +67,13 @@ module ice_forcing rain_file, & sst_file, & sss_file, & - pslv_file + pslv_file, & + sublim_file, & + snow_file + + character (char_len_long), dimension(ncat) :: & ! input data file names + topmelt_file, & + botmelt_file real (kind=dbl_kind) :: & c1intp, c2intp , & ! interpolation coefficients @@ -96,15 +102,26 @@ module ice_forcing zlvl_data, & flw_data, & sst_data, & - sss_data + sss_data, & + uocn_data, & + vocn_data, & + sublim_data, & + frain_data + + real (kind=dbl_kind), & + dimension(nx_block,ny_block,2,max_blocks,ncat) :: & + topmelt_data, & + botmelt_data character(char_len) :: & atm_data_format, & ! 'bin'=binary or 'nc'=netcdf ocn_data_format, & ! 'bin'=binary or 'nc'=netcdf - atm_data_type, & ! 'default', 'monthly', 'ncar', 'ecmwf', or 'LYq' - sss_data_type, & ! 'default', 'clim', or 'ncar' - sst_data_type, & ! 'default', 'clim', or 'ncar' - precip_units ! 'mm_per_month', 'mm_per_sec', 'mks' + atm_data_type, & ! 'default', 'monthly', 'ncar', 'ecmwf', + ! 'LYq' or 'hadgem' + sss_data_type, & ! 'default', 'clim', or 'ncar' + sst_data_type, & ! 'default', 'clim', 'ncar', + ! 'hadgem_sst' or 'hadgem_sst_uvocn' + precip_units ! 'mm_per_month', 'mm_per_sec', 'mks' character(char_len_long) :: & atm_data_dir , & ! top directory for atmospheric data @@ -114,6 +131,13 @@ module ice_forcing integer (kind=int_kind), parameter :: & nfld = 8 ! number of fields to search for in forcing file + ! as in the dummy atm (latm) + real (kind=dbl_kind), parameter :: & + frcvdr = 0.28_dbl_kind, & ! frac of incoming sw in vis direct band + frcvdf = 0.24_dbl_kind, & ! frac of incoming sw in vis diffuse band + frcidr = 0.31_dbl_kind, & ! frac of incoming sw in near IR direct band + frcidf = 0.17_dbl_kind ! frac of incoming sw in near IR diffuse band + real (kind=dbl_kind), & dimension (nx_block,ny_block,max_blocks,nfld,12) :: & ocn_frc_m ! ocn data for 12 months @@ -179,6 +203,8 @@ subroutine init_forcing_atmo call ecmwf_files(fyear) elseif (trim(atm_data_type) == 'LYq') then call LY_files(fyear) + elseif (trim(atm_data_type) == 'hadgem') then + call hadgem_files(fyear) elseif (trim(atm_data_type) == 'monthly') then call monthly_files(fyear) endif @@ -212,7 +238,7 @@ subroutine init_forcing_ocn(dt) ! !USES: ! use ice_domain, only: nblocks - use ice_flux, only: sss, sst, Tf + use ice_flux, only: sss, sst, Tf, Tfrzpt use ice_work, only: work1 use ice_read_write use ice_therm_vertical, only: ustar_scale @@ -227,7 +253,13 @@ subroutine init_forcing_ocn(dt) integer (kind=int_kind) :: & i, j, iblk , & ! horizontal indices k , & ! month index - nbits + fid , & ! file id for netCDF file + nbits + + logical (kind=log_kind) :: diag + + character (char_len) :: & + fieldname ! field name in netcdf file nbits = 64 ! double precision data @@ -270,7 +302,11 @@ subroutine init_forcing_ocn(dt) do i = 1, nx_block sss(i,j,iblk) = sss(i,j,iblk) / c12 ! annual average sss(i,j,iblk) = max(sss(i,j,iblk),c0) - Tf (i,j,iblk) = -depressT * sss(i,j,iblk) ! deg C + if (trim(Tfrzpt) == 'constant') then + Tf (i,j,iblk) = -1.8_dbl_kind ! deg C + else ! default: Tfrzpt = 'linear_S' + Tf (i,j,iblk) = -depressT * sss(i,j,iblk) ! deg C + endif enddo enddo enddo @@ -327,6 +363,40 @@ subroutine init_forcing_ocn(dt) endif ! init_sst_data + + if (trim(sst_data_type) == 'hadgem_sst' .or. & + trim(sst_data_type) == 'hadgem_sst_uvocn') then + + diag = .true. ! write diagnostic information + + sst_file = trim (ocn_data_dir)//'MONTHLY/sst.1997.nc' + + if (my_task == master_task) then + + write (nu_diag,*) ' ' + write (nu_diag,*) 'Initial SST file:', trim(sst_file) + + call ice_open_nc(sst_file,fid) + + endif + + fieldname='sst' + call ice_read_nc(fid,month,fieldname,sst,diag) + + if (my_task == master_task) call ice_close_nc(fid) + + ! Make sure sst is not less than freezing temperature Tf + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + sst(i,j,iblk) = max(sst(i,j,iblk),Tf(i,j,iblk)) + enddo + enddo + enddo + + endif ! sst_data_type + + if (trim(sst_data_type) == 'ncar' .or. & trim(sss_data_type) == 'ncar') then call ocn_data_ncar_init @@ -336,7 +406,8 @@ subroutine init_forcing_ocn(dt) ! default value of c1 (for nonzero currents) set in init_thermo_vertical if (trim(sst_data_type) /= 'ncar' .or. & - trim(sss_data_type) /= 'ncar') then + trim(sss_data_type) /= 'ncar' .or. & + trim(sst_data_type) /= 'hadgem_sst_uvocn') then ustar_scale = c10 ! for zero currents endif @@ -395,6 +466,8 @@ subroutine get_forcing_atmo call ecmwf_data elseif (trim(atm_data_type) == 'LYq') then call LY_data + elseif (trim(atm_data_type) == 'hadgem') then + call hadgem_data elseif (trim(atm_data_type) == 'monthly') then call monthly_data else ! default values set in init_flux @@ -481,6 +554,9 @@ subroutine get_forcing_ocn (dt) elseif (trim(sst_data_type) == 'ncar' .or. & trim(sss_data_type) == 'ncar') then call ocn_data_ncar(dt) + elseif (trim(sst_data_type) == 'hadgem_sst' .or. & + trim(sst_data_type) == 'hadgem_sst_uvocn') then + call ocn_data_hadgem(dt) endif end subroutine get_forcing_ocn @@ -591,12 +667,14 @@ subroutine read_data (flag, recd, yr, ixm, ixx, ixp, & endif endif ! yr > fyear_init endif ! ixx <= 1 + call ice_open (nu_forcing, data_file, nbits) arg = 1 nrec = recd + n2 call ice_read (nu_forcing, nrec, field_data(:,:,arg,:), & 'rda8', dbug, field_loc, field_type) + if (ixx==1 .and. my_task == master_task) close(nu_forcing) endif ! ixm ne 99 @@ -622,7 +700,9 @@ subroutine read_data (flag, recd, yr, ixm, ixx, ixp, & else ! go to beginning of fyear_init if (my_task == master_task) close(nu_forcing) call file_year (data_file, fyear_init) + call ice_open (nu_forcing, data_file, nbits) + endif endif ! yr < fyear_final endif ! ixx = maxrec @@ -1093,7 +1173,7 @@ subroutine file_year (data_file, yr) ! ! Construct the correct name of the atmospheric data file ! to be read, given the year and assuming the naming convention -! that filenames end with 'yyyy.dat' or 'yyyy.r'. +! that filenames end with 'yyyy.dat' or 'yyyy.r' or 'yyyy.nc'. ! ! !REVISION HISTORY: ! @@ -1118,6 +1198,10 @@ subroutine file_year (data_file, yr) i = index(data_file,'.r') - 5 tmpname = data_file write(data_file,'(a,i4.4,a)') tmpname(1:i), yr, '.r' + elseif (trim(atm_data_type) == 'hadgem') then ! netcdf + i = index(data_file,'.nc') - 5 + tmpname = data_file + write(data_file,'(a,i4.4,a)') tmpname(1:i), yr, '.nc' else ! LANL/NCAR naming convention i = index(data_file,'.dat') - 5 tmpname = data_file @@ -1192,13 +1276,6 @@ subroutine prepare_forcing (nx_block, ny_block, & swidr , & ! sw down, near IR, direct (W/m^2) swidf , & ! sw down, near IR, diffuse (W/m^2) potT ! air potential temperature (K) - - ! as in the dummy atm (latm) - real (kind=dbl_kind), parameter :: & - frcvdr = 0.28_dbl_kind, & ! frac of incoming sw in vis direct band - frcvdf = 0.24_dbl_kind, & ! frac of incoming sw in vis diffuse band - frcidr = 0.31_dbl_kind, & ! frac of incoming sw in near IR direct band - frcidf = 0.17_dbl_kind ! frac of incoming sw in near IR diffuse band ! !EOP ! @@ -1332,10 +1409,16 @@ subroutine prepare_forcing (nx_block, ny_block, & endif ! determine whether precip is rain or snow - frain(i,j) = c0 - if (Tair(i,j) >= Tffresh) then - frain(i,j) = fsnow(i,j) - fsnow(i,j) = c0 + ! HadGEM forcing provides separate snowfall and rainfall rather + ! than total precipitation + if (trim(atm_data_type) /= 'hadgem') then + + frain(i,j) = c0 + if (Tair(i,j) >= Tffresh) then + frain(i,j) = fsnow(i,j) + fsnow(i,j) = c0 + endif + endif if (calc_strair) then @@ -2248,6 +2331,452 @@ subroutine Qa_fixLY(nx_block, ny_block, Tair, Qa) end subroutine Qa_fixLY +!======================================================================= +! HadGEM or HadGAM atmospheric forcing +!======================================================================= +! +!BOP +! +! !IROUTINE: hadgem_files - construct filenames for HadGEM or HadGAM files +! +! !INTERFACE: +! + subroutine hadgem_files (yr) +! +! !DESCRIPTION: +! +! Construct filenames based on selected model options +! +! Note: The year number in these filenames does not matter, because +! subroutine file\_year will insert the correct year. +! +! !REVISION HISTORY: +! +! author: Alison McLaren, Met Office +! +! !USES: +! + use ice_therm_vertical, only: calc_Tsfc + use ice_ocean, only: oceanmixed_ice +! +! !INPUT/OUTPUT PARAMETERS: +! + integer (kind=int_kind), intent(in) :: & + yr ! current forcing year +! +!EOP +! + integer (kind=int_kind) :: & + n ! thickness category index + + ! ----------------------------------------------------------- + ! Rainfall and snowfall + ! ----------------------------------------------------------- + + snow_file = & + trim(atm_data_dir)//'MONTHLY/snowfall.1996.nc' + call file_year(snow_file,yr) + + rain_file = & + trim(atm_data_dir)//'MONTHLY/rainfall.1996.nc' + call file_year(rain_file,yr) + + if (my_task == master_task) then + write (nu_diag,*) ' ' + write (nu_diag,*) 'Atmospheric data files:' + write (nu_diag,*) trim(rain_file) + write (nu_diag,*) trim(snow_file) + endif + + if (calc_strair) then + + ! -------------------------------------------------------- + ! Wind velocity + ! -------------------------------------------------------- + + uwind_file = & + trim(atm_data_dir)//'MONTHLY/u_10.1996.nc' + call file_year(uwind_file,yr) + + vwind_file = & + trim(atm_data_dir)//'MONTHLY/v_10.1996.nc' + call file_year(vwind_file,yr) + + if (my_task == master_task) then + write (nu_diag,*) trim(uwind_file) + write (nu_diag,*) trim(vwind_file) + endif + + else + + ! -------------------------------------------------------- + ! Wind stress + ! -------------------------------------------------------- + + strax_file = & + trim(atm_data_dir)//'MONTHLY/taux.1996.nc' + call file_year(strax_file,yr) + + stray_file = & + trim(atm_data_dir)//'MONTHLY/tauy.1996.nc' + call file_year(stray_file,yr) + + if (my_task == master_task) then + write (nu_diag,*) trim(strax_file) + write (nu_diag,*) trim(stray_file) + endif + + if (calc_Tsfc .or. oceanmixed_ice) then + + ! -------------------------------------------------- + ! Wind speed + ! -------------------------------------------------- + + wind_file = & + trim(atm_data_dir)//'MONTHLY/wind_10.1996.nc' + call file_year(wind_file,yr) + + if (my_task == master_task) then + write (nu_diag,*) trim(wind_file) + endif + + endif ! calc_Tsfc or oceanmixed_ice + + endif ! calc_strair + + ! -------------------------------------------------------------- + ! Atmosphere properties. Even if these fields are not + ! being used to force the ice (i.e. calc_Tsfc=.false.), they + ! are still needed to generate forcing for mixed layer model or + ! to calculate wind stress + ! -------------------------------------------------------------- + + if (calc_Tsfc .or. oceanmixed_ice .or. calc_strair) then + + fsw_file = & + trim(atm_data_dir)//'MONTHLY/SW_incoming.1996.nc' + call file_year(fsw_file,yr) + + flw_file = & + trim(atm_data_dir)//'MONTHLY/LW_incoming.1996.nc' + call file_year(flw_file,yr) + + tair_file = & + trim(atm_data_dir)//'MONTHLY/t_10.1996.nc' + call file_year(tair_file,yr) + + humid_file = & + trim(atm_data_dir)//'MONTHLY/q_10.1996.nc' + call file_year(humid_file,yr) + + rhoa_file = & + trim(atm_data_dir)//'MONTHLY/rho_10.1996.nc' + call file_year(rhoa_file,yr) + + if (my_task == master_task) then + write (nu_diag,*) trim(fsw_file) + write (nu_diag,*) trim(flw_file) + write (nu_diag,*) trim(tair_file) + write (nu_diag,*) trim(humid_file) + write (nu_diag,*) trim(rhoa_file) + endif ! master_task + + endif ! calc_Tsfc or oceanmixed_ice or calc_strair + + if (.not. calc_Tsfc) then + + ! ------------------------------------------------------ + ! Sublimation, topmelt and botmelt + ! ------------------------------------------------------ + + do n = 1, ncat + + ! 'topmelt' = fsurf - fcondtop. + write(topmelt_file(n), '(a,i1,a)') & + trim(atm_data_dir)//'MONTHLY/topmeltn',n,'.1996.nc' + call file_year(topmelt_file(n),yr) + + ! 'botmelt' = fcondtop. + write(botmelt_file(n), '(a,i1,a)') & + trim(atm_data_dir)//'MONTHLY/botmeltn',n,'.1996.nc' + call file_year(botmelt_file(n),yr) + + enddo + + ! 'sublim' = - flat / Lsub. + sublim_file = & + trim(atm_data_dir)//'MONTHLY/sublim.1996.nc' + call file_year(sublim_file,yr) + + if (my_task == master_task) then + do n = 1, ncat + write (nu_diag,*) trim(topmelt_file(n)) + write (nu_diag,*) trim(botmelt_file(n)) + enddo + write (nu_diag,*) trim(sublim_file) + + endif + + endif ! .not. calc_Tsfc + + end subroutine hadgem_files + +!======================================================================= +! +!BOP +! +! !IROUTINE: hadgem_data - read HadGEM or HadGAM atmospheric data +! +! !INTERFACE: +! + subroutine hadgem_data +! +! !DESCRIPTION: +! +! !REVISION HISTORY: +! +! authors: Alison McLaren, Met Office +! +! !USES: +! + use ice_domain, only: nblocks + use ice_flux + use ice_state, only: aice,aicen + use ice_ocean, only: oceanmixed_ice + use ice_therm_vertical, only: calc_Tsfc +! +! !INPUT/OUTPUT PARAMETERS: +! +! +!EOP +! + integer (kind=int_kind) :: & + i, j , & ! horizontal indices + n , & ! thickness category index + iblk , & ! block index + ixm,ixx,ixp , & ! record numbers for neighboring months + recnum , & ! record number + maxrec , & ! maximum record number + recslot , & ! spline slot for current record + dataloc , & ! = 1 for data located in middle of time interval + ! = 2 for date located at end of time interval + midmonth ! middle day of month + + logical (kind=log_kind) :: readm + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & + topmelt, & ! temporary fields + botmelt, & + sublim + + character (char_len) :: & + fieldname ! field name in netcdf file + + !------------------------------------------------------------------- + ! monthly data + ! + ! Assume that monthly data values are located in the middle of the + ! month. + !------------------------------------------------------------------- + + midmonth = 15 ! data is given on 15th of every month +! midmonth = fix(p5 * real(daymo(month))) ! exact middle + + ! Compute record numbers for surrounding months + maxrec = 12 + ixm = mod(month+maxrec-2,maxrec) + 1 + ixp = mod(month, maxrec) + 1 + if (mday >= midmonth) ixm = 99 ! other two points will be used + if (mday < midmonth) ixp = 99 + + ! Determine whether interpolation will use values 1:2 or 2:3 + ! recslot = 2 means we use values 1:2, with the current value (2) + ! in the second slot + ! recslot = 1 means we use values 2:3, with the current value (2) + ! in the first slot + recslot = 1 ! latter half of month + if (mday < midmonth) recslot = 2 ! first half of month + + ! Find interpolation coefficients + call interp_coeff_monthly (recslot) + + ! Read 2 monthly values + readm = .false. + if (istep==1 .or. (mday==midmonth .and. sec==0)) readm = .true. + + ! ----------------------------------------------------------- + ! Rainfall and snowfall + ! ----------------------------------------------------------- + + fieldname='rainfall' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, rain_file, fieldname, frain_data, & + field_loc_center, field_type_scalar) + fieldname='snowfall' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, snow_file, fieldname, fsnow_data, & + field_loc_center, field_type_scalar) + + ! Interpolate to current time step + call interpolate_data (fsnow_data, fsnow) + call interpolate_data (frain_data, frain) + + if (calc_strair) then + + ! -------------------------------------------------------- + ! Wind velocity + ! -------------------------------------------------------- + + fieldname='u_10' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, uwind_file, fieldname, uatm_data, & + field_loc_center, field_type_vector) + fieldname='v_10' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, vwind_file, fieldname, vatm_data, & + field_loc_center, field_type_vector) + + ! Interpolate to current time step + call interpolate_data (uatm_data, uatm) + call interpolate_data (vatm_data, vatm) + + else + + ! -------------------------------------------------------- + ! Wind stress + ! -------------------------------------------------------- + + fieldname='taux' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, strax_file, fieldname, strax_data, & + field_loc_center, field_type_vector) + fieldname='tauy' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, stray_file, fieldname, stray_data, & + field_loc_center, field_type_vector) + + ! Interpolate to current time step + call interpolate_data (strax_data, strax) + call interpolate_data (stray_data, stray) + + if (calc_Tsfc .or. oceanmixed_ice) then + + ! -------------------------------------------------- + ! Wind speed + ! -------------------------------------------------- + + fieldname='wind_10' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, wind_file, fieldname, wind_data, & + field_loc_center, field_type_scalar) + + ! Interpolate to current time step + call interpolate_data (wind_data, wind) + + endif ! calc_Tsfc or oceanmixed_ice + + endif ! calc_strair + + ! ----------------------------------------------------------- + ! SW incoming, LW incoming, air temperature, density and + ! humidity at 10m. + ! + ! Even if these fields are not being used to force the ice + ! (i.e. calc_Tsfc=.false.), they are still needed to generate + ! forcing for mixed layer model or to calculate wind stress + ! ----------------------------------------------------------- + + if (calc_Tsfc .or. oceanmixed_ice .or. calc_strair) then + + fieldname='SW_incoming' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, fsw_file, fieldname, fsw_data, & + field_loc_center, field_type_scalar) + fieldname='LW_incoming' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, flw_file, fieldname, flw_data, & + field_loc_center, field_type_scalar) + fieldname='t_10' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, tair_file, fieldname, Tair_data, & + field_loc_center, field_type_scalar) + fieldname='rho_10' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, rhoa_file, fieldname, rhoa_data, & + field_loc_center, field_type_scalar) + fieldname='q_10' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, humid_file, fieldname, Qa_data, & + field_loc_center, field_type_scalar) + + ! Interpolate onto current timestep + + call interpolate_data (fsw_data, fsw) + call interpolate_data (flw_data, flw) + call interpolate_data (Tair_data, Tair) + call interpolate_data (rhoa_data, rhoa) + call interpolate_data (Qa_data, Qa) + + endif ! calc_Tsfc or oceanmixed_ice or calc_strair + + if (.not. calc_Tsfc) then + + ! ------------------------------------------------------ + ! Sublimation, topmelt and botmelt + ! ------------------------------------------------------ + + fieldname='sublim' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, sublim_file, fieldname, sublim_data, & + field_loc_center, field_type_scalar) + + ! Interpolate to current time step + call interpolate_data (sublim_data, sublim) + + do n = 1, ncat + write(fieldname, '(a,i1)') 'topmeltn',n + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, topmelt_file(n), fieldname, topmelt_data(:,:,:,:,n), & + field_loc_center, field_type_scalar) + + write(fieldname, '(a,i1)') 'botmeltn',n + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, botmelt_file(n), fieldname, botmelt_data(:,:,:,:,n), & + field_loc_center, field_type_scalar) + + call interpolate_data (topmelt_data(:,:,:,:,n), topmelt) + call interpolate_data (botmelt_data(:,:,:,:,n), botmelt) + + !-------------------------------------------------------- + ! Convert from UM variables to CICE variables + ! topmelt = fsurf - fcondtop + ! botmelt = fcondtop (as zero layer) + ! + ! Convert UM sublimation data into CICE LH flux + ! (sublim = - flatn / Lsub) and have same value for all + ! categories + !-------------------------------------------------------- + + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + + fcondtopn_f(i,j,n,iblk) = botmelt(i,j,iblk) + fsurfn_f(i,j,n,iblk) = topmelt(i,j,iblk) & + + botmelt(i,j,iblk) + flatn_f(i,j,n,iblk) = - sublim(i,j,iblk)*Lsub + + enddo + enddo + + enddo + + enddo ! ncat + + endif ! .not. calc_Tsfc + + end subroutine hadgem_data + !======================================================================= ! monthly forcing !======================================================================= @@ -2529,7 +3058,7 @@ subroutine ocn_data_clim (dt) ! use ice_domain, only: nblocks use ice_ocean - use ice_flux, only: Tf, sss, sst, uocn, vocn, ss_tltx, ss_tlty + use ice_flux, only: Tf, sss, sst, uocn, vocn, ss_tltx, ss_tlty, Tfrzpt use ice_grid, only: t2ugrid_vector ! ! !INPUT/OUTPUT PARAMETERS: @@ -2617,7 +3146,11 @@ subroutine ocn_data_clim (dt) do j = 1, ny_block do i = 1, nx_block sss(i,j,iblk) = max(sss(i,j,iblk), c0) - Tf (i,j,iblk) = -depressT*sss(i,j,iblk) ! deg C + if (trim(Tfrzpt) == 'constant') then + Tf (i,j,iblk) = -1.8_dbl_kind ! deg C + else ! default: Tfrzpt = 'linear_S' + Tf (i,j,iblk) = -depressT * sss(i,j,iblk) ! deg C + endif enddo enddo enddo @@ -2836,7 +3369,7 @@ subroutine ocn_data_ncar(dt) use ice_exit use ice_work, only: work_g1, work1 use ice_flux, only: sss, sst, Tf, uocn, vocn, ss_tltx, ss_tlty, & - qdp, hmix + qdp, hmix, Tfrzpt ! use ice_ocean use ice_restart, only: restart use ice_grid, only: hm, tmask, umask @@ -2927,7 +3460,11 @@ subroutine ocn_data_ncar(dt) do j = 1, ny_block do i = 1, nx_block sss (i,j,:) = max (sss(i,j,:), c0) - Tf (i,j,:) = -depressT*sss(i,j,:) ! deg C + if (trim(Tfrzpt) == 'constant') then + Tf (i,j,:) = -1.8_dbl_kind ! deg C + else ! default: Tfrzpt = 'linear_S' + Tf (i,j,:) = -depressT * sss(i,j,:) ! deg C + endif hmix(i,j,:) = max(hmix(i,j,:), c0) enddo enddo @@ -3000,6 +3537,205 @@ subroutine ocn_data_ncar(dt) end subroutine ocn_data_ncar +!======================================================================= +! +!BOP +! +! !IROUTINE: ocn_data_hadgem - read HadGEM ocean data +! +! !INTERFACE: +! + subroutine ocn_data_hadgem(dt) +! +! !DESCRIPTION: +! Reads in HadGEM ocean forcing data as required from netCDF files +! Current options (selected by sst_data_type) +! hadgem_sst: read in sst only +! hadgem_sst_uvocn: read in sst plus uocn and vocn +! +! +! !REVISION HISTORY: +! +! authors: Ann Keen, Met Office +! +! !USES: +! + use ice_domain, only: nblocks + use ice_flux, only: sst, uocn, vocn + use ice_grid, only: t2ugrid_vector, ANGLET +! +! !INPUT/OUTPUT PARAMETERS: +! +! +!EOP +! + real (kind=dbl_kind), intent(in) :: & + dt ! time step + + integer (kind=int_kind) :: & + i, j , & ! horizontal indices + n , & ! thickness category index + iblk , & ! block index + ixm,ixx,ixp , & ! record numbers for neighboring months + recnum , & ! record number + maxrec , & ! maximum record number + recslot , & ! spline slot for current record + dataloc , & ! = 1 for data located in middle of time interval + ! = 2 for date located at end of time interval + midmonth ! middle day of month + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & + sstdat ! data value toward which SST is restored + + real (kind=dbl_kind) :: workx, worky + + logical (kind=log_kind) :: readm + + character (char_len) :: & + fieldname ! field name in netcdf file + + character (char_len_long) :: & + filename ! name of netCDF file + + !------------------------------------------------------------------- + ! monthly data + ! + ! Assume that monthly data values are located in the middle of the + ! month. + !------------------------------------------------------------------- + + midmonth = 15 ! data is given on 15th of every month +! midmonth = fix(p5 * real(daymo(month))) ! exact middle + + ! Compute record numbers for surrounding months + maxrec = 12 + ixm = mod(month+maxrec-2,maxrec) + 1 + ixp = mod(month, maxrec) + 1 + if (mday >= midmonth) ixm = 99 ! other two points will be used + if (mday < midmonth) ixp = 99 + + ! Determine whether interpolation will use values 1:2 or 2:3 + ! recslot = 2 means we use values 1:2, with the current value (2) + ! in the second slot + ! recslot = 1 means we use values 2:3, with the current value (2) + ! in the first slot + recslot = 1 ! latter half of month + if (mday < midmonth) recslot = 2 ! first half of month + + ! Find interpolation coefficients + call interp_coeff_monthly (recslot) + + ! Read 2 monthly values + readm = .false. + if (istep==1 .or. (mday==midmonth .and. sec==0)) readm = .true. + + + if (my_task == master_task .and. istep == 1) then + write (nu_diag,*) ' ' + write (nu_diag,*) 'SST data interpolated to timestep:' + write (nu_diag,*) trim(ocn_data_dir)//'MONTHLY/sst.1997.nc' + if (restore_sst) write (nu_diag,*) & + 'SST restoring timescale (days) =', trestore + if (trim(sst_data_type)=='hadgem_sst_uvocn') then + write (nu_diag,*) ' ' + write (nu_diag,*) 'uocn and vocn interpolated to timestep:' + write (nu_diag,*) trim(ocn_data_dir)//'MONTHLY/uocn.1997.nc' + write (nu_diag,*) trim(ocn_data_dir)//'MONTHLY/vocn.1997.nc' + endif + endif ! my_task, istep + + + ! ----------------------------------------------------------- + ! SST + ! ----------------------------------------------------------- + sst_file = trim(ocn_data_dir)//'MONTHLY/sst.1997.nc' + fieldname='sst' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, sst_file, fieldname, sst_data, & + field_loc_center, field_type_scalar) + + ! Interpolate to current time step + call interpolate_data (sst_data, sstdat) + + ! Restore SSTs if required + if (restore_sst) then + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + sst(i,j,iblk) = sst(i,j,iblk) & + + (sstdat(i,j,iblk)-sst(i,j,iblk))*dt/trest + enddo + enddo + enddo + endif + + + ! ----------------------------------------------------------- + ! Ocean currents + ! -------------- + ! Values read in are on T grid and oriented geographically, hence + ! vectors need to be rotated to model grid and then interpolated + ! to U grid. + ! Also need to be converted from cm s-1 (UM) to m s-1 (CICE) + ! ----------------------------------------------------------- + + if (trim(sst_data_type)=='hadgem_sst_uvocn') then + + filename = trim(ocn_data_dir)//'MONTHLY/uocn.1997.nc' + fieldname='uocn' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, filename, fieldname, uocn_data, & + field_loc_center, field_type_vector) + + ! Interpolate to current time step + call interpolate_data (uocn_data, uocn) + + filename = trim(ocn_data_dir)//'MONTHLY/vocn.1997.nc' + fieldname='vocn' + call read_data_nc (readm, 0, fyear, ixm, month, ixp, & + maxrec, filename, fieldname, vocn_data, & + field_loc_center, field_type_vector) + + ! Interpolate to current time step + call interpolate_data (vocn_data, vocn) + + !----------------------------------------------------------------- + ! Rotate zonal/meridional vectors to local coordinates, + ! and change units + !----------------------------------------------------------------- + + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + + workx = uocn(i,j,iblk) + worky = vocn(i,j,iblk) + uocn(i,j,iblk) = workx*cos(ANGLET(i,j,iblk)) & + + worky*sin(ANGLET(i,j,iblk)) + vocn(i,j,iblk) = worky*cos(ANGLET(i,j,iblk)) & + - workx*sin(ANGLET(i,j,iblk)) + + uocn(i,j,iblk) = uocn(i,j,iblk) * cm_to_m + vocn(i,j,iblk) = vocn(i,j,iblk) * cm_to_m + + enddo ! i + enddo ! j + enddo ! nblocks + + !----------------------------------------------------------------- + ! Interpolate to U grid + !----------------------------------------------------------------- + + call t2ugrid_vector(uocn) + call t2ugrid_vector(vocn) + + + endif ! sst_data_type = hadgem_sst_uvocn + + + end subroutine ocn_data_hadgem + + !======================================================================= end module ice_forcing diff --git a/cice/source/ice_grid.F90 b/cice/source/ice_grid.F90 index 3644ade..cfdd398 100644 --- a/cice/source/ice_grid.F90 +++ b/cice/source/ice_grid.F90 @@ -79,6 +79,13 @@ module ice_grid dxhy , & ! 0.5*(HTE - HTE) dyhx ! 0.5*(HTN - HTN) + ! Corners of grid boxes for history output + real (kind=dbl_kind), dimension (4,nx_block,ny_block,max_blocks):: & + lont_bounds, & ! longitude of gridbox corners for T point + latt_bounds, & ! latitude of gridbox corners for T point + lonu_bounds, & ! longitude of gridbox corners for U point + latu_bounds ! latitude of gridbox corners for U point + ! geometric quantities used for remapping transport real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks):: & xav , & ! mean T-cell value of x @@ -447,6 +454,12 @@ subroutine init_grid2 call Tlatlon ! get lat, lon on the T grid + !---------------------------------------------------------------- + ! Corner coordinates for CF compliant history files + !---------------------------------------------------------------- + + call gridbox_corners + !----------------------------------------------------------------- ! Compute global index (used for unpacking messages from coupler) !----------------------------------------------------------------- @@ -552,11 +565,15 @@ subroutine popgrid allocate(work_g1(nx_global,ny_global)) call ice_read_global(nu_grid,1,work_g1,'rda8',.true.) ! ULAT + call gridbox_verts(work_g1,latt_bounds) call scatter_global(ULAT, work_g1, master_task, distrb_info, & field_loc_NEcorner, field_type_scalar) + call ice_read_global(nu_grid,2,work_g1,'rda8',.true.) ! ULON + call gridbox_verts(work_g1,lont_bounds) call scatter_global(ULON, work_g1, master_task, distrb_info, & field_loc_NEcorner, field_type_scalar) + call ice_read_global(nu_grid,7,work_g1,'rda8',.true.) ! ANGLE call scatter_global(ANGLE, work_g1, master_task, distrb_info, & field_loc_NEcorner, field_type_scalar) @@ -674,12 +691,25 @@ subroutine popgrid_nc fieldname='ulat' call ice_read_global_nc(fid_grid,1,fieldname,work_g1,diag) ! ULAT +#ifdef ORCA_GRID + ! Kludge: remove this code when ORCA grid files are fixed. + ! Extrapolate to correct ULAT along j=1. + if (my_task == master_task) then + do i = 1, nx_global + work_g1(i,1) = c2*work_g1(i,2) - work_g1(i,3) + enddo + endif +#endif + call gridbox_verts(work_g1,latt_bounds) call scatter_global(ULAT, work_g1, master_task, distrb_info, & field_loc_NEcorner, field_type_scalar) + fieldname='ulon' call ice_read_global_nc(fid_grid,2,fieldname,work_g1,diag) ! ULON + call gridbox_verts(work_g1,lont_bounds) call scatter_global(ULON, work_g1, master_task, distrb_info, & field_loc_NEcorner, field_type_scalar) + fieldname='angle' call ice_read_global_nc(fid_grid,7,fieldname,work_g1,diag) ! ANGLE call scatter_global(ANGLE, work_g1, master_task, distrb_info, & @@ -1920,24 +1950,25 @@ subroutine bsslzr(bes, n) ! Local Workspace !----------------------------------------- - data bz/ 2.4048255577_dbl_kind, 5.5200781103_dbl_kind, 8.6537279129_dbl_kind ,& - 11.7915344391_dbl_kind, 14.9309177086_dbl_kind, 18.0710639679_dbl_kind ,& - 21.2116366299_dbl_kind, 24.3524715308_dbl_kind, 27.4934791320_dbl_kind ,& - 30.6346064684_dbl_kind, 33.7758202136_dbl_kind, 36.9170983537_dbl_kind ,& - 40.0584257646_dbl_kind, 43.1997917132_dbl_kind, 46.3411883717_dbl_kind ,& - 49.4826098974_dbl_kind, 52.6240518411_dbl_kind, 55.7655107550_dbl_kind ,& - 58.9069839261_dbl_kind, 62.0484691902_dbl_kind, 65.1899648002_dbl_kind ,& - 68.3314693299_dbl_kind, 71.4729816036_dbl_kind, 74.6145006437_dbl_kind ,& - 77.7560256304_dbl_kind, 80.8975558711_dbl_kind, 84.0390907769_dbl_kind ,& - 87.1806298436_dbl_kind, 90.3221726372_dbl_kind, 93.4637187819_dbl_kind ,& - 96.6052679510_dbl_kind, 99.7468198587_dbl_kind, 102.8883742542_dbl_kind ,& - 106.0299309165_dbl_kind, 109.1714896498_dbl_kind, 112.3130502805_dbl_kind ,& - 115.4546126537_dbl_kind, 118.5961766309_dbl_kind, 121.7377420880_dbl_kind ,& - 124.8793089132_dbl_kind, 128.0208770059_dbl_kind, 131.1624462752_dbl_kind ,& - 134.3040166383_dbl_kind, 137.4455880203_dbl_kind, 140.5871603528_dbl_kind ,& - 143.7287335737_dbl_kind, 146.8703076258_dbl_kind, 150.0118824570_dbl_kind ,& - 153.1534580192_dbl_kind, 156.2950342685_dbl_kind/ -! + data bz/ & + 2.4048255577_dbl_kind, 5.5200781103_dbl_kind, 8.6537279129_dbl_kind, & + 11.7915344391_dbl_kind, 14.9309177086_dbl_kind, 18.0710639679_dbl_kind, & + 21.2116366299_dbl_kind, 24.3524715308_dbl_kind, 27.4934791320_dbl_kind, & + 30.6346064684_dbl_kind, 33.7758202136_dbl_kind, 36.9170983537_dbl_kind, & + 40.0584257646_dbl_kind, 43.1997917132_dbl_kind, 46.3411883717_dbl_kind, & + 49.4826098974_dbl_kind, 52.6240518411_dbl_kind, 55.7655107550_dbl_kind, & + 58.9069839261_dbl_kind, 62.0484691902_dbl_kind, 65.1899648002_dbl_kind, & + 68.3314693299_dbl_kind, 71.4729816036_dbl_kind, 74.6145006437_dbl_kind, & + 77.7560256304_dbl_kind, 80.8975558711_dbl_kind, 84.0390907769_dbl_kind, & + 87.1806298436_dbl_kind, 90.3221726372_dbl_kind, 93.4637187819_dbl_kind, & + 96.6052679510_dbl_kind, 99.7468198587_dbl_kind, 102.8883742542_dbl_kind, & + 106.0299309165_dbl_kind, 109.1714896498_dbl_kind, 112.3130502805_dbl_kind, & + 115.4546126537_dbl_kind, 118.5961766309_dbl_kind, 121.7377420880_dbl_kind, & + 124.8793089132_dbl_kind, 128.0208770059_dbl_kind, 131.1624462752_dbl_kind, & + 134.3040166383_dbl_kind, 137.4455880203_dbl_kind, 140.5871603528_dbl_kind, & + 143.7287335737_dbl_kind, 146.8703076258_dbl_kind, 150.0118824570_dbl_kind, & + 153.1534580192_dbl_kind, 156.2950342685_dbl_kind/ + nn = n if (n > 50) then bes(50) = bz(50) @@ -1950,6 +1981,315 @@ subroutine bsslzr(bes, n) end subroutine bsslzr +!======================================================================= +! The following code is used for obtaining the coordinates of the grid +! vertices for CF-compliant netCDF history output. Approximate! +!======================================================================= +! +!BOP +! +! !IROUTINE: gridbox_corners - get coordinates of grid box corners +! +! !INTERFACE: +! + subroutine gridbox_corners +! +! !DESCRIPTION: +! +! NOTE: Boundary conditions for fields on NW, SW, SE corners +! have not been implemented; using NE corner location for all. +! Extrapolations are also used: these fields are approximate! +! +! !REVISION HISTORY: +! +! authors: A. McLaren, Met Office +! E. Hunke, LANL +! +! !USES: + use ice_work, only: work1, work_g2 +! +! !INPUT/OUTPUT PARAMETERS: +! +!EOP +! + integer (kind=int_kind) :: & + i,j,iblk,icorner,& ! index counters + ilo,ihi,jlo,jhi ! beginning and end of physical domain + + type (block) :: & + this_block ! block information for current block + + !------------------------------------------------------------- + ! Get coordinates of grid boxes for each block as follows: + ! (1) SW corner, (2) SE corner, (3) NE corner, (4) NW corner + !------------------------------------------------------------- + + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + do j = jlo, jhi + do i = ilo, ihi + + latu_bounds(1,i,j,iblk)=TLAT(i ,j ,iblk)*rad_to_deg + latu_bounds(2,i,j,iblk)=TLAT(i+1,j ,iblk)*rad_to_deg + latu_bounds(3,i,j,iblk)=TLAT(i+1,j+1,iblk)*rad_to_deg + latu_bounds(4,i,j,iblk)=TLAT(i ,j+1,iblk)*rad_to_deg + + lonu_bounds(1,i,j,iblk)=TLON(i ,j ,iblk)*rad_to_deg + lonu_bounds(2,i,j,iblk)=TLON(i+1,j ,iblk)*rad_to_deg + lonu_bounds(3,i,j,iblk)=TLON(i+1,j+1,iblk)*rad_to_deg + lonu_bounds(4,i,j,iblk)=TLON(i ,j+1,iblk)*rad_to_deg + + enddo + enddo + enddo + + !---------------------------------------------------------------- + ! extrapolate on global grid to get edge values + !---------------------------------------------------------------- + + if (my_task == master_task) then + allocate(work_g2(nx_global,ny_global)) + else + allocate(work_g2(1,1)) + endif + + work1(:,:,:) = latu_bounds(2,:,:,:) + call gather_global(work_g2, work1, master_task, distrb_info) + if (my_task == master_task) then + do j = 1, ny_global + work_g2(nx_global,j) = c2*work_g2(nx_global-1,j) & + - work_g2(nx_global-2,j) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + latu_bounds(2,:,:,:) = work1(:,:,:) + + work1(:,:,:) = latu_bounds(3,:,:,:) + call gather_global(work_g2, work1, master_task, distrb_info) + if (my_task == master_task) then + do i = 1, nx_global + work_g2(i,ny_global) = c2*work_g2(i,ny_global-1) & + - work_g2(i,ny_global-2) + enddo + do j = 1, ny_global + work_g2(nx_global,j) = c2*work_g2(nx_global-1,j) & + - work_g2(nx_global-2,j) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + latu_bounds(3,:,:,:) = work1(:,:,:) + + work1(:,:,:) = latu_bounds(4,:,:,:) + call gather_global(work_g2, work1, master_task, distrb_info) + if (my_task == master_task) then + do i = 1, nx_global + work_g2(i,ny_global) = c2*work_g2(i,ny_global-1) & + - work_g2(i,ny_global-2) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + latu_bounds(4,:,:,:) = work1(:,:,:) + + work1(:,:,:) = lonu_bounds(2,:,:,:) + call gather_global(work_g2, work1, master_task, distrb_info) + if (my_task == master_task) then + do j = 1, ny_global + work_g2(nx_global,j) = c2*work_g2(nx_global-1,j) & + - work_g2(nx_global-2,j) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + lonu_bounds(2,:,:,:) = work1(:,:,:) + + work1(:,:,:) = lonu_bounds(3,:,:,:) + call gather_global(work_g2, work1, master_task, distrb_info) + if (my_task == master_task) then + do i = 1, nx_global + work_g2(i,ny_global) = c2*work_g2(i,ny_global-1) & + - work_g2(i,ny_global-2) + enddo + do j = 1, ny_global + work_g2(nx_global,j) = c2*work_g2(nx_global-1,j) & + - work_g2(nx_global-2,j) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + lonu_bounds(3,:,:,:) = work1(:,:,:) + + work1(:,:,:) = lonu_bounds(4,:,:,:) + call gather_global(work_g2, work1, master_task, distrb_info) + if (my_task == master_task) then + do i = 1, nx_global + work_g2(i,ny_global) = c2*work_g2(i,ny_global-1) & + - work_g2(i,ny_global-2) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + lonu_bounds(4,:,:,:) = work1(:,:,:) + + deallocate(work_g2) + + !---------------------------------------------------------------- + ! Convert longitude to Degrees East >0 for history output + !---------------------------------------------------------------- + + allocate(work_g2(nx_block,ny_block)) ! not used as global here + do iblk = 1, nblocks + do icorner = 1, 4 + work_g2(:,:) = lont_bounds(icorner,:,:,iblk) + c360 + where (work_g2 > c360) work_g2 = work_g2 - c360 + where (work_g2 < c0 ) work_g2 = work_g2 + c360 + lont_bounds(icorner,:,:,iblk) = work_g2(:,:) + work_g2(:,:) = lonu_bounds(icorner,:,:,iblk) + c360 + where (work_g2 > c360) work_g2 = work_g2 - c360 + where (work_g2 < c0 ) work_g2 = work_g2 + c360 + lonu_bounds(icorner,:,:,iblk) = work_g2(:,:) + enddo + enddo + deallocate(work_g2) + + end subroutine gridbox_corners + +!======================================================================= +! +!BOP +! +! !IROUTINE: gridbox_verts - coordinates of grid box vertices +! +! !INTERFACE: +! + subroutine gridbox_verts(work_g,vbounds) +! +! !DESCRIPTION: +! +! NOTE: Boundary conditions for fields on NW, SW, SE corners +! have not been implemented; using NE corner location for all. +! Extrapolations are also used: these fields are approximate! +! +! !REVISION HISTORY: +! +! authors: A. McLaren, Met Office +! E. Hunke, LANL +! +! !USES: + use ice_work, only: work_g2, work1 +! +! !INPUT/OUTPUT PARAMETERS: +! +!EOP +! + real (kind=dbl_kind), dimension(:,:), intent(in) :: work_g + + real (kind=dbl_kind), & + dimension(4,nx_block,ny_block,max_blocks), & + intent(out) :: vbounds + + integer (kind=int_kind) :: & + i,j, & ! index counters + ilo,ihi,jlo,jhi ! beginning and end of physical domain + + type (block) :: & + this_block ! block information for current block + + if (my_task == master_task) then + allocate(work_g2(nx_global,ny_global)) + else + allocate(work_g2(1,1)) + endif + + !------------------------------------------------------------- + ! Get coordinates of grid boxes for each block as follows: + ! (1) SW corner, (2) SE corner, (3) NE corner, (4) NW corner + !------------------------------------------------------------- + + work_g2(:,:) = c0 + if (my_task == master_task) then + do j = 2, ny_global + do i = 2, nx_global + work_g2(i,j) = work_g(i-1,j-1) * rad_to_deg + enddo + enddo + ! extrapolate + do j = 1, ny_global + work_g2(1,j) = c2*work_g2(2,j) - work_g2(3,j) + enddo + do i = 1, nx_global + work_g2(i,1) = c2*work_g2(i,2) - work_g2(i,3) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + vbounds(1,:,:,:) = work1(:,:,:) + + work_g2(:,:) = c0 + if (my_task == master_task) then + do j = 2, ny_global + do i = 1, nx_global + work_g2(i,j) = work_g(i,j-1) * rad_to_deg + enddo + enddo + ! extrapolate + do i = 1, nx_global + work_g2(i,1) = (c2*work_g2(i,2) - work_g2(i,3)) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + vbounds(2,:,:,:) = work1(:,:,:) + + work_g2(:,:) = c0 + if (my_task == master_task) then + do j = 1, ny_global + do i = 1, nx_global + work_g2(i,j) = work_g(i,j) * rad_to_deg + enddo + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + vbounds(3,:,:,:) = work1(:,:,:) + + work_g2(:,:) = c0 + if (my_task == master_task) then + do j = 1, ny_global + do i = 2, nx_global + work_g2(i,j) = work_g(i-1,j ) * rad_to_deg + enddo + enddo + ! extrapolate + do j = 1, ny_global + work_g2(1,j) = c2*work_g2(2,j) - work_g2(3,j) + enddo + endif + call scatter_global(work1, work_g2, & + master_task, distrb_info, & + field_loc_NEcorner, field_type_scalar) + vbounds(4,:,:,:) = work1(:,:,:) + + deallocate (work_g2) + + end subroutine gridbox_verts + !======================================================================= end module ice_grid diff --git a/cice/source/ice_history.F90 b/cice/source/ice_history.F90 index 3462e12..8cdf8c6 100644 --- a/cice/source/ice_history.F90 +++ b/cice/source/ice_history.F90 @@ -78,8 +78,10 @@ module ice_history !--------------------------------------------------------------- integer (kind=int_kind), parameter :: & + nvar = 11 , & ! number of grid fields that can be written + ! excluding grid vertices ncat_hist = ncat , & ! number of ice categories written <= ncat - avgsiz = 77 + 3*ncat_hist ! number of fields that can be written + avgsiz = 80 + 7*ncat_hist ! number of fields that can be written real (kind=real_kind) :: time_beg, time_end ! bounds for averaging @@ -93,16 +95,20 @@ module ice_history conb(avgsiz) ! additive conversion factor logical (kind=log_kind) :: & - iout(avgsiz) ! true if field is written to output file + iout(avgsiz) , & ! true if time-dep field is written to output file + igrd(nvar) ! true if grid field is written to output file character (len=16) :: & vname(avgsiz) , & ! variable names vunit(avgsiz) , & ! variable units - vcoord(avgsiz) ! variable coordinates + vcoord(avgsiz), & ! variable coordinates + vcellmeas(avgsiz) ! variable cell measures character (len=16), parameter :: & - tstr = 'TLON TLAT time', & ! vcoord for T cell quantities - ustr = 'ULON ULAT time' ! vcoord for U cell quantities + tstr = 'TLON TLAT time', & ! vcoord for T cell quantities + ustr = 'ULON ULAT time', & ! vcoord for U cell quantities + tcstr = 'area: tarea' , & ! vcellmeas for T cell quantities + ucstr = 'area: uarea' ! vcellmeas for U cell quantities character (len=55) :: & vdesc(avgsiz) , & ! variable descriptions @@ -112,6 +118,15 @@ module ice_history ! logical flags: write to output file if true !--------------------------------------------------------------- + logical (kind=log_kind) :: & + f_tmask = .true., & + f_tarea = .true., f_uarea = .true., & + f_dxt = .true., f_dyt = .true., & + f_dxu = .true., f_dyu = .true., & + f_HTN = .true., f_HTE = .true., & + f_ANGLE = .true., f_ANGLET = .true., & + f_bounds = .true. + logical (kind=log_kind) :: & f_hi = .true., f_hs = .true., & f_Tsfc = .true., f_aice = .true., & @@ -154,13 +169,24 @@ module ice_history f_hisnap = .true., f_aisnap = .true., & f_aicen = .true., f_vicen = .true., & f_volpn = .false., & - f_trsig = .true., f_icepresent = .true. + f_trsig = .true., f_icepresent = .true., & + f_fsurf_ai = .true., f_fcondtop_ai= .true., & + f_fmeltt_ai = .true., & + f_fsurfn_ai = .true.,f_fcondtopn_ai= .true., & + f_fmelttn_ai= .true., f_flatn_ai = .true. !--------------------------------------------------------------- ! namelist variables (same as logical flags) !--------------------------------------------------------------- namelist / icefields_nml / & + f_tmask , & + f_tarea , f_uarea , & + f_dxt , f_dyt , & + f_dxu , f_dyu , & + f_HTN , f_HTE , & + f_ANGLE , f_ANGLET , & + f_bounds , & f_hi, f_hs , & f_Tsfc, f_aice , & f_uvel, f_vvel , & @@ -202,13 +228,34 @@ module ice_history f_hisnap, f_aisnap , & f_aicen, f_vicen , & f_iage, f_volpn , & - f_trsig, f_icepresent + f_trsig, f_icepresent,& + f_fsurf_ai, f_fcondtop_ai,& + f_fmeltt_ai, & + f_fsurfn_ai,f_fcondtopn_ai,& + f_fmelttn_ai,f_flatn_ai !--------------------------------------------------------------- ! field indices !--------------------------------------------------------------- integer (kind=int_kind), parameter :: & + n_tmask = 1, & + n_tarea = 2, & + n_uarea = 3, & + n_dxt = 4, & + n_dyt = 5, & + n_dxu = 6, & + n_dyu = 7, & + n_HTN = 8, & + n_HTE = 9, & + n_ANGLE = 10, & + n_ANGLET = 11, & + + n_lont_bnds = 1, & + n_latt_bnds = 2, & + n_lonu_bnds = 3, & + n_latu_bnds = 4, & + n_hi = 1, & n_hs = 2, & n_Tsfc = 3, & @@ -286,9 +333,16 @@ module ice_history n_trsig = 75, & n_icepresent = 76, & n_iage = 77, & - n_aicen = 78, & ! n_aicen, n_vicen, n_volpn must be - n_vicen = 79 + ncat_hist - 1, & ! last in this list - n_volpn = 79 + 2*ncat_hist - 1 + n_fsurf_ai = 78, & + n_fcondtop_ai= 79, & + n_fmeltt_ai = 80, & + n_aicen = 81, & ! n_aicen, n_vicen must be last in this list + n_vicen = 82 + 1*ncat_hist - 1, & + n_volpn = 82 + 2*ncat_hist - 1, & + n_fsurfn_ai = 82 + 3*ncat_hist - 1, & + n_fcondtopn_ai = 82 + 4*ncat_hist - 1, & + n_fmelttn_ai = 82 + 5*ncat_hist - 1, & + n_flatn_ai = 82 + 6*ncat_hist - 1 !======================================================================= @@ -336,7 +390,7 @@ subroutine init_hist (dt) integer (kind=int_kind) :: nml_error ! namelist i/o error flag character (len=3) :: nchar - character (len=30) :: tmp + character (len=40) :: tmp !--------------------------------------------------------------- ! field names @@ -419,14 +473,29 @@ subroutine init_hist (dt) vname(n_trsig ) = 'trsig' vname(n_icepresent) = 'ice_present' vname(n_iage ) = 'iage' + vname(n_fsurf_ai ) = 'fsurf_ai' + vname(n_fcondtop_ai)= 'fcondtop_ai' + vname(n_fmeltt_ai ) = 'fmeltt_ai' do n = 1, ncat_hist write(nchar,'(i3.3)') n write(vname(n_aicen+n-1),'(a,a)') 'aice', trim(nchar) ! aicen write(vname(n_vicen+n-1),'(a,a)') 'vice', trim(nchar) ! vicen write(vname(n_volpn+n-1),'(a,a)') 'volp', trim(nchar) ! volpn - vname(n_aicen+n-1) = trim(vname(n_aicen+n-1)) - vname(n_vicen+n-1) = trim(vname(n_vicen+n-1)) - vname(n_volpn+n-1) = trim(vname(n_volpn+n-1)) + write(vname(n_fsurfn_ai+n-1),'(a,a)') & + 'fsurfn_ai', trim(nchar) ! fsurfn + write(vname(n_fcondtopn_ai+n-1),'(a,a)') & + 'fcondtopn_ai', trim(nchar) ! fcondtopn + write(vname(n_fmelttn_ai+n-1),'(a,a)') & + 'fmelttn_ai', trim(nchar) ! fmeltn + write(vname(n_flatn_ai+n-1),'(a,a)') & + 'flatn_ai', trim(nchar) ! flatn + vname(n_aicen+n-1) = trim(vname(n_aicen+n-1)) + vname(n_vicen+n-1) = trim(vname(n_vicen+n-1)) + vname(n_volpn+n-1) = trim(vname(n_volpn+n-1)) + vname(n_fsurfn_ai+n-1) = trim(vname(n_fsurfn_ai+n-1)) + vname(n_fcondtopn_ai+n-1) = trim(vname(n_fcondtopn_ai+n-1)) + vname(n_fmelttn_ai+n-1) = trim(vname(n_fmelttn_ai+n-1)) + vname(n_flatn_ai+n-1) = trim(vname(n_flatn_ai+n-1)) enddo !--------------------------------------------------------------- @@ -511,6 +580,9 @@ subroutine init_hist (dt) vdesc(n_icepresent) = & 'fraction of time-avg interval that any ice is present' vdesc(n_iage ) = 'sea ice age' + vdesc(n_fsurf_ai ) = 'net surface heat flux' + vdesc(n_fcondtop_ai)= 'top surface conductive heat flux' + vdesc(n_fmeltt_ai ) = 'net surface heat flux causing melt' do n = 1, ncat_hist write(nchar,'(i3)') n @@ -525,6 +597,22 @@ subroutine init_hist (dt) tmp = 'meltpond volume, category ' ! volpn write(vdesc(n_volpn+n-1),'(a,2x,a)') trim(tmp), trim(nchar) vdesc(n_volpn+n-1) = trim(vdesc(n_volpn+n-1)) + + tmp = 'net surface heat flux, category ' ! fsurfn + write(vdesc(n_fsurfn_ai+n-1),'(a,2x,a)') trim(tmp), trim(nchar) + vdesc(n_fsurfn_ai+n-1) = trim(vdesc(n_fsurfn_ai+n-1)) + + tmp = 'top sfc conductive heat flux , cat ' ! fcondtopn + write(vdesc(n_fcondtopn_ai+n-1),'(a,2x,a)') trim(tmp), trim(nchar) + vdesc(n_fcondtopn_ai+n-1) = trim(vdesc(n_fcondtopn_ai+n-1)) + + tmp = 'net sfc heat flux causing melt, cat ' ! fmelttn + write(vdesc(n_fmelttn_ai+n-1),'(a,2x,a)') trim(tmp), trim(nchar) + vdesc(n_fmelttn_ai+n-1) = trim(vdesc(n_fmelttn_ai+n-1)) + + tmp = 'latent heat flux, category ' ! flatn + write(vdesc(n_flatn_ai+n-1),'(a,2x,a)') trim(tmp), trim(nchar) + vdesc(n_flatn_ai+n-1) = trim(vdesc(n_flatn_ai+n-1)) enddo !--------------------------------------------------------------- @@ -608,10 +696,17 @@ subroutine init_hist (dt) vunit(n_trsig ) = 'N/m^2' vunit(n_icepresent) = '1' vunit(n_iage ) = 'years' + vunit(n_fsurf_ai ) = 'W/m^2' + vunit(n_fcondtop_ai)= 'W/m^2' + vunit(n_fmeltt_ai ) = 'W/m^2' do n = 1, ncat_hist - vunit(n_aicen+n-1) = ' ' ! aicen - vunit(n_vicen+n-1) = 'm' ! vicen - vunit(n_volpn+n-1) = 'm' ! volpn + vunit(n_aicen+n-1) = ' ' ! aicen + vunit(n_vicen+n-1) = 'm' ! vicen + vunit(n_volpn+n-1) = 'm' ! volpn + vunit(n_fsurfn_ai+n-1) = 'W/m^2' ! fsurfn + vunit(n_fcondtopn_ai+n-1) = 'W/m^2' ! fcondtopn + vunit(n_fmelttn_ai+n-1) = 'W/m^2' ! fmelttn + vunit(n_flatn_ai+n-1) = 'W/m^2' ! flatn enddo #if (defined CCSM) || (defined SEQ_MCT) @@ -709,10 +804,18 @@ subroutine init_hist (dt) vcomment(n_trsig ) = 'ice strength approximation' vcomment(n_icepresent) = 'ice extent flag' vcomment(n_iage ) = 'none' + vcomment(n_fsurf_ai ) = & + 'positive downwards, excludes conductive flux, weighted by ice area' + vcomment(n_fcondtop_ai)= 'positive downwards, weighted by ice area' + vcomment(n_fmeltt_ai ) = 'always >= 0, weighted by ice area' do n = 1, ncat_hist - vcomment(n_aicen+n-1) = 'Ice range:' ! aicen - vcomment(n_vicen+n-1) = 'none' ! vicen - vcomment(n_volpn+n-1) = 'none' ! volpn + vcomment(n_aicen+n-1) = 'Ice range:' ! aicen + vcomment(n_vicen+n-1) = 'none' ! vicen + vcomment(n_volpn+n-1) = 'none' ! volpn + vcomment(n_fsurfn_ai+n-1) = 'weighted by ice area' ! fsurfn + vcomment(n_fcondtopn_ai+n-1) = 'weighted by ice area' ! fcontopn + vcomment(n_fmelttn_ai+n-1) = 'weighted by ice area' ! fmelttn + vcomment(n_flatn_ai+n-1) = 'weighted by ice area' ! flatn enddo !----------------------------------------------------------------- @@ -742,6 +845,22 @@ subroutine init_hist (dt) endif if (.not. tr_iage) f_iage = .false. +#ifndef ncdf + f_bounds = .false. +#endif + + call broadcast_scalar (f_tmask, master_task) + call broadcast_scalar (f_tarea, master_task) + call broadcast_scalar (f_uarea, master_task) + call broadcast_scalar (f_dxt, master_task) + call broadcast_scalar (f_dyt, master_task) + call broadcast_scalar (f_dxu, master_task) + call broadcast_scalar (f_dyu, master_task) + call broadcast_scalar (f_HTN, master_task) + call broadcast_scalar (f_HTE, master_task) + call broadcast_scalar (f_ANGLE, master_task) + call broadcast_scalar (f_ANGLET, master_task) + call broadcast_scalar (f_bounds, master_task) call broadcast_scalar (f_hi, master_task) call broadcast_scalar (f_hs, master_task) @@ -823,12 +942,32 @@ subroutine init_hist (dt) call broadcast_scalar (f_trsig, master_task) call broadcast_scalar (f_icepresent, master_task) call broadcast_scalar (f_iage, master_task) + call broadcast_scalar (f_fsurf_ai, master_task) + call broadcast_scalar (f_fcondtop_ai, master_task) + call broadcast_scalar (f_fmeltt_ai, master_task) + call broadcast_scalar (f_fsurfn_ai, master_task) + call broadcast_scalar (f_fcondtopn_ai, master_task) + call broadcast_scalar (f_fmelttn_ai, master_task) + call broadcast_scalar (f_flatn_ai, master_task) !----------------------------------------------------------------- ! fill iout array with namelist values !----------------------------------------------------------------- iout=.true. ! all fields are written by default + igrd=.true. + + igrd(n_tmask ) = f_tmask + igrd(n_tarea ) = f_tarea + igrd(n_uarea ) = f_uarea + igrd(n_dxt ) = f_dxt + igrd(n_dyt ) = f_dyt + igrd(n_dxu ) = f_dxu + igrd(n_dyu ) = f_dyu + igrd(n_HTN ) = f_HTN + igrd(n_HTE ) = f_HTE + igrd(n_ANGLE ) = f_ANGLE + igrd(n_ANGLET ) = f_ANGLET iout(n_hi ) = f_hi iout(n_hs ) = f_hs @@ -907,10 +1046,17 @@ subroutine init_hist (dt) iout(n_trsig ) = f_trsig iout(n_icepresent) = f_icepresent iout(n_iage ) = f_iage + iout(n_fsurf_ai ) = f_fsurf_ai + iout(n_fcondtop_ai)= f_fcondtop_ai + iout(n_fmeltt_ai ) = f_fmeltt_ai do n = 1, ncat_hist - iout(n_aicen+n-1) = f_aicen - iout(n_vicen+n-1) = f_vicen - iout(n_volpn+n-1) = f_volpn + iout(n_aicen+n-1) = f_aicen + iout(n_vicen+n-1) = f_vicen + iout(n_volpn+n-1) = f_volpn + iout(n_fsurfn_ai+n-1) = f_fsurfn_ai + iout(n_fcondtopn_ai+n-1) = f_fcondtopn_ai + iout(n_fmelttn_ai+n-1) = f_fmelttn_ai + iout(n_flatn_ai+n-1) = f_flatn_ai enddo if (my_task == master_task) then @@ -919,12 +1065,12 @@ subroutine init_hist (dt) 'written to the history tape: ' write(nu_diag,*) ' description units', & ' netcdf variable' - do n=1,avgsiz - if (iout(n)) write(nu_diag,100) vdesc(n), vunit(n), vname(n) - enddo - write(nu_diag,*) ' ' + do n=1,avgsiz + if (iout(n)) write(nu_diag,100) vdesc(n), vunit(n), vname(n) + enddo + write(nu_diag,*) ' ' endif - 100 format (1x,a40,2x,a10,2x,a10) + 100 format (1x,a40,2x,a10,2x,a16) !----------------------------------------------------------------- ! initialize the history arrays @@ -1001,9 +1147,9 @@ subroutine init_hist (dt) cona(n_fsalt_ai) = secday ! salt flux kg/m2/s to kg/m2/day #endif -!------------------------------------------------------------------- -! Change coordinates of variables printed out on u grid -!------------------------------------------------------------------- +!------------------------------------------------------------------------ +! Change coordinates and cell measures of variables printed out on u grid +!------------------------------------------------------------------------ if (my_task == master_task) then do k=1,avgsiz @@ -1024,6 +1170,24 @@ subroutine init_hist (dt) if (TRIM(vname(k)) == 'strinty') vcoord(k) = ustr if (TRIM(vname(k)) == 'sig1') vcoord(k) = ustr if (TRIM(vname(k)) == 'sig2') vcoord(k) = ustr + + vcellmeas(k) = tcstr + if (TRIM(vname(k)) == 'uvel') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'vvel') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'uocn') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'vocn') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strairx') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strairy') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strtltx') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strtlty') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strcorx') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strcory') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strocnx') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strocny') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strintx') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'strinty') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'sig1') vcellmeas(k) = ucstr + if (TRIM(vname(k)) == 'sig2') vcellmeas(k) = ucstr enddo endif @@ -1058,6 +1222,9 @@ subroutine ice_write_hist (dt) use ice_constants use ice_flux use ice_dyn_evp + use ice_age, only: tr_iage + use ice_meltpond, only: tr_pond + use ice_work, only: worka ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -1072,7 +1239,8 @@ subroutine ice_write_hist (dt) real (kind=dbl_kind) :: & ravgct , & ! 1/avgct - ai ! aice_init + ai , & ! aice_init + ain ! aicen_init type (block) :: & this_block ! block information for current block @@ -1177,19 +1345,19 @@ subroutine ice_write_hist (dt) aa(i,j,n_fresh, iblk)= aa(i,j,n_fresh, iblk) & + fresh_hist(i,j,iblk) aa(i,j,n_fresh_ai,iblk) = aa(i,j,n_fresh_ai,iblk) & - + ai*fresh_hist(i,j,iblk) + + fresh_hist_gbm(i,j,iblk) aa(i,j,n_fsalt, iblk) = aa(i,j,n_fsalt, iblk) & + fsalt_hist(i,j,iblk) aa(i,j,n_fsalt_ai,iblk) = aa(i,j,n_fsalt_ai,iblk) & - + ai*fsalt_hist(i,j,iblk) + + fsalt_hist_gbm(i,j,iblk) aa(i,j,n_fhocn, iblk) = aa(i,j,n_fhocn, iblk) & + fhocn_hist(i,j,iblk) aa(i,j,n_fhocn_ai,iblk) = aa(i,j,n_fhocn_ai,iblk) & - + ai*fhocn_hist(i,j,iblk) + + fhocn_hist_gbm(i,j,iblk) aa(i,j,n_fswthru,iblk) = aa(i,j,n_fswthru,iblk) & + fswthru_hist(i,j,iblk) aa(i,j,n_fswthru_ai,iblk)=aa(i,j,n_fswthru_ai,iblk) & - + ai*fswthru_hist(i,j,iblk) + + fswthru_hist_gbm(i,j,iblk) aa(i,j,n_strairx,iblk) = aa(i,j,n_strairx,iblk) & + strairx(i,j,iblk) @@ -1240,7 +1408,11 @@ subroutine ice_write_hist (dt) aa(i,j,n_dvirdgdt,iblk)= aa(i,j,n_dvirdgdt,iblk) & + dvirdgdt(i,j,iblk) if (aice(i,j,iblk).gt.puny) & - aa(i,j,n_icepresent,iblk) = aa(i,j,n_icepresent,iblk) + c1 + aa(i,j,n_icepresent,iblk) = aa(i,j,n_icepresent,iblk) + c1 + aa(i,j,n_fsurf_ai,iblk) = aa(i,j,n_fsurf_ai,iblk) & + + fsurf(i,j,iblk)*ai + aa(i,j,n_fcondtop_ai,iblk)= aa(i,j,n_fcondtop_ai,iblk) & + + fcondtop(i,j,iblk)*ai endif ! tmask enddo ! i enddo ! j @@ -1250,18 +1422,48 @@ subroutine ice_write_hist (dt) do j=jlo,jhi do i=ilo,ihi if (tmask(i,j,iblk)) then + ain = aicen_init(i,j,n,iblk) ! assume consecutive indices aa(i,j,n_aicen+n-1,iblk) = aa(i,j,n_aicen+n-1,iblk) & + aicen(i,j,n,iblk) aa(i,j,n_vicen+n-1,iblk) = aa(i,j,n_vicen+n-1,iblk) & + vicen(i,j,n,iblk) - aa(i,j,n_volpn+n-1,iblk) = aa(i,j,n_volpn+n-1,iblk) & - + trcrn(i,j,nt_volpn,n,iblk) + if (tr_pond) aa(i,j,n_volpn+n-1,iblk) = & + aa(i,j,n_volpn+n-1,iblk) & + + trcrn(i,j,nt_volpn,n,iblk) + aa(i,j,n_fsurfn_ai+n-1,iblk) = & + aa(i,j,n_fsurfn_ai+n-1,iblk) & + + fsurfn(i,j,n,iblk)*ain + aa(i,j,n_fcondtopn_ai+n-1,iblk) = & + aa(i,j,n_fcondtopn_ai+n-1,iblk) & + + fcondtopn(i,j,n,iblk)*ain + ! Calculate surface heat flux that causes melt as this + ! is what is calculated by the atmos in HadGEM3 so + ! needed for checking purposes + aa(i,j,n_fmelttn_ai+n-1,iblk) = & + aa(i,j,n_fmelttn_ai+n-1,iblk) & + + max(fsurfn(i,j,n,iblk) - fcondtopn(i,j,n,iblk),c0)*ain + aa(i,j,n_flatn_ai+n-1,iblk) = & + aa(i,j,n_flatn_ai+n-1,iblk) & + + flatn(i,j,n,iblk)*ain endif ! tmask enddo ! i enddo ! j enddo ! n + ! Calculate aggregate surface melt flux by summing category values + worka(:,:) = c0 + do j = jlo, jhi + do i = ilo, ihi + if (tmask(i,j,iblk)) then + do n=1,nct + worka(i,j) = worka(i,j) + aa(i,j,n_fmelttn_ai+n-1,iblk) + enddo ! n + endif ! tmask + enddo ! i + enddo ! j + aa(:,:,n_fmeltt_ai,iblk) = worka(:,:) + enddo ! iblk !--------------------------------------------------------------- @@ -1335,7 +1537,8 @@ subroutine ice_write_hist (dt) + stressp_2(i,j,iblk) & + stressp_3(i,j,iblk) & + stressp_4(i,j,iblk)) - aa(i,j,n_iage,iblk) = trcr(i,j,nt_iage,iblk)*cona(n_iage) + if (tr_iage) aa(i,j,n_iage,iblk) = & + trcr(i,j,nt_iage,iblk)*cona(n_iage) endif enddo ! i enddo ! j @@ -1430,8 +1633,8 @@ subroutine icecdf use ice_calendar, only: time, sec, idate, idate0, nyr, month, & mday, write_ic, histfreq, histfreq_n, & year_init, new_year, new_month, new_day, & - dayyr, daymo - use ice_work, only: work_g1, work_gr, work_gr3 + dayyr, daymo, days_per_year + use ice_work, only: work_g1, work_gr, work_gr3, work1 use ice_restart, only: lenstr, runid use ice_domain, only: distrb_info use ice_itd, only: c_hi_range @@ -1444,8 +1647,9 @@ subroutine icecdf ! integer (kind=int_kind) :: i,j,n, & ncid,status,imtid,jmtid,timid,varid, & - length + length,nvertexid,ivertex integer (kind=int_kind), dimension(3) :: dimid + integer (kind=int_kind), dimension(3) :: dimid_nverts real (kind=real_kind) :: ltime character (char_len) :: title character (char_len_long) :: ncfile @@ -1457,14 +1661,18 @@ subroutine icecdf character (len=16) :: c_aice character (len=8) :: cdate -! Info for lat, lon and time invariant variables -#if (defined CCSM) || (defined SEQ_MCT) - INTEGER (kind=int_kind), PARAMETER :: ncoord = 4, nvar = 10 -#else - INTEGER (kind=int_kind), PARAMETER :: ncoord = 4, nvar = 4 -#endif + ! 4 coordinate variables: TLON, TLAT, ULON, ULAT + INTEGER (kind=int_kind), PARAMETER :: ncoord = 4 + + ! 4 vertices in each grid cell + INTEGER (kind=int_kind), PARAMETER :: nverts = 4 + + ! 4 variables describe T, U grid boundaries: + ! lont_bounds, latt_bounds, lonu_bounds, latu_bounds + INTEGER (kind=int_kind), PARAMETER :: nvar_verts = 4 + TYPE coord_attributes ! netcdf coordinate attributes - character (len=10) :: short_name + character (len=11) :: short_name character (len=45) :: long_name character (len=20) :: units END TYPE coord_attributes @@ -1476,6 +1684,8 @@ subroutine icecdf TYPE(req_attributes), dimension(nvar) :: var TYPE(coord_attributes), dimension(ncoord) :: coord_var + TYPE(coord_attributes), dimension(nvar_verts) :: var_nverts + CHARACTER (char_len), dimension(ncoord) :: coord_bounds if (my_task == master_task) then @@ -1517,6 +1727,10 @@ subroutine icecdf if (status /= nf90_noerr) call abort_ice( & 'ice: Error defining dim time') + status = nf90_def_dim(ncid,'nvertices',nverts,nvertexid) + if (status /= nf90_noerr) call abort_ice( & + 'ice: Error defining dim nverts') + !----------------------------------------------------------------- ! define coordinate variables !----------------------------------------------------------------- @@ -1536,9 +1750,15 @@ subroutine icecdf if (status /= nf90_noerr) call abort_ice( & 'ice Error: time units') - status = nf90_put_att(ncid,varid,'calendar','noleap') - if (status /= nf90_noerr) call abort_ice( & - 'ice Error: time calendar') + if (days_per_year == 360) then + status = nf90_put_att(ncid,varid,'calendar','360_day') + if (status /= nf90_noerr) call abort_ice( & + 'ice Error: time calendar') + else + status = nf90_put_att(ncid,varid,'calendar','noleap') + if (status /= nf90_noerr) call abort_ice( & + 'ice Error: time calendar') + endif if (hist_avg) then status = nf90_put_att(ncid,varid,'bounds','time_bounds') @@ -1569,69 +1789,74 @@ subroutine icecdf endif !----------------------------------------------------------------- - ! define information for the creation of time-invariant variables + ! define information for required time-invariant variables !----------------------------------------------------------------- ind = 0 ind = ind + 1 coord_var(ind) = coord_attributes('TLON', & 'T grid center longitude', 'degrees_east') + coord_bounds(ind) = 'lont_bounds' ind = ind + 1 coord_var(ind) = coord_attributes('TLAT', & 'T grid center latitude', 'degrees_north') + coord_bounds(ind) = 'latt_bounds' ind = ind + 1 coord_var(ind) = coord_attributes('ULON', & 'U grid center longitude', 'degrees_east') + coord_bounds(ind) = 'lonu_bounds' ind = ind + 1 coord_var(ind) = coord_attributes('ULAT', & 'U grid center latitude', 'degrees_north') + coord_bounds(ind) = 'latu_bounds' - ind = 0 - ind = ind + 1 - var(ind)%req = coord_attributes('tarea', 'area of T grid cells', & - 'm^2') - var(ind)%coordinates = 'TLON TLAT' - ind = ind + 1 - var(ind)%req = coord_attributes('uarea', 'area of U grid cells', & - 'm^2') - var(ind)%coordinates = 'ULON ULAT' -#if (defined CCSM) || (defined SEQ_MCT) - ind = ind + 1 - var(ind)%req = coord_attributes('dxt', & - 'T cell width through middle', 'm') - var(ind)%coordinates = 'TLON TLAT' - ind = ind + 1 - var(ind)%req = coord_attributes('dyt', & - 'T cell height through middle', 'm') - var(ind)%coordinates = 'TLON TLAT' - ind = ind + 1 - var(ind)%req = coord_attributes('dxu', & - 'U cell width through middle', 'm') - var(ind)%coordinates = 'ULON ULAT' - ind = ind + 1 - var(ind)%req = coord_attributes('dyu', & - 'U cell height through middle', 'm') - var(ind)%coordinates = 'ULON ULAT' - ind = ind + 1 - var(ind)%req = coord_attributes('HTN', & - 'T cell width on North side','m') - var(ind)%coordinates = 'TLON TLAT' + !----------------------------------------------------------------- + ! define information for optional time-invariant variables + !----------------------------------------------------------------- - ind = ind + 1 - var(ind)%req = coord_attributes('HTE', & - 'T cell width on East side', 'm') - var(ind)%coordinates = 'TLON TLAT' -#endif - ind = ind + 1 - var(ind)%req = coord_attributes('ANGLET', & - 'angle grid makes with latitude line on T grid', & - 'radians') - var(ind)%coordinates = 'TLON TLAT' - ind = ind + 1 - var(ind)%req = coord_attributes('ANGLE', & - 'angle grid makes with latitude line on U grid', & - 'radians') - var(ind)%coordinates = 'ULON ULAT' + var(n_tarea)%req = coord_attributes('tarea', & + 'area of T grid cells', 'm^2') + var(n_tarea)%coordinates = 'TLON TLAT' + var(n_uarea)%req = coord_attributes('uarea', & + 'area of U grid cells', 'm^2') + var(n_uarea)%coordinates = 'ULON ULAT' + var(n_dxt)%req = coord_attributes('dxt', & + 'T cell width through middle', 'm') + var(n_dxt)%coordinates = 'TLON TLAT' + var(n_dyt)%req = coord_attributes('dyt', & + 'T cell height through middle', 'm') + var(n_dyt)%coordinates = 'TLON TLAT' + var(n_dxu)%req = coord_attributes('dxu', & + 'U cell width through middle', 'm') + var(n_dxu)%coordinates = 'ULON ULAT' + var(n_dyu)%req = coord_attributes('dyu', & + 'U cell height through middle', 'm') + var(n_dyu)%coordinates = 'ULON ULAT' + var(n_HTN)%req = coord_attributes('HTN', & + 'T cell width on North side','m') + var(n_HTN)%coordinates = 'TLON TLAT' + var(n_HTE)%req = coord_attributes('HTE', & + 'T cell width on East side', 'm') + var(n_HTE)%coordinates = 'TLON TLAT' + var(n_ANGLE)%req = coord_attributes('ANGLE', & + 'angle grid makes with latitude line on U grid', & + 'radians') + var(n_ANGLE)%coordinates = 'ULON ULAT' + var(n_ANGLET)%req = coord_attributes('ANGLET', & + 'angle grid makes with latitude line on T grid', & + 'radians') + var(n_ANGLET)%coordinates = 'TLON TLAT' + + ! These fields are required for CF compliance + ! dimensions (nx,ny,nverts) + var_nverts(n_lont_bnds) = coord_attributes('lont_bounds', & + 'longitude boundaries of T cells', 'degrees_east') + var_nverts(n_latt_bnds) = coord_attributes('latt_bounds', & + 'latitude boundaries of T cells', 'degrees_north') + var_nverts(n_lonu_bnds) = coord_attributes('lonu_bounds', & + 'longitude boundaries of U cells', 'degrees_east') + var_nverts(n_latu_bnds) = coord_attributes('latu_bounds', & + 'latitude boundaries of U cells', 'degrees_north') !----------------------------------------------------------------- ! define attributes for time-invariant variables @@ -1645,46 +1870,76 @@ subroutine icecdf status = nf90_def_var(ncid, coord_var(i)%short_name, nf90_float, & dimid(1:2), varid) if (status /= nf90_noerr) call abort_ice( & - 'Error defining short_name for'//coord_var(i)%short_name) + 'Error defining short_name for '//coord_var(i)%short_name) status = nf90_put_att(ncid,varid,'long_name',coord_var(i)%long_name) if (status /= nf90_noerr) call abort_ice( & - 'Error defining long_name for'//coord_var(i)%short_name) + 'Error defining long_name for '//coord_var(i)%short_name) status = nf90_put_att(ncid, varid, 'units', coord_var(i)%units) if (status /= nf90_noerr) call abort_ice( & - 'Error defining units for'//coord_var(i)%short_name) + 'Error defining units for '//coord_var(i)%short_name) if (coord_var(i)%short_name == 'ULAT') then - status = nf90_put_att(ncid,varid,'comment', & + status = nf90_put_att(ncid,varid,'comment', & 'Latitude of NE corner of T grid cell') - if (status /= nf90_noerr) call abort_ice( & - 'Error defining comment for'//coord_var(i)%short_name) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining comment for '//coord_var(i)%short_name) endif + if (f_bounds) then + status = nf90_put_att(ncid, varid, 'bounds', coord_bounds(i)) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining bounds for '//coord_var(i)%short_name) + endif enddo ! Attributes for tmask defined separately, since it has no units - status = nf90_def_var(ncid, 'tmask', nf90_float, dimid(1:2), varid) - if (status /= nf90_noerr) call abort_ice( & - 'ice: Error defining var tmask') - status = nf90_put_att(ncid,varid, 'long_name', 'ocean grid mask') - if (status /= nf90_noerr) call abort_ice('ice Error: tmask long_name') - status = nf90_put_att(ncid, varid, 'coordinates', 'TLON TLAT') - if (status /= nf90_noerr) call abort_ice('ice Error: tmask units') - status = nf90_put_att(ncid,varid,'comment', '0 = land, 1 = ocean') - if (status /= nf90_noerr) call abort_ice('ice Error: tmask comment') - - do i = 1, nvar - status = nf90_def_var(ncid, var(i)%req%short_name, & - nf90_float, dimid(1:2), varid) - if (status /= nf90_noerr) call abort_ice( & - 'Error defining variable'//var(i)%req%short_name) - status = nf90_put_att(ncid,varid, 'long_name', var(i)%req%long_name) - if (status /= nf90_noerr) call abort_ice( & - 'Error defining long_name for'//var(i)%req%short_name) - status = nf90_put_att(ncid, varid, 'units', var(i)%req%units) - if (status /= nf90_noerr) call abort_ice( & - 'Error defining units for'//var(i)%req%short_name) - status = nf90_put_att(ncid, varid, 'coordinates', var(i)%coordinates) - if (status /= nf90_noerr) call abort_ice( & - 'Error defining coordinates for'//var(i)%req%short_name) + if (igrd(n_tmask)) then + status = nf90_def_var(ncid, 'tmask', nf90_float, dimid(1:2), varid) + if (status /= nf90_noerr) call abort_ice( & + 'ice: Error defining var tmask') + status = nf90_put_att(ncid,varid, 'long_name', 'ocean grid mask') + if (status /= nf90_noerr) call abort_ice('ice Error: tmask long_name') + status = nf90_put_att(ncid, varid, 'coordinates', 'TLON TLAT') + if (status /= nf90_noerr) call abort_ice('ice Error: tmask units') + status = nf90_put_att(ncid,varid,'comment', '0 = land, 1 = ocean') + if (status /= nf90_noerr) call abort_ice('ice Error: tmask comment') + endif + + do i = 2, nvar ! note: n_tmask=1 + if (igrd(i)) then + status = nf90_def_var(ncid, var(i)%req%short_name, & + nf90_float, dimid(1:2), varid) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining variable '//var(i)%req%short_name) + status = nf90_put_att(ncid,varid, 'long_name', var(i)%req%long_name) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining long_name for '//var(i)%req%short_name) + status = nf90_put_att(ncid, varid, 'units', var(i)%req%units) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining units for '//var(i)%req%short_name) + status = nf90_put_att(ncid, varid, 'coordinates', var(i)%coordinates) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining coordinates for '//var(i)%req%short_name) + endif + enddo + + ! Fields with dimensions (nverts,nx,ny) + dimid_nverts(1) = nvertexid + dimid_nverts(2) = imtid + dimid_nverts(3) = jmtid + do i = 1, nvar_verts + if (f_bounds) then + status = nf90_def_var(ncid, var_nverts(i)%short_name, & + nf90_float,dimid_nverts, varid) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining variable '//var_nverts(i)%short_name) + status = & + nf90_put_att(ncid,varid, 'long_name', var_nverts(i)%long_name) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining long_name for '//var_nverts(i)%short_name) + status = & + nf90_put_att(ncid, varid, 'units', var_nverts(i)%units) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining units for '//var_nverts(i)%short_name) + endif enddo do n=1,avgsiz @@ -1692,23 +1947,26 @@ subroutine icecdf status = nf90_def_var(ncid, vname(n), nf90_float, & dimid, varid) if (status /= nf90_noerr) call abort_ice( & - 'Error defining variable'//vname(n)) + 'Error defining variable '//vname(n)) status = nf90_put_att(ncid,varid, 'units',vunit(n)) if (status /= nf90_noerr) call abort_ice( & - 'Error defining units for'//vname(n)) + 'Error defining units for '//vname(n)) status = nf90_put_att(ncid,varid, 'long_name',vdesc(n)) if (status /= nf90_noerr) call abort_ice( & - 'Error defining long_name for'//vname(n)) + 'Error defining long_name for '//vname(n)) status = nf90_put_att(ncid,varid,'coordinates', vcoord(n)) if (status /= nf90_noerr) call abort_ice( & - 'Error defining coordinates for'//vname(n)) + 'Error defining coordinates for '//vname(n)) + status = nf90_put_att(ncid,varid,'cell_measures', vcellmeas(n)) + if (status /= nf90_noerr) call abort_ice( & + 'Error defining cell measures for '//vname(n)) status = nf90_put_att(ncid,varid,'missing_value',spval) if (status /= nf90_noerr) call abort_ice( & - 'Error defining mising_value for'//vname(n)) + 'Error defining mising_value for '//vname(n)) status = nf90_put_att(ncid,varid,'_FillValue',spval) if (status /= nf90_noerr) call abort_ice( & - 'Error defining _FillValue for'//vname(n)) + 'Error defining _FillValue for '//vname(n)) !----------------------------------------------------------------- ! Append ice thickness range to aicen comments !----------------------------------------------------------------- @@ -1724,7 +1982,7 @@ subroutine icecdf endif status = nf90_put_att(ncid,varid,'comment',vcomment(n)) if (status /= nf90_noerr) call abort_ice( & - 'Error defining comment for'//vname(n)) + 'Error defining comment for '//vname(n)) !----------------------------------------------------------------- ! Add cell_methods attribute to variables if averaged !----------------------------------------------------------------- @@ -1732,7 +1990,7 @@ subroutine icecdf if (TRIM(vname(n))/='sig1'.or.TRIM(vname(n))/='sig2') then status = nf90_put_att(ncid,varid,'cell_methods','time: mean') if (status /= nf90_noerr) call abort_ice( & - 'Error defining cell methods for'//vname(n)) + 'Error defining cell methods for '//vname(n)) endif endif @@ -1880,7 +2138,7 @@ subroutine icecdf if (my_task == master_task) then status = nf90_inq_varid(ncid, coord_var(i)%short_name, varid) if (status /= nf90_noerr) call abort_ice( & - 'ice: Error getting varid for'//coord_var(i)%short_name) + 'ice: Error getting varid for '//coord_var(i)%short_name) status = nf90_put_var(ncid,varid,work_gr) if (status /= nf90_noerr) call abort_ice( & 'ice: Error writing'//coord_var(i)%short_name) @@ -1891,6 +2149,7 @@ subroutine icecdf ! write grid mask, area and rotation angle !----------------------------------------------------------------- + if (igrd(n_tmask)) then call gather_global(work_g1, hm, master_task, distrb_info) if (my_task == master_task) then work_gr=work_g1 @@ -1901,8 +2160,10 @@ subroutine icecdf if (status /= nf90_noerr) call abort_ice( & 'ice: Error writing variable tmask') endif + endif - do i = 1,nvar + do i = 2, nvar ! note: n_tmask=1 + if (igrd(i)) then call broadcast_scalar(var(i)%req%short_name,master_task) SELECT CASE (var(i)%req%short_name) CASE ('tarea') @@ -1931,25 +2192,81 @@ subroutine icecdf work_gr=work_g1 status = nf90_inq_varid(ncid, var(i)%req%short_name, varid) if (status /= nf90_noerr) call abort_ice( & - 'ice: Error getting varid for'//var(i)%req%short_name) + 'ice: Error getting varid for '//var(i)%req%short_name) status = nf90_put_var(ncid,varid,work_gr) if (status /= nf90_noerr) call abort_ice( & - 'ice: Error writing variable'//var(i)%req%short_name) + 'ice: Error writing variable '//var(i)%req%short_name) + endif endif enddo - deallocate(work_gr) + !---------------------------------------------------------------- + ! Write coordinates of grid box vertices + !---------------------------------------------------------------- + if (f_bounds) then if (my_task==master_task) then - allocate(work_gr3(nx_global,ny_global,1)) + allocate(work_gr3(nverts,nx_global,ny_global)) else allocate(work_gr3(1,1,1)) ! to save memory endif + work_gr3(:,:,:) = c0 + work1 (:,:,:) = c0 + + do i = 1, nvar_verts + call broadcast_scalar(var_nverts(i)%short_name,master_task) + SELECT CASE (var_nverts(i)%short_name) + CASE ('lont_bounds') + do ivertex = 1, nverts + work1(:,:,:) = lont_bounds(ivertex,:,:,:) + call gather_global(work_g1, work1, master_task, distrb_info) + if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + enddo + CASE ('latt_bounds') + do ivertex = 1, nverts + work1(:,:,:) = latt_bounds(ivertex,:,:,:) + call gather_global(work_g1, work1, master_task, distrb_info) + if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + enddo + CASE ('lonu_bounds') + do ivertex = 1, nverts + work1(:,:,:) = lonu_bounds(ivertex,:,:,:) + call gather_global(work_g1, work1, master_task, distrb_info) + if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + enddo + CASE ('latu_bounds') + do ivertex = 1, nverts + work1(:,:,:) = latu_bounds(ivertex,:,:,:) + call gather_global(work_g1, work1, master_task, distrb_info) + if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + enddo + END SELECT + + if (my_task == master_task) then + status = nf90_inq_varid(ncid, var_nverts(i)%short_name, varid) + if (status /= nf90_noerr) call abort_ice( & + 'ice: Error getting varid for '//var_nverts(i)%short_name) + status = nf90_put_var(ncid,varid,work_gr3) + if (status /= nf90_noerr) call abort_ice( & + 'ice: Error writing variable '//var_nverts(i)%short_name) + endif + enddo + deallocate(work_gr3) + endif + + deallocate(work_gr) + !----------------------------------------------------------------- ! write variable data !----------------------------------------------------------------- + if (my_task==master_task) then + allocate(work_gr3(nx_global,ny_global,1)) + else + allocate(work_gr3(1,1,1)) ! to save memory + endif + do n=1,avgsiz if (iout(n)) then call gather_global(work_g1, aa(:,:,n,:), & @@ -1958,11 +2275,11 @@ subroutine icecdf work_gr3(:,:,1) = work_g1(:,:) status = nf90_inq_varid(ncid,vname(n),varid) if (status /= nf90_noerr) call abort_ice( & - 'ice: Error getting varid for'//vname(n)) + 'ice: Error getting varid for '//vname(n)) status = nf90_put_var(ncid,varid,work_gr3, & count=(/nx_global,ny_global,1/)) if (status /= nf90_noerr) call abort_ice( & - 'ice: Error writing variable'//vname(n)) + 'ice: Error writing variable '//vname(n)) endif endif enddo diff --git a/cice/source/ice_init.F90 b/cice/source/ice_init.F90 index 74f57b5..40defe8 100644 --- a/cice/source/ice_init.F90 +++ b/cice/source/ice_init.F90 @@ -79,6 +79,7 @@ subroutine input_data use ice_exit use ice_itd, only: kitd, kcatbound use ice_ocean, only: oceanmixed_ice + use ice_flux, only: Tfrzpt, update_ocn_f use ice_forcing, only: & ycycle, fyear_init, dbug, & atm_data_type, atm_data_dir, precip_units, & @@ -95,6 +96,7 @@ subroutine input_data use ice_transport_driver, only: advection use ice_age, only: tr_iage, restart_age use ice_meltpond, only: tr_pond, restart_pond + use ice_therm_vertical, only: calc_Tsfc, heat_capacity ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -112,28 +114,29 @@ subroutine input_data !----------------------------------------------------------------- namelist /ice_nml/ & - year_init, istep0, dt, npt, & - diagfreq, days_per_year, & - print_points, print_global, diag_type, diag_file, & - history_format, & - histfreq, hist_avg, history_dir, history_file, & - histfreq_n, dumpfreq, dumpfreq_n, restart_file, & - restart, restart_dir, pointer_file, ice_ic, & - grid_format, grid_type, grid_file, kmt_file, & - kitd, kcatbound, & - kdyn, ndyn_dt, ndte, evp_damping, & - yield_curve, advection, & - kstrength, krdg_partic, krdg_redist, shortwave, & - R_ice, R_pnd, R_snw, & - albicev, albicei, albsnowv, albsnowi, & - albedo_type, atmbndy, fyear_init, ycycle , & - atm_data_format, & - atm_data_type, atm_data_dir, calc_strair, precip_units, & - oceanmixed_ice, sss_data_type, sst_data_type, ocn_data_format, & - ocn_data_dir, oceanmixed_file, restore_sst, trestore, & - latpnt, lonpnt, dbug, & + year_init, istep0, dt, npt, & + diagfreq, days_per_year, & + print_points, print_global, diag_type, diag_file, & + history_format, & + histfreq, hist_avg, history_dir, history_file, & + histfreq_n, dumpfreq, dumpfreq_n, restart_file, & + restart, restart_dir, pointer_file, ice_ic, & + grid_format, grid_type, grid_file, kmt_file, & + kitd, kcatbound, & + kdyn, ndyn_dt, ndte, evp_damping, & + yield_curve, advection, & + kstrength, krdg_partic, krdg_redist, shortwave, & + R_ice, R_pnd, R_snw, & + albicev, albicei, albsnowv, albsnowi, & + albedo_type, heat_capacity, calc_Tsfc, Tfrzpt, & + update_ocn_f, atmbndy, fyear_init, ycycle, & + atm_data_format, & + atm_data_type, atm_data_dir, calc_strair, precip_units, & + oceanmixed_ice, sss_data_type, sst_data_type, ocn_data_format,& + ocn_data_dir, oceanmixed_file, restore_sst, trestore, & + latpnt, lonpnt, dbug, & #ifndef SEQ_MCT - runid, runtype, & + runid, runtype, & #endif incond_dir, incond_file @@ -189,6 +192,10 @@ subroutine input_data advection = 'remap' ! incremental remapping transport scheme shortwave = 'default' ! or 'dEdd' (delta-Eddington) albedo_type = 'default'! or 'constant' + heat_capacity = .true. ! nonzero heat capacity (F => 0-layer thermo) + calc_Tsfc = .true. ! calculate surface temperature + Tfrzpt = 'linear_S' ! ocean freezing temperature, 'constant'=-1.8C + update_ocn_f = .false. ! include fresh water and salt fluxes for frazil R_ice = 0.00_dbl_kind ! tuning parameter for sea ice R_pnd = 0.00_dbl_kind ! tuning parameter for ponded sea ice R_snw = 0.00_dbl_kind ! tuning parameter for snow over sea ice @@ -312,6 +319,16 @@ subroutine input_data if (trim(atm_data_type) == 'monthly' .and. calc_strair) & calc_strair = .false. + if (trim(atm_data_type) == 'hadgem' .and. & + trim(precip_units) /= 'mks') then + if (my_task == master_task) & + write (nu_diag,*) & + 'WARNING: HadGEM atmospheric data chosen with wrong precip_units' + write (nu_diag,*) & + 'WARNING: Changing precip_units to mks (i.e. kg/m2 s).' + precip_units='mks' + endif + call broadcast_scalar(days_per_year, master_task) call broadcast_scalar(year_init, master_task) call broadcast_scalar(istep0, master_task) @@ -354,6 +371,7 @@ subroutine input_data call broadcast_scalar(advection, master_task) call broadcast_scalar(shortwave, master_task) call broadcast_scalar(albedo_type, master_task) + call broadcast_scalar(heat_capacity, master_task) call broadcast_scalar(R_ice, master_task) call broadcast_scalar(R_pnd, master_task) call broadcast_scalar(R_snw, master_task) @@ -368,6 +386,9 @@ subroutine input_data call broadcast_scalar(atm_data_type, master_task) call broadcast_scalar(atm_data_dir, master_task) call broadcast_scalar(calc_strair, master_task) + call broadcast_scalar(calc_Tsfc, master_task) + call broadcast_scalar(Tfrzpt, master_task) + call broadcast_scalar(update_ocn_f, master_task) call broadcast_scalar(precip_units, master_task) call broadcast_scalar(oceanmixed_ice, master_task) call broadcast_scalar(ocn_data_format, master_task) @@ -489,6 +510,8 @@ subroutine input_data write(nu_diag,1000) ' albicei = ', albicei write(nu_diag,1000) ' albsnowv = ', albsnowv write(nu_diag,1000) ' albsnowi = ', albsnowi + write(nu_diag,1010) ' heat_capacity = ', & + heat_capacity write(nu_diag,1030) ' atmbndy = ', & trim(atmbndy) @@ -498,6 +521,9 @@ subroutine input_data write(nu_diag,*) ' atm_data_type = ', & trim(atm_data_type) write(nu_diag,1010) ' calc_strair = ', calc_strair + write(nu_diag,1010) ' calc_Tsfc = ', calc_Tsfc + write(nu_diag,*) ' Tfrzpt = ', trim(Tfrzpt) + write(nu_diag,1010) ' update_ocn_f = ', update_ocn_f if (trim(atm_data_type) /= 'default') then write(nu_diag,*) ' atm_data_dir = ', & trim(atm_data_dir) @@ -603,6 +629,7 @@ subroutine init_state use ice_exit use ice_age, only: tr_iage use ice_meltpond, only: tr_pond + use ice_therm_vertical, only: heat_capacity ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -617,17 +644,41 @@ subroutine init_state ! Check number of layers in ice and snow. !----------------------------------------------------------------- - if (nilyr < 1) then - write (nu_diag,*) 'nilyr =', nilyr - write (nu_diag,*) 'Must have at least one ice layer' - call abort_ice('ice_init: Not enough ice layers') - endif + if (my_task == master_task) then + + if (nilyr < 1) then + write (nu_diag,*) 'nilyr =', nilyr + write (nu_diag,*) 'Must have at least one ice layer' + call abort_ice ('ice_init: Not enough ice layers') + endif - if (nslyr < 1) then - write (nu_diag,*) 'nslyr =', nslyr - write (nu_diag,*) 'Must have at least one snow layer' - call abort_ice('ice_init: Not enough snow layers') - endif + if (nslyr < 1) then + write (nu_diag,*) 'nslyr =', nslyr + write (nu_diag,*) 'Must have at least one snow layer' + call abort_ice('ice_init: Not enough snow layers') + endif + + if (.not.heat_capacity) then + + write (nu_diag,*) 'WARNING - Zero-layer thermodynamics' + + if (nilyr > 1) then + write (nu_diag,*) 'nilyr =', nilyr + write (nu_diag,*) & + 'Must have nilyr = 1 if heat_capacity = F' + call abort_ice('ice_init: Too many ice layers') + endif + + if (nslyr > 1) then + write (nu_diag,*) 'nslyr =', nslyr + write (nu_diag,*) & + 'Must have nslyr = 1 if heat_capacity = F' + call abort_ice('ice_init: Too many snow layers') + endif + + endif ! heat_capacity = F + + endif ! my_task !----------------------------------------------------------------- ! Set tracer types @@ -722,7 +773,7 @@ subroutine set_state_var (nx_block, ny_block, & ! !USES: ! use ice_state, only: nt_Tsfc - use ice_therm_vertical, only: Tmlt + use ice_therm_vertical, only: heat_capacity, calc_Tsfc, Tmlt use ice_itd, only: ilyr1, slyr1, hin_max ! ! !INPUT/OUTPUT PARAMETERS: @@ -860,9 +911,10 @@ subroutine set_state_var (nx_block, ny_block, & enddo ! j - ! ice volume, snow volume, surface temperature, other tracers - do n = 1, ncat + + ! ice volume, snow volume + !DIR$ CONCURRENT !Cray !cdir nodep !NEC !ocl novrec !Fujitsu @@ -874,45 +926,96 @@ subroutine set_state_var (nx_block, ny_block, & vicen(i,j,n) = hinit(n) * ainit(n) ! m vsnon(i,j,n) =min(aicen(i,j,n)*hsno_init,p2*vicen(i,j,n)) - ! surface temperature - trcrn(i,j,nt_Tsfc,n) = min(Tsmelt, Tair(i,j) - Tffresh) ! deg C enddo ! ij - ! ice energy - do k = 1, nilyr + ! surface temperature + + if (calc_Tsfc) then + do ij = 1, icells i = indxi(ij) j = indxj(ij) + trcrn(i,j,nt_Tsfc,n) = min(Tsmelt, Tair(i,j) - Tffresh) !deg C - ! assume linear temp profile and compute enthalpy - slope = Tf(i,j) - trcrn(i,j,nt_Tsfc,n) - Ti = trcrn(i,j,nt_Tsfc,n) & - + slope*(real(k,kind=dbl_kind)-p5) & - /real(nilyr,kind=dbl_kind) + enddo - eicen(i,j,ilyr1(n)+k-1) = & - -(rhoi * (cp_ice*(Tmlt(k)-Ti) & - + Lfresh*(c1-Tmlt(k)/Ti) - cp_ocn*Tmlt(k))) & - * vicen(i,j,n)/real(nilyr,kind=dbl_kind) + else ! Tsfc is not calculated by the ice model - enddo ! ij - enddo ! nilyr + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + trcrn(i,j,nt_Tsfc,n) = Tf(i,j) ! not used + enddo + + endif ! calc_Tsfc + + ! other tracers (none at present) + + + if (heat_capacity) then + + ! ice energy + + do k = 1, nilyr + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + ! assume linear temp profile and compute enthalpy + slope = Tf(i,j) - trcrn(i,j,nt_Tsfc,n) + Ti = trcrn(i,j,nt_Tsfc,n) & + + slope*(real(k,kind=dbl_kind)-p5) & + /real(nilyr,kind=dbl_kind) + + eicen(i,j,ilyr1(n)+k-1) = & + -(rhoi * (cp_ice*(Tmlt(k)-Ti) & + + Lfresh*(c1-Tmlt(k)/Ti) - cp_ocn*Tmlt(k))) & + * vicen(i,j,n)/real(nilyr,kind=dbl_kind) + + enddo ! ij + enddo ! nilyr + + ! snow energy + + do k = 1, nslyr + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) - ! snow energy + Ti = min(c0, trcrn(i,j,nt_Tsfc,n)) + esnon(i,j,slyr1(n)+k-1) = -rhos*(Lfresh - cp_ice*Ti) & + *vsnon(i,j,n) & + /real(nslyr,kind=dbl_kind) + enddo ! ij + enddo ! nslyr - do k = 1, nslyr + else ! one layer with zero heat capacity + + ! ice energy + k = 1 + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + eicen(i,j,ilyr1(n)+k-1) = & + - rhoi * Lfresh * vicen(i,j,n) + + enddo ! ij + + ! snow energy do ij = 1, icells i = indxi(ij) j = indxj(ij) + esnon(i,j,slyr1(n)+k-1) = & + - rhos * Lfresh * vsnon(i,j,n) - Ti = min(c0, trcrn(i,j,nt_Tsfc,n)) - esnon(i,j,slyr1(n)+k-1) = -rhos*(Lfresh - cp_ice*Ti) & - *vsnon(i,j,n) & - /real(nslyr,kind=dbl_kind) enddo ! ij - enddo ! nslyr - + + + endif ! heat_capacity + enddo ! ncat endif ! ice_ic diff --git a/cice/source/ice_itd.F90 b/cice/source/ice_itd.F90 index fca96f7..637de49 100644 --- a/cice/source/ice_itd.F90 +++ b/cice/source/ice_itd.F90 @@ -64,7 +64,7 @@ module ice_itd hi_min = p01 ! minimum ice thickness allowed (m) real (kind=dbl_kind) :: & - hin_max(0:ncat) ! category limits (m) + hin_max(0:ncat) ! category limits (m) character (len=35) :: c_hi_range(ncat) @@ -74,15 +74,10 @@ module ice_itd ! intended to be used for particular numerical implementations ! of category conversions in the ice thickness distribution. ! hi_min is a more general purpose parameter, but is specifically -! for maintaining stability in the thermodynamics. Currently, -! hi_min = 0.1 m +! for maintaining stability in the thermodynamics. ! hin_max(0) = 0.1 m for the delta function itd ! hin_max(0) = 0.0 m for linear remapping ! -! similarly, there are two values of minimum snow thickness -! (the other is defined in ice_vthermo.H since it is used only -! for thermo.) -! ! Also note that the upper limit on the thickest category ! is only used for the linear remapping scheme ! and it is not a true upper limit on the thickness @@ -1613,9 +1608,9 @@ subroutine cleanup_itd (nx_block, ny_block, & fresh, fresh_hist, & fsalt, fsalt_hist, & fhocn, fhocn_hist, & - l_stop, & - istop, jstop, & - l_limit_aice_in) + heat_capacity, l_stop, & + istop, jstop, & + limit_aice_in) ! ! !DESCRIPTION: ! @@ -1667,6 +1662,9 @@ subroutine cleanup_itd (nx_block, ny_block, & integer (kind=int_kind), dimension(ntrcr), intent(in) :: & trcr_depend ! tracer dependency information + logical (kind=log_kind), intent(in) :: & + heat_capacity ! if false, ice and snow have zero heat capacity + logical (kind=log_kind), intent(out) :: & l_stop ! if true, abort on return @@ -1684,8 +1682,8 @@ subroutine cleanup_itd (nx_block, ny_block, & fhocn_hist ! net heat flux to ocean (W/m^2) logical (kind=log_kind), intent(in), optional :: & - l_limit_aice_in ! if false, allow aice to be out of bounds - ! may want to allow this for unit tests + limit_aice_in ! if false, allow aice to be out of bounds + ! may want to allow this for unit tests ! !EOP ! @@ -1703,16 +1701,16 @@ subroutine cleanup_itd (nx_block, ny_block, & dfhocn ! zapped energy flux ( W/m^2) logical (kind=log_kind) :: & - l_limit_aice ! if true, check for aice out of bounds + limit_aice ! if true, check for aice out of bounds !----------------------------------------------------------------- ! Initialize !----------------------------------------------------------------- - if (present(l_limit_aice_in)) then - l_limit_aice = l_limit_aice_in + if (present(limit_aice_in)) then + limit_aice = limit_aice_in else - l_limit_aice = .true. + limit_aice = .true. endif l_stop = .false. @@ -1728,7 +1726,7 @@ subroutine cleanup_itd (nx_block, ny_block, & aice, aice0) - if (l_limit_aice) then ! check for aice out of bounds + if (limit_aice) then ! check for aice out of bounds do j = jlo,jhi do i = ilo,ihi @@ -1752,7 +1750,7 @@ subroutine cleanup_itd (nx_block, ny_block, & enddo return endif ! l_stop - endif ! l_limit_aice + endif ! limit_aice !----------------------------------------------------------------- ! Identify grid cells with ice. @@ -1791,7 +1789,7 @@ subroutine cleanup_itd (nx_block, ny_block, & ! Zero out ice categories with very small areas. !----------------------------------------------------------------- - if (l_limit_aice) then + if (limit_aice) then call zap_small_areas (nx_block, ny_block, & ilo, ihi, jlo, jhi, & dt, & @@ -1823,6 +1821,23 @@ subroutine cleanup_itd (nx_block, ny_block, & if (present(fhocn_hist)) & fhocn_hist(:,:) = fhocn_hist(:,:) + dfhocn(:,:) + !---------------------------------------------------------------- + ! If using zero-layer model (no heat capacity), check that the + ! energy of snow and ice is correct. + !---------------------------------------------------------------- + + if (.not. heat_capacity) then + + call zerolayer_check(nx_block, ny_block, & + icells, indxi, indxj, & + aicen, & + vicen, vsnon, & + eicen, esnon, & + l_stop, & + istop, jstop) + + endif + end subroutine cleanup_itd !======================================================================= @@ -2148,6 +2163,175 @@ subroutine zap_small_areas (nx_block, ny_block, & end subroutine zap_small_areas +!======================================================================= +!BOP +! +! !IROUTINE: zerolayer_check - check that snow and ice energy is +! correct when using zero layer thermodynamics +! +! !INTERFACE: +! + subroutine zerolayer_check (nx_block, ny_block, & + icells, indxi, indxj, & + aicen, & + vicen, vsnon, & + eicen, esnon, & + l_stop, & + istop, jstop) +! +! !DESCRIPTION: +! +! Checks that the snow and ice energy in the zero layer thermodynamics +! model still agrees with the snow and ice volume. +! If there is an error, the model will abort. +! This subroutine is only called if heat_capacity = .false. +! +! !REVISION HISTORY: +! +! author: Alison McLaren, Met Office +! +! !USES: +! + use ice_work, only: worka, workb +! +! !INPUT/OUTPUT PARAMETERS: +! + integer (kind=int_kind), intent(in) :: & + nx_block, ny_block, & ! block dimensions + icells ! number of grid cells with ice + + integer (kind=int_kind), dimension (nx_block*ny_block), & + intent(in) :: & + indxi, indxj ! compressed i/j indices + + real (kind=dbl_kind), dimension (nx_block,ny_block,ncat), & + intent(inout) :: & + aicen , & ! concentration of ice + vicen , & ! volume per unit area of ice (m) + vsnon ! volume per unit area of snow (m) + + real (kind=dbl_kind), dimension (nx_block,ny_block,ntilyr), & + intent(in) :: & + eicen ! energy of melting for each ice layer (J/m^2) + + real (kind=dbl_kind), dimension (nx_block,ny_block,ntslyr), & + intent(in) :: & + esnon ! energy of melting for each snow layer (J/m^2) + + logical (kind=log_kind), intent(out) :: & + l_stop ! if true, abort on return + + integer (kind=int_kind), intent(out) :: & + istop, jstop ! indices of grid cell where model aborts +! +!EOP +! + integer (kind=int_kind) :: & + i, j , & ! horizontal indices + n , & ! category index + ij ! combined horizontal index + + real (kind=dbl_kind), parameter :: & + max_error = puny*Lfresh*rhos ! max error in zero layer energy check + ! (so max volume error = puny) + + logical (kind=log_kind) :: & + ice_energy_correct , & ! zero layer ice energy check + snow_energy_correct ! zero layer snow energy check + + !----------------------------------------------------------------- + ! Initialize + !----------------------------------------------------------------- + + l_stop = .false. + istop = 0 + jstop = 0 + + worka(:,:) = c0 + workb(:,:) = c0 + + !---------------------------------------------------------------- + ! Calculate difference between ice and snow energies and the + ! energy values derived from the ice and snow volumes + !---------------------------------------------------------------- + + ice_energy_correct = .true. + snow_energy_correct = .true. + + do n=1,ncat + + do ij=1,icells + i=indxi(ij) + j=indxj(ij) + + worka(i,j) = eicen(i,j,n) + rhoi * Lfresh * vicen(i,j,n) + workb(i,j) = esnon(i,j,n) + rhos * Lfresh * vsnon(i,j,n) + + if(abs(worka(i,j)) > max_error) then + ice_energy_correct = .false. + endif + + if(abs(workb(i,j)) > max_error) then + snow_energy_correct = .false. + endif + enddo + + !---------------------------------------------------------------- + ! If there is a problem, abort with error message + !---------------------------------------------------------------- + + if (.not. ice_energy_correct) then + + do ij=1,icells + i=indxi(ij) + j=indxj(ij) + + if(abs(worka(i,j)) > max_error) then + write(nu_diag,*) ' ' + write(nu_diag,*) & + 'zerolayer check - wrong ice energy' + write(nu_diag,*) 'i, j, n:', i,j,n + write(nu_diag,*) 'eicen =', eicen(i,j,n) + write(nu_diag,*) 'error=', worka(i,j) + write(nu_diag,*) 'vicen =', vicen(i,j,n) + write(nu_diag,*) 'aicen =', aicen(i,j,n) + l_stop = .true. + istop = i + jstop = j + endif + enddo + + endif + if (l_stop) return + + if (.not. snow_energy_correct) then + + do ij=1,icells + i=indxi(ij) + j=indxj(ij) + + if(abs(workb(i,j)) > max_error) then + write(nu_diag,*) ' ' + write(nu_diag,*) & + 'zerolayer_check - wrong snow energy' + write(nu_diag,*) 'i, j, n:', i,j,n + write(nu_diag,*) 'esnon =', esnon(i,j,n) + write(nu_diag,*) 'error=', workb(i,j) + write(nu_diag,*) 'vsnon =', vsnon(i,j,n) + write(nu_diag,*) 'aicen =', aicen(i,j,n) + l_stop = .true. + istop = i + jstop = j + return + endif + enddo + + endif + + enddo ! ncat + + end subroutine zerolayer_check + !======================================================================= end module ice_itd diff --git a/cice/source/ice_read_write.F90 b/cice/source/ice_read_write.F90 index ecefc2d..e239469 100644 --- a/cice/source/ice_read_write.F90 +++ b/cice/source/ice_read_write.F90 @@ -529,7 +529,7 @@ subroutine ice_read_nc(fid, nrec, varname, work, diag, & ! use ice_domain use ice_gather_scatter - use ice_work, only: work_g1 + use ice_work, only: work_g1, work_g2 use ice_exit ! ! !INPUT/OUTPUT PARAMETERS: @@ -576,6 +576,14 @@ subroutine ice_read_nc(fid, nrec, varname, work, diag, & allocate(work_g1(1,1)) ! to save memory endif +#ifdef ORCA_GRID + if (my_task == master_task) then + allocate(work_g2(nx_global,ny_global)) + else + allocate(work_g2(1,1)) ! to save memory + endif +#endif + if (my_task == master_task) then !------------------------------------------------------------- @@ -593,9 +601,16 @@ subroutine ice_read_nc(fid, nrec, varname, work, diag, & ! Read global array !-------------------------------------------------------------- +#ifndef ORCA_GRID status = nf90_get_var( fid, varid, work_g1, & start=(/1,1,nrec/), & count=(/nx_global,ny_global,1/) ) +#else + status = nf90_get_var( fid, varid, work_g2, & + start=(/1,1,nrec/), & + count=(/nx_global+2,ny_global+1,1/) ) + work_g1=work_g2(2:nx_global+1,1:ny_global) +#endif endif ! my_task = master_task @@ -635,6 +650,9 @@ subroutine ice_read_nc(fid, nrec, varname, work, diag, & endif deallocate(work_g1) +#ifdef ORCA_GRID + deallocate(work_g2) +#endif #else work = c0 ! to satisfy intent(out) attribute @@ -663,6 +681,9 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) ! !USES: ! use ice_exit +#ifdef ORCA_GRID + use ice_work, only: work_g3 +#endif ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -698,6 +719,15 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) dimname ! dimension name ! +#ifdef ORCA_GRID + if (my_task == master_task) then + allocate(work_g3(nx_global+2,ny_global+1)) + else + allocate(work_g3(1,1)) ! to save memory + endif + + work_g3(:,:) = c0 +#endif work_g(:,:) = c0 if (my_task == master_task) then @@ -717,10 +747,16 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) ! Read global array !-------------------------------------------------------------- +#ifndef ORCA_GRID status = nf90_get_var( fid, varid, work_g, & start=(/1,1,nrec/), & count=(/nx_global,ny_global,1/) ) - +#else + status = nf90_get_var( fid, varid, work_g3, & + start=(/1,1,nrec/), & + count=(/nx_global+2,ny_global+1,1/) ) + work_g=work_g3(2:nx_global+1,1:ny_global) +#endif endif ! my_task = master_task !------------------------------------------------------------------- @@ -745,6 +781,10 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) endif +#ifdef ORCA_GRID + deallocate(work_g3) +#endif + #else work_g = c0 ! to satisfy intent(out) attribute #endif diff --git a/cice/source/ice_restart.F90 b/cice/source/ice_restart.F90 index 3b66312..3573b49 100644 --- a/cice/source/ice_restart.F90 +++ b/cice/source/ice_restart.F90 @@ -274,8 +274,9 @@ subroutine restartfile if (my_task == master_task) then read (nu_restart) istep0,time,time_forc - write(nu_diag,*) 'read ',pointer_file(1:lenstr(pointer_file)) - write(nu_diag,*) 'restart read at istep=',istep0,time,time_forc + write(nu_diag,*) 'Read ',pointer_file(1:lenstr(pointer_file)) + write(nu_diag,*) 'Using restart dump=', trim(filename) + write(nu_diag,*) 'Restart read at istep=',istep0,time,time_forc endif call broadcast_scalar(istep0,master_task) diff --git a/cice/source/ice_shortwave.F90 b/cice/source/ice_shortwave.F90 index 8135aa2..5b2fe53 100644 --- a/cice/source/ice_shortwave.F90 +++ b/cice/source/ice_shortwave.F90 @@ -825,6 +825,8 @@ subroutine absorbed_solar (nx_block, ny_block, & fswthru, Iswabs) ! ! !USES: +! + use ice_therm_vertical, only: heat_capacity ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -994,6 +996,31 @@ subroutine absorbed_solar (nx_block, ny_block, & enddo ! ij + !---------------------------------------------------------------- + ! if zero-layer model (no heat capacity), no SW is absorbed in ice + ! interior, so add to surface absorption + !---------------------------------------------------------------- + + if (.not. heat_capacity) then + +!DIR$ CONCURRENT !Cray +!cdir nodep !NEC +!ocl novrec !Fujitsu + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + ! SW absorbed at snow/ice surface + fswsfc(i,j) = fswsfc(i,j) + fswint(i,j) + + ! SW absorbed in ice interior (nilyr = 1) + fswint(i,j) = c0 + Iswabs(i,j,1) = c0 + + enddo ! ij + + endif ! heat_capacity + end subroutine absorbed_solar ! End ccsm3 shortwave method @@ -1402,7 +1429,7 @@ subroutine compute_dEdd & icells_DE, indxi_DE, indxj_DE, fnidr, coszen, & swvdr, swvdf, swidr, swidf, srftyp, & hs, rhosnw, rsnw, hi, hp, & - fi, alvdr, alvdf, & + fi, alvdr, alvdf, & alidr, alidf, & fswsfc, fswint, & fswthru, Sswabs, & @@ -1419,6 +1446,8 @@ subroutine compute_dEdd & ! update: 8 February 2007 ! ! !USES: +! + use ice_therm_vertical, only: heat_capacity ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -2475,6 +2504,33 @@ subroutine compute_dEdd & enddo ! ij enddo ! k + !---------------------------------------------------------------- + ! if ice has zero heat capacity, no SW can be absorbed + ! in the ice/snow interior, so add to surface absorption. + ! Note: nilyr = nslyr = 1 for this case + !---------------------------------------------------------------- + + if (.not. heat_capacity) then + +!DIR$ CONCURRENT !Cray +!cdir nodep !NEC +!ocl novrec !Fujitsu + do ij = 1, icells_DE + i = indxi_DE(ij) + j = indxj_DE(ij) + + ! SW absorbed at snow/ice surface + fswsfc(i,j) = fswsfc(i,j) + Iswabs(i,j,1) + Sswabs(i,j,1) + + ! SW absorbed in ice interior + fswint(i,j) = c0 + Iswabs(i,j,1) = c0 + Sswabs(i,j,1) = c0 + + enddo ! ij + + endif ! heat_capacity + end subroutine compute_dEdd !======================================================================= diff --git a/cice/source/ice_therm_itd.F90 b/cice/source/ice_therm_itd.F90 index ab76077..aeb2e72 100644 --- a/cice/source/ice_therm_itd.F90 +++ b/cice/source/ice_therm_itd.F90 @@ -506,7 +506,7 @@ subroutine linear_itd (nx_block, ny_block, & !----------------------------------------------------------------- do n = 1, ncat - do ij = 1, iflag ! remap_flag = .true. + do ij = 1, icells donor(ij,n) = 0 daice(ij,n) = c0 dvice(ij,n) = c0 @@ -834,16 +834,18 @@ end subroutine fit_line ! ! !INTERFACE: ! - subroutine add_new_ice (nx_block, ny_block, & - icells, & - indxi, indxj, & - tmask, dt, & - aicen, trcrn, & - vicen, eicen, & - aice0, aice, & - frzmlt, frazil, & - frz_onset, yday, & - Tf, l_stop, & + subroutine add_new_ice (nx_block, ny_block, & + icells, & + indxi, indxj, & + tmask, dt, & + aicen, trcrn, & + vicen, eicen, & + aice0, aice, & + frzmlt, frazil, & + frz_onset, yday, & + fresh, fresh_hist, & + fsalt, fsalt_hist, & + Tf, l_stop, & istop, jstop) ! ! !USES: @@ -852,6 +854,7 @@ subroutine add_new_ice (nx_block, ny_block, & column_conservation_check use ice_state, only: nt_Tsfc, nt_iage use ice_age, only: tr_iage + use ice_flux, only: update_ocn_f ! !INPUT/OUTPUT PARAMETERS: ! @@ -891,8 +894,12 @@ subroutine add_new_ice (nx_block, ny_block, & real (kind=dbl_kind), dimension (nx_block,ny_block), & intent(inout) :: & - aice0 , & ! concentration of open water - frazil ! frazil ice growth (m/step-->cm/day) + aice0 , & ! concentration of open water + frazil , & ! frazil ice growth (m/step-->cm/day) + fresh , & ! fresh water flux to ocean (kg/m^2/s) + fresh_hist, & ! fresh water flux to ocean (kg/m^2/s) + fsalt , & ! salt flux to ocean (kg/m^2/s) + fsalt_hist ! salt flux to ocean (kg/m^2/s) real (kind=dbl_kind), dimension (nx_block,ny_block), & intent(inout), optional :: & @@ -1017,14 +1024,15 @@ subroutine add_new_ice (nx_block, ny_block, & ! is NOT included in fluxes fresh and fsalt. !----------------------------------------------------------------- -!!! dfresh = -rhoi*vi0new(ij)/dt ! if POP had not already adjusted - ! itself based on frzmlt -!!! dfsalt = ice_ref_salinity*p001*dfresh + if (update_ocn_f) then + dfresh = -rhoi*vi0new(ij)/dt + dfsalt = ice_ref_salinity*p001*dfresh -!!! fresh(i,j) = fresh(i,j) + dfresh -!!! fresh_hist(i,j) = fresh_hist(i,j) + dfresh -!!! fsalt(i,j) = fsalt(i,j) + dfsalt -!!! fsalt_hist(i,j) = fsalt_hist(i,j) + dfsalt + fresh(i,j) = fresh(i,j) + dfresh + fresh_hist(i,j) = fresh_hist(i,j) + dfresh + fsalt(i,j) = fsalt(i,j) + dfsalt + fsalt_hist(i,j) = fsalt_hist(i,j) + dfsalt + endif !----------------------------------------------------------------- ! Decide how to distribute the new ice. diff --git a/cice/source/ice_therm_vertical.F90 b/cice/source/ice_therm_vertical.F90 index f53cb14..1096a54 100644 --- a/cice/source/ice_therm_vertical.F90 +++ b/cice/source/ice_therm_vertical.F90 @@ -43,7 +43,10 @@ module ice_therm_vertical save real (kind=dbl_kind), parameter :: & - saltmax = 3.2_dbl_kind ! max salinity at ice base (ppt) + saltmax = 3.2_dbl_kind, & ! max salinity at ice base (ppt) + hs_min = 1.0e-4_dbl_kind,&! min thickness for which Tsno computed + betak = 0.13_dbl_kind, & ! constant in formula for k (W m-1 ppt-1) + kimin = 0.10_dbl_kind ! min conductivity of saline ice (W m-1 deg-1) real (kind=dbl_kind), dimension(nilyr+1) :: & salin , & ! salinity (ppt) @@ -54,15 +57,21 @@ module ice_therm_vertical ustar_scale ! scaling for ice-ocean heat flux real (kind=dbl_kind), parameter, private :: & - ferrmax = 1.0e-3_dbl_kind, & ! max allowed energy flux error (W m-2) + ferrmax = 1.0e-3_dbl_kind ! max allowed energy flux error (W m-2) ! recommend ferrmax < 0.01 W m-2 - hsnomin = 1.0e-4_dbl_kind ! min thickness for which Tsno computed character (char_len) :: stoplabel logical (kind=log_kind) :: & l_brine ! if true, treat brine pocket effects + logical (kind=log_kind) :: & + heat_capacity = .true., &! if true, ice has nonzero heat capacity + ! if false, use zero-layer thermodynamics + calc_Tsfc = .true. ! if true, calculate surface temperature + ! if false, Tsfc is computed elsewhere and + ! atmos-ice fluxes are provided to CICE + !======================================================================= contains @@ -98,8 +107,9 @@ subroutine thermo_vertical (nx_block, ny_block, & fbot, Tbot, & lhcoef, shcoef, & fswsfc, fswint, & - fswthrun, Sswabs, & - Iswabs, & + fswthrun, & + Sswabs, Iswabs, & + fsurfn, fcondtopn, & fsensn, flatn, & fswabsn, flwoutn, & evapn, freshn, & @@ -116,7 +126,6 @@ subroutine thermo_vertical (nx_block, ny_block, & ! use ice_communicate, only: my_task, master_task use ice_calendar, only: istep1 - use ice_diagnostics, only: print_state use ice_exit use ice_ocean use ice_itd, only: ilyr1, slyr1, ilyrn, slyrn @@ -187,11 +196,16 @@ subroutine thermo_vertical (nx_block, ny_block, & ! coupler fluxes to atmosphere real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out):: & fsensn , & ! sensible heat flux (W/m^2) - flatn , & ! latent heat flux (W/m^2) fswabsn , & ! shortwave flux absorbed in ice and ocean (W/m^2) flwoutn , & ! outgoing longwave radiation (W/m^2) evapn ! evaporative water flux (kg/m^2/s) + ! Note: these are intent out if calc_Tsfc = T, otherwise intent in + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(inout):: & + flatn , & ! latent heat flux (W/m^2) + fsurfn , & ! net flux to top surface, excluding fcondtopn + fcondtopn ! downward cond flux at top surface (W m-2) + ! coupler fluxes to ocean real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out):: & freshn , & ! fresh water flux to ocean (kg/m^2/s) @@ -224,7 +238,6 @@ subroutine thermo_vertical (nx_block, ny_block, & i, j , & ! horizontal indices ij , & ! horizontal index, combines i and j loops ilo,ihi,jlo,jhi, & ! beginning and end of physical domain - n , & ! thickness category index k , & ! ice layer index il1, il2 , & ! ice layer indices for eice sl1, sl2 ! snow layer indices for esno @@ -256,8 +269,6 @@ subroutine thermo_vertical (nx_block, ny_block, & ! other 2D flux and energy variables real (kind=dbl_kind), dimension (icells) :: & - fsurf , & ! net flux to top surface, not including fcondtop - fcondtop , & ! downward cond flux at top surface (W m-2) fcondbot , & ! downward cond flux at bottom surface (W m-2) einit , & ! initial energy of melting (J m-2) efinal ! final energy of melting (J m-2) @@ -278,7 +289,6 @@ subroutine thermo_vertical (nx_block, ny_block, & do j=1, ny_block do i=1, nx_block fsensn (i,j) = c0 - flatn (i,j) = c0 fswabsn(i,j) = c0 flwoutn(i,j) = c0 evapn (i,j) = c0 @@ -292,6 +302,16 @@ subroutine thermo_vertical (nx_block, ny_block, & enddo enddo + if (calc_Tsfc) then + do j=1, ny_block + do i=1, nx_block + flatn (i,j) = c0 + fsurfn (i,j) = c0 + fcondtopn(i,j) = c0 + enddo + enddo + endif + !----------------------------------------------------------------- ! Compute variables needed for vertical thermo calculation !----------------------------------------------------------------- @@ -320,32 +340,71 @@ subroutine thermo_vertical (nx_block, ny_block, & works(ij) = hsn(ij) enddo - !----------------------------------------------------------------- ! Compute new surface temperature and internal ice and snow ! temperatures. !----------------------------------------------------------------- - call temperature_changes (nx_block, ny_block, & - my_task, istep1, & - dt, icells, & - indxi, indxj, & - rhoa, flw, & - potT, Qa, & - shcoef, lhcoef, & - fswsfc, fswint, & - fswthrun, Sswabs, & - Iswabs, & - hilyr, hslyr, & - qin, Tin, & - qsn, Tsn, & - Tsf, Tbot, & - fsensn, flatn, & - fswabsn, flwoutn, & - fsurf, & - fcondtop, fcondbot, & - einit, l_stop, & - istop, jstop) + if (heat_capacity) then ! usual case + + call temperature_changes(nx_block, ny_block, & + my_task, istep1, & + dt, icells, & + indxi, indxj, & + rhoa, flw, & + potT, Qa, & + shcoef, lhcoef, & + fswsfc, fswint, & + fswthrun, Sswabs, & + Iswabs, & + hilyr, hslyr, & + qin, Tin, & + qsn, Tsn, & + Tsf, Tbot, & + fsensn, flatn, & + fswabsn, flwoutn, & + fsurfn, & + fcondtopn, fcondbot, & + einit, l_stop, & + istop, jstop) + + else + + if (calc_Tsfc) then + + call zerolayer_temperature(nx_block, ny_block, & + my_task, istep1, & + dt, icells, & + indxi, indxj, & + rhoa, flw, & + potT, Qa, & + shcoef, lhcoef, & + fswsfc, fswthrun, & + hilyr, hslyr, & + Tsf, Tbot, & + fsensn, flatn, & + fswabsn, flwoutn, & + fsurfn, & + fcondtopn, fcondbot, & + l_stop, & + istop, jstop) + + else + + !------------------------------------------------------------ + ! Set fcondbot = fcondtop for zero layer thermodynamics + ! fcondtop is set in call to set_sfcflux in step_therm1 + !------------------------------------------------------------ + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + fcondbot(ij) = fcondtopn(i,j) ! zero layer + enddo + + endif ! calc_Tsfc + + endif ! heat_capacity if (l_stop) return @@ -364,8 +423,8 @@ subroutine thermo_vertical (nx_block, ny_block, & hsn, hslyr, & qin, qsn, & fbot, Tbot, & - flatn, fsurf, & - fcondtop, fcondbot, & + flatn, fsurfn, & + fcondtopn, fcondbot, & fsnow, hsn_new, & fhocnn, evapn, & meltt, melts, & @@ -382,7 +441,7 @@ subroutine thermo_vertical (nx_block, ny_block, & my_task, istep1, & dt, icells, & indxi, indxj, & - fsurf, flatn, & + fsurfn, flatn, & fhocnn, fswint, & fsnow, & einit, efinal, & @@ -409,7 +468,6 @@ subroutine thermo_vertical (nx_block, ny_block, & enddo ! ij - !----------------------------------------------------------------- ! Given the vertical thermo state variables (hin, hsn, Tsf, ! qin, qsn,), compute the new ice state variables (vicen, vsnon, @@ -476,9 +534,10 @@ subroutine init_thermo_vertical ! Determine l_brine based on saltmax. ! Thermodynamic solver will not converge if l_brine is true and ! saltmax is close to zero. + ! Set l_brine to false for zero layer thermodynamics !----------------------------------------------------------------- - if (saltmax > min_salin) then + if (saltmax > min_salin .and. heat_capacity) then l_brine = .true. else l_brine = .false. @@ -889,6 +948,11 @@ subroutine init_vertical_profile(nx_block, ny_block, & enddo ! ij + !----------------------------------------------------------------- + ! Snow enthalpy and maximum allowed snow temperature + ! If heat_capacity = F, qsn and Tsn are never used. + !----------------------------------------------------------------- + do k = 1, nslyr !DIR$ CONCURRENT !Cray !cdir nodep !NEC @@ -898,7 +962,6 @@ subroutine init_vertical_profile(nx_block, ny_block, & j = indxj(ij) !----------------------------------------------------------------- - ! Snow enthalpy and maximum allowed snow temperature ! ! Tmax based on the idea that dT ~ dq / (rhos*cp_ice) ! dq ~ q dv / v @@ -906,7 +969,7 @@ subroutine init_vertical_profile(nx_block, ny_block, & ! where 'd' denotes an error due to roundoff. !----------------------------------------------------------------- - if (hslyr(ij) > hsnomin) then + if (hslyr(ij) > hs_min .and. heat_capacity) then ! qsn, esnon < 0 qsn (ij,k) = esnon(i,j,k)*real(nslyr,kind=dbl_kind) & /vsnon(i,j) @@ -938,13 +1001,14 @@ subroutine init_vertical_profile(nx_block, ny_block, & !----------------------------------------------------------------- ! If Tsn is out of bounds, print diagnostics and exit. !----------------------------------------------------------------- - if (tsno_high) then + + if (tsno_high .and. heat_capacity) then do k = 1, nslyr do ij = 1, icells i = indxi(ij) j = indxj(ij) - if (hslyr(ij) > hsnomin) then + if (hslyr(ij) > hs_min) then Tmax = -qsn(ij,k)*puny / & (rhos*cp_ice*vsnon(i,j)) else @@ -969,7 +1033,7 @@ subroutine init_vertical_profile(nx_block, ny_block, & enddo ! nslyr endif ! tsno_high - if (tsno_low) then + if (tsno_low .and. heat_capacity) then do k = 1, nslyr do ij = 1, icells i = indxi(ij) @@ -1022,6 +1086,7 @@ subroutine init_vertical_profile(nx_block, ny_block, & !----------------------------------------------------------------- ! Compute ice enthalpy + ! If heat_capacity = F, qin and Tin are never used. !----------------------------------------------------------------- ! qin, eicen < 0 qin(ij,k) = eicen(i,j,k)*real(nilyr,kind=dbl_kind) & @@ -1060,7 +1125,7 @@ subroutine init_vertical_profile(nx_block, ny_block, & ! If Tin is out of bounds, print diagnostics and exit. !----------------------------------------------------------------- - if (tice_high) then + if (tice_high .and. heat_capacity) then do ij = 1, icells i = indxi(ij) j = indxj(ij) @@ -1086,7 +1151,7 @@ subroutine init_vertical_profile(nx_block, ny_block, & enddo ! ij endif ! tice_high - if (tice_low) then + if (tice_low .and. heat_capacity) then do ij = 1, icells i = indxi(ij) j = indxj(ij) @@ -1171,8 +1236,8 @@ subroutine temperature_changes (nx_block, ny_block, & Tsf, Tbot, & fsensn, flatn, & fswabsn, flwoutn, & - fsurf, & - fcondtop, fcondbot, & + fsurfn, & + fcondtopn,fcondbot, & einit, l_stop, & istop, jstop) ! @@ -1222,6 +1287,11 @@ subroutine temperature_changes (nx_block, ny_block, & intent(inout) :: & Iswabs ! SW radiation absorbed in ice layers (W m-2) + ! These are input arguments if calc_Tsfc = F, else are output arguments + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(inout):: & + fsurfn , & ! net flux to top surface, excluding fcondtopn + fcondtopn ! downward cond flux at top surface (W m-2) + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out):: & fsensn , & ! surface downward sensible heat (W m-2) flatn , & ! surface downward latent heat (W m-2) @@ -1229,8 +1299,6 @@ subroutine temperature_changes (nx_block, ny_block, & flwoutn ! upward LW at surface (W m-2) real (kind=dbl_kind), dimension (icells), intent(out):: & - fsurf , & ! net flux to top surface, not including fcondtop - fcondtop , & ! downward cond flux at top surface (W m-2) fcondbot ! downward cond flux at bottom surface (W m-2) real (kind=dbl_kind), dimension (icells), & @@ -1285,12 +1353,14 @@ subroutine temperature_changes (nx_block, ny_block, & real (kind=dbl_kind), dimension (:), allocatable :: & Tsf_start , & ! Tsf at start of iteration dTsf , & ! Tsf - Tsf_start + dTi1 , & ! Ti1(1) - Tin_start(1) dfsurf_dT , & ! derivative of fsurf wrt Tsf avg_Tsi , & ! = 1. if new snow/ice temps avg'd w/starting temps enew ! new energy of melting after temp change (J m-2) real (kind=dbl_kind), dimension (icells) :: & dTsf_prev , & ! dTsf from previous iteration + dTi1_prev , & ! dTi1 from previous iteration dfsens_dT , & ! deriv of fsens wrt Tsf (W m-2 deg-1) dflat_dT , & ! deriv of flat wrt Tsf (W m-2 deg-1) dflwout_dT , & ! deriv of flwout wrt Tsf (W m-2 deg-1) @@ -1336,26 +1406,29 @@ subroutine temperature_changes (nx_block, ny_block, & all_converged = .false. do ij = 1, icells - fsurf (ij) = c0 - fcondtop(ij) = c0 - fcondbot(ij) = c0 converged (ij) = .false. l_snow (ij) = .false. l_cold (ij) = .true. - + fcondbot (ij) = c0 dTsf_prev (ij) = c0 - + dTi1_prev (ij) = c0 + dfsens_dT (ij) = c0 + dflat_dT (ij) = c0 + dflwout_dT(ij) = c0 dt_rhoi_hlyr(ij) = dt / (rhoi*hilyr(ij)) ! hilyr > 0 - if (hslyr(ij) > hsnomin) l_snow(ij) = .true. + if (hslyr(ij) > hs_min) l_snow(ij) = .true. enddo ! ij do k = 1, nslyr do ij = 1, icells Tsn_init (ij,k) = Tsn(ij,k) ! beginning of time step Tsn_start(ij,k) = Tsn(ij,k) ! beginning of iteration - etas (ij,k) = c0 - if (l_snow(ij)) etas(ij,k) = dt/(rhos*cp_ice*hslyr(ij)) + if (l_snow(ij)) then + etas(ij,k) = dt/(rhos*cp_ice*hslyr(ij)) + else + etas(ij,k) = c0 + endif enddo ! ij enddo ! k @@ -1379,6 +1452,14 @@ subroutine temperature_changes (nx_block, ny_block, & hilyr, hslyr, & Tin, kh ) + !----------------------------------------------------------------- + ! Check for excessive absorbed solar radiation that may result in + ! temperature overshoots. Switch that radiation to fswsfc if necessary. + ! NOTE: This option is not available if the atmosphere model + ! has already computed fsurf. (Unless we adjust fsurf here) + !----------------------------------------------------------------- +!mclaren: Should there be an if calc_Tsfc statement here then?? + allocate(etai(icells,nilyr)) do k = 1, nilyr @@ -1388,8 +1469,7 @@ subroutine temperature_changes (nx_block, ny_block, & if (l_brine) then ci = cp_ice - Lfresh*Tmlt(k) / & - max( (Tin_init(ij,k)*Tin_init(ij,k)), & - (1.21_dbl_kind*Tmlt(k)*Tmlt(k)) ) + max( Tin_init(ij,k)**2, Tmlt(k)**2 ) else ci = cp_ice endif @@ -1405,10 +1485,10 @@ subroutine temperature_changes (nx_block, ny_block, & if (l_brine) then Iswabs_tmp = min(Iswabs(i,j,k), & - 0.9_dbl_kind*(Tmlt(k)-Tin_init(ij,k))/etai(ij,k)) + (Tmlt(k)-Tin_init(ij,k))/etai(ij,k)) else Iswabs_tmp = min(Iswabs(i,j,k), & - -0.9_dbl_kind*Tin_init(ij,k)/etai(ij,k)) + Tin_init(ij,k)/etai(ij,k)) endif if (Tin_init(ij,k) > (Tmlt(k) - p01)) Iswabs_tmp = c0 @@ -1443,6 +1523,16 @@ subroutine temperature_changes (nx_block, ny_block, & enddo enddo +!lipscomb - This could be done in the shortwave module instead. +! (Change zerolayer routine also) + ! absorbed shortwave flux for coupler + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + fswabsn(i,j) = fswsfc(i,j) + fswint(i,j) + fswthrun(i,j) + enddo + !----------------------------------------------------------------- ! Solve for new temperatures. ! Iterate until temperatures converge with minimal energy error. @@ -1450,6 +1540,10 @@ subroutine temperature_changes (nx_block, ny_block, & do niter = 1, nitermax + !----------------------------------------------------------------- + ! Identify cells, if any, where calculation has not converged. + !----------------------------------------------------------------- + if (all_converged) then ! thermo calculation is done exit else ! identify cells not yet converged @@ -1466,6 +1560,10 @@ subroutine temperature_changes (nx_block, ny_block, & enddo ! ij endif + !----------------------------------------------------------------- + ! Allocate and initialize + !----------------------------------------------------------------- + allocate( sbdiag(isolve,nilyr+nslyr+1)) allocate( diag(isolve,nilyr+nslyr+1)) allocate( spdiag(isolve,nilyr+nslyr+1)) @@ -1477,13 +1575,26 @@ subroutine temperature_changes (nx_block, ny_block, & allocate(dfsurf_dT(isolve)) allocate( avg_Tsi(isolve)) allocate( enew(isolve)) + allocate( dTi1(isolve)) + + all_converged = .true. + + do ij = 1, isolve + m = indxij(ij) + converged(m) = .true. + dfsurf_dT(ij) = c0 + avg_Tsi (ij) = c0 + enew (ij) = c0 + enddo + + if (calc_Tsfc) then !----------------------------------------------------------------- ! Update radiative and turbulent fluxes and their derivatives ! with respect to Tsf. !----------------------------------------------------------------- - call surface_fluxes (nx_block, ny_block, & + call surface_fluxes(nx_block, ny_block, & isolve, icells, & indxii, indxjj, indxij, & Tsf, fswsfc, & @@ -1491,29 +1602,31 @@ subroutine temperature_changes (nx_block, ny_block, & potT, Qa, & shcoef, lhcoef, & flwoutn, fsensn, & - flatn, fsurf, & + flatn, fsurfn, & dflwout_dT, dfsens_dT, & dflat_dT, dfsurf_dT) !DIR$ CONCURRENT !Cray !cdir nodep !NEC !ocl novrec !Fujitsu - do ij = 1, isolve + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) m = indxij(ij) !----------------------------------------------------------------- - ! Compute conductive flux at top surface, fcondtop. - ! If fsurf < fcondtop and Tsf = 0, then reset Tsf to slightly less + ! Compute conductive flux at top surface, fcondtopn. + ! If fsurfn < fcondtopn and Tsf = 0, then reset Tsf to slightly less ! than zero (but not less than -puny). !----------------------------------------------------------------- if (l_snow(m)) then - fcondtop(m) = kh(m,1) * (Tsf(m) - Tsn(m,1)) + fcondtopn(i,j) = kh(m,1) * (Tsf(m) - Tsn(m,1)) else - fcondtop(m) = kh(m,1+nslyr) * (Tsf(m) - Tin(m,1)) + fcondtopn(i,j) = kh(m,1+nslyr) * (Tsf(m) - Tin(m,1)) endif - if (fsurf(m) < fcondtop(m)) & + if (fsurfn(i,j) < fcondtopn(i,j)) & Tsf(m) = min (Tsf(m), -puny) !----------------------------------------------------------------- @@ -1527,7 +1640,9 @@ subroutine temperature_changes (nx_block, ny_block, & else l_cold(m) = .false. endif - enddo ! ij + enddo ! ij + + endif ! calc_Tsfc !----------------------------------------------------------------- ! Update specific heat of ice layers. @@ -1553,18 +1668,23 @@ subroutine temperature_changes (nx_block, ny_block, & enddo enddo + !----------------------------------------------------------------- + ! Compute elements of tridiagonal matrix. + !----------------------------------------------------------------- + call get_matrix_elements (nx_block, ny_block, & isolve, icells, & indxii, indxjj, indxij, & l_snow, l_cold, & Tsf, Tbot, & - fsurf, dfsurf_dT, & + fsurfn, dfsurf_dT, & Tin_init, Tsn_init, & kh, Sswabs, & Iswabs, & etai, etas, & sbdiag, diag, & - spdiag, rhs) + spdiag, rhs, & + fcondtopn) !----------------------------------------------------------------- ! Solve tridiagonal matrix to obtain the new temperatures. @@ -1588,8 +1708,8 @@ subroutine temperature_changes (nx_block, ny_block, & ! with magnitude greater than 0.5. ! (3) abs(dTsf) < Tsf_errmax ! (4) If Tsf = 0 C, then the downward turbulent/radiative - ! flux, fsurf, must be greater than or equal to the downward - ! conductive flux, fcondtop. + ! flux, fsurfn, must be greater than or equal to the downward + ! conductive flux, fcondtopn. ! (5) The net energy added to the ice per unit time must equal ! the net change in internal ice energy per unit time, ! within the prescribed error ferrmax. @@ -1604,13 +1724,12 @@ subroutine temperature_changes (nx_block, ny_block, & ! to conserve energy) in the thickness_changes subroutine. !----------------------------------------------------------------- - ! initialize global convergence flag - all_converged = .true. + if (calc_Tsfc) then !DIR$ CONCURRENT !Cray !cdir nodep !NEC !ocl novrec !Fujitsu - do ij = 1, isolve + do ij = 1, isolve m = indxij(ij) !----------------------------------------------------------------- @@ -1634,11 +1753,8 @@ subroutine temperature_changes (nx_block, ny_block, & ! Initialize energy. !----------------------------------------------------------------- - converged(m) = .true. dTsf(ij) = Tsf(m) - Tsf_start(ij) - avg_Tsf = c0 - avg_Tsi(ij) = c0 - enew(ij) = c0 + avg_Tsf = c0 !----------------------------------------------------------------- ! Condition 1: check for Tsf > 0 @@ -1673,6 +1789,8 @@ subroutine temperature_changes (nx_block, ny_block, & all_converged = .false. endif +!!! dTsf_prev(m) = dTsf(ij) + !----------------------------------------------------------------- ! If condition 2 failed, average new surface temperature with ! starting value. @@ -1680,7 +1798,9 @@ subroutine temperature_changes (nx_block, ny_block, & Tsf(m) = Tsf(m) & + avg_Tsf * p5 * (Tsf_start(ij) - Tsf(m)) - enddo ! ij + enddo ! ij + + endif ! calc_Tsfc do k = 1, nslyr !DIR$ CONCURRENT !Cray @@ -1698,6 +1818,7 @@ subroutine temperature_changes (nx_block, ny_block, & else Tsn(m,k) = c0 endif +!lipscomb - if l_brine and calc_Tsfc? if (l_brine) Tsn(m,k) = min(Tsn(m,k), c0) !----------------------------------------------------------------- @@ -1729,8 +1850,30 @@ subroutine temperature_changes (nx_block, ny_block, & ! Reload Tin from matrix solution !----------------------------------------------------------------- Tin(m,k) = Tmat(ij,k+1+nslyr) +!lipscomb - if l_brine and calc_Tsfc? if (l_brine) Tin(m,k) = min(Tin(m,k), Tmlt(k)) + !----------------------------------------------------------------- + ! Condition 2b: check for oscillating Tin(1) + ! If oscillating, average all ice temps to increase rate of convergence. + !----------------------------------------------------------------- + + if (k==1 .and. .not.calc_Tsfc) then + dTi1(ij) = Tin(m,k) - Tin_start(m,k) + + if (niter > 1 & ! condition 2b + .and. abs(dTi1(ij)) > puny & + .and. abs(dTi1_prev(m)) > puny & + .and. -dTi1(ij)/(dTi1_prev(m)+puny*puny) > p5) then + + if (l_brine) avg_Tsi(ij) = c1 + dTi1(ij) = p5 * dTi1(ij) + converged(m) = .false. + all_converged = .false. + endif + dTi1_prev(m) = dTi1(ij) + endif ! k = 1 .and. calc_Tsfc = F + !----------------------------------------------------------------- ! If condition 1 or 2 failed, average new ice layer ! temperatures with their starting values. @@ -1751,10 +1894,12 @@ subroutine temperature_changes (nx_block, ny_block, & enddo ! ij enddo ! nilyr + if (calc_Tsfc) then + !DIR$ CONCURRENT !Cray !cdir nodep !NEC !ocl novrec !Fujitsu - do ij = 1, isolve + do ij = 1, isolve i = indxii(ij) j = indxjj(ij) m = indxij(ij) @@ -1769,31 +1914,41 @@ subroutine temperature_changes (nx_block, ny_block, & endif !----------------------------------------------------------------- - ! Condition 4: check for fsurf < fcondtop with Tsf > 0 + ! Condition 4: check for fsurfn < fcondtopn with Tsf > 0 !----------------------------------------------------------------- - fsurf(m) = fsurf(m) + dTsf(ij)*dfsurf_dT(ij) + fsurfn(i,j) = fsurfn(i,j) + dTsf(ij)*dfsurf_dT(ij) if (l_snow(m)) then - fcondtop(m) = kh(m,1) * (Tsf(m)-Tsn(m,1)) + fcondtopn(i,j) = kh(m,1) * (Tsf(m)-Tsn(m,1)) else - fcondtop(m) = kh(m,1+nslyr) * (Tsf(m)-Tin(m,1)) + fcondtopn(i,j) = kh(m,1+nslyr) * (Tsf(m)-Tin(m,1)) endif - if (Tsf(m) > -puny .and. fsurf(m) < fcondtop(m)) then + if (Tsf(m) > -puny .and. fsurfn(i,j) < fcondtopn(i,j)) then converged(m) = .false. all_converged = .false. endif + dTsf_prev(m) = dTsf(ij) + + enddo ! ij + endif ! calc_Tsfc + !----------------------------------------------------------------- ! Condition 5: check for energy conservation error ! Change in internal ice energy should equal net energy input. !----------------------------------------------------------------- + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + fcondbot(m) = kh(m,1+nslyr+nilyr) * & (Tin(m,nilyr) - Tbot(i,j)) ferr = abs( (enew(ij)-einit(m))/dt & - - (fcondtop(m) - fcondbot(m) + fswint(i,j)) ) + - (fcondtopn(i,j) - fcondbot(m) + fswint(i,j)) ) ! factor of 0.9 allows for roundoff errors later if (ferr > 0.9_dbl_kind*ferrmax) then ! condition (5) @@ -1801,8 +1956,6 @@ subroutine temperature_changes (nx_block, ny_block, & all_converged = .false. endif - dTsf_prev(m) = dTsf(ij) - enddo ! ij deallocate(sbdiag) @@ -1816,6 +1969,7 @@ subroutine temperature_changes (nx_block, ny_block, & deallocate(dfsurf_dT) deallocate(avg_Tsi) deallocate(enew) + deallocate(dTi1) enddo ! temperature iteration niter @@ -1837,11 +1991,11 @@ subroutine temperature_changes (nx_block, ny_block, & write(nu_diag,*) 'dTsf, Tsf_errmax:',dTsf_prev(ij), & Tsf_errmax write(nu_diag,*) 'Tsf:', Tsf(ij) - write(nu_diag,*) 'fsurf:', fsurf(ij) + write(nu_diag,*) 'fsurf:', fsurfn(i,j) write(nu_diag,*) 'fcondtop, fcondbot, fswint', & - fcondtop(ij), fcondbot(ij), fswint(i,j) + fcondtopn(i,j), fcondbot(ij), fswint(i,j) write(nu_diag,*) 'fswsfc, fswthrun', & - fswsfc(i,j), fswthrun(i,j) + fswsfc(i,j), fswthrun(i,j) write(nu_diag,*) 'Flux conservation error =', ferr write(nu_diag,*) 'Initial snow temperatures:' write(nu_diag,*) (Tsn_init(ij,k),k=1,nslyr) @@ -1859,22 +2013,21 @@ subroutine temperature_changes (nx_block, ny_block, & enddo ! ij endif ! all_converged + if (calc_Tsfc) then !DIR$ CONCURRENT !Cray !cdir nodep !NEC !ocl novrec !Fujitsu - do ij = 1, icells - i = indxi(ij) - j = indxj(ij) - - ! update fluxes that depend on Tsf - flwoutn(i,j) = flwoutn(i,j) + dTsf_prev(ij) * dflwout_dT(ij) - fsensn(i,j) = fsensn(i,j) + dTsf_prev(ij) * dfsens_dT(ij) - flatn(i,j) = flatn(i,j) + dTsf_prev(ij) * dflat_dT(ij) + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) - ! absorbed shortwave flux for coupler - fswabsn(i,j) = fswsfc(i,j) + fswint(i,j) + fswthrun(i,j) + ! update fluxes that depend on Tsf + flwoutn(i,j) = flwoutn(i,j) + dTsf_prev(ij) * dflwout_dT(ij) + fsensn(i,j) = fsensn(i,j) + dTsf_prev(ij) * dfsens_dT(ij) + flatn(i,j) = flatn(i,j) + dTsf_prev(ij) * dflat_dT(ij) - enddo ! ij + enddo ! ij + endif ! calc_Tsfc end subroutine temperature_changes @@ -1937,10 +2090,6 @@ subroutine conductivity (nx_block, ny_block, & ! !EOP ! - real (kind=dbl_kind), parameter :: & - betak = 0.13_dbl_kind, & ! constant in formula for k (W m-1 ppt-1) - kimin = 0.10_dbl_kind ! min conductivity of saline ice (W m-1 deg-1) - integer (kind=int_kind) :: & i, j , & ! horizontal indices ij, m , & ! horizontal indices, combine i and j loops @@ -2038,7 +2187,7 @@ subroutine surface_fluxes (nx_block, ny_block, & potT, Qa, & shcoef, lhcoef, & flwoutn, fsensn, & - flatn, fsurf, & + flatn, fsurfn, & dflwout_dT, dfsens_dT, & dflat_dT, dfsurf_dT) ! @@ -2074,18 +2223,18 @@ subroutine surface_fluxes (nx_block, ny_block, & intent(inout) :: & fsensn , & ! surface downward sensible heat (W m-2) flatn , & ! surface downward latent heat (W m-2) - flwoutn ! upward LW at surface (W m-2) + flwoutn , & ! upward LW at surface (W m-2) + fsurfn ! net flux to top surface, excluding fcondtopn real (kind=dbl_kind), dimension (icells), & intent(inout) :: & dfsens_dT , & ! deriv of fsens wrt Tsf (W m-2 deg-1) dflat_dT , & ! deriv of flat wrt Tsf (W m-2 deg-1) - dflwout_dT , & ! deriv of flwout wrt Tsf (W m-2 deg-1) - fsurf ! net flux to top surface, not including fcondtop + dflwout_dT ! deriv of flwout wrt Tsf (W m-2 deg-1) real (kind=dbl_kind), dimension (isolve), & intent(inout) :: & - dfsurf_dT ! derivative of fsurf wrt Tsf + dfsurf_dT ! derivative of fsurfn wrt Tsf ! !EOP ! @@ -2132,8 +2281,8 @@ subroutine surface_fluxes (nx_block, ny_block, & dfsens_dT(m) = - shcoef(i,j) dflat_dT(m) = - lhcoef(i,j) * dQsfcdT - fsurf(m) = fswsfc(i,j) + flwdabs + flwoutn(i,j) & - + fsensn(i,j) + flatn(i,j) + fsurfn(i,j) = fswsfc(i,j) + flwdabs + flwoutn(i,j) & + + fsensn(i,j) + flatn(i,j) dfsurf_dT(ij) = dflwout_dT(m) & + dfsens_dT(m) + dflat_dT(m) @@ -2166,13 +2315,14 @@ subroutine get_matrix_elements (nx_block, ny_block, & indxii, indxjj, indxij, & l_snow, l_cold, & Tsf, Tbot, & - fsurf, dfsurf_dT, & + fsurfn, dfsurf_dT, & Tin_init, Tsn_init, & kh, Sswabs, & Iswabs, & etai, etas, & sbdiag, diag, & - spdiag, rhs) + spdiag, rhs, & + fcondtopn) ! ! !USES: ! @@ -2197,10 +2347,10 @@ subroutine get_matrix_elements (nx_block, ny_block, & l_cold ! true if surface temperature is computed real (kind=dbl_kind), dimension (icells), intent(in) :: & - Tsf , & ! ice/snow top surface temp (deg C) - fsurf ! net flux to top surface, not including fcondtop + Tsf ! ice/snow top surface temp (deg C) real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & + fsurfn , & ! net flux to top surface, excluding fcondtopn (W/m^2) Tbot ! ice bottom surface temperature (deg C) real (kind=dbl_kind), dimension (isolve), intent(in) :: & @@ -2238,6 +2388,10 @@ subroutine get_matrix_elements (nx_block, ny_block, & diag , & ! diagonal matrix elements spdiag , & ! super-diagonal matrix elements rhs ! rhs of tri-diagonal matrix eqn. + + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in), & + optional :: & + fcondtopn ! conductive flux at top sfc, positive down (W/m^2) ! !EOP ! @@ -2272,28 +2426,59 @@ subroutine get_matrix_elements (nx_block, ny_block, & ! (4) Melting surface (Tsf = 0), no snow !----------------------------------------------------------------- - do ij = 1, isolve - i = indxii(ij) - j = indxjj(ij) - m = indxij(ij) + if (calc_Tsfc) then + + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) !----------------------------------------------------------------- ! Tsf equation for case of cold surface (with or without snow) !----------------------------------------------------------------- - if (l_cold(m)) then - if (l_snow(m)) then - k = 1 - else ! no snow - k = 1 + nslyr - endif - kr = k + if (l_cold(m)) then + if (l_snow(m)) then + k = 1 + else ! no snow + k = 1 + nslyr + endif + kr = k - sbdiag(ij,kr) = c0 - diag (ij,kr) = dfsurf_dT(ij) - kh(m,k) - spdiag(ij,kr) = kh(m,k) - rhs (ij,kr) = dfsurf_dT(ij)*Tsf(m) - fsurf(m) + sbdiag(ij,kr) = c0 + diag (ij,kr) = dfsurf_dT(ij) - kh(m,k) + spdiag(ij,kr) = kh(m,k) + rhs (ij,kr) = dfsurf_dT(ij)*Tsf(m) - fsurfn(i,j) + + endif ! l_cold + + !----------------------------------------------------------------- + ! top snow layer + !----------------------------------------------------------------- +! k = 1 +! kr = 2 - endif ! l_cold + if (l_snow(m)) then + if (l_cold(m)) then + sbdiag(ij,2) = -etas(m,1) * kh(m,1) + spdiag(ij,2) = -etas(m,1) * kh(m,2) + diag (ij,2) = c1 & + + etas(m,1) * (kh(m,1) + kh(m,2)) + rhs (ij,2) = Tsn_init(m,1) & + + etas(m,1) * Sswabs(i,j,1) + else ! melting surface + sbdiag(ij,2) = c0 + spdiag(ij,2) = -etas(m,1) * kh(m,2) + diag (ij,2) = c1 & + + etas(m,1) * (kh(m,1) + kh(m,2)) + rhs (ij,2) = Tsn_init(m,1) & + + etas(m,1)*kh(m,1)*Tsf(m) & + + etas(m,1) * Sswabs(i,j,1) + endif ! l_cold + endif ! l_snow + + enddo ! ij + + else ! calc_Tsfc = F !----------------------------------------------------------------- ! top snow layer @@ -2301,26 +2486,23 @@ subroutine get_matrix_elements (nx_block, ny_block, & ! k = 1 ! kr = 2 - if (l_snow(m)) then - if (l_cold(m)) then - sbdiag(ij,2) = -etas(m,1) * kh(m,1) - spdiag(ij,2) = -etas(m,1) * kh(m,2) - diag (ij,2) = c1 & - + etas(m,1) * (kh(m,1) + kh(m,2)) - rhs (ij,2) = Tsn_init(m,1) & - + etas(m,1) * Sswabs(i,j,1) - else ! melting surface + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + if (l_snow(m)) then sbdiag(ij,2) = c0 spdiag(ij,2) = -etas(m,1) * kh(m,2) - diag (ij,2) = c1 & - + etas(m,1) * (kh(m,1) + kh(m,2)) - rhs (ij,2) = Tsn_init(m,1) & - + etas(m,1)*kh(m,1)*Tsf(m) & - + etas(m,1) * Sswabs(i,j,1) - endif ! l_cold - endif ! l_snow + diag (ij,2) = c1 & + + etas(m,1) * kh(m,2) + rhs (ij,2) = Tsn_init(m,1) & + + etas(m,1) * Sswabs(i,j,1) & + + etas(m,1) * fcondtopn(i,j) + endif ! l_snow + enddo ! ij - enddo ! ij + endif ! calc_Tsfc !----------------------------------------------------------------- ! remaining snow layers @@ -2352,44 +2534,80 @@ subroutine get_matrix_elements (nx_block, ny_block, & if (nilyr > 1) then - do ij = 1, isolve - i = indxii(ij) - j = indxjj(ij) - m = indxij(ij) - !----------------------------------------------------------------- ! top ice layer !----------------------------------------------------------------- - ki = 1 - k = ki + nslyr - kr = k + 1 + ki = 1 + k = ki + nslyr + kr = k + 1 - if (l_snow(m) .or. l_cold(m)) then - sbdiag(ij,kr) = -etai(ij,ki) * kh(m,k) - spdiag(ij,kr) = -etai(ij,ki) * kh(m,k+1) - diag (ij,kr) = c1 & - + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) - rhs (ij,kr) = Tin_init(m,ki) & - + etai(ij,ki)*Iswabs(i,j,ki) - else ! no snow, warm surface - sbdiag(ij,kr) = c0 - spdiag(ij,kr) = -etai(ij,ki) * kh(m,k+1) - diag (ij,kr) = c1 & - + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) - rhs (ij,kr) = Tin_init(m,ki) & - + etai(ij,ki)*Iswabs(i,j,ki) & - + etai(ij,ki)*kh(m,k)*Tsf(m) - endif + if (calc_Tsfc) then + + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + if (l_snow(m) .or. l_cold(m)) then + sbdiag(ij,kr) = -etai(ij,ki) * kh(m,k) + spdiag(ij,kr) = -etai(ij,ki) * kh(m,k+1) + diag (ij,kr) = c1 & + + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki)*Iswabs(i,j,ki) + else ! no snow, warm surface + sbdiag(ij,kr) = c0 + spdiag(ij,kr) = -etai(ij,ki) * kh(m,k+1) + diag (ij,kr) = c1 & + + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki)*Iswabs(i,j,ki) & + + etai(ij,ki)*kh(m,k)*Tsf(m) + endif + + enddo ! ij + + else ! calc_Tsfc = F + + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + if (l_snow(m)) then + sbdiag(ij,kr) = -etai(ij,ki) * kh(m,k) + spdiag(ij,kr) = -etai(ij,ki) * kh(m,k+1) + diag (ij,kr) = c1 & + + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki) * Iswabs(i,j,ki) + else + sbdiag(ij,kr) = c0 + spdiag(ij,kr) = -etai(ij,ki) * kh(m,k+1) + diag (ij,kr) = c1 & + + etai(ij,ki) * kh(m,k+1) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki) * Iswabs(i,j,ki) & + + etai(ij,ki) * fcondtopn(i,j) + endif ! l_snow + enddo ! ij + + endif ! calc_Tsfc + !----------------------------------------------------------------- ! bottom ice layer !----------------------------------------------------------------- - ki = nilyr - k = ki + nslyr - kr = k + 1 + ki = nilyr + k = ki + nslyr + kr = k + 1 + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) sbdiag(ij,kr) = -etai(ij,ki) * kh(m,k) spdiag(ij,kr) = c0 diag (ij,kr) = c1 & @@ -2410,30 +2628,61 @@ subroutine get_matrix_elements (nx_block, ny_block, & k = ki + nslyr kr = k + 1 - do ij = 1, isolve - i = indxii(ij) - j = indxjj(ij) - m = indxij(ij) + if (calc_Tsfc) then - if (l_snow(m) .or. l_cold(m)) then - sbdiag(ij,kr) = -etai(ij,ki) * kh(m,k) - spdiag(ij,kr) = c0 - diag (ij,kr) = c1 & - + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) - rhs (ij,kr) = Tin_init(m,ki) & - + etai(ij,ki) * Iswabs(i,j,ki) & - + etai(ij,ki) * kh(m,k+1)*Tbot(i,j) - else ! no snow, warm surface - sbdiag(ij,kr) = c0 - spdiag(ij,kr) = c0 - diag (ij,kr) = c1 & - + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) - rhs (ij,kr) = Tin_init(m,ki) & - + etai(ij,ki) * Iswabs(i,j,ki) & - + etai(ij,ki) * kh(m,k)*Tsf(m) & - + etai(ij,ki) * kh(m,k+1)*Tbot(i,j) - endif - enddo ! ij + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + if (l_snow(m) .or. l_cold(m)) then + sbdiag(ij,kr) = -etai(ij,ki) * kh(m,k) + spdiag(ij,kr) = c0 + diag (ij,kr) = c1 & + + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki) * Iswabs(i,j,ki) & + + etai(ij,ki) * kh(m,k+1)*Tbot(i,j) + else ! no snow, warm surface + sbdiag(ij,kr) = c0 + spdiag(ij,kr) = c0 + diag (ij,kr) = c1 & + + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki) * Iswabs(i,j,ki) & + + etai(ij,ki) * kh(m,k)*Tsf(m) & + + etai(ij,ki) * kh(m,k+1)*Tbot(i,j) + endif + enddo ! ij + + else ! calc_Tsfc = F + + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + if (l_snow(m)) then + sbdiag(ij,kr) = -etai(ij,ki) * kh(m,k) + spdiag(ij,kr) = c0 + diag (ij,kr) = c1 & + + etai(ij,ki) * (kh(m,k) + kh(m,k+1)) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki) * Iswabs(i,j,ki) & + + etai(ij,ki) * kh(m,k+1)*Tbot(i,j) + else + sbdiag(ij,kr) = c0 + spdiag(ij,kr) = c0 + diag (ij,kr) = c1 & + + etai(ij,ki) * kh(m,k+1) + rhs (ij,kr) = Tin_init(m,ki) & + + etai(ij,ki) * Iswabs(i,j,ki) & + + etai(ij,ki) * fcondtopn(i,j) & + + etai(ij,ki) * kh(m,k+1)*Tbot(i,j) + endif + enddo ! ij + + endif ! calc_Tsfc endif ! nilyr > 1 @@ -2560,37 +2809,40 @@ end subroutine tridiag_solver !======================================================================= !BOP ! -! !ROUTINE: thickness changes - top and bottom growth/melting +! !ROUTINE: zerolayer_temperature - new surface temperature calculation ! ! !DESCRIPTION: ! -! Compute growth and/or melting at the top and bottom surfaces. -! Convert snow to ice if necessary. +! Compute new surface temperature using zero layer model of Semtner +! (1976). +! +! New temperatures are computed iteratively by solving a +! surface flux balance equation (i.e. net surface flux from atmos +! equals conductive flux from the top to the bottom surface). ! ! !REVISION HISTORY: ! -! authors William H. Lipscomb, LANL -! C. M. Bitz, UW +! author: Alison McLaren, Met Office +! (but largely taken from temperature_changes) ! ! !INTERFACE: ! - subroutine thickness_changes (nx_block, ny_block, & - dt, & - yday, icells, & - indxi, indxj, & - aicen, efinal, & - hin, hilyr, & - hsn, hslyr, & - qin, qsn, & - fbot, Tbot, & - flatn, fsurf, & - fcondtop, fcondbot, & - fsnow, hsn_new, & - fhocnn, evapn, & - meltt, melts, & - meltb, iage, & - congel, snoice, & - mlt_onset, frz_onset) + subroutine zerolayer_temperature(nx_block, ny_block, & + my_task, istep1, & + dt, icells, & + indxi, indxj, & + rhoa, flw, & + potT, Qa, & + shcoef, lhcoef, & + fswsfc, fswthrun, & + hilyr, hslyr, & + Tsf, Tbot, & + fsensn, flatn, & + fswabsn, flwoutn, & + fsurfn, & + fcondtopn,fcondbot, & + l_stop, & + istop, jstop) ! ! !USES: ! @@ -2598,27 +2850,482 @@ subroutine thickness_changes (nx_block, ny_block, & ! integer (kind=int_kind), intent(in) :: & nx_block, ny_block, & ! block dimensions + my_task , & ! task number (diagnostic only) + istep1 , & ! time step index (diagnostic only) icells ! number of cells with aicen > puny + real (kind=dbl_kind), intent(in) :: & + dt ! time step + integer (kind=int_kind), dimension(nx_block*ny_block), & intent(in) :: & indxi, indxj ! compressed indices for cells with aicen > puny - real (kind=dbl_kind), intent(in) :: & - dt , & ! time step - yday ! day of the year - real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & - aicen , & ! fractional concentration of ice - fbot , & ! ice-ocean heat flux at bottom surface (W/m^2) + rhoa , & ! air density (kg/m^3) + flw , & ! incoming longwave radiation (W/m^2) + potT , & ! air potential temperature (K) + Qa , & ! specific humidity (kg/kg) + shcoef , & ! transfer coefficient for sensible heat + lhcoef , & ! transfer coefficient for latent heat Tbot , & ! ice bottom surface temperature (deg C) - fsnow , & ! snowfall rate (kg m-2 s-1) - flatn ! surface downward latent heat (W m-2) + fswsfc , & ! SW absorbed at ice/snow surface (W m-2) + fswthrun ! SW through ice to ocean (W m-2) real (kind=dbl_kind), dimension (icells), intent(in) :: & - fsurf , & ! net flux to top surface, not including fcondtop - fcondtop , & ! downward cond flux at top surface (W m-2) - fcondbot ! downward cond flux at bottom surface (W m-2) + hilyr , & ! ice layer thickness (m) + hslyr ! snow layer thickness (m) + + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out):: & + fsensn , & ! surface downward sensible heat (W m-2) + fswabsn , & ! shortwave flux absorbed by ice (W/m-2) + flatn , & ! surface downward latent heat (W m-2) + flwoutn , & ! upward LW at surface (W m-2) + fsurfn , & ! net flux to top surface, excluding fcondtopn + fcondtopn ! downward cond flux at top surface (W m-2) + + real (kind=dbl_kind), dimension (icells), intent(out):: & + fcondbot ! downward cond flux at bottom surface (W m-2) + + real (kind=dbl_kind), dimension (icells), & + intent(inout):: & + Tsf ! ice/snow surface temperature, Tsfcn + + logical (kind=log_kind), intent(inout) :: & + l_stop ! if true, print diagnostics and abort model + + integer (kind=int_kind), intent(inout) :: & + istop, jstop ! i and j indices of cell where model fails +! +!EOP +! + logical (kind=log_kind), parameter :: & + l_zerolayerchecks = .true. + + integer (kind=int_kind), parameter :: & + nitermax = 50 ! max number of iterations in temperature solver + + real (kind=dbl_kind), parameter :: & + Tsf_errmax = 5.e-4_dbl_kind ! max allowed error in Tsf + ! recommend Tsf_errmax < 0.01 K + + integer (kind=int_kind) :: & + i, j , & ! horizontal indices + ij, m , & ! horizontal indices, combine i and j loops + niter ! iteration counter in temperature solver + + integer (kind=int_kind) :: & + isolve ! number of cells with temps not converged + + integer (kind=int_kind), dimension (icells) :: & + indxii, indxjj ! compressed indices for cells not converged + + integer (kind=int_kind), dimension (icells) :: & + indxij ! compressed 1D index for cells not converged + + real (kind=dbl_kind), dimension (:), allocatable :: & + Tsf_start , & ! Tsf at start of iteration + dTsf , & ! Tsf - Tsf_start + dfsurf_dT ! derivative of fsurfn wrt Tsf + + real (kind=dbl_kind), dimension (icells) :: & + dTsf_prev , & ! dTsf from previous iteration + dfsens_dT , & ! deriv of fsens wrt Tsf (W m-2 deg-1) + dflat_dT , & ! deriv of flat wrt Tsf (W m-2 deg-1) + dflwout_dT ! deriv of flwout wrt Tsf (W m-2 deg-1) + + real (kind=dbl_kind), dimension (:), allocatable :: & + heff , & ! effective ice thickness (m) + ! ( hice + hsno*kseaice/ksnow) + kh , & ! effective conductivity + diag , & ! diagonal matrix elements + rhs ! rhs of tri-diagonal matrix equation + + real (kind=dbl_kind) :: & + kratio , & ! ratio of ice and snow conductivies + avg_Tsf ! = 1. if Tsf averaged w/Tsf_start, else = 0. + + logical (kind=log_kind), dimension (icells) :: & + converged ! = true when local solution has converged + + logical (kind=log_kind) :: & + all_converged ! = true when all cells have converged + + !----------------------------------------------------------------- + ! Initialize + !----------------------------------------------------------------- + + all_converged = .false. + + do ij = 1, icells + fcondbot(ij) = c0 + + converged (ij) = .false. + + dTsf_prev (ij) = c0 + + enddo ! ij + + !----------------------------------------------------------------- + ! Solve for new temperatures. + ! Iterate until temperatures converge with minimal temperature + ! change. + !----------------------------------------------------------------- + + do niter = 1, nitermax + + if (all_converged) then ! thermo calculation is done + exit + else ! identify cells not yet converged + isolve = 0 + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (.not.converged(ij)) then + isolve = isolve + 1 + indxii(isolve) = i + indxjj(isolve) = j + indxij(isolve) = ij + endif + enddo ! ij + endif + + allocate( diag(isolve)) + allocate( rhs(isolve)) + allocate( kh(isolve)) + allocate( heff(isolve)) + allocate(Tsf_start(isolve)) + allocate( dTsf(isolve)) + allocate(dfsurf_dT(isolve)) + + !----------------------------------------------------------------- + ! Update radiative and turbulent fluxes and their derivatives + ! with respect to Tsf. + !----------------------------------------------------------------- + + call surface_fluxes (nx_block, ny_block, & + isolve, icells, & + indxii, indxjj, indxij, & + Tsf, fswsfc, & + rhoa, flw, & + potT, Qa, & + shcoef, lhcoef, & + flwoutn, fsensn, & + flatn, fsurfn, & + dflwout_dT, dfsens_dT, & + dflat_dT, dfsurf_dT) + + !----------------------------------------------------------------- + ! Compute effective ice thickness (includes snow) and thermal + ! conductivity + !----------------------------------------------------------------- + + kratio = kseaice/ksno + + do ij = 1, isolve + m = indxij(ij) + + heff(ij) = hilyr(m) + kratio * hslyr(m) + kh(ij) = kseaice / heff(ij) + enddo ! ij + + +!DIR$ CONCURRENT !Cray +!cdir nodep !NEC +!ocl novrec !Fujitsu + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + !----------------------------------------------------------------- + ! Compute conductive flux at top surface, fcondtopn. + ! If fsurfn < fcondtopn and Tsf = 0, then reset Tsf to slightly less + ! than zero (but not less than -puny). + !----------------------------------------------------------------- + + fcondtopn(i,j) = kh(ij) * (Tsf(m) - Tbot(i,j)) + + if (fsurfn(i,j) < fcondtopn(i,j)) & + Tsf(m) = min (Tsf(m), -puny) + + !----------------------------------------------------------------- + ! Save surface temperature at start of iteration + !----------------------------------------------------------------- + + Tsf_start(ij) = Tsf(m) + + enddo ! ij + + !----------------------------------------------------------------- + ! Solve surface balance equation to obtain the new temperatures. + !----------------------------------------------------------------- + + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + diag(ij) = dfsurf_dT(ij) - kh(ij) + rhs(ij) = dfsurf_dT(ij)*Tsf(m) - fsurfn(i,j) & + - kh(ij)*Tbot(i,j) + Tsf(m) = rhs(ij) / diag(ij) + + enddo + + !----------------------------------------------------------------- + ! Determine whether the computation has converged to an acceptable + ! solution. Four conditions must be satisfied: + ! + ! (1) Tsf <= 0 C. + ! (2) Tsf is not oscillating; i.e., if both dTsf(niter) and + ! dTsf(niter-1) have magnitudes greater than puny, then + ! dTsf(niter)/dTsf(niter-1) cannot be a negative number + ! with magnitude greater than 0.5. + ! (3) abs(dTsf) < Tsf_errmax + ! (4) If Tsf = 0 C, then the downward turbulent/radiative + ! flux, fsurfn, must be greater than or equal to the downward + ! conductive flux, fcondtopn. + !----------------------------------------------------------------- + + ! initialize global convergence flag + all_converged = .true. + +!DIR$ CONCURRENT !Cray +!cdir nodep !NEC +!ocl novrec !Fujitsu + do ij = 1, isolve + m = indxij(ij) + + !----------------------------------------------------------------- + ! Initialize convergence flag (true until proven false), dTsf, + ! and temperature-averaging coefficients. + ! Average only if test 1 or 2 fails. + ! Initialize energy. + !----------------------------------------------------------------- + + converged(m) = .true. + dTsf(ij) = Tsf(m) - Tsf_start(ij) + avg_Tsf = c0 + + !----------------------------------------------------------------- + ! Condition 1: check for Tsf > 0 + ! If Tsf > 0, set Tsf = 0 and leave converged=.true. + !----------------------------------------------------------------- + + if (Tsf(m) > puny) then + Tsf(m) = c0 + dTsf(ij) = -Tsf_start(ij) + + !----------------------------------------------------------------- + ! Condition 2: check for oscillating Tsf + ! If oscillating, average all temps to increase rate of convergence. + ! It is possible that this may never occur. + !----------------------------------------------------------------- + + elseif (niter > 1 & ! condition (2) + .and. Tsf_start(ij) <= -puny & + .and. abs(dTsf(ij)) > puny & + .and. abs(dTsf_prev(m)) > puny & + .and. -dTsf(ij)/(dTsf_prev(m)+puny*puny) > p5) then + + avg_Tsf = c1 ! average with starting temp + dTsf(ij) = p5 * dTsf(ij) + converged(m) = .false. + all_converged = .false. + endif + + !----------------------------------------------------------------- + ! If condition 2 failed, average new surface temperature with + ! starting value. + !----------------------------------------------------------------- + Tsf(m) = Tsf(m) & + + avg_Tsf * p5 * (Tsf_start(ij) - Tsf(m)) + + enddo ! ij + +!DIR$ CONCURRENT !Cray +!cdir nodep !NEC +!ocl novrec !Fujitsu + do ij = 1, isolve + i = indxii(ij) + j = indxjj(ij) + m = indxij(ij) + + !----------------------------------------------------------------- + ! Condition 3: check for large change in Tsf + !----------------------------------------------------------------- + + if (abs(dTsf(ij)) > Tsf_errmax) then + converged(m) = .false. + all_converged = .false. + endif + + !----------------------------------------------------------------- + ! Condition 4: check for fsurfn < fcondtopn with Tsf > 0 + !----------------------------------------------------------------- + + fsurfn(i,j) = fsurfn(i,j) + dTsf(ij)*dfsurf_dT(ij) + fcondtopn(i,j) = kh(ij) * (Tsf(m)-Tbot(i,j)) + + if (Tsf(m) > -puny .and. fsurfn(i,j) < fcondtopn(i,j)) then + converged(m) = .false. + all_converged = .false. + endif + + fcondbot(m) = fcondtopn(i,j) + + dTsf_prev(m) = dTsf(ij) + + enddo ! ij + + deallocate(diag) + deallocate(rhs) + deallocate(kh) + deallocate(heff) + deallocate(Tsf_start) + deallocate(dTsf) + deallocate(dfsurf_dT) + + enddo ! temperature iteration niter + + if (.not.all_converged) then + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + !----------------------------------------------------------------- + ! Check for convergence failures. + !----------------------------------------------------------------- + if (.not.converged(ij)) then + write(nu_diag,*) 'Thermo iteration does not converge,', & + 'istep1, my_task, i, j:', & + istep1, my_task, i, j + write(nu_diag,*) 'Ice thickness:', hilyr(ij)*nilyr + write(nu_diag,*) 'Snow thickness:', hslyr(ij)*nslyr + write(nu_diag,*) 'dTsf, Tsf_errmax:',dTsf_prev(ij), & + Tsf_errmax + write(nu_diag,*) 'Tsf:', Tsf(ij) + write(nu_diag,*) 'fsurfn:', fsurfn(i,j) + write(nu_diag,*) 'fcondtopn, fcondbot', & + fcondtopn(i,j), fcondbot(ij) + l_stop = .true. + istop = i + jstop = j + return + endif + enddo ! ij + endif ! all_converged + + !----------------------------------------------------------------- + ! Check that if Tsfc < 0, then fcondtopn = fsurfn + !----------------------------------------------------------------- + + if (l_zerolayerchecks) then + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + if (Tsf(ij) < c0 .and. & + abs(fcondtopn(i,j)-fsurfn(i,j)) > puny) then + + write(nu_diag,*) 'fcondtopn does not equal fsurfn,', & + 'istep1, my_task, i, j:', & + istep1, my_task, i, j + write(nu_diag,*) 'Tsf=',Tsf(ij) + write(nu_diag,*) 'fcondtopn=',fcondtopn(i,j) + write(nu_diag,*) 'fsurfn=',fsurfn(i,j) + l_stop = .true. + istop = i + jstop = j + return + endif + enddo ! ij + endif ! l_zerolayerchecks + + +!DIR$ CONCURRENT !Cray +!cdir nodep !NEC +!ocl novrec !Fujitsu + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + ! update fluxes that depend on Tsf + flwoutn(i,j) = flwoutn(i,j) + dTsf_prev(ij) * dflwout_dT(ij) + fsensn(i,j) = fsensn(i,j) + dTsf_prev(ij) * dfsens_dT(ij) + flatn(i,j) = flatn(i,j) + dTsf_prev(ij) * dflat_dT(ij) + + ! absorbed shortwave flux for coupler + fswabsn(i,j) = fswsfc(i,j) + fswthrun(i,j) + + enddo ! ij + + end subroutine zerolayer_temperature + +!======================================================================= +!BOP +! +! !ROUTINE: thickness changes - top and bottom growth/melting +! +! !DESCRIPTION: +! +! Compute growth and/or melting at the top and bottom surfaces. +! Convert snow to ice if necessary. +! +! !REVISION HISTORY: +! +! authors William H. Lipscomb, LANL +! C. M. Bitz, UW +! +! !INTERFACE: +! + subroutine thickness_changes (nx_block, ny_block, & + dt, & + yday, icells, & + indxi, indxj, & + aicen, efinal, & + hin, hilyr, & + hsn, hslyr, & + qin, qsn, & + fbot, Tbot, & + flatn, fsurfn, & + fcondtopn, fcondbot, & + fsnow, hsn_new, & + fhocnn, evapn, & + meltt, melts, & + meltb, iage, & + congel, snoice, & + mlt_onset, frz_onset) +! +! !USES: +! +! !INPUT/OUTPUT PARAMETERS: +! + integer (kind=int_kind), intent(in) :: & + nx_block, ny_block, & ! block dimensions + icells ! number of cells with aicen > puny + + integer (kind=int_kind), dimension(nx_block*ny_block), & + intent(in) :: & + indxi, indxj ! compressed indices for cells with aicen > puny + + real (kind=dbl_kind), intent(in) :: & + dt , & ! time step + yday ! day of the year + + real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & + aicen , & ! fractional concentration of ice + fbot , & ! ice-ocean heat flux at bottom surface (W/m^2) + Tbot , & ! ice bottom surface temperature (deg C) + fsnow , & ! snowfall rate (kg m-2 s-1) + flatn , & ! surface downward latent heat (W m-2) + fsurfn , & ! net flux to top surface, excluding fcondtopn + fcondtopn ! downward cond flux at top surface (W m-2) + + real (kind=dbl_kind), dimension (icells), intent(in) :: & + fcondbot ! downward cond flux at bottom surface (W m-2) real (kind=dbl_kind), dimension (icells,nilyr), & intent(inout) :: & @@ -2773,7 +3480,7 @@ subroutine thickness_changes (nx_block, ny_block, & esub(ij) = max(wk1, c0) ! energy for sublimation, > 0 econ(ij) = min(wk1, c0) ! energy for condensation, < 0 - wk1 = (fsurf(ij) - fcondtop(ij)) * dt + wk1 = (fsurfn(i,j) - fcondtopn(i,j)) * dt etop_mlt(ij) = max(wk1, c0) ! etop_mlt > 0 wk1 = (fcondbot(ij) - fbot(i,j)) * dt @@ -2802,10 +3509,15 @@ subroutine thickness_changes (nx_block, ny_block, & !-------------------------------------------------------------- ! enthalpy of new ice growing at bottom surface - qbot = -rhoi * (cp_ice * (Tmlt(nilyr+1)-Tbot(i,j)) & - + Lfresh * (c1-Tmlt(nilyr+1)/Tbot(i,j)) & - - cp_ocn * Tmlt(nilyr+1)) - qbot = min (qbot, qbotmax) ! in case Tbot is close to Tmlt + if (heat_capacity) then + qbot = -rhoi * (cp_ice * (Tmlt(nilyr+1)-Tbot(i,j)) & + + Lfresh * (c1-Tmlt(nilyr+1)/Tbot(i,j)) & + - cp_ocn * Tmlt(nilyr+1)) + qbot = min (qbot, qbotmax) ! in case Tbot is close to Tmlt + else ! zero layer + qbot = -rhoi * Lfresh + endif + dhi = ebot_gro(ij) / qbot ! dhi > 0 hqtot = dzi(ij,nilyr)*qin(ij,nilyr) + dhi*qbot @@ -3033,14 +3745,13 @@ subroutine thickness_changes (nx_block, ny_block, & !----------------------------------------------------------------- do ij = 1, icells - + if (hin(ij) > c0) then hilyr(ij) = hin(ij) / real(nilyr,kind=dbl_kind) else hin(ij) = c0 hilyr(ij) = c0 endif - if (hsn(ij) > c0) then hslyr(ij) = hsn(ij) / real(nslyr,kind=dbl_kind) else @@ -3055,32 +3766,43 @@ subroutine thickness_changes (nx_block, ny_block, & zi1(ij,1) = c0 zi1(ij,1+nilyr) = hin(ij) - + zi2(ij,1) = c0 zi2(ij,1+nilyr) = hin(ij) enddo ! ij - do k = 1, nilyr-1 + if (heat_capacity) then + + do k = 1, nilyr-1 !DIR$ CONCURRENT !Cray !cdir nodep !NEC !ocl novrec !Fujitsu - do ij = 1, icells - zi1(ij,k+1) = zi1(ij,k) + dzi(ij,k) - zi2(ij,k+1) = zi2(ij,k) + hilyr(ij) - end do - enddo + do ij = 1, icells + zi1(ij,k+1) = zi1(ij,k) + dzi(ij,k) + zi2(ij,k+1) = zi2(ij,k) + hilyr(ij) + end do + enddo - !----------------------------------------------------------------- - ! Conserving energy, compute the enthalpy of the new equal layers. - !----------------------------------------------------------------- + !----------------------------------------------------------------- + ! Conserving energy, compute the enthalpy of the new equal layers. + !----------------------------------------------------------------- - call adjust_enthalpy (nx_block, ny_block, & - nilyr, icells, & - indxi, indxj, & - zi1, zi2, & - hilyr, hin, & - qin) + call adjust_enthalpy (nx_block, ny_block, & + nilyr, icells, & + indxi, indxj, & + zi1, zi2, & + hilyr, hin, & + qin) + + else ! zero layer (nilyr=1) + + do ij = 1, icells + qin(ij,1) = -rhoi * Lfresh + qsn(ij,1) = -rhos * Lfresh + end do + + endif if (nslyr > 1) then @@ -3214,7 +3936,7 @@ subroutine freeboard (nx_block, ny_block, & real (kind=dbl_kind), dimension (icells,nilyr), & intent(inout) :: & - dzi ! ice layer thicknesses (m) + dzi ! ice layer thicknesses (m) real (kind=dbl_kind), dimension (icells,nslyr), & intent(in) :: & @@ -3444,7 +4166,7 @@ subroutine conservation_check_vthermo(nx_block, ny_block, & my_task, istep1, & dt, icells, & indxi, indxj, & - fsurf, flatn, & + fsurfn, flatn, & fhocnn, fswint, & fsnow, & einit, efinal, & @@ -3469,13 +4191,14 @@ subroutine conservation_check_vthermo(nx_block, ny_block, & dt ! time step real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & + fsurfn , & ! net flux to top surface, excluding fcondtopn flatn , & ! surface downward latent heat (W m-2) fhocnn , & ! fbot, corrected for any surplus energy fswint , & ! SW absorbed in ice interior, below surface (W m-2) fsnow ! snowfall rate (kg m-2 s-1) + real (kind=dbl_kind), dimension (icells), intent(in) :: & - fsurf , & ! net flux to top surface, not including fcondtop einit , & ! initial energy of melting (J m-2) efinal ! final energy of melting (J m-2) @@ -3505,7 +4228,7 @@ subroutine conservation_check_vthermo(nx_block, ny_block, & i = indxi(ij) j = indxj(ij) - einp = (fsurf(ij) - flatn(i,j) + fswint(i,j) - fhocnn(i,j) & + einp = (fsurfn(i,j) - flatn(i,j) + fswint(i,j) - fhocnn(i,j) & - fsnow(i,j)*Lfresh) * dt ferr = abs(efinal(ij)-einit(ij)-einp) / dt if (ferr > ferrmax) then @@ -3520,9 +4243,9 @@ subroutine conservation_check_vthermo(nx_block, ny_block, & ! heat lost by the ice is equal to that gained by the vapor. !----------------------------------------------------------------- - einp = (fsurf(ij) - flatn(i,j) + fswint(i,j) - fhocnn(i,j) & - -fsnow(i,j)*Lfresh) * dt - ferr = abs(efinal(ij)-einit(ij)-einp) / dt +! einp = (fsurfn(i,j) - flatn(i,j) + fswint(i,j) - fhocnn(i,j) & +! -fsnow(i,j)*Lfresh) * dt +! ferr = abs(efinal(ij)-einit(ij)-einp) / dt write(nu_diag,*) 'Thermo energy conservation error' write(nu_diag,*) 'istep1, my_task, i, j:', & diff --git a/cice/source/ice_work.F90 b/cice/source/ice_work.F90 index b232687..d2022b0 100644 --- a/cice/source/ice_work.F90 +++ b/cice/source/ice_work.F90 @@ -35,7 +35,8 @@ module ice_work real (kind=dbl_kind), dimension(:,:), allocatable :: & work_g1, & - work_g2 + work_g2, & + work_g3 real (kind=real_kind), dimension(:,:), allocatable :: & work_gr