diff --git a/.gitmodules b/.gitmodules index d002c037a1d9..cf0fa15d63ac 100644 --- a/.gitmodules +++ b/.gitmodules @@ -55,6 +55,9 @@ [submodule "externals/mct"] path = externals/mct url = git@github.com:MCSclimate/MCT.git +[submodule "components/mpas-albany-landice/src/SeaLevelModel"] + path = components/mpas-albany-landice/src/SeaLevelModel + url = git@github.com:MALI-Dev/1DSeaLevelModel_FWTW.git [submodule "components/mpas-ocean/src/SHTNS"] path = components/mpas-ocean/src/SHTNS url = https://bitbucket.org/nschaeff/shtns.git diff --git a/cime_config/allactive/config_pesall.xml b/cime_config/allactive/config_pesall.xml index d907bc4ed57e..64a952cc781e 100644 --- a/cime_config/allactive/config_pesall.xml +++ b/cime_config/allactive/config_pesall.xml @@ -1225,16 +1225,16 @@ anvil: --compset BGC* --res ne30pg2_r05_EC30to60E2r2 on 30 nodes pure-MPI, ~3 sypd 675 - 144 - 144 - 540 + 684 + 684 + 684 396 684 0 - 540 - 540 + 0 + 0 0 684 0 diff --git a/cime_config/machines/config_machines.xml b/cime_config/machines/config_machines.xml index 96e66b94a0af..fbc336a6ced5 100644 --- a/cime_config/machines/config_machines.xml +++ b/cime_config/machines/config_machines.xml @@ -453,7 +453,7 @@ PrgEnv-gnu/8.3.3 - gcc/11.2.0 + gcc/12.1.0 @@ -470,10 +470,10 @@ craype-accel-host cray-libsci craype - cray-mpich/8.1.17 - cray-hdf5-parallel/1.12.1.5 - cray-netcdf-hdf5parallel/4.8.1.5 - cray-parallel-netcdf/1.12.2.5 + cray-mpich/8.1.22 + cray-hdf5-parallel/1.12.2.1 + cray-netcdf-hdf5parallel/4.9.0.1 + cray-parallel-netcdf/1.12.3.1 cmake/3.22.0 @@ -491,6 +491,7 @@ FALSE /global/cfs/cdirs/e3sm/perl/lib/perl5-only-switch software + MPI_Bcast -1 @@ -584,8 +585,8 @@ CNL gnu,crayclang,amdclang mpich - cli133 - /gpfs/alpine/$PROJECT/proj-shared/$ENV{USER}/e3sm_scratch/crusher + cli133_crusher + /gpfs/alpine/cli133/proj-shared/$ENV{USER}/e3sm_scratch/crusher /gpfs/alpine/cli115/world-shared/e3sm/inputdata /gpfs/alpine/cli115/world-shared/e3sm/inputdata/atm/datm7 $CIME_OUTPUT_ROOT/archive/$CASE @@ -4284,6 +4285,8 @@ $CIME_OUTPUT_ROOT/$CASE/run $CIME_OUTPUT_ROOT/$CASE/bld + 0.2 + 0.20 $SHELL{dirname $(dirname $(which h5diff))} $SHELL{dirname $(dirname $(which nc-config))} diff --git a/cime_config/tests.py b/cime_config/tests.py index 0140e62ea810..83dcb68cdc04 100644 --- a/cime_config/tests.py +++ b/cime_config/tests.py @@ -17,6 +17,7 @@ "ERS.r05_r05.RMOSGPCC.mosart-gpcc_1972", "ERS.MOS_USRDAT.RMOSGPCC.mosart-mos_usrdat", "SMS.MOS_USRDAT.RMOSGPCC.mosart-unstructure", + "ERS.r05_r05.RMOSGPCC.mosart-heat", ) }, diff --git a/components/data_comps/drof/cime_config/config_component.xml b/components/data_comps/drof/cime_config/config_component.xml index 0d0ba1b2d54b..9052da1c75e3 100644 --- a/components/data_comps/drof/cime_config/config_component.xml +++ b/components/data_comps/drof/cime_config/config_component.xml @@ -13,7 +13,7 @@ --> - Data runoff model + Data runoff model NULL mode COREv2 normal year forcing: COREv2 interannual year forcing: @@ -22,6 +22,7 @@ COREv2 interannual year forcing: CPLHIST mode: JRA55 interannual forcing, v1.5, through 2020 + JRA55 interannual forcing, v1.5, through 2020, no rofi or rofl around AIS JRA55 interannual forcing, v1.4, through 2018 JRA55 interannual forcing, v1.4, through 2018, no rofi around AIS JRA55 interannual forcing, v1.4, through 2018, no rofl around AIS @@ -43,7 +44,7 @@ char - CPLHIST,DIATREN_ANN_RX1,DIATREN_IAF_RX1,DIATREN_IAF_AIS00_RX1,DIATREN_IAF_AIS45_RX1,DIATREN_IAF_AIS55_RX1,IAF_JRA,IAF_JRA_1p5,IAF_JRA_1p4_2018,IAF_JRA_1p4_2018_AIS0ICE,IAF_JRA_1p4_2018_AIS0LIQ,IAF_JRA_1p4_2018_AIS0ROF,RYF8485_JRA,RYF9091_JRA,RYF0304_JRA,NULL + CPLHIST,DIATREN_ANN_RX1,DIATREN_IAF_RX1,DIATREN_IAF_AIS00_RX1,DIATREN_IAF_AIS45_RX1,DIATREN_IAF_AIS55_RX1,IAF_JRA,IAF_JRA_1p5,IAF_JRA_1p5_AIS0ROF,IAF_JRA_1p4_2018,IAF_JRA_1p4_2018_AIS0ICE,IAF_JRA_1p4_2018_AIS0LIQ,IAF_JRA_1p4_2018_AIS0ROF,RYF8485_JRA,RYF9091_JRA,RYF0304_JRA,NULL DIATREN_ANN_RX1 NULL @@ -58,6 +59,7 @@ CPLHIST IAF_JRA IAF_JRA_1p5 + IAF_JRA_1p5_AIS0ROF IAF_JRA_1p4_2018 IAF_JRA_1p4_2018_AIS0ICE IAF_JRA_1p4_2018_AIS0LIQ diff --git a/components/data_comps/drof/cime_config/namelist_definition_drof.xml b/components/data_comps/drof/cime_config/namelist_definition_drof.xml index a1af7adf7114..867169e2dc71 100644 --- a/components/data_comps/drof/cime_config/namelist_definition_drof.xml +++ b/components/data_comps/drof/cime_config/namelist_definition_drof.xml @@ -63,6 +63,7 @@ rof.iaf_jra_1p4_2018_ais0liq rof.iaf_jra_1p4_2018_ais0rof rof.iaf_jra_1p4_2018 + rof.iaf_jra_1p5_ais0rof rof.iaf_jra_1p5 rof.iaf_jra rof.ryf8485_jra @@ -203,6 +204,71 @@ RAF_8485.JRA.v1.3.runoff.180404.nc RAF_9091.JRA.v1.3.runoff.180404.nc RAF_0304.JRA.v1.3.runoff.180404.nc + + JRA.v1.5.runoff.1958.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1959.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1960.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1961.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1962.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1963.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1964.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1965.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1966.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1967.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1968.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1969.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1970.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1971.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1972.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1973.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1974.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1975.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1976.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1977.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1978.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1979.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1980.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1981.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1982.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1983.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1984.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1985.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1986.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1987.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1988.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1989.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1990.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1991.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1992.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1993.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1994.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1995.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1996.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1997.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1998.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.1999.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2000.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2001.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2002.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2003.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2004.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2005.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2006.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2007.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2008.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2009.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2010.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2011.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2012.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2013.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2014.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2015.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2016.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2017.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2018.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2019.no_rofi_no_rofl.210505.nc + JRA.v1.5.runoff.2020.no_rofi_no_rofl.210504.nc + JRA.v1.5.runoff.1958.210505.nc JRA.v1.5.runoff.1959.210505.nc diff --git a/components/elm/cime_config/config_compsets.xml b/components/elm/cime_config/config_compsets.xml index 5179b6a31660..b9da027e62e3 100644 --- a/components/elm/cime_config/config_compsets.xml +++ b/components/elm/cime_config/config_compsets.xml @@ -508,7 +508,7 @@ - I20TRCRUELMBGC + I20TRGSWELMBGC 20TR_DATM%GSWP3v1_ELM%BGC_SICE_SOCN_MOSART_SGLC_SWAV diff --git a/components/elm/src/main/elm_driver.F90 b/components/elm/src/main/elm_driver.F90 index aab7777f58b3..9f9988b06c3d 100644 --- a/components/elm/src/main/elm_driver.F90 +++ b/components/elm/src/main/elm_driver.F90 @@ -1108,21 +1108,20 @@ subroutine elm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate) filter(nc)%num_soilp, filter(nc)%soilp, & cnstate_vars) end if + + if (use_fates_sp) then + call SatellitePhenology(bounds_clump, & + filter_inactive_and_active(nc)%num_soilp, filter_inactive_and_active(nc)%soilp, & + waterstate_vars, canopystate_vars) + endif + else ! not ( if-use_cn or if-use_fates) - - if (.not.use_fates_sp .and. doalb) then + if (doalb) then ! Prescribed biogeography - prescribed canopy structure, some prognostic carbon fluxes call SatellitePhenology(bounds_clump, & filter(nc)%num_nolakep, filter(nc)%nolakep, & waterstate_vars, canopystate_vars) end if - - if (use_fates_sp .and. doalb) then - call SatellitePhenology(bounds_clump, & - filter_inactive_and_active(nc)%num_soilp, filter_inactive_and_active(nc)%soilp, & - waterstate_vars, canopystate_vars) - endif - end if ! end of if-use_cn or if-use_fates end if ! end of is_active_betr_bgc diff --git a/components/mosart/cime_config/testdefs/testmods_dirs/mosart/heat/shell_commands b/components/mosart/cime_config/testdefs/testmods_dirs/mosart/heat/shell_commands new file mode 100644 index 000000000000..1fe51e449b45 --- /dev/null +++ b/components/mosart/cime_config/testdefs/testmods_dirs/mosart/heat/shell_commands @@ -0,0 +1 @@ +./xmlchange DATM_CLMNCEP_YR_END=1972 diff --git a/components/mosart/cime_config/testdefs/testmods_dirs/mosart/heat/user_nl_mosart b/components/mosart/cime_config/testdefs/testmods_dirs/mosart/heat/user_nl_mosart new file mode 100644 index 000000000000..9dd0fc62663c --- /dev/null +++ b/components/mosart/cime_config/testdefs/testmods_dirs/mosart/heat/user_nl_mosart @@ -0,0 +1,2 @@ +frivinp_rtm = '$DIN_LOC_ROOT/rof/mosart/MOSART_global_half_20180721a.nc' +heatflag = .true. diff --git a/components/mosart/src/riverroute/MOSART_heat_mod.F90 b/components/mosart/src/riverroute/MOSART_heat_mod.F90 index 78b16751efef..05e5d527255a 100644 --- a/components/mosart/src/riverroute/MOSART_heat_mod.F90 +++ b/components/mosart/src/riverroute/MOSART_heat_mod.F90 @@ -75,21 +75,19 @@ subroutine subnetworkHeat_simple(iunit, theDeltaT) integer, intent(in) :: iunit real(r8), intent(in) :: theDeltaT - real(r8) :: Qsur, Qsub ! flow rate of surface and subsurface runoff separately - !if(TUnit%fdir(iunit) >= 0 .and. TUnit%areaTotal(iunit) > TINYVALUE1) then - THeat%Hs_t(iunit) = 0._r8 - THeat%Hl_t(iunit) = 0._r8 - THeat%He_t(iunit) = 0._r8 - THeat%Hh_t(iunit) = 0._r8 - THeat%Hc_t(iunit) = 0._r8 + THeat%Hs_t(iunit) = 0._r8 + THeat%Hl_t(iunit) = 0._r8 + THeat%He_t(iunit) = 0._r8 + THeat%Hh_t(iunit) = 0._r8 + THeat%Hc_t(iunit) = 0._r8 + + THeat%Ha_h2t(iunit) = 0._r8 + THeat%Ha_t2r(iunit) = -cr_advectheat(abs(TRunoff%etout(iunit,nt_nliq)+TRunoff%etout(iunit,nt_nice)), THeat%Tt(iunit)) + ! change of energy due to heat exchange with the environment + THeat%deltaH_t(iunit) = 0._r8 + ! change of energy due to advective heat flux + THeat%deltaM_t(iunit) = 0._r8 - THeat%Ha_h2t(iunit) = 0._r8 - THeat%Ha_t2r(iunit) = -cr_advectheat(abs(TRunoff%etout(iunit,nt_nliq)+TRunoff%etout(iunit,nt_nice)), THeat%Tt(iunit)) - ! change of energy due to heat exchange with the environment - THeat%deltaH_t(iunit) = theDeltaT * (THeat%Hs_t(iunit) + THeat%Hl_t(iunit) + THeat%He_t(iunit) + THeat%Hc_t(iunit) + THeat%Hh_t(iunit)) - ! change of energy due to advective heat flux - THeat%deltaM_t(iunit) = theDeltaT * (THeat%Ha_h2t(iunit)-cr_advectheat(Qsur + Qsub, THeat%Tt(iunit))) - !end if end subroutine subnetworkHeat_simple diff --git a/components/mpas-albany-landice/bld/build-namelist b/components/mpas-albany-landice/bld/build-namelist index 07704ca78a75..224225abe9a4 100755 --- a/components/mpas-albany-landice/bld/build-namelist +++ b/components/mpas-albany-landice/bld/build-namelist @@ -457,12 +457,16 @@ if ($MALI_DYNAMIC eq 'TRUE') { add_default($nl, 'config_tracer_advection', 'val'=>"none"); } add_default($nl, 'config_restore_thickness_after_advection'); +add_default($nl, 'config_zero_sfcMassBalApplied_over_bare_land'); ############################## # Namelist group: solidearth # ############################## add_default($nl, 'config_uplift_method'); +add_default($nl, 'config_slm_coupling_interval'); +add_default($nl, 'config_MALI_to_SLM_weights_file'); +add_default($nl, 'config_SLM_to_MALI_weights_file'); ########################### # Namelist group: calving # @@ -488,6 +492,8 @@ add_default($nl, 'config_remove_small_islands'); add_default($nl, 'config_calving_speed_limit'); add_default($nl, 'config_grounded_von_Mises_threshold_stress'); add_default($nl, 'config_floating_von_Mises_threshold_stress'); +add_default($nl, 'config_grounded_von_Mises_threshold_stress_source'); +add_default($nl, 'config_floating_von_Mises_threshold_stress_source'); add_default($nl, 'config_finalize_damage_after_advection'); add_default($nl, 'config_preserve_damage'); add_default($nl, 'config_calculate_damage'); @@ -498,6 +504,9 @@ add_default($nl, 'config_damage_rheology_coupling'); add_default($nl, 'config_damage_gl_setting'); add_default($nl, 'config_damage_calving_method'); add_default($nl, 'config_damagecalvingParameter'); +add_default($nl, 'config_ismip6_retreat_k'); +add_default($nl, 'config_calving_error_threshold'); +add_default($nl, 'config_distribute_unablatedVolumeDynCell'); ################################## # Namelist group: thermal_solver # @@ -566,7 +575,9 @@ add_default($nl, 'config_adaptive_timestep'); add_default($nl, 'config_min_adaptive_timestep'); add_default($nl, 'config_max_adaptive_timestep'); add_default($nl, 'config_adaptive_timestep_CFL_fraction'); +add_default($nl, 'config_adaptive_timestep_calvingCFL_fraction'); add_default($nl, 'config_adaptive_timestep_include_DCFL'); +add_default($nl, 'config_adaptive_timestep_include_calving'); add_default($nl, 'config_adaptive_timestep_force_interval'); ################################### diff --git a/components/mpas-albany-landice/bld/build-namelist-section b/components/mpas-albany-landice/bld/build-namelist-section index 021e62dd8399..c88917a689d7 100644 --- a/components/mpas-albany-landice/bld/build-namelist-section +++ b/components/mpas-albany-landice/bld/build-namelist-section @@ -23,12 +23,16 @@ add_default($nl, 'config_effective_pressure_max'); add_default($nl, 'config_thickness_advection'); add_default($nl, 'config_tracer_advection'); add_default($nl, 'config_restore_thickness_after_advection'); +add_default($nl, 'config_zero_sfcMassBalApplied_over_bare_land'); ############################## # Namelist group: solidearth # ############################## add_default($nl, 'config_uplift_method'); +add_default($nl, 'config_slm_coupling_interval'); +add_default($nl, 'config_MALI_to_SLM_weights_file'); +add_default($nl, 'config_SLM_to_MALI_weights_file'); ########################### # Namelist group: calving # @@ -50,6 +54,8 @@ add_default($nl, 'config_remove_small_islands'); add_default($nl, 'config_calving_speed_limit'); add_default($nl, 'config_grounded_von_Mises_threshold_stress'); add_default($nl, 'config_floating_von_Mises_threshold_stress'); +add_default($nl, 'config_grounded_von_Mises_threshold_stress_source'); +add_default($nl, 'config_floating_von_Mises_threshold_stress_source'); add_default($nl, 'config_finalize_damage_after_advection'); add_default($nl, 'config_preserve_damage'); add_default($nl, 'config_calculate_damage'); @@ -60,6 +66,9 @@ add_default($nl, 'config_damage_rheology_coupling'); add_default($nl, 'config_damage_gl_setting'); add_default($nl, 'config_damage_calving_method'); add_default($nl, 'config_damagecalvingParameter'); +add_default($nl, 'config_ismip6_retreat_k'); +add_default($nl, 'config_calving_error_threshold'); +add_default($nl, 'config_distribute_unablatedVolumeDynCell'); ################################## # Namelist group: thermal_solver # @@ -128,7 +137,9 @@ add_default($nl, 'config_adaptive_timestep'); add_default($nl, 'config_min_adaptive_timestep'); add_default($nl, 'config_max_adaptive_timestep'); add_default($nl, 'config_adaptive_timestep_CFL_fraction'); +add_default($nl, 'config_adaptive_timestep_calvingCFL_fraction'); add_default($nl, 'config_adaptive_timestep_include_DCFL'); +add_default($nl, 'config_adaptive_timestep_include_calving'); add_default($nl, 'config_adaptive_timestep_force_interval'); ################################### diff --git a/components/mpas-albany-landice/bld/namelist_files/namelist_defaults_mali.xml b/components/mpas-albany-landice/bld/namelist_files/namelist_defaults_mali.xml index 1a369ef06052..80ac6c582155 100644 --- a/components/mpas-albany-landice/bld/namelist_files/namelist_defaults_mali.xml +++ b/components/mpas-albany-landice/bld/namelist_files/namelist_defaults_mali.xml @@ -20,9 +20,13 @@ 'fo' 'none' .false. +.true. 'none' +'0002-00-00_00:00:00' +'mpas_to_grid.nc' +'grid_to_mpas.nc' 'none' @@ -41,6 +45,8 @@ 100.0 1.0e6 1.0e6 +'scalar' +'scalar' .true. .false. .false. @@ -49,8 +55,11 @@ 0.1 .false. 'nye' -'threshold' +'none' 1.0e-4 +-170.0 +0.1 +.false. 'none' @@ -107,7 +116,9 @@ 3600.0 3.15e9 0.25 +1.0 .false. +.true. '1000-00-00_00:00:00' diff --git a/components/mpas-albany-landice/bld/namelist_files/namelist_definition_mali.xml b/components/mpas-albany-landice/bld/namelist_files/namelist_definition_mali.xml index 4eee0acc6f9e..41d1123dd7a0 100644 --- a/components/mpas-albany-landice/bld/namelist_files/namelist_definition_mali.xml +++ b/components/mpas-albany-landice/bld/namelist_files/namelist_definition_mali.xml @@ -159,6 +159,14 @@ Valid values: .true. or .false. Default: Defined in namelist_defaults.xml + +Mask to zero out sfcMassBalApplied in regions where there is no ice at the timestep. + +Valid values: .true. or .false. +Default: Defined in namelist_defaults.xml + + @@ -166,7 +174,31 @@ Default: Defined in namelist_defaults.xml category="solidearth" group="solidearth"> Selection of the method for bedrock uplift calculation. -Valid values: 'none', 'data' +Valid values: 'none', 'data', 'sealevelmodel' +Default: Defined in namelist_defaults.xml + + + +Time interval at which the sea-level model is called by MALI. The interval has to be an even multiple of the option 'config_adaptive_timestep_force_interval + +Valid values: Any time interval of the format 'YYYY-MM-DD_HH:MM:SS' +Default: Defined in namelist_defaults.xml + + + +File containing the interpolation weights for regridding from MPAS mesh to the Gaussian grid used by the Sea Level Model. + +Valid values: Any file name string +Default: Defined in namelist_defaults.xml + + + +File containing the interpolation weights for regridding from the Gaussian grid used by the Sea Level Model to the MPAS mesh. + +Valid values: Any file name string Default: Defined in namelist_defaults.xml @@ -175,9 +207,9 @@ Default: Defined in namelist_defaults.xml -Selection of the method for calving ice (as defined below). +Selection of the method for calving ice (as defined below). 'von_Mises_stress' and 'eigencalving' options can be used in combination with damage threshold calving (see descrption of config_damage_calving_method for details). -Valid values: 'none', 'floating', 'topographic_threshold', 'thickness_threshold', 'mask', 'eigencalving', 'specified_calving_velocity', 'von_Mises_stress', 'damagecalving' +Valid values: 'none', 'floating', 'topographic_threshold', 'thickness_threshold', 'mask', 'eigencalving', 'specified_calving_velocity', 'von_Mises_stress', 'damagecalving', 'ismip6_retreat' Default: Defined in namelist_defaults.xml @@ -301,6 +333,22 @@ Valid values: Any positive real value Default: Defined in namelist_defaults.xml + +Source of von MIses threshold stress value for calving from grounded ice. + +Valid values: 'data' (read from input file), 'scalar' (specified by config_grounded_von_Mises_threshold_stress) +Default: Defined in namelist_defaults.xml + + + +Source of von MIses threshold stress value for calving from floating ice. + +Valid values: 'data' (read from input file), 'scalar' (specified by config_floating_von_Mises_threshold_stress) +Default: Defined in namelist_defaults.xml + + If true, then the 'li_finalize_damage_after_advection' subroutine is applied, doing the following: 1) set the value of damage at the grounding line based on the choice of 'config_damage_gl_setting', 2) reset the value of damage to its initial value (to avoid healing), based on choice of 'config_preserve_damage', 3) couple the updated damage value to the rheology if 'config_damage_rheology_coupling' is true. @@ -367,9 +415,9 @@ Default: Defined in namelist_defaults.xml -Selection of the method for damage calving. For 'threshold', ice with damage above the value specified by 'config_damage_calving_threshold' will be removed (currently, only if this ice is also AT a marine margin, but eventually this will be expanded to also include any ice at the threshold adjacent to cells at the marine margin). For 'calving_rate', a rate of calving is specified as proportional to the damage value above some threshold, with the constant of proportionality specified by 'config_damagecalvingParameter' and the threshold defined by config_damage_calving_threshold. +Selection of the method for damage calving. For 'threshold', ice with damage above the value specified by 'config_damage_calving_threshold' will be removed if it is connected to the marine margin. The 'threshold' option can be combined with config_calving = 'von_Mises_stress' and config_calving = 'eigencalving'. For 'calving_rate', a rate of calving is specified as proportional to the damage value above some threshold, with the constant of proportionality specified by 'config_damagecalvingParameter' and the threshold defined by config_damage_calving_threshold. The 'calving_rate' option cannot currently be combined with other calving routines, and requires config_calving = 'damagecalving'. -Valid values: 'calving_rate', 'threshold' +Valid values: 'calving_rate', 'threshold', 'none' Default: Defined in namelist_defaults.xml @@ -381,6 +429,30 @@ Valid values: any positive real value Default: Defined in namelist_defaults.xml + +Coefficient for ISMIP6 retreat parameterization from Slater et al. (2019) + +Valid values: any negative real value +Default: Defined in namelist_defaults.xml + + + +Fraction of total volume intended to be ablated remaining before an error is triggered. + +Valid values: any positive real value +Default: Defined in namelist_defaults.xml + + + +If true, then distribute unablatedVolumeDynCell among dynamic neighbors when converting ablation velocity to ablation thickness. This should only be used as a clean-up measure, while limiting the timestep based on ablation velocity should be used as the primary method of getting accurate ablation thickness from ablation velocity. If you choose to set config_adaptive_timestep_calvingCFL_fraction much larger than 1.0 (which is not recommended), setting this option to true usually results in more accurate calving behavior. + +Valid values: .true. or .false. +Default: Defined in namelist_defaults.xml + + @@ -771,12 +843,20 @@ Default: Defined in namelist_defaults.xml -A multiplier on the minimum allowable time step calculated from the CFL condition. (Setting to 1.0 may be unstable, so smaller values are recommended.) +A multiplier on the minimum allowable time step calculated from the advective CFL condition. (Setting to 1.0 may be unstable, so smaller values are recommended.) Note that 'advective' is not in the name. This is for backwards compatibility Valid values: Any positive real value less than 1.0. Default: Defined in namelist_defaults.xml + +A multiplier on the minimum allowable time step calculated from the calving CFL condition. This should be conservative given the calving CFL calculation is lagged + +Valid values: Any positive real value. Note that values greater than 1.0 are allowed and may be desired. This is because the calving CFL is an approximate calculation. A value between 0.75 and 1.0, possibly as large as 1.25, was found to maintain converged accuracy for many configurations explored, so it is recommended to use values in this range. However, much larger values (up to 2 or 3) provide acceptable accuracy for some configurations (but it is not clear what conditions allow it). If values much greater than 1.0 are used, it is recommended to set config_distribute_unablatedVolumeDynCell to true. +Default: Defined in namelist_defaults.xml + + Option of whether to include the diffusive CFL condition in the determination of the maximum allowable timestep. The diffusive CFL condition at any location is estimated based on the local ice flux and surface slope. @@ -785,6 +865,14 @@ Valid values: .true. or .false. Default: Defined in namelist_defaults.xml + +Option of whether to include the calving CFL condition in the determination of the maximum allowable timestep. This only is applied if config_calving is set to a method that uses a calvingVelocity. Note that this is an approximate CFL condition and is lagged a timestep. + +Valid values: .true. or .false. +Default: Defined in namelist_defaults.xml + + If adaptive timestep is enabled, the model will ensure a timestep ends at multiples of this interval. This is useful for ensuring that model output is written at a specific desired interval (rather than the closest time after) or when running coupled to an earth system model that expects a certain interval. diff --git a/components/mpas-albany-landice/src/Makefile b/components/mpas-albany-landice/src/Makefile index b622a1757d0c..ca228410cbe9 100644 --- a/components/mpas-albany-landice/src/Makefile +++ b/components/mpas-albany-landice/src/Makefile @@ -5,6 +5,9 @@ FW = ../../../mpas-framework/src SHARED_INCLUDES = -I$(FW)/framework -I$(FW)/external/esmf_time_f90 -I$(FW)/operators SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/mode_forward +ifeq "$(SLM)" "true" +SHARED_INCLUDES += -I$(PWD)/SeaLevelModel +endif all: core_landice @@ -15,10 +18,19 @@ analysis_members: shared (cd analysis_members; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(SHARED_INCLUDES)") -mode_forward: shared analysis_members +mode_forward: shared analysis_members sea_level_model (cd mode_forward; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(SHARED_INCLUDES)") -core_landice: mode_forward shared analysis_members +sea_level_model: +ifeq "$(SLM)" "true" + if [ -e SeaLevelModel/.git ]; then \ + (cd SeaLevelModel; $(MAKE) all FC="$(FC)" FCFLAGS="$(FFLAGS)" FINCLUDES="$(FINCLUDES)") \ + else \ + (echo "Missing mpas-ocean/src/SeaLevelModel/.git, did you forget to 'git submodule update --init --recursive' ?"; exit 1) \ + fi +endif + +core_landice: mode_forward shared analysis_members sea_level_model ar -ru libdycore.a `find . -type f -name "*.o"` core_input_gen: @@ -49,3 +61,6 @@ clean: (cd shared; $(MAKE) clean) (cd mode_forward; $(MAKE) clean) (cd analysis_members; $(MAKE) clean) + if [ -e SeaLevelModel/.git ]; then \ + (cd SeaLevelModel; $(MAKE) clean) \ + fi diff --git a/components/mpas-albany-landice/src/Registry.xml b/components/mpas-albany-landice/src/Registry.xml index ea9a7e432b24..75477cd47932 100644 --- a/components/mpas-albany-landice/src/Registry.xml +++ b/components/mpas-albany-landice/src/Registry.xml @@ -120,6 +120,10 @@ description="If true, reset thickness to values at previous timestep after advection occurs. This is used for spinning up tracer fields such as damage. When this is true, geometry changes from surface and basal mass balance (grounded or floating) and facemelting are not retained, but changes from calving are." possible_values=".true. or .false." /> + + + + + @@ -787,7 +841,12 @@ - + + + + + + @@ -838,6 +897,20 @@ + + + + + + + @@ -1027,6 +1100,9 @@ is the value of that variable from the *previous* time level! + @@ -1036,6 +1112,9 @@ is the value of that variable from the *previous* time level! + @@ -1090,13 +1169,22 @@ is the value of that variable from the *previous* time level! description="applied surface mass balance on grounded ice" /> + + + + + + + + + @@ -1224,7 +1330,6 @@ is the value of that variable from the *previous* time level! - /> @@ -1239,12 +1344,25 @@ is the value of that variable from the *previous* time level! /> - + /> + + + + + - + @@ -1378,6 +1499,10 @@ is the value of that variable from the *previous* time level! units="none" description="flag needed by external velocity solvers that indicates if the Dirichlet boundary condition mask has changed (treated as a logical)" packages="higherOrderVelocity" /> + @@ -1412,6 +1537,9 @@ is the value of that variable from the *previous* time level! + diff --git a/components/mpas-albany-landice/src/Registry_subglacial_hydro.xml b/components/mpas-albany-landice/src/Registry_subglacial_hydro.xml index 6179f9af8114..754e8385255c 100644 --- a/components/mpas-albany-landice/src/Registry_subglacial_hydro.xml +++ b/components/mpas-albany-landice/src/Registry_subglacial_hydro.xml @@ -172,6 +172,8 @@ description="total water flux in subglacial hydrology system" /> + - + + + + + + + + + + diff --git a/components/mpas-albany-landice/src/analysis_members/mpas_li_global_stats.F b/components/mpas-albany-landice/src/analysis_members/mpas_li_global_stats.F index c661544199d2..b39936b588f7 100644 --- a/components/mpas-albany-landice/src/analysis_members/mpas_li_global_stats.F +++ b/components/mpas-albany-landice/src/analysis_members/mpas_li_global_stats.F @@ -172,9 +172,9 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err) real (kind=RKIND), dimension(:), pointer :: bedTopography real (kind=RKIND), dimension(:), pointer :: sfcMassBalApplied real (kind=RKIND), dimension(:), pointer :: groundedSfcMassBalApplied - real (kind=RKIND), dimension(:), pointer :: basalMassBal - real (kind=RKIND), dimension(:), pointer :: groundedBasalMassBal - real (kind=RKIND), dimension(:), pointer :: floatingBasalMassBal + real (kind=RKIND), dimension(:), pointer :: basalMassBalApplied + real (kind=RKIND), dimension(:), pointer :: groundedBasalMassBalApplied + real (kind=RKIND), dimension(:), pointer :: floatingBasalMassBalApplied real (kind=RKIND), dimension(:), pointer :: calvingThickness real (kind=RKIND), dimension(:), pointer :: surfaceSpeed real (kind=RKIND), dimension(:), pointer :: basalSpeed @@ -286,9 +286,9 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) call mpas_pool_get_array(geometryPool, 'sfcMassBalApplied', sfcMassBalApplied) call mpas_pool_get_array(geometryPool, 'groundedSfcMassBalApplied', groundedSfcMassBalApplied) - call mpas_pool_get_array(geometryPool, 'basalMassBal', basalMassBal) - call mpas_pool_get_array(geometryPool, 'groundedBasalMassBal', groundedBasalMassBal) - call mpas_pool_get_array(geometryPool, 'floatingBasalMassBal', floatingBasalMassBal) + call mpas_pool_get_array(geometryPool, 'basalMassBalApplied', basalMassBalApplied) + call mpas_pool_get_array(geometryPool, 'groundedBasalMassBalApplied', groundedBasalMassBalApplied) + call mpas_pool_get_array(geometryPool, 'floatingBasalMassBalApplied', floatingBasalMassBalApplied) call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) call mpas_pool_get_array(geometryPool, 'groundedToFloatingThickness', groundedToFloatingThickness) call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed) @@ -331,12 +331,9 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err) blockSumFloatingSfcMassBal = blockSumFloatingSfcMassBal + & (sfcMassBalApplied(iCell) - groundedSfcMassBalApplied(iCell)) * areaCell(iCell) * scyr ! BMB (kg yr-1) - blockSumBasalMassBal = blockSumBasalMassBal + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & - * areaCell(iCell) * basalMassBal(iCell) * scyr - blockSumGroundedBasalMassBal = blockSumGroundedBasalMassBal + real(li_mask_is_grounded_ice_int(cellMask(iCell)),RKIND)& - * areaCell(iCell) * groundedBasalMassBal(iCell) * scyr - blockSumFloatingBasalMassBal = blockSumFloatingBasalMassBal + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND)& - * areaCell(iCell) * floatingBasalMassBal(iCell) * scyr + blockSumBasalMassBal = blockSumBasalMassBal + areaCell(iCell) * basalMassBalApplied(iCell) * scyr + blockSumGroundedBasalMassBal = blockSumGroundedBasalMassBal + areaCell(iCell) * groundedBasalMassBalApplied(iCell) * scyr + blockSumFloatingBasalMassBal = blockSumFloatingBasalMassBal + areaCell(iCell) * floatingBasalMassBalApplied(iCell) * scyr ! mass lass due do calving (kg yr^{-1}) blockSumCalvingFlux = blockSumCalvingFlux + calvingThickness(iCell) * & diff --git a/components/mpas-albany-landice/src/analysis_members/mpas_li_regional_stats.F b/components/mpas-albany-landice/src/analysis_members/mpas_li_regional_stats.F index 0a63543f93cc..544707a30f15 100644 --- a/components/mpas-albany-landice/src/analysis_members/mpas_li_regional_stats.F +++ b/components/mpas-albany-landice/src/analysis_members/mpas_li_regional_stats.F @@ -174,9 +174,9 @@ subroutine li_compute_regional_stats(domain, memberName, timeLevel, err) real (kind=RKIND), dimension(:), pointer :: bedTopography real (kind=RKIND), dimension(:), pointer :: sfcMassBalApplied real (kind=RKIND), dimension(:), pointer :: groundedSfcMassBalApplied - real (kind=RKIND), dimension(:), pointer :: basalMassBal - real (kind=RKIND), dimension(:), pointer :: groundedBasalMassBal - real (kind=RKIND), dimension(:), pointer :: floatingBasalMassBal + real (kind=RKIND), dimension(:), pointer :: basalMassBalApplied + real (kind=RKIND), dimension(:), pointer :: groundedBasalMassBalApplied + real (kind=RKIND), dimension(:), pointer :: floatingBasalMassBalApplied real (kind=RKIND), dimension(:), pointer :: calvingThickness real (kind=RKIND), dimension(:), pointer :: surfaceSpeed real (kind=RKIND), dimension(:), pointer :: basalSpeed @@ -279,9 +279,9 @@ subroutine li_compute_regional_stats(domain, memberName, timeLevel, err) call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) call mpas_pool_get_array(geometryPool, 'sfcMassBalApplied', sfcMassBalApplied) call mpas_pool_get_array(geometryPool, 'groundedSfcMassBalApplied', groundedSfcMassBalApplied) - call mpas_pool_get_array(geometryPool, 'basalMassBal', basalMassBal) - call mpas_pool_get_array(geometryPool, 'groundedBasalMassBal', groundedBasalMassBal) - call mpas_pool_get_array(geometryPool, 'floatingBasalMassBal', floatingBasalMassBal) + call mpas_pool_get_array(geometryPool, 'basalMassBalApplied', basalMassBalApplied) + call mpas_pool_get_array(geometryPool, 'groundedBasalMassBalApplied', groundedBasalMassBalApplied) + call mpas_pool_get_array(geometryPool, 'floatingBasalMassBalApplied', floatingBasalMassBalApplied) call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) call mpas_pool_get_array(geometryPool, 'groundedToFloatingThickness', groundedToFloatingThickness) call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed) @@ -372,18 +372,15 @@ subroutine li_compute_regional_stats(domain, memberName, timeLevel, err) ! regional sum of basal mass balance (kg yr^{-1}) blockSumRegionBasalMassBal(iRegion) = blockSumRegionBasalMassBal(iRegion) + & - ( real(regionCellMasks(iRegion,iCell),RKIND) * real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & - * areaCell(iCell) * basalMassBal(iCell) * scyr ) + ( real(regionCellMasks(iRegion,iCell),RKIND) * areaCell(iCell) * basalMassBalApplied(iCell) * scyr ) ! regional sum of floating basal mass balance (kg yr^{-1}) blockSumRegionFloatingBasalMassBal(iRegion) = blockSumRegionFloatingBasalMassBal(iRegion) + & - ( real(regionCellMasks(iRegion,iCell),RKIND) * real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & - * areaCell(iCell) * floatingBasalMassBal(iCell) * scyr ) + ( real(regionCellMasks(iRegion,iCell),RKIND) * areaCell(iCell) * floatingBasalMassBalApplied(iCell) * scyr ) ! regional sum of grounded basal mass balance (kg yr^{-1}) blockSumRegionGroundedBasalMassBal(iRegion) = blockSumRegionGroundedBasalMassBal(iRegion) + & - ( real(regionCellMasks(iRegion,iCell),RKIND) * real(li_mask_is_grounded_ice_int(cellMask(iCell)),RKIND) & - * areaCell(iCell) * groundedBasalMassBal(iCell) * scyr ) + ( real(regionCellMasks(iRegion,iCell),RKIND) * areaCell(iCell) * groundedBasalMassBalApplied(iCell) * scyr ) ! regional sum of mass lass due do calving (kg yr^{-1}) blockSumRegionCalvingFlux(iRegion) = blockSumRegionCalvingFlux(iRegion) + & @@ -414,6 +411,7 @@ subroutine li_compute_regional_stats(domain, memberName, timeLevel, err) ! GL migration flux blockRegionGLMigrationFlux(iRegion) = blockRegionGLMigrationFlux(iRegion) + & + real(regionCellMasks(iRegion,iCell),RKIND) * & groundedToFloatingThickness(iCell) * areaCell(iCell) * rhoi / (deltat / scyr) end do ! end loop over regions diff --git a/components/mpas-albany-landice/src/build_options.mk b/components/mpas-albany-landice/src/build_options.mk index eae9b9659590..2708034435e0 100644 --- a/components/mpas-albany-landice/src/build_options.mk +++ b/components/mpas-albany-landice/src/build_options.mk @@ -45,5 +45,11 @@ endif # PHG IF override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) # =================================== +# Optional Sea Level model +ifeq "$(SLM)" "true" + override CPPFLAGS += -DUSE_SEALEVELMODEL +endif + +# =================================== report_builds: @echo "CORE=landice" diff --git a/components/mpas-albany-landice/src/mode_forward/Interface_velocity_solver.cpp b/components/mpas-albany-landice/src/mode_forward/Interface_velocity_solver.cpp index 60ad7a16a05f..39dcdaa94150 100644 --- a/components/mpas-albany-landice/src/mode_forward/Interface_velocity_solver.cpp +++ b/components/mpas-albany-landice/src/mode_forward/Interface_velocity_solver.cpp @@ -1712,15 +1712,23 @@ bool belongToTria(double const* x, double const* t, double bcoords[3], double ep // apparent mass balance std::vector appMbData(smbData.size()), - appMbUncertaintyData(smbData.size()); - + appMbUncertaintyData(smbData.size()), + muLogData(muFrictionData.size()), + stiffnessLogData(stiffnessFactorData.size()); + for (int i=0; i thermalCellMaskField % array ! given the old thickness, compute the thickness in each layer call li_calculate_layerThickness(meshPool, thickness, layerThickness) @@ -403,7 +425,6 @@ subroutine li_advection_thickness_tracers(& edgeMask, & layerThickness, & advectedTracers, & - fluxAcrossGroundingLine, & err) if (config_print_thickness_advection_info) then @@ -440,22 +461,36 @@ subroutine li_advection_thickness_tracers(& ! TODO: more complicated treatment at GL? - where ( li_mask_is_grounded_ice(cellMask) ) - - basalMassBal = groundedBasalMassBal - - elsewhere ( li_mask_is_floating_ice(cellMask) ) - - ! Currently, floating and grounded ice are mutually exclusive. - ! This could change if the GL is parameterized, in which case this logic may need adjustment. - basalMassBal = floatingBasalMassBal - - elsewhere ( .not. (li_mask_is_ice(cellMask) ) ) - - ! We don't allow a positive basal mass balance where ice is not already present. - basalMassBal = 0.0_RKIND + do iCell = 1, nCells + if (li_mask_is_grounded_ice(cellMask(iCell))) then + basalMassBal(iCell) = groundedBasalMassBal(iCell) + elseif (li_mask_is_floating_ice(cellMask(iCell))) then + ! Currently, floating and grounded ice are mutually exclusive. + ! This could change if the GL is parameterized, in which case this logic may need adjustment. + basalMassBal(iCell) = floatingBasalMassBal(iCell) + elseif ( .not. (li_mask_is_ice(cellMask(iCell)))) then + ! We don't allow a positive basal mass balance where ice is not already present. + basalMassBal(iCell) = 0.0_RKIND + endif + enddo - end where + ! It is possible that excess internal melting was computed and assigned + ! to the drainedInternalMeltRate array in mpas_li_thermal.F. If so, then add it to basalMassBal. + ! floatingBasalMassBal should never be altered because it is an input variable. + ! Note: Subroutine basal_melt_floating_ice should be called earlier in the time step, before adding this term. + ! calculate a mask to identify ice that is thick enough to be thermally active + if (config_thermal_calculate_bmb) then + do iCell = 1, nCells + if (thickness(iCell) > config_thermal_thickness) then + thermalCellMask(iCell) = 1 + do k = 1, nVertLevels + basalMassBal(iCell) = basalMassBal(iCell) - drainedInternalMeltRate(k, iCell) + enddo + else + thermalCellMask(iCell) = 0 + endif + enddo + endif call apply_mass_balance(& dt, & @@ -466,6 +501,9 @@ subroutine li_advection_thickness_tracers(& sfcMassBalApplied, & groundedSfcMassBalApplied, & basalMassBal, & + basalMassBalApplied, & + groundedBasalMassBalApplied, & + floatingBasalMassBalApplied, & surfaceTracers, & basalTracers, & layerThickness, & @@ -483,13 +521,13 @@ subroutine li_advection_thickness_tracers(& do iCell = 1, nCells if (indexToCellID(iCell) == config_stats_cell_ID) then call mpas_log_write(' ') - call mpas_log_write('After apply_mass_balance, iCell=$i, thickness=$r', intArgs=(/iCell/), & + call mpas_log_write('After apply_mass_balance, indexToCellID=$i, thickness=$r', intArgs=(/indexToCellID(iCell)/), & realArgs=(/thickness(iCell)/) ) call mpas_log_write('cellMask=$i, is ice=$l, is grounded=$l, is floating=$l', & intArgs=(/cellMask(iCell)/), logicArgs=(/li_mask_is_ice(cellMask(iCell)), & li_mask_is_grounded_ice(cellMask(iCell)), li_mask_is_floating_ice(cellMask(iCell)) /) ) - call mpas_log_write('basalMassBal=$r, grounded=$r, floating=$r', realArgs=(/ basalMassBal(iCell)*31536000./917.,& - groundedBasalMassBal(iCell)*31536000./917., floatingBasalMassBal(iCell)*31536000./917. /) ) + call mpas_log_write('basalMassBalApplied=$r, grounded=$r, floating=$r', realArgs=(/ basalMassBalApplied(iCell)*31536000./917.,& + groundedBasalMassBalApplied(iCell)*31536000./917., floatingBasalMassBalApplied(iCell)*31536000./917. /) ) endif enddo endif @@ -504,19 +542,31 @@ subroutine li_advection_thickness_tracers(& ! Calculate flux across grounding line ! Do this after new thickness & mask have been calculated, including SMB/BMB fluxAcrossGroundingLine(:) = 0.0_RKIND + fluxAcrossGroundingLineOnCells(:) = 0.0_RKIND do iEdge = 1, nEdges if (li_mask_is_grounding_line(edgeMask(iEdge))) then iCell1 = cellsOnEdge(1,iEdge) - !iCell2 = cellsOnEdge(2,iEdge) + iCell2 = cellsOnEdge(2,iEdge) if (li_mask_is_grounded_ice(cellMask(iCell1))) then GLfluxSign = 1.0_RKIND ! edge sign convention is positive from iCell1 to iCell2 on an edge + theGroundedCell = iCell1 else GLfluxSign = -1.0_RKIND + theGroundedCell = iCell2 endif do k = 1, nVertLevels thicknessFluxEdge = layerNormalVelocity(k,iEdge) * dvEdge(iEdge) * layerThicknessEdge(k,iEdge) fluxAcrossGroundingLine(iEdge) = fluxAcrossGroundingLine(iEdge) + GLfluxSign * thicknessFluxEdge / dvEdge(iEdge) enddo + ! assign to grounded cell in fluxAcrossGroundingLineOnCells + if (thickness(theGroundedCell) <= 0.0_RKIND) then + ! This should never be the case, but checking to avoid possible divide by zero + call mpas_log_write("thickness at a grounding line is unexepectedly <=0", MPAS_LOG_ERR) + err = ior(err, 1) + return + endif + fluxAcrossGroundingLineOnCells(theGroundedCell) = fluxAcrossGroundingLineOnCells(theGroundedCell) + & + fluxAcrossGroundingLine(iEdge) / thickness(theGroundedCell) * config_ice_density ! adjust to correct units endif enddo ! edges @@ -575,6 +625,7 @@ subroutine li_advection_thickness_tracers(& call mpas_deallocate_scratch_field(basalTracersField, .true.) call mpas_deallocate_scratch_field(surfaceTracersField, .true.) call mpas_deallocate_scratch_field(cellMaskTemporaryField, .true.) + call mpas_deallocate_scratch_field(thermalCellMaskField, .true.) ! === error check if (err > 0) then @@ -686,6 +737,9 @@ subroutine apply_mass_balance(& sfcMassBalApplied, & groundedSfcMassBalApplied, & basalMassBal, & + basalMassBalApplied, & + groundedBasalMassBalApplied, & + floatingBasalMassBalApplied, & surfaceTracers, & basalTracers, & layerThickness, & @@ -730,7 +784,10 @@ subroutine apply_mass_balance(& real(kind=RKIND), dimension(:), intent(out) :: & groundedSfcMassBalApplied !< Output: surface mass balance actually applied to grounded ice on this time step (kg/m^2/s) - + real(kind=RKIND), dimension(:), intent(out) :: & + basalMassBalApplied, & !< Output: basal mass balance actually applied on this time step (kg/m^2/s) + groundedBasalMassBalApplied, & !< Output: basal mass balance actually applied to grounded ice on this time step (kg/m^2/s) + floatingBasalMassBalApplied !< Output: basal mass balance actually applied to floating ice on this time step (kg/m^2/s) ! local variables real (kind=RKIND) :: & @@ -744,6 +801,7 @@ subroutine apply_mass_balance(& integer :: nLayers ! number of layers integer :: nTracers ! number of tracers real (kind=RKIND), pointer :: config_sea_level ! sea level relative to z = 0 + logical, pointer :: config_zero_sfcMassBalApplied_over_bare_land integer :: iCell, iLayer, iTracer @@ -754,13 +812,16 @@ subroutine apply_mass_balance(& allocate(thckTracerProducts(nTracers)) call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_zero_sfcMassBalApplied_over_bare_land', & + config_zero_sfcMassBalApplied_over_bare_land) ! apply surface mass balance ! If positive, then add the SMB to the top layer, conserving mass*tracer products ! If negative, then melt from the top down until the melting term is used up or the ice is gone - ! Initialize applied SMB field + ! Initialize applied SMB and BMB fields sfcMassBalApplied(:) = sfcMassBal(:) + basalMassBalApplied(:) = basalMassBal(:) do iCell = 1, nCells @@ -775,10 +836,18 @@ subroutine apply_mass_balance(& ! Zero out any positive surface mass balance for ice-free ocean cells if (sfcMassBalApplied(iCell) > 0.0_RKIND .and. & - bedTopography(iCell) < config_sea_level .and. .not.(li_mask_is_ice(cellMask(iCell)) ) ) then + bedTopography(iCell) < config_sea_level .and. .not.(li_mask_is_ice(cellMask(iCell)) ) ) then sfcMassBalApplied(iCell) = 0.0_RKIND end if + ! Zero out positive surface mass balance for bare land cells + if (config_zero_sfcMassBalApplied_over_bare_land) then + if (sfcMassBalApplied(iCell) > 0.0_RKIND .and. & + bedTopography(iCell) >= config_sea_level .and. .not.(li_mask_is_ice(cellMask(iCell)) ) ) then + sfcMassBalApplied(iCell) = 0.0_RKIND + endif + endif + ! surface accumulation if (sfcMassBalApplied(iCell) > 0.0_RKIND) then @@ -822,19 +891,14 @@ subroutine apply_mass_balance(& endif ! sfcMassBal > 0 - groundedSfcMassBalApplied(:) = 0.0_RKIND - where (li_mask_is_grounded_ice(cellMask) .or. bedTopography > config_sea_level) - groundedSfcMassBalApplied = sfcMassBalApplied - end where - ! apply basal mass balance - if (basalMassBal(iCell) > 0.0_RKIND) then + if (basalMassBalApplied(iCell) > 0.0_RKIND) then ! basal freeze-on ! modify tracers conservatively in top layer - basalAccum = basalMassBal(iCell) * dt / rhoi + basalAccum = basalMassBalApplied(iCell) * dt / rhoi ! compute mass-tracer products in bottom layer thckTracerProducts(:) = layerThickness(nLayers,iCell)*advectedTracers(:,nLayers,iCell) & @@ -846,11 +910,11 @@ subroutine apply_mass_balance(& ! new tracers in top layer advectedTracers(:,nLayers,iCell) = thckTracerProducts(:) / layerThickness(nLayers,iCell) - elseif (basalMassBal(iCell) < 0.0_RKIND) then + elseif (basalMassBalApplied(iCell) < 0.0_RKIND) then ! surface ablation from the bottom up - basalAblat = -basalMassBal(iCell) * dt /rhoi ! positive for melting + basalAblat = -basalMassBalApplied(iCell) * dt /rhoi ! positive for melting do iLayer = nLayers, 1, -1 if (basalAblat > layerThickness(iLayer,iCell)) then ! melt the entire layer @@ -864,12 +928,35 @@ subroutine apply_mass_balance(& endif enddo - !TODO - If remaining basalAblat > 0, then keep track of it to conserve energy + if (basalAblat > 0.0_RKIND) then + basalMassBalApplied(iCell) = basalMassBalApplied(iCell) + basalAblat * rhoi / dt + !TODO - If remaining basalAblat > 0, then keep track of it to conserve energy + endif - endif ! basalMassBal > 0 + endif ! basalMassBalApplied > 0 enddo ! iCell + ! Separate grounded and floating components, as necessary. + where (li_mask_is_grounded_ice(cellMask) .or. bedTopography > config_sea_level) + groundedSfcMassBalApplied = sfcMassBalApplied + elsewhere + groundedSfcMassBalApplied = 0.0_RKIND + end where + + do iCell = 1, nCells + if (li_mask_is_grounded_ice(cellMask(iCell))) then + groundedBasalMassBalApplied(iCell) = basalMassBalApplied(iCell) + floatingBasalMassBalApplied(iCell) = 0.0_RKIND + elseif (li_mask_is_floating_ice(cellMask(iCell))) then + floatingBasalMassBalApplied(iCell) = basalMassBalApplied(iCell) + groundedBasalMassBalApplied(iCell) = 0.0_RKIND + else + groundedBasalMassBalApplied(iCell) = 0.0_RKIND + floatingBasalMassBalApplied(iCell) = 0.0_RKIND + endif + enddo + deallocate(thckTracerProducts) end subroutine apply_mass_balance @@ -1242,7 +1329,6 @@ subroutine advect_thickness_tracers_upwind(& edgeMask, & layerThicknessNew, & tracersNew, & - fluxAcrossGroundingLine, & err, & advectTracersIn) @@ -1296,9 +1382,6 @@ subroutine advect_thickness_tracers_upwind(& real (kind=RKIND), dimension(:,:,:), intent(out) :: & tracersNew !< Output: tracer values - real (kind=RKIND), dimension(:), intent(out) :: & - fluxAcrossGroundingLine !< Output: ice flux at grounding lines - integer, intent(out) :: & err !< Output: error flag @@ -1353,8 +1436,8 @@ subroutine advect_thickness_tracers_upwind(& thicknessTracerTendency, &! net thickness*tracer tendency for a cell newThicknessTracers ! new values of thickness*tracer - real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND - ! This is ~300 million years in seconds, but it is small enough not to overflow + real (kind=RKIND), parameter :: bigNumber = 1.0e11_RKIND + ! This is ~5000 years in seconds, but it is small enough not to overflow real(kind=RKIND) :: velSign ! = 1.0_RKIND or -1.0_RKIND depending on sign of velocity real(kind=RKIND) :: GLfluxSign @@ -1632,8 +1715,8 @@ subroutine li_layer_normal_velocity(& integer :: iEdge, k - real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND - ! This is ~300 million years in seconds, but is small enough not to overflow + real (kind=RKIND), parameter :: bigNumber = 1.0e11_RKIND + ! This is ~5000 years in seconds, but is small enough not to overflow err = 0 @@ -1750,6 +1833,7 @@ subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers ! pointers to mesh arrays real (kind=RKIND), dimension(:), pointer :: layerThicknessFractions, layerInterfaceSigma + integer, dimension(:), pointer :: indexToCellID ! local arrays real (kind=RKIND), dimension(:), allocatable :: layerInterfaceSigma_Input @@ -1776,6 +1860,7 @@ subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) allocate(layerInterfaceSigma_Input(nVertLevels+1)) allocate(hTsum(nTracers, nVertLevels)) @@ -1841,8 +1926,8 @@ subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers difference = abs(finalEnergySum - initEnergySum) if (initEnergySum > eps11) then if (difference/initEnergySum > eps11) then - call mpas_log_write('vertical_remap, mass*tracer conservation error, iCell = $i', & - MPAS_LOG_WARN, intArgs=(/iCell/)) + call mpas_log_write('vertical_remap, mass*tracer conservation error, indexToCellID = $i', & + MPAS_LOG_WARN, intArgs=(/indexToCellID(iCell)/)) call mpas_log_write('init energy, final energy, difference: $r $r $r', & realArgs=(/initEnergySum, finalEnergySum, finalEnergySum - initEnergySum/)) endif diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_bedtopo.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_bedtopo.F index 19052078629c..d6e670b26111 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_bedtopo.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_bedtopo.F @@ -11,11 +11,11 @@ ! li_bedtopo ! !> \MPAS land-ice bedtopo driver -!> \author Matt Hoffman -!> \date 20 June 2019 +!> \author Matt Hoffman and Holly Han (modified) +!> \date 20 June 2019, January 2022 (modified) !> \details -!> This module contains the routines for bed topography for solid earth changes -!> +!> This module contains the routines for +!> bed topography for solid earth changes ! !----------------------------------------------------------------------- @@ -27,6 +27,10 @@ module li_bedtopo use mpas_log use li_mask use li_setup + use netcdf +#ifdef _MPI + use mpi +#endif implicit none private @@ -38,6 +42,7 @@ module li_bedtopo !-------------------------------------------------------------------- ! Public member functions !-------------------------------------------------------------------- + public :: li_bedtopo_init, & li_bedtopo_finalize, & li_bedtopo_block_init, & @@ -47,7 +52,29 @@ module li_bedtopo ! Private module variables !-------------------------------------------------------------------- - + ! sea-level model timestep + integer, save :: slmTimeStep + + ! Interpolation weights variables + integer, dimension(:), allocatable :: toRowValues, toColValues + integer, dimension(:), allocatable :: fromRowValues, fromColValues + real, dimension(:), allocatable :: toSValues, fromSValues + integer:: nMpas, nGrid + + ! MPI variables + integer :: nCellsGlobal + integer, dimension(:), allocatable :: nCellsDisplacement + integer, dimension(:), allocatable :: indexToCellIDGathered + integer, dimension(:), allocatable :: nCellsPerProc + integer, pointer :: nCellsAll + integer, pointer :: nCellsOwned + integer :: iCell, ilm, curProc + real (kind=RKIND), dimension(:), allocatable :: globalArrayThickness + real (kind=RKIND), dimension(:), allocatable :: gatheredArrayThickness + real (kind=RKIND), dimension(:), allocatable :: globalArrayBedTopography + real (kind=RKIND), dimension(:), allocatable :: gatheredArrayBedTopography + real (kind=RKIND), dimension(:), allocatable :: globalArrayTopoChange + real (kind=RKIND), dimension(:), allocatable :: gatheredArrayTopoChange !*********************************************************************** @@ -58,8 +85,8 @@ module li_bedtopo ! routine li_bedtopo_init ! !> \brief Initializes bedtopo solver -!> \author Matt Hoffman -!> \date 20 June 2019 +!> \author Matt Hoffman and Holly Han (modified) +!> \date 20 June 2019 (original), December 2021 (modified) !> \details !> This routine initializes the bedtopo solver. ! @@ -87,10 +114,17 @@ subroutine li_bedtopo_init(domain, err) ! local variables !----------------------------------------------------------------- + character (len=StrKIND), pointer :: config_uplift_method ! No init is needed. err = 0 + call mpas_pool_get_config(liConfigs, 'config_uplift_method', config_uplift_method) + if (trim(config_uplift_method)=='sealevelmodel') then + ! initialize the 1D sea-level model + call slmodel_init(domain, err) + endif + !-------------------------------------------------------------------- end subroutine li_bedtopo_init @@ -143,17 +177,19 @@ end subroutine li_bedtopo_block_init ! subroutine li_bedtopo_solve ! !> \brief Updates bed topography -!> \author Matt Hoffman -!> \date 20 June 2019 +!> \author Matt Hoffman and Holly Han (modified) +!> \date 20 June 2019 (original), December 2021 (modified) !> \details !> This routine updates the bed topography. Currently the only option !> is a data field passed in as input. ! !----------------------------------------------------------------------- -subroutine li_bedtopo_solve(domain, err) + subroutine li_bedtopo_solve(domain, err) + + use mpas_timekeeping use li_mask - use li_advection + use li_advection, only: li_update_geometry !----------------------------------------------------------------- ! input variables @@ -192,6 +228,7 @@ subroutine li_bedtopo_solve(domain, err) call mpas_pool_get_config(liConfigs, 'config_uplift_method', config_uplift_method) if (trim(config_uplift_method)=='none') then ! do nothing + elseif (trim(config_uplift_method)=='data') then block => domain % blocklist @@ -213,6 +250,26 @@ subroutine li_bedtopo_solve(domain, err) block => block % next end do + elseif (trim(config_uplift_method)=='sealevelmodel') then +#ifdef USE_SEALEVELMODEL + if (mpas_is_alarm_ringing(domain % clock, 'slmCouplingInterval', ierr=err_tmp)) then + err = ior(err, err_tmp) + + slmTimeStep = slmTimeStep + 1 + + call mpas_log_write("Calling the SLM. SLM timestep $i", intArgs=(/slmTimeStep/)) + call slmodel_solve(slmTimeStep, domain) + + call mpas_reset_clock_alarm(domain % clock, 'slmCouplingInterval', ierr=err_tmp) + err = ior(err, err_tmp) + else + ! do nothing for now, but could calculate uplift rate here later instead. + endif +#else + call mpas_log_write("The sea-level model needs to be included in the compilation with 'SLM=true'", & + MPAS_LOG_ERR) + err = ior(err,1) +#endif else call mpas_log_write("Unknown option selected for 'config_uplift_method'", MPAS_LOG_ERR) endif @@ -232,7 +289,6 @@ end subroutine li_bedtopo_solve - !*********************************************************************** ! ! routine li_bedtopo_finalize @@ -267,8 +323,22 @@ subroutine li_bedtopo_finalize(domain, err) ! local variables !----------------------------------------------------------------- + character (len=StrKIND), pointer :: config_uplift_method + err = 0 +#ifdef USE_SEALEVELMODEL + call mpas_pool_get_config(liConfigs, 'config_uplift_method', config_uplift_method) + if (trim(config_uplift_method)=='sealevelmodel') then + if (curProc.eq.0) then + deallocate(toRowValues, toColValues, toSValues) + deallocate(fromRowValues, fromColValues, fromSValues) + endif + deallocate(nCellsPerProc) + deallocate(nCellsDisplacement) + deallocate(indexToCellIDGathered) + endif +#endif !-------------------------------------------------------------------- end subroutine li_bedtopo_finalize @@ -276,7 +346,601 @@ end subroutine li_bedtopo_finalize ! private subroutines +!*********************************************************************** +! +! routine slmodel_init +! +!> \brief Initializes the sea-level model +!> \author Holly Kyeore Han +!> \date January 2022 +!> \details +!> This wrapper routine initializes the sea-level solver(Han et al., 2022, GMD, +!> https://github.com/MALI-Dev/1DSeaLevelModel_FWTW) +! +!----------------------------------------------------------------------- + + subroutine slmodel_init(domain, err) + +#ifdef USE_SEALEVELMODEL + use sl_model_mod !< this is part of the SLM code + use sl_io_mod !< this is part of the SLM code + use user_specs_mod, only: nglv !< this is part of the SLM code +#endif + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + +#ifdef USE_SEALEVELMODEL + character (len=StrKIND), pointer :: config_slm_coupling_interval + type (mpas_pool_type), pointer :: meshPool !< mesh information + type (mpas_pool_type), pointer :: geometryPool + real (kind=RKIND), dimension(:), pointer :: thickness, bedTopography + real (kind=RKIND), dimension(:), allocatable :: meshMask + real (kind=RKIND), dimension(nglv,2*nglv) :: ismIceload, ismBedtopo, ismMask + real (kind=RKIND), dimension(nglv*2*nglv) :: thicknessSLgrid1D + real (kind=RKIND), dimension(nglv*2*nglv) :: bedtopoSLgrid1D + real (kind=RKIND), dimension(nglv*2*nglv) :: maskSLgrid1D + integer :: slm_coupling_interval + integer :: err_tmp + integer :: unit_num_slm ! SLM variable + integer :: itersl, dtime ! SLM variable + real :: starttime ! SLM variable + + ! MPI variables + integer, dimension(:), pointer :: indexToCellID + integer :: iProc, l, ilm, nProcs + + err = 0 + err_tmp = 0 + + ! initialize interpolation + call interpolate_init(domain, err_tmp) + err = ior(err, err_tmp) + + ! Set needed variables for using MPI + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCells', nCellsAll) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsOwned) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) + + ! Allocate globalArray and gatheredArray only on process 0 + call MPI_COMM_RANK( domain % dminfo % comm, curProc, err_tmp) + err = ior(err, err_tmp) + call MPI_COMM_SIZE( domain % dminfo % comm, nProcs, err_tmp) + err = ior(err, err_tmp) + + ! perform the initialization on the head processor + allocate(nCellsPerProc(nProcs)) + allocate(nCellsDisplacement(nProcs)) + + ! Gather nCellsOwned + call MPI_GATHER( nCellsOwned, 1, MPI_INTEGER, nCellsPerProc, 1, MPI_INTEGER, & + 0, domain % dminfo % comm, err_tmp) + err = ior(err, err_tmp) + + ! Set Displacement variable for GATHERV command + if (curProc.eq.0) then + nCellsGlobal = sum(nCellsPerProc) + allocate(indexToCellIDGathered(nCellsGlobal)) + nCellsDisplacement(1) = 0 + if (nProcs > 1) then + do iProc=2,nProcs + nCellsDisplacement(iProc) = nCellsDisplacement(iProc-1) + nCellsPerProc(iProc-1) + enddo + endif + else + ! Intel requires this be allocated even though it is not meaningful on the non-destination procs + allocate(indexToCellIDGathered(1)) + endif + + ! Gather indexToCellID + call MPI_GATHERV( indexToCellID, nCellsOwned, MPI_INTEGER, indexToCellIDGathered, & + nCellsPerProc, nCellsDisplacement, MPI_INTEGER, 0, domain % dminfo % comm, err_tmp) + err = ior(err, err_tmp) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + + if (curProc.eq.0) then + allocate(globalArrayThickness(nCellsGlobal), gatheredArrayThickness(nCellsGlobal)) + allocate(globalArrayBedTopography(nCellsGlobal), gatheredArrayBedTopography(nCellsGlobal)) + allocate(meshMask(nCellsGlobal)) + ismIceload(:,:) = 0.0 + ismBedtopo(:,:) = 0.0 + ismMask(:,:) = 0.0 + bedtopoSLgrid1D(:) = 0.0 + thicknessSLgrid1D(:) = 0.0 + maskSLgrid1D(:) = 0.0 + else + ! Intel requires these be allocated even though they are not meaningful on the non-destination procs + allocate(globalArrayThickness(1), gatheredArrayThickness(1)) + allocate(globalArrayBedTopography(1), gatheredArrayBedTopography(1)) + allocate(meshMask(1)) + endif + + ! Gather only the nCellsOwned from thickness and bedtopo (does not include Halos) + call MPI_GATHERV(thickness, nCellsOwned, MPI_DOUBLE, gatheredArrayThickness, nCellsPerProc, & + nCellsDisplacement, MPI_DOUBLE, 0, domain % dminfo % comm, err_tmp) + err = ior(err, err_tmp) + call MPI_GATHERV(bedTopography, nCellsOwned, MPI_DOUBLE, gatheredArrayBedTopography, nCellsPerProc, & + nCellsDisplacement, MPI_DOUBLE, 0, domain % dminfo % comm, err_tmp) + err = ior(err, err_tmp) + + if (curProc.eq.0) then + + ! First, check consistency in coupling interval set up in MALI and SLM + err = 0 + call mpas_pool_get_config(liConfigs, 'config_slm_coupling_interval', config_slm_coupling_interval) + read(config_slm_coupling_interval(1:4),*) slm_coupling_interval + call sl_drive_readnl(itersl, dtime, starttime) !SLM subroutine + if (slm_coupling_interval .NE. dtime) then + call mpas_log_write("The coupling interval in MALI and SLM settings are inconsistent", & + MPAS_LOG_ERR) + err = ior(err,1) + endif + + ! Rearrange data into CellID order + do iCell = 1,nCellsGlobal + globalArrayThickness(indexToCellIDGathered(iCell)) = gatheredArrayThickness(iCell) + globalArrayBedTopography(indexToCellIDGathered(iCell)) = gatheredArrayBedTopography(iCell) + meshMask(indexToCellIDGathered(iCell)) = 1 + enddo + + ! interpolate thickness, bedTopograpy, mesh mask to the Gaussian grid + call interpolate(toColValues, toRowValues, toSvalues, globalArrayThickness, thicknessSLgrid1D) + call interpolate(toColValues, toRowValues, toSvalues, globalArrayBedTopography, bedtopoSLgrid1D) + call interpolate(toColValues, toRowValues, toSvalues, meshMask, maskSLgrid1D) + + ! reformat the interpolated data + ismIceload = reshape(thicknessSLgrid1D, [nglv,2*nglv]) + ismBedtopo = reshape(bedtopoSLgrid1D, [nglv,2*nglv]) + ismMask = reshape(maskSLgrid1D, [nglv,2*nglv]) + + ! initialize coupling time step number. initial time is 0 + slmTimeStep = 0 + + ! set SLM unit number to the MALI output log file unit + unit_num_slm = domain % logInfo % outputLog % unitNum + + ! series of calling SLM routines + call sl_set_unit_num(unit_num_slm) + call sl_call_readnl + call sl_solver_checkpoint(itersl, dtime) + call sl_timewindow(slmTimeStep) + call sl_solver_init(itersl, starttime, ismIceload, ismBedtopo, ismMask) + call sl_deallocate_array + + endif + deallocate(globalArrayThickness) + deallocate(gatheredArrayThickness) + deallocate(globalArrayBedTopography) + deallocate(gatheredArrayBedTopography) + deallocate(meshMask) + +# else + call mpas_log_write("The sea-level model needs to be included in the compilation with 'SLM=true'", & + MPAS_LOG_ERR) + err = ior(err,1) +# endif + + !-------------------------------------------------------------------- + end subroutine slmodel_init + + + +!*********************************************************************** +! +! routine slmodel_solve +! +!> \brief Solves gravitationally consistent sea-level change +!> \author Holly Kyeore Han +!> \date January 2022 +!> \details +!> This wrapper routine calls the sea-level solver that takes in +!> ice thickness and provides sea-level change (i.e., changes in the +!> heights of the sea surface and the solid Earth surface associated +!> with ice sheet changes. The sea-level model is taken and modified +!> from Han et al. (2021, GMD, https://doi.org/10.5281/zenodo.5775235) +! +!----------------------------------------------------------------------- + + subroutine slmodel_solve(slmTimeStep, domain) + + use li_advection, only: li_update_geometry +#ifdef USE_SEALEVELMODEL + use sl_model_mod !< this is part of the SLM code + use sl_io_mod !< this is part of the SLM code + use user_specs_mod, only: nglv, dt1 !< this is part of the SLM code +#endif + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + integer, intent(in) :: slmTimeStep + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + +#ifdef USE_SEALEVELMODEL + type (mpas_pool_type), pointer :: meshPool !< mesh information + type (mpas_pool_type), pointer :: geometryPool !< geometry information + type (mpas_pool_type), pointer :: velocityPool !< velocity information + + real (kind=RKIND), dimension(:), pointer :: bedTopography, thickness + real (kind=RKIND), dimension(:), pointer :: bedTopographyChange + real (kind=RKIND), dimension(:), allocatable :: meshMask + real (kind=RKIND), dimension(nglv,2*nglv) :: ismIceload, ismMask + real (kind=RKIND), dimension(nglv,2*nglv) :: slmSLchange + real (kind=RKIND), dimension(nglv*2*nglv) :: slChangeSLgrid1D + real (kind=RKIND), dimension(nglv*2*nglv) :: thicknessSLgrid1D + real (kind=RKIND), dimension(nglv*2*nglv) :: maskSLgrid1D + + integer :: err, err_tmp + + integer :: itersl, dtime ! SLM variable + real :: starttime ! SLM variable + + err = 0 + err_tmp = 0 + + call mpas_pool_get_subpool(domain % blocklist % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'bedTopographyChange', bedTopographyChange) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) + + ! Allocate globalArray and gatheredArray only on process 0 + call MPI_COMM_RANK(domain % dminfo % comm, curProc, err_tmp) + err = ior(err, err_tmp) + + if (curProc.eq.0) then + allocate(globalArrayThickness(nCellsGlobal), gatheredArrayThickness(nCellsGlobal)) + allocate(globalArrayTopoChange(nCellsGlobal), gatheredArrayTopoChange(nCellsGlobal)) + allocate(meshMask(nCellsGlobal)) + ismIceload(:,:) = 0.0 + ismMask(:,:) = 0.0 + slmSLchange(:,:) = 0.0 + slChangeSLgrid1D(:) = 0.0 + thicknessSLgrid1D(:) = 0.0 + maskSLgrid1D(:) = 0.0 + else + ! Intel requires these be allocated even though they are not meaningful on the non-destination procs + allocate(globalArrayThickness(1), gatheredArrayThickness(1)) + allocate(globalArrayTopoChange(1), gatheredArrayTopoChange(1)) + allocate(meshMask(1)) + endif + + ! Gather only the nCellsOwned from ice thickness (does not include Halos) + call MPI_GATHERV(thickness, nCellsOwned, MPI_DOUBLE, gatheredArrayThickness, nCellsPerProc, & + nCellsDisplacement, MPI_DOUBLE, 0, domain % dminfo % comm, err_tmp) + err = ior(err, err_tmp) + + if (curProc.eq.0) then + + ! Rearrange thickness into CellID order + do iCell = 1,nCellsGlobal + globalArrayThickness(indexToCellIDGathered(iCell)) = gatheredArrayThickness(iCell) + meshMask(indexToCellIDGathered(iCell)) = 1 + enddo + + ! interpolate thickness to Gaussian grid + call interpolate(toColValues, toRowValues, toSvalues, globalArrayThickness, thicknessSLgrid1D) + call interpolate(toColValues, toRowValues, toSvalues, meshMask, maskSLgrid1D) + + ! reformat the interpolated data + ismIceload = reshape(thicknessSLgrid1D, [nglv,2*nglv]) + ismMask = reshape(maskSLgrid1D, [nglv,2*nglv]) + + ! series of calling SLM routines + call sl_drive_readnl(itersl, dtime, starttime) + call sl_call_readnl + call sl_solver_checkpoint(itersl, dtime) + call sl_timewindow(slmTimeStep) + call sl_solver(itersl, slmTimeStep, dtime, starttime, ismIceload, ismMask, slmSLchange) + call sl_deallocate_array + + ! reshape 2D array SLM output into 1D array + slChangeSLgrid1D = reshape(slmSLchange, [nglv*2*nglv]) + + ! interpolate sea-level change from GL grid to MALI mesh. + ! note: in the static sea-level theory, sea level and topography are globally defined !> + ! and negative of each other. That is, topography change is negative of sea-level change + call interpolate(fromColValues, fromRowValues, fromSValues, -1.0_RKIND*(slChangeSLgrid1D), & + globalArrayTopoChange) + + ! Rearrange back to index order + do iCell = 1,nCellsGlobal + gatheredArrayTopoChange(iCell) = globalArrayTopoChange(indexToCellIDGathered(iCell)) + enddo + + endif + + ! scatter output sea-level changes to processors + call MPI_SCATTERV(gatheredArrayTopoChange, nCellsPerProc, nCellsDisplacement, MPI_DOUBLE, & + bedTopographyChange, nCellsAll, MPI_DOUBLE, 0, domain % dminfo % comm, err_tmp) + err = ior(err, err_tmp) + + ! update bedTopography + bedTopography(:) = bedTopography(:) + bedTopographyChange(:) + + ! Perform Halo exchange update + call mpas_dmpar_field_halo_exch(domain,'bedTopography') + call li_update_geometry(geometryPool) + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) + err = ior(err, err_tmp) + + ! deallocate memory + deallocate(globalArrayThickness) + deallocate(gatheredArrayThickness) + deallocate(globalArrayTopoChange) + deallocate(gatheredArrayTopoChange) + deallocate(meshMask) +#endif + + !-------------------------------------------------------------------- + end subroutine slmodel_solve + + + +!*********************************************************************** +! +! routine interpolate +! +!> \brief Perform interpolation between MALI mesh and SLM grid +!> \author Holly Han +!> \date December 2021 +!> \details +!> This routine contains the sparse matrix multiplication +!> algorithm to interpolate between MPAS and Gaussian Grid. +!> Note: This routine is a copy of the inerpolation +!> routine written by Kristin Barton in the code +!> mpas_ocn_vel_self_attraction_loading.F in MPAS-Ocean, +!> with addition of reformatting the interpolated data +!> +!----------------------------------------------------------------------- + + subroutine interpolate(colValues, rowValues, sValues, dataIn, dataOut) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + integer, dimension(:), intent(in) :: rowValues, colValues + real (kind=RKIND), dimension(:), intent(in) :: sValues, dataIn + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: dataOut + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + real (kind=RKIND) :: rhs + integer :: n_S, n, nRow, nCol + + n_S = size(sValues) + n = 1 + rhs = 0.0_RKIND + + do while (n .LE. n_S) + nRow = rowValues(n) + do while ( (n.LT.(n_S)) .AND. (rowValues(n).EQ.nRow) ) + nCol = colValues(n) + rhs = rhs + dataIn(nCol) * sValues(n) + n = n + 1 + enddo + if ( (n.EQ.n_S) .AND. (rowValues(n).EQ.nRow) ) then + nCol = colValues(n) + rhs = rhs + dataIn(nCol) * sValues(n) + n = n + 1 + endif + dataOut(nRow) = rhs + rhs = 0.0_RKIND + enddo + + !-------------------------------------------------------------------- + end subroutine interpolate + + + +!*********************************************************************** +! +! routine interpolate_init +! +!> \brief Sets up interpolation between MALI and SLM native grids +!> \author Holly Han +!> \date December 2021 +!> \details +!> This routine reads in map (weight) files needed to interpolate +!> values of ice thicknesss, bedTopography, sea-level change +!> between native grid of MALI (unstructured) and SLM (Gaussian). +!> It also gathers and scatters data from and to multiple processors. +!> Note: A big portion of the routine is copied from routine +!> 'ocn_vel_self_attraction_loading_init' written by Kristin Barton +!> in the code smpas_ocn_vel_self_attraction_loading.F in MPAS-Ocean +! +!----------------------------------------------------------------------- + + subroutine interpolate_init(domain, err) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain !< Input/output: Domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + integer :: err_tmp + character (len=StrKIND), pointer :: config_MALI_to_SLM_weights_file + character (len=StrKIND), pointer :: config_SLM_to_MALI_weights_file + + ! NetCDF and weights file variables + integer :: toNcId, toNsDimId, toRowId, toColId, toSId + integer :: fromNcId, fromNsDimId, fromRowId, fromColId, fromSId + integer:: nMpasDimId, nGridDimId, toNsLen, fromNsLen + character (len = NF90_MAX_NAME) :: toNsName, fromNsName, nMpasName, nGridName + integer, pointer :: n_s + character(len=StrKIND) :: mpasToGridFile, gridToMpasFile + + ! MPI variables + integer :: curProc + + err = 0 + err_tmp = 0 + + call mpas_pool_get_config(liConfigs, 'config_MALI_to_SLM_weights_file', config_MALI_to_SLM_weights_file) + call mpas_pool_get_config(liConfigs, 'config_SLM_to_MALI_weights_file', config_SLM_to_MALI_weights_file) + + ! Begin MPI portion + call MPI_COMM_RANK( domain % dminfo % comm, curProc, err_tmp) + err = ior(err, err_tmp) + + !initialize interpolation + if (curProc.eq.0) then + + mpasToGridFile = trim(config_MALI_to_SLM_weights_file) + gridToMpasFile = trim(config_SLM_to_MALI_weights_file) + + ! Open netcdf weights files + call check( nf90_open(path = mpasToGridFile, mode = nf90_nowrite, ncid = toNcId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_open(path = gridToMpasFile, mode = nf90_nowrite, ncid = fromNcId), err_tmp) + err = ior(err, err_tmp) + + ! Get dimension ID + call check( nf90_inq_dimid(toNcId, "n_a", nMpasDimId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_dimid(toNcId, "n_s", toNsDimId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_dimid(fromNcId, "n_a", nGridDimId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_dimid(fromNcId, "n_s", fromNsDimId), err_tmp) + err = ior(err, err_tmp) + + ! Get Variable IDs + call check( nf90_inq_varid(toNcId, "row", toRowId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_varid(toNcId, "col", toColId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_varid(toNcId, "S", toSId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_varid(fromNcId, "row", fromRowId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_varid(fromNcId, "col", fromColId), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inq_varid(fromNcId, "S", fromSId), err_tmp) + err = ior(err, err_tmp) + + ! Get Dimension Length + call check( nf90_inquire_dimension(toNcId, toNsDimId, toNsName, toNsLen), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inquire_dimension(fromNcId, fromNsDimId, fromNsName, fromNsLen), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inquire_dimension(toNcId, nMpasDimId, nMpasName, nMpas), err_tmp) + err = ior(err, err_tmp) + call check( nf90_inquire_dimension(fromNcId, nGridDimId, nGridName, nGrid), err_tmp) + err = ior(err, err_tmp) + + ! Allocate matrices to read data into + allocate ( toRowValues (toNsLen) ) + allocate ( toColValues (toNsLen) ) + allocate ( toSValues (toNsLen) ) + allocate ( fromRowValues (fromNsLen) ) + allocate ( fromColValues (fromNsLen) ) + allocate ( fromSValues (fromNsLen) ) + + ! Retrieve data + call check( nf90_get_var(toNcId, toColId, toColValues(:) ), err_tmp) + err = ior(err, err_tmp) + call check( nf90_get_var(toNcId, toRowId, toRowValues(:) ), err_tmp) + err = ior(err, err_tmp) + call check( nf90_get_var(toNcId, toSId, toSValues(:) ), err_tmp) + err = ior(err, err_tmp) + call check( nf90_get_var(fromNcId, fromColId, fromColValues(:) ), err_tmp) + err = ior(err, err_tmp) + call check( nf90_get_var(fromNcId, fromRowId, fromRowValues(:) ), err_tmp) + err = ior(err, err_tmp) + call check( nf90_get_var(fromNcId, fromSId, fromSValues(:) ), err_tmp) + err = ior(err, err_tmp) + + endif + + !-------------------------------------------------------------------- + end subroutine interpolate_init + + + +!*********************************************************************** +! +! routine check +! +!> \brief Check status of netcdf operations +!> \author Holly Han +!> \date December 2021 +!> \details +!> This routine checks to status of the netcdf file +! +!----------------------------------------------------------------------- + + subroutine check(status, err) + + integer, intent ( in) :: status + integer, intent(inout) :: err + + if(status /= nf90_noerr) then + err = 1 + endif + !-------------------------------------------------------------------- + end subroutine check !*********************************************************************** diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_calving.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_calving.F index 51f94fb185fd..60b16d94b234 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_calving.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_calving.F @@ -105,7 +105,8 @@ subroutine li_calve_ice(domain, err) type (mpas_pool_type), pointer :: scratchPool ! calving-relevant config options - character (len=StrKIND), pointer :: config_calving + character (len=StrKIND), pointer :: config_calving, & + config_front_mass_bal_grounded logical, pointer :: config_print_calving_info, config_data_calving real(kind=RKIND), pointer :: config_calving_timescale @@ -141,6 +142,7 @@ subroutine li_calve_ice(domain, err) err_tmp = 0 call mpas_pool_get_config(liConfigs, 'config_calving', config_calving) + call mpas_pool_get_config(liConfigs, 'config_front_mass_bal_grounded', config_front_mass_bal_grounded) call mpas_pool_get_config(liConfigs, 'config_calving_timescale', config_calving_timescale) call mpas_pool_get_config(liConfigs, 'config_print_calving_info', config_print_calving_info) call mpas_pool_get_config(liConfigs, 'config_data_calving', config_data_calving) @@ -155,6 +157,13 @@ subroutine li_calve_ice(domain, err) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_array(meshPool, 'deltat', deltat) + ! Update mask and geometry before calling any calving routines. May not be necessary, but best be safe. + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) + err = ior(err, err_tmp) + call li_update_geometry(geometryPool) + ! based on the calving timescale, set the fraction of ice that calves if (config_calving_timescale > 0.0_RKIND) then calvingFraction = min(deltat/config_calving_timescale, 1.0_RKIND) @@ -254,6 +263,17 @@ subroutine li_calve_ice(domain, err) call specified_calving_velocity(domain, err_tmp) err = ior(err, err_tmp) + elseif (trim(config_calving) == 'ismip6_retreat') then + + if (trim(config_front_mass_bal_grounded) .ne. 'none') then + call mpas_log_write("config_front_mass_bal_grounded must be set to 'none' '// & + 'when config_calving = 'ismip6_retreat'.", MPAS_LOG_ERR) + err = 1 + else + call ismip6_retreat(domain, err_tmp) + err = ior(err, err_tmp) + end if + else call mpas_log_write("Invalid option for config_calving specified: " // trim(config_calving), MPAS_LOG_ERR) @@ -364,7 +384,7 @@ subroutine li_restore_calving_front(domain, err) type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: velocityPool - integer, pointer :: nCellsSolve, nVertLevels + integer, pointer :: nCells, nVertLevels logical, pointer :: & config_print_calving_info @@ -374,7 +394,8 @@ subroutine li_restore_calving_front(domain, err) config_dynamic_thickness integer, dimension(:), pointer :: & - cellMask ! bit mask describing whether ice is floating, dynamically active, etc. + cellMask, & ! bit mask describing whether ice is floating, dynamically active, etc. + indexToCellID real(kind=RKIND), dimension(:), pointer :: & layerCenterSigma ! vertical sigma coordinate at layer midpoints @@ -427,11 +448,12 @@ subroutine li_restore_calving_front(domain, err) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) ! get dimensions - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) ! get required fields from the mesh pool call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) ! get required fields from the geometry pool call mpas_pool_get_array(geometryPool, 'thickness', thickness) @@ -492,7 +514,7 @@ subroutine li_restore_calving_front(domain, err) restoreThickness = 0.0_RKIND ! loop over locally owned cells - do iCell = 1, nCellsSolve + do iCell = 1, nCells if (bedTopography(iCell) < config_sea_level) then @@ -506,7 +528,7 @@ subroutine li_restore_calving_front(domain, err) ! Save the difference (restoreThicknessMin - thickness) so as to keep track of energy non-conservation. if (config_print_calving_info) then - call mpas_log_write('Restore ice: iCell=$i, thickness=$r', intArgs=(/iCell/), realArgs=(/thickness(iCell)/)) + call mpas_log_write('Restore ice: indexToCellID=$i, thickness=$r', intArgs=(/indexToCellID(iCell)/), realArgs=(/thickness(iCell)/)) endif restoreThickness(iCell) = restoreThicknessMin - thickness(iCell) @@ -531,7 +553,7 @@ subroutine li_restore_calving_front(domain, err) ! Remove the ice and add it to calvingThickness. if (config_print_calving_info) then - call mpas_log_write('Remove ice: iCell=$i, thickness=$r', intArgs=(/iCell/), realArgs=(/thickness(iCell)/)) + call mpas_log_write('Remove ice: indexToCellID=$i, thickness=$r', intArgs=(/indexToCellID(iCell)/), realArgs=(/thickness(iCell)/)) endif calvingThickness(iCell) = thickness(iCell) @@ -1136,6 +1158,8 @@ subroutine eigencalving(domain, err) type (mpas_pool_type), pointer :: scratchPool real(kind=RKIND), pointer :: config_calving_eigencalving_parameter_scalar_value character (len=StrKIND), pointer :: config_calving_eigencalving_parameter_source + character (len=StrKIND), pointer :: config_damage_calving_method + real(kind=RKIND), pointer :: config_damage_calving_threshold logical, pointer :: config_print_calving_info real(kind=RKIND), pointer :: config_calving_thickness real (kind=RKIND), dimension(:), pointer :: eigencalvingParameter @@ -1144,6 +1168,8 @@ subroutine eigencalving(domain, err) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: thickness real (kind=RKIND), dimension(:), pointer :: calvingThickness + real (kind=RKIND), pointer :: calvingCFLdt + real (kind=RKIND), pointer :: dtCalvingCFLratio integer, dimension(:,:), pointer :: cellsOnCell ! list of cells that neighbor each cell integer, dimension(:), pointer :: nEdgesOnCell ! number of cells that border each cell integer, dimension(:), pointer :: cellMask @@ -1157,6 +1183,7 @@ subroutine eigencalving(domain, err) real(kind=RKIND) :: calvingSubtotal integer :: err_tmp logical :: applyToGrounded, applyToFloating, applyToGroundingLine + real (kind=RKIND), pointer :: totalRatebasedCalvedVolume, totalRatebasedUncalvedVolume err = 0 @@ -1171,6 +1198,8 @@ subroutine eigencalving(domain, err) call mpas_pool_get_config(liConfigs, 'config_calving_eigencalving_parameter_source', & config_calving_eigencalving_parameter_source) call mpas_pool_get_config(liConfigs, 'config_calving_thickness', config_calving_thickness) + call mpas_pool_get_config(liConfigs, 'config_damage_calving_threshold', config_damage_calving_threshold) + call mpas_pool_get_config(liConfigs, 'config_damage_calving_method', config_damage_calving_method) ! block loop block => domain % blocklist @@ -1196,11 +1225,14 @@ subroutine eigencalving(domain, err) call mpas_pool_get_array(velocityPool, 'eMin', eMin) call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) + call mpas_pool_get_array(geometryPool, 'calvingCFLdt', calvingCFLdt) + call mpas_pool_get_array(geometryPool, 'dtCalvingCFLratio', dtCalvingCFLratio) + call mpas_pool_get_array(geometryPool, 'totalRatebasedCalvedVolume', totalRatebasedCalvedVolume) + call mpas_pool_get_array(geometryPool, 'totalRatebasedUncalvedVolume', totalRatebasedUncalvedVolume) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) - ! get parameter value if (trim(config_calving_eigencalving_parameter_source) == 'scalar') then eigencalvingParameter = config_calving_eigencalving_parameter_scalar_value @@ -1217,19 +1249,37 @@ subroutine eigencalving(domain, err) realArgs=(/minval(eigencalvingParameter), maxval(eigencalvingParameter)/)) endif - ! update mask - call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) - err = ior(err, err_tmp) - calvingVelocity(:) = 0.0_RKIND ! First calculate the front retreat rate (Levermann eq. 1) calvingVelocity(:) = eigencalvingParameter(:) * max(0.0_RKIND, eMax(:)) * max(0.0_RKIND, eMin(:)) ! m/s call mpas_log_write("calling li_apply_front_ablation_velocity from eigencalving") - ! Convert calvingVelocity to calvingThickness - call li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool, & + ! Convert calvingVelocity to calvingThickness + call li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool, & calvingThickness, calvingVelocity, applyToGrounded, & - applyToFloating, applyToGroundingLine, domain, err) + applyToFloating, applyToGroundingLine, domain, calvingCFLdt, dtCalvingCFLratio, & + totalRatebasedCalvedVolume, totalRatebasedUncalvedVolume, err_tmp) + err = ior(err, err_tmp) + + if ( trim(config_damage_calving_method) == 'none' ) then + ! do nothing + elseif ( trim(config_damage_calving_method) == 'threshold' ) then + ! remove ice exceeding damage threshold + call mpas_log_write('config_damage_calving_method == threshold; & + removing ice with damage > $r', realArgs=(/config_damage_calving_threshold/)) + + call apply_calving_damage_threshold(meshPool, geometryPool, scratchPool, domain, err_tmp) + err = ior(err, err_tmp) + elseif ( trim(config_damage_calving_method) == 'calving_rate' ) then + call mpas_log_write('config_damage_calving_method == calving_rate & + is not supported with config_calving == eigencalving', MPAS_LOG_ERR) + err = 1 + return + else + call mpas_log_write('Invalid setting for config_damage_calving_method', MPAS_LOG_ERR) + err = 1 + return + endif ! Update halos on calvingThickness or faceMeltingThickness before ! applying it. ! Testing seemed to indicate this is not necessary, but I don't @@ -1239,7 +1289,6 @@ subroutine eigencalving(domain, err) call mpas_timer_start("halo updates") call mpas_dmpar_field_halo_exch(domain, 'calvingThickness') call mpas_timer_stop("halo updates") - ! === apply calving === thickness(:) = thickness(:) - calvingThickness(:) @@ -1345,6 +1394,8 @@ subroutine specified_calving_velocity(domain, err) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: thickness real (kind=RKIND), dimension(:), pointer :: calvingThickness + real (kind=RKIND), pointer :: calvingCFLdt + real (kind=RKIND), pointer :: dtCalvingCFLratio integer, dimension(:,:), pointer :: cellsOnCell ! list of cells that neighbor each cell integer, dimension(:), pointer :: nEdgesOnCell ! number of cells that border each cell integer, dimension(:), pointer :: cellMask @@ -1356,6 +1407,7 @@ subroutine specified_calving_velocity(domain, err) integer :: iCell, jCell, iNeighbor logical :: dynamicNeighbor real(kind=RKIND) :: calvingSubtotal + real (kind=RKIND), pointer :: totalRatebasedCalvedVolume, totalRatebasedUncalvedVolume integer :: err_tmp err = 0 @@ -1387,6 +1439,10 @@ subroutine specified_calving_velocity(domain, err) call mpas_pool_get_array(geometryPool, 'calvingVelocityData', calvingVelocityData) call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) + call mpas_pool_get_array(geometryPool, 'calvingCFLdt', calvingCFLdt) + call mpas_pool_get_array(geometryPool, 'dtCalvingCFLratio', dtCalvingCFLratio) + call mpas_pool_get_array(geometryPool, 'totalRatebasedCalvedVolume', totalRatebasedCalvedVolume) + call mpas_pool_get_array(geometryPool, 'totalRatebasedUncalvedVolume', totalRatebasedUncalvedVolume) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) @@ -1408,14 +1464,13 @@ subroutine specified_calving_velocity(domain, err) realArgs=(/minval(calvingVelocity), maxval(calvingVelocity)/)) endif - ! update mask - call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) - err = ior(err, err_tmp) - ! Convert calvingVelocity to calvingThickness call li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool, calvingThickness, calvingVelocity, & applyToGrounded=.true., applyToFloating=.true., applyToGroundingLine=.false., & - domain=domain, err=err_tmp) + domain=domain, maxDt=calvingCFLdt, CFLratio=dtCalvingCFLratio, & + totalAblatedVolume=totalRatebasedCalvedVolume, & + totalUnablatedVolume=totalRatebasedUncalvedVolume, & + err=err_tmp) err = ior(err, err_tmp) ! === apply calving === @@ -1520,17 +1575,26 @@ subroutine von_Mises_calving(domain, err) velocityPool, scratchPool, thermalPool real (kind=RKIND), pointer :: config_grounded_von_Mises_threshold_stress, & config_floating_von_Mises_threshold_stress, & - config_flowLawExponent, config_calving_speed_limit + config_flowLawExponent, config_calving_speed_limit, & + config_damage_calving_threshold + character (len=StrKIND), pointer :: config_grounded_von_Mises_threshold_stress_source, & + config_floating_von_Mises_threshold_stress_source + character (len=StrKIND), pointer :: config_damage_calving_method logical, pointer :: config_use_Albany_flowA_eqn_for_vM real (kind=RKIND), dimension(:), pointer :: eMax, eMin, & calvingVelocity, thickness, & - xvelmean, yvelmean, calvingThickness + xvelmean, yvelmean, calvingThickness, & + floatingVonMisesThresholdStress, & + groundedVonMisesThresholdStress real (kind=RKIND), dimension(:,:), pointer :: flowParamA, & temperature, layerThickness real (kind=RKIND), pointer :: config_default_flowParamA + real (kind=RKIND), pointer :: calvingCFLdt + real (kind=RKIND), pointer :: dtCalvingCFLratio integer, pointer :: nCells integer, dimension(:), pointer :: cellMask - real (kind=RKIND), dimension(:), pointer :: vonMisesStress + real (kind=RKIND), dimension(:), pointer :: vonMisesStress, damage + real (kind=RKIND), pointer :: totalRatebasedCalvedVolume, totalRatebasedUncalvedVolume logical :: applyToGrounded, applyToFloating, applyToGroundingLine err = 0 @@ -1540,14 +1604,14 @@ subroutine von_Mises_calving(domain, err) applyToFloating = .true. applyToGroundingLine = .false. + call mpas_pool_get_config(liConfigs, 'config_grounded_von_Mises_threshold_stress_source', config_grounded_von_Mises_threshold_stress_source) + call mpas_pool_get_config(liConfigs, 'config_floating_von_Mises_threshold_stress_source', config_floating_von_Mises_threshold_stress_source) call mpas_pool_get_config(liConfigs, 'config_grounded_von_Mises_threshold_stress', config_grounded_von_Mises_threshold_stress) call mpas_pool_get_config(liConfigs, 'config_floating_von_Mises_threshold_stress', config_floating_von_Mises_threshold_stress) call mpas_pool_get_config(liConfigs, 'config_calving_speed_limit', config_calving_speed_limit) + call mpas_pool_get_config(liConfigs, 'config_damage_calving_threshold', config_damage_calving_threshold) + call mpas_pool_get_config(liConfigs, 'config_damage_calving_method', config_damage_calving_method) - if ( config_grounded_von_Mises_threshold_stress <= 0.0_RKIND ) then - call mpas_log_write("config_grounded_von_Mises_threshold_stress must be >0.0", MPAS_LOG_ERR) - err = 1 - endif !call mpas_pool_get_config(liConfigs, 'config_default_flowParamA', !config_default_flowParamA) ! REMOVE THIS ONCE YOU CAN GET A FROM !ALBANY!!!!! @@ -1577,11 +1641,54 @@ subroutine von_Mises_calving(domain, err) call mpas_pool_get_array(velocityPool, 'yvelmean', yvelmean) call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) call mpas_pool_get_array(geometryPool, 'calvingVelocity', calvingVelocity) + call mpas_pool_get_array(geometryPool, 'calvingCFLdt', calvingCFLdt) + call mpas_pool_get_array(geometryPool, 'dtCalvingCFLratio', dtCalvingCFLratio) call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'groundedVonMisesThresholdStress', groundedVonMisesThresholdStress) + call mpas_pool_get_array(geometryPool, 'floatingVonMisesThresholdStress', floatingVonMisesThresholdStress) + call mpas_pool_get_array(geometryPool, 'totalRatebasedCalvedVolume', totalRatebasedCalvedVolume) + call mpas_pool_get_array(geometryPool, 'totalRatebasedUncalvedVolume', totalRatebasedUncalvedVolume) call mpas_pool_get_array(thermalPool, 'temperature', temperature) - vonMisesStress(:) = 0.0_RKIND + ! get parameter value and check that values are valid + if (trim(config_grounded_von_Mises_threshold_stress_source) == 'scalar') then + groundedVonMisesThresholdStress(:) = config_grounded_von_Mises_threshold_stress + elseif (trim(config_grounded_von_Mises_threshold_stress_source) == 'data') then + ! do nothing - use value from input file + else + err = 1 + call mpas_log_write("Invalid value specified for option config_grounded_von_Mises_threshold_stress_source" // & + config_grounded_von_Mises_threshold_stress_source, MPAS_LOG_ERR) + endif + + if ( minval(groundedVonMisesThresholdStress(1:nCells)) <= 0.0_RKIND ) then + err = 1 + call mpas_log_write("groundedVonMisesThresholdStress must be >0.0", MPAS_LOG_ERR) + endif + + if (trim(config_floating_von_Mises_threshold_stress_source) == 'scalar') then + floatingVonMisesThresholdStress(:) = config_floating_von_Mises_threshold_stress + elseif (trim(config_floating_von_Mises_threshold_stress_source) == 'data') then + ! do nothing - use value from input file + else + err = 1 + call mpas_log_write("Invalid value specified for option config_floating_von_Mises_threshold_stress_source" // & + config_floating_von_Mises_threshold_stress_source, MPAS_LOG_ERR) + endif + if ( minval(floatingVonMisesThresholdStress(:)) < 0.0_RKIND ) then + err = 1 + call mpas_log_write("floatingVonMisesThresholdStress must be >=0.0", MPAS_LOG_ERR) + endif + + ! If von Mises threshold stresses contain invalid values, do not + ! continue. + if ( err == 1 ) then + return + endif + + vonMisesStress(:) = 0.0_RKIND + ! get flowParamA from MPAS or use Albany-like equation if ( config_use_Albany_flowA_eqn_for_vM ) then !calculate Albany-type flowParamA @@ -1591,11 +1698,11 @@ subroutine von_Mises_calving(domain, err) call li_calculate_flowParamA(meshPool, temperature, thickness,flowParamA,err) ! Get MPAS flowParamA endif - !Using a depth-averaged ice viscosity parameter B_depthAvg - !=sum(layerThickness(:,iCell) * - !flowParamA(:,iCell)**(-1.0_RKIND/config_flowLawExponent), dim=1) / - !thickness(iCell) - ! Calculate effective von Mises stress. + !Using a depth-averaged ice viscosity parameter B_depthAvg + !=sum(layerThickness(:,iCell) * + !flowParamA(:,iCell)**(-1.0_RKIND/config_flowLawExponent), dim=1) / + !thickness(iCell) + ! Calculate effective von Mises stress. calvingVelocity(:) = 0.0_RKIND do iCell = 1,nCells @@ -1609,22 +1716,28 @@ subroutine von_Mises_calving(domain, err) ! Calculate calving velocity for grounded cells at marine margin if ( .not. li_mask_is_floating_ice(cellMask(iCell)) ) then calvingVelocity(iCell) = min(sqrt(xvelmean(iCell)**2.0_RKIND + yvelmean(iCell)**2.0_RKIND) * & - vonMisesStress(iCell) / config_grounded_von_Mises_threshold_stress, config_calving_speed_limit) + vonMisesStress(iCell) / groundedVonMisesThresholdStress(iCell), config_calving_speed_limit) ! If config_floating_von_Mises_threshold_stress is not 0.0, calculate ! calvingVelocity. If config_floating_von_Mises_threshold_stress is ! 0.0, remove floating ice in loop below. elseif ( li_mask_is_floating_ice(cellMask(iCell)) .and. config_floating_von_Mises_threshold_stress .ne. 0.0_RKIND) then calvingVelocity(iCell) = min(sqrt(xvelmean(iCell)**2 + yvelmean(iCell)**2) * & - vonMisesStress(iCell) / config_floating_von_Mises_threshold_stress, config_calving_speed_limit) + vonMisesStress(iCell) / floatingVonMisesThresholdStress(iCell), config_calving_speed_limit) endif enddo + call mpas_timer_start("halo updates") + call mpas_dmpar_field_halo_exch(domain, 'calvingVelocity') + call mpas_timer_stop("halo updates") call mpas_log_write("calling li_apply_front_ablation_velocity from von Mises stress calving routine") ! Convert calvingVelocity to calvingThickness call li_apply_front_ablation_velocity(meshPool, geometryPool,velocityPool, & calvingThickness, calvingVelocity, applyToGrounded, & - applyToFloating, applyToGroundingLine, domain, err) + applyToFloating, applyToGroundingLine, domain, & + calvingCFLdt, dtCalvingCFLratio, & + totalRatebasedCalvedVolume, totalRatebasedUncalvedVolume, err_tmp) + err = ior(err, err_tmp) ! Update halos on calvingThickness or faceMeltingThickness before ! applying it. ! Testing seemed to indicate this is not necessary, but I don't @@ -1661,6 +1774,35 @@ subroutine von_Mises_calving(domain, err) enddo endif + if ( trim(config_damage_calving_method) == 'none' ) then + ! do nothing + elseif ( trim(config_damage_calving_method) == 'threshold' ) then + ! remove ice exceeding damage threshold + call mpas_log_write('config_damage_calving_method == threshold; & + removing ice with damage > $r', realArgs=(/config_damage_calving_threshold/)) + + call apply_calving_damage_threshold(meshPool, geometryPool, scratchPool, domain, err_tmp) + err = ior(err, err_tmp) + elseif ( trim(config_damage_calving_method) == 'calving_rate' ) then + call mpas_log_write('config_damage_calving_method == calving_rate & + is not supported with config_calving == von_Mises_stress', MPAS_LOG_ERR) + err = 1 + return + else + call mpas_log_write('Invalid setting for config_damage_calving_method', MPAS_LOG_ERR) + err = 1 + return + endif + + ! Update halos on calvingThickness or faceMeltingThickness before + ! applying it. + ! Testing seemed to indicate this is not necessary, but I don't + ! understand + ! why not, so leaving it. + ! NOTE: THIS WILL NOT WORK ON MULTIPLE BLOCKS PER PROCESSOR + call mpas_timer_start("halo updates") + call mpas_dmpar_field_halo_exch(domain, 'calvingThickness') + call mpas_timer_stop("halo updates") ! === apply calving === thickness(:) = thickness(:) - calvingThickness(:) @@ -1670,7 +1812,7 @@ subroutine von_Mises_calving(domain, err) err = ior(err, err_tmp) call remove_small_islands(meshPool, geometryPool) - + block => block % next enddo ! associated(block) @@ -1679,6 +1821,274 @@ end subroutine von_Mises_calving !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! +! routine ismip6_retreat +! +!> /brief Use ISMIP6 retreat parameterization for Greenland (Slater et al., 2019, 2020). +!> /author Trevor Hillebrand +!> /date November 2021 +!> /details This routine applies the ISMIP6 glacier retreat parateterization +!> based on ocean thermal forcing and subglacial discharge. This routine uses multiple +!> time-levels fields provided by ISMIP6. Once we use E3SM fields, this will need to be restructured. +!> The routine searches for an input stream named 'ismip6-gis', from which it reads ismip6Runoff and +!> ismip6_2dThermalForcing fields from the previous forcing time whenever the mostRecentAccessTime +!> attribute of the ismip6-gis stream is updated. It then calculates calvingVelocity based on +!> the change in ismip6Runoff and ismip6_2dThermalForcing between the two most recent time-levels, and +!> calls apply_front_ablation_velocity to calculate a calvingThickness. config_front_mass_bal_grounded +!> must be set to 'none' when using this routine. +!> Slater, D. A., Straneo, F., Felikson, D., Little, C. M., Goelzer, H., +!> Fettweis, X., & Holte, J. (2019). +!> Estimating Greenland tidewater glacier retreat driven by submarine melting. +!> The Cryosphere, 13(9), 2489-2509. +!> https://doi.org/10.5194/tc-13-2489-2019 +!> Slater, D. A., Felikson, D., Straneo, F., Goelzer, H., Little, C. M., +!> Morlighem, M., et al. (2020). +!> Twenty-first century ocean forcing of the Greenland ice sheet for modelling +!> of sea level contribution. +!> The Cryosphere, 14(3), 985-1008. https://doi.org/10.5194/tc-14-985-2020 + subroutine ismip6_retreat(domain, err) + + use li_diagnostic_vars + use mpas_timekeeping + use mpas_stream_manager + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: & + domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer :: iCell, jCell, iEdge, iNeighbor, err_tmp + type (block_type), pointer :: block + integer, dimension(:,:), pointer :: cellsOnCell + type (mpas_pool_type), pointer :: geometryPool, meshPool, & + velocityPool + real (kind=RKIND), pointer :: config_ismip6_retreat_k, seaLevel + logical, pointer :: config_do_restart + real (kind=RKIND), dimension(:), pointer :: & + calvingVelocity, thickness, & + xvelmean, yvelmean, calvingThickness, & + bedTopography + real (kind=RKIND), pointer :: calvingCFLdt + real (kind=RKIND), pointer :: dtCalvingCFLratio + integer, pointer :: nCells, timestepNumber + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: cellMask, nEdgesOnCell + real (kind=RKIND) :: waterDepth + real (kind=RKIND), dimension(:), pointer :: dvEdge + real (kind=RKIND), dimension(:), pointer :: TFocean, ismip6Runoff + real (kind=RKIND), dimension(:), pointer :: TFoceanPrevious, ismip6RunoffPrevious + real (kind=RKIND), dimension(:), pointer :: TFoceanCurrent, ismip6RunoffCurrent + real (kind=RKIND), dimension(:), allocatable :: submergedArea + real (kind=RKIND) :: deltatForcing ! time between forcing updates + type (MPAS_Time_Type), save :: forcingTime, forcingTimeOld + character (len=StrKIND), pointer :: forcingTimeStamp + character(len=StrKIND) :: forcingTimeOldStamp + type (MPAS_stream_list_type), pointer :: stream_cursor + logical :: streamFound ! used to throw an error if required stream is not found + real (kind=RKIND), pointer :: totalRatebasedCalvedVolume, totalRatebasedUncalvedVolume + + call mpas_pool_get_config(liConfigs, 'config_ismip6_retreat_k', config_ismip6_retreat_k) + call mpas_pool_get_config(liConfigs, 'config_sea_level', seaLevel) + call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) + + if (config_ismip6_retreat_k .ge. 0.0) then + call mpas_log_write('Error: config_ismip6_retreat_k should be negative, but is >= 0.0.') + err = 1 + endif + + block => domain % blocklist + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + ! get fields + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'forcingTimeStamp', forcingTimeStamp) + call mpas_pool_get_array(meshPool, 'timestepNumber', timestepNumber) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) + call mpas_pool_get_array(geometryPool, 'calvingVelocity', calvingVelocity) + call mpas_pool_get_array(geometryPool, 'calvingCFLdt', calvingCFLdt) + call mpas_pool_get_array(geometryPool, 'dtCalvingCFLratio', dtCalvingCFLratio) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(velocityPool, 'xvelmean', xvelmean) + call mpas_pool_get_array(velocityPool, 'yvelmean', yvelmean) + call mpas_pool_get_array(geometryPool, 'ismip6_2dThermalForcing', TFocean) + call mpas_pool_get_array(geometryPool, 'ismip6Runoff', ismip6Runoff) + call mpas_pool_get_array(geometryPool, 'ismip6_2dThermalForcingPrevious', TFoceanPrevious) + call mpas_pool_get_array(geometryPool, 'ismip6RunoffPrevious', ismip6RunoffPrevious) + call mpas_pool_get_array(geometryPool, 'ismip6_2dThermalForcingCurrent', TFoceanCurrent) + call mpas_pool_get_array(geometryPool, 'ismip6RunoffCurrent', ismip6RunoffCurrent) + call mpas_pool_get_array(geometryPool, 'totalRatebasedCalvedVolume', totalRatebasedCalvedVolume) + call mpas_pool_get_array(geometryPool, 'totalRatebasedUncalvedVolume', totalRatebasedUncalvedVolume) + + ! submergedArea used in runoff unit conversion + allocate(submergedArea(nCells+1)) + + streamFound = .false. ! Changed to true if ismip6-gis stream is found, otherwise throws error + stream_cursor => domain % streamManager % streams % head + do while (associated(stream_cursor)) + ! Input stream with forcings must be called 'ismip6-gis', or this will throw an error. + if ( trim(stream_cursor % name) == 'ismip6-gis' .and. (stream_cursor % valid) ) then + streamFound = .true. + if (timestepNumber == 1) then + ! On the first timestep of a cold start OR restart initialize all needed fields by forcing a read of + ! the previous forcing data on the first timestep. This could be potentially be an unnecessary read on the + ! initial time of a restart run, but that is a small cost for simplifying logic and making the initial time of both + ! cold starts and restarts behave the same. The potentially extra read does not affect the algorithm. + + ! Use forcing fields and time from most recent time in file, which was read on init. + call mpas_get_time(stream_cursor%mostRecentAccessTime, dateTimeString=forcingTimeStamp, ierr=err_tmp) + err = ior(err, err_tmp) + + TFoceanCurrent = TFocean + ismip6RunoffCurrent = ismip6Runoff + + ! Force a read of this stream, and use the second most recent time in the file + call mpas_stream_mgr_read(domain % streamManager, streamID = stream_cursor % name, rightNow = .true., & + when = forcingTimeStamp, whence = MPAS_STREAM_LATEST_STRICTLY_BEFORE, saveActualWhen= .true., ierr=err_tmp) + err = ior(err, err_tmp) + + call mpas_get_time(stream_cursor%mostRecentAccessTime, dateTimeString=forcingTimeOldStamp, ierr=err_tmp) + err = ior(err, err_tmp) + + TFoceanPrevious = TFocean + ismip6RunoffPrevious = ismip6Runoff + + call mpas_log_write(" * Forced a read of input stream 'ismip6-gis'" // & + " from time: " // trim(forcingTimeOldStamp)) + + call mpas_set_time(forcingTime, dateTimeString=forcingTimeStamp, ierr=err_tmp) + err = ior(err, err_tmp) + call mpas_set_time(forcingTimeOld, dateTimeString=forcingTimeOldStamp, ierr=err_tmp) + err = ior(err, err_tmp) + + ! Do not overwrite forcing fields with values from previous time + ismip6Runoff = ismip6RunoffCurrent + TFocean = TFoceanCurrent + elseif (forcingTime < stream_cursor % mostRecentAccessTime) then + TFoceanPrevious = TFoceanCurrent + ismip6RunoffPrevious = ismip6RunoffCurrent + TFoceanCurrent = TFocean + ismip6RunoffCurrent = ismip6Runoff + + forcingTimeOld = forcingTime + forcingTime = stream_cursor % mostRecentAccessTime + call mpas_get_time(forcingTime, dateTimeString=forcingTimeStamp, ierr=err_tmp) + err = ior(err, err_tmp) + call mpas_get_time(forcingTimeOld, dateTimeString=forcingTimeOldStamp, ierr=err_tmp) + err = ior(err, err_tmp) + call mpas_log_write(" * ismip6 retreat forcings have been updated:" // & + " forcingTime: " // trim(forcingTimeStamp) // & + "; forcingTimeOld: " // trim(forcingTimeOldStamp)) + else + call mpas_log_write(" * No new forcing times for ismip6 retreat this timestep.") + endif + exit ! We have processed the stream we wanted. + endif + stream_cursor => stream_cursor % next + enddo ! end loop over stream_cursors + + ! check that the ismip6-gis stream was found + if (.not. streamFound) then + call mpas_log_write('Input stream ismip6-gis is required for config_calving = ismip6_retreat, ' // & + 'but was not found.', MPAS_LOG_ERR) + err = 1 + endif + ! Get submerged area of each cell to convert from kg m^{-2} s^{-1} to m^3 s^{-1} + ! TODO: ensure that this unit conversion is still appropriate when we + ! eventually use this subroutine with fields passed from the E3SM coupler + ! rather than external ISMIP6 forcings. + submergedArea(:) = 0.0_RKIND + do iCell = 1, nCells + if ( li_mask_is_dynamic_margin(cellMask(iCell)) .and. bedTopography(iCell) < seaLevel ) then + waterDepth = max(0.0_RKIND, seaLevel - bedTopography(iCell)) + do iNeighbor = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(iNeighbor, iCell) + jCell = cellsOnCell(iNeighbor, iCell) + ! sum up length of edges adjacent to open ocean or non-dynamic cells + if ( (.not. li_mask_is_dynamic_ice(cellMask(jCell))) & + .and. (bedTopography(jCell) < seaLevel) ) then + submergedArea(iCell) = submergedArea(iCell) + dvEdge(iEdge) * waterDepth + endif + enddo + endif + enddo + + ! Get the time between forcings to calculate retreat rate. + call mpas_get_timeInterval(forcingTime - forcingTimeOld, dt=deltatForcing) + call mpas_log_write("ismip6 retreat deltatForcing = $r", realArgs = (/deltatForcing/)) + + ! This if-statement is probably unnecessary, but this ensures there is no divide-by-zero error + ! if somehow deltatForcing = 0.0. + if (forcingTime .ne. forcingTimeOld) then + do iCell=1, nCells + ! For now, hard-coding factor of 4.0 to roughly convert mean annual to mean summer runoff. + ! Factor of 1000.0 is freshwater density. + ! TODO: ensure that this scaling factor is still appropriate when we + ! eventually use this subroutine with fields passed from the E3SM coupler + ! rather than external ISMIP6 forcings. + calvingVelocity(iCell) = max(-1.0_RKIND * config_ismip6_retreat_k * ( ( (4.0_RKIND * submergedArea(iCell) & + * ismip6Runoff(iCell) / 1000.0_RKIND)**0.4_RKIND * TFocean(iCell) ) - & + ( (4.0_RKIND * submergedArea(iCell) * ismip6RunoffPrevious(iCell) / 1000.0_RKIND)**0.4_RKIND & + * TFoceanPrevious(iCell) ) ) / deltatForcing + & + sqrt(xvelmean(iCell)**2.0_RKIND + yvelmean(iCell)**2.0_RKIND), 0.0_RKIND) + enddo + else ! throw an error if the forcing times are the same + call mpas_log_write("Forcings used in ismip6_retreat have the same timestamp. Check xtime in the input file(s).") + err = 1 + endif + + ! Testing indicates this halo update is necessary before calling li_apply_front_ablation_velocity. + call mpas_timer_start("halo updates") + call mpas_dmpar_field_halo_exch(domain, 'calvingVelocity') + call mpas_timer_stop("halo updates") + + call mpas_log_write("calling li_apply_front_ablation_velocity from ismip6 retreat routine") + ! Convert calvingVelocity to calvingThickness + call li_apply_front_ablation_velocity(meshPool, geometryPool,velocityPool, & + calvingThickness, calvingVelocity, applyToGrounded=.true., & + applyToFloating=.true., applyToGroundingLine=.false., & + domain=domain, maxDt=calvingCFLdt, CFLratio=dtCalvingCFLratio, & + totalAblatedVolume=totalRatebasedCalvedVolume, & + totalUnablatedVolume=totalRatebasedUncalvedVolume, & + err=err_tmp) + err = ior(err, err_tmp) + + ! Update halos on calvingThickness before applying it. + ! NOTE: THIS WILL NOT WORK ON MULTIPLE BLOCKS PER PROCESSOR + call mpas_timer_start("halo updates") + call mpas_dmpar_field_halo_exch(domain, 'calvingThickness') + call mpas_timer_stop("halo updates") + + ! === apply calving === + thickness(:) = thickness(:) - calvingThickness(:) + + ! update mask + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) + err = ior(err, err_tmp) + call remove_small_islands(meshPool, geometryPool) + + deallocate(submergedArea) + + end subroutine ismip6_retreat +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! ! routine li_apply_front_ablation_velocity ! !> \brief Convert a calving or melting velocity to an ice thickness removal @@ -1719,12 +2129,16 @@ end subroutine von_Mises_calving !> otherwise it is applied to the last grounded cell. !> If applyToFloating = .true., ablation is applied to dynamic floating margin cells !> The output of this routine is calvingThickness or faceMeltingThickness, which then needs to be applied to thickness -!> by the calling routine. The calling routine should perform a halo update -!> after the call and before applying ablation. +!> by the calling routine. + +!> IMPORTANT: The calling routine may need to perform a halo update on calving or melting velocity +!> before the call. Testing shows this is necessary for von Mises calving, but not for eigencalving, for instance. +!> The calling routine should always perform a halo update on calving or melting thickness after the call and before applying ablation. !----------------------------------------------------------------------- subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool, ablationThickness, ablationVelocity, & - applyToGrounded, applyToFloating, applyToGroundingLine, domain, err) + applyToGrounded, applyToFloating, applyToGroundingLine, domain, maxDt, CFLratio, & + totalAblatedVolume, totalUnablatedVolume, err) use ieee_arithmetic, only : ieee_is_nan @@ -1745,9 +2159,17 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool !----------------------------------------------------------------- ! output variables !----------------------------------------------------------------- + real (kind=RKIND), optional :: maxDt + !< Output: an approximation of the max allowable dt based on a CFL-like condition calculated from ablation velocity + real (kind=RKIND), optional :: CFLratio + !< Output: the ratio of the actual timestep being applied to the maximum allowable timestep from the CFL-like condition + real (kind=RKIND), optional :: totalAblatedVolume + !< Output: the total ablated volume + real (kind=RKIND), optional :: totalUnablatedVolume + !< Output: the total unablated volume integer, intent(out) :: err !< Output: error flag - integer, pointer :: nEdges, nCells, nCellsSolve, maxEdges + integer, pointer :: nEdges, nEdgesSolve, nCells, nCellsSolve, maxEdges integer :: iEdge, iCell, jCell, kCell, iNeighbor, jNeighbor integer :: nEmptyNeighbors, nGroundedNeighbors, counter, nTwoCellsBack, nOneCellBack real (kind=RKIND), dimension(:), pointer :: thickness @@ -1755,11 +2177,14 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool real (kind=RKIND), dimension(:), pointer :: lowerSurface integer, dimension(:,:), pointer :: cellsOnCell ! list of cells that neighbor each cell integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge integer, dimension(:), pointer :: cellMask, edgeMask integer, dimension(:), pointer :: frontAblationMask real (kind=RKIND), dimension(:), pointer :: calvingThickness, faceMeltingThickness real (kind=RKIND), pointer :: config_sea_level - real (kind=RKIND), dimension(:), pointer :: dvEdge + real (kind=RKIND), pointer :: config_calving_error_threshold + logical, pointer :: config_distribute_unablatedVolumeDynCell + real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: calvingVelocity, faceMeltSpeed real (kind=RKIND), dimension(:), pointer :: areaCell @@ -1786,18 +2211,24 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool real(kind=RKIND), dimension(6) :: localInfo, globalInfo real(kind=RKIND) :: edgeLengthScaling real(kind=RKIND), parameter :: ablationSmallThk = 1.0e-8_RKIND ! in meters, a small thickness threshold - integer :: err_tmp + real(kind=RKIND) :: minOfMaxAllowableDt + integer :: err_tmp, nDynNeighbors err = 0 err_tmp = 0 call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_calving_error_threshold', config_calving_error_threshold) + call mpas_pool_get_config(liConfigs, 'config_distribute_unablatedVolumeDynCell', config_distribute_unablatedVolumeDynCell) call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'maxEdges', maxEdges) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) @@ -1840,8 +2271,10 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool ! margin, (2) have at least one neighboring cell without ice, (3) contain ! grounded ice, and (4) have bed topography below sea level. ! OR is adjacent to an inactive floating margin cell - if (li_mask_is_grounding_line(cellMask(iCell)) & - !< GL here means cell is grounded but has a neighbor that is floating or ocean + if (li_mask_is_grounded_ice(cellMask(iCell)) & + ! GL here means cell is grounded but has a neighbor that is floating or ocean. + ! Note that as of Oct 2022, this is no longer the general + ! definition of the grounding line throughout the code. .and. bedTopography(iCell) < config_sea_level & .and. li_mask_is_dynamic_ice(cellMask(iCell)) ) then @@ -1921,6 +2354,18 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool endif enddo + ! Calculate an approximate ablation CFL limiting dt + if (present(maxDt)) then + minOfMaxAllowableDt = 1.0e16_RKIND ! Initialize to large number + do iEdge = 1, nEdgesSolve + if ((frontAblationMask(cellsOnEdge(1,iEdge)) > 0) .or. (frontAblationMask(cellsOnEdge(2,iEdge)) > 0)) then + minOfMaxAllowableDt = min(minOfMaxAllowableDt, & + 0.5_RKIND * dcEdge(iEdge) / & + (max(ablationVelocity(cellsOnEdge(1,iEdge)), ablationVelocity(cellsOnEdge(2,iEdge))) + 1.0E-18_RKIND) ) + endif + enddo + endif + ! Init fields for accounting ablationThickness(:) = 0.0_RKIND ablatedVolumeNonDynCell(:) = 0.0_RKIND @@ -2097,6 +2542,9 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool ablationThickness(iCell) = removeVolumeHere / areaCell(iCell) ablatedVolumeNonDynCell(iCell) = removeVolumeHere unablatedVolumeNonDynCell(iCell) = requiredAblationVolumeNonDynCell(iCell) - removeVolumeHere + if (bedTopography(iCell) >= config_sea_level) then + unablatedVolumeNonDynCell(iCell) = 0.0_RKIND ! Ignore leftover potential calving when we hit sea level + endif cellVolume(iCell) = cellVolume(iCell) - removeVolumeHere if (iCell <= nCellsSolve) ablationSubtotal1 = ablationSubtotal1 + removeVolumeHere endif @@ -2141,7 +2589,7 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool .and. li_mask_is_margin(cellMask(iCell)) ) then ! that is at the edge of the ice do iNeighbor = 1, nEdgesOnCell(iCell) jCell = cellsOnCell(iNeighbor, iCell) - if ((.not. li_mask_is_ice(cellMask(jCell))) .and. (bedTopography(jCell) <= config_sea_level)) then + if ((.not. li_mask_is_ice(cellMask(jCell))) .and. (bedTopography(jCell) < config_sea_level)) then iEdge = edgesOnCell(iNeighbor, iCell) edgeLengthScaling = scale_edge_length(angleEdge(iEdge), uvelForAblation(iCell), vvelForAblation(iCell)) requiredAblationVolumeDynEdge(iEdge) = ablationVelocity(iCell) * & @@ -2173,7 +2621,7 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool endif enddo - ! Now that we know calvLengthCell, pass along the required calving volume relative to the interface length + ! Now that we know ablateLengthCell, pass along the required calving volume relative to the interface length if ( ablateLengthCell > 0.0_RKIND ) then do iNeighbor = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(iNeighbor, iCell) @@ -2189,8 +2637,11 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool endif requiredAblationVolumeDynEdge(iEdge) = ablateLengthEdge / ablateLengthCell * volumeAvailableToPass unablatedVolumeNonDynCell(iCell) = unablatedVolumeNonDynCell(iCell) - requiredAblationVolumeDynEdge(iEdge) - !call mpas_log_write(" Passed calving $r from non-dynamic cell $i to dynamic cell $i", & - ! realArgs=(/requiredAblationVolumeDynEdge(iEdge)/), intArgs=(/iCell, jCell/)) + !call mpas_log_write(" Passed calving $r from non-dynamic cell $i to dynamic cell $i", & + ! realArgs=(/requiredAblationVolumeDynEdge(iEdge)/), intArgs=(/iCell, jCell/)) ! Note: change to global IDs + if (bedTopography(jCell) >= config_sea_level) then + requiredAblationVolumeDynEdge(iEdge) = 0.0_RKIND ! Don't pass this further if it would go above sea level + endif endif enddo endif @@ -2202,7 +2653,7 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool ! c. Now apply ablation to each cell do iCell = 1, nCells - if ((li_mask_is_dynamic_ice(cellMask(iCell))) .and. (bedTopography(iCell) <= config_sea_level)) then + if ((li_mask_is_dynamic_ice(cellMask(iCell))) .and. (bedTopography(iCell) < config_sea_level)) then ! Can loop over all dyn cells - only ones with calving on their edges will have calving applied. ! Note, we ignore any leftover calving/melting if it would be applied to cells where the bed is above sea level. do iNeighbor = 1, nEdgesOnCell(iCell) @@ -2220,8 +2671,6 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool if (iCell <= nCellsSolve) ablationSubtotal2 = ablationSubtotal2 + removeVolumeHere endif enddo - !call mpas_log_write("Done calculating ablation for dynamic floating cells. Removed $r m^3", realArgs=(/calvingSubtotal2/)) - ! Clean up to account for roundoff level errors that can occur do iCell = 1, nCells @@ -2230,7 +2679,69 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool endif enddo - ! Clean up - zap any stranded ice. This only needs to be considered for floating ice. + if ( config_distribute_unablatedVolumeDynCell ) then + ! 3. Distribute unablatedVolumeDynCell among neighboring cells. This is + ! necesssary when a cell is fully depleted but still has not ablated as + ! much ice as required by the ablation parameterization. This still may + ! result in large error for very high ablation rates, which should be + ! prevented by limiting the timestep based on the ablation velocity. + + ! a. Calculate volume to be distributed evenly among neighboring dynamic cells + do iCell = 1, nCells + if ( (unablatedVolumeDynCell(iCell) > 0.0_RKIND) ) then + nDynNeighbors = 0 + ! Count neighbors between which to evenly distribute + ! unablatedVolumeDynCell + do iEdge = 1, nEdgesOnCell(iCell) + iNeighbor = cellsOnCell(iEdge, iCell) + if ((li_mask_is_dynamic_ice(cellMask(iNeighbor))) .and. (bedTopography(iNeighbor) < config_sea_level) & + .and. ( cellVolume(iNeighbor) > (ablationSmallThk * areaCell(iNeighbor)) ) ) then + nDynNeighbors = nDynNeighbors + 1 + endif + enddo + if ( nDynNeighbors > 0 ) then + ! Now distribute unablatedVolumeDynCell between those neighbors + do iEdge = 1, nEdgesOnCell(iCell) + iNeighbor = cellsOnCell(iEdge, iCell) + if ((li_mask_is_dynamic_ice(cellMask(iNeighbor))) .and. (bedTopography(iNeighbor) < config_sea_level) & + .and. ( cellVolume(iNeighbor) > (ablationSmallThk * areaCell(iNeighbor)) ) ) then + unablatedVolumeDynCell(iNeighbor) = unablatedVolumeDynCell(iNeighbor) + & + unablatedVolumeDynCell(iCell) / nDynNeighbors + endif + enddo + ! This cell now has no more unablatedVolume + unablatedVolumeDynCell(iCell) = 0.0_RKIND + endif + endif + enddo + + ! b. Apply ablation + do iCell = 1, nCells + if ((li_mask_is_dynamic_ice(cellMask(iCell))) .and. (bedTopography(iCell) < config_sea_level) & + .and. ( cellVolume(iCell) > (ablationSmallThk * areaCell(iCell)) ) & + .and. (unablatedVolumeDynCell(iCell) > 0.0_RKIND) ) then + removeVolumeHere = min(cellVolume(iCell), unablatedVolumeDynCell(iCell)) ! Don't use more than available + ablationThickness(iCell) = ablationThickness(iCell) + removeVolumeHere / areaCell(iCell) ! add to ablationThickness calculated in 2c + ablatedVolumeDynCell(iCell) = ablatedVolumeDynCell(iCell) + removeVolumeHere + unablatedVolumeDynCell(iCell) = unablatedVolumeDynCell(iCell) - removeVolumeHere + cellVolume(iCell) = cellVolume(iCell) - removeVolumeHere + ! For debugging it may be helpful to add a separate metric for + ! this step. + if (iCell <= nCellsSolve) ablationSubtotal2 = ablationSubtotal2 + removeVolumeHere + endif + enddo + !call mpas_log_write("Done calculating ablation for dynamic floating cells. Removed $r m^3", realArgs=(/calvingSubtotal2/)) + + ! c. Clean up to account for roundoff level errors that can occur + do iCell = 1, nCells + if (abs(ablationThickness(iCell) - thickness(iCell)) < ablationSmallThk) then + ablationThickness(iCell) = thickness(iCell) + endif + enddo + endif ! config_distribute_unablatedVolumeDynCell + + ! 4. Clean up after applying ablation velocity from parameterization + ! a. Zap any stranded ice. This only needs to be considered for floating ice. ablationSubtotal3 = 0.0_RKIND do iCell = 1, nCells if (li_mask_is_floating_ice(cellMask(iCell)) .and. (.not. li_mask_is_dynamic_ice(cellMask(iCell)))) then @@ -2253,13 +2764,28 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool endif enddo - ! Clean up to account for roundoff level errors that can occur + ! b. Clean up to account for roundoff level errors that can occur do iCell = 1, nCells if (abs(ablationThickness(iCell) - thickness(iCell)) < ablationSmallThk) then ablationThickness(iCell) = thickness(iCell) endif enddo + ! Clean up to unablated volume arrays before checking for errors + do iCell = 1, nCells + ! Eliminate leftover potental calving from cells above sea level to avoid erroneous warnings/errors + if (bedTopography(iCell) >= config_sea_level) then + unablatedVolumeNonDynCell(iCell) = 0.0_RKIND + unablatedVolumeDynCell(iCell) = 0.0_RKIND + endif + ! Clean up round off. Because this is volume, threshold can be kind of large + if (unablatedVolumeNonDynCell(iCell) < (ablationSmallThk * areaCell(iCell))) then + unablatedVolumeNonDynCell(iCell) = 0.0_RKIND + endif + if (unablatedVolumeDynCell(iCell) < (ablationSmallThk * areaCell(iCell))) then + unablatedVolumeDynCell(iCell) = 0.0_RKIND + endif + enddo ! End of routine accounting/reporting localInfo(1) = ablationSubtotal1 @@ -2270,6 +2796,16 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool localInfo(6) = sum(unablatedVolumeDynCell(1:nCellsSolve)) ! NOTE: THIS WILL NOT WORK ON MULTIPLE BLOCKS PER PROCESSOR call mpas_dmpar_sum_real_array(domain % dminfo, 6, localInfo, globalInfo) + if (present(maxDt)) then + ! Do this global reduce at the same time as the previous for efficiency + call mpas_dmpar_min_real(domain % dminfo, minOfMaxAllowableDt, maxDt) + if (present(CFLratio)) then + CFLratio = deltat / maxDt + if (CFLratio > 1.0_RKIND) then + call mpas_log_write("Ratio of dt to calving CFL dt exceeds 1: $r", MPAS_LOG_WARN, realArgs = (/CFLratio/)) + endif + endif + endif call mpas_log_write("== Ablation complete. Total calved = $r", realArgs = (/globalInfo(4)/)) call mpas_log_write("== Ablated from non-dynamic cells = $r", realArgs = (/globalInfo(1)/)) call mpas_log_write("== Ablated from dynamic cells = $r", realArgs = (/globalInfo(2)/)) @@ -2281,12 +2817,11 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool realArgs=(/globalInfo(5) + globalInfo(6), & 100.0_RKIND * (globalInfo(5) + globalInfo(6)) / (globalInfo(4)+1.0e-30_RKIND)/)) endif - if (((globalInfo(5) + globalInfo(6)) / (globalInfo(4) + 1.0e-30_RKIND) > 0.1_RKIND) .and. & + if (((globalInfo(5) + globalInfo(6)) / (globalInfo(4) + 1.0e-30_RKIND) > config_calving_error_threshold) .and. & (globalInfo(4) > 1000.0_RKIND**2)) then ! Include some small amount of total calving for comparison - call mpas_log_write("Failed to ablate an amount greater than 10% of the ice ablated. " // & + call mpas_log_write("Failed to ablate an amount greater than $r% of the ice ablated. " // & "Try reducing time step or li_apply_front_ablation_velocity may need improvements.", & - MPAS_LOG_ERR, realArgs=(/globalInfo(5) + globalInfo(6), & - 100.0_RKIND * (globalInfo(5) + globalInfo(6)) / (globalInfo(4)+1.0e-30_RKIND)/)) + MPAS_LOG_ERR, realArgs=(/config_calving_error_threshold * 100.0_RKIND/)) err_tmp = 1 err = ior(err, err_tmp) endif @@ -2299,6 +2834,13 @@ subroutine li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool err = ior(err, err_tmp) endif + if (present(totalAblatedVolume)) then + totalAblatedVolume = globalInfo(4) + endif + if (present(totalUnablatedVolume)) then + totalUnablatedVolume = globalInfo(5) + globalInfo(6) + endif + deallocate(cellVolume) deallocate(thicknessForAblation) deallocate(uvelForAblation) @@ -2375,6 +2917,8 @@ subroutine damage_calving(domain, err) real (kind=RKIND), dimension(:), pointer :: bedTopography real (kind=RKIND), dimension(:), pointer :: calvingThickness real (kind=RKIND), dimension(:), pointer :: calvingVelocity + real (kind=RKIND), pointer :: calvingCFLdt + real (kind=RKIND), pointer :: dtCalvingCFLratio real (kind=RKIND), dimension(:), pointer :: eMax, eMin real (kind=RKIND), dimension(:), pointer :: damage integer, dimension(:), pointer :: calvingFrontMask @@ -2394,6 +2938,7 @@ subroutine damage_calving(domain, err) real(kind=RKIND) :: calvingSubtotal character (len=StrKIND), pointer :: config_damage_calving_method real(kind=RKIND), pointer :: config_damage_calving_threshold + real (kind=RKIND), pointer :: totalRatebasedCalvedVolume, totalRatebasedUncalvedVolume err = 0 @@ -2429,6 +2974,10 @@ subroutine damage_calving(domain, err) call mpas_pool_get_array(geometryPool, 'damage', damage) call mpas_pool_get_array(geometryPool, 'calvingVelocity', calvingVelocity) call mpas_pool_get_array(geometryPool, 'calvingFrontMask', calvingFrontMask) + call mpas_pool_get_array(geometryPool, 'calvingCFLdt', calvingCFLdt) + call mpas_pool_get_array(geometryPool, 'dtCalvingCFLratio', dtCalvingCFLratio) + call mpas_pool_get_array(geometryPool, 'totalRatebasedCalvedVolume', totalRatebasedCalvedVolume) + call mpas_pool_get_array(geometryPool, 'totalRatebasedUncalvedVolume', totalRatebasedUncalvedVolume) call calculate_calving_front_mask(meshPool, geometryPool, calvingFrontMask) @@ -2445,7 +2994,10 @@ subroutine damage_calving(domain, err) * real(li_mask_is_floating_ice_int(cellMask(:)), kind=RKIND) ! calculate only for floating ice call li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool, calvingThickness, calvingVelocity, & applyToGrounded=.false., applyToFloating=.true., applyToGroundingLine=.false., & - domain=domain, err=err_tmp) + domain=domain, maxDt=calvingCFLdt, CFLratio=dtCalvingCFLratio, & + totalAblatedVolume=totalRatebasedCalvedVolume, & + totalUnablatedVolume=totalRatebasedUncalvedVolume, & + err=err_tmp) err = ior(err, err_tmp) elseif (trim(config_damage_calving_method) == 'threshold') then call apply_calving_damage_threshold(meshPool, geometryPool, scratchPool, domain, err_tmp) @@ -3322,8 +3874,20 @@ subroutine remove_icebergs(domain) call mpas_log_write("Iceberg-detection flood-fill initialization complete.") - where ( seedMask == 0 .and. li_mask_is_floating_ice(cellMask(:)) ) + where ( (seedMask == 0) .and. li_mask_is_floating_ice(cellMask(:)) .and. li_mask_is_dynamic_ice(cellMask(:)) ) + growMask = 1 + endwhere + call flood_fill(seedMask, growMask, domain) + + ! Add floating non-dynamic fringe, but exclude dynamic ice isolated by + ! non-dynamic ice, which can cause velocity solver to fail to converge. + ! This is a bit of an expensive solution to this problem + ! that may only occur once in a while, so we might need to revisit this. + + where ( li_mask_is_floating_ice(cellMask(:)) .and. .not. li_mask_is_dynamic_ice(cellMask(:)) ) growMask = 1 + elsewhere + growMask = 0 endwhere call flood_fill(seedMask, growMask, domain) diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_core.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_core.F index cdeeda278d83..9975963323e2 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_core.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_core.F @@ -70,6 +70,7 @@ function li_core_init(domain, startTimeStamp) result(err) use li_setup use li_constants use li_subglacial_hydro + use li_bedtopo !!! use mpas_tracer_advection !!! use li_global_diagnostics @@ -287,6 +288,10 @@ function li_core_init(domain, startTimeStamp) result(err) call li_SGH_init(domain, err_tmp) err = ior(err, err_tmp) + ! Initialize bed topo module + call li_bedtopo_init(domain, err_tmp) + err = ior(err, err_tmp) + ! initialize analysis driver call li_analysis_init(domain, err_tmp) err = ior(err, err_tmp) @@ -426,7 +431,11 @@ function li_core_run(domain) result(err) block => block % next end do - call mpas_log_write('Starting timestep number $i', intArgs=(/timestepNumber/), flushNow=.true.) + call mpas_log_write('') + call mpas_log_write('=============================') + call mpas_log_write('Starting timestep number $i', intArgs=(/timestepNumber/)) + call mpas_log_write('=============================') + call mpas_log_write('', flushNow=.true.) ! === ! === Perform Timestep @@ -457,7 +466,7 @@ function li_core_run(domain) result(err) ! will allow that. ! Finally, set whence to latest_before so we have piecewise-constant forcing. ! Could add, e.g., linear interpolation later. - call mpas_stream_mgr_read(domain % streamManager, whence=MPAS_STREAM_LATEST_BEFORE, ierr=err_tmp) + call mpas_stream_mgr_read(domain % streamManager, whence=MPAS_STREAM_LATEST_BEFORE, saveActualWhen = .true., ierr=err_tmp) err = ior(err, err_tmp) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_INPUT, ierr=err_tmp) err = ior(err, err_tmp) @@ -535,8 +544,8 @@ function li_core_run(domain) result(err) err = ior(err, err_tmp) call mpas_timer_stop("write streams") - ! === (end of output section) === + ! === (end of output section) === ! Move time level 1 fields (current values) into time level 2 (old values) for next time step ! (for those fields with multiple time levels) @@ -678,6 +687,7 @@ function li_core_initial_solve(domain) result(err) use li_setup use li_statistics use li_advection + use li_calving, only: li_calve_ice use mpas_io_streams, only: MPAS_STREAM_LATEST_BEFORE implicit none @@ -713,6 +723,8 @@ function li_core_initial_solve(domain) result(err) ! Variables needed for printing timestamps type (MPAS_Time_Type) :: currTime character(len=StrKIND) :: timeStamp + real(kind=RKIND), pointer :: deltat + real(kind=RKIND) :: deltatTemp integer :: err, err_tmp, globalErr logical :: solveVelo @@ -772,6 +784,27 @@ function li_core_initial_solve(domain) result(err) call li_velocity_solve(domain, solveVelo=solveVelo, err=err_tmp) err = ior(err, err_tmp) + ! Initial calving solution + ! This is required for the calving CFL to work correctly + ! For rate-based calving laws, no calving actually occurs because dt=0. + ! For threshold calving laws (e.g. thickness-based) calving *will* occur + ! Note that during a timestep, calving occurs before velocity, but because + ! many calving laws require velocity-related fields, it needs to be called + ! after velocity here. + if (.not. config_do_restart) then + ! Temporarily set dt to 0 to avoid actually calving anything for rate-based calving laws + call mpas_pool_get_array(meshPool, 'deltat', deltat) + deltatTemp = deltat + deltat = 0.0_RKIND + + call li_calve_ice(domain, err_tmp) + err = ior(err, err_tmp) + + ! Restore appropriate value for dt + deltat = deltatTemp + endif + + ! Calculate diagnostic vars call li_calculate_diagnostic_vars(domain, err=err_tmp) err = ior(err, err_tmp) @@ -904,6 +937,7 @@ subroutine landice_init_block(block, dminfo, err) type (mpas_pool_type), pointer :: geometryPool integer, dimension(:), pointer :: vertexMask real (kind=RKIND), dimension(:), pointer :: thickness, thicknessOld + real (kind=RKIND), dimension(:,:), pointer :: layerThickness character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_do_velocity_reconstruction_for_external_dycore logical, pointer :: config_adaptive_timestep_include_DCFL @@ -978,6 +1012,11 @@ subroutine landice_init_block(block, dminfo, err) call mpas_pool_get_array(geometryPool, 'thicknessOld', thicknessOld) thicknessOld = thickness + ! Initialize layerThickness + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness) + call li_calculate_layerThickness(meshPool, thickness, layerThickness) + + ! === error check if (err > 0) then call mpas_log_write("An error has occurred in landice_init_block.", MPAS_LOG_ERR) @@ -1037,11 +1076,13 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep type (MPAS_TimeInterval_type) :: adaptDtForceInterval + type (MPAS_TimeInterval_type) :: slm_coupling_interval character (len=StrKIND), pointer :: config_start_time, config_run_duration, config_stop_time, & config_output_interval, config_restart_interval ! MPAS standard configs character (len=StrKIND), pointer :: config_dt ! MPAS LI-specific config option character (len=StrKIND), pointer :: config_adaptive_timestep_force_interval ! MPAS LI-specific config option character (len=StrKIND), pointer :: config_restart_timestamp_name + character (len=StrKIND), pointer :: config_uplift_method, config_slm_coupling_interval character (len=StrKIND) :: restartTimeStamp !< string to be read from file integer, pointer :: config_year_digits integer :: err_tmp @@ -1060,6 +1101,8 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) call mpas_pool_get_config(configs, 'config_restart_timestamp_name', config_restart_timestamp_name) call mpas_pool_get_config(configs, 'config_adaptive_timestep_force_interval', config_adaptive_timestep_force_interval) + call mpas_pool_get_config(configs, 'config_uplift_method', config_uplift_method) + call mpas_pool_get_config(configs, 'config_slm_coupling_interval', config_slm_coupling_interval) ! Set time to the user-specified start time OR use a restart time from file @@ -1123,6 +1166,20 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) endif ierr = ior(ierr, err_tmp) + ! Set up the coupling time interval if MALI is coupled to sea-level model + if (trim(config_uplift_method) == "sealevelmodel") then + call mpas_set_timeInterval(slm_coupling_interval, timeString=config_slm_coupling_interval, ierr=err_tmp) + ierr = ior(ierr,err_tmp) + call mpas_add_clock_alarm(core_clock, 'slmCouplingInterval', alarmTime=startTime, & + alarmTimeInterval=slm_coupling_interval, ierr=err_tmp) + ierr = ior(ierr,err_tmp) + if (mpas_is_alarm_ringing(core_clock, 'slmCouplingInterval', ierr=err_tmp)) then + ierr = ior(ierr, err_tmp) + call mpas_reset_clock_alarm(core_clock, 'slmCouplingInterval', ierr=err_tmp) + ierr = ior(ierr, err_tmp) + endif + endif + ! === error check if (ierr > 0) then call mpas_log_write("An error has occurred in li_simulation_clock_init.", MPAS_LOG_ERR) diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_core_interface.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_core_interface.F index 001c14bef655..0a867dcd5a94 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_core_interface.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_core_interface.F @@ -100,6 +100,7 @@ function li_setup_packages(configPool, packagePool, iocontext) result(ierr) ! Local variables character (len=StrKIND), pointer :: config_velocity_solver + character (len=StrKIND), pointer :: config_calving character (len=StrKIND), pointer :: config_basal_mass_bal_float character (len=StrKIND), pointer :: config_front_mass_bal_grounded character (len=StrKIND), pointer :: config_thermal_solver @@ -119,6 +120,7 @@ function li_setup_packages(configPool, packagePool, iocontext) result(ierr) call mpas_pool_get_config(configPool, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(configPool, 'config_SGH', config_SGH) + call mpas_pool_get_config(configPool, 'config_calving', config_calving) call mpas_pool_get_config(configPool, 'config_write_albany_ascii_mesh', config_write_albany_ascii_mesh) call mpas_pool_get_config(configPool, 'config_basal_mass_bal_float', config_basal_mass_bal_float) call mpas_pool_get_config(configPool, 'config_front_mass_bal_grounded', config_front_mass_bal_grounded) @@ -159,10 +161,10 @@ function li_setup_packages(configPool, packagePool, iocontext) result(ierr) "'config_basal_mass_bal_float' is set to 'ismip6'") endif - if (trim(config_front_mass_bal_grounded) == 'ismip6') then + if ((trim(config_front_mass_bal_grounded) == 'ismip6') .or. (trim(config_calving) == 'ismip6_retreat')) then ismip6GroundedFaceMeltActive=.true. call mpas_log_write("The 'ismip6GroundedFaceMelt' package and assocated variables have been enabled because " // & - "'config_front_mass_bal_grounded' is set to 'ismip6'") + "'config_front_mass_bal_grounded' is set to 'ismip6' or 'config_calving' is set to 'ismip6_retreat'") endif if ((trim(config_thermal_solver) == 'temperature') .or. (trim(config_thermal_solver) == 'enthalpy')) then diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_diagnostic_vars.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_diagnostic_vars.F index 218dec72b10e..48e4464b769a 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_diagnostic_vars.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_diagnostic_vars.F @@ -235,8 +235,8 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool real (kind=RKIND) :: slopeCellMagnitude real (kind=RKIND) :: dCell integer :: iCell, iEdge, iLevel - real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND - !<- This is ~300 million years in seconds, but it is small enough not too overflow + real (kind=RKIND), parameter :: bigNumber = 1.0e11_RKIND + !<- This is 5000 years in seconds. Small enough to avoid timekeeping overflow real (kind=RKIND), parameter :: smallNumber = 1.0e-36_RKIND logical :: divideSingularityFound diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_iceshelf_melt.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_iceshelf_melt.F index be9e71606edb..f65744f049eb 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_iceshelf_melt.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_iceshelf_melt.F @@ -256,7 +256,7 @@ subroutine li_basal_melt_floating_ice(domain, err) nEdgesOnCell, & edgeMask - integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, cellsOnCell type (field1dInteger), pointer :: thermalCellMaskField @@ -275,7 +275,7 @@ subroutine li_basal_melt_floating_ice(domain, err) real(kind=RKIND), pointer :: daysSinceStart - integer :: iCell, iEdge, err_tmp + integer :: iCell, jCell, iEdge, iNeighbor, err_tmp ! Local variables for some melt methods @@ -509,23 +509,26 @@ subroutine li_basal_melt_floating_ice(domain, err) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) call mpas_pool_get_array(geometryPool, 'floatingBasalMassBal', floatingBasalMassBal) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) ! If config_front_mass_bal_grounded is not none, only apply ice shelf melt to active cells - ! and stranded non-dynamic cells. + ! and stranded non-dynamic cells. i.e., if a floating non-dynamic + ! cell has a grounded neighbor, do not apply ice shelf melt to it. do iCell = 1, nCellsSolve if ( li_mask_is_floating_ice(cellMask(iCell)) .and. (.not. li_mask_is_dynamic_ice(cellMask(iCell))) ) then - do iEdge = 1, nEdgesOnCell(iCell) - if ( li_mask_is_grounding_line(edgeMask(edgesOnCell(iEdge,iCell))) ) then - + do iNeighbor = 1, nEdgesOnCell(iCell) + jCell = cellsOnCell(iNeighbor, iCell) + if ( li_mask_is_grounded_ice(cellMask(jCell)) ) then floatingBasalMassBal(iCell) = 0.0_RKIND - + exit ! No need to look over other neighbors endif enddo endif enddo + block => block % next enddo ! associated(block) endif @@ -1154,7 +1157,7 @@ subroutine iceshelf_melt_ismip6(domain, err) real (kind=RKIND), dimension(:), pointer :: areaCell real (kind=RKIND), dimension(:), allocatable :: mean_TF, IS_area integer, parameter :: maxNumBasins = 32 - integer, dimension(:), pointer :: cellMask + integer, dimension(:), pointer :: cellMask, indexToCellID real(kind=RKIND), dimension(maxNumBasins*2) :: localSums, globalSums real (kind=RKIND), pointer :: gamma0 real (kind=RKIND), dimension(:), pointer :: floatingBasalMassBal @@ -1177,6 +1180,7 @@ subroutine iceshelf_melt_ismip6(domain, err) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nISMIP6OceanLayers', nOceanLayers) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) ! Get 3d thermal forcing (had to be read-in) call mpas_pool_get_array(geometryPool, 'ismip6shelfMelt_3dThermalForcing', TFocean) @@ -1216,8 +1220,8 @@ subroutine iceshelf_melt_ismip6(domain, err) kinf = ksup + 1 if ((zOcean(ksup)-zOcean(kinf)) == 0) then call mpas_log_write("iceshelf_melt_ismip6: Invalid value for zOcean. " // & - "ksup=$i kinf=$i zOcean(ksup)=$r zOcean(kinf)=$r iCell=$i lowerSurface=$r", MPAS_LOG_ERR, & - intArgs=(/ksup, kinf, iCell/), & + "ksup=$i kinf=$i zOcean(ksup)=$r zOcean(kinf)=$r indexToCellID=$i lowerSurface=$r", MPAS_LOG_ERR, & + intArgs=(/ksup, kinf, indexToCellID(iCell)/), & realArgs=(/zOcean(ksup), zOcean(kinf), lowerSurface(iCell) /) ) err = ior(err, 1) endif @@ -1432,7 +1436,8 @@ subroutine grounded_face_melt_ismip6(domain, applyToGrounded, & ! Distribute melt among neighbors call li_apply_front_ablation_velocity(meshPool, geometryPool, velocityPool, & faceMeltingThickness, faceMeltSpeedVertAvg, applyToGrounded, & - applyToFloating, applyToGroundingLine, domain, err) + applyToFloating, applyToGroundingLine, domain, err=err_tmp) + err = ior(err, err_tmp) block => block % next diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_subglacial_hydro.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_subglacial_hydro.F index 43906bc6c040..ad3642622e1f 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_subglacial_hydro.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_subglacial_hydro.F @@ -160,6 +160,8 @@ subroutine li_SGH_init(domain, err) call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) err = ior(err, err_tmp) + call calc_hydro_mask(domain) + ! remove invalid values - not necessary on restart, but shouldn't hurt call mpas_pool_get_array(hydroPool, 'waterThickness', waterThickness) waterThickness = max(0.0_RKIND, waterThickness) @@ -294,6 +296,8 @@ subroutine li_SGH_solve(domain, err) return endif + call calc_hydro_mask(domain) + call mpas_log_write('Beginning subglacial hydro solve.') call mpas_pool_get_config(liConfigs, 'config_SGH_chnl_active', config_SGH_chnl_active) call mpas_pool_get_config(liConfigs, 'config_SGH_till_drainage', Cd) @@ -728,6 +732,7 @@ subroutine calc_edge_quantities(block, err) real (kind=RKIND), dimension(:), pointer :: waterFluxAdvec real (kind=RKIND), dimension(:), pointer :: waterFluxDiffu integer, dimension(:), pointer :: waterFluxMask + integer, dimension(:), pointer :: hydroMarineMarginMask integer, dimension(:,:), pointer :: edgeSignOnCell integer, dimension(:), pointer :: cellMask integer, dimension(:), pointer :: edgeMask @@ -797,6 +802,7 @@ subroutine calc_edge_quantities(block, err) call mpas_pool_get_array(hydroPool, 'waterFluxAdvec', waterFluxAdvec) call mpas_pool_get_array(hydroPool, 'waterFluxDiffu', waterFluxDiffu) call mpas_pool_get_array(hydroPool, 'waterFluxMask', waterFluxMask) + call mpas_pool_get_array(hydroPool, 'hydroMarineMarginMask', hydroMarineMarginMask) call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) @@ -827,7 +833,7 @@ subroutine calc_edge_quantities(block, err) ! at the edge of the cell in a 1-sided sense do iEdge = 1, nEdges if ( (li_mask_is_margin(edgeMask(iEdge)) .and. li_mask_is_grounded_ice(edgeMask(iEdge))) .or. & - (li_mask_is_grounding_line(edgeMask(iEdge)))) then + (hydroMarineMarginMask(iEdge)==1)) then cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) if (li_mask_is_grounded_ice(cellMask(cell1))) then ! cell2 is the icefree cell - replace phi there with cell1 Phig @@ -856,7 +862,7 @@ subroutine calc_edge_quantities(block, err) ! (Do this step only after the other hydropotential special cases are treated above.) do iEdge = 1, nEdges ! Find edges along GL or margin to check for 'backwards' flow - if ((li_mask_is_grounding_line(edgeMask(iEdge))) .or. & + if ((hydroMarineMarginMask(iEdge)==1) .or. & li_mask_is_margin(edgeMask(iEdge)) ) then ! Now check if flow is backwards cell1 = cellsOnEdge(1, iEdge) @@ -1364,7 +1370,10 @@ subroutine calc_pressure(block, err) real (kind=RKIND), dimension(:), pointer :: divergenceChannel real (kind=RKIND), dimension(:), pointer :: channelAreaChangeCell real (kind=RKIND), dimension(:), pointer :: bedTopography + integer, dimension(:), pointer :: hydroMarineMarginMask integer, dimension(:), pointer :: cellMask + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell real (kind=RKIND), pointer :: deltatSGH real (kind=RKIND), pointer :: bedRough, bedRoughMax real (kind=RKIND), pointer :: rhoi @@ -1377,6 +1386,8 @@ subroutine calc_pressure(block, err) real (kind=RKIND), pointer :: rhoo integer :: err_tmp integer :: iCell + integer :: iEdge + logical :: onMarineMargin err = 0 err_tmp = 0 @@ -1400,6 +1411,8 @@ subroutine calc_pressure(block, err) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(hydroPool, 'effectivePressure', effectivePressure) call mpas_pool_get_array(hydroPool, 'waterPressure', waterPressure) @@ -1417,6 +1430,7 @@ subroutine calc_pressure(block, err) call mpas_pool_get_array(hydroPool, 'divergence', divergence) call mpas_pool_get_array(hydroPool, 'divergenceChannel', divergenceChannel) call mpas_pool_get_array(hydroPool, 'channelAreaChangeCell', channelAreaChangeCell) + call mpas_pool_get_array(hydroPool, 'hydroMarineMarginMask', hydroMarineMarginMask) call mpas_pool_get_array(velocityPool, 'basalSpeed', basalSpeed) call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA) call mpas_pool_get_array(geometryPool, 'thickness', thickness) @@ -1472,11 +1486,20 @@ subroutine calc_pressure(block, err) ((.not. li_mask_is_ice(cellMask(iCell))) .and. (bedTopography(iCell) < config_sea_level) ) ) then ! set pressure correctly under floating ice and open ocean waterPressure(iCell) = rhoo * gravity * (config_sea_level - bedTopography(iCell)) - elseif (li_mask_is_grounding_line(cellMask(iCell))) then - ! At GL, don't let water pressure fall below ocean pressure - ! TODO: Not sure if this should include the water layer thickness term. Leaving it off. - if (waterPressure(iCell) < rhoo * gravity * (config_sea_level - bedTopography(iCell))) then - waterPressure(iCell) = rhoo * gravity * (config_sea_level - bedTopography(iCell)) + else + onMarineMargin = .false. + do iEdge = 1, nEdgesOnCell(iCell) + if (hydroMarineMarginMask(edgesOnCell(iEdge, iCell)) == 1) then + onMarineMargin = .true. + exit + endif + enddo + if (onMarineMargin) then + ! At marine margin, don't let water pressure fall below ocean pressure + ! TODO: Not sure if this should include the water layer thickness term. Leaving it off. + if (waterPressure(iCell) < rhoo * gravity * (config_sea_level - bedTopography(iCell))) then + waterPressure(iCell) = rhoo * gravity * (config_sea_level - bedTopography(iCell)) + endif endif endif enddo @@ -1633,6 +1656,7 @@ subroutine update_channel(block, err) real (kind=RKIND), dimension(:), pointer :: effectivePressure real (kind=RKIND), dimension(:), pointer :: channelDiffusivity integer, dimension(:), pointer :: waterFluxMask + integer, dimension(:), pointer :: hydroMarineMarginMask integer, dimension(:), pointer :: edgeMask real (kind=RKIND), dimension(:,:), pointer :: flowParamA integer, dimension(:,:), pointer :: cellsOnEdge @@ -1680,6 +1704,7 @@ subroutine update_channel(block, err) call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA) call mpas_pool_get_array(hydroPool, 'effectivePressure', effectivePressure) call mpas_pool_get_array(hydroPool, 'waterFluxMask', waterFluxMask) + call mpas_pool_get_array(hydroPool, 'hydroMarineMarginMask', hydroMarineMarginMask) call mpas_pool_get_array(hydroPool, 'channelDiffusivity', channelDiffusivity) call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) @@ -1699,7 +1724,7 @@ subroutine update_channel(block, err) ! Note: an edge with only one grounded cell neighbor is called floating, so this logic retains channel vars ! on those edges to allow channel discharge across GL - where (.not. ( (li_mask_is_grounded_ice(edgeMask)) .or. (li_mask_is_grounding_line(edgeMask)) ) ) + where (.not. ( (li_mask_is_grounded_ice(edgeMask)) .or. (hydroMarineMarginMask==1) ) ) channelArea = 0.0_RKIND channelDischarge = 0.0_RKIND end where @@ -2049,4 +2074,83 @@ subroutine ocean_connection_N(domain) end subroutine ocean_connection_N +!*********************************************************************** +! +! routine calc_hydro_mask +! +!> \brief Calculate the boundaries of the active hydrology domain +!> \author Matt Hoffman +!> \date 24 October 2022 +!> \details +!> This routine calculates a mask of the boundaries of the active hydrology domain +!----------------------------------------------------------------------- + subroutine calc_hydro_mask(domain) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: hydroPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: meshPool + real (kind=RKIND), dimension(:), pointer :: bedTopography + integer, dimension(:), pointer :: hydroMarineMarginMask + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:), pointer :: cellMask + integer, pointer :: nEdgesSolve + integer :: cell1, cell2, iEdge + real (kind=RKIND), pointer :: config_sea_level + + call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'hydro', hydroPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(hydroPool, 'hydroMarineMarginMask', hydroMarineMarginMask) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + hydroMarineMarginMask(:) = 0 + do iEdge = 1, nEdgesSolve + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + ! We are looking for edges with 1 edge grounded ice and the other edge floating ice or open ocean + if ( (li_mask_is_grounded_ice(cellMask(cell1))) .and. & + (li_mask_is_floating_ice(cellMask(cell2)) .or. & + ((bedTopography(cell2) < config_sea_level) .and. (.not. li_mask_is_ice(cellMask(cell2)))) ) ) then + hydroMarineMarginMask(iEdge) = 1 + elseif ( (li_mask_is_grounded_ice(cellMask(cell2))) .and. & + (li_mask_is_floating_ice(cellMask(cell1)) .or. & + ((bedTopography(cell1) < config_sea_level) .and. (.not. li_mask_is_ice(cellMask(cell1)))) ) ) then + hydroMarineMarginMask(iEdge) = 1 + endif + enddo + + block => block % next + end do + + call mpas_timer_start("halo updates") + call mpas_dmpar_field_halo_exch(domain, 'hydroMarineMarginMask') + call mpas_timer_stop("halo updates") + + !-------------------------------------------------------------------- + end subroutine calc_hydro_mask + end module li_subglacial_hydro diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_thermal.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_thermal.F index f40b02a25464..4ef8ae672b8c 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_thermal.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_thermal.F @@ -724,6 +724,7 @@ subroutine li_thermal_solver(domain, err) temperature, & ! interior ice temperature (K) waterFrac, & ! interior water fraction (unitless) enthalpy, & ! interior ice enthalpy (J m^{-3}) + drainedInternalMeltRate, & ! excess internal melt drained to the bed heatDissipation ! interior heat dissipation (deg/s) real(kind=RKIND), dimension(:), allocatable :: & @@ -829,6 +830,7 @@ subroutine li_thermal_solver(domain, err) call mpas_pool_get_array(thermalPool, 'temperature', temperature) call mpas_pool_get_array(thermalPool, 'waterFrac', waterFrac) call mpas_pool_get_array(thermalPool, 'enthalpy', enthalpy) + call mpas_pool_get_array(thermalPool, 'drainedInternalMeltRate', drainedInternalMeltRate) call mpas_pool_get_array(thermalPool, 'surfaceTemperature', surfaceTemperature) call mpas_pool_get_array(thermalPool, 'basalTemperature', basalTemperature) call mpas_pool_get_array(thermalPool, 'surfaceAirTemperature', surfaceAirTemperature) @@ -915,7 +917,7 @@ subroutine li_thermal_solver(domain, err) call mpas_log_write('thickness = $r', realArgs=(/thickness(iCell)/)) call mpas_log_write('surfaceAirTemperature = $r', realArgs=(/surfaceAirTemperature(iCell)/)) call mpas_log_write(' ') - call mpas_log_write('Initial column temperatures, iCell = $i', intArgs=(/iCell/)) + call mpas_log_write('Initial column temperatures, indexToCellID = $i', intArgs=(/indexToCellID(iCell)/)) call mpas_log_write("0 $r", realArgs=(/surfaceTemperature(iCell)/)) do k = 1, nVertLevels call mpas_log_write("$i $r", intArgs=(/k/), realArgs=(/temperature(k,iCell)/)) @@ -964,7 +966,7 @@ subroutine li_thermal_solver(domain, err) if (verboseColumn) then call mpas_log_write(' ') - call mpas_log_write('Before prognostic enthalpy, iCell = $i', intArgs=(/indexToCellID(iCell)/)) + call mpas_log_write('Before prognostic enthalpy, indexToCellID = $i', intArgs=(/indexToCellID(iCell)/)) call mpas_log_write('thickness = $r', realArgs=(/thickness(iCell)/)) call mpas_log_write('Temperature (C), waterFrac, enthalpy/(rhoi*cp_ice):') call mpas_log_write('0 $r', realArgs=(/surfaceEnthalpy/(rhoi*cp_ice)/)) @@ -1007,7 +1009,7 @@ subroutine li_thermal_solver(domain, err) if (verboseColumn) then call mpas_log_write(' ') - call mpas_log_write('After matrix elements, iCell = $i', intArgs=(/indexToCellID(iCell)/)) + call mpas_log_write('After matrix elements, indexToCellID = $i', intArgs=(/indexToCellID(iCell)/)) call mpas_log_write('k, subd, diag, supd, rhs/(rhoi*ci):') do k = 1, nVertLevels+2 call mpas_log_write('$i $r $r $r $r', intArgs=(/k-1/), realArgs= & @@ -1071,7 +1073,7 @@ subroutine li_thermal_solver(domain, err) if (verboseColumn) then call mpas_log_write(' ') - call mpas_log_write('After prognostic enthalpy, iCell = $i', intArgs=(/indexToCellID(iCell)/)) + call mpas_log_write('After prognostic enthalpy, indexToCellID = $i', intArgs=(/indexToCellID(iCell)/)) call mpas_log_write('thickness = $r', realArgs=(/thickness(iCell)/)) call mpas_log_write('Temperature, waterFrac, enthalpy/(rhoi*cp_ice):') call mpas_log_write('0 $r', realArgs=(/surfaceEnthalpy/(rhoi*cp_ice)/)) @@ -1093,7 +1095,7 @@ subroutine li_thermal_solver(domain, err) if (verboseColumn) then call mpas_log_write(' ') - call mpas_log_write('Before prognostic temperature, iCell = $i', intArgs=(/indexToCellID(iCell)/)) + call mpas_log_write('Before prognostic temperature, indexToCellID = $i', intArgs=(/indexToCellID(iCell)/)) call mpas_log_write('thickness = $r', realArgs=(/thickness(iCell)/)) call mpas_log_write('0 $r', realArgs=(/surfaceTemperature(iCell)/)) do k = 1, nVertLevels @@ -1132,7 +1134,7 @@ subroutine li_thermal_solver(domain, err) if (verboseColumn) then call mpas_log_write(' ') call mpas_log_write('deltat = $r', realArgs=(/deltat/)) - call mpas_log_write('After matrix elements, iCell = $i', intArgs=(/indexToCellID(iCell)/)) + call mpas_log_write('After matrix elements, indexToCellID = $i', intArgs=(/indexToCellID(iCell)/)) call mpas_log_write('k, subd, diag, supd, rhs:') do k = 1, nVertLevels+2 call mpas_log_write('$i $r $r $r $r', intArgs=(/k-1/), realArgs= & @@ -1170,7 +1172,7 @@ subroutine li_thermal_solver(domain, err) if (verboseColumn) then call mpas_log_write(' ') - call mpas_log_write('After prognostic temperature, iCell = $i', intArgs=(/indexToCellID(iCell)/)) + call mpas_log_write('After prognostic temperature, indexToCellID = $i', intArgs=(/indexToCellID(iCell)/)) call mpas_log_write('thickness = $r', realArgs=(/thickness(iCell)/)) call mpas_log_write('0 $r', realArgs=(/surfaceTemperature(iCell)/)) do k = 1, nVertLevels @@ -1235,7 +1237,7 @@ subroutine li_thermal_solver(domain, err) realArgs=(/basalFrictionFlux(iCell) + basalHeatFlux(iCell) + basalConductiveFlux(iCell)/)) endif ! verboseColumn - call mpas_log_write('li_thermal, energy conservation error: iCell=$i, imbalance=$r (W/m2):', MPAS_LOG_WARN, & + call mpas_log_write('li_thermal, energy conservation error: indexToCellID=$i, imbalance=$r (W/m2):', MPAS_LOG_WARN, & intArgs=(/indexToCellID(iCell)/), realArgs=(/(finalEnergy - initialEnergy - deltaEnergy)/deltat/)) !err = ior(err, 1) @@ -1285,6 +1287,7 @@ subroutine li_thermal_solver(domain, err) basalHeatFlux, & basalConductiveFlux, & basalWaterThickness, & + drainedInternalMeltRate, & groundedBasalMassBal) ! Convert temperatures from Celsius back to Kelvin @@ -1302,7 +1305,7 @@ subroutine li_thermal_solver(domain, err) mintemp = minval(temperature(:,iCell)) if (maxtemp > maxtempThreshold) then - call mpas_log_write('maxtemp > maxtempThreshold: iCell=$i, maxtemp = $r', intArgs=(/iCell/), & + call mpas_log_write('maxtemp > maxtempThreshold: indexToCellID=$i, maxtemp = $r', intArgs=(/indexToCellID(iCell)/), & realArgs=(/maxtemp/)) call mpas_log_write('thickness = $r', realArgs=(/thickness(iCell)/)) call mpas_log_write('temperature:') @@ -1313,7 +1316,7 @@ subroutine li_thermal_solver(domain, err) endif if (mintemp < mintempThreshold) then - call mpas_log_write('mintemp < mintempThreshold: iCell=$i, mintemp = $r', intArgs=(/iCell/), & + call mpas_log_write('mintemp < mintempThreshold: indexToCellID=$i, mintemp = $r', intArgs=(/indexToCellID(iCell)/), & realArgs=(/mintemp/)) call mpas_log_write('thickness = $r', realArgs=(/thickness(iCell)/)) call mpas_log_write('temperature:') @@ -1331,24 +1334,10 @@ subroutine li_thermal_solver(domain, err) end select ! config_thermal_solver ! It is possible that internal melting was computed above for floating ice and assigned - ! to the groundedBasalMassBal array. If so, then add it to floatingBasalMassBal. + ! to the groundedBasalMassBal array. If so, then this is added to basalMassBal for floating cells in + ! mpas_li_advection.F. floatingBasalMassBal should never be altered because it is an input variable. ! Note: Subroutine basal_melt_floating_ice should be called earlier in the time step, before adding this term. - do iCell = 1, nCellsSolve - - if (thermalCellMask(iCell) == 1 .and. li_mask_is_floating_ice(cellMask(iCell)) .and. & - groundedBasalMassBal(iCell) /= 0.0_RKIND) then - floatingBasalMassBal(iCell) = floatingBasalMassBal(iCell) + groundedBasalMassBal(iCell) - groundedBasalMassBal(iCell) = 0.0_RKIND - endif - - if (config_print_thermal_info .and. indexToCellID(iCell) == config_stats_cell_ID) then - call mpas_log_write('iCell=$i, basal mass balance (m/yr): grounded=$r, floating=$r', & - intArgs=(/iCell/), realArgs=(/groundedBasalMassBal(iCell)*scyr/rhoi, floatingBasalMassBal(iCell)*scyr/rhoi/) ) - endif - - enddo - ! clean up call mpas_deallocate_scratch_field(thermalCellMaskField, .true.) if (allocated(subdiagonal)) deallocate(subdiagonal) @@ -1774,8 +1763,8 @@ subroutine li_basal_friction(domain, err) if (config_print_thermal_info) then do iCell = 1, nCellsSolve if (indexToCellID(iCell) == config_stats_cell_ID) then - call mpas_log_write('iCell=$i, betaSolve=$r, basalSpeed=$r, basalFrictionFlux=$r', & - intArgs=(/iCell/), realArgs=(/betaSolve(iCell), basalSpeed(iCell), basalFrictionFlux(iCell)/)) + call mpas_log_write('indexToCellID=$i, betaSolve=$r, basalSpeed=$r, basalFrictionFlux=$r', & + intArgs=(/indexToCellID(iCell)/), realArgs=(/betaSolve(iCell), basalSpeed(iCell), basalFrictionFlux(iCell)/)) endif enddo endif @@ -2716,6 +2705,7 @@ subroutine basal_melt_grounded_ice(& basalHeatFlux, & basalConductiveFlux, & basalWaterThickness, & + drainedInternalMeltRate, & groundedBasalMassBal) !----------------------------------------------------------------- @@ -2780,8 +2770,9 @@ subroutine basal_melt_grounded_ice(& !----------------------------------------------------------------- real(kind=RKIND), dimension(:), intent(out):: & - groundedBasalMassBal !< Output: basal mass balance for grounded ice (kg/m^2/s): < 0 for melting, > 0 for freeze-on - + groundedBasalMassBal !< Output: basal mass balance for grounded ice (kg/m^2/s): < 0 for melting, > 0 for freeze-on + real(kind=RKIND), dimension(:,:), intent(out):: & + drainedInternalMeltRate !< Output: excess internal melt drained to the bed !----------------------------------------------------------------- ! local variables !----------------------------------------------------------------- @@ -2796,7 +2787,6 @@ subroutine basal_melt_grounded_ice(& real(kind=RKIND) :: netBasalFlux ! heat flux available for basal melting (W/m^2) real(kind=RKIND) :: layerThickness ! layer thickness (m) real(kind=RKIND) :: meltEnergy ! energy available for internal melting (J/m^2) - real(kind=RKIND) :: internalMeltRate ! internal melt rate, transferred to bed (m/s) real(kind=RKIND) :: excessWater ! thickness of excess meltwater (m) real(kind=RKIND) :: maxwaterFrac ! maximum allowed water fraction; excess drains to bed @@ -2812,6 +2802,7 @@ subroutine basal_melt_grounded_ice(& ! Compute melt rate for grounded ice groundedBasalMassBal(:) = 0.0_RKIND + drainedInternalMeltRate(:,:) = 0.0_RKIND do iCell = 1, nCellsSolve @@ -2878,12 +2869,8 @@ subroutine basal_melt_grounded_ice(& ! compute melt rate associated with excess water excessWater = (waterFrac(k,iCell) - maxwaterFrac) * thickness(iCell) * (layerInterfaceSigma(k+1) & - layerInterfaceSigma(k)) ! m - internalMeltRate = excessWater / deltat - - ! transfer meltwater to the bed - ! Note: It is possible to have internal melting for floating ice. - ! If so, then this melting will later be switched from groundedBasalMassBall to floatingBasalMassBal. - groundedBasalMassBal(iCell) = groundedBasalMassBal(iCell) - internalMeltRate ! m/s + drainedInternalMeltRate(k, iCell) = excessWater / deltat + ! transfer meltwater to the bed in mpas_li_advection.F ! reset waterFrac to max value waterFrac(k,iCell) = maxwaterFrac @@ -2906,12 +2893,9 @@ subroutine basal_melt_grounded_ice(& ! compute excess energy available for melting layerThickness = thickness(iCell) * (layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) ! m meltEnergy = rhoi*cp_ice * (temperature(k,iCell) - pmpTemperature(k)) * layerThickness ! J/m^2 - internalMeltRate = meltEnergy / (rhoi * latent_heat_ice * deltat) ! m/s + drainedInternalMeltRate(k, iCell) = meltEnergy / (rhoi * latent_heat_ice * deltat) ! m/s - ! transfer meltwater to the bed - ! Note: It is possible to have internal melting for floating ice. - ! If so, then this melting will later be switched from groundedBasalMassBall to floatingBasalMassBal. - groundedBasalMassBal(iCell) = groundedBasalMassBal(iCell) - internalMeltRate ! m/s + ! transfer meltwater to the bed in mpas_li_advection.F ! reset T to Tpmp temperature(k,iCell) = pmpTemperature(k) diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_time_integration_fe.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_time_integration_fe.F index d3db7d1e5471..dfb795ade354 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_time_integration_fe.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_time_integration_fe.F @@ -283,6 +283,8 @@ subroutine prepare_advection(domain, err) real (kind=RKIND), dimension(:,:), pointer :: normalVelocity real (kind=RKIND), dimension(:,:), pointer :: layerNormalVelocity + real (kind=RKIND), pointer :: calvingCFLdt + integer, pointer :: processLimitingTimestep integer, dimension(:), pointer :: edgeMask logical, pointer :: config_print_thickness_advection_info @@ -503,7 +505,9 @@ subroutine prepare_advection(domain, err) ! Set adaptive timestep if needed if (config_adaptive_timestep) then - call set_timestep(allowableAdvecDtAllProcs, allowableDiffDtAllProcs, domain % clock, dtSeconds, err_tmp) + call mpas_pool_get_array(geometryPool, 'calvingCFLdt', calvingCFLdt) + call mpas_pool_get_array(meshPool, 'processLimitingTimestep', processLimitingTimestep) + call set_timestep(allowableAdvecDtAllProcs, allowableDiffDtAllProcs, calvingCFLdt, domain % clock, dtSeconds, processLimitingTimestep, err_tmp) err = ior(err,err_tmp) ! Set new value on all blocks block => domain % blocklist @@ -831,7 +835,7 @@ end subroutine advection_solver !> This routine sdjusts the time step based on the CFL condition. ! !----------------------------------------------------------------------- - subroutine set_timestep(allowableAdvecDt, allowableDiffDt, clock, dtSeconds, err) + subroutine set_timestep(allowableAdvecDt, allowableDiffDt, calvingCFLdt, clock, dtSeconds, CFLprocess, err) use mpas_timekeeping !----------------------------------------------------------------- @@ -839,21 +843,27 @@ subroutine set_timestep(allowableAdvecDt, allowableDiffDt, clock, dtSeconds, err !----------------------------------------------------------------- real (kind=RKIND), intent(in) :: allowableAdvecDt real (kind=RKIND), intent(in) :: allowableDiffDt + real (kind=RKIND), intent(in) :: calvingCFLdt type (MPAS_Clock_type), intent(in) :: clock !----------------------------------------------------------------- ! output variables !----------------------------------------------------------------- real (kind=RKIND), intent(out) :: dtSeconds !< Output: time step in seconds determined by this routine + integer, intent(out) :: CFLprocess !< Output: flag for which process limits the CFL: 1=advective, 2=diffusive, 3=calving integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- ! local variables !----------------------------------------------------------------- logical, pointer :: config_adaptive_timestep_include_DCFL + logical, pointer :: config_adaptive_timestep_include_calving real (kind=RKIND), pointer :: config_adaptive_timestep_CFL_fraction + real (kind=RKIND), pointer :: config_adaptive_timestep_calvingCFL_fraction real (kind=RKIND), pointer :: config_max_adaptive_timestep real (kind=RKIND), pointer :: config_min_adaptive_timestep + character (len=StrKIND), pointer :: config_calving + character (len=StrKIND), pointer :: config_damage_calving_method type (MPAS_Time_type) :: nextForceTime, currTime type (MPAS_TimeInterval_type) :: intervalToNextForceTime real (kind=RKIND) :: secondsToNextForceTime @@ -869,20 +879,64 @@ subroutine set_timestep(allowableAdvecDt, allowableDiffDt, clock, dtSeconds, err call mpas_pool_get_config(liConfigs, 'config_max_adaptive_timestep', config_max_adaptive_timestep) call mpas_pool_get_config(liConfigs, 'config_min_adaptive_timestep', config_min_adaptive_timestep) call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_include_DCFL', config_adaptive_timestep_include_DCFL) + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_include_calving', config_adaptive_timestep_include_calving) + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_calvingCFL_fraction', config_adaptive_timestep_calvingCFL_fraction) + call mpas_pool_get_config(liConfigs, 'config_calving', config_calving) + call mpas_pool_get_config(liConfigs, 'config_damage_calving_method', config_damage_calving_method) + + allowableDt = allowableAdvecDt * config_adaptive_timestep_CFL_fraction + CFLprocess = 1 if (config_adaptive_timestep_include_DCFL) then - allowableDt = min(allowableAdvecDt, allowableDiffDt) - else - allowableDt = allowableAdvecDt + ! todo: We currently do not have a namelist option for the diffusive CFL fraction + ! But that's ok - we rarely use it. Could be added later if needed. + if (allowableDiffDt < allowableDt) then + allowableDt = allowableDiffDt + CFLprocess = 2 + endif + endif + + ! Only include calving CFL if requested and we are using a calving option that calculates it + if (config_adaptive_timestep_include_calving .and. ( & + trim(config_calving) == 'specified_calving_velocity' .or. & + trim(config_calving) == 'eigencalving' .or. & + trim(config_calving) == 'von_Mises_stress' .or. & + trim(config_calving) == 'ismip6_retreat' .or. & + (trim(config_calving) == 'damagecalving' .and. & + trim(config_damage_calving_method) == 'calving_rate'))) then + if (config_adaptive_timestep_calvingCFL_fraction * calvingCFLDt < allowableDt) then + allowableDt = config_adaptive_timestep_calvingCFL_fraction * calvingCFLDt + CFLprocess = 3 + endif + endif + + call mpas_log_write("CFL dt adjusted for fractions (days): advective=$r, diffusive=$r, calving=$r", & + realArgs=(/allowableAdvecDt*config_adaptive_timestep_CFL_fraction/86400.0_RKIND, & + allowableDiffDt/86400.0_RKIND, & + calvingCFLdt*config_adaptive_timestep_calvingCFL_fraction/86400.0_RKIND/)) + if (CFLprocess == 1) then + call mpas_log_write("Timestep limited by advective CFL condition.") + elseif (CFLprocess == 2) then + call mpas_log_write("Timestep limited by diffusive CFL condition.") + elseif (CFLprocess == 3) then + call mpas_log_write("Timestep limited by calving CFL condition.") endif ! Take minimum of the max adaptive timestep setting and the allowable dt from the CFL condition - proposedDt = min(allowableDt * config_adaptive_timestep_CFL_fraction, config_max_adaptive_timestep) + proposedDt = min(allowableDt, config_max_adaptive_timestep) + ! Round down the proposed dt to avoid complications with fractional seconds ! (some timekeeping-related functionality, like restarts, don't support them) ! (need to perform floor with an 8-bit integer to allow up 293 billion years in seconds) proposedDt = real(floor(proposedDt, KIND=8), RKIND) + ! Check if the proposed timestep is smaller than specified limit. + ! Do this prior to limiting the timestep for the force interval + if (proposedDt < config_min_adaptive_timestep) then + call mpas_log_write('New deltat is less than config_min_adaptive_timestep.', MPAS_LOG_ERR) + err = ior(err, 1) + endif + ! Check if we need to force a timestep length to hit the target interval currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) !print *, 'curr', currTime % t % YR, currTime % t % basetime % S, currTime % t % basetime % Sn, currTime % t % basetime % Sd @@ -919,10 +973,6 @@ subroutine set_timestep(allowableAdvecDt, allowableDiffDt, clock, dtSeconds, err dtSeconds = min(proposedDt, secondsToNextForceTime) call mpas_log_write(' Setting time step (days) to: $r', realArgs=(/dtSeconds / (86400.0_RKIND)/)) - if (dtSeconds < config_min_adaptive_timestep) then - call mpas_log_write('New deltat is less than config_min_adaptive_timestep.', MPAS_LOG_ERR) - err = ior(err, 1) - endif !-------------------------------------------------------------------- end subroutine set_timestep diff --git a/components/mpas-albany-landice/src/mode_forward/mpas_li_velocity_external.F b/components/mpas-albany-landice/src/mode_forward/mpas_li_velocity_external.F index 312e8fef9473..4cbe4da25bc8 100644 --- a/components/mpas-albany-landice/src/mode_forward/mpas_li_velocity_external.F +++ b/components/mpas-albany-landice/src/mode_forward/mpas_li_velocity_external.F @@ -473,11 +473,9 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, hydro integer :: iCell real(kind=RKIND), parameter :: secondsInYear = 365.0_RKIND * 24.0_RKIND * 3600.0_RKIND !< The value of seconds in a year assumed by external dycores - integer, target :: err_tmp - integer, pointer :: err_albany + integer, pointer :: albanyVelocityError err = 0 - err_tmp = 0 ! configs call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) @@ -522,6 +520,8 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, hydro call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged) call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel = 1) call mpas_pool_get_array(velocityPool, 'stiffnessFactor', stiffnessFactor) + call mpas_pool_get_array(velocityPool, 'albanyVelocityError', albanyVelocityError) + albanyVelocityError = 0 ! Hydro variables call mpas_pool_get_array(hydroPool, 'effectivePressure', effectivePressure) @@ -595,26 +595,24 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, hydro call mpas_timer_start("velocity_solver_solve_FO") - err_albany => err_tmp call velocity_solver_solve_FO(bedTopography, lowerSurface, thickness, & betaSolve, sfcMassBal, temperature, stiffnessFactor, & effectivePressureLimited, muFriction, & uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 normalVelocity, drivingStressVert, dissipationVertexField % array, uReconstructX, uReconstructY, & ! return values - deltat, err_albany) ! return values + deltat, albanyVelocityError) ! return values call mpas_timer_stop("velocity_solver_solve_FO") - if (err_tmp == 1) then + if (albanyVelocityError == 1) then if (config_nonconvergence_error) then call mpas_log_write("Albany velocity solve failed to converge! " // & "Check log.albany.0000.out for more information.", MPAS_LOG_ERR) + err = ior(err, albanyVelocityError) else call mpas_log_write("Albany velocity solve failed to converge! " // & "Check log.albany.0000.out for more information.", MPAS_LOG_WARN) - err_tmp = 0 endif endif - err = ior(err,err_tmp) ! Now interpolate from vertices to cell centers diff --git a/components/mpas-albany-landice/src/shared/mpas_li_mask.F b/components/mpas-albany-landice/src/shared/mpas_li_mask.F index 4f59343a054b..673ed8186e47 100644 --- a/components/mpas-albany-landice/src/shared/mpas_li_mask.F +++ b/components/mpas-albany-landice/src/shared/mpas_li_mask.F @@ -294,10 +294,10 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) logical :: isMargin logical :: isAlbanyMarginNeighbor logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, & - aCellOnVertexIsFloating, aCellOnVertexIsAlbanyActive + aCellOnVertexIsFloating, aCellOnVertexIsFloatingAndDynamic, aCellOnVertexIsAlbanyActive logical :: aCellOnVertexIsGrounded logical :: aCellOnEdgeHasIce, aCellOnEdgeHasNoIce, aCellOnEdgeHasDynamicIce, aCellOnEdgeHasNoDynamicIce, & - aCellOnEdgeIsFloating + aCellOnEdgeIsFloating, aCellOnEdgeIsFloatingAndDynamic logical :: aCellOnEdgeIsGrounded logical :: aCellOnEdgeIsOpenOcean integer :: numCellsOnVertex @@ -455,16 +455,20 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) endif ! Identify the grounding line - ! For a cell, we define the GL as a grounded cell with ice with at least one neighbor with floating ice or open ocean + ! For a cell, we define the GL as a grounded cell with ice with at least one dynamic floating neighbor + ! Note that this is a different definition that prior to Oct 2022. Earlier + ! defined the grounding line as a grounded cell with at least one neighbor + ! that was floating or open ocean, which caused issues with calculating + ! mass budgets at grounded marine margins. do i=1,nCells if (li_mask_is_grounded_ice(cellMask(i))) then ! only need to check grounded cells - do j=1,nEdgesOnCell(i) ! Check if any neighbors are floating or open ocean + do j=1,nEdgesOnCell(i) ! Check if any neighbors are floating dynamic ice iCellNeighbor = cellsOnCell(j,i) - if (li_mask_is_floating_ice(cellMask(iCellNeighbor)) .or. & - ((bedTopography(iCellNeighbor) < config_sea_level) .and. (.not. li_mask_is_ice(cellMask(iCellNeighbor)))) ) then + if ( li_mask_is_floating_ice(cellMask(iCellNeighbor)) .and. & + li_mask_is_dynamic_ice(cellMask(iCellNeighbor)) ) then cellMask(i) = ior(cellMask(i), li_mask_ValueGroundingLine) + exit ! if we found a floating neighbor, no need to look at additional neighbors endif - cycle ! no need to look at additional neighbors enddo endif enddo @@ -485,7 +489,8 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! cells (i.e., the cells exist in the mesh). This allows external dycores to use the ! vertexMask to get information about triangles in the Delaunay triangulation. ! (This is done in a way which does not assume vertexMask==3.) - ! Bit: GL is a vertex with at least one neighboring cell grounded ice and at least one neighboring cell floating ice + ! Bit: GL is a vertex with at least one neighboring cell grounded ice and at least one neighboring cell dynamic floating ice + ! Note: this definition was changed Oct 2022 from one cell grounded and one cell floating !call mpas_timer_start('calculate mask vertex') @@ -497,6 +502,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnVertexHasNoDynamicIce = .false. aCellOnVertexIsFloating = .false. aCellOnVertexIsGrounded = .false. + aCellOnVertexIsFloatingAndDynamic = .false. do j = 1, vertexDegree ! vertexDegree is usually 3 (e.g. CVT mesh) but could be something else (e.g. 4 for quad mesh) iCell = cellsOnVertex(j,i) aCellOnVertexHasIce = (aCellOnVertexHasIce .or. li_mask_is_ice(cellMask(iCell))) @@ -504,6 +510,9 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnVertexHasDynamicIce = (aCellOnVertexHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) aCellOnVertexHasNoDynamicIce = (aCellOnVertexHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) aCellOnVertexIsFloating = (aCellOnVertexIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) + aCellOnVertexIsFloatingAndDynamic = ( aCellOnVertexIsFloatingAndDynamic .or. & + (li_mask_is_floating_ice(cellMask(iCell)) .and. & + li_mask_is_dynamic_ice(cellMask(iCell))) ) aCellOnVertexIsGrounded = (aCellOnVertexIsGrounded .or. li_mask_is_grounded_ice(cellMask(iCell))) end do if (aCellOnVertexHasIce) then @@ -515,7 +524,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) if (aCellOnVertexIsFloating) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueFloating) endif - if (aCellOnVertexIsFloating .and. aCellOnVertexIsGrounded) then + if (aCellOnVertexIsFloatingAndDynamic .and. aCellOnVertexIsGrounded) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueGroundingLine) endif if (aCellOnVertexHasIce .and. aCellOnVertexHasNoIce) then @@ -583,7 +592,8 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! Bit: Edges on margin are edges with one neighboring cell with ice and one neighboring cell without ice ! Bit: Edges on dynamic margin are edges with one neighboring cell with dynamic ice and ! one neighboring cell without dynamic ice - ! Bit: GL is an edge with one cell grounded ice and one cell floating ice + ! Bit: GL is an edge with one cell grounded ice and one cell dynamic floating ice + ! Note: This was changed Oct 2022 from one cell grounded and one floating or open ocean !call mpas_timer_start('calculate mask edge') @@ -596,6 +606,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnEdgeIsFloating = .false. aCellOnEdgeIsGrounded = .false. aCellOnEdgeIsOpenOcean = .false. + aCellOnEdgeIsFloatingAndDynamic = .false. do j = 1, 2 iCell = cellsOnEdge(j,i) aCellOnEdgeHasIce = (aCellOnEdgeHasIce .or. li_mask_is_ice(cellMask(iCell))) @@ -603,6 +614,9 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnEdgeHasDynamicIce = (aCellOnEdgeHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) aCellOnEdgeHasNoDynamicIce = (aCellOnEdgeHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) aCellOnEdgeIsFloating = (aCellOnEdgeIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) + aCellOnEdgeIsFloatingAndDynamic = ( aCellOnEdgeIsFloatingAndDynamic .or. & + (li_mask_is_floating_ice(cellMask(iCell)) .and. & + li_mask_is_dynamic_ice(cellMask(iCell))) ) aCellOnEdgeIsGrounded = (aCellOnEdgeIsGrounded .or. li_mask_is_grounded_ice(cellMask(iCell))) aCellOnEdgeIsOpenOcean = aCellOnEdgeIsOpenOcean .or. & ((bedTopography(iCell) < config_sea_level) .and. (.not. li_mask_is_ice(cellMask(iCell)))) @@ -618,7 +632,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) if (aCellOnEdgeIsFloating) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueFloating) endif - if (aCellOnEdgeIsGrounded .and. (aCellOnEdgeIsFloating .or. aCellOnEdgeIsOpenOcean)) then + if (aCellOnEdgeIsGrounded .and. aCellOnEdgeIsFloatingAndDynamic) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueGroundingLine) endif if (aCellOnEdgeHasIce .and. aCellOnEdgeHasNoIce) then diff --git a/components/mpas-framework/Makefile b/components/mpas-framework/Makefile index c7804a511102..2d87dec8ef4f 100644 --- a/components/mpas-framework/Makefile +++ b/components/mpas-framework/Makefile @@ -167,29 +167,6 @@ pgi-summit: "USE_SHTNS = $(USE_SHTNS)" \ "CPPFLAGS = -DpgiFortran -D_MPI -DUNDERSCORE" ) -pgi-nersc: - ( $(MAKE) all \ - "FC_PARALLEL = ftn" \ - "CC_PARALLEL = cc" \ - "CXX_PARALLEL = CC" \ - "FC_SERIAL = ftn" \ - "CC_SERIAL = cc" \ - "CXX_SERIAL = CC" \ - "FFLAGS_FPIEEE = -Kieee" \ - "FFLAGS_PROMOTION = -r8" \ - "FFLAGS_OPT = -O3 -byteswapio -Mfree" \ - "CFLAGS_OPT = -O3" \ - "CXXFLAGS_OPT = -O3" \ - "LDFLAGS_OPT = -O3" \ - "FFLAGS_OMP = -mp" \ - "CFLAGS_OMP = -mp" \ - "BUILD_TARGET = $(@)" \ - "CORE = $(CORE)" \ - "DEBUG = $(DEBUG)" \ - "USE_PAPI = $(USE_PAPI)" \ - "OPENMP = $(OPENMP)" \ - "USE_SHTNS = $(USE_SHTNS)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) ifort: ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ @@ -397,31 +374,7 @@ g95: "USE_SHTNS = $(USE_SHTNS)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -cray-nersc: - ( $(MAKE) all \ - "FC_PARALLEL = ftn" \ - "CC_PARALLEL = cc" \ - "CXX_PARALLEL = CC" \ - "FC_SERIAL = ftn" \ - "CC_SERIAL = cc" \ - "CXX_SERIAL = CC" \ - "FFLAGS_FPIEEE = " \ - "FFLAGS_PROMOTION = -default64" \ - "FFLAGS_OPT = -O3 -f free" \ - "CFLAGS_OPT = -O3" \ - "CXXFLAGS_OPT = -O3" \ - "LDFLAGS_OPT = -O3" \ - "FFLAGS_OMP = " \ - "CFLAGS_OMP = " \ - "BUILD_TARGET = $(@)" \ - "CORE = $(CORE)" \ - "DEBUG = $(DEBUG)" \ - "USE_PAPI = $(USE_PAPI)" \ - "OPENMP = $(OPENMP)" \ - "USE_SHTNS = $(USE_SHTNS)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) - -gnu-nersc: +gnu-cray: GFORTRAN_GTE_10=$$(expr `ftn -dumpversion | cut -f1 -d.` \>= 10) ;\ if [ "$${GFORTRAN_GTE_10}" = "1" ]; then \ EXTRA_FFLAGS="-fallow-argument-mismatch"; \ @@ -456,7 +409,7 @@ gnu-nersc: "USE_SHTNS = $(USE_SHTNS)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" ) -intel-nersc: +intel-cray: ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ diff --git a/components/mpas-ocean/cime_config/buildnml b/components/mpas-ocean/cime_config/buildnml index d9612efe708d..dda7531576ab 100755 --- a/components/mpas-ocean/cime_config/buildnml +++ b/components/mpas-ocean/cime_config/buildnml @@ -41,8 +41,7 @@ def buildnml(case, caseroot, compname): atm_co2_const_val = case.get_value("CCSM_CO2_PPMV") ice_bgc = case.get_value("MPASI_BGC") ocn_pio_typename = case.get_value("OCN_PIO_TYPENAME") - ninst_ocn = 1 # Change if you want multiple instances... though this isn't coded yet. - ninst_ocn_real = case.get_value("NINST_OCN") + ninst_ocn = case.get_value("NINST_OCN") nthrds_ocn = case.get_value("NTHRDS_OCN") ntasks_ocn = case.get_value("NTASKS_PER_INST_OCN") rundir = case.get_value("RUNDIR") @@ -292,17 +291,10 @@ def buildnml(case, caseroot, compname): logger.warning(" But no file available for this grid.") #-------------------------------------------------------------------- - # Set the initial file, changing to a restart file for branch and hybrid runs - # Note: this is not setup for multiple instances + # Set the initial file #-------------------------------------------------------------------- input_file = "{}/ocn/mpas-o/{}/{}.{}.nc".format(din_loc_root, ocn_mask, ic_prefix, ic_date) - if run_type == 'hybrid' or run_type == 'branch': - input_file = "{}/{}.mpaso.rst.{}_{}.nc".format(rundir, run_refcase, run_refdate, run_reftod) - expect(os.path.exists(input_file), "ERROR mpaso buildnml: missing specified restart file for branch or hybrid run: " + input_file) - restart_file = "{}/{}.mpaso.rst.{}_{}.nc".format(rundir, casename, run_refdate, run_reftod) - if not os.path.exists(restart_file): - safe_copy(input_file, restart_file) #-------------------------------------------------------------------- # Generate input data file with stream-specified files @@ -343,6 +335,19 @@ def buildnml(case, caseroot, compname): safe_copy(os.path.join(rundir, "rpointer.ocn"), os.path.join(rundir, "rpointer.ocn{}".format(inst_string))) + stream_name_inst = f"{stream_name}{inst_string}" + + #-------------------------------------------------------------------- + # Change the initial file to a restart file for branch and hybrid runs + #-------------------------------------------------------------------- + + if run_type == 'hybrid' or run_type == 'branch': + input_file = "{}/{}.mpaso{}.rst.{}_{}.nc".format(rundir, run_refcase, inst_string, run_refdate, run_reftod) + expect(os.path.exists(input_file), "ERROR mpaso buildnml: missing specified restart file for branch or hybrid run: " + input_file) + restart_file = "{}/{}.mpaso{}.rst.{}_{}.nc".format(rundir, casename, inst_string, run_refdate, run_reftod) + if not os.path.exists(restart_file): + safe_copy(input_file, restart_file) + # ----------------------------------------------------- # create mpasoconf/cesm_namelist # ----------------------------------------------------- @@ -373,7 +378,7 @@ def buildnml(case, caseroot, compname): sysmod += " -atm_co2_const_val '{}'".format(atm_co2_const_val) sysmod += " -ice_bgc '{}'".format(ice_bgc) sysmod += " -ntasks_ocn '{}'".format(ntasks_ocn) - sysmod += " -ninst_ocn '{}'".format(ninst_ocn_real) + sysmod += " -ninst_ocn '{}'".format(ninst_ocn) # pass in OCN_MASK for now as a short-cut for the grid # at some point, we may want to pass both -- but for now this is simpler @@ -388,1271 +393,1271 @@ def buildnml(case, caseroot, compname): if os.path.isdir(rundir): safe_copy(os.path.join(mpasoconf_dir, "mpaso_in"), os.path.join(rundir, in_filename)) - # Write streams file if there isn't one in SourceMods - - if os.path.exists(os.path.join(caseroot, "SourceMods/src.mpaso", stream_name)): - safe_copy(os.path.join(caseroot, "SourceMods/src.mpaso", stream_name), os.path.join(rundir, stream_name)) - else: - lines = [] - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_bgc in ['eco_only', 'eco_and_dms', 'eco_and_macromolecules', 'eco_and_dms_and_macromolecules']: - lines.append(' ') - lines.append(' ') - - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - if ocn_forcing == 'datm_forced_restoring': - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append('') + lines.append(' filename_template="{}.mpaso{}.hist.$Y-$M-$D_$S.nc"'.format(casename, inst_string)) + lines.append(' filename_interval="00-01-00_00:00:00"') + lines.append(' clobber_mode="truncate"') + lines.append(' reference_time="01-01-01_00:00:00"') + lines.append(' output_interval="none">') lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_bgc in ['eco_only', 'eco_and_dms', 'eco_and_macromolecules', 'eco_and_dms_and_macromolecules']: + lines.append(' ') + lines.append(' ') - if analysis_mask_file != '': - lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') + lines.append(' filename_template="{}.mpaso{}.output_debug_block_$B.nc"'.format(casename, inst_string)) + lines.append(' reference_time="01-01-01_00:00:00"') + lines.append(' filename_interval="1000-00-00_00:00:00"') + lines.append(' clobber_mode="truncate"') + lines.append(' output_interval="1000-00-00_00:00:00">') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') lines.append('') lines.append('') - lines.append('') + lines.append('') + if ocn_forcing == 'datm_forced_restoring': + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + + if analysis_mask_file != '': + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + + lines.append('') + lines.append(' filename_template="{}.mpaso{}.hist.am.mocStreamfunctionOutput.$Y-$M-$D.nc"'.format(casename, inst_string)) + lines.append(' filename_interval="01-00-00_00:00:00"') + lines.append(' clobber_mode="truncate"') + lines.append(' reference_time="01-01-01_00:00:00"') + lines.append(' output_interval="none"') + lines.append(' packages="mocStreamfunctionAMPKG">') lines.append('') - lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') lines.append(' ') lines.append(' ') lines.append(' ') - lines.append(' ') lines.append('') lines.append('') - - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_bgc in ['eco_only', 'eco_and_dms', 'eco_and_macromolecules', 'eco_and_dms_and_macromolecules']: - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - if ocn_wave == 'true': - lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_bgc in ['eco_only', 'eco_and_dms', 'eco_and_macromolecules', 'eco_and_dms_and_macromolecules']: + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') lines.append('') lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_bgc in ['eco_only', 'eco_and_dms', 'eco_and_macromolecules', 'eco_and_dms_and_macromolecules']: - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_bgc in ['eco_only', 'eco_and_dms', 'eco_and_macromolecules', 'eco_and_dms_and_macromolecules']: + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') - lines.append(' useMissingValMask="true"') - lines.append(' filename_template="{}.mpaso.hist.am.timeSeriesStatsMonthly.$Y-$M-$D.nc"'.format(casename)) - lines.append(' filename_interval="00-01-00_00:00:00"') - lines.append(' reference_time="01-01-01_00:00:00"') - lines.append(' output_interval="00-01-00_00:00:00"') - lines.append(' clobber_mode="truncate"') - lines.append(' packages="timeSeriesStatsMonthlyAMPKG"') - lines.append(' runtime_format="single_file">') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if not ocn_grid.startswith("oRRS1"): - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_iceberg == 'true': - lines.append(' ') - lines.append(' ') + lines.append('') + lines.append('') + lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_wave == 'true': - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if not ocn_grid.startswith("oRRS1"): + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_iceberg == 'true': + lines.append(' ') + lines.append(' ') + + if ocn_bgc in ['eco_only', 'eco_and_dms', 'eco_and_macromolecules', 'eco_and_dms_and_macromolecules']: + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_wave == 'true': + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') - lines.append(' useMissingValMask="true"') - lines.append(' filename_template="{}.mpaso.hist.am.timeSeriesStatsMonthlyMax.$Y-$M-$D.nc"'.format(casename)) - lines.append(' filename_interval="00-01-00_00:00:00"') - lines.append(' reference_time="01-01-01_00:00:00"') - lines.append(' output_interval="00-01-00_00:00:00"') - lines.append(' clobber_mode="truncate"') - lines.append(' packages="timeSeriesStatsMonthlyMaxAMPKG"') - lines.append(' runtime_format="single_file">') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_iceberg == 'true': - lines.append(' ') - - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_iceberg == 'true': - lines.append(' ') - - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_iceberg == 'true': - lines.append(' ') - - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if ocn_iceberg == 'true': - lines.append(' ') - - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_iceberg == 'true': + lines.append(' ') + + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_iceberg == 'true': + lines.append(' ') + + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_iceberg == 'true': + lines.append(' ') + + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + if ocn_iceberg == 'true': + lines.append(' ') + + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append('') - lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - if eco_forcing_file != '': - lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') + lines.append(' packages="timeSeriesStatsDailyAMPKG"') + lines.append(' reference_time="01-01-01_00:00:00"') + lines.append(' output_interval="none">') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') lines.append('') lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + if eco_forcing_file != '': + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - - with open(os.path.join(rundir, stream_name), "w") as fd: - fd.write("\n".join(lines)) + with open(os.path.join(rundir, stream_name_inst), "w") as fd: + fd.write("\n".join(lines)) ############################################################################### def _main_func(): diff --git a/components/mpas-ocean/cime_config/config_compsets.xml b/components/mpas-ocean/cime_config/config_compsets.xml index 1d029b4fb270..7acef3f7c8e5 100644 --- a/components/mpas-ocean/cime_config/config_compsets.xml +++ b/components/mpas-ocean/cime_config/config_compsets.xml @@ -57,6 +57,11 @@ 2000_DATM%JRA-1p5_SLND_MPASSI_MPASO%DATMFORCED_DROF%JRA-1p5_SGLC_SWAV + + GMPAS-JRA1p5-DIB-ISMF + 2000_DATM%JRA-1p5_SLND_MPASSI%DIB_MPASO%IBISMFDATMFORCED_DROF%JRA-1p5-AIS0ROF_SGLC_SWAV + + GMPAS-JRA1p4 2000_DATM%JRA-1p4-2018_SLND_MPASSI_MPASO%DATMFORCED_DROF%JRA-1p4-2018_SGLC_SWAV diff --git a/components/mpas-ocean/driver/ocn_comp_mct.F b/components/mpas-ocean/driver/ocn_comp_mct.F index 7c0c3f767419..9c47dc25715b 100644 --- a/components/mpas-ocean/driver/ocn_comp_mct.F +++ b/components/mpas-ocean/driver/ocn_comp_mct.F @@ -392,8 +392,8 @@ end subroutine xml_stream_get_attributes ! Process namelist and streams files ! ---------- ! Override the names of the stream and namelist files - domain_ptr % namelist_filename = 'mpaso_in' - domain_ptr % streams_filename = 'streams.ocean' + domain_ptr % namelist_filename = 'mpaso_in' // trim(inst_suffix) + domain_ptr % streams_filename = 'streams.ocean' // trim(inst_suffix) ! Setup namelist variables, and read the namelist ierr = domain_ptr % core % setup_namelist(domain_ptr % configs, domain_ptr % namelist_filename, domain_ptr % dminfo) diff --git a/components/mpas-ocean/src/mode_forward/mpas_ocn_time_integration_split.F b/components/mpas-ocean/src/mode_forward/mpas_ocn_time_integration_split.F index 84dc8d4cfc5f..ae171995ad80 100644 --- a/components/mpas-ocean/src/mode_forward/mpas_ocn_time_integration_split.F +++ b/components/mpas-ocean/src/mode_forward/mpas_ocn_time_integration_split.F @@ -173,8 +173,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ edgeHaloComputeCounter, &! halo counters to reduce cellHaloComputeCounter ! halo updates during cycling - integer, dimension(:), pointer :: nEdgesArray - real (kind=RKIND) :: & normalThicknessFluxSum, &! sum of thickness flux in column thicknessSum, &! sum of thicknesses in column @@ -385,8 +383,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracersNew, 2) - call mpas_pool_get_dimension(meshPool,'nEdgesArray', nEdgesArray) - allocate(bottomDepthEdge(nEdgesAll+1)) if (config_transport_tests_flow_id > 0) then @@ -775,8 +771,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ enddo barotropicForcing(iEdge) = splitFact* & normalThicknessFluxSum/thicknessSum/dt - bottomDepthEdge(iEdge) = thicknessSum & - - 0.5_RKIND*(sshNew(cell1) + sshNew(cell2)) do k = minLevelEdgeBot(iEdge), maxLevelEdgeTop(iEdge) ! These two steps are together here: @@ -798,7 +792,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ !$omp parallel !$omp do schedule(runtime) & !$omp private(cell1, cell2, k, thicknessSum) - do iEdge = nEdgesOwned+1, nEdgesArray(4) + do iEdge = 1, nEdgesHalo(config_num_halos+1) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) thicknessSum = layerThickEdgeFlux(minLevelEdgeBot(iEdge),iEdge) diff --git a/components/mpas-seaice/cime_config/buildnml b/components/mpas-seaice/cime_config/buildnml index 9ad56f645a9f..a7944810ef12 100755 --- a/components/mpas-seaice/cime_config/buildnml +++ b/components/mpas-seaice/cime_config/buildnml @@ -37,9 +37,7 @@ def buildnml(case, caseroot, compname): iceberg_mode = case.get_value("MPASSI_ICEBERG_MODE") prognostic_mode = case.get_value("MPASSI_PROGNOSTIC_MODE") ice_pio_typename = case.get_value("ICE_PIO_TYPENAME") - #ninst_ice = case.get_value("NINST_ICE") - ninst_ice = 1 # Change if you want multiple instances... though this isn't coded yet. - ninst_ice_real = case.get_value("NINST_ICE") + ninst_ice = case.get_value("NINST_ICE") ntasks_ice = case.get_value("NTASKS_PER_INST_ICE") rundir = case.get_value("RUNDIR") run_type = case.get_value("RUN_TYPE") @@ -256,17 +254,10 @@ def buildnml(case, caseroot, compname): #-------------------------------------------------------------------- - # Set the initial file, changing to a restart file for branch and hybrid runs - # Note: this is not setup for multiple instances + # Set the initial file #-------------------------------------------------------------------- input_file = "{}/ice/mpas-cice/{}/{}.{}.nc".format(din_loc_root, ice_mask, grid_prefix, grid_date) - if run_type == 'hybrid' or run_type == 'branch': - input_file = "{}/{}.mpassi.rst.{}_{}.nc".format(rundir, run_refcase, run_refdate, run_reftod) - expect(os.path.exists(input_file), " ERROR mpassi buildnml: missing specified restart file for branch or hybrid run: {}".format(input_file)) - restart_file = "{}/{}.mpassi.rst.{}_{}.nc".format(rundir, casename, run_refdate, run_reftod) - if not os.path.exists(restart_file): - safe_copy(input_file, restart_file) #-------------------------------------------------------------------- # Generate input data file with stream-specified files @@ -302,6 +293,18 @@ def buildnml(case, caseroot, compname): os.path.exists(os.path.join(rundir, "rpointer.ice")): safe_copy(os.path.join(rundir, "rpointer.ice"), os.path.join(rundir, "rpointer.ice{}".format(inst_string))) + stream_name_inst = f"{stream_name}{inst_string}" + + #-------------------------------------------------------------------- + # Change the initial file to a restart file for branch and hybrid runs + #-------------------------------------------------------------------- + + if run_type == 'hybrid' or run_type == 'branch': + input_file = "{}/{}.mpassi{}.rst.{}_{}.nc".format(rundir, run_refcase, inst_string, run_refdate, run_reftod) + expect(os.path.exists(input_file), " ERROR mpassi buildnml: missing specified restart file for branch or hybrid run: {}".format(input_file)) + restart_file = "{}/{}.mpassi{}.rst.{}_{}.nc".format(rundir, casename, inst_string, run_refdate, run_reftod) + if not os.path.exists(restart_file): + safe_copy(input_file, restart_file) # ----------------------------------------------------- # create mpassiconf/cesm_namelist @@ -344,7 +347,7 @@ def buildnml(case, caseroot, compname): sysmod += " -iceberg_mode '{}'".format(iceberg_mode) sysmod += " -prognostic_mode '{}'".format(prognostic_mode) sysmod += " -ntasks_ice '{}'".format(ntasks_ice) - sysmod += " -ninst_ice '{}'".format(ninst_ice_real) + sysmod += " -ninst_ice '{}'".format(ninst_ice) # pass in ICE_MASK for now as a short-cut for the grid # at some point, we may want to pass both -- but for now this is simpler @@ -361,613 +364,613 @@ def buildnml(case, caseroot, compname): if os.path.isdir(rundir): safe_copy(os.path.join(mpassiconf_dir, "mpassi_in"), os.path.join(rundir, in_filename)) - # Write streams file if there isn't one in SourceMods + # Write streams file if there isn't one in SourceMods - if os.path.exists("{}/SourceMods/src.mpassi/{}".format(caseroot, stream_name)): - safe_copy("{}/SourceMods/src.mpassi/{}".format(caseroot, stream_name), rundir) + if os.path.exists("{}/SourceMods/src.mpassi/{}".format(caseroot, stream_name_inst)): + safe_copy("{}/SourceMods/src.mpassi/{}".format(caseroot, stream_name_inst), rundir) - else: - lines = [] - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append("") - lines.append('') - lines.append('') - lines.append('') + lines = [] + lines.append('') + lines.append('') + lines.append('') + lines.append('') lines.append('') + lines.append("") + lines.append('') + lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - if iceberg_mode == 'data': - lines.append('') + lines.append('') + + if ice_ic_mode == 'spunup': + lines.append('') + lines.append('') + + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' clobber_mode="truncate"') + lines.append(' output_interval="none" >') lines.append('') - lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') lines.append(' ') lines.append('') lines.append('') - - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - if iceberg_mode != 'none': - lines.append(' ') - lines.append(' ') - - if ice_bgc == 'ice_bgc': - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - - lines.append('') - lines.append('') - - if ice_bgc == 'ice_bgc': - if points_file != '': - lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + if iceberg_mode == 'data': + lines.append('') - + lines.append(' filename_template="{}/ice/mpas-cice/{}/{}"'.format(din_loc_root, ice_mask, data_iceberg_file)) + lines.append(' filename_interval="none"') + lines.append(' input_interval="none" >') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + + lines.append('') lines.append('') - - lines.append('') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') - + lines.append(' packages="regionalStatisticsAMPKG">') lines.append('') - - lines.append(' ') - lines.append(' ') lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') lines.append(' ') lines.append(' ') lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') lines.append(' ') - lines.append(' ') lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') + lines.append(' ') + lines.append(' ') + if iceberg_mode != 'none': + lines.append(' ') + lines.append(' ') + + if ice_bgc == 'ice_bgc': + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + + lines.append('') + lines.append('') + + if ice_bgc == 'ice_bgc': + if points_file != '': + lines.append('') + + lines.append('') + + lines.append('') + + lines.append('') + + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append(' ') + lines.append('') + + lines.append('') + + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(' ') + lines.append(' ') lines.append(' ') lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append('') + lines.append(''.format(din_loc_root, ice_mask, grid_prefix, grid_date)) + lines.append('') + lines.append(' ') + lines.append('') + lines.append('') + lines.append('') + lines.append('') - lines.append('') - - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - lines.append(''.format(din_loc_root, ice_mask, grid_prefix, grid_date)) - lines.append('') - lines.append(' ') - lines.append('') - lines.append('') - lines.append('') - lines.append('') - - with open(os.path.join(rundir, stream_name), "w") as fd: - fd.write("\n".join(lines)) + with open(os.path.join(rundir, stream_name_inst), "w") as fd: + fd.write("\n".join(lines)) ############################################################################### def _main_func(): diff --git a/components/mpas-seaice/cime_config/config_compsets.xml b/components/mpas-seaice/cime_config/config_compsets.xml index 16f03a9be252..8e0a9ce26ad2 100644 --- a/components/mpas-seaice/cime_config/config_compsets.xml +++ b/components/mpas-seaice/cime_config/config_compsets.xml @@ -9,6 +9,11 @@ + + DMPAS-JRA1p5 + 2000_DATM%JRA-1p5_SLND_MPASSI_DOCN%SOM_DROF%JRA-1p5_SGLC_SWAV_TEST + + DTESTM 2000_DATM%NYF_SLND_MPASSI_DOCN%SOM_DROF%NYF_SGLC_SWAV_TEST diff --git a/components/mpas-seaice/cime_config/config_pes.xml b/components/mpas-seaice/cime_config/config_pes.xml index bb3bbea1ee48..ed5f5056ad6a 100644 --- a/components/mpas-seaice/cime_config/config_pes.xml +++ b/components/mpas-seaice/cime_config/config_pes.xml @@ -32,6 +32,21 @@ + + + seaice: 20 nodes pure mpi, ~23 SYPD + + 720 + 720 + 720 + 720 + 720 + 720 + 720 + 720 + + + seaice+chrysalis: default, 4 nodes x 32 mpi x 2 omp @ root 0 @@ -59,6 +74,33 @@ + + + seaice+chrysalis: 20 nodes pure mpi, ~47 SYPD + 64 + 64 + + 1280 + 1280 + 1280 + 1280 + 1280 + 1280 + 1280 + 1280 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + seaice: default, 1 node x MAX_MPITASKS_PER_NODE mpi x 1 omp @ root 0 diff --git a/components/mpas-seaice/driver/ice_comp_mct.F b/components/mpas-seaice/driver/ice_comp_mct.F index 5c0e676ca088..8649380aad8a 100644 --- a/components/mpas-seaice/driver/ice_comp_mct.F +++ b/components/mpas-seaice/driver/ice_comp_mct.F @@ -380,8 +380,8 @@ end subroutine xml_stream_get_attributes ! Process namelist and streams files ! ---------- ! Override the names of the stream and namelist files - domain % namelist_filename = 'mpassi_in' - domain % streams_filename = 'streams.seaice' + domain % namelist_filename = 'mpassi_in' // trim(inst_suffix) + domain % streams_filename = 'streams.seaice' // trim(inst_suffix) ! Setup namelist variables, and read the namelist ierr = domain % core % setup_namelist(domain % configs, domain % namelist_filename, domain % dminfo) diff --git a/components/mpas-seaice/src/seaice.cmake b/components/mpas-seaice/src/seaice.cmake index 276190e2d595..e97a0f7c179e 100644 --- a/components/mpas-seaice/src/seaice.cmake +++ b/components/mpas-seaice/src/seaice.cmake @@ -96,6 +96,8 @@ list(APPEND RAW_SOURCES core_seaice/shared/mpas_seaice_velocity_solver_pwl.F core_seaice/shared/mpas_seaice_velocity_solver_variational_shared.F core_seaice/shared/mpas_seaice_velocity_solver_constitutive_relation.F + core_seaice/shared/mpas_seaice_triangle_quadrature.F + core_seaice/shared/mpas_seaice_wachspress_basis.F core_seaice/shared/mpas_seaice_forcing.F core_seaice/shared/mpas_seaice_initialize.F core_seaice/shared/mpas_seaice_testing.F diff --git a/components/mpas-seaice/src/shared/Makefile b/components/mpas-seaice/src/shared/Makefile index b57b984dae91..948f5199bb99 100644 --- a/components/mpas-seaice/src/shared/Makefile +++ b/components/mpas-seaice/src/shared/Makefile @@ -12,6 +12,8 @@ OBJS = mpas_seaice_time_integration.o \ mpas_seaice_velocity_solver_pwl.o \ mpas_seaice_velocity_solver_variational_shared.o \ mpas_seaice_velocity_solver_constitutive_relation.o \ + mpas_seaice_wachspress_basis.o \ + mpas_seaice_triangle_quadrature.o \ mpas_seaice_forcing.o \ mpas_seaice_initialize.o \ mpas_seaice_testing.o \ @@ -51,15 +53,19 @@ mpas_seaice_velocity_solver_constitutive_relation.o: mpas_seaice_constants.o mpa mpas_seaice_forcing.o: mpas_seaice_constants.o mpas_seaice_mesh.o mpas_seaice_column.o mpas_seaice_icepack.o +mpas_seaice_wachspress_basis.o: mpas_seaice_mesh.o + +mpas_seaice_triangle_quadrature.o: + mpas_seaice_velocity_solver_weak.o: mpas_seaice_constants.o mpas_seaice_testing.o mpas_seaice_velocity_solver_constitutive_relation.o mpas_seaice_mesh_pool.o mpas_seaice_velocity_solver_variational_shared.o: mpas_seaice_constants.o -mpas_seaice_velocity_solver_wachspress.o: mpas_seaice_constants.o mpas_seaice_numerics.o mpas_seaice_mesh.o mpas_seaice_testing.o mpas_seaice_velocity_solver_variational_shared.o +mpas_seaice_velocity_solver_wachspress.o: mpas_seaice_constants.o mpas_seaice_numerics.o mpas_seaice_mesh.o mpas_seaice_testing.o mpas_seaice_velocity_solver_variational_shared.o mpas_seaice_wachspress_basis.o mpas_seaice_triangle_quadrature.o mpas_seaice_velocity_solver_pwl.o: mpas_seaice_constants.o mpas_seaice_numerics.o mpas_seaice_mesh.o mpas_seaice_testing.o mpas_seaice_velocity_solver_variational_shared.o -mpas_seaice_velocity_solver_variational.o: mpas_seaice_constants.o mpas_seaice_velocity_solver_constitutive_relation.o mpas_seaice_velocity_solver_wachspress.o mpas_seaice_velocity_solver_pwl.o mpas_seaice_mesh_pool.o +mpas_seaice_velocity_solver_variational.o: mpas_seaice_constants.o mpas_seaice_velocity_solver_constitutive_relation.o mpas_seaice_velocity_solver_wachspress.o mpas_seaice_velocity_solver_pwl.o mpas_seaice_mesh_pool.o mpas_seaice_mesh.o mpas_seaice_velocity_solver.o: mpas_seaice_constants.o mpas_seaice_mesh.o mpas_seaice_testing.o mpas_seaice_velocity_solver_weak.o mpas_seaice_velocity_solver_constitutive_relation.o mpas_seaice_velocity_solver_variational.o mpas_seaice_diagnostics.o mpas_seaice_mesh_pool.o mpas_seaice_special_boundaries.o mpas_seaice_column.o mpas_seaice_icepack.o diff --git a/components/mpas-seaice/src/shared/mpas_seaice_mesh.F b/components/mpas-seaice/src/shared/mpas_seaice_mesh.F index 5ca85939ac80..6d88c05147af 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_mesh.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_mesh.F @@ -24,7 +24,8 @@ module seaice_mesh public :: & seaice_init_mesh, & - seaice_cell_vertices_at_vertex, & + seaice_wrapped_index, & + seaice_calc_local_coords, & seaice_normal_vectors, & seaice_normal_vectors_polygon, & seaice_dot_product_3space, & @@ -614,12 +615,12 @@ subroutine interior_edges(& end subroutine interior_edges !----------------------------------------------------------------------- -! mesh searches +! misc !----------------------------------------------------------------------- !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! -! seaice_cell_vertices_at_vertex +! seaice_wrapped_index ! !> \brief !> \author Adrian K. Turner, LANL @@ -629,60 +630,266 @@ end subroutine interior_edges ! !----------------------------------------------------------------------- - subroutine seaice_cell_vertices_at_vertex(& - cellVerticesAtVertex, & - nVertices, & - vertexDegree, & + function seaice_wrapped_index(& + input, & + nelements) & + result(output)!{{{ + + integer, intent(in) :: & + input, & !< Input: + nelements !< Input: + + integer :: output + + output = modulo(input - 1, nelements) + 1 + + end function seaice_wrapped_index!}}} +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_calc_local_coords +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 22 October 2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine seaice_calc_local_coords(& + xLocal, & + yLocal, & + nCells, & + nEdgesOnCell, & + verticesOnCell, & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell, & + rotateCartesianGrid, & + onASphere)!{{{ + + real(kind=RKIND), dimension(:,:), intent(out) :: & + xLocal, & !< Output: + yLocal !< Output: + + integer, intent(in) :: & + nCells !< Input: + + integer, dimension(:), intent(in) :: & + nEdgesOnCell !< Input: + + integer, dimension(:,:), intent(in) :: & + verticesOnCell !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + xVertex, & !< Input: + yVertex, & !< Input: + zVertex, & !< Input: + xCell, & !< Input: + yCell, & !< Input: + zCell !< Input: + + logical, intent(in) :: & + rotateCartesianGrid, & !< Input: + onASphere !< Input: + + if (onASphere) then + call calc_local_coords_spherical(& + xLocal, & + yLocal, & + nCells, & + nEdgesOnCell, & + verticesOnCell, & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell, & + rotateCartesianGrid) + else + call calc_local_coords_planar(& + xLocal, & + yLocal, & + nCells, & + nEdgesOnCell, & + verticesOnCell, & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell) + endif + + end subroutine seaice_calc_local_coords!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! calc_local_coords_planar +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine calc_local_coords_planar(& + xLocal, & + yLocal, & + nCells, & nEdgesOnCell, & verticesOnCell, & - cellsOnVertex)!{{{ + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell)!{{{ - integer, dimension(:,:), intent(out) :: & - cellVerticesAtVertex !< Output: + real(kind=RKIND), dimension(:,:), intent(out) :: & + xLocal, & !< Output: + yLocal !< Output: integer, intent(in) :: & - nVertices, & !< Input: - vertexDegree !< Input: + nCells !< Input: integer, dimension(:), intent(in) :: & nEdgesOnCell !< Input: integer, dimension(:,:), intent(in) :: & - cellsOnVertex, & !< Input: - verticesOnCell !< Input: + verticesOnCell !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + xVertex, & !< Input: + yVertex, & !< Input: + zVertex, & !< Input: + xCell, & !< Input: + yCell, & !< Input: + zCell !< Input: integer :: & - iVertex, & - iVertexDegree, & iCell, & - iVertexOnCell, & - jVertex + iVertex, & + iVertexOnCell - do iVertex = 1, nVertices + do iCell = 1, nCells - do iVertexDegree = 1, vertexDegree + do iVertexOnCell = 1, nEdgesOnCell(iCell) - cellVerticesAtVertex(iVertexDegree,iVertex) = 0 + iVertex = verticesOnCell(iVertexOnCell, iCell) - iCell = cellsOnVertex(iVertexDegree, iVertex) + xLocal(iVertexOnCell,iCell) = xVertex(iVertex) - xCell(iCell) + yLocal(iVertexOnCell,iCell) = yVertex(iVertex) - yCell(iCell) - do iVertexOnCell = 1, nEdgesOnCell(iCell) + enddo ! iVertexOnCell - jVertex = verticesOnCell(iVertexOnCell,iCell) + enddo ! iCell - if (iVertex == jVertex) then + end subroutine calc_local_coords_planar!}}} - cellVerticesAtVertex(iVertexDegree,iVertex) = iVertexOnCell +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! calc_local_coords_spherical +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 22 October 2014 +!> \details +!> +! +!----------------------------------------------------------------------- - endif + subroutine calc_local_coords_spherical(& + xLocal, & + yLocal, & + nCells, & + nEdgesOnCell, & + verticesOnCell, & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell, & + rotateCartesianGrid)!{{{ + + real(kind=RKIND), dimension(:,:), intent(out) :: & + xLocal, & !< Output: + yLocal !< Output: - enddo ! iVertexOnCell + integer, intent(in) :: & + nCells !< Input: - enddo ! iVertexDegree + integer, dimension(:), intent(in) :: & + nEdgesOnCell !< Input: - enddo ! iVertex + integer, dimension(:,:), intent(in) :: & + verticesOnCell !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + xVertex, & !< Input: + yVertex, & !< Input: + zVertex, & !< Input: + xCell, & !< Input: + yCell, & !< Input: + zCell !< Input: + + logical, intent(in) :: & + rotateCartesianGrid !< Input: + + real(kind=RKIND), dimension(3) :: & + normalVector3D + + real(kind=RKIND), dimension(2) :: & + normalVector2D + + integer :: & + iCell, & + iVertex, & + iVertexOnCell + + real(kind=RKIND) :: & + xCellRotated, & + yCellRotated, & + zCellRotated + + do iCell = 1, nCells + + call seaice_grid_rotation_forward(& + xCellRotated, yCellRotated, zCellRotated, & + xCell(iCell), yCell(iCell), zCell(iCell), & + rotateCartesianGrid) + + do iVertexOnCell = 1, nEdgesOnCell(iCell) + + iVertex = verticesOnCell(iVertexOnCell, iCell) + + call seaice_grid_rotation_forward(& + normalVector3D(1), normalVector3D(2), normalVector3D(3), & + xVertex(iVertex), yVertex(iVertex), zVertex(iVertex), & + rotateCartesianGrid) + + call seaice_project_3D_vector_onto_local_2D(& + normalVector2D, & + normalVector3D, & + xCellRotated, & + yCellRotated, & + zCellRotated) + + xLocal(iVertexOnCell,iCell) = normalVector2D(1) + yLocal(iVertexOnCell,iCell) = normalVector2D(2) + + enddo ! iVertexOnCell + + enddo ! iCell - end subroutine seaice_cell_vertices_at_vertex!}}} + end subroutine calc_local_coords_spherical!}}} !----------------------------------------------------------------------- ! normal vectors diff --git a/components/mpas-seaice/src/shared/mpas_seaice_triangle_quadrature.F b/components/mpas-seaice/src/shared/mpas_seaice_triangle_quadrature.F new file mode 100644 index 000000000000..a3b264e6c69f --- /dev/null +++ b/components/mpas-seaice/src/shared/mpas_seaice_triangle_quadrature.F @@ -0,0 +1,761 @@ +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_triangle_quadrature +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 4th November 2022 +!> \details +!> +! +!----------------------------------------------------------------------- + +module seaice_triangle_quadrature + + use mpas_derived_types + use mpas_log, only: mpas_log_write + + implicit none + + private + save + + public :: & + seaice_triangle_quadrature_rules + +contains + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_triangle_quadrature_rules +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 18th October 2016 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine seaice_triangle_quadrature_rules(& + integrationType, & + integrationOrder, & + nIntegrationPoints, & + u, & + v, & + weights, & + normalizationFactor) + + character(len=strKIND), intent(in) :: & + integrationType + + integer, intent(in) :: & + integrationOrder + + integer, intent(out) :: & + nIntegrationPoints + + real(kind=RKIND), dimension(:), allocatable, intent(out) :: & + u, & + v, & + weights + + real(kind=RKIND), intent(out) :: & + normalizationFactor + + if (trim(integrationType) == "trapezoidal") then + + call triangle_quadrature_rules_trapezoidal(& + integrationOrder, & + nIntegrationPoints, & + u, & + v, & + weights, & + normalizationFactor) + + else if (trim(integrationType) == "dunavant") then + + call triangle_quadrature_rules_dunavant(& + integrationOrder, & + nIntegrationPoints, & + u, & + v, & + weights, & + normalizationFactor) + + else if (trim(integrationType) == "fekete") then + + call triangle_quadrature_rules_fekete(& + integrationOrder, & + nIntegrationPoints, & + u, & + v, & + weights, & + normalizationFactor) + + else + + ! unknown integration type + call mpas_log_write("seaice_triangle_quadrature_rules: Unknown triangle quadrature type: "//trim(integrationType), MPAS_LOG_CRIT) + + endif + + end subroutine seaice_triangle_quadrature_rules + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! triangle_quadrature_rules_trapezoidal +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 18th October 2016 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine triangle_quadrature_rules_trapezoidal(& + integrationOrder, & + nIntegrationPoints, & + u, & + v, & + weights, & + normalizationFactor) + + integer, intent(in) :: & + integrationOrder + + integer, intent(out) :: & + nIntegrationPoints + + real(kind=RKIND), dimension(:), allocatable, intent(out) :: & + u, & + v, & + weights + + real(kind=RKIND), intent(out) :: & + normalizationFactor + + integer :: & + nIntegrationTriangles + + integer :: & + i, j, ij + + nIntegrationTriangles = integrationOrder + + ! total number of integration points in sub triangle + nIntegrationPoints = ((nIntegrationTriangles+1)**2 + (nIntegrationTriangles+1)) / 2 + + ! allocate integration factors + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + ! get integration point canonical location + ij = 1 + do i = 0, nIntegrationTriangles + do j = 0, nIntegrationTriangles-i + + u(ij) = real(i,RKIND) / real(nIntegrationTriangles,RKIND) + v(ij) = real(j,RKIND) / real(nIntegrationTriangles,RKIND) + + ij = ij + 1 + + enddo ! j + enddo ! i + + ! get the weights + ij = 1 + do i = 0, nIntegrationTriangles + do j = 0, nIntegrationTriangles-i + + weights(ij) = 0.0_RKIND + + if (i<=nIntegrationTriangles-j) then + + if (i==nIntegrationTriangles .or. j==nIntegrationTriangles .or. (i==0 .and. j==0)) then + + weights(ij) = 1.0_RKIND + + else if ((j==0 .and. i/=0 .and. i/=nIntegrationTriangles) .or. & + (i==0 .and. j/=0 .and. j/=nIntegrationTriangles) .or. & + (i==nIntegrationTriangles-j .and. i/=0 .and. j/=0)) then + + weights(ij) = 3.0_RKIND + + else + + weights(ij) = 6.0_RKIND + + endif + + endif + + ij = ij + 1 + + enddo ! j + enddo ! i + + ! normalization factor + normalizationFactor = 6.0_RKIND * real(nIntegrationTriangles,RKIND)**2 + + end subroutine triangle_quadrature_rules_trapezoidal + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! triangle_quadrature_rules_dunavant +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 18th October 2016 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine triangle_quadrature_rules_dunavant(& + integrationOrder, & + nIntegrationPoints, & + u, & + v, & + weights, & + normalizationFactor) + + integer, intent(in) :: & + integrationOrder + + integer, intent(out) :: & + nIntegrationPoints + + real(kind=RKIND), dimension(:), allocatable, intent(out) :: & + u, & + v, & + weights + + real(kind=RKIND), intent(out) :: & + normalizationFactor + + ! D. A. Dunavant, High degree efficient symmetrical Gaussian quadrature rules for the triangle, + ! Int. J. Num. Meth. Engng, 21(1985):1129-1148. + + normalizationFactor = 2.0_RKIND + + if (modulo(integrationOrder,2) /= 0) then + call mpas_log_write("get_integration_factors_dunavant: odd orders of integration not recommended", MPAS_LOG_WARN) + endif + + select case (integrationOrder) + case(1) + + nIntegrationPoints = 1 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.33333333333333_RKIND /) + + v = (/ & + 0.33333333333333_RKIND /) + + weights = (/ & + 1.00000000000000_RKIND /) + + case (2) + + nIntegrationPoints = 3 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.16666666666667_RKIND, 0.16666666666667_RKIND, 0.66666666666667_RKIND /) + + v = (/ & + 0.16666666666667_RKIND, 0.66666666666667_RKIND, 0.16666666666667_RKIND /) + + weights = (/ & + 0.33333333333333_RKIND, 0.33333333333333_RKIND, 0.33333333333333_RKIND /) + + case (3) + + nIntegrationPoints = 4 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.33333333333333_RKIND, 0.20000000000000_RKIND, 0.20000000000000_RKIND, 0.60000000000000_RKIND /) + + v = (/ & + 0.33333333333333_RKIND, 0.20000000000000_RKIND, 0.60000000000000_RKIND, 0.20000000000000_RKIND /) + + weights = (/ & + -0.56250000000000_RKIND, 0.52083333333333_RKIND, 0.52083333333333_RKIND, 0.52083333333333_RKIND /) + + case (4) + + nIntegrationPoints = 6 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.44594849091597_RKIND, 0.44594849091597_RKIND, 0.10810301816807_RKIND, 0.09157621350977_RKIND, & + 0.09157621350977_RKIND, 0.81684757298046_RKIND /) + + v = (/ & + 0.44594849091597_RKIND, 0.10810301816807_RKIND, 0.44594849091597_RKIND, 0.09157621350977_RKIND, & + 0.81684757298046_RKIND, 0.09157621350977_RKIND /) + + weights = (/ & + 0.22338158967801_RKIND, 0.22338158967801_RKIND, 0.22338158967801_RKIND, 0.10995174365532_RKIND, & + 0.10995174365532_RKIND, 0.10995174365532_RKIND /) + + case (5) + + nIntegrationPoints = 7 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.33333333333333_RKIND, 0.47014206410511_RKIND, 0.47014206410511_RKIND, 0.05971587178977_RKIND, & + 0.10128650732346_RKIND, 0.10128650732346_RKIND, 0.79742698535309_RKIND /) + + v = (/ & + 0.33333333333333_RKIND, 0.47014206410511_RKIND, 0.05971587178977_RKIND, 0.47014206410511_RKIND, & + 0.10128650732346_RKIND, 0.79742698535309_RKIND, 0.10128650732346_RKIND /) + + weights = (/ & + 0.22500000000000_RKIND, 0.13239415278851_RKIND, 0.13239415278851_RKIND, 0.13239415278851_RKIND, & + 0.12593918054483_RKIND, 0.12593918054483_RKIND, 0.12593918054483_RKIND /) + + case (6) + + nIntegrationPoints = 12 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.24928674517091_RKIND, 0.24928674517091_RKIND, 0.50142650965818_RKIND, 0.06308901449150_RKIND, & + 0.06308901449150_RKIND, 0.87382197101700_RKIND, 0.31035245103378_RKIND, 0.63650249912140_RKIND, & + 0.05314504984482_RKIND, 0.63650249912140_RKIND, 0.31035245103378_RKIND, 0.05314504984482_RKIND /) + + v = (/ & + 0.24928674517091_RKIND, 0.50142650965818_RKIND, 0.24928674517091_RKIND, 0.06308901449150_RKIND, & + 0.87382197101700_RKIND, 0.06308901449150_RKIND, 0.63650249912140_RKIND, 0.05314504984482_RKIND, & + 0.31035245103378_RKIND, 0.31035245103378_RKIND, 0.05314504984482_RKIND, 0.63650249912140_RKIND /) + + weights = (/ & + 0.11678627572638_RKIND, 0.11678627572638_RKIND, 0.11678627572638_RKIND, 0.05084490637021_RKIND, & + 0.05084490637021_RKIND, 0.05084490637021_RKIND, 0.08285107561837_RKIND, 0.08285107561837_RKIND, & + 0.08285107561837_RKIND, 0.08285107561837_RKIND, 0.08285107561837_RKIND, 0.08285107561837_RKIND /) + + case (7) + + nIntegrationPoints = 13 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.33333333333333_RKIND, 0.26034596607904_RKIND, 0.26034596607904_RKIND, 0.47930806784192_RKIND, & + 0.06513010290222_RKIND, 0.06513010290222_RKIND, 0.86973979419557_RKIND, 0.31286549600487_RKIND, & + 0.63844418856981_RKIND, 0.04869031542532_RKIND, 0.63844418856981_RKIND, 0.31286549600487_RKIND, & + 0.04869031542532_RKIND /) + + v = (/ & + 0.33333333333333_RKIND, 0.26034596607904_RKIND, 0.47930806784192_RKIND, 0.26034596607904_RKIND, & + 0.06513010290222_RKIND, 0.86973979419557_RKIND, 0.06513010290222_RKIND, 0.63844418856981_RKIND, & + 0.04869031542532_RKIND, 0.31286549600487_RKIND, 0.31286549600487_RKIND, 0.04869031542532_RKIND, & + 0.63844418856981_RKIND /) + + weights = (/ & + -0.14957004446768_RKIND, 0.17561525743321_RKIND, 0.17561525743321_RKIND, 0.17561525743321_RKIND, & + 0.05334723560884_RKIND, 0.05334723560884_RKIND, 0.05334723560884_RKIND, 0.07711376089026_RKIND, & + 0.07711376089026_RKIND, 0.07711376089026_RKIND, 0.07711376089026_RKIND, 0.07711376089026_RKIND, & + 0.07711376089026_RKIND /) + + case (8) + + nIntegrationPoints = 16 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.33333333333333_RKIND, 0.45929258829272_RKIND, 0.45929258829272_RKIND, 0.08141482341455_RKIND, & + 0.17056930775176_RKIND, 0.17056930775176_RKIND, 0.65886138449648_RKIND, 0.05054722831703_RKIND, & + 0.05054722831703_RKIND, 0.89890554336594_RKIND, 0.26311282963464_RKIND, 0.72849239295540_RKIND, & + 0.00839477740996_RKIND, 0.72849239295540_RKIND, 0.26311282963464_RKIND, 0.00839477740996_RKIND /) + + v = (/ & + 0.33333333333333_RKIND, 0.45929258829272_RKIND, 0.08141482341455_RKIND, 0.45929258829272_RKIND, & + 0.17056930775176_RKIND, 0.65886138449648_RKIND, 0.17056930775176_RKIND, 0.05054722831703_RKIND, & + 0.89890554336594_RKIND, 0.05054722831703_RKIND, 0.72849239295540_RKIND, 0.00839477740996_RKIND, & + 0.26311282963464_RKIND, 0.26311282963464_RKIND, 0.00839477740996_RKIND, 0.72849239295540_RKIND /) + + weights = (/ & + 0.14431560767779_RKIND, 0.09509163426728_RKIND, 0.09509163426728_RKIND, 0.09509163426728_RKIND, & + 0.10321737053472_RKIND, 0.10321737053472_RKIND, 0.10321737053472_RKIND, 0.03245849762320_RKIND, & + 0.03245849762320_RKIND, 0.03245849762320_RKIND, 0.02723031417443_RKIND, 0.02723031417443_RKIND, & + 0.02723031417443_RKIND, 0.02723031417443_RKIND, 0.02723031417443_RKIND, 0.02723031417443_RKIND /) + + case (9) + + nIntegrationPoints = 19 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.333333333333333_RKIND, 0.020634961602525_RKIND, 0.489682519198738_RKIND, 0.489682519198738_RKIND, & + 0.125820817014127_RKIND, 0.437089591492937_RKIND, 0.437089591492937_RKIND, 0.623592928761935_RKIND, & + 0.188203535619033_RKIND, 0.188203535619033_RKIND, 0.910540973211095_RKIND, 0.044729513394453_RKIND, & + 0.044729513394453_RKIND, 0.036838412054736_RKIND, 0.221962989160766_RKIND, 0.036838412054736_RKIND, & + 0.741198598784498_RKIND, 0.221962989160766_RKIND, 0.741198598784498_RKIND /) + + v = (/ & + 0.333333333333333_RKIND, 0.489682519198738_RKIND, 0.020634961602525_RKIND, 0.489682519198738_RKIND, & + 0.437089591492937_RKIND, 0.125820817014127_RKIND, 0.437089591492937_RKIND, 0.188203535619033_RKIND, & + 0.623592928761935_RKIND, 0.188203535619033_RKIND, 0.044729513394453_RKIND, 0.910540973211095_RKIND, & + 0.044729513394453_RKIND, 0.221962989160766_RKIND, 0.036838412054736_RKIND, 0.741198598784498_RKIND, & + 0.036838412054736_RKIND, 0.741198598784498_RKIND, 0.221962989160766_RKIND /) + + weights = (/ & + 0.097135796282799_RKIND, 0.031334700227139_RKIND, 0.031334700227139_RKIND, 0.031334700227139_RKIND, & + 0.077827541004774_RKIND, 0.077827541004774_RKIND, 0.077827541004774_RKIND, 0.079647738927210_RKIND, & + 0.079647738927210_RKIND, 0.079647738927210_RKIND, 0.025577675658698_RKIND, 0.025577675658698_RKIND, & + 0.025577675658698_RKIND, 0.043283539377289_RKIND, 0.043283539377289_RKIND, 0.043283539377289_RKIND, & + 0.043283539377289_RKIND, 0.043283539377289_RKIND, 0.043283539377289_RKIND /) + + case (10) + + nIntegrationPoints = 25 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.333333333333333_RKIND, 0.028844733232685_RKIND, 0.485577633383657_RKIND, 0.485577633383657_RKIND, & + 0.781036849029926_RKIND, 0.109481575485037_RKIND, 0.109481575485037_RKIND, 0.141707219414880_RKIND, & + 0.307939838764121_RKIND, 0.141707219414880_RKIND, 0.550352941820999_RKIND, 0.307939838764121_RKIND, & + 0.550352941820999_RKIND, 0.025003534762686_RKIND, 0.246672560639903_RKIND, 0.025003534762686_RKIND, & + 0.728323904597411_RKIND, 0.246672560639903_RKIND, 0.728323904597411_RKIND, 0.009540815400299_RKIND, & + 0.066803251012200_RKIND, 0.009540815400299_RKIND, 0.923655933587500_RKIND, 0.066803251012200_RKIND, & + 0.923655933587500_RKIND /) + + v = (/ & + 0.333333333333333_RKIND, 0.485577633383657_RKIND, 0.028844733232685_RKIND, 0.485577633383657_RKIND, & + 0.109481575485037_RKIND, 0.781036849029926_RKIND, 0.109481575485037_RKIND, 0.307939838764121_RKIND, & + 0.141707219414880_RKIND, 0.550352941820999_RKIND, 0.141707219414880_RKIND, 0.550352941820999_RKIND, & + 0.307939838764121_RKIND, 0.246672560639903_RKIND, 0.025003534762686_RKIND, 0.728323904597411_RKIND, & + 0.025003534762686_RKIND, 0.728323904597411_RKIND, 0.246672560639903_RKIND, 0.066803251012200_RKIND, & + 0.009540815400299_RKIND, 0.923655933587500_RKIND, 0.009540815400299_RKIND, 0.923655933587500_RKIND, & + 0.066803251012200_RKIND /) + + weights = (/ & + 0.090817990382754_RKIND, 0.036725957756467_RKIND, 0.036725957756467_RKIND, 0.036725957756467_RKIND, & + 0.045321059435528_RKIND, 0.045321059435528_RKIND, 0.045321059435528_RKIND, 0.072757916845420_RKIND, & + 0.072757916845420_RKIND, 0.072757916845420_RKIND, 0.072757916845420_RKIND, 0.072757916845420_RKIND, & + 0.072757916845420_RKIND, 0.028327242531057_RKIND, 0.028327242531057_RKIND, 0.028327242531057_RKIND, & + 0.028327242531057_RKIND, 0.028327242531057_RKIND, 0.028327242531057_RKIND, 0.009421666963733_RKIND, & + 0.009421666963733_RKIND, 0.009421666963733_RKIND, 0.009421666963733_RKIND, 0.009421666963733_RKIND, & + 0.009421666963733_RKIND /) + + case (12) + + nIntegrationPoints = 33 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.023565220452390_RKIND, 0.488217389773805_RKIND, 0.488217389773805_RKIND, 0.120551215411079_RKIND, & + 0.439724392294460_RKIND, 0.439724392294460_RKIND, 0.457579229975768_RKIND, 0.271210385012116_RKIND, & + 0.271210385012116_RKIND, 0.744847708916828_RKIND, 0.127576145541586_RKIND, 0.127576145541586_RKIND, & + 0.957365299093579_RKIND, 0.021317350453210_RKIND, 0.021317350453210_RKIND, 0.115343494534698_RKIND, & + 0.275713269685514_RKIND, 0.115343494534698_RKIND, 0.608943235779788_RKIND, 0.275713269685514_RKIND, & + 0.608943235779788_RKIND, 0.022838332222257_RKIND, 0.281325580989940_RKIND, 0.022838332222257_RKIND, & + 0.695836086787803_RKIND, 0.281325580989940_RKIND, 0.695836086787803_RKIND, 0.025734050548330_RKIND, & + 0.116251915907597_RKIND, 0.025734050548330_RKIND, 0.858014033544073_RKIND, 0.116251915907597_RKIND, & + 0.858014033544073_RKIND /) + + v = (/ & + 0.488217389773805_RKIND, 0.023565220452390_RKIND, 0.488217389773805_RKIND, 0.439724392294460_RKIND, & + 0.120551215411079_RKIND, 0.439724392294460_RKIND, 0.271210385012116_RKIND, 0.457579229975768_RKIND, & + 0.271210385012116_RKIND, 0.127576145541586_RKIND, 0.744847708916828_RKIND, 0.127576145541586_RKIND, & + 0.021317350453210_RKIND, 0.957365299093579_RKIND, 0.021317350453210_RKIND, 0.275713269685514_RKIND, & + 0.115343494534698_RKIND, 0.608943235779788_RKIND, 0.115343494534698_RKIND, 0.608943235779788_RKIND, & + 0.275713269685514_RKIND, 0.281325580989940_RKIND, 0.022838332222257_RKIND, 0.695836086787803_RKIND, & + 0.022838332222257_RKIND, 0.695836086787803_RKIND, 0.281325580989940_RKIND, 0.116251915907597_RKIND, & + 0.025734050548330_RKIND, 0.858014033544073_RKIND, 0.025734050548330_RKIND, 0.858014033544073_RKIND, & + 0.116251915907597_RKIND /) + + weights = (/ & + 0.025731066440455_RKIND, 0.025731066440455_RKIND, 0.025731066440455_RKIND, 0.043692544538038_RKIND, & + 0.043692544538038_RKIND, 0.043692544538038_RKIND, 0.062858224217885_RKIND, 0.062858224217885_RKIND, & + 0.062858224217885_RKIND, 0.034796112930709_RKIND, 0.034796112930709_RKIND, 0.034796112930709_RKIND, & + 0.006166261051559_RKIND, 0.006166261051559_RKIND, 0.006166261051559_RKIND, 0.040371557766381_RKIND, & + 0.040371557766381_RKIND, 0.040371557766381_RKIND, 0.040371557766381_RKIND, 0.040371557766381_RKIND, & + 0.040371557766381_RKIND, 0.022356773202303_RKIND, 0.022356773202303_RKIND, 0.022356773202303_RKIND, & + 0.022356773202303_RKIND, 0.022356773202303_RKIND, 0.022356773202303_RKIND, 0.017316231108659_RKIND, & + 0.017316231108659_RKIND, 0.017316231108659_RKIND, 0.017316231108659_RKIND, 0.017316231108659_RKIND, & + 0.017316231108659_RKIND /) + + case default + + call mpas_log_write(& + "get_integration_factors_dunavant: Unimplemented integration order for Dunavant wachspress integration", & + MPAS_LOG_CRIT) + + end select + + end subroutine triangle_quadrature_rules_dunavant + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! triangle_quadrature_rules_fekete +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 18th October 2016 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine triangle_quadrature_rules_fekete(& + integrationOrder, & + nIntegrationPoints, & + u, & + v, & + weights, & + normalizationFactor) + + integer, intent(in) :: & + integrationOrder + + integer, intent(out) :: & + nIntegrationPoints + + real(kind=RKIND), dimension(:), allocatable, intent(out) :: & + u, & + v, & + weights + + real(kind=RKIND), intent(out) :: & + normalizationFactor + + ! M. A. TAYLOR, B. A. WINGATE, AND R. E. VINCENT, (200), "AN ALGORITHM FOR COMPUTING FEKETE POINTS IN THE TRIANGLE", + ! SIAM J. NUMER. ANAL., Vol. 38, No. 5, pp. 1707–1720 + + normalizationFactor = 2.0_RKIND + + select case (integrationOrder) + case (1) + + nIntegrationPoints = 1 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 3.33333333333333333e-01_RKIND /) + + v = (/ & + 3.33333333333333333e-01_RKIND /) + + weights = (/ & + 1.0_RKIND /) + + case (2) + + nIntegrationPoints = 3 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 1.66666666666666666e-01_RKIND, 6.66666666666666666e-01_RKIND, 1.66666666666666666e-01_RKIND /) + + v = (/ & + 6.66666666666666666e-01_RKIND, 1.66666666666666666e-01_RKIND, 1.66666666666666666e-01_RKIND /) + + weights = (/ & + 3.33333333333333333e-01_RKIND, 3.33333333333333333e-01_RKIND, 3.33333333333333333e-01_RKIND /) + + case (3:4) + + nIntegrationPoints = 6 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 9.15762135097704655e-02_RKIND, 8.16847572980458514e-01_RKIND, & + 9.15762135097710761e-02_RKIND, 1.08103018168070275e-01_RKIND, & + 4.45948490915965612e-01_RKIND, 4.45948490915964113e-01_RKIND /) + + v = (/ & + 8.16847572980458514e-01_RKIND, 9.15762135097710761e-02_RKIND, & + 9.15762135097704655e-02_RKIND, 4.45948490915964113e-01_RKIND, & + 1.08103018168070275e-01_RKIND, 4.45948490915965612e-01_RKIND /) + + weights = (/ & + 1.09951743655321843e-01_RKIND, 1.09951743655321857e-01_RKIND, & + 1.09951743655321885e-01_RKIND, 2.23381589678011389e-01_RKIND, & + 2.23381589678011527e-01_RKIND, 2.23381589678011527e-01_RKIND /) + + case (5) + + nIntegrationPoints = 10 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 0.00000000000000000e+00_RKIND, 1.00000000000000000e+00_RKIND, & + 0.00000000000000000e+00_RKIND, 2.67327353118498978e-01_RKIND, & + 6.72817552946136210e-01_RKIND, 6.49236350054349654e-02_RKIND, & + 6.71649853904175198e-01_RKIND, 6.54032456800035522e-02_RKIND, & + 2.69376706913982855e-01_RKIND, 3.38673850389605513e-01_RKIND /) + + v = (/ & + 1.00000000000000000e+00_RKIND, 0.00000000000000000e+00_RKIND, & + 0.00000000000000000e+00_RKIND, 6.72819921871012694e-01_RKIND, & + 2.67328859948191944e-01_RKIND, 6.71653011149382917e-01_RKIND, & + 6.49251690028951334e-02_RKIND, 2.69378936645285116e-01_RKIND, & + 6.54054874919145490e-02_RKIND, 3.38679989302702156e-01_RKIND /) + + weights = (/ & + 1.31356049751916795e-02_RKIND, 1.31358306034076201e-02_RKIND, & + 1.37081973800151392e-02_RKIND, 1.17419193291163376e-01_RKIND, & + 1.17420611913379477e-01_RKIND, 1.24012589655715613e-01_RKIND, & + 1.24015246126072495e-01_RKIND, 1.25930230276426303e-01_RKIND, & + 1.25933026682913923e-01_RKIND, 2.25289469095714456e-01_RKIND /) + + case (6) + + nIntegrationPoints = 11 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 5.72549866774768601e-02_RKIND, 8.95362640024579104e-01_RKIND, 6.84475748456514044e-01_RKIND, & + 6.87462559150295305e-02_RKIND, 6.15676205575839575e-01_RKIND, 6.27946141197789465e-01_RKIND, & + 6.29091383418635686e-02_RKIND, 6.83782119205099126e-02_RKIND, 2.87529458374392255e-01_RKIND, & + 3.28783556413134614e-01_RKIND, 3.12290405013644801e-01_RKIND /) + + v = (/ & + 8.95498146789879490e-01_RKIND, 6.18282212503219533e-02_RKIND, 2.33437384976827311e-02_RKIND, & + 6.00302757472630025e-02_RKIND, 3.33461808341377175e-01_RKIND, 1.59189185992151483e-01_RKIND, & + 6.55295093705452469e-01_RKIND, 3.09117685428267230e-01_RKIND, 6.36426509179620181e-01_RKIND, & + 7.70240056424634223e-02_RKIND, 3.52344786445899505e-01_RKIND /) + + weights = (/ & + 3.80680718529555623e-02_RKIND, 3.83793553077528410e-02_RKIND, 4.62004567445618367e-02_RKIND, & + 5.34675894441989999e-02_RKIND, 8.37558269657456833e-02_RKIND, 1.01644833025517037e-01_RKIND, & + 1.01861524461366940e-01_RKIND, 1.11421831660001677e-01_RKIND, 1.12009450262946106e-01_RKIND, & + 1.24787571437558295e-01_RKIND, 1.88403488837394911e-01_RKIND /) + + case (8) + + nIntegrationPoints = 16 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 7.28492392955404355e-01_RKIND, 8.39477740995753056e-03_RKIND, 2.63112829634638112e-01_RKIND, & + 8.39477740995753056e-03_RKIND, 7.28492392955404355e-01_RKIND, 2.63112829634638112e-01_RKIND, & + 5.05472283170310122e-02_RKIND, 5.05472283170309566e-02_RKIND, 8.98905543365938087e-01_RKIND, & + 4.59292588292723236e-01_RKIND, 8.14148234145536387e-02_RKIND, 4.59292588292723125e-01_RKIND, & + 1.70569307751760324e-01_RKIND, 1.70569307751760046e-01_RKIND, 6.58861384496479685e-01_RKIND, & + 3.33333333333333370e-01_RKIND /) + + v = (/ & + 8.39477740995753056e-03_RKIND, 2.63112829634638112e-01_RKIND, 7.28492392955404355e-01_RKIND, & + 7.28492392955404355e-01_RKIND, 2.63112829634638112e-01_RKIND, 8.39477740995753056e-03_RKIND, & + 5.05472283170309566e-02_RKIND, 8.98905543365938087e-01_RKIND, 5.05472283170310122e-02_RKIND, & + 8.14148234145536387e-02_RKIND, 4.59292588292723125e-01_RKIND, 4.59292588292723236e-01_RKIND, & + 6.58861384496479685e-01_RKIND, 1.70569307751760324e-01_RKIND, 1.70569307751760046e-01_RKIND, & + 3.33333333333333370e-01_RKIND /) + + weights = (/ & + 2.72303141744348991e-02_RKIND, 2.72303141744349199e-02_RKIND, 2.72303141744349199e-02_RKIND, & + 2.72303141744349789e-02_RKIND, 2.72303141744349789e-02_RKIND, 2.72303141744349997e-02_RKIND, & + 3.24584976231980793e-02_RKIND, 3.24584976231980793e-02_RKIND, 3.24584976231981001e-02_RKIND, & + 9.50916342672845638e-02_RKIND, 9.50916342672846193e-02_RKIND, 9.50916342672846193e-02_RKIND, & + 1.03217370534718286e-01_RKIND, 1.03217370534718314e-01_RKIND, 1.03217370534718314e-01_RKIND, & + 1.44315607677787283e-01_RKIND /) + + case (9) + + nIntegrationPoints = 19 + + allocate(u(nIntegrationPoints)) + allocate(v(nIntegrationPoints)) + allocate(weights(nIntegrationPoints)) + + u = (/ & + 2.26739052759332704e-01_RKIND, 4.77345862087794129e-02_RKIND, 2.26577168977105115e-02_RKIND, & + 9.10074385862343016e-01_RKIND, 4.41452661673673585e-02_RKIND, 4.79944340675050984e-01_RKIND, & + 7.42657808541620557e-01_RKIND, 7.43369623518591927e-01_RKIND, 2.79454959355581213e-02_RKIND, & + 3.71861932583309532e-02_RKIND, 2.22639561442096401e-01_RKIND, 1.16082059855864395e-01_RKIND, & + 4.73822270420208358e-01_RKIND, 4.77758170054016440e-01_RKIND, 6.46387881792721997e-01_RKIND, & + 2.85357695207302253e-01_RKIND, 2.04236860041029755e-01_RKIND, 1.59370884213907937e-01_RKIND, & + 3.95698265017060125e-01_RKIND /) + + v = (/ & + 0.00000000000000000e+00_RKIND, 9.16183156802148568e-01_RKIND, 7.97193825386026345e-01_RKIND, & + 4.44666861644595901e-02_RKIND, 4.81588383854628099e-02_RKIND, 5.01294615157430568e-01_RKIND, & + 3.03405081749971196e-02_RKIND, 2.22245578824042445e-01_RKIND, 5.25527023486726308e-01_RKIND, & + 2.39263537482135413e-01_RKIND, 7.29063709376736702e-01_RKIND, 6.62507673462198188e-01_RKIND, & + 4.60334709656892230e-02_RKIND, 4.01038691325781238e-01_RKIND, 1.65342747538830548e-01_RKIND, & + 4.92973630851354261e-01_RKIND, 1.19056565447230756e-01_RKIND, 3.66261159763432431e-01_RKIND, & + 2.27511600022304139e-01_RKIND /) + + weights = (/ & + 1.58676858667487208e-02_RKIND, 2.19524732703951786e-02_RKIND, 2.40354401213296598e-02_RKIND, & + 2.58522468388647786e-02_RKIND, 2.71951393759608216e-02_RKIND, 3.02097786027936584e-02_RKIND, & + 3.70093240446550606e-02_RKIND, 4.11482921825866571e-02_RKIND, 4.26331605467379776e-02_RKIND, & + 4.71413336863812371e-02_RKIND, 5.45129844125978591e-02_RKIND, 6.26632599630084636e-02_RKIND, & + 6.31379657675310846e-02_RKIND, 7.14623133641135444e-02_RKIND, 7.51048615652924606e-02_RKIND, & + 7.98259878444318866e-02_RKIND, 8.16607475819435963e-02_RKIND, 9.37481686311500140e-02_RKIND, & + 1.04838836333477403e-01_RKIND /) + + case default + + call mpas_log_write(& + "get_integration_factors_fekete: Unimplemented integration order for Fekete wachspress integration", & + MPAS_LOG_CRIT) + + end select + + end subroutine triangle_quadrature_rules_fekete + +!----------------------------------------------------------------------- + +end module seaice_triangle_quadrature diff --git a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver.F b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver.F index b82d92060b35..f1215793aebc 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver.F @@ -99,7 +99,7 @@ subroutine seaice_init_velocity_solver(& domain !< Input/Output: type(block_type), pointer :: & - block + blockPtr character(len=strKIND), pointer :: & config_strain_scheme, & @@ -118,12 +118,7 @@ subroutine seaice_init_velocity_solver(& config_reuse_halo_exch type (MPAS_pool_type), pointer :: & - mesh, & - boundary, & - velocitySolver, & - velocity_weak, & - velocity_variational, & - velocity_pwl + velocitySolverPool real(kind=RKIND), pointer :: & dynamicsTimeStep, & @@ -142,22 +137,22 @@ subroutine seaice_init_velocity_solver(& call dynamically_locked_cell_mask(domain) ! set timesteps even with velocity turned off - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_config(block % configs, "config_dt", config_dt) - call MPAS_pool_get_config(block % configs, "config_dynamics_subcycle_number", config_dynamics_subcycle_number) - call MPAS_pool_get_config(block % configs, "config_elastic_subcycle_number", config_elastic_subcycle_number) + call MPAS_pool_get_config(blockPtr % configs, "config_dt", config_dt) + call MPAS_pool_get_config(blockPtr % configs, "config_dynamics_subcycle_number", config_dynamics_subcycle_number) + call MPAS_pool_get_config(blockPtr % configs, "config_elastic_subcycle_number", config_elastic_subcycle_number) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolver) - call MPAS_pool_get_array(velocitySolver, "dynamicsTimeStep", dynamicsTimeStep) - call MPAS_pool_get_array(velocitySolver, "elasticTimeStep", elasticTimeStep) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_array(velocitySolverPool, "dynamicsTimeStep", dynamicsTimeStep) + call MPAS_pool_get_array(velocitySolverPool, "elasticTimeStep", elasticTimeStep) dynamicsTimeStep = config_dt / real(config_dynamics_subcycle_number,RKIND) elasticTimeStep = dynamicsTimeStep / real(config_elastic_subcycle_number,RKIND) - block => block % next + blockPtr => blockPtr % next enddo ! check if we initialize velocity solver @@ -206,51 +201,20 @@ subroutine seaice_init_velocity_solver(& ! initialize the evp solver call seaice_init_evp(domain) - block => domain % blocklist - do while (associated(block)) - - call MPAS_pool_get_subpool(block % structs, "mesh", mesh) - call MPAS_pool_get_subpool(block % structs, "boundary", boundary) - call MPAS_pool_get_subpool(block % structs, "velocity_weak", velocity_weak) - call MPAS_pool_get_subpool(block % structs, "velocity_variational", velocity_variational) - - call MPAS_pool_get_config(block % configs, "config_variational_basis", config_variational_basis) - call MPAS_pool_get_config(block % configs, "config_variational_denominator_type", config_variational_denominator_type) - call MPAS_pool_get_config(block % configs, "config_rotate_cartesian_grid", config_rotate_cartesian_grid) - call MPAS_pool_get_config(block % configs, "config_include_metric_terms", config_include_metric_terms) - call MPAS_pool_get_config(block % configs, "config_wachspress_integration_type", config_wachspress_integration_type) - call MPAS_pool_get_config(block % configs, "config_wachspress_integration_order", config_wachspress_integration_order) - - ! init solvers - if (strainSchemeType == WEAK_STRAIN_SCHEME .or. & - stressDivergenceSchemeType == WEAK_STRESS_DIVERGENCE_SCHEME) then - - call seaice_init_velocity_solver_weak(& - mesh, & - boundary, & - velocity_weak, & - config_rotate_cartesian_grid) + ! init solvers + if (strainSchemeType == WEAK_STRAIN_SCHEME .or. & + stressDivergenceSchemeType == WEAK_STRESS_DIVERGENCE_SCHEME) then - endif + call seaice_init_velocity_solver_weak(domain) - if (strainSchemeType == VARIATIONAL_STRAIN_SCHEME .or. & - stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then + endif - call seaice_init_velocity_solver_variational(& - mesh, & - velocity_variational, & - boundary, & - config_rotate_cartesian_grid, & - config_include_metric_terms, & - config_variational_basis, & - config_variational_denominator_type, & - config_wachspress_integration_type, & - config_wachspress_integration_order) + if (strainSchemeType == VARIATIONAL_STRAIN_SCHEME .or. & + stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then - endif + call seaice_init_velocity_solver_variational(domain) - block => block % next - enddo + endif endif @@ -408,7 +372,7 @@ subroutine dynamically_locked_cell_mask(domain) domain !< Input/Output: type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -431,12 +395,12 @@ subroutine dynamically_locked_cell_mask(domain) iVertexOnCell, & iVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "boundary", boundaryPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "boundary", boundaryPool) call MPAS_pool_get_array(velocitySolverPool, "dynamicallyLockedCellsMask", dynamicallyLockedCellsMask) @@ -445,7 +409,7 @@ subroutine dynamically_locked_cell_mask(domain) call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) call MPAS_pool_get_array(meshPool, "verticesOnCell", verticesOnCell) - call MPAS_pool_get_dimension(block % dimensions, "nCells", nCells) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCells", nCells) do iCell = 1, nCells @@ -464,7 +428,7 @@ subroutine dynamically_locked_cell_mask(domain) enddo ! iCell - block => block % next + blockPtr => blockPtr % next enddo end subroutine dynamically_locked_cell_mask @@ -487,7 +451,7 @@ subroutine init_ice_shelve_vertex_mask(domain) domain !< Input/Output: type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & oceanCouplingPool, & @@ -509,19 +473,19 @@ subroutine init_ice_shelve_vertex_mask(domain) iVertex, & iCellOnVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "ocean_coupling", oceanCouplingPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "ocean_coupling", oceanCouplingPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) call MPAS_pool_get_array(oceanCouplingPool, "landIceMask", landIceMask) call MPAS_pool_get_array(oceanCouplingPool, "landIceMaskVertex", landIceMaskVertex) call MPAS_pool_get_array(meshPool, "cellsOnVertex", cellsOnVertex) - call MPAS_pool_get_dimension(block % dimensions, "vertexDegree", vertexDegree) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "vertexDegree", vertexDegree) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) landIceMaskVertex(:) = 0 @@ -541,7 +505,7 @@ subroutine init_ice_shelve_vertex_mask(domain) enddo ! iVertex - block => block % next + blockPtr => blockPtr % next enddo end subroutine init_ice_shelve_vertex_mask @@ -695,7 +659,7 @@ subroutine aggregate_mass_and_area(domain)!{{{ domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & tracersPool, & @@ -719,14 +683,14 @@ subroutine aggregate_mass_and_area(domain)!{{{ integer :: & iCell - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nCells", nCellsSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCells", nCellsSolve) - call MPAS_pool_get_subpool(block % structs, "tracers", tracersPool) - call MPAS_pool_get_subpool(block % structs, "tracers_aggregate", tracersAggregatePool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "tracers", tracersPool) + call MPAS_pool_get_subpool(blockPtr % structs, "tracers_aggregate", tracersAggregatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) call MPAS_pool_get_array(tracersPool, "iceAreaCategory", iceAreaCategory, 1) call MPAS_pool_get_array(tracersPool, "iceVolumeCategory", iceVolumeCategory, 1) @@ -749,7 +713,7 @@ subroutine aggregate_mass_and_area(domain)!{{{ enddo ! iCell - block => block % next + blockPtr => blockPtr % next enddo end subroutine aggregate_mass_and_area!}}} @@ -778,7 +742,7 @@ subroutine calculation_masks(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & icestatePool, & @@ -811,17 +775,17 @@ subroutine calculation_masks(domain) if (.not. config_use_column_package .or. & (config_use_column_package .and. .not. config_use_column_vertical_thermodynamics)) then - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "tracers_aggregate", tracersAggregatePool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "tracers_aggregate", tracersAggregatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) call MPAS_pool_get_array(tracersAggregatePool, "iceAreaCell", iceAreaCell) call MPAS_pool_get_array(icestatePool, "iceAreaCellInitial", iceAreaCellInitial) iceAreaCellInitial = iceAreaCell - block => block % next + blockPtr => blockPtr % next end do endif @@ -872,11 +836,11 @@ subroutine calculation_masks(domain) call seaice_load_balance_timers(domain, "vel prep after") ! interpolate area and mass from cells to vertices - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) call MPAS_pool_get_array(icestatePool, "iceAreaVertex", iceAreaVertex) call MPAS_pool_get_array(icestatePool, "totalMassCell", totalMassCell) @@ -893,7 +857,7 @@ subroutine calculation_masks(domain) totalMassVertex, & totalMassCell) - block => block % next + blockPtr => blockPtr % next end do ! calculate computational masks @@ -967,7 +931,7 @@ subroutine stress_calculation_mask(domain)!{{{ domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & meshPool, & @@ -997,15 +961,15 @@ subroutine stress_calculation_mask(domain)!{{{ integer, dimension(:,:), pointer :: & cellsOnCell - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nCells", nCells) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCells", nCells) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "ocean_coupling", oceanCouplingPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "ocean_coupling", oceanCouplingPool) call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) call MPAS_pool_get_array(meshPool, "cellsOnCell", cellsOnCell) @@ -1056,7 +1020,7 @@ subroutine stress_calculation_mask(domain)!{{{ enddo ! iCell - block => block % next + blockPtr => blockPtr % next enddo end subroutine stress_calculation_mask!}}} @@ -1079,7 +1043,7 @@ subroutine velocity_calculation_mask(domain)!{{{ domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -1105,16 +1069,16 @@ subroutine velocity_calculation_mask(domain)!{{{ nVerticesSolve, & nVertices - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_dimension(block % dimensions, "nVertices", nVertices) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVertices", nVertices) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "boundary", boundaryPool) - call MPAS_pool_get_subpool(block % structs, "ocean_coupling", oceanCouplingPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "boundary", boundaryPool) + call MPAS_pool_get_subpool(blockPtr % structs, "ocean_coupling", oceanCouplingPool) call MPAS_pool_get_array(velocitySolverPool, "solveVelocity", solveVelocity) @@ -1147,7 +1111,7 @@ subroutine velocity_calculation_mask(domain)!{{{ enddo ! iVertex - block => block % next + blockPtr => blockPtr % next enddo end subroutine velocity_calculation_mask!}}} @@ -1176,7 +1140,7 @@ subroutine new_ice_velocities(domain)!{{{ domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -1213,14 +1177,14 @@ subroutine new_ice_velocities(domain)!{{{ config_aggregate_halo_exch, & config_reuse_halo_exch - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "ocean_coupling", oceanCouplingPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "ocean_coupling", oceanCouplingPool) call MPAS_pool_get_array(velocitySolverPool, "uVelocity", uVelocity) call MPAS_pool_get_array(velocitySolverPool, "vVelocity", vVelocity) @@ -1279,7 +1243,7 @@ subroutine new_ice_velocities(domain)!{{{ uVelocityInitial = uVelocity vVelocityInitial = vVelocity - block => block % next + blockPtr => blockPtr % next enddo ! halo exchange velocities @@ -1359,7 +1323,7 @@ subroutine ice_strength(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -1398,22 +1362,21 @@ subroutine ice_strength(domain) character(len=strKIND), pointer :: & config_column_physics_type - block => domain % blocklist - do while (associated(block)) - - call MPAS_pool_get_config(block % configs, "config_column_physics_type", config_column_physics_type) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_config(block % configs, "config_use_column_package", config_use_column_package) - call MPAS_pool_get_config(block % configs, "config_use_column_vertical_thermodynamics", & - config_use_column_vertical_thermodynamics) + call MPAS_pool_get_config(blockPtr % configs, "config_column_physics_type", config_column_physics_type) + call MPAS_pool_get_config(blockPtr % configs, "config_use_column_package", config_use_column_package) + call MPAS_pool_get_config(blockPtr % configs, "config_use_column_vertical_thermodynamics", & + config_use_column_vertical_thermodynamics) - call MPAS_pool_get_dimension(block % dimensions, "nCellsSolve", nCellsSolve) - call MPAS_pool_get_dimension(block % dimensions, "nCategories", nCategories) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCellsSolve", nCellsSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCategories", nCategories) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "tracers_aggregate", tracersAggregatePool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "tracers", tracersPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "tracers_aggregate", tracersAggregatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "tracers", tracersPool) call MPAS_pool_get_array(velocitySolverPool, "icePressure", icePressure) call MPAS_pool_get_array(velocitySolverPool, "solveStress", solveStress) @@ -1490,7 +1453,7 @@ subroutine ice_strength(domain) endif - block => block % next + blockPtr => blockPtr % next enddo ! halo exchange ice strength @@ -1563,7 +1526,7 @@ subroutine air_stress(domain) domain type(block_type), pointer :: & - block + blockPtr logical, pointer :: & config_use_column_package, & @@ -1599,14 +1562,14 @@ subroutine air_stress(domain) ! check for no air stress call MPAS_pool_get_config(domain % blocklist % configs, "config_use_air_stress", config_use_air_stress) if (.not. config_use_air_stress) then - block => domain % blocklist - do while (associated(block)) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + blockPtr => domain % blocklist + do while (associated(blockPtr)) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) call MPAS_pool_get_array(velocitySolverPool, "airStressCellU", airStressCellU) call MPAS_pool_get_array(velocitySolverPool, "airStressCellV", airStressCellV) airStressCellU = 0.0_RKIND airStressCellV = 0.0_RKIND - block => block % next + blockPtr => blockPtr % next end do endif ! .not. config_use_air_stress @@ -1656,11 +1619,11 @@ subroutine air_stress(domain) call seaice_load_balance_timers(domain, "vel prep after") ! interpolate air stress - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) call MPAS_pool_get_array(velocitySolverPool, "airStressCellU", airStressCellU) call MPAS_pool_get_array(velocitySolverPool, "airStressCellV", airStressCellV) @@ -1677,7 +1640,7 @@ subroutine air_stress(domain) airStressVertexV, & airStressCellV) - block => block % next + blockPtr => blockPtr % next end do end subroutine air_stress @@ -1700,7 +1663,7 @@ subroutine constant_air_stress(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -1727,14 +1690,14 @@ subroutine constant_air_stress(domain) real(kind=RKIND), parameter :: & airStressCoeff = 0.0012_RKIND - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nCellsSolve", nCellsSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCellsSolve", nCellsSolve) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "atmos_coupling", atmosCouplingPool) - call MPAS_pool_get_subpool(block % structs, "tracers_aggregate", tracersAggregatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "atmos_coupling", atmosCouplingPool) + call MPAS_pool_get_subpool(blockPtr % structs, "tracers_aggregate", tracersAggregatePool) call MPAS_pool_get_array(velocitySolverPool, "airStressCellU", airStressCellU) call MPAS_pool_get_array(velocitySolverPool, "airStressCellV", airStressCellV) @@ -1754,7 +1717,7 @@ subroutine constant_air_stress(domain) enddo ! iCell - block => block % next + blockPtr => blockPtr % next end do end subroutine constant_air_stress @@ -1777,7 +1740,7 @@ subroutine coriolis_force_coefficient(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & icestatePool, & @@ -1795,14 +1758,14 @@ subroutine coriolis_force_coefficient(domain) integer :: & iVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) call MPAS_pool_get_array(icestatePool, "totalMassVertex", totalMassVertex) call MPAS_pool_get_array(velocitySolverPool, "totalMassVertexfVertex", totalMassVertexfVertex) @@ -1814,7 +1777,7 @@ subroutine coriolis_force_coefficient(domain) enddo ! iVertex - block => block % next + blockPtr => blockPtr % next end do end subroutine coriolis_force_coefficient @@ -1837,7 +1800,7 @@ subroutine ocean_stress(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -1862,15 +1825,15 @@ subroutine ocean_stress(domain) integer :: & iVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_config(block % configs, "config_use_ocean_stress", configUseOceanStress) + call MPAS_pool_get_config(blockPtr % configs, "config_use_ocean_stress", configUseOceanStress) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) call MPAS_pool_get_array(velocitySolverPool, "oceanStressU", oceanStressU) call MPAS_pool_get_array(velocitySolverPool, "oceanStressV", oceanStressV) @@ -1909,7 +1872,7 @@ subroutine ocean_stress(domain) endif - block => block % next + blockPtr => blockPtr % next end do end subroutine ocean_stress @@ -1976,7 +1939,7 @@ subroutine surface_tilt_geostrophic(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & icestatePool, & @@ -2000,14 +1963,14 @@ subroutine surface_tilt_geostrophic(domain) integer :: & iVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) call MPAS_pool_get_array(velocitySolverPool, "surfaceTiltForceU", surfaceTiltForceU) call MPAS_pool_get_array(velocitySolverPool, "surfaceTiltForceV", surfaceTiltForceV) @@ -2036,7 +1999,7 @@ subroutine surface_tilt_geostrophic(domain) enddo ! iVertex - block => block % next + blockPtr => blockPtr % next end do end subroutine surface_tilt_geostrophic @@ -2068,7 +2031,7 @@ subroutine surface_tilt_ssh_gradient(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & icestatePool, & @@ -2145,15 +2108,15 @@ subroutine surface_tilt_ssh_gradient(domain) call seaice_load_balance_timers(domain, "vel prep after") - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "ocean_coupling", oceanCouplingPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "ocean_coupling", oceanCouplingPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) call MPAS_pool_get_array(velocitySolverPool, "surfaceTiltForceU", surfaceTiltForceU) call MPAS_pool_get_array(velocitySolverPool, "surfaceTiltForceV", surfaceTiltForceV) @@ -2195,7 +2158,7 @@ subroutine surface_tilt_ssh_gradient(domain) enddo ! iVertex - block => block % next + blockPtr => blockPtr % next end do end subroutine surface_tilt_ssh_gradient @@ -2218,7 +2181,7 @@ subroutine no_surface_tilt(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool @@ -2227,10 +2190,10 @@ subroutine no_surface_tilt(domain) surfaceTiltForceU, & surfaceTiltForceV - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) call MPAS_pool_get_array(velocitySolverPool, "surfaceTiltForceU", surfaceTiltForceU) call MPAS_pool_get_array(velocitySolverPool, "surfaceTiltForceV", surfaceTiltForceV) @@ -2239,7 +2202,7 @@ subroutine no_surface_tilt(domain) surfaceTiltForceU = 0.0_RKIND surfaceTiltForceV = 0.0_RKIND - block => block % next + blockPtr => blockPtr % next end do end subroutine no_surface_tilt @@ -2260,7 +2223,7 @@ subroutine init_subcycle_variables(domain) type(domain_type) :: domain - type(block_type), pointer :: block + type(block_type), pointer :: blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -2307,10 +2270,10 @@ subroutine init_subcycle_variables(domain) call MPAS_pool_get_config(domain % configs, "config_stress_divergence_scheme", config_stress_divergence_scheme) - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) ! divergence of stress call MPAS_pool_get_array(velocitySolverPool, "stressDivergenceU", stressDivergenceU) @@ -2326,7 +2289,7 @@ subroutine init_subcycle_variables(domain) call MPAS_pool_get_array(velocitySolverPool, "vVelocity", vVelocity) call MPAS_pool_get_array(velocitySolverPool, "oceanStressCoeff", oceanStressCoeff) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) do iVertex = 1, nVerticesSolve @@ -2344,7 +2307,7 @@ subroutine init_subcycle_variables(domain) if (trim(config_stress_divergence_scheme) == "variational") then ! variational - call MPAS_pool_get_subpool(block % structs, "velocity_variational", velocityVariationalPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) ! strains call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11Var) @@ -2362,7 +2325,7 @@ subroutine init_subcycle_variables(domain) call MPAS_pool_get_array(velocityVariationalPool, "stress22", stress22Var) call MPAS_pool_get_array(velocityVariationalPool, "stress12", stress12Var) - call MPAS_pool_get_dimension(block % dimensions, "nCells", nCells) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCells", nCells) do iCell = 1, nCells @@ -2378,7 +2341,7 @@ subroutine init_subcycle_variables(domain) else if (trim(config_stress_divergence_scheme) == "weak") then - call MPAS_pool_get_subpool(block % structs, "velocity_weak", velocityWeakPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) ! strains call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11Weak) @@ -2396,7 +2359,7 @@ subroutine init_subcycle_variables(domain) call MPAS_pool_get_array(velocityWeakPool, "stress22", stress22Weak) call MPAS_pool_get_array(velocityWeakPool, "stress12", stress12Weak) - call MPAS_pool_get_dimension(block % dimensions, "nCells", nCells) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCells", nCells) do iCell = 1, nCells @@ -2412,7 +2375,7 @@ subroutine init_subcycle_variables(domain) endif ! config_stress_divergence_scheme - block => block % next + blockPtr => blockPtr % next enddo end subroutine init_subcycle_variables @@ -2637,23 +2600,6 @@ end subroutine single_subcycle_velocity_solver!}}} subroutine seaice_internal_stress(domain) - use seaice_mesh_pool, only: & - basisGradientU, & - basisGradientV, & - basisIntegralsMetric, & - basisIntegralsU, & - basisIntegralsV, & - cellVerticesAtVertex, & - icePressure, & - solveStress, & - solveVelocity, & - stress11var => stress11, & - stress22var => stress22, & - stress12var => stress12, & - tanLatVertexRotatedOverRadius, & - uVelocity, & - vVelocity - use seaice_velocity_solver_weak, only: & seaice_strain_tensor_weak, & seaice_stress_tensor_weak, & @@ -2668,229 +2614,66 @@ subroutine seaice_internal_stress(domain) type(domain_type), intent(inout) :: & domain - type(block_type), pointer :: & - blockPtr + ! strain + if (strainSchemeType == WEAK_STRAIN_SCHEME) then - type (MPAS_pool_type), pointer :: & - meshPool, & - velocityWeakPool, & - velocityVariationalPool, & - velocityWeakVariationalPool, & - velocitySolverPool + call mpas_timer_start("Velocity solver strain tensor") + call seaice_strain_tensor_weak(domain) + call mpas_timer_stop("Velocity solver strain tensor") - real(kind=RKIND), pointer :: & - elasticTimeStep + else if (strainSchemeType == VARIATIONAL_STRAIN_SCHEME) then - real(kind=RKIND), dimension(:), pointer :: & - stressDivergenceU, & - stressDivergenceV + call mpas_timer_start("Velocity solver strain tensor") + call seaice_strain_tensor_variational(domain) + call mpas_timer_stop("Velocity solver strain tensor") - real(kind=RKIND), dimension(:), pointer :: & - replacementPressureWeak, & - strain11weak, & - strain22weak, & - strain12weak, & - stress11weak, & - stress22weak, & - stress12weak, & - latCellRotated, & - latVertexRotated, & - areaCell - - real(kind=RKIND), dimension(:,:,:), pointer :: & - normalVectorPolygon, & - normalVectorTriangle - - real(kind=RKIND), dimension(:,:), pointer :: & - replacementPressureVar, & - strain11var, & - strain22var, & - strain12var - - real(kind=RKIND), dimension(:), pointer :: & - variationalDenominator - - blockPtr => domain % blocklist - do while (associated(blockPtr)) - - call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) - call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) - call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak_variational", velocityWeakVariationalPool) - call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) - - call MPAS_pool_get_array(velocitySolverPool, "elasticTimeStep", elasticTimeStep) - call MPAS_pool_get_array(velocitySolverPool, "stressDivergenceU", stressDivergenceU) - call MPAS_pool_get_array(velocitySolverPool, "stressDivergenceV", stressDivergenceV) - - if (strainSchemeType == WEAK_STRAIN_SCHEME .or. & - stressDivergenceSchemeType == WEAK_STRESS_DIVERGENCE_SCHEME) then - - call MPAS_pool_get_array(velocityWeakPool, "normalVectorPolygon", normalVectorPolygon) - call MPAS_pool_get_array(velocityWeakPool, "normalVectorTriangle", normalVectorTriangle) - call MPAS_pool_get_array(velocityWeakPool, "latCellRotated", latCellRotated) - call MPAS_pool_get_array(velocityWeakPool, "latVertexRotated", latVertexRotated) - call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11weak) - call MPAS_pool_get_array(velocityWeakPool, "strain22", strain22weak) - call MPAS_pool_get_array(velocityWeakPool, "strain12", strain12weak) - call MPAS_pool_get_array(velocityWeakPool, "stress11", stress11weak) - call MPAS_pool_get_array(velocityWeakPool, "stress22", stress22weak) - call MPAS_pool_get_array(velocityWeakPool, "stress12", stress12weak) - call MPAS_pool_get_array(velocityWeakPool, "replacementPressure", replacementPressureWeak) - - endif - - if (strainSchemeType == VARIATIONAL_STRAIN_SCHEME .or. & - stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then + endif - call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11var) - call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22var) - call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12var) - call MPAS_pool_get_array(velocityVariationalPool, "replacementPressure", replacementPressureVar) - call MPAS_pool_get_array(velocityVariationalPool, "variationalDenominator", variationalDenominator) + ! average variational strains around vertex + if (strainSchemeType == VARIATIONAL_STRAIN_SCHEME .and. & + averageVariationalStrains) then + call seaice_average_strains_on_vertex(domain) + endif - endif + ! weak strain / variational stress divergence + if (strainSchemeType == WEAK_STRAIN_SCHEME .and. & + stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then - ! strain - if (strainSchemeType == WEAK_STRAIN_SCHEME) then - - call mpas_timer_start("Velocity solver strain tensor") - call seaice_strain_tensor_weak(& - meshPool, & - strain11weak, & - strain22weak, & - strain12weak, & - uVelocity, & - vVelocity, & - normalVectorPolygon, & - latCellRotated, & - solveStress) - call mpas_timer_stop("Velocity solver strain tensor") - - else if (strainSchemeType == VARIATIONAL_STRAIN_SCHEME) then - - call mpas_timer_start("Velocity solver strain tensor") - call seaice_strain_tensor_variational(& - meshPool, & - strain11var, & - strain22var, & - strain12var, & - uVelocity, & - vVelocity, & - basisGradientU, & - basisGradientV, & - tanLatVertexRotatedOverRadius, & - solveStress) - call mpas_timer_stop("Velocity solver strain tensor") + call mpas_timer_start("Velocity solver interpolate strain") + call interpolate_strains_weak_to_variational(domain) + call mpas_timer_stop("Velocity solver interpolate strain") - endif + endif - ! average variational strains around vertex - if (strainSchemeType == VARIATIONAL_STRAIN_SCHEME .and. & - averageVariationalStrains) then + ! consitutive relation + if (stressDivergenceSchemeType == WEAK_STRESS_DIVERGENCE_SCHEME) then - call MPAS_pool_get_array(meshPool, "areaCell", areaCell) - call seaice_average_strains_on_vertex(& - areaCell, & - strain11var, & - strain22var, & - strain12var) - endif + call mpas_timer_start("Velocity solver stress tensor") + call seaice_stress_tensor_weak(domain) + call mpas_timer_stop("Velocity solver stress tensor") - ! weak strain / variational stress divergence - if (strainSchemeType == WEAK_STRAIN_SCHEME .and. & - stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then + else if (stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then - call mpas_timer_start("Velocity solver interpolate strain") - call interpolate_strains_weak_to_variational(& - meshPool, & - velocityWeakVariationalPool, & - strain11weak, & - strain22weak, & - strain12weak, & - strain11var, & - strain22var, & - strain12var) - call mpas_timer_stop("Velocity solver interpolate strain") + call mpas_timer_start("Velocity solver stress tensor") + call seaice_stress_tensor_variational(domain) + call mpas_timer_stop("Velocity solver stress tensor") - endif + endif - ! consitutive relation - if (stressDivergenceSchemeType == WEAK_STRESS_DIVERGENCE_SCHEME) then - - call mpas_timer_start("Velocity solver stress tensor") - call seaice_stress_tensor_weak(& - meshPool, & - stress11weak, & - stress22weak, & - stress12weak, & - strain11weak, & - strain22weak, & - strain12weak, & - icePressure, & - replacementPressureWeak, & - solveStress, & - elasticTimeStep) - call mpas_timer_stop("Velocity solver stress tensor") - - else if (stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then - - call mpas_timer_start("Velocity solver stress tensor") - call seaice_stress_tensor_variational(& - meshPool, & - stress11var, & - stress22var, & - stress12var, & - strain11var, & - strain22var, & - strain12var, & - icePressure, & - replacementPressureVar, & - solveStress, & - elasticTimeStep) - call mpas_timer_stop("Velocity solver stress tensor") + ! stress divergence + if (stressDivergenceSchemeType == WEAK_STRESS_DIVERGENCE_SCHEME) then - endif + call mpas_timer_start("Velocity solver stress divergence") + call seaice_stress_divergence_weak(domain) + call mpas_timer_stop("Velocity solver stress divergence") - ! stress divergence - if (stressDivergenceSchemeType == WEAK_STRESS_DIVERGENCE_SCHEME) then - - call mpas_timer_start("Velocity solver stress divergence") - call seaice_stress_divergence_weak(& - meshPool, & - stressDivergenceU, & - stressDivergenceV, & - stress11weak, & - stress22weak, & - stress12weak, & - normalVectorTriangle, & - latVertexRotated, & - solveVelocity) - call mpas_timer_stop("Velocity solver stress divergence") - - else if (stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then - - call mpas_timer_start("Velocity solver stress divergence") - call seaice_stress_divergence_variational(& - meshPool, & - stressDivergenceU, & - stressDivergenceV, & - stress11var, & - stress22var, & - stress12var, & - basisIntegralsU, & - basisIntegralsV, & - basisIntegralsMetric, & - variationalDenominator, & - tanLatVertexRotatedOverRadius, & - cellVerticesAtVertex, & - solveVelocity) - call mpas_timer_stop("Velocity solver stress divergence") + else if (stressDivergenceSchemeType == VARIATIONAL_STRESS_DIVERGENCE_SCHEME) then - endif + call mpas_timer_start("Velocity solver stress divergence") + call seaice_stress_divergence_variational(domain) + call mpas_timer_stop("Velocity solver stress divergence") - blockPtr => blockPtr % next - end do + endif end subroutine seaice_internal_stress @@ -2906,15 +2689,7 @@ end subroutine seaice_internal_stress ! !----------------------------------------------------------------------- - subroutine interpolate_strains_weak_to_variational(& - meshPool, & - velocityWeakVariationalPool, & - strain11weak, & - strain22weak, & - strain12weak, & - strain11var, & - strain22var, & - strain12var) + subroutine interpolate_strains_weak_to_variational(domain) use seaice_mesh_pool, only: & nCells, & @@ -2924,19 +2699,27 @@ subroutine interpolate_strains_weak_to_variational(& nEdgesOnCell, & verticesOnCell + type(domain_type), intent(inout) :: & + domain + + type(block_type), pointer :: & + blockPtr + type (MPAS_pool_type), pointer :: & meshPool, & + velocityWeakPool, & + velocityVariationalPool, & velocityWeakVariationalPool - real(kind=RKIND), dimension(:), intent(in) :: & - strain11weak, & !< Input/Output: - strain22weak, & !< Input/Output: - strain12weak !< Input/Output: + real(kind=RKIND), dimension(:), pointer :: & + strain11weak, & + strain22weak, & + strain12weak - real(kind=RKIND), dimension(:,:), intent(out) :: & - strain11var, & !< Input/Output: - strain22var, & !< Input/Output: - strain12var !< Input/Output: + real(kind=RKIND), dimension(:,:), pointer :: & + strain11var, & + strain22var, & + strain12var real(kind=RKIND), dimension(:), pointer :: & strain11Vertex, & @@ -2955,51 +2738,70 @@ subroutine interpolate_strains_weak_to_variational(& iCell, & iVertexOnCell - call MPAS_pool_get_array(meshPool, "areaCell", areaCell) + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak_variational", velocityWeakVariationalPool) + + call MPAS_pool_get_array(meshPool, "areaCell", areaCell) + + call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11var) + call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22var) + call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12var) - call MPAS_pool_get_array(velocityWeakVariationalPool, "strain11Vertex", strain11Vertex) - call MPAS_pool_get_array(velocityWeakVariationalPool, "strain22Vertex", strain22Vertex) - call MPAS_pool_get_array(velocityWeakVariationalPool, "strain12Vertex", strain12Vertex) + call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11weak) + call MPAS_pool_get_array(velocityWeakPool, "strain22", strain22weak) + call MPAS_pool_get_array(velocityWeakPool, "strain12", strain12weak) - do iVertex = 1, nVerticesSolve + call MPAS_pool_get_array(velocityWeakVariationalPool, "strain11Vertex", strain11Vertex) + call MPAS_pool_get_array(velocityWeakVariationalPool, "strain22Vertex", strain22Vertex) + call MPAS_pool_get_array(velocityWeakVariationalPool, "strain12Vertex", strain12Vertex) - strain11Vertex(iVertex) = 0.0_RKIND - strain22Vertex(iVertex) = 0.0_RKIND - strain12Vertex(iVertex) = 0.0_RKIND - denom = 0.0_RKIND + do iVertex = 1, nVerticesSolve - do iCellOnVertex = 1, vertexDegree + strain11Vertex(iVertex) = 0.0_RKIND + strain22Vertex(iVertex) = 0.0_RKIND + strain12Vertex(iVertex) = 0.0_RKIND + denom = 0.0_RKIND - iCell = cellsOnVertex(iCellOnVertex,iVertex) + do iCellOnVertex = 1, vertexDegree - if (iCell >= 1 .and. iCell <= nCells) then - strain11Vertex(iVertex) = strain11Vertex(iVertex) + areaCell(iCell) * strain11weak(iCell) - strain22Vertex(iVertex) = strain22Vertex(iVertex) + areaCell(iCell) * strain22weak(iCell) - strain12Vertex(iVertex) = strain12Vertex(iVertex) + areaCell(iCell) * strain12weak(iCell) - denom = denom + areaCell(iCell) - endif + iCell = cellsOnVertex(iCellOnVertex,iVertex) - enddo ! iCellOnVertex + if (iCell >= 1 .and. iCell <= nCells) then + strain11Vertex(iVertex) = strain11Vertex(iVertex) + areaCell(iCell) * strain11weak(iCell) + strain22Vertex(iVertex) = strain22Vertex(iVertex) + areaCell(iCell) * strain22weak(iCell) + strain12Vertex(iVertex) = strain12Vertex(iVertex) + areaCell(iCell) * strain12weak(iCell) + denom = denom + areaCell(iCell) + endif + + enddo ! iCellOnVertex + + strain11Vertex(iVertex) = strain11Vertex(iVertex) / denom + strain22Vertex(iVertex) = strain22Vertex(iVertex) / denom + strain12Vertex(iVertex) = strain12Vertex(iVertex) / denom - strain11Vertex(iVertex) = strain11Vertex(iVertex) / denom - strain22Vertex(iVertex) = strain22Vertex(iVertex) / denom - strain12Vertex(iVertex) = strain12Vertex(iVertex) / denom + enddo ! iVertex - enddo ! iVertex + do iCell = 1, nCells - do iCell = 1, nCells + do iVertexOnCell = 1, nEdgesOnCell(iCell) - do iVertexOnCell = 1, nEdgesOnCell(iCell) + iVertex = verticesOnCell(iVertexOnCell,iCell) - iVertex = verticesOnCell(iVertexOnCell,iCell) + strain11var(iVertexOnCell,iCell) = strain11Vertex(iVertex) + strain22var(iVertexOnCell,iCell) = strain22Vertex(iVertex) + strain12var(iVertexOnCell,iCell) = strain12Vertex(iVertex) - strain11var(iVertexOnCell,iCell) = strain11Vertex(iVertex) - strain22var(iVertexOnCell,iCell) = strain22Vertex(iVertex) - strain12var(iVertexOnCell,iCell) = strain12Vertex(iVertex) + enddo ! iVertexOnCell - enddo ! iVertexOnCell + enddo ! iCell - enddo ! iCell + blockPtr => blockPtr % next + end do end subroutine interpolate_strains_weak_to_variational @@ -3025,7 +2827,7 @@ subroutine ocean_stress_coefficient(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -3051,15 +2853,15 @@ subroutine ocean_stress_coefficient(domain) integer :: & iVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_config(block % configs, "config_use_ocean_stress", configUseOceanStress) + call MPAS_pool_get_config(blockPtr % configs, "config_use_ocean_stress", configUseOceanStress) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) call MPAS_pool_get_array(velocitySolverPool, "oceanStressCoeff", oceanStressCoeff) @@ -3108,7 +2910,7 @@ subroutine ocean_stress_coefficient(domain) endif ! configUseOceanStress - block => block % next + blockPtr => blockPtr % next end do end subroutine ocean_stress_coefficient @@ -3131,7 +2933,7 @@ subroutine solve_velocity(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -3173,13 +2975,13 @@ subroutine solve_velocity(domain) integer :: & iVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) call MPAS_pool_get_array(icestatePool, "totalMassVertex", totalMassVertex) @@ -3234,7 +3036,7 @@ subroutine solve_velocity(domain) enddo ! iVertex - block => block % next + blockPtr => blockPtr % next end do end subroutine solve_velocity @@ -3260,7 +3062,7 @@ subroutine solve_velocity_revised(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocitySolverPool, & @@ -3304,13 +3106,13 @@ subroutine solve_velocity_revised(domain) integer :: & iVertex - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) call MPAS_pool_get_array(icestatePool, "totalMassVertex", totalMassVertex) @@ -3368,7 +3170,7 @@ subroutine solve_velocity_revised(domain) enddo ! iVertex - block => block % next + blockPtr => blockPtr % next end do end subroutine solve_velocity_revised @@ -3434,29 +3236,20 @@ subroutine final_divergence_shear(domain) type(domain_type), intent(inout) :: & domain - type(block_type), pointer :: & - block - character(len=strKIND), pointer :: & config_stress_divergence_scheme - block => domain % blocklist - do while (associated(block)) - - call MPAS_pool_get_config(block % configs, "config_stress_divergence_scheme", config_stress_divergence_scheme) - - if (trim(config_stress_divergence_scheme) == "weak") then + call MPAS_pool_get_config(domain % configs, "config_stress_divergence_scheme", config_stress_divergence_scheme) - call seaice_final_divergence_shear_weak(block) + if (trim(config_stress_divergence_scheme) == "weak") then - else if (trim(config_stress_divergence_scheme) == "variational") then + call seaice_final_divergence_shear_weak(domain) - call seaice_final_divergence_shear_variational(block) + else if (trim(config_stress_divergence_scheme) == "variational") then - endif + call seaice_final_divergence_shear_variational(domain) - block => block % next - enddo + endif end subroutine final_divergence_shear @@ -3478,7 +3271,7 @@ subroutine principal_stresses_driver(domain)!{{{ domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & velocityWeakPool, & @@ -3518,17 +3311,17 @@ subroutine principal_stresses_driver(domain)!{{{ character(len=strKIND), pointer :: & config_stress_divergence_scheme - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_config(block % configs, "config_stress_divergence_scheme", config_stress_divergence_scheme) + call MPAS_pool_get_config(blockPtr % configs, "config_stress_divergence_scheme", config_stress_divergence_scheme) - call MPAS_pool_get_dimension(block % dimensions, "nCellsSolve", nCellsSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nCellsSolve", nCellsSolve) ! calculate the principal stresses if (trim(config_stress_divergence_scheme) == "weak") then - call MPAS_pool_get_subpool(block % structs, "velocity_weak", velocityWeakPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) call MPAS_pool_get_array(velocityWeakPool, "stress11", stress11Weak) call MPAS_pool_get_array(velocityWeakPool, "stress22", stress22Weak) @@ -3551,8 +3344,8 @@ subroutine principal_stresses_driver(domain)!{{{ else if (trim(config_stress_divergence_scheme) == "variational") then - call MPAS_pool_get_subpool(block % structs, "velocity_variational", velocityVariationalPool) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) @@ -3579,7 +3372,7 @@ subroutine principal_stresses_driver(domain)!{{{ endif - block => block % next + blockPtr => blockPtr % next enddo end subroutine principal_stresses_driver!}}} @@ -3665,7 +3458,7 @@ subroutine ocean_stress_final(domain) domain type(block_type), pointer :: & - block + blockPtr type(MPAS_pool_type), pointer :: & meshPool, & @@ -3709,14 +3502,14 @@ subroutine ocean_stress_final(domain) call MPAS_pool_get_config(domain % blocklist % configs, "config_use_ocean_stress", configUseOceanStress) ! get ocean stress on vertices - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) call MPAS_pool_get_array(velocitySolverPool, "oceanStressU", oceanStressU) call MPAS_pool_get_array(velocitySolverPool, "oceanStressV", oceanStressV) @@ -3771,7 +3564,7 @@ subroutine ocean_stress_final(domain) endif - block => block % next + blockPtr => blockPtr % next end do ! get ocean stress on cells @@ -3822,15 +3615,15 @@ subroutine ocean_stress_final(domain) call seaice_load_balance_timers(domain, "vel prep after") - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_dimension(block % dimensions, "nVerticesSolve", nVerticesSolve) + call MPAS_pool_get_dimension(blockPtr % dimensions, "nVerticesSolve", nVerticesSolve) - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "boundary", boundaryPool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_subpool(block % structs, "icestate", icestatePool) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "boundary", boundaryPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "icestate", icestatePool) call MPAS_pool_get_array(icestatePool, "iceAreaVertex", iceAreaVertex) @@ -3856,15 +3649,15 @@ subroutine ocean_stress_final(domain) enddo ! iVertex - block => block % next + blockPtr => blockPtr % next end do else - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) call MPAS_pool_get_array(velocitySolverPool, "oceanStressCellU", oceanStressCellU) call MPAS_pool_get_array(velocitySolverPool, "oceanStressCellV", oceanStressCellV) @@ -3872,7 +3665,7 @@ subroutine ocean_stress_final(domain) oceanStressCellU = 0.0_RKIND oceanStressCellV = 0.0_RKIND - block => block % next + blockPtr => blockPtr % next end do endif ! configUseOceanStress diff --git a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_constitutive_relation.F b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_constitutive_relation.F index 7cdd96c36a10..332705267b24 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_constitutive_relation.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_constitutive_relation.F @@ -76,14 +76,14 @@ subroutine seaice_init_evp(domain) type(domain_type) :: domain - type(block_type), pointer :: block + type(block_type), pointer :: blockPtr character(len=strKIND), pointer :: & config_constitutive_relation_type type(MPAS_pool_type), pointer :: & - velocitySolver, & - mesh + velocitySolverPool, & + meshPool real(kind=RKIND), pointer :: & dynamicsTimeStep, & @@ -115,50 +115,47 @@ subroutine seaice_init_evp(domain) endif ! general EVP - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolver) - call MPAS_pool_get_array(velocitySolver, "dynamicsTimeStep", dynamicsTimeStep) - call MPAS_pool_get_array(velocitySolver, "elasticTimeStep", elasticTimeStep) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_array(velocitySolverPool, "dynamicsTimeStep", dynamicsTimeStep) + call MPAS_pool_get_array(velocitySolverPool, "elasticTimeStep", elasticTimeStep) dampingTimescale = dampingTimescaleParameter * dynamicsTimeStep evpDampingCriterion = (1230.0_RKIND * dampingTimescale) / elasticTimeStep**2 - block => block % next + blockPtr => blockPtr % next enddo ! find the minimum edge length in the grid dvEdgeMin = 1.0e30_RKIND - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_subpool(block % structs, "mesh", mesh) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) - call MPAS_pool_get_dimension(mesh, "nEdgesSolve", nEdgesSolve) + call MPAS_pool_get_dimension(meshPool, "nEdgesSolve", nEdgesSolve) - call MPAS_pool_get_array(mesh, "dvEdge", dvEdge) + call MPAS_pool_get_array(meshPool, "dvEdge", dvEdge) dvEdgeMin = min(dvEdgeMin, minval(dvEdge(1:nEdgesSolve))) - block => block % next + blockPtr => blockPtr % next enddo call mpas_dmpar_min_real(domain % dminfo, dvEdgeMin, dvEdgeMinGlobal) - !!!! Testing! - !dvEdgeMinGlobal = 8558.2317072059941_RKIND - ! Bouillon et al. 2013 - block => domain % blocklist - do while (associated(block)) + blockPtr => domain % blocklist + do while (associated(blockPtr)) gamma = 0.25_RKIND * 1.0e11_RKIND * dynamicsTimeStep numericalInertiaCoefficient = (2.0_RKIND * dampingRatioDenominator * dampingRatio * gamma) / dvEdgeMinGlobal**2 - block => block % next + blockPtr => blockPtr % next enddo end subroutine seaice_init_evp diff --git a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_pwl.F b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_pwl.F index 23a2c5a80559..12ad3a25f9cb 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_pwl.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_pwl.F @@ -14,6 +14,7 @@ module seaice_velocity_solver_pwl use mpas_derived_types use mpas_pool_routines + use mpas_timer implicit none @@ -41,53 +42,60 @@ module seaice_velocity_solver_pwl ! !----------------------------------------------------------------------- - subroutine seaice_init_velocity_solver_pwl(& - nCells, & - maxEdges, & - nEdgesOnCell, & - verticesOnCell, & - edgesOnCell, & - dvEdge, & - areaCell, & - xLocal, & - yLocal, & - basisGradientU, & - basisGradientV, & - basisIntegralsMetric, & - basisIntegralsU, & - basisIntegralsV)!{{{ + subroutine seaice_init_velocity_solver_pwl(domain)!{{{ use seaice_numerics, only: & seaice_solve_linear_basis_system - use seaice_velocity_solver_variational_shared, only: & - seaice_wrapped_index + use seaice_mesh, only: & + seaice_wrapped_index, & + seaice_calc_local_coords - real(kind=RKIND), dimension(:,:), intent(in) :: & - xLocal, & !< Input: - yLocal !< Input: + type (domain_type), intent(inout) :: & + domain !< Input/Output: - integer, intent(in) :: & - nCells, & !< Input: - maxEdges !< Input: + type(block_type), pointer :: & + blockPtr + + logical, pointer :: & + on_a_sphere, & + config_rotate_cartesian_grid + + real(kind=RKIND), pointer :: & + sphere_radius + + type(MPAS_pool_type), pointer :: & + meshPool, & + velocityVariationalPool + + integer, pointer :: & + nCells, & + maxEdges - integer, dimension(:), intent(in) :: & - nEdgesOnCell !< Input: + integer, dimension(:), pointer :: & + nEdgesOnCell - integer, dimension(:,:), intent(in) :: & - verticesOnCell, & !< Input: - edgesOnCell !< Input: + integer, dimension(:,:), pointer :: & + verticesOnCell, & + cellsOnVertex, & + edgesOnCell - real(kind=RKIND), dimension(:), intent(in) :: & - dvEdge, & !< Input: - areaCell !< Input: + real(kind=RKIND), dimension(:), pointer :: & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell, & + areaCell, & + dvEdge - real(kind=RKIND), dimension(:,:,:), intent(out) :: & - basisGradientU, & !< Output: - basisGradientV, & !< Output: - basisIntegralsMetric, & !< Output: - basisIntegralsU, & !< Output: - basisIntegralsV !< Output: + real(kind=RKIND), dimension(:,:,:), pointer :: & + basisGradientU, & + basisGradientV, & + basisIntegralsMetric, & + basisIntegralsU, & + basisIntegralsV real(kind=RKIND) :: & xPWLCentre, & @@ -123,6 +131,8 @@ subroutine seaice_init_velocity_solver_pwl(& solutionVector real(kind=RKIND), dimension(:,:), allocatable :: & + xLocal, & + yLocal, & subBasisGradientU, & subBasisGradientV, & subBasisConstant, & @@ -131,244 +141,298 @@ subroutine seaice_init_velocity_solver_pwl(& real(kind=RKIND), dimension(:), allocatable :: & basisSubArea +call MPAS_pool_get_config(domain % configs, "config_rotate_cartesian_grid", config_rotate_cartesian_grid) + + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + + call MPAS_pool_get_config(meshPool, "on_a_sphere", on_a_sphere) + call MPAS_pool_get_config(meshPool, "sphere_radius", sphere_radius) + + call MPAS_pool_get_dimension(meshPool, "nCells", nCells) + call MPAS_pool_get_dimension(meshPool, "maxEdges", maxEdges) + + call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) + call MPAS_pool_get_array(meshPool, "verticesOnCell", verticesOnCell) + call MPAS_pool_get_array(meshPool, "edgesOnCell", edgesOnCell) + call MPAS_pool_get_array(meshPool, "xVertex", xVertex) + call MPAS_pool_get_array(meshPool, "yVertex", yVertex) + call MPAS_pool_get_array(meshPool, "zVertex", zVertex) + call MPAS_pool_get_array(meshPool, "xCell", xCell) + call MPAS_pool_get_array(meshPool, "yCell", yCell) + call MPAS_pool_get_array(meshPool, "zCell", zCell) + call MPAS_pool_get_array(meshPool, "areaCell", areaCell) + call MPAS_pool_get_array(meshPool, "dvEdge", dvEdge) + + call MPAS_pool_get_array(velocityVariationalPool, "basisGradientU", basisGradientU) + call MPAS_pool_get_array(velocityVariationalPool, "basisGradientV", basisGradientV) + call MPAS_pool_get_array(velocityVariationalPool, "basisIntegralsU", basisIntegralsU) + call MPAS_pool_get_array(velocityVariationalPool, "basisIntegralsV", basisIntegralsV) + call MPAS_pool_get_array(velocityVariationalPool, "basisIntegralsMetric", basisIntegralsMetric) + + call mpas_timer_start("variational calc_local_coords") + allocate(xLocal(maxEdges,nCells)) + allocate(yLocal(maxEdges,nCells)) + + call seaice_calc_local_coords(& + xLocal, & + yLocal, & + nCells, & + nEdgesOnCell, & + verticesOnCell, & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell, & + config_rotate_cartesian_grid, & + on_a_sphere) + call mpas_timer_stop("variational calc_local_coords") + + allocate(subBasisGradientU(maxEdges,3)) + allocate(subBasisGradientV(maxEdges,3)) + allocate(subBasisConstant(maxEdges,3)) + allocate(subCellgradientU(maxEdges,maxEdges)) + allocate(subCellgradientV(maxEdges,maxEdges)) + allocate(basisSubArea(maxEdges)) + + ! loop over cells + do iCell = 1, nCells + + alphaPWL = 1.0_RKIND / real(nEdgesOnCell(iCell),RKIND) + + ! determine cell centre for piecewise linear basis + xPWLCentre = 0.0_RKIND + yPWLCentre = 0.0_RKIND + + do iVertexOnCell = 1, nEdgesOnCell(iCell) + + xPWLCentre = xPWLCentre + alphaPWL * xLocal(iVertexOnCell,iCell) + yPWLCentre = yPWLCentre + alphaPWL * yLocal(iVertexOnCell,iCell) + + enddo ! iVertexOnCell + + ! calculate the area of the subcells + basisSubAreaSum = 0.0_RKIND - allocate(subBasisGradientU(maxEdges,3)) - allocate(subBasisGradientV(maxEdges,3)) - allocate(subBasisConstant(maxEdges,3)) - allocate(subCellgradientU(maxEdges,maxEdges)) - allocate(subCellgradientV(maxEdges,maxEdges)) - allocate(basisSubArea(maxEdges)) - - ! loop over cells - do iCell = 1, nCells - - alphaPWL = 1.0_RKIND / real(nEdgesOnCell(iCell),RKIND) - - ! determine cell centre for piecewise linear basis - xPWLCentre = 0.0_RKIND - yPWLCentre = 0.0_RKIND - - do iVertexOnCell = 1, nEdgesOnCell(iCell) - - xPWLCentre = xPWLCentre + alphaPWL * xLocal(iVertexOnCell,iCell) - yPWLCentre = yPWLCentre + alphaPWL * yLocal(iVertexOnCell,iCell) - - enddo ! iVertexOnCell - - ! calculate the area of the subcells - basisSubAreaSum = 0.0_RKIND + do iSubCell = 1, nEdgesOnCell(iCell) - do iSubCell = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(iSubCell,iCell) + iVertexOnCell1 = seaice_wrapped_index(iSubCell - 1, nEdgesOnCell(iCell)) + iVertexOnCell2 = iSubCell - iEdge = edgesOnCell(iSubCell,iCell) - iVertexOnCell1 = seaice_wrapped_index(iSubCell - 1, nEdgesOnCell(iCell)) - iVertexOnCell2 = iSubCell + c = dvEdge(iEdge) + a = sqrt((xLocal(iVertexOnCell1,iCell) - xPWLCentre)**2 + & + (yLocal(iVertexOnCell1,iCell) - yPWLCentre)**2) + b = sqrt((xLocal(iVertexOnCell2,iCell) - xPWLCentre)**2 + & + (yLocal(iVertexOnCell2,iCell) - yPWLCentre)**2) - c = dvEdge(iEdge) - a = sqrt((xLocal(iVertexOnCell1,iCell) - xPWLCentre)**2 + & - (yLocal(iVertexOnCell1,iCell) - yPWLCentre)**2) - b = sqrt((xLocal(iVertexOnCell2,iCell) - xPWLCentre)**2 + & - (yLocal(iVertexOnCell2,iCell) - yPWLCentre)**2) + s = (a + b + c) * 0.5_RKIND - s = (a + b + c) * 0.5_RKIND + ! Heron's formula + basisSubArea(iSubCell) = sqrt(s * (s-a) * (s-b) * (s-c)) - ! Heron's formula - basisSubArea(iSubCell) = sqrt(s * (s-a) * (s-b) * (s-c)) + basisSubAreaSum = basisSubAreaSum + basisSubArea(iSubCell) - basisSubAreaSum = basisSubAreaSum + basisSubArea(iSubCell) + enddo ! iSubCell - enddo ! iSubCell + ! ensure sum of subareas equals the area of the cell + basisSubArea(:) = basisSubArea(:) * (areaCell(iCell) / basisSubAreaSum) - ! ensure sum of subareas equals the area of the cell - basisSubArea(:) = basisSubArea(:) * (areaCell(iCell) / basisSubAreaSum) + ! calculate the linear basis on the sub triangle + do iSubCell = 1, nEdgesOnCell(iCell) - ! calculate the linear basis on the sub triangle - do iSubCell = 1, nEdgesOnCell(iCell) + iVertexOnCell1 = seaice_wrapped_index(iSubCell - 1, nEdgesOnCell(iCell)) + iVertexOnCell2 = iSubCell - iVertexOnCell1 = seaice_wrapped_index(iSubCell - 1, nEdgesOnCell(iCell)) - iVertexOnCell2 = iSubCell + ! set up left hand matrix + leftMatrix(1,1) = xLocal(iVertexOnCell1,iCell) - xPWLCentre + leftMatrix(1,2) = yLocal(iVertexOnCell1,iCell) - yPWLCentre + leftMatrix(1,3) = 1.0_RKIND - ! set up left hand matrix - leftMatrix(1,1) = xLocal(iVertexOnCell1,iCell) - xPWLCentre - leftMatrix(1,2) = yLocal(iVertexOnCell1,iCell) - yPWLCentre - leftMatrix(1,3) = 1.0_RKIND + leftMatrix(2,1) = xLocal(iVertexOnCell2,iCell) - xPWLCentre + leftMatrix(2,2) = yLocal(iVertexOnCell2,iCell) - yPWLCentre + leftMatrix(2,3) = 1.0_RKIND - leftMatrix(2,1) = xLocal(iVertexOnCell2,iCell) - xPWLCentre - leftMatrix(2,2) = yLocal(iVertexOnCell2,iCell) - yPWLCentre - leftMatrix(2,3) = 1.0_RKIND + leftMatrix(3,1) = 0.0_RKIND + leftMatrix(3,2) = 0.0_RKIND + leftMatrix(3,3) = 1.0_RKIND - leftMatrix(3,1) = 0.0_RKIND - leftMatrix(3,2) = 0.0_RKIND - leftMatrix(3,3) = 1.0_RKIND + ! first basis + rightHandSide(1) = 1.0_RKIND + rightHandSide(2) = 0.0_RKIND + rightHandSide(3) = 0.0_RKIND - ! first basis - rightHandSide(1) = 1.0_RKIND - rightHandSide(2) = 0.0_RKIND - rightHandSide(3) = 0.0_RKIND + call seaice_solve_linear_basis_system(leftMatrix, rightHandSide, solutionVector) - call seaice_solve_linear_basis_system(leftMatrix, rightHandSide, solutionVector) + subBasisGradientU(iSubCell,1) = solutionVector(1) + subBasisGradientV(iSubCell,1) = solutionVector(2) + subBasisConstant(iSubCell,1) = solutionVector(3) - subBasisGradientU(iSubCell,1) = solutionVector(1) - subBasisGradientV(iSubCell,1) = solutionVector(2) - subBasisConstant(iSubCell,1) = solutionVector(3) + ! second basis + rightHandSide(1) = 0.0_RKIND + rightHandSide(2) = 1.0_RKIND + rightHandSide(3) = 0.0_RKIND - ! second basis - rightHandSide(1) = 0.0_RKIND - rightHandSide(2) = 1.0_RKIND - rightHandSide(3) = 0.0_RKIND + call seaice_solve_linear_basis_system(leftMatrix, rightHandSide, solutionVector) - call seaice_solve_linear_basis_system(leftMatrix, rightHandSide, solutionVector) + subBasisGradientU(iSubCell,2) = solutionVector(1) + subBasisGradientV(iSubCell,2) = solutionVector(2) + subBasisConstant(iSubCell,2) = solutionVector(3) - subBasisGradientU(iSubCell,2) = solutionVector(1) - subBasisGradientV(iSubCell,2) = solutionVector(2) - subBasisConstant(iSubCell,2) = solutionVector(3) + ! third basis + subBasisGradientU(iSubCell,3) = -subBasisGradientU(iSubCell,1) - subBasisGradientU(iSubCell,2) + subBasisGradientV(iSubCell,3) = -subBasisGradientV(iSubCell,1) - subBasisGradientV(iSubCell,2) + subBasisConstant(iSubCell,3) = 1.0_RKIND - subBasisConstant(iSubCell,1) - subBasisConstant(iSubCell,2) - ! third basis - subBasisGradientU(iSubCell,3) = -subBasisGradientU(iSubCell,1) - subBasisGradientU(iSubCell,2) - subBasisGradientV(iSubCell,3) = -subBasisGradientV(iSubCell,1) - subBasisGradientV(iSubCell,2) - subBasisConstant(iSubCell,3) = 1.0_RKIND - subBasisConstant(iSubCell,1) - subBasisConstant(iSubCell,2) + enddo ! iSubCell - enddo ! iSubCell + ! use the linear sub area basis to calculate the PWL basis + do iBasisVertex = 1, nEdgesOnCell(iCell) - ! use the linear sub area basis to calculate the PWL basis - do iBasisVertex = 1, nEdgesOnCell(iCell) + ! loop over subcells + do iSubCell = 1, nEdgesOnCell(iCell) - ! loop over subcells - do iSubCell = 1, nEdgesOnCell(iCell) + ! array (index of the basis vertex, subarea value) + subCellGradientU(iBasisVertex,iSubCell) = subBasisGradientU(iSubCell,3) * alphaPWL + subCellGradientV(iBasisVertex,iSubCell) = subBasisGradientV(iSubCell,3) * alphaPWL - ! array (index of the basis vertex, subarea value) - subCellGradientU(iBasisVertex,iSubCell) = subBasisGradientU(iSubCell,3) * alphaPWL - subCellGradientV(iBasisVertex,iSubCell) = subBasisGradientV(iSubCell,3) * alphaPWL + if (iSubCell == seaice_wrapped_index(iBasisVertex + 1, nEdgesOnCell(iCell))) then - if (iSubCell == seaice_wrapped_index(iBasisVertex + 1, nEdgesOnCell(iCell))) then + subCellGradientU(iBasisVertex,iSubCell) = subCellGradientU(iBasisVertex,iSubCell) + subBasisGradientU(iSubCell,1) + subCellGradientV(iBasisVertex,iSubCell) = subCellGradientV(iBasisVertex,iSubCell) + subBasisGradientV(iSubCell,1) - subCellGradientU(iBasisVertex,iSubCell) = subCellGradientU(iBasisVertex,iSubCell) + subBasisGradientU(iSubCell,1) - subCellGradientV(iBasisVertex,iSubCell) = subCellGradientV(iBasisVertex,iSubCell) + subBasisGradientV(iSubCell,1) + else if (iSubCell == iBasisVertex) then - else if (iSubCell == iBasisVertex) then + subCellGradientU(iBasisVertex,iSubCell) = subCellGradientU(iBasisVertex,iSubCell) + subBasisGradientU(iSubCell,2) + subCellGradientV(iBasisVertex,iSubCell) = subCellGradientV(iBasisVertex,iSubCell) + subBasisGradientV(iSubCell,2) - subCellGradientU(iBasisVertex,iSubCell) = subCellGradientU(iBasisVertex,iSubCell) + subBasisGradientU(iSubCell,2) - subCellGradientV(iBasisVertex,iSubCell) = subCellGradientV(iBasisVertex,iSubCell) + subBasisGradientV(iSubCell,2) + endif - endif + enddo ! iSubCell - enddo ! iSubCell + enddo ! iEdgeOnCell - enddo ! iEdgeOnCell + ! calculate the gradients at the cell corners + do iBasisVertex = 1, nEdgesOnCell(iCell) - ! calculate the gradients at the cell corners - do iBasisVertex = 1, nEdgesOnCell(iCell) + do iGradientVertex = 1, nEdgesOnCell(iCell) - do iGradientVertex = 1, nEdgesOnCell(iCell) + iSubCell1 = iGradientVertex + iSubCell2 = seaice_wrapped_index(iGradientVertex + 1, nEdgesOnCell(iCell)) - iSubCell1 = iGradientVertex - iSubCell2 = seaice_wrapped_index(iGradientVertex + 1, nEdgesOnCell(iCell)) + basisGradientU(iBasisVertex,iGradientVertex,iCell) = & + 0.5_RKIND * (subCellGradientU(iBasisVertex,iSubCell1) + subCellGradientU(iBasisVertex,iSubCell2)) + basisGradientV(iBasisVertex,iGradientVertex,iCell) = & + 0.5_RKIND * (subCellGradientV(iBasisVertex,iSubCell1) + subCellGradientV(iBasisVertex,iSubCell2)) - basisGradientU(iBasisVertex,iGradientVertex,iCell) = & - 0.5_RKIND * (subCellGradientU(iBasisVertex,iSubCell1) + subCellGradientU(iBasisVertex,iSubCell2)) - basisGradientV(iBasisVertex,iGradientVertex,iCell) = & - 0.5_RKIND * (subCellGradientV(iBasisVertex,iSubCell1) + subCellGradientV(iBasisVertex,iSubCell2)) + enddo ! iGradientVertex - enddo ! iGradientVertex + enddo ! iBasisVertex - enddo ! iBasisVertex + ! calculate the basis integrals + do iStressVertex = 1, nEdgesOnCell(iCell) + do iVelocityVertex = 1, nEdgesOnCell(iCell) - ! calculate the basis integrals - do iStressVertex = 1, nEdgesOnCell(iCell) - do iVelocityVertex = 1, nEdgesOnCell(iCell) + basisIntegralsU(iStressVertex,iVelocityVertex,iCell) = 0.0_RKIND + basisIntegralsV(iStressVertex,iVelocityVertex,iCell) = 0.0_RKIND - basisIntegralsU(iStressVertex,iVelocityVertex,iCell) = 0.0_RKIND - basisIntegralsV(iStressVertex,iVelocityVertex,iCell) = 0.0_RKIND + do iSubCell = 1, nEdgesOnCell(iCell) - do iSubCell = 1, nEdgesOnCell(iCell) + if (iSubCell == iStressVertex .or. iSubCell == seaice_wrapped_index(iStressVertex + 1, nEdgesOnCell(iCell))) then + basisIntegral = ((alphaPWL + 1) * basisSubArea(iSubCell)) / 3.0_RKIND + else + basisIntegral = ( alphaPWL * basisSubArea(iSubCell)) / 3.0_RKIND + endif - if (iSubCell == iStressVertex .or. iSubCell == seaice_wrapped_index(iStressVertex + 1, nEdgesOnCell(iCell))) then - basisIntegral = ((alphaPWL + 1) * basisSubArea(iSubCell)) / 3.0_RKIND - else - basisIntegral = ( alphaPWL * basisSubArea(iSubCell)) / 3.0_RKIND - endif + basisIntegralsU(iStressVertex,iVelocityVertex,iCell) = basisIntegralsU(iStressVertex,iVelocityVertex,iCell) + & + subCellGradientU(iVelocityVertex,iSubCell) * basisIntegral - basisIntegralsU(iStressVertex,iVelocityVertex,iCell) = basisIntegralsU(iStressVertex,iVelocityVertex,iCell) + & - subCellGradientU(iVelocityVertex,iSubCell) * basisIntegral + basisIntegralsV(iStressVertex,iVelocityVertex,iCell) = basisIntegralsV(iStressVertex,iVelocityVertex,iCell) + & + subCellGradientV(iVelocityVertex,iSubCell) * basisIntegral - basisIntegralsV(iStressVertex,iVelocityVertex,iCell) = basisIntegralsV(iStressVertex,iVelocityVertex,iCell) + & - subCellGradientV(iVelocityVertex,iSubCell) * basisIntegral + enddo ! iSubCell - enddo ! iSubCell + enddo ! iVelocityVertex + enddo ! iStressVertex - enddo ! iVelocityVertex - enddo ! iStressVertex + ! basis integrals for the metric terms + do iStressVertex = 1, nEdgesOnCell(iCell) + do iVelocityVertex = 1, nEdgesOnCell(iCell) - ! basis integrals for the metric terms - do iStressVertex = 1, nEdgesOnCell(iCell) - do iVelocityVertex = 1, nEdgesOnCell(iCell) + basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) = 0.0_RKIND - basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) = 0.0_RKIND + do iSubCell = 1, nEdgesOnCell(iCell) - do iSubCell = 1, nEdgesOnCell(iCell) + ! determine stress subcell type + if (iSubCell == seaice_wrapped_index(iStressVertex + 1, nEdgesOnCell(iCell))) then + subCellTypeStress = 1 + else if (iSubCell == iStressVertex) then + subCellTypeStress = 2 + else + subCellTypeStress = 3 + endif - ! determine stress subcell type - if (iSubCell == seaice_wrapped_index(iStressVertex + 1, nEdgesOnCell(iCell))) then - subCellTypeStress = 1 - else if (iSubCell == iStressVertex) then - subCellTypeStress = 2 - else - subCellTypeStress = 3 - endif + ! determine velocity subcell type + if (iSubCell == seaice_wrapped_index(iVelocityVertex + 1, nEdgesOnCell(iCell))) then + subCellTypeVelocity = 1 + else if (iSubCell == iVelocityVertex) then + subCellTypeVelocity = 2 + else + subCellTypeVelocity = 3 + endif - ! determine velocity subcell type - if (iSubCell == seaice_wrapped_index(iVelocityVertex + 1, nEdgesOnCell(iCell))) then - subCellTypeVelocity = 1 - else if (iSubCell == iVelocityVertex) then - subCellTypeVelocity = 2 - else - subCellTypeVelocity = 3 - endif + ! set the subcell integral value + if ((subCellTypeStress == 1 .and. subCellTypeVelocity == 1) .or. & + (subCellTypeStress == 2 .and. subCellTypeVelocity == 2)) then - ! set the subcell integral value - if ((subCellTypeStress == 1 .and. subCellTypeVelocity == 1) .or. & - (subCellTypeStress == 2 .and. subCellTypeVelocity == 2)) then + basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 + 2.0_RKIND * alphaPWL + 2.0_RKIND - basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 + 2.0_RKIND * alphaPWL + 2.0_RKIND + else if ((subCellTypeStress == 1 .and. subCellTypeVelocity == 2) .or. & + (subCellTypeStress == 2 .and. subCellTypeVelocity == 1)) then - else if ((subCellTypeStress == 1 .and. subCellTypeVelocity == 2) .or. & - (subCellTypeStress == 2 .and. subCellTypeVelocity == 1)) then + basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 + 2.0_RKIND * alphaPWL + 1.0_RKIND - basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 + 2.0_RKIND * alphaPWL + 1.0_RKIND + else if ((subCellTypeStress == 1 .and. subCellTypeVelocity == 3) .or. & + (subCellTypeStress == 3 .and. subCellTypeVelocity == 1) .or. & + (subCellTypeStress == 2 .and. subCellTypeVelocity == 3) .or. & + (subCellTypeStress == 3 .and. subCellTypeVelocity == 2)) then - else if ((subCellTypeStress == 1 .and. subCellTypeVelocity == 3) .or. & - (subCellTypeStress == 3 .and. subCellTypeVelocity == 1) .or. & - (subCellTypeStress == 2 .and. subCellTypeVelocity == 3) .or. & - (subCellTypeStress == 3 .and. subCellTypeVelocity == 2)) then + basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 + alphaPWL - basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 + alphaPWL + else if (subCellTypeStress == 3 .and. subCellTypeVelocity == 3) then - else if (subCellTypeStress == 3 .and. subCellTypeVelocity == 3) then + basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 - basisIntegralsMetricSubCell = 2.0_RKIND * alphaPWL**2 + end if - end if + basisIntegralsMetricSubCell = basisIntegralsMetricSubCell * & + basisSubArea(iSubCell) / 12.0_RKIND - basisIntegralsMetricSubCell = basisIntegralsMetricSubCell * & - basisSubArea(iSubCell) / 12.0_RKIND + basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) = & + basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) + & + basisIntegralsMetricSubCell - basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) = & - basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) + & - basisIntegralsMetricSubCell + enddo ! iSubCell - enddo ! iSubCell + enddo ! iVelocityVertex + enddo ! iStressVertex - enddo ! iVelocityVertex - enddo ! iStressVertex + enddo ! iCell - enddo ! iCell + deallocate(subBasisGradientU) + deallocate(subBasisGradientV) + deallocate(subBasisConstant) + deallocate(subCellgradientU) + deallocate(subCellgradientV) + deallocate(basisSubArea) - deallocate(subBasisGradientU) - deallocate(subBasisGradientV) - deallocate(subBasisConstant) - deallocate(subCellgradientU) - deallocate(subCellgradientV) - deallocate(basisSubArea) + blockPtr => blockPtr % next + enddo end subroutine seaice_init_velocity_solver_pwl!}}} @@ -392,7 +456,7 @@ function pwl_basis_gradient(& iSubCell) & result(grad)!{{{ - use seaice_velocity_solver_variational_shared, only: & + use seaice_mesh, only: & seaice_wrapped_index integer, intent(in) :: & diff --git a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational.F b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational.F index 92eed849db84..cabe015a3118 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational.F @@ -50,78 +50,14 @@ module seaice_velocity_solver_variational ! !----------------------------------------------------------------------- - subroutine seaice_init_velocity_solver_variational(& - mesh, & - velocity_variational, & - boundary, & - rotateCartesianGrid, & - includeMetricTerms, & - variationalBasisType, & - variationalDenominatorType, & - integrationType, & - integrationOrder)!{{{ - - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: - - type(MPAS_pool_type), pointer :: & - velocity_variational, & !< Input/Output: - boundary !< Input/Output: - - logical, intent(in) :: & - rotateCartesianGrid, & !< Input: - includeMetricTerms !< Input: - - character(len=*), intent(in) :: & - variationalBasisType, & !< Input: - variationalDenominatorType, & !< Input: - integrationType !< Input: - - integer, intent(in) :: & - integrationOrder !< Input: - - call init_velocity_solver_variational_primary_mesh(& - mesh, & - velocity_variational, & - boundary, & - rotateCartesianGrid, & - includeMetricTerms, & - variationalBasisType, & - variationalDenominatorType, & - integrationType, & - integrationOrder) - - end subroutine seaice_init_velocity_solver_variational - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! init_velocity_solver_variational_primary_mesh -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 24 October 2014 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine init_velocity_solver_variational_primary_mesh(& - mesh, & - velocity_variational, & - boundary, & - rotateCartesianGrid, & - includeMetricTerms, & - variationalBasisType, & - variationalDenominatorType, & - integrationType, & - integrationOrder)!{{{ + subroutine seaice_init_velocity_solver_variational(domain)!{{{ use seaice_mesh, only: & - seaice_cell_vertices_at_vertex + seaice_calc_local_coords use seaice_velocity_solver_variational_shared, only: & - seaice_calc_local_coords, & - seaice_calc_variational_metric_terms + seaice_calc_variational_metric_terms, & + seaice_cell_vertices_at_vertex use seaice_velocity_solver_wachspress, only: & seaice_init_velocity_solver_wachspress @@ -129,219 +65,47 @@ subroutine init_velocity_solver_variational_primary_mesh(& use seaice_velocity_solver_pwl, only: & seaice_init_velocity_solver_pwl - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: - - type(MPAS_pool_type), pointer :: & - velocity_variational, & !< Input/Output: - boundary !< Input/Output: - - logical, intent(in) :: & - rotateCartesianGrid, & !< Input: - includeMetricTerms !< Input: - - character(len=*), intent(in) :: & - variationalBasisType, & !< Input: - variationalDenominatorType, & !< Input: - integrationType !< Input: - - integer, intent(in) :: & - integrationOrder !< Input: + type (domain_type), intent(inout) :: & + domain !< Input/Output: - integer, dimension(:,:), pointer :: & - cellVerticesAtVertex - - real(kind=RKIND), dimension(:), pointer :: & - tanLatVertexRotatedOverRadius, & - variationalDenominator - - real(kind=RKIND), dimension(:,:,:), pointer :: & - basisGradientU, & - basisGradientV, & - basisIntegralsMetric, & - basisIntegralsU, & - basisIntegralsV - - integer, pointer :: & - nCells, & - nVertices, & - vertexDegree, & - maxEdges - - integer, dimension(:), pointer :: & - nEdgesOnCell, & - interiorVertex - - integer, dimension(:,:), pointer :: & - verticesOnCell, & - cellsOnVertex, & - edgesOnCell - - real(kind=RKIND), dimension(:), pointer :: & - xVertex, & - yVertex, & - zVertex, & - xCell, & - yCell, & - zCell, & - areaCell, & - areaTriangle, & - dvEdge - - logical, pointer :: & - on_a_sphere - - real(kind=RKIND), pointer :: & - sphere_radius - - real(kind=RKIND), dimension(:,:), allocatable :: & - xLocal, & - yLocal - - call MPAS_pool_get_config(mesh, "on_a_sphere", on_a_sphere) - call MPAS_pool_get_config(mesh, "sphere_radius", sphere_radius) - - call MPAS_pool_get_dimension(mesh, "nCells", nCells) - call MPAS_pool_get_dimension(mesh, "nVertices", nVertices) - call MPAS_pool_get_dimension(mesh, "vertexDegree", vertexDegree) - call MPAS_pool_get_dimension(mesh, "maxEdges", maxEdges) - - call MPAS_pool_get_array(mesh, "nEdgesOnCell", nEdgesOnCell) - call MPAS_pool_get_array(mesh, "verticesOnCell", verticesOnCell) - call MPAS_pool_get_array(mesh, "cellsOnVertex", cellsOnVertex) - call MPAS_pool_get_array(mesh, "edgesOnCell", edgesOnCell) - call MPAS_pool_get_array(mesh, "xVertex", xVertex) - call MPAS_pool_get_array(mesh, "yVertex", yVertex) - call MPAS_pool_get_array(mesh, "zVertex", zVertex) - call MPAS_pool_get_array(mesh, "xCell", xCell) - call MPAS_pool_get_array(mesh, "yCell", yCell) - call MPAS_pool_get_array(mesh, "zCell", zCell) - call MPAS_pool_get_array(mesh, "areaCell", areaCell) - call MPAS_pool_get_array(mesh, "areaTriangle", areaTriangle) - call MPAS_pool_get_array(mesh, "dvEdge", dvEdge) - - call MPAS_pool_get_array(boundary, "interiorVertex", interiorVertex) - - call MPAS_pool_get_array(velocity_variational, "cellVerticesAtVertex", cellVerticesAtVertex) - call MPAS_pool_get_array(velocity_variational, "tanLatVertexRotatedOverRadius", tanLatVertexRotatedOverRadius) - call MPAS_pool_get_array(velocity_variational, "basisGradientU", basisGradientU) - call MPAS_pool_get_array(velocity_variational, "basisGradientV", basisGradientV) - call MPAS_pool_get_array(velocity_variational, "basisIntegralsU", basisIntegralsU) - call MPAS_pool_get_array(velocity_variational, "basisIntegralsV", basisIntegralsV) - call MPAS_pool_get_array(velocity_variational, "basisIntegralsMetric", basisIntegralsMetric) - call MPAS_pool_get_array(velocity_variational, "variationalDenominator", variationalDenominator) + character(len=strKIND), pointer :: & + config_variational_basis call mpas_timer_start("variational calc_metric_terms") - call seaice_calc_variational_metric_terms(& - tanLatVertexRotatedOverRadius, & - nVertices, & - xVertex, & - yVertex, & - zVertex, & - sphere_radius, & - rotateCartesianGrid, & - includeMetricTerms) + call seaice_calc_variational_metric_terms(domain) call mpas_timer_stop("variational calc_metric_terms") call mpas_timer_start("variational vertices_at_vertex") - call seaice_cell_vertices_at_vertex(& - cellVerticesAtVertex, & - nVertices, & - vertexDegree, & - nEdgesOnCell, & - verticesOnCell, & - cellsOnVertex) + call seaice_cell_vertices_at_vertex(domain) call mpas_timer_stop("variational vertices_at_vertex") - call mpas_timer_start("variational calc_local_coords") - allocate(xLocal(maxEdges,nCells)) - allocate(yLocal(maxEdges,nCells)) + call MPAS_pool_get_config(domain % configs, "config_variational_basis", config_variational_basis) - call seaice_calc_local_coords(& - xLocal, & - yLocal, & - nCells, & - nEdgesOnCell, & - verticesOnCell, & - xVertex, & - yVertex, & - zVertex, & - xCell, & - yCell, & - zCell, & - rotateCartesianGrid, & - on_a_sphere) - call mpas_timer_stop("variational calc_local_coords") - - if (trim(variationalBasisType) == "wachspress") then - - call seaice_init_velocity_solver_wachspress(& - nCells, & - maxEdges, & - nEdgesOnCell, & - xLocal, & - yLocal, & - rotateCartesianGrid, & - includeMetricTerms, & - on_a_sphere, & - integrationType, & - integrationOrder, & - sphere_radius, & - basisGradientU, & - basisGradientV, & - basisIntegralsU, & - basisIntegralsV, & - basisIntegralsMetric) - - else if (trim(variationalBasisType) == "pwl") then - - call seaice_init_velocity_solver_pwl(& - nCells, & - maxEdges, & - nEdgesOnCell, & - verticesOnCell, & - edgesOnCell, & - dvEdge, & - areaCell, & - xLocal, & - yLocal, & - basisGradientU, & - basisGradientV, & - basisIntegralsMetric, & - basisIntegralsU, & - basisIntegralsV) - - else if (trim(variationalBasisType) == "none") then + if (trim(config_variational_basis) == "wachspress") then + + call seaice_init_velocity_solver_wachspress(domain) + + else if (trim(config_variational_basis) == "pwl") then + + call seaice_init_velocity_solver_pwl(domain) + + else if (trim(config_variational_basis) == "none") then continue else - call MPAS_log_write("Unknown variational basis type: "//trim(variationalBasisType), MPAS_LOG_CRIT) + call MPAS_log_write("Unknown variational basis type: "//trim(config_variational_basis), MPAS_LOG_CRIT) endif call mpas_timer_start("variational denominator") - call variational_denominator(& - nVertices, & - vertexDegree, & - nEdgesOnCell, & - interiorVertex, & - areaTriangle, & - cellsOnVertex, & - cellVerticesAtVertex, & - basisIntegralsMetric, & - variationalDenominatorType, & - variationalDenominator) + call variational_denominator(domain) call mpas_timer_stop("variational denominator") - ! clean up - deallocate(xLocal) - deallocate(yLocal) - !call homogenize_variational_basis_field() - end subroutine init_velocity_solver_variational_primary_mesh + end subroutine seaice_init_velocity_solver_variational !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -355,42 +119,43 @@ end subroutine init_velocity_solver_variational_primary_mesh ! !----------------------------------------------------------------------- - subroutine variational_denominator(& - nVertices, & - vertexDegree, & - nEdgesOnCell, & - interiorVertex, & - areaTriangle, & - cellsOnVertex, & - cellVerticesAtVertex, & - basisIntegralsMetric, & - variationalDenominatorType, & - variationalDenominator) + subroutine variational_denominator(domain) - integer, intent(in) :: & - nVertices, & !< Input: - vertexDegree !< Input: + type (domain_type), intent(inout) :: & + domain !< Input/Output: + + type(block_type), pointer :: & + blockPtr - integer, dimension(:), intent(in) :: & - nEdgesOnCell, & !< Input: - interiorVertex !< Input: + type(MPAS_pool_type), pointer :: & + meshPool, & + boundaryPool, & + velocityVariationalPool + + character(len=strKIND), pointer :: & + config_variational_denominator_type + + integer, pointer :: & + nVertices, & + vertexDegree - real(kind=RKIND), dimension(:), intent(in) :: & - areaTriangle !< Input: + integer, dimension(:), pointer :: & + nEdgesOnCell, & + interiorVertex - integer, dimension(:,:), intent(in) :: & - cellsOnVertex !< Input: + real(kind=RKIND), dimension(:), pointer :: & + areaTriangle - integer, dimension(:,:), intent(in) :: & - cellVerticesAtVertex !< Input: + integer, dimension(:,:), pointer :: & + cellsOnVertex - real(kind=RKIND), dimension(:,:,:), intent(in) :: & - basisIntegralsMetric !< Input: + integer, dimension(:,:), pointer :: & + cellVerticesAtVertex - character(len=*), intent(in) :: & - variationalDenominatorType !< Input: + real(kind=RKIND), dimension(:,:,:), pointer :: & + basisIntegralsMetric - real(kind=RKIND), dimension(:), intent(out) :: & + real(kind=RKIND), dimension(:), pointer :: & variationalDenominator integer :: & @@ -400,45 +165,84 @@ subroutine variational_denominator(& iCell, & iVelocityVertex - if (trim(variationalDenominatorType) == "alternate") then + call MPAS_pool_get_config(domain % configs, "config_variational_denominator_type", config_variational_denominator_type) + if (trim(config_variational_denominator_type) == "alternate") then - do iVertex = 1, nVertices + blockPtr => domain % blocklist + do while (associated(blockPtr)) - variationalDenominator(iVertex) = 0.0_RKIND + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "boundary", boundaryPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) - ! loop over surrounding cells - do iSurroundingCell = 1, vertexDegree + call MPAS_pool_get_dimension(meshPool, "nVertices", nVertices) + call MPAS_pool_get_dimension(meshPool, "vertexDegree", vertexDegree) - ! get the cell number of this cell - iCell = cellsOnVertex(iSurroundingCell, iVertex) + call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) + call MPAS_pool_get_array(meshPool, "areaTriangle", areaTriangle) + call MPAS_pool_get_array(meshPool, "cellsOnVertex", cellsOnVertex) - ! get the vertexOnCell number of the iVertex velocity point from cell iCell - iVelocityVertex = cellVerticesAtVertex(iSurroundingCell,iVertex) + call MPAS_pool_get_array(boundaryPool, "interiorVertex", interiorVertex) - ! loop over the vertices of the surrounding cell - do iStressVertex = 1, nEdgesOnCell(iCell) + call MPAS_pool_get_array(velocityVariationalPool, "cellVerticesAtVertex", cellVerticesAtVertex) + call MPAS_pool_get_array(velocityVariationalPool, "basisIntegralsMetric", basisIntegralsMetric) + call MPAS_pool_get_array(velocityVariationalPool, "variationalDenominator", variationalDenominator) - variationalDenominator(iVertex) = variationalDenominator(iVertex) + & - basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) + do iVertex = 1, nVertices - enddo ! iStressVertex + variationalDenominator(iVertex) = 0.0_RKIND - enddo ! iSurroundingCell + ! loop over surrounding cells + do iSurroundingCell = 1, vertexDegree - ! inverse - variationalDenominator(iVertex) = variationalDenominator(iVertex) + ! get the cell number of this cell + iCell = cellsOnVertex(iSurroundingCell, iVertex) - enddo ! iVertex + ! get the vertexOnCell number of the iVertex velocity point from cell iCell + iVelocityVertex = cellVerticesAtVertex(iSurroundingCell,iVertex) - else if (trim(variationalDenominatorType) == "original") then + ! loop over the vertices of the surrounding cell + do iStressVertex = 1, nEdgesOnCell(iCell) - do iVertex = 1, nVertices - variationalDenominator(iVertex) = areaTriangle(iVertex) - enddo ! iVertex + variationalDenominator(iVertex) = variationalDenominator(iVertex) + & + basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) + + enddo ! iStressVertex + + enddo ! iSurroundingCell + + ! inverse + variationalDenominator(iVertex) = variationalDenominator(iVertex) + + enddo ! iVertex + + blockPtr => blockPtr % next + enddo + + else if (trim(config_variational_denominator_type) == "original") then + + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + + call MPAS_pool_get_dimension(meshPool, "nVertices", nVertices) + + call MPAS_pool_get_array(meshPool, "areaTriangle", areaTriangle) + + call MPAS_pool_get_array(velocityVariationalPool, "variationalDenominator", variationalDenominator) + + do iVertex = 1, nVertices + variationalDenominator(iVertex) = areaTriangle(iVertex) + enddo ! iVertex + + blockPtr => blockPtr % next + enddo else - call MPAS_log_write("Unknown variational denominator type: "//trim(variationalDenominatorType), MPAS_LOG_CRIT) + call MPAS_log_write("Unknown variational denominator type: "//trim(config_variational_denominator_type), MPAS_LOG_CRIT) endif @@ -572,42 +376,32 @@ end subroutine homogenize_cell ! !----------------------------------------------------------------------- - subroutine seaice_strain_tensor_variational(& - mesh, & - strain11, & - strain22, & - strain12, & - uVelocity, & - vVelocity, & - basisGradientU, & - basisGradientV, & - tanLatVertexRotatedOverRadius, & - solveStress)!{{{ + subroutine seaice_strain_tensor_variational(domain)!{{{ use seaice_mesh_pool, only: & nCells, & verticesOnCell, & - nEdgesOnCell - - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: + nEdgesOnCell, & + basisGradientU, & + basisGradientV, & + solveStress, & + tanLatVertexRotatedOverRadius, & + uVelocity, & + vVelocity - real(kind=RKIND), dimension(:,:), intent(out) :: & - strain11, & !< Output: - strain22, & !< Output: - strain12 !< Output: + type(domain_type), intent(inout) :: & + domain - real(kind=RKIND), dimension(:), intent(in) :: & - uVelocity, & !< Input: - vVelocity, & !< Input: - tanLatVertexRotatedOverRadius !< Input: + type(block_type), pointer :: & + blockPtr - real(kind=RKIND), dimension(:,:,:), contiguous, intent(in) :: & - basisGradientU, & !< Input: - basisGradientV !< Input: + type(MPAS_pool_type), pointer :: & + velocityVariationalPool - integer, dimension(:), intent(in) :: & - solveStress !< Input: + real(kind=RKIND), dimension(:,:), pointer :: & + strain11, & + strain22, & + strain12 integer :: & iCell, & @@ -621,7 +415,16 @@ subroutine seaice_strain_tensor_variational(& strain22Tmp, & strain12Tmp - ! loop over cells + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + + call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11) + call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22) + call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12) + + ! loop over cells #ifdef MPAS_OPENMP_OFFLOAD !$omp target teams distribute parallel do #elif MPAS_OPENACC @@ -630,42 +433,45 @@ subroutine seaice_strain_tensor_variational(& !$omp parallel do default(shared) private(iGradientVertex, iBasisVertex, iVertex, jVertex, & !$omp& strain11Tmp, strain22Tmp, strain12Tmp) #endif - do iCell = 1, nCells + do iCell = 1, nCells - if (solveStress(iCell) == 1) then + if (solveStress(iCell) == 1) then - ! loop over velocity points surrounding cell - location of stress and derivative - do iGradientVertex = 1, nEdgesOnCell(iCell) + ! loop over velocity points surrounding cell - location of stress and derivative + do iGradientVertex = 1, nEdgesOnCell(iCell) - strain11Tmp = 0.0_RKIND - strain22Tmp = 0.0_RKIND - strain12Tmp = 0.0_RKIND + strain11Tmp = 0.0_RKIND + strain22Tmp = 0.0_RKIND + strain12Tmp = 0.0_RKIND - ! loop over basis functions - do iBasisVertex = 1, nEdgesOnCell(iCell) + ! loop over basis functions + do iBasisVertex = 1, nEdgesOnCell(iCell) - iVertex = verticesOnCell(iBasisVertex,iCell) + iVertex = verticesOnCell(iBasisVertex,iCell) - strain11Tmp = strain11Tmp + uVelocity(iVertex) * basisGradientU(iBasisVertex,iGradientVertex,iCell) - strain22Tmp = strain22Tmp + vVelocity(iVertex) * basisGradientV(iBasisVertex,iGradientVertex,iCell) - strain12Tmp = strain12Tmp + 0.5_RKIND * (& - uVelocity(iVertex) * basisGradientV(iBasisVertex,iGradientVertex,iCell) + & - vVelocity(iVertex) * basisGradientU(iBasisVertex,iGradientVertex,iCell)) + strain11Tmp = strain11Tmp + uVelocity(iVertex) * basisGradientU(iBasisVertex,iGradientVertex,iCell) + strain22Tmp = strain22Tmp + vVelocity(iVertex) * basisGradientV(iBasisVertex,iGradientVertex,iCell) + strain12Tmp = strain12Tmp + 0.5_RKIND * (& + uVelocity(iVertex) * basisGradientV(iBasisVertex,iGradientVertex,iCell) + & + vVelocity(iVertex) * basisGradientU(iBasisVertex,iGradientVertex,iCell)) - enddo ! iVertexOnCell + enddo ! iVertexOnCell - ! metric terms - jVertex = verticesOnCell(iGradientVertex,iCell) + ! metric terms + jVertex = verticesOnCell(iGradientVertex,iCell) - strain11(iGradientVertex,iCell) = strain11Tmp - vVelocity(jVertex) * tanLatVertexRotatedOverRadius(jVertex) - strain12(iGradientVertex,iCell) = strain12Tmp + uVelocity(jVertex) * tanLatVertexRotatedOverRadius(jVertex) * 0.5_RKIND - strain22(iGradientVertex,iCell) = strain22Tmp + strain11(iGradientVertex,iCell) = strain11Tmp - vVelocity(jVertex) * tanLatVertexRotatedOverRadius(jVertex) + strain12(iGradientVertex,iCell) = strain12Tmp + uVelocity(jVertex) * tanLatVertexRotatedOverRadius(jVertex) * 0.5_RKIND + strain22(iGradientVertex,iCell) = strain22Tmp - enddo ! jVertexOnCell + enddo ! jVertexOnCell - endif ! solveStress + endif ! solveStress - enddo ! iCell + enddo ! iCell + + blockPtr => blockPtr % next + end do end subroutine seaice_strain_tensor_variational!}}} @@ -681,11 +487,7 @@ end subroutine seaice_strain_tensor_variational!}}} ! !----------------------------------------------------------------------- - subroutine seaice_average_strains_on_vertex(& - areaCell, & - strain11, & - strain22, & - strain12) + subroutine seaice_average_strains_on_vertex(domain) use seaice_mesh_pool, only: & nCells, & @@ -694,13 +496,23 @@ subroutine seaice_average_strains_on_vertex(& cellsOnVertex, & vertexDegree - real(kind=RKIND), dimension(:), intent(in) :: & - areaCell !< Input + type(domain_type), intent(inout) :: & + domain + + type(block_type), pointer :: & + blockPtr + + type(MPAS_pool_type), pointer :: & + meshPool, & + velocityVariationalPool + + real(kind=RKIND), dimension(:), pointer :: & + areaCell - real(kind=RKIND), dimension(:,:), intent(inout) :: & - strain11, & !< Input/Output: - strain22, & !< Input/Output: - strain12 !< Input/Output: + real(kind=RKIND), dimension(:,:), pointer :: & + strain11, & + strain22, & + strain12 real(kind=RKIND) :: & strain11avg, & @@ -714,51 +526,66 @@ subroutine seaice_average_strains_on_vertex(& iCell, & iVertexOnCell - do iVertex = 1, nVerticesSolve + blockPtr => domain % blocklist + do while (associated(blockPtr)) - strain11avg = 0.0_RKIND - strain22avg = 0.0_RKIND - strain12avg = 0.0_RKIND - denominator = 0.0_RKIND + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) - do iVertexDegree = 1, vertexDegree + call MPAS_pool_get_array(meshPool, "areaCell", areaCell) - iCell = cellsOnVertex(iVertexDegree,iVertex) + call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11) + call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22) + call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12) - if (iCell <= nCells) then + do iVertex = 1, nVerticesSolve - iVertexOnCell = cellVerticesAtVertex(iVertexDegree,iVertex) + strain11avg = 0.0_RKIND + strain22avg = 0.0_RKIND + strain12avg = 0.0_RKIND + denominator = 0.0_RKIND - strain11avg = strain11avg + strain11(iVertexOnCell,iCell) * areaCell(iCell) - strain22avg = strain22avg + strain22(iVertexOnCell,iCell) * areaCell(iCell) - strain12avg = strain12avg + strain12(iVertexOnCell,iCell) * areaCell(iCell) - denominator = denominator + areaCell(iCell) + do iVertexDegree = 1, vertexDegree - endif + iCell = cellsOnVertex(iVertexDegree,iVertex) - enddo ! iVertexDegree + if (iCell <= nCells) then - strain11avg = strain11avg / denominator - strain22avg = strain22avg / denominator - strain12avg = strain12avg / denominator + iVertexOnCell = cellVerticesAtVertex(iVertexDegree,iVertex) - do iVertexDegree = 1, vertexDegree + strain11avg = strain11avg + strain11(iVertexOnCell,iCell) * areaCell(iCell) + strain22avg = strain22avg + strain22(iVertexOnCell,iCell) * areaCell(iCell) + strain12avg = strain12avg + strain12(iVertexOnCell,iCell) * areaCell(iCell) + denominator = denominator + areaCell(iCell) - iCell = cellsOnVertex(iVertexDegree,iVertex) + endif - if (iCell <= nCells) then + enddo ! iVertexDegree - iVertexOnCell = cellVerticesAtVertex(iVertexDegree,iVertex) + strain11avg = strain11avg / denominator + strain22avg = strain22avg / denominator + strain12avg = strain12avg / denominator - strain11(iVertexOnCell,iCell) = strain11avg - strain22(iVertexOnCell,iCell) = strain22avg - strain12(iVertexOnCell,iCell) = strain12avg + do iVertexDegree = 1, vertexDegree - endif + iCell = cellsOnVertex(iVertexDegree,iVertex) - enddo ! iCellOnVertex + if (iCell <= nCells) then - enddo ! iVertex + iVertexOnCell = cellVerticesAtVertex(iVertexDegree,iVertex) + + strain11(iVertexOnCell,iCell) = strain11avg + strain22(iVertexOnCell,iCell) = strain22avg + strain12(iVertexOnCell,iCell) = strain12avg + + endif + + enddo ! iCellOnVertex + + enddo ! iVertex + + blockPtr => blockPtr % next + end do end subroutine seaice_average_strains_on_vertex @@ -774,18 +601,7 @@ end subroutine seaice_average_strains_on_vertex ! !----------------------------------------------------------------------- - subroutine seaice_stress_tensor_variational(& - mesh, & - stress11, & - stress22, & - stress12, & - strain11, & - strain22, & - strain12, & - icePressure, & - replacementPressure, & - solveStress, & - dtElastic)!{{{ + subroutine seaice_stress_tensor_variational(domain)!{{{ use seaice_velocity_solver_constitutive_relation, only: & constitutiveRelationType, & @@ -799,32 +615,34 @@ subroutine seaice_stress_tensor_variational(& use seaice_mesh_pool, only: & nCells, & - nEdgesOnCell - - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: + nEdgesOnCell, & + stress11, & + stress22, & + stress12, & + icePressure, & + solveStress - real(kind=RKIND), dimension(:,:), contiguous, intent(inout) :: & - stress11, & !< Input/Output: - stress22, & !< Input/Output: - stress12 !< Input/Output: + type(domain_type), intent(inout) :: & + domain - real(kind=RKIND), dimension(:,:), contiguous, intent(out) :: & - replacementPressure !< Output: + type(block_type), pointer :: & + blockPtr - real(kind=RKIND), dimension(:,:), contiguous, intent(in) :: & - strain11, & !< Input: - strain22, & !< Input: - strain12 !< Input: + type(MPAS_pool_type), pointer :: & + meshPool, & + velocitySolverPool, & + velocityVariationalPool - real(kind=RKIND), dimension(:), intent(in) :: & - icePressure !< Input: + real(kind=RKIND), dimension(:,:), pointer :: & + replacementPressure - integer, dimension(:), intent(in) :: & - solveStress !< Input: + real(kind=RKIND), dimension(:,:), pointer :: & + strain11, & + strain22, & + strain12 - real(kind=RKIND), intent(in) :: & - dtElastic !< Input: + real(kind=RKIND), pointer :: & + elasticTimeStep integer :: & iCell, & @@ -843,12 +661,25 @@ subroutine seaice_stress_tensor_variational(& pressureCoefficient, & denominator - ! init variables - call MPAS_pool_get_array(mesh, "areaCell", areaCell) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - if (constitutiveRelationType == EVP_CONSTITUTIVE_RELATION) then + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) - denominator = 1.0_RKIND + (0.5_RKIND * dtElastic) / dampingTimescale + call MPAS_pool_get_array(velocitySolverPool, "elasticTimeStep", elasticTimeStep) + + call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11) + call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22) + call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12) + call MPAS_pool_get_array(velocityVariationalPool, "replacementPressure", replacementPressure) + + call MPAS_pool_get_array(meshPool, "areaCell", areaCell) + + if (constitutiveRelationType == EVP_CONSTITUTIVE_RELATION) then + + denominator = 1.0_RKIND + (0.5_RKIND * elasticTimeStep) / dampingTimescale #ifdef MPAS_OPENMP_OFFLOAD !$omp target teams distribute parallel do @@ -857,120 +688,123 @@ subroutine seaice_stress_tensor_variational(& #else !$omp parallel do default(shared) private(iVertexOnCell) #endif - do iCell = 1, nCells + do iCell = 1, nCells - replacementPressure(:,iCell) = 0.0_RKIND + replacementPressure(:,iCell) = 0.0_RKIND - if (solveStress(iCell) == 1) then + if (solveStress(iCell) == 1) then #if defined(MPAS_OPENMP_OFFLOAD) || defined(MPAS_OPENACC) - ! inline call to seaice_evp_constitutive_relation for GPUs - do iVertexOnCell = 1, nEdgesOnCell(iCell) + ! inline call to seaice_evp_constitutive_relation for GPUs + do iVertexOnCell = 1, nEdgesOnCell(iCell) - ! convert from stress11 to stress1 etc - strainDivergence = strain11(iVertexOnCell,iCell) + strain22(iVertexOnCell,iCell) - strainTension = strain11(iVertexOnCell,iCell) - strain22(iVertexOnCell,iCell) - strainShearing = strain12(iVertexOnCell,iCell) * 2.0_RKIND + ! convert from stress11 to stress1 etc + strainDivergence = strain11(iVertexOnCell,iCell) + strain22(iVertexOnCell,iCell) + strainTension = strain11(iVertexOnCell,iCell) - strain22(iVertexOnCell,iCell) + strainShearing = strain12(iVertexOnCell,iCell) * 2.0_RKIND - stress1 = stress11(iVertexOnCell,iCell) + stress22(iVertexOnCell,iCell) - stress2 = stress11(iVertexOnCell,iCell) - stress22(iVertexOnCell,iCell) + stress1 = stress11(iVertexOnCell,iCell) + stress22(iVertexOnCell,iCell) + stress2 = stress11(iVertexOnCell,iCell) - stress22(iVertexOnCell,iCell) - ! perform the constituitive relation - Delta = sqrt(strainDivergence*strainDivergence + & - (strainTension*strainTension + strainShearing*strainShearing) / eccentricitySquared) + ! perform the constituitive relation + Delta = sqrt(strainDivergence*strainDivergence + & + (strainTension*strainTension + strainShearing*strainShearing) / eccentricitySquared) - pressureCoefficient = icePressure(iCell) / max(Delta,puny) - replacementPressure(iVertexOnCell,iCell) = pressureCoefficient * Delta + pressureCoefficient = icePressure(iCell) / max(Delta,puny) + replacementPressure(iVertexOnCell,iCell) = pressureCoefficient * Delta - pressureCoefficient = (pressureCoefficient * dtElastic) / (2.0_RKIND * dampingTimescale) + pressureCoefficient = (pressureCoefficient * elasticTimeStep) / (2.0_RKIND * dampingTimescale) - stress1 = (stress1 + pressureCoefficient * (strainDivergence - Delta)) / denominator - stress2 = (stress2 + (pressureCoefficient / eccentricitySquared) * strainTension ) / denominator - stress12(iVertexOnCell,iCell) = (stress12(iVertexOnCell,iCell) & - + (pressureCoefficient / eccentricitysquared) * strainShearing * 0.5_RKIND) / denominator + stress1 = (stress1 + pressureCoefficient * (strainDivergence - Delta)) / denominator + stress2 = (stress2 + (pressureCoefficient / eccentricitySquared) * strainTension ) / denominator + stress12(iVertexOnCell,iCell) = (stress12(iVertexOnCell,iCell) & + + (pressureCoefficient / eccentricitysquared) * strainShearing * 0.5_RKIND) / denominator - ! convert back - stress11(iVertexOnCell,iCell) = 0.5_RKIND * (stress1 + stress2) - stress22(iVertexOnCell,iCell) = 0.5_RKIND * (stress1 - stress2) + ! convert back + stress11(iVertexOnCell,iCell) = 0.5_RKIND * (stress1 + stress2) + stress22(iVertexOnCell,iCell) = 0.5_RKIND * (stress1 - stress2) #else - !$omp simd - do iVertexOnCell = 1, nEdgesOnCell(iCell) - - call seaice_evp_constitutive_relation(& - stress11(iVertexOnCell,iCell), & - stress22(iVertexOnCell,iCell), & - stress12(iVertexOnCell,iCell), & - strain11(iVertexOnCell,iCell), & - strain22(iVertexOnCell,iCell), & - strain12(iVertexOnCell,iCell), & - icePressure(iCell), & - replacementPressure(iVertexOnCell,iCell), & - areaCell(iCell), & - dtElastic) + !$omp simd + do iVertexOnCell = 1, nEdgesOnCell(iCell) + + call seaice_evp_constitutive_relation(& + stress11(iVertexOnCell,iCell), & + stress22(iVertexOnCell,iCell), & + stress12(iVertexOnCell,iCell), & + strain11(iVertexOnCell,iCell), & + strain22(iVertexOnCell,iCell), & + strain12(iVertexOnCell,iCell), & + icePressure(iCell), & + replacementPressure(iVertexOnCell,iCell), & + areaCell(iCell), & + elasticTimeStep) #endif - enddo ! iVertexOnCell + enddo ! iVertexOnCell - endif ! solveStress + endif ! solveStress - enddo ! iCell + enddo ! iCell - else if (constitutiveRelationType == REVISED_EVP_CONSTITUTIVE_RELATION) then + else if (constitutiveRelationType == REVISED_EVP_CONSTITUTIVE_RELATION) then #ifdef MPAS_OPENMP !$omp parallel do default(shared) private(iVertexOnCell) #endif - do iCell = 1, nCells + do iCell = 1, nCells - if (solveStress(iCell) == 1) then + if (solveStress(iCell) == 1) then - !$omp simd - do iVertexOnCell = 1, nEdgesOnCell(iCell) + !$omp simd + do iVertexOnCell = 1, nEdgesOnCell(iCell) - call seaice_evp_constitutive_relation_revised(& - stress11(iVertexOnCell,iCell), & - stress22(iVertexOnCell,iCell), & - stress12(iVertexOnCell,iCell), & - strain11(iVertexOnCell,iCell), & - strain22(iVertexOnCell,iCell), & - strain12(iVertexOnCell,iCell), & - icePressure(iCell), & - replacementPressure(iVertexOnCell,iCell), & - areaCell(iCell)) + call seaice_evp_constitutive_relation_revised(& + stress11(iVertexOnCell,iCell), & + stress22(iVertexOnCell,iCell), & + stress12(iVertexOnCell,iCell), & + strain11(iVertexOnCell,iCell), & + strain22(iVertexOnCell,iCell), & + strain12(iVertexOnCell,iCell), & + icePressure(iCell), & + replacementPressure(iVertexOnCell,iCell), & + areaCell(iCell)) - enddo ! iVertexOnCell + enddo ! iVertexOnCell - endif ! solveStress + endif ! solveStress - enddo ! iCell + enddo ! iCell - else if (constitutiveRelationType == LINEAR_CONSTITUTIVE_RELATION) then + else if (constitutiveRelationType == LINEAR_CONSTITUTIVE_RELATION) then #ifdef MPAS_OPENMP !$omp parallel do default(shared) private(iCell, iVertexOnCell) #endif - do iCell = 1, nCells + do iCell = 1, nCells - if (solveStress(iCell) == 1) then + if (solveStress(iCell) == 1) then - !$omp simd - do iVertexOnCell = 1, nEdgesOnCell(iCell) + !$omp simd + do iVertexOnCell = 1, nEdgesOnCell(iCell) - call seaice_linear_constitutive_relation(& - stress11(iVertexOnCell,iCell), & - stress22(iVertexOnCell,iCell), & - stress12(iVertexOnCell,iCell), & - strain11(iVertexOnCell,iCell), & - strain22(iVertexOnCell,iCell), & - strain12(iVertexOnCell,iCell)) + call seaice_linear_constitutive_relation(& + stress11(iVertexOnCell,iCell), & + stress22(iVertexOnCell,iCell), & + stress12(iVertexOnCell,iCell), & + strain11(iVertexOnCell,iCell), & + strain22(iVertexOnCell,iCell), & + strain12(iVertexOnCell,iCell)) - enddo ! iVertexOnCell + enddo ! iVertexOnCell - endif ! solveStress + endif ! solveStress - enddo ! iCell + enddo ! iCell - endif ! constitutiveRelationType + endif ! constitutiveRelationType + + blockPtr => blockPtr % next + end do end subroutine seaice_stress_tensor_variational!}}} @@ -986,66 +820,72 @@ end subroutine seaice_stress_tensor_variational!}}} ! !----------------------------------------------------------------------- - subroutine seaice_stress_tensor_variational_linear(& - mesh, & - stress11, & - stress22, & - stress12, & - strain11, & - strain22, & - strain12, & - solveStress)!{{{ + subroutine seaice_stress_tensor_variational_linear(domain)!{{{ use seaice_velocity_solver_constitutive_relation, only: & seaice_linear_constitutive_relation use seaice_mesh_pool, only: & nCells, & - nEdgesOnCell + nEdgesOnCell, & + stress11, & + stress22, & + stress12, & + solveStress - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: + type(domain_type), intent(inout) :: & + domain - real(kind=RKIND), dimension(:,:), contiguous, intent(out) :: & - stress11, & !< Input/Output: - stress22, & !< Input/Output: - stress12 !< Input/Output: + type(block_type), pointer :: & + blockPtr - real(kind=RKIND), dimension(:,:), contiguous, intent(in) :: & - strain11, & !< Input: - strain22, & !< Input: - strain12 !< Input: + type(MPAS_pool_type), pointer :: & + velocityVariationalPool - integer, dimension(:), intent(in) :: & - solveStress !< Input: + real(kind=RKIND), dimension(:,:), pointer :: & + strain11, & + strain22, & + strain12 integer :: & iCell, & iVertexOnCell + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + + call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11) + call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22) + call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12) + #ifdef MPAS_OPENMP !$omp parallel do default(shared) private(iCell, iVertexOnCell) #endif - do iCell = 1, nCells + do iCell = 1, nCells + + if (solveStress(iCell) == 1) then - if (solveStress(iCell) == 1) then + !$omp simd + do iVertexOnCell = 1, nEdgesOnCell(iCell) - !$omp simd - do iVertexOnCell = 1, nEdgesOnCell(iCell) + call seaice_linear_constitutive_relation(& + stress11(iVertexOnCell,iCell), & + stress22(iVertexOnCell,iCell), & + stress12(iVertexOnCell,iCell), & + strain11(iVertexOnCell,iCell), & + strain22(iVertexOnCell,iCell), & + strain12(iVertexOnCell,iCell)) - call seaice_linear_constitutive_relation(& - stress11(iVertexOnCell,iCell), & - stress22(iVertexOnCell,iCell), & - stress12(iVertexOnCell,iCell), & - strain11(iVertexOnCell,iCell), & - strain22(iVertexOnCell,iCell), & - strain12(iVertexOnCell,iCell)) + enddo ! iVertexOnCell - enddo ! iVertexOnCell + endif ! solveStress - endif ! solveStress + enddo ! iCell - enddo ! iCell + blockPtr => blockPtr % next + end do end subroutine seaice_stress_tensor_variational_linear!}}} @@ -1061,54 +901,40 @@ end subroutine seaice_stress_tensor_variational_linear!}}} ! !----------------------------------------------------------------------- - subroutine seaice_stress_divergence_variational(& - mesh, & - stressDivergenceU, & - stressDivergenceV, & - stress11, & - stress22, & - stress12, & - basisIntegralsU, & - basisIntegralsV, & - basisIntegralsMetric, & - variationalDenominator, & - tanLatVertexRotatedOverRadius, & - cellVerticesAtVertex, & - solveVelocity)!{{{ + subroutine seaice_stress_divergence_variational(domain)!{{{ use seaice_mesh_pool, only: & nVerticesSolve, & cellsOnVertex, & nEdgesOnCell, & areaTriangle, & - vertexDegree - - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: - - real(kind=RKIND), dimension(:), intent(out) :: & - stressDivergenceU, & !< Output: - stressDivergenceV !< Output: + vertexDegree, & + basisIntegralsMetric, & + basisIntegralsU, & + basisIntegralsV, & + cellVerticesAtVertex, & + solveVelocity, & + stress11, & + stress22, & + stress12, & + tanLatVertexRotatedOverRadius - real(kind=RKIND), dimension(:,:), contiguous, intent(in) :: & - stress11, & !< Input: - stress22, & !< Input: - stress12 !< Input: + type(domain_type), intent(inout) :: & + domain - real(kind=RKIND), dimension(:,:,:), contiguous, intent(in) :: & - basisIntegralsU, & !< Input: - basisIntegralsV, & !< Input: - basisIntegralsMetric !< Input: + type(block_type), pointer :: & + blockPtr - real(kind=RKIND), dimension(:), intent(in) :: & - tanLatVertexRotatedOverRadius, & !< Input: - variationalDenominator !< Input: + type(MPAS_pool_type), pointer :: & + velocitySolverPool, & + velocityVariationalPool - integer, dimension(:,:), intent(in) :: & - cellVerticesAtVertex !< Input: + real(kind=RKIND), dimension(:), pointer :: & + stressDivergenceU, & + stressDivergenceV - integer, dimension(:), intent(in) :: & - solveVelocity !< Input: + real(kind=RKIND), dimension(:), pointer :: & + variationalDenominator real(kind=RKIND) :: & stressDivergenceUVertex, & @@ -1123,7 +949,18 @@ subroutine seaice_stress_divergence_variational(& iStressVertex, & iVelocityVertex - ! loop over velocity positions + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + + call MPAS_pool_get_array(velocitySolverPool, "stressDivergenceU", stressDivergenceU) + call MPAS_pool_get_array(velocitySolverPool, "stressDivergenceV", stressDivergenceV) + + call MPAS_pool_get_array(velocityVariationalPool, "variationalDenominator", variationalDenominator) + + ! loop over velocity positions #ifdef MPAS_OPENMP_OFFLOAD !$omp target teams distribute parallel do #elif MPAS_OPENACC @@ -1132,54 +969,57 @@ subroutine seaice_stress_divergence_variational(& !$omp parallel do default(shared) private(stressDivergenceUVertex, stressDivergenceVVertex, & !$omp& iSurroundingCell, iCell, iVelocityVertex, stressDivergenceUCell, stressDivergenceVCell, iStressVertex) #endif - do iVertex = 1, nVerticesSolve + do iVertex = 1, nVerticesSolve - if (solveVelocity(iVertex) == 1) then + if (solveVelocity(iVertex) == 1) then - stressDivergenceUVertex = 0.0_RKIND - stressDivergenceVVertex = 0.0_RKIND + stressDivergenceUVertex = 0.0_RKIND + stressDivergenceVVertex = 0.0_RKIND - ! loop over surrounding cells - do iSurroundingCell = 1, vertexDegree + ! loop over surrounding cells + do iSurroundingCell = 1, vertexDegree - ! get the cell number of this cell - iCell = cellsOnVertex(iSurroundingCell, iVertex) + ! get the cell number of this cell + iCell = cellsOnVertex(iSurroundingCell, iVertex) - ! get the vertexOnCell number of the iVertex velocity point from cell iCell - iVelocityVertex = cellVerticesAtVertex(iSurroundingCell,iVertex) + ! get the vertexOnCell number of the iVertex velocity point from cell iCell + iVelocityVertex = cellVerticesAtVertex(iSurroundingCell,iVertex) - stressDivergenceUCell = 0.0_RKIND - stressDivergenceVCell = 0.0_RKIND + stressDivergenceUCell = 0.0_RKIND + stressDivergenceVCell = 0.0_RKIND - ! loop over the vertices of the surrounding cell - do iStressVertex = 1, nEdgesOnCell(iCell) + ! loop over the vertices of the surrounding cell + do iStressVertex = 1, nEdgesOnCell(iCell) - ! normal & metric terms - stressDivergenceUCell = stressDivergenceUCell - & - stress11(iStressVertex,iCell) * basisIntegralsU(iStressVertex,iVelocityVertex,iCell) - & - stress12(iStressVertex,iCell) * basisIntegralsV(iStressVertex,iVelocityVertex,iCell) - & - stress12(iStressVertex,iCell) * basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) * & - tanLatVertexRotatedOverRadius(iVertex) + ! normal & metric terms + stressDivergenceUCell = stressDivergenceUCell - & + stress11(iStressVertex,iCell) * basisIntegralsU(iStressVertex,iVelocityVertex,iCell) - & + stress12(iStressVertex,iCell) * basisIntegralsV(iStressVertex,iVelocityVertex,iCell) - & + stress12(iStressVertex,iCell) * basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) * & + tanLatVertexRotatedOverRadius(iVertex) - stressDivergenceVCell = stressDivergenceVCell - & - stress22(iStressVertex,iCell) * basisIntegralsV(iStressVertex,iVelocityVertex,iCell) - & - stress12(iStressVertex,iCell) * basisIntegralsU(iStressVertex,iVelocityVertex,iCell) + & - stress11(iStressVertex,iCell) * basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) * & - tanLatVertexRotatedOverRadius(iVertex) + stressDivergenceVCell = stressDivergenceVCell - & + stress22(iStressVertex,iCell) * basisIntegralsV(iStressVertex,iVelocityVertex,iCell) - & + stress12(iStressVertex,iCell) * basisIntegralsU(iStressVertex,iVelocityVertex,iCell) + & + stress11(iStressVertex,iCell) * basisIntegralsMetric(iStressVertex,iVelocityVertex,iCell) * & + tanLatVertexRotatedOverRadius(iVertex) - enddo ! iStressVertex + enddo ! iStressVertex - stressDivergenceUVertex = stressDivergenceUVertex + stressDivergenceUCell - stressDivergenceVVertex = stressDivergenceVVertex + stressDivergenceVCell + stressDivergenceUVertex = stressDivergenceUVertex + stressDivergenceUCell + stressDivergenceVVertex = stressDivergenceVVertex + stressDivergenceVCell - enddo ! iSurroundingCell + enddo ! iSurroundingCell - stressDivergenceU(iVertex) = stressDivergenceUVertex / variationalDenominator(iVertex) - stressDivergenceV(iVertex) = stressDivergenceVVertex / variationalDenominator(iVertex) + stressDivergenceU(iVertex) = stressDivergenceUVertex / variationalDenominator(iVertex) + stressDivergenceV(iVertex) = stressDivergenceVVertex / variationalDenominator(iVertex) - endif ! solveVelocity + endif ! solveVelocity + + enddo ! iVertex - enddo ! iVertex + blockPtr => blockPtr % next + end do end subroutine seaice_stress_divergence_variational!}}} @@ -1195,7 +1035,7 @@ end subroutine seaice_stress_divergence_variational!}}} ! !----------------------------------------------------------------------- - subroutine seaice_final_divergence_shear_variational(block) + subroutine seaice_final_divergence_shear_variational(domain) use seaice_velocity_solver_constitutive_relation, only: & eccentricitySquared @@ -1205,8 +1045,11 @@ subroutine seaice_final_divergence_shear_variational(block) solveStress, & nEdgesOnCell - type(block_type), intent(inout) :: & - block + type(domain_type), intent(inout) :: & + domain + + type(block_type), pointer :: & + blockPtr type(MPAS_pool_type), pointer :: & velocityVariationalPool, & @@ -1243,89 +1086,95 @@ subroutine seaice_final_divergence_shear_variational(block) iCell, & iVertexOnCell - call MPAS_pool_get_subpool(block % structs, "velocity_variational", velocityVariationalPool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11) - call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22) - call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_array(velocitySolverPool, "divergence", divergence) - call MPAS_pool_get_array(velocitySolverPool, "shear", shear) + call MPAS_pool_get_array(velocityVariationalPool, "strain11", strain11) + call MPAS_pool_get_array(velocityVariationalPool, "strain22", strain22) + call MPAS_pool_get_array(velocityVariationalPool, "strain12", strain12) - allocate(DeltaAverage(nCells)) + call MPAS_pool_get_array(velocitySolverPool, "divergence", divergence) + call MPAS_pool_get_array(velocitySolverPool, "shear", shear) - do iCell = 1, nCells + allocate(DeltaAverage(nCells)) - if (solveStress(iCell) == 1) then + do iCell = 1, nCells - strainDivergenceSum = 0.0_RKIND - strainTensionSum = 0.0_RKIND - strainShearingSum = 0.0_RKIND - DeltaAverage(iCell) = 0.0_RKIND + if (solveStress(iCell) == 1) then - do iVertexOnCell = 1, nEdgesOnCell(iCell) + strainDivergenceSum = 0.0_RKIND + strainTensionSum = 0.0_RKIND + strainShearingSum = 0.0_RKIND + DeltaAverage(iCell) = 0.0_RKIND - strainDivergence = strain11(iVertexOnCell,iCell) + strain22(iVertexOnCell,iCell) - strainTension = strain11(iVertexOnCell,iCell) - strain22(iVertexOnCell,iCell) - strainShearing = strain12(iVertexOnCell,iCell) * 2.0_RKIND + do iVertexOnCell = 1, nEdgesOnCell(iCell) - Delta = sqrt(strainDivergence**2 + (strainTension**2 + strainShearing**2) / eccentricitySquared) + strainDivergence = strain11(iVertexOnCell,iCell) + strain22(iVertexOnCell,iCell) + strainTension = strain11(iVertexOnCell,iCell) - strain22(iVertexOnCell,iCell) + strainShearing = strain12(iVertexOnCell,iCell) * 2.0_RKIND - strainDivergenceSum = strainDivergenceSum + strainDivergence - strainTensionSum = strainTensionSum + strainTension - strainShearingSum = strainShearingSum + strainShearing - DeltaAverage(iCell) = DeltaAverage(iCell) + Delta + Delta = sqrt(strainDivergence**2 + (strainTension**2 + strainShearing**2) / eccentricitySquared) - enddo ! iVertexOnCell + strainDivergenceSum = strainDivergenceSum + strainDivergence + strainTensionSum = strainTensionSum + strainTension + strainShearingSum = strainShearingSum + strainShearing + DeltaAverage(iCell) = DeltaAverage(iCell) + Delta - divergence(iCell) = strainDivergenceSum / real(nEdgesOnCell(iCell),RKIND) - shear(iCell) = sqrt(strainTensionSum**2 + strainShearingSum**2) / real(nEdgesOnCell(iCell),RKIND) - DeltaAverage(iCell) = DeltaAverage(iCell) / real(nEdgesOnCell(iCell),RKIND) + enddo ! iVertexOnCell - else + divergence(iCell) = strainDivergenceSum / real(nEdgesOnCell(iCell),RKIND) + shear(iCell) = sqrt(strainTensionSum**2 + strainShearingSum**2) / real(nEdgesOnCell(iCell),RKIND) + DeltaAverage(iCell) = DeltaAverage(iCell) / real(nEdgesOnCell(iCell),RKIND) - divergence(iCell) = 0.0_RKIND - shear(iCell) = 0.0_RKIND + else - endif + divergence(iCell) = 0.0_RKIND + shear(iCell) = 0.0_RKIND - enddo ! iCell + endif - ! ridging parameters - call MPAS_pool_get_config(block % configs, "config_use_column_package", config_use_column_package) + enddo ! iCell - if (config_use_column_package) then + ! ridging parameters + call MPAS_pool_get_config(blockPtr % configs, "config_use_column_package", config_use_column_package) - call MPAS_pool_get_subpool(block % structs, "ridging", ridgingPool) + if (config_use_column_package) then - call MPAS_pool_get_array(ridgingPool, "ridgeConvergence", ridgeConvergence) - call MPAS_pool_get_array(ridgingPool, "ridgeShear", ridgeShear) + call MPAS_pool_get_subpool(blockPtr % structs, "ridging", ridgingPool) - do iCell = 1, nCells + call MPAS_pool_get_array(ridgingPool, "ridgeConvergence", ridgeConvergence) + call MPAS_pool_get_array(ridgingPool, "ridgeShear", ridgeShear) - if (solveStress(iCell) == 1) then + do iCell = 1, nCells - ridgeConvergence(iCell) = -min(divergence(iCell),0.0_RKIND) - ridgeShear(iCell) = 0.5_RKIND * (DeltaAverage(iCell) - abs(divergence(iCell))) + if (solveStress(iCell) == 1) then - else + ridgeConvergence(iCell) = -min(divergence(iCell),0.0_RKIND) + ridgeShear(iCell) = 0.5_RKIND * (DeltaAverage(iCell) - abs(divergence(iCell))) - ridgeConvergence(iCell) = 0.0_RKIND - ridgeShear(iCell) = 0.0_RKIND + else - endif + ridgeConvergence(iCell) = 0.0_RKIND + ridgeShear(iCell) = 0.0_RKIND - enddo ! iCell + endif + + enddo ! iCell + + endif ! config_use_column_package - endif ! config_use_column_package + ! units - for comparison to CICE + divergence = divergence * 100.0_RKIND * 86400.0_RKIND + shear = shear * 100.0_RKIND * 86400.0_RKIND - ! units - for comparison to CICE - divergence = divergence * 100.0_RKIND * 86400.0_RKIND - shear = shear * 100.0_RKIND * 86400.0_RKIND + ! cleanup + deallocate(DeltaAverage) - ! cleanup - deallocate(DeltaAverage) + blockPtr => blockPtr % next + enddo end subroutine seaice_final_divergence_shear_variational diff --git a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational_shared.F b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational_shared.F index 92165961caf2..442a6534c7ba 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational_shared.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_variational_shared.F @@ -21,15 +21,14 @@ module seaice_velocity_solver_variational_shared save public :: & - seaice_calc_local_coords, & seaice_calc_variational_metric_terms, & - seaice_wrapped_index + seaice_cell_vertices_at_vertex contains !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! -! seaice_calc_local_coords +! seaice_calc_variational_metric_terms ! !> \brief !> \author Adrian K. Turner, LANL @@ -39,350 +38,196 @@ module seaice_velocity_solver_variational_shared ! !----------------------------------------------------------------------- - subroutine seaice_calc_local_coords(& - xLocal, & - yLocal, & - nCells, & - nEdgesOnCell, & - verticesOnCell, & - xVertex, & - yVertex, & - zVertex, & - xCell, & - yCell, & - zCell, & - rotateCartesianGrid, & - onASphere)!{{{ - - real(kind=RKIND), dimension(:,:), intent(out) :: & - xLocal, & !< Output: - yLocal !< Output: - - integer, intent(in) :: & - nCells !< Input: - - integer, dimension(:), intent(in) :: & - nEdgesOnCell !< Input: - - integer, dimension(:,:), intent(in) :: & - verticesOnCell !< Input: - - real(kind=RKIND), dimension(:), intent(in) :: & - xVertex, & !< Input: - yVertex, & !< Input: - zVertex, & !< Input: - xCell, & !< Input: - yCell, & !< Input: - zCell !< Input: - - logical, intent(in) :: & - rotateCartesianGrid, & !< Input: - onASphere !< Input: - - if (onASphere) then - call calc_local_coords_spherical(& - xLocal, & - yLocal, & - nCells, & - nEdgesOnCell, & - verticesOnCell, & - xVertex, & - yVertex, & - zVertex, & - xCell, & - yCell, & - zCell, & - rotateCartesianGrid) - else - call calc_local_coords_planar(& - xLocal, & - yLocal, & - nCells, & - nEdgesOnCell, & - verticesOnCell, & - xVertex, & - yVertex, & - zVertex, & - xCell, & - yCell, & - zCell) - endif + subroutine seaice_calc_variational_metric_terms(domain) - end subroutine seaice_calc_local_coords!}}} + use seaice_mesh, only: & + seaice_grid_rotation_forward -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! calc_local_coords_planar -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- + type (domain_type), intent(inout) :: & + domain !< Input/Output: - subroutine calc_local_coords_planar(& - xLocal, & - yLocal, & - nCells, & - nEdgesOnCell, & - verticesOnCell, & - xVertex, & - yVertex, & - zVertex, & - xCell, & - yCell, & - zCell)!{{{ - - real(kind=RKIND), dimension(:,:), intent(out) :: & - xLocal, & !< Output: - yLocal !< Output: - - integer, intent(in) :: & - nCells !< Input: - - integer, dimension(:), intent(in) :: & - nEdgesOnCell !< Input: - - integer, dimension(:,:), intent(in) :: & - verticesOnCell !< Input: - - real(kind=RKIND), dimension(:), intent(in) :: & - xVertex, & !< Input: - yVertex, & !< Input: - zVertex, & !< Input: - xCell, & !< Input: - yCell, & !< Input: - zCell !< Input: + type(block_type), pointer :: & + blockPtr - integer :: & - iCell, & - iVertex, & - iVertexOnCell + type(MPAS_pool_type), pointer :: & + meshPool, & + velocityVariationalPool - do iCell = 1, nCells + real(kind=RKIND), dimension(:), pointer :: & + tanLatVertexRotatedOverRadius - do iVertexOnCell = 1, nEdgesOnCell(iCell) + integer, pointer :: & + nVertices - iVertex = verticesOnCell(iVertexOnCell, iCell) + real(kind=RKIND), dimension(:), pointer :: & + xVertex, & + yVertex, & + zVertex - xLocal(iVertexOnCell,iCell) = xVertex(iVertex) - xCell(iCell) - yLocal(iVertexOnCell,iCell) = yVertex(iVertex) - yCell(iCell) + real(kind=RKIND), pointer :: & + sphereRadius - enddo ! iVertexOnCell + logical, pointer :: & + config_rotate_cartesian_grid, & + config_include_metric_terms - enddo ! iCell + integer :: & + iVertex - end subroutine calc_local_coords_planar!}}} + real(kind=RKIND) :: & + xVertexRotated, & + yVertexRotated, & + zVertexRotated, & + latVertexRotated -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! calc_local_coords_spherical -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 22 October 2014 -!> \details -!> -! -!----------------------------------------------------------------------- + call MPAS_pool_get_config(domain % configs, "config_include_metric_terms", config_include_metric_terms) - subroutine calc_local_coords_spherical(& - xLocal, & - yLocal, & - nCells, & - nEdgesOnCell, & - verticesOnCell, & - xVertex, & - yVertex, & - zVertex, & - xCell, & - yCell, & - zCell, & - rotateCartesianGrid)!{{{ + if (config_include_metric_terms) then - use seaice_mesh, only: & - seaice_project_3D_vector_onto_local_2D, & - seaice_grid_rotation_forward + call MPAS_pool_get_config(domain % configs, "config_rotate_cartesian_grid", config_rotate_cartesian_grid) - real(kind=RKIND), dimension(:,:), intent(out) :: & - xLocal, & !< Output: - yLocal !< Output: + blockPtr => domain % blocklist + do while (associated(blockPtr)) - integer, intent(in) :: & - nCells !< Input: + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) - integer, dimension(:), intent(in) :: & - nEdgesOnCell !< Input: + call MPAS_pool_get_dimension(meshPool, "nVertices", nVertices) - integer, dimension(:,:), intent(in) :: & - verticesOnCell !< Input: + call MPAS_pool_get_config(meshPool, "sphere_radius", sphereRadius) - real(kind=RKIND), dimension(:), intent(in) :: & - xVertex, & !< Input: - yVertex, & !< Input: - zVertex, & !< Input: - xCell, & !< Input: - yCell, & !< Input: - zCell !< Input: + call MPAS_pool_get_array(meshPool, "xVertex", xVertex) + call MPAS_pool_get_array(meshPool, "yVertex", yVertex) + call MPAS_pool_get_array(meshPool, "zVertex", zVertex) - logical, intent(in) :: & - rotateCartesianGrid !< Input: + call MPAS_pool_get_array(velocityVariationalPool, "tanLatVertexRotatedOverRadius", tanLatVertexRotatedOverRadius) - real(kind=RKIND), dimension(3) :: & - normalVector3D + do iVertex = 1, nVertices - real(kind=RKIND), dimension(2) :: & - normalVector2D + call seaice_grid_rotation_forward(& + xVertexRotated, yVertexRotated, zVertexRotated, & + xVertex(iVertex), yVertex(iVertex), zVertex(iVertex), & + config_rotate_cartesian_grid) - integer :: & - iCell, & - iVertex, & - iVertexOnCell + latVertexRotated = asin(zVertexRotated / sphereRadius) - real(kind=RKIND) :: & - xCellRotated, & - yCellRotated, & - zCellRotated + tanLatVertexRotatedOverRadius(iVertex) = tan(latVertexRotated) / sphereRadius + + enddo ! iVertex - do iCell = 1, nCells + blockPtr => blockPtr % next + enddo - call seaice_grid_rotation_forward(& - xCellRotated, yCellRotated, zCellRotated, & - xCell(iCell), yCell(iCell), zCell(iCell), & - rotateCartesianGrid) + else - do iVertexOnCell = 1, nEdgesOnCell(iCell) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - iVertex = verticesOnCell(iVertexOnCell, iCell) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) - call seaice_grid_rotation_forward(& - normalVector3D(1), normalVector3D(2), normalVector3D(3), & - xVertex(iVertex), yVertex(iVertex), zVertex(iVertex), & - rotateCartesianGrid) + call MPAS_pool_get_array(velocityVariationalPool, "tanLatVertexRotatedOverRadius", tanLatVertexRotatedOverRadius) - call seaice_project_3D_vector_onto_local_2D(& - normalVector2D, & - normalVector3D, & - xCellRotated, & - yCellRotated, & - zCellRotated) + do iVertex = 1, nVertices - xLocal(iVertexOnCell,iCell) = normalVector2D(1) - yLocal(iVertexOnCell,iCell) = normalVector2D(2) + tanLatVertexRotatedOverRadius(iVertex) = 0.0_RKIND - enddo ! iVertexOnCell + enddo ! iVertex - enddo ! iCell + blockPtr => blockPtr % next + enddo - end subroutine calc_local_coords_spherical!}}} + endif + + end subroutine seaice_calc_variational_metric_terms !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! -! seaice_calc_variational_metric_terms +! seaice_cell_vertices_at_vertex ! !> \brief !> \author Adrian K. Turner, LANL -!> \date 22 October 2014 +!> \date 2013-2014 !> \details !> ! !----------------------------------------------------------------------- - subroutine seaice_calc_variational_metric_terms(& - tanLatVertexRotatedOverRadius, & - nVertices, & - xVertex, & - yVertex, & - zVertex, & - sphereRadius, & - rotateCartesianGrid, & - includeMetricTerms) + subroutine seaice_cell_vertices_at_vertex(domain)!{{{ - use seaice_mesh, only: & - seaice_grid_rotation_forward + type (domain_type), intent(inout) :: & + domain !< Input/Output: - real(kind=RKIND), dimension(:), intent(out) :: & - tanLatVertexRotatedOverRadius !< Output: + type(block_type), pointer :: & + blockPtr - integer, intent(in) :: & - nVertices !< Input: + type(MPAS_pool_type), pointer :: & + meshPool, & + velocityVariationalPool - real(kind=RKIND), dimension(:), pointer :: & - xVertex, & !< Input: - yVertex, & !< Input: - zVertex !< Input: + integer, dimension(:,:), pointer :: & + cellVerticesAtVertex - real(kind=RKIND), pointer :: & - sphereRadius !< Input: + integer, pointer :: & + nVertices, & + vertexDegree - logical, intent(in) :: & - rotateCartesianGrid, & !< Input: - includeMetricTerms !< Input: + integer, dimension(:), pointer :: & + nEdgesOnCell + + integer, dimension(:,:), pointer :: & + cellsOnVertex, & + verticesOnCell integer :: & - iVertex + iVertex, & + iVertexDegree, & + iCell, & + iVertexOnCell, & + jVertex - real(kind=RKIND) :: & - xVertexRotated, & - yVertexRotated, & - zVertexRotated, & - latVertexRotated + blockPtr => domain % blocklist + do while (associated(blockPtr)) - if (includeMetricTerms) then + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) - do iVertex = 1, nVertices + call MPAS_pool_get_dimension(meshPool, "nVertices", nVertices) + call MPAS_pool_get_dimension(meshPool, "vertexDegree", vertexDegree) - call seaice_grid_rotation_forward(& - xVertexRotated, yVertexRotated, zVertexRotated, & - xVertex(iVertex), yVertex(iVertex), zVertex(iVertex), & - rotateCartesianGrid) + call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) + call MPAS_pool_get_array(meshPool, "verticesOnCell", verticesOnCell) + call MPAS_pool_get_array(meshPool, "cellsOnVertex", cellsOnVertex) - latVertexRotated = asin(zVertexRotated / sphereRadius) + call MPAS_pool_get_array(velocityVariationalPool, "cellVerticesAtVertex", cellVerticesAtVertex) - tanLatVertexRotatedOverRadius(iVertex) = tan(latVertexRotated) / sphereRadius + do iVertex = 1, nVertices - enddo ! iVertex + do iVertexDegree = 1, vertexDegree - else + cellVerticesAtVertex(iVertexDegree,iVertex) = 0 - do iVertex = 1, nVertices + iCell = cellsOnVertex(iVertexDegree, iVertex) - tanLatVertexRotatedOverRadius(iVertex) = 0.0_RKIND + do iVertexOnCell = 1, nEdgesOnCell(iCell) - enddo ! iVertex + jVertex = verticesOnCell(iVertexOnCell,iCell) - endif + if (iVertex == jVertex) then - end subroutine seaice_calc_variational_metric_terms + cellVerticesAtVertex(iVertexDegree,iVertex) = iVertexOnCell -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! seaice_wrapped_index -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- + endif - function seaice_wrapped_index(& - input, & - nelements) & - result(output)!{{{ + enddo ! iVertexOnCell - integer, intent(in) :: & - input, & !< Input: - nelements !< Input: + enddo ! iVertexDegree - integer :: output + enddo ! iVertex - output = modulo(input - 1, nelements) + 1 + blockPtr => blockPtr % next + enddo - end function seaice_wrapped_index!}}} + end subroutine seaice_cell_vertices_at_vertex!}}} !----------------------------------------------------------------------- diff --git a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_wachspress.F b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_wachspress.F index 1e46eea0bda7..8fa9a4a3f719 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_wachspress.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_wachspress.F @@ -43,118 +43,190 @@ module seaice_velocity_solver_wachspress ! !----------------------------------------------------------------------- - subroutine seaice_init_velocity_solver_wachspress(& - nCells, & - maxEdges, & - nEdgesOnCell, & - xLocal, & - yLocal, & - rotateCartesianGrid, & - includeMetricTerms, & - onASphere, & - integrationType, & - integrationOrder, & - sphereRadius, & - basisGradientU, & - basisGradientV, & - basisIntegralsU, & - basisIntegralsV, & - basisIntegralsMetric)!{{{ + subroutine seaice_init_velocity_solver_wachspress(domain)!{{{ use mpas_timer - use seaice_velocity_solver_variational_shared, only: & + use seaice_mesh, only: & seaice_calc_local_coords - integer, intent(in) :: & - nCells, & !< Input: - maxEdges !< Input: + use seaice_wachspress_basis, only: & + seaice_calc_wachspress_coefficients - integer, dimension(:), intent(in) :: & - nEdgesOnCell !< Input: + type (domain_type), intent(inout) :: & + domain !< Input/Output: - real(kind=RKIND), dimension(:,:), intent(in) :: & - xLocal, & !< Input: - yLocal !< Input: + type(block_type), pointer :: & + blockPtr - logical, intent(in) :: & - rotateCartesianGrid, & !< Input: - includeMetricTerms, & !< Input: - onASphere !< Input: + type(MPAS_pool_type), pointer :: & + meshPool, & + velocityVariationalPool - character(len=strKIND), intent(in) :: & - integrationType !< Input: + integer, pointer :: & + nCells, & + maxEdges - integer, intent(in) :: & - integrationOrder !< Input: + integer, dimension(:), pointer :: & + nEdgesOnCell - real(kind=RKIND), intent(in) :: & - sphereRadius !< Input: + integer, dimension(:,:), pointer :: & + verticesOnCell - real(kind=RKIND), dimension(:,:,:), intent(out) :: & - basisGradientU, & !< Output: - basisGradientV, & !< Output: - basisIntegralsU, & !< Output: - basisIntegralsV, & !< Output: - basisIntegralsMetric !< Output: + real(kind=RKIND), dimension(:), pointer :: & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell real(kind=RKIND), dimension(:,:), allocatable :: & - wachspressA, & - wachspressB + xLocal, & + yLocal - real(kind=RKIND), dimension(:,:,:), allocatable :: & - wachspressKappa + logical, pointer :: & + config_rotate_cartesian_grid, & + config_include_metric_terms, & + on_a_sphere - call mpas_timer_start("Velocity solver Wachpress init") + character(len=strKIND), pointer :: & + config_wachspress_integration_type - allocate(wachspressKappa(maxEdges,maxEdges,nCells)) - allocate(wachspressA(maxEdges,nCells)) - allocate(wachspressB(maxEdges,nCells)) + integer, pointer :: & + config_wachspress_integration_order - call mpas_timer_start("wachpress calc_coefficients") - call calc_wachspress_coefficients(& - wachspressKappa, & - wachspressA, & - wachspressB, & - nCells, & - nEdgesOnCell, & - xLocal, & - yLocal) - call mpas_timer_stop("wachpress calc_coefficients") + real(kind=RKIND), pointer :: & + sphere_radius - call mpas_timer_start("wachpress calc_derivatives") - call calculate_wachspress_derivatives(& + real(kind=RKIND), dimension(:,:,:), pointer :: & basisGradientU, & basisGradientV, & - nCells, & - maxEdges, & - nEdgesOnCell, & - xLocal, & - yLocal, & - wachspressA, & - wachspressB, & - wachspressKappa) - call mpas_timer_stop("wachpress calc_derivatives") - - call mpas_timer_start("wachpress integrate") - call integrate_wachspress(& basisIntegralsU, & basisIntegralsV, & - basisIntegralsMetric, & - nCells, & - nEdgesOnCell, & - xLocal, & - yLocal, & + basisIntegralsMetric + + real(kind=RKIND), dimension(:,:), allocatable :: & wachspressA, & - wachspressB, & - wachspressKappa, & - integrationType, & - integrationOrder) - call mpas_timer_stop("wachpress integrate") + wachspressB + + real(kind=RKIND), dimension(:,:,:), allocatable :: & + wachspressKappa + + integer :: & + iCell, & + iStressVertex, & + iVelocityVertex, & + iSubCell, & + iVertex + + call mpas_timer_start("Velocity solver Wachpress init") - deallocate(wachspressKappa) - deallocate(wachspressA) - deallocate(wachspressB) + call MPAS_pool_get_config(domain % configs, "config_rotate_cartesian_grid", config_rotate_cartesian_grid) + call MPAS_pool_get_config(domain % configs, "config_include_metric_terms", config_include_metric_terms) + call MPAS_pool_get_config(domain % configs, "config_wachspress_integration_type", config_wachspress_integration_type) + call MPAS_pool_get_config(domain % configs, "config_wachspress_integration_order", config_wachspress_integration_order) + + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_variational", velocityVariationalPool) + + call MPAS_pool_get_config(meshPool, "on_a_sphere", on_a_sphere) + call MPAS_pool_get_config(meshPool, "sphere_radius", sphere_radius) + + call MPAS_pool_get_dimension(meshPool, "nCells", nCells) + call MPAS_pool_get_dimension(meshPool, "maxEdges", maxEdges) + + call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) + call MPAS_pool_get_array(meshPool, "verticesOnCell", verticesOnCell) + call MPAS_pool_get_array(meshPool, "xVertex", xVertex) + call MPAS_pool_get_array(meshPool, "yVertex", yVertex) + call MPAS_pool_get_array(meshPool, "zVertex", zVertex) + call MPAS_pool_get_array(meshPool, "xCell", xCell) + call MPAS_pool_get_array(meshPool, "yCell", yCell) + call MPAS_pool_get_array(meshPool, "zCell", zCell) + + call MPAS_pool_get_array(velocityVariationalPool, "basisGradientU", basisGradientU) + call MPAS_pool_get_array(velocityVariationalPool, "basisGradientV", basisGradientV) + call MPAS_pool_get_array(velocityVariationalPool, "basisIntegralsU", basisIntegralsU) + call MPAS_pool_get_array(velocityVariationalPool, "basisIntegralsV", basisIntegralsV) + call MPAS_pool_get_array(velocityVariationalPool, "basisIntegralsMetric", basisIntegralsMetric) + + call mpas_timer_start("variational calc_local_coords") + allocate(xLocal(maxEdges,nCells)) + allocate(yLocal(maxEdges,nCells)) + + call seaice_calc_local_coords(& + xLocal, & + yLocal, & + nCells, & + nEdgesOnCell, & + verticesOnCell, & + xVertex, & + yVertex, & + zVertex, & + xCell, & + yCell, & + zCell, & + config_rotate_cartesian_grid, & + on_a_sphere) + call mpas_timer_stop("variational calc_local_coords") + + allocate(wachspressKappa(maxEdges,maxEdges,nCells)) + allocate(wachspressA(maxEdges,nCells)) + allocate(wachspressB(maxEdges,nCells)) + + call mpas_timer_start("wachpress calc_coefficients") + call seaice_calc_wachspress_coefficients(& + wachspressKappa, & + wachspressA, & + wachspressB, & + nCells, & + nEdgesOnCell, & + xLocal, & + yLocal) + call mpas_timer_stop("wachpress calc_coefficients") + + call mpas_timer_start("wachpress calc_derivatives") + call calculate_wachspress_derivatives(& + basisGradientU, & + basisGradientV, & + nCells, & + maxEdges, & + nEdgesOnCell, & + xLocal, & + yLocal, & + wachspressA, & + wachspressB, & + wachspressKappa) + call mpas_timer_stop("wachpress calc_derivatives") + + call mpas_timer_start("wachpress integrate") + call integrate_wachspress(& + basisIntegralsU, & + basisIntegralsV, & + basisIntegralsMetric, & + nCells, & + nEdgesOnCell, & + xLocal, & + yLocal, & + wachspressA, & + wachspressB, & + wachspressKappa, & + config_wachspress_integration_type, & + config_wachspress_integration_order) + call mpas_timer_stop("wachpress integrate") + + deallocate(wachspressKappa) + deallocate(wachspressA) + deallocate(wachspressB) + deallocate(xLocal) + deallocate(yLocal) + + blockPtr => blockPtr % next + enddo call mpas_timer_stop("Velocity solver Wachpress init") @@ -190,6 +262,9 @@ subroutine integrate_wachspress(& integrationType, & integrationOrder)!{{{ + use seaice_triangle_quadrature, only: & + seaice_triangle_quadrature_rules + ! basisIntegralsUV (iStressVertex,iVelocityVertex,iCell) ! iCell : cell integrals are performed on ! iStressVertex : vertex number of Wachspress function @@ -239,7 +314,7 @@ subroutine integrate_wachspress(& normalizationFactor ! Quadrature rules - call get_integration_factors(& + call seaice_triangle_quadrature_rules(& integrationType, & integrationOrder, & nIntegrationPoints, & @@ -319,9 +394,14 @@ subroutine integrate_wachspress_polygon(& integrationWeights, & normalizationFactor)!{{{ - use seaice_velocity_solver_variational_shared, only: & + use seaice_mesh, only: & seaice_wrapped_index + use seaice_wachspress_basis, only: & + seaice_wachspress_indexes, & + seaice_wachspress_basis_function, & + seaice_wachspress_basis_derivative + real(kind=RKIND), intent(inout) :: & basisIntegralsU, & !< Input/Output: basisIntegralsV, & !< Input/Output: @@ -386,7 +466,7 @@ subroutine integrate_wachspress_polygon(& i1, & i2 - call wachspress_indexes(& + call seaice_wachspress_indexes(& nEdgesOnCell, & nEdgesOnCellSubset, & vertexIndexSubset) @@ -414,19 +494,19 @@ subroutine integrate_wachspress_polygon(& enddo ! iIntegrationPoint - call wachspress_basis_function(& + call seaice_wachspress_basis_function(& nEdgesOnCell, iStressVertex, x, y, & wachspressKappa, wachspressA, wachspressB, & nEdgesOnCellSubset, vertexIndexSubset, & stressBasisFunction) - call wachspress_basis_function(& + call seaice_wachspress_basis_function(& nEdgesOnCell, iVelocityVertex, x, y, & wachspressKappa, wachspressA, wachspressB, & nEdgesOnCellSubset, vertexIndexSubset, & velocityBasisFunction) - call wachspress_basis_derivative(& + call seaice_wachspress_basis_derivative(& nEdgesOnCell, iVelocityVertex, x, y, & wachspressKappa, wachspressA, wachspressB, & nEdgesOnCellSubset, vertexIndexSubset, & @@ -517,12 +597,12 @@ subroutine get_triangle_mapping(& end subroutine get_triangle_mapping!}}} !----------------------------------------------------------------------- -! Wachspress function +! Wachspress derivatives !----------------------------------------------------------------------- !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! -! calc_wachspress_coefficients +! calculate_wachspress_derivatives ! !> \brief !> \author Adrian K. Turner, LANL @@ -532,1414 +612,135 @@ end subroutine get_triangle_mapping!}}} ! !----------------------------------------------------------------------- - subroutine calc_wachspress_coefficients(& - wachspressKappa, & - wachspressA, & - wachspressB, & + subroutine calculate_wachspress_derivatives(& + basisGradientU, & + basisGradientV, & nCells, & + maxEdges, & nEdgesOnCell, & xLocal, & - yLocal)!{{{ - - real(kind=RKIND), dimension(:,:,:), intent(out) :: & - wachspressKappa !< Output: - - real(kind=RKIND), dimension(:,:), intent(out) :: & - wachspressA, & !< Output: - wachspressB !< Output: - - integer, intent(in) :: & - nCells !< Input: - - integer, dimension(:), intent(in) :: & - nEdgesOnCell !< Input: - - real(kind=RKIND), dimension(:,:), intent(in) :: & - xLocal, & !< Input: - yLocal !< Input: - - integer :: & - iCell, & - iVertex, & - i0, & - i1, & - i2, & - jVertex - - ! loop over cells - do iCell = 1, nCells - - ! loop over vertices - do iVertex = 1, nEdgesOnCell(iCell) - - ! end points of line segment - i1 = iVertex - 1 - i2 = iVertex - if (i1 < 1) i1 = i1 + nEdgesOnCell(iCell) - - ! solve for the line segment equation - wachspressA(iVertex, iCell) = & - (yLocal(i2,iCell) - yLocal(i1,iCell)) / (xLocal(i1,iCell) * yLocal(i2,iCell) - xLocal(i2,iCell) * yLocal(i1,iCell)) - wachspressB(iVertex, iCell) = & - (xLocal(i1,iCell) - xLocal(i2,iCell)) / (xLocal(i1,iCell) * yLocal(i2,iCell) - xLocal(i2,iCell) * yLocal(i1,iCell)) - - enddo ! iVertex - - ! loop over vertices - do iVertex = 1, nEdgesOnCell(iCell) - - ! determine kappa - wachspressKappa(1,iVertex,iCell) = 1.0_RKIND - - do jVertex = 2, nEdgesOnCell(iCell) - - ! previous, this and next vertex - i0 = jVertex - 1 - i1 = jVertex - i2 = jVertex + 1 - if (i2 > nEdgesOnCell(iCell)) i2 = i2 - nEdgesOnCell(iCell) - - wachspressKappa(jVertex,iVertex,iCell) = wachspressKappa(jVertex-1,iVertex,iCell) * & - (wachspressA(i2,iCell) * (xLocal(i0,iCell) - xLocal(i1,iCell)) + & - wachspressB(i2,iCell) * (yLocal(i0,iCell) - yLocal(i1,iCell))) / & - (wachspressA(i0,iCell) * (xLocal(i1,iCell) - xLocal(i0,iCell)) + & - wachspressB(i0,iCell) * (yLocal(i1,iCell) - yLocal(i0,iCell))) - - enddo ! jVertex - - enddo ! iVertex - - enddo ! iCell - - end subroutine calc_wachspress_coefficients!}}} - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! wachspress_indexes -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine wachspress_indexes(& - nEdgesOnCell, & - nEdgesOnCellSubset, & - vertexIndexSubset) + yLocal, & + wachspressA, & + wachspressB, & + wachspressKappa)!{{{ - use seaice_velocity_solver_variational_shared, only: & + use seaice_mesh, only: & seaice_wrapped_index - integer, intent(in) :: & - nEdgesOnCell !< Input: - - integer, dimension(:), intent(out) :: & - nEdgesOnCellSubset !< Output: - - integer, dimension(:,:), intent(out) :: & - vertexIndexSubset !< Output: - - integer :: & - jVertex, & - kVertex, & - i1, i2 - - do jVertex = 1, nEdgesOnCell - - i1 = jVertex - i2 = seaice_wrapped_index(jVertex + 1, nEdgesOnCell) - - nEdgesOnCellSubset(jVertex) = 0 - - do kVertex = 1, nEdgesOnCell - - if (kVertex /= i1 .and. kVertex /= i2) then - nEdgesOnCellSubset(jVertex) = nEdgesOnCellSubset(jVertex) + 1 - vertexIndexSubset(jVertex,nEdgesOnCellSubset(jVertex)) = kVertex - endif - - enddo ! kVertex - - enddo ! jVertex - - end subroutine wachspress_indexes - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! wachspress_basis_function -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- + use seaice_wachspress_basis, only: & + seaice_wachspress_indexes, & + seaice_wachspress_basis_derivative - subroutine wachspress_basis_function(& - nEdgesOnCell, & - iVertex, & - x, & - y, & - wachspressKappa, & - wachspressA, & - wachspressB, & - nEdgesOnCellSubset, & - vertexIndexSubset, & - wachpress)!{{{ + ! basisGradientUV(jVertexOnCell,iVertexOnCell,iCell) + ! iCell : The cell the gradients are based in + ! iVertexOnCell : The vertex basis function the gradient is calculated from + ! jVertexOnCell : The vertex location the gradients are calculated at - use seaice_velocity_solver_variational_shared, only: & - seaice_wrapped_index + real(kind=RKIND), dimension(:,:,:), intent(out) :: & + basisGradientU, & !< Output: + basisGradientV !< Output: integer, intent(in) :: & - nEdgesOnCell, & !< Input: - iVertex !< Input: + nCells, & !< Input: + maxEdges !< Input: - real(kind=RKIND), dimension(:), intent(in) :: & - x, & !< Input: - y !< Input: + integer, dimension(:), intent(in) :: & + nEdgesOnCell !< Input: real(kind=RKIND), dimension(:,:), intent(in) :: & - wachspressKappa !< Input: - - real(kind=RKIND), dimension(:), intent(in) :: & wachspressA, & !< Input: - wachspressB !< Input: + wachspressB, & !< Input: + xLocal, & !< Input: + yLocal !< Input: - integer, dimension(:), intent(in) :: & - nEdgesOnCellSubset !< Input: + real(kind=RKIND), dimension(:,:,:), intent(in) :: & + wachspressKappa !< Input: - integer, dimension(:,:), intent(in) :: & - vertexIndexSubset !< Input: + integer :: & + iCell, & + iBasisVertex, & + iGradientVertex - real(kind=RKIND), dimension(:), intent(out) :: & - wachpress !< Output: + integer, dimension(:), allocatable :: & + nEdgesOnCellSubset - real(kind=RKIND), dimension(size(x),nEdgesOnCell) :: & - numerator + integer, dimension(:,:), allocatable :: & + vertexIndexSubset - real(kind=RKIND), dimension(size(x)) :: & - denominator, & - edgeEquation + real(kind=RKIND), dimension(:), allocatable :: & + x, y, derivativeU, derivativeV - integer :: & - jVertex + allocate(x(maxEdges)) + allocate(y(maxEdges)) - ! sum over numerators to get denominator - denominator(:) = 0.0_RKIND + allocate(derivativeU(maxEdges)) + allocate(derivativeV(maxEdges)) - do jVertex = 1, nEdgesOnCell + allocate(nEdgesOnCellSubset(maxEdges)) + allocate(vertexIndexSubset(maxEdges,maxEdges)) - call wachspress_numerator(& - nEdgesOnCell, jVertex, iVertex, x(:), y(:), & - wachspressKappa, wachspressA, wachspressB, & - nEdgesOnCellSubset, vertexIndexSubset, & - edgeEquation(:), & - numerator(:,jVertex)) + ! loop over cells + do iCell = 1, nCells - denominator(:) = denominator(:) + numerator(:,jVertex) + call seaice_wachspress_indexes(& + nEdgesOnCell(iCell), & + nEdgesOnCellSubset(1:nEdgesOnCell(iCell)), & + vertexIndexSubset(1:nEdgesOnCell(iCell),1:nEdgesOnCell(iCell))) - enddo ! jVertex + ! loop over vertices again - derivative position + do iGradientVertex = 1, nEdgesOnCell(iCell) - wachpress(:) = numerator(:,iVertex) / denominator(:) + x(iGradientVertex) = xLocal(iGradientVertex,iCell) + y(iGradientVertex) = yLocal(iGradientVertex,iCell) - end subroutine wachspress_basis_function!}}} + enddo ! iGradientVertex -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! wachspress_basis_derivative -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- + ! loop over vertices - basis function + do iBasisVertex = 1, nEdgesOnCell(iCell) - subroutine wachspress_basis_derivative(& - nEdgesOnCell, & - iVertex, & - x, & - y, & - wachspressKappa, & - wachspressA, & - wachspressB, & - nEdgesOnCellSubset, & - vertexIndexSubset, & - wachspressU, & - wachspressV)!{{{ + call seaice_wachspress_basis_derivative(& + nEdgesOnCell(iCell), & + iBasisVertex, & + x(1:nEdgesOnCell(iCell)), & + y(1:nEdgesOnCell(iCell)), & + wachspressKappa(:,:,iCell), & + wachspressA(:,iCell), & + wachspressB(:,iCell), & + nEdgesOnCellSubset(1:nEdgesOnCell(iCell)), & + vertexIndexSubset(1:nEdgesOnCell(iCell),1:nEdgesOnCell(iCell)), & + derivativeU(1:nEdgesOnCell(iCell)), & + derivativeV(1:nEdgesOnCell(iCell))) - integer, intent(in) :: & - nEdgesOnCell, & !< Input: - iVertex !< Input: + basisGradientU(iBasisVertex,:,iCell) = 0.0_RKIND + basisGradientV(iBasisVertex,:,iCell) = 0.0_RKIND - real(kind=RKIND), dimension(:), intent(in) :: & - x, & !< Input: - y !< Input: + iGradientVertex = iBasisVertex + basisGradientU(iBasisVertex,iGradientVertex,iCell) = derivativeU(iGradientVertex) + basisGradientV(iBasisVertex,iGradientVertex,iCell) = derivativeV(iGradientVertex) - real(kind=RKIND), dimension(:,:), intent(in) :: & - wachspressKappa !< Input: + iGradientVertex = seaice_wrapped_index(iBasisVertex - 1, nEdgesOnCell(iCell)) + basisGradientU(iBasisVertex,iGradientVertex,iCell) = derivativeU(iGradientVertex) + basisGradientV(iBasisVertex,iGradientVertex,iCell) = derivativeV(iGradientVertex) - real(kind=RKIND), dimension(:), intent(in) :: & - wachspressA, & !< Input: - wachspressB !< Input: + iGradientVertex = seaice_wrapped_index(iBasisVertex + 1, nEdgesOnCell(iCell)) + basisGradientU(iBasisVertex,iGradientVertex,iCell) = derivativeU(iGradientVertex) + basisGradientV(iBasisVertex,iGradientVertex,iCell) = derivativeV(iGradientVertex) - integer, dimension(:), intent(in) :: & - nEdgesOnCellSubset !< Input: + enddo ! iBasisVertex - integer, dimension(:,:), intent(in) :: & - vertexIndexSubset !< Input: + enddo ! iCell - real(kind=RKIND), dimension(:), intent(out) :: & - wachspressU, & !< Output: - wachspressV !< Output: + deallocate(nEdgesOnCellSubset) + deallocate(vertexIndexSubset) - real(kind=RKIND), dimension(size(x),2,nEdgesOnCell) :: & - derivative + deallocate(x) + deallocate(y) - real(kind=RKIND), dimension(size(x),nEdgesOnCell) :: & - numerator - - real(kind=RKIND), dimension(size(x),2) :: & - sum_of_derivatives, & - sum_of_products, & - product - - real(kind=RKIND), dimension(size(x)) :: & - denominator, & - edgeEquation - - integer :: & - jVertex - - ! sum over numerators to get denominator - denominator(:) = 0.0_RKIND - sum_of_derivatives(:,:) = 0.0_RKIND - - do jVertex = 1, nEdgesOnCell - - call wachspress_numerator(& - nEdgesOnCell, jVertex, iVertex, x(:), y(:), & - wachspressKappa, wachspressA, wachspressB, & - nEdgesOnCellSubset, vertexIndexSubset, & - edgeEquation, & - numerator(:,jVertex)) - - denominator(:) = denominator(:) + numerator(:,jVertex) - - call wachspress_numerator_derivative(& - nEdgesOnCell, jVertex, iVertex, x(:), y(:), & - wachspressKappa, wachspressA, wachspressB, & - nEdgesOnCellSubset, vertexIndexSubset, & - sum_of_products, product, edgeEquation, & - derivative(:,:,jVertex)) - - sum_of_derivatives(:,:) = sum_of_derivatives(:,:) + derivative(:,:,jVertex) - - enddo ! jVertex - - wachspressU(:) = derivative(:,1,iVertex) / denominator(:) - & - (numerator(:,iVertex) / denominator(:)**2) * sum_of_derivatives(:,1) - wachspressV(:) = derivative(:,2,iVertex) / denominator(:) - & - (numerator(:,iVertex) / denominator(:)**2) * sum_of_derivatives(:,2) - - end subroutine wachspress_basis_derivative!}}} - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! wachspress_numerator -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine wachspress_numerator(& - nEdgesOnCell, & - jVertex, & - iVertex, & - x, & - y, & - wachspressKappa, & - wachspressA, & - wachspressB, & - nEdgesOnCellSubset, & - vertexIndexSubset, & - edgeEquation, & - numerator)!{{{ - - integer, intent(in) :: & - nEdgesOnCell, & !< Input: - jVertex, & !< Input: - iVertex !< Input: - - real(kind=RKIND), dimension(:), intent(in) :: & - x, & !< Input: - y !< Input: - - real(kind=RKIND), dimension(:,:), intent(in) :: & - wachspressKappa !< Input: - - real(kind=RKIND), dimension(:), intent(in) :: & - wachspressA, & !< Input: - wachspressB !< Input: - - integer, dimension(:), intent(in) :: & - nEdgesOnCellSubset !< Input: - - integer, dimension(:,:), intent(in) :: & - vertexIndexSubset !< Input: - - real(kind=RKIND), dimension(:), intent(inout) :: & - edgeEquation - - real(kind=RKIND), dimension(:), intent(out) :: & - numerator !< Output: - - integer :: & - kVertex - - numerator(:) = 1.0_RKIND - - do kVertex = 1, nEdgesOnCellSubset(jVertex) - - call wachspress_edge_equation(& - x(:), y(:), & - wachspressA(vertexIndexSubset(jVertex,kVertex)), & - wachspressB(vertexIndexSubset(jVertex,kVertex)), & - edgeEquation(:)) - - numerator(:) = numerator(:) * edgeEquation(:) - - enddo ! jVertex - - numerator(:) = numerator(:) * wachspressKappa(jVertex,iVertex) - - end subroutine wachspress_numerator!}}} - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! wachspress_numerator_derivative -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine wachspress_numerator_derivative(& - nEdgesOnCell, & - jVertex, & - iVertex, & - x, & - y, & - wachspressKappa, & - wachspressA, & - wachspressB, & - nEdgesOnCellSubset, & - vertexIndexSubset, & - sum_of_products, & - product, & - edgeEquation, & - derivative)!{{{ - - integer, intent(in) :: & - nEdgesOnCell, & !< Input: - jVertex, & !< Input: - iVertex !< Input: - - real(kind=RKIND), dimension(:), intent(in) :: & - x, & !< Input: - y !< Input: - - real(kind=RKIND), dimension(:,:), intent(in) :: & - wachspressKappa !< Input: - - real(kind=RKIND), dimension(:), intent(in) :: & - wachspressA, & !< Input: - wachspressB !< Input: - - integer, dimension(:), intent(in) :: & - nEdgesOnCellSubset !< Input: - - integer, dimension(:,:), intent(in) :: & - vertexIndexSubset !< Input: - - real(kind=RKIND), dimension(:,:), intent(out) :: & - derivative !< Output: - - real(kind=RKIND), dimension(:,:), intent(inout) :: & - sum_of_products, & !< Input/Output: - product !< Input/Output: - - real(kind=RKIND), dimension(:), intent(inout) :: & - edgeEquation !< Input/Output: - - integer :: & - kVertex, & - lVertex - - sum_of_products(:,:) = 0.0_RKIND - - do kVertex = 1, nEdgesOnCellSubset(jVertex) - - product(:,:) = 1.0_RKIND - - ! lVertex < kVertex - do lVertex = 1, kVertex - 1 - - call wachspress_edge_equation(& - x(:), y(:), & - wachspressA(vertexIndexSubset(jVertex,lVertex)), & - wachspressB(vertexIndexSubset(jVertex,lVertex)), & - edgeEquation(:)) - - product(:,1) = product(:,1) * edgeEquation(:) - product(:,2) = product(:,2) * edgeEquation(:) - - enddo ! lVertex - - ! lVertex == kVertex - product(:,1) = product(:,1) * (-wachspressA(vertexIndexSubset(jVertex,kVertex))) - product(:,2) = product(:,2) * (-wachspressB(vertexIndexSubset(jVertex,kVertex))) - - ! lVertex > kVertex - do lVertex = kVertex + 1, nEdgesOnCellSubset(jVertex) - - call wachspress_edge_equation(& - x(:), y(:), & - wachspressA(vertexIndexSubset(jVertex,lVertex)), & - wachspressB(vertexIndexSubset(jVertex,lVertex)), & - edgeEquation(:)) - - product(:,1) = product(:,1) * edgeEquation(:) - product(:,2) = product(:,2) * edgeEquation(:) - - enddo ! lVertex - - sum_of_products(:,:) = sum_of_products(:,:) + product(:,:) - - enddo ! jVertex - - derivative(:,:) = sum_of_products(:,:) * wachspressKappa(jVertex,iVertex) - - end subroutine wachspress_numerator_derivative!}}} - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! wachspress_edge_equation -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine wachspress_edge_equation(& - x, & - y, & - wachspressA, & - wachspressB, & - edgeEquation) - - real(kind=RKIND), dimension(:), intent(in) :: & - x, & !< Input: - y !< Input: - - real(kind=RKIND), intent(in) :: & - wachspressA, & !< Input: - wachspressB !< Input: - - real(kind=RKIND), dimension(:), intent(out) :: & - edgeEquation !< Output: - - edgeEquation(:) = 1.0_RKIND - wachspressA * x(:) - wachspressB * y(:) - - end subroutine wachspress_edge_equation!}}} - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! calculate_wachspress_derivatives -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 2013-2014 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine calculate_wachspress_derivatives(& - basisGradientU, & - basisGradientV, & - nCells, & - maxEdges, & - nEdgesOnCell, & - xLocal, & - yLocal, & - wachspressA, & - wachspressB, & - wachspressKappa)!{{{ - - use seaice_velocity_solver_variational_shared, only: & - seaice_wrapped_index - - ! basisGradientUV(jVertexOnCell,iVertexOnCell,iCell) - ! iCell : The cell the gradients are based in - ! iVertexOnCell : The vertex basis function the gradient is calculated from - ! jVertexOnCell : The vertex location the gradients are calculated at - - real(kind=RKIND), dimension(:,:,:), intent(out) :: & - basisGradientU, & !< Output: - basisGradientV !< Output: - - integer, intent(in) :: & - nCells, & !< Input: - maxEdges !< Input: - - integer, dimension(:), intent(in) :: & - nEdgesOnCell !< Input: - - real(kind=RKIND), dimension(:,:), intent(in) :: & - wachspressA, & !< Input: - wachspressB, & !< Input: - xLocal, & !< Input: - yLocal !< Input: - - real(kind=RKIND), dimension(:,:,:), intent(in) :: & - wachspressKappa !< Input: - - integer :: & - iCell, & - iBasisVertex, & - iGradientVertex - - integer, dimension(:), allocatable :: & - nEdgesOnCellSubset - - integer, dimension(:,:), allocatable :: & - vertexIndexSubset - - real(kind=RKIND), dimension(:), allocatable :: & - x, y, derivativeU, derivativeV - - allocate(x(maxEdges)) - allocate(y(maxEdges)) - - allocate(derivativeU(maxEdges)) - allocate(derivativeV(maxEdges)) - - allocate(nEdgesOnCellSubset(maxEdges)) - allocate(vertexIndexSubset(maxEdges,maxEdges)) - - ! loop over cells - do iCell = 1, nCells - - call wachspress_indexes(& - nEdgesOnCell(iCell), & - nEdgesOnCellSubset(1:nEdgesOnCell(iCell)), & - vertexIndexSubset(1:nEdgesOnCell(iCell),1:nEdgesOnCell(iCell))) - - ! loop over vertices again - derivative position - do iGradientVertex = 1, nEdgesOnCell(iCell) - - x(iGradientVertex) = xLocal(iGradientVertex,iCell) - y(iGradientVertex) = yLocal(iGradientVertex,iCell) - - enddo ! iGradientVertex - - ! loop over vertices - basis function - do iBasisVertex = 1, nEdgesOnCell(iCell) - - call wachspress_basis_derivative(& - nEdgesOnCell(iCell), & - iBasisVertex, & - x(1:nEdgesOnCell(iCell)), & - y(1:nEdgesOnCell(iCell)), & - wachspressKappa(:,:,iCell), & - wachspressA(:,iCell), & - wachspressB(:,iCell), & - nEdgesOnCellSubset(1:nEdgesOnCell(iCell)), & - vertexIndexSubset(1:nEdgesOnCell(iCell),1:nEdgesOnCell(iCell)), & - derivativeU(1:nEdgesOnCell(iCell)), & - derivativeV(1:nEdgesOnCell(iCell))) - - basisGradientU(iBasisVertex,:,iCell) = 0.0_RKIND - basisGradientV(iBasisVertex,:,iCell) = 0.0_RKIND - - iGradientVertex = iBasisVertex - basisGradientU(iBasisVertex,iGradientVertex,iCell) = derivativeU(iGradientVertex) - basisGradientV(iBasisVertex,iGradientVertex,iCell) = derivativeV(iGradientVertex) - - iGradientVertex = seaice_wrapped_index(iBasisVertex - 1, nEdgesOnCell(iCell)) - basisGradientU(iBasisVertex,iGradientVertex,iCell) = derivativeU(iGradientVertex) - basisGradientV(iBasisVertex,iGradientVertex,iCell) = derivativeV(iGradientVertex) - - iGradientVertex = seaice_wrapped_index(iBasisVertex + 1, nEdgesOnCell(iCell)) - basisGradientU(iBasisVertex,iGradientVertex,iCell) = derivativeU(iGradientVertex) - basisGradientV(iBasisVertex,iGradientVertex,iCell) = derivativeV(iGradientVertex) - - enddo ! iBasisVertex - - enddo ! iCell - - deallocate(nEdgesOnCellSubset) - deallocate(vertexIndexSubset) - - deallocate(x) - deallocate(y) - - deallocate(derivativeU) - deallocate(derivativeV) + deallocate(derivativeU) + deallocate(derivativeV) end subroutine calculate_wachspress_derivatives!}}} -!----------------------------------------------------------------------- -! Integration factors -!----------------------------------------------------------------------- - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! get_integration_factors -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 18th October 2016 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine get_integration_factors(& - integrationType, & - integrationOrder, & - nIntegrationPoints, & - u, & - v, & - weights, & - normalizationFactor) - - character(len=strKIND), intent(in) :: & - integrationType - - integer, intent(in) :: & - integrationOrder - - integer, intent(out) :: & - nIntegrationPoints - - real(kind=RKIND), dimension(:), allocatable, intent(out) :: & - u, & - v, & - weights - - real(kind=RKIND), intent(out) :: & - normalizationFactor - - if (trim(integrationType) == "trapezoidal") then - - call get_integration_factors_trapezoidal(& - integrationOrder, & - nIntegrationPoints, & - u, & - v, & - weights, & - normalizationFactor) - - else if (trim(integrationType) == "dunavant") then - - call get_integration_factors_dunavant(& - integrationOrder, & - nIntegrationPoints, & - u, & - v, & - weights, & - normalizationFactor) - - else if (trim(integrationType) == "fekete") then - - call get_integration_factors_fekete(& - integrationOrder, & - nIntegrationPoints, & - u, & - v, & - weights, & - normalizationFactor) - - else - - ! unknown integration type - call mpas_log_write("get_integration_factors: Unknown wachspress integration type: "//trim(integrationType), MPAS_LOG_CRIT) - - endif - - end subroutine get_integration_factors - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! get_integration_factors_trapezoidal -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 18th October 2016 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine get_integration_factors_trapezoidal(& - integrationOrder, & - nIntegrationPoints, & - u, & - v, & - weights, & - normalizationFactor) - - integer, intent(in) :: & - integrationOrder - - integer, intent(out) :: & - nIntegrationPoints - - real(kind=RKIND), dimension(:), allocatable, intent(out) :: & - u, & - v, & - weights - - real(kind=RKIND), intent(out) :: & - normalizationFactor - - integer :: & - nIntegrationTriangles - - integer :: & - i, j, ij - - nIntegrationTriangles = integrationOrder - - ! total number of integration points in sub triangle - nIntegrationPoints = ((nIntegrationTriangles+1)**2 + (nIntegrationTriangles+1)) / 2 - - ! allocate integration factors - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - ! get integration point canonical location - ij = 1 - do i = 0, nIntegrationTriangles - do j = 0, nIntegrationTriangles-i - - u(ij) = real(i,RKIND) / real(nIntegrationTriangles,RKIND) - v(ij) = real(j,RKIND) / real(nIntegrationTriangles,RKIND) - - ij = ij + 1 - - enddo ! j - enddo ! i - - ! get the weights - ij = 1 - do i = 0, nIntegrationTriangles - do j = 0, nIntegrationTriangles-i - - weights(ij) = 0.0_RKIND - - if (i<=nIntegrationTriangles-j) then - - if (i==nIntegrationTriangles .or. j==nIntegrationTriangles .or. (i==0 .and. j==0)) then - - weights(ij) = 1.0_RKIND - - else if ((j==0 .and. i/=0 .and. i/=nIntegrationTriangles) .or. & - (i==0 .and. j/=0 .and. j/=nIntegrationTriangles) .or. & - (i==nIntegrationTriangles-j .and. i/=0 .and. j/=0)) then - - weights(ij) = 3.0_RKIND - - else - - weights(ij) = 6.0_RKIND - - endif - - endif - - ij = ij + 1 - - enddo ! j - enddo ! i - - ! normalization factor - normalizationFactor = 6.0_RKIND * real(nIntegrationTriangles,RKIND)**2 - - end subroutine get_integration_factors_trapezoidal - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! get_integration_factors -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 18th October 2016 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine get_integration_factors_dunavant(& - integrationOrder, & - nIntegrationPoints, & - u, & - v, & - weights, & - normalizationFactor) - - integer, intent(in) :: & - integrationOrder - - integer, intent(out) :: & - nIntegrationPoints - - real(kind=RKIND), dimension(:), allocatable, intent(out) :: & - u, & - v, & - weights - - real(kind=RKIND), intent(out) :: & - normalizationFactor - - ! D. A. Dunavant, High degree efficient symmetrical Gaussian quadrature rules for the triangle, - ! Int. J. Num. Meth. Engng, 21(1985):1129-1148. - - normalizationFactor = 2.0_RKIND - - if (modulo(integrationOrder,2) /= 0) then - call mpas_log_write("get_integration_factors_dunavant: odd orders of integration not recommended", MPAS_LOG_WARN) - endif - - select case (integrationOrder) - case(1) - - nIntegrationPoints = 1 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.33333333333333_RKIND /) - - v = (/ & - 0.33333333333333_RKIND /) - - weights = (/ & - 1.00000000000000_RKIND /) - - case (2) - - nIntegrationPoints = 3 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.16666666666667_RKIND, 0.16666666666667_RKIND, 0.66666666666667_RKIND /) - - v = (/ & - 0.16666666666667_RKIND, 0.66666666666667_RKIND, 0.16666666666667_RKIND /) - - weights = (/ & - 0.33333333333333_RKIND, 0.33333333333333_RKIND, 0.33333333333333_RKIND /) - - case (3) - - nIntegrationPoints = 4 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.33333333333333_RKIND, 0.20000000000000_RKIND, 0.20000000000000_RKIND, 0.60000000000000_RKIND /) - - v = (/ & - 0.33333333333333_RKIND, 0.20000000000000_RKIND, 0.60000000000000_RKIND, 0.20000000000000_RKIND /) - - weights = (/ & - -0.56250000000000_RKIND, 0.52083333333333_RKIND, 0.52083333333333_RKIND, 0.52083333333333_RKIND /) - - case (4) - - nIntegrationPoints = 6 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.44594849091597_RKIND, 0.44594849091597_RKIND, 0.10810301816807_RKIND, 0.09157621350977_RKIND, & - 0.09157621350977_RKIND, 0.81684757298046_RKIND /) - - v = (/ & - 0.44594849091597_RKIND, 0.10810301816807_RKIND, 0.44594849091597_RKIND, 0.09157621350977_RKIND, & - 0.81684757298046_RKIND, 0.09157621350977_RKIND /) - - weights = (/ & - 0.22338158967801_RKIND, 0.22338158967801_RKIND, 0.22338158967801_RKIND, 0.10995174365532_RKIND, & - 0.10995174365532_RKIND, 0.10995174365532_RKIND /) - - case (5) - - nIntegrationPoints = 7 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.33333333333333_RKIND, 0.47014206410511_RKIND, 0.47014206410511_RKIND, 0.05971587178977_RKIND, & - 0.10128650732346_RKIND, 0.10128650732346_RKIND, 0.79742698535309_RKIND /) - - v = (/ & - 0.33333333333333_RKIND, 0.47014206410511_RKIND, 0.05971587178977_RKIND, 0.47014206410511_RKIND, & - 0.10128650732346_RKIND, 0.79742698535309_RKIND, 0.10128650732346_RKIND /) - - weights = (/ & - 0.22500000000000_RKIND, 0.13239415278851_RKIND, 0.13239415278851_RKIND, 0.13239415278851_RKIND, & - 0.12593918054483_RKIND, 0.12593918054483_RKIND, 0.12593918054483_RKIND /) - - case (6) - - nIntegrationPoints = 12 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.24928674517091_RKIND, 0.24928674517091_RKIND, 0.50142650965818_RKIND, 0.06308901449150_RKIND, & - 0.06308901449150_RKIND, 0.87382197101700_RKIND, 0.31035245103378_RKIND, 0.63650249912140_RKIND, & - 0.05314504984482_RKIND, 0.63650249912140_RKIND, 0.31035245103378_RKIND, 0.05314504984482_RKIND /) - - v = (/ & - 0.24928674517091_RKIND, 0.50142650965818_RKIND, 0.24928674517091_RKIND, 0.06308901449150_RKIND, & - 0.87382197101700_RKIND, 0.06308901449150_RKIND, 0.63650249912140_RKIND, 0.05314504984482_RKIND, & - 0.31035245103378_RKIND, 0.31035245103378_RKIND, 0.05314504984482_RKIND, 0.63650249912140_RKIND /) - - weights = (/ & - 0.11678627572638_RKIND, 0.11678627572638_RKIND, 0.11678627572638_RKIND, 0.05084490637021_RKIND, & - 0.05084490637021_RKIND, 0.05084490637021_RKIND, 0.08285107561837_RKIND, 0.08285107561837_RKIND, & - 0.08285107561837_RKIND, 0.08285107561837_RKIND, 0.08285107561837_RKIND, 0.08285107561837_RKIND /) - - case (7) - - nIntegrationPoints = 13 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.33333333333333_RKIND, 0.26034596607904_RKIND, 0.26034596607904_RKIND, 0.47930806784192_RKIND, & - 0.06513010290222_RKIND, 0.06513010290222_RKIND, 0.86973979419557_RKIND, 0.31286549600487_RKIND, & - 0.63844418856981_RKIND, 0.04869031542532_RKIND, 0.63844418856981_RKIND, 0.31286549600487_RKIND, & - 0.04869031542532_RKIND /) - - v = (/ & - 0.33333333333333_RKIND, 0.26034596607904_RKIND, 0.47930806784192_RKIND, 0.26034596607904_RKIND, & - 0.06513010290222_RKIND, 0.86973979419557_RKIND, 0.06513010290222_RKIND, 0.63844418856981_RKIND, & - 0.04869031542532_RKIND, 0.31286549600487_RKIND, 0.31286549600487_RKIND, 0.04869031542532_RKIND, & - 0.63844418856981_RKIND /) - - weights = (/ & - -0.14957004446768_RKIND, 0.17561525743321_RKIND, 0.17561525743321_RKIND, 0.17561525743321_RKIND, & - 0.05334723560884_RKIND, 0.05334723560884_RKIND, 0.05334723560884_RKIND, 0.07711376089026_RKIND, & - 0.07711376089026_RKIND, 0.07711376089026_RKIND, 0.07711376089026_RKIND, 0.07711376089026_RKIND, & - 0.07711376089026_RKIND /) - - case (8) - - nIntegrationPoints = 16 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.33333333333333_RKIND, 0.45929258829272_RKIND, 0.45929258829272_RKIND, 0.08141482341455_RKIND, & - 0.17056930775176_RKIND, 0.17056930775176_RKIND, 0.65886138449648_RKIND, 0.05054722831703_RKIND, & - 0.05054722831703_RKIND, 0.89890554336594_RKIND, 0.26311282963464_RKIND, 0.72849239295540_RKIND, & - 0.00839477740996_RKIND, 0.72849239295540_RKIND, 0.26311282963464_RKIND, 0.00839477740996_RKIND /) - - v = (/ & - 0.33333333333333_RKIND, 0.45929258829272_RKIND, 0.08141482341455_RKIND, 0.45929258829272_RKIND, & - 0.17056930775176_RKIND, 0.65886138449648_RKIND, 0.17056930775176_RKIND, 0.05054722831703_RKIND, & - 0.89890554336594_RKIND, 0.05054722831703_RKIND, 0.72849239295540_RKIND, 0.00839477740996_RKIND, & - 0.26311282963464_RKIND, 0.26311282963464_RKIND, 0.00839477740996_RKIND, 0.72849239295540_RKIND /) - - weights = (/ & - 0.14431560767779_RKIND, 0.09509163426728_RKIND, 0.09509163426728_RKIND, 0.09509163426728_RKIND, & - 0.10321737053472_RKIND, 0.10321737053472_RKIND, 0.10321737053472_RKIND, 0.03245849762320_RKIND, & - 0.03245849762320_RKIND, 0.03245849762320_RKIND, 0.02723031417443_RKIND, 0.02723031417443_RKIND, & - 0.02723031417443_RKIND, 0.02723031417443_RKIND, 0.02723031417443_RKIND, 0.02723031417443_RKIND /) - - case (9) - - nIntegrationPoints = 19 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.333333333333333_RKIND, 0.020634961602525_RKIND, 0.489682519198738_RKIND, 0.489682519198738_RKIND, & - 0.125820817014127_RKIND, 0.437089591492937_RKIND, 0.437089591492937_RKIND, 0.623592928761935_RKIND, & - 0.188203535619033_RKIND, 0.188203535619033_RKIND, 0.910540973211095_RKIND, 0.044729513394453_RKIND, & - 0.044729513394453_RKIND, 0.036838412054736_RKIND, 0.221962989160766_RKIND, 0.036838412054736_RKIND, & - 0.741198598784498_RKIND, 0.221962989160766_RKIND, 0.741198598784498_RKIND /) - - v = (/ & - 0.333333333333333_RKIND, 0.489682519198738_RKIND, 0.020634961602525_RKIND, 0.489682519198738_RKIND, & - 0.437089591492937_RKIND, 0.125820817014127_RKIND, 0.437089591492937_RKIND, 0.188203535619033_RKIND, & - 0.623592928761935_RKIND, 0.188203535619033_RKIND, 0.044729513394453_RKIND, 0.910540973211095_RKIND, & - 0.044729513394453_RKIND, 0.221962989160766_RKIND, 0.036838412054736_RKIND, 0.741198598784498_RKIND, & - 0.036838412054736_RKIND, 0.741198598784498_RKIND, 0.221962989160766_RKIND /) - - weights = (/ & - 0.097135796282799_RKIND, 0.031334700227139_RKIND, 0.031334700227139_RKIND, 0.031334700227139_RKIND, & - 0.077827541004774_RKIND, 0.077827541004774_RKIND, 0.077827541004774_RKIND, 0.079647738927210_RKIND, & - 0.079647738927210_RKIND, 0.079647738927210_RKIND, 0.025577675658698_RKIND, 0.025577675658698_RKIND, & - 0.025577675658698_RKIND, 0.043283539377289_RKIND, 0.043283539377289_RKIND, 0.043283539377289_RKIND, & - 0.043283539377289_RKIND, 0.043283539377289_RKIND, 0.043283539377289_RKIND /) - - case (10) - - nIntegrationPoints = 25 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.333333333333333_RKIND, 0.028844733232685_RKIND, 0.485577633383657_RKIND, 0.485577633383657_RKIND, & - 0.781036849029926_RKIND, 0.109481575485037_RKIND, 0.109481575485037_RKIND, 0.141707219414880_RKIND, & - 0.307939838764121_RKIND, 0.141707219414880_RKIND, 0.550352941820999_RKIND, 0.307939838764121_RKIND, & - 0.550352941820999_RKIND, 0.025003534762686_RKIND, 0.246672560639903_RKIND, 0.025003534762686_RKIND, & - 0.728323904597411_RKIND, 0.246672560639903_RKIND, 0.728323904597411_RKIND, 0.009540815400299_RKIND, & - 0.066803251012200_RKIND, 0.009540815400299_RKIND, 0.923655933587500_RKIND, 0.066803251012200_RKIND, & - 0.923655933587500_RKIND /) - - v = (/ & - 0.333333333333333_RKIND, 0.485577633383657_RKIND, 0.028844733232685_RKIND, 0.485577633383657_RKIND, & - 0.109481575485037_RKIND, 0.781036849029926_RKIND, 0.109481575485037_RKIND, 0.307939838764121_RKIND, & - 0.141707219414880_RKIND, 0.550352941820999_RKIND, 0.141707219414880_RKIND, 0.550352941820999_RKIND, & - 0.307939838764121_RKIND, 0.246672560639903_RKIND, 0.025003534762686_RKIND, 0.728323904597411_RKIND, & - 0.025003534762686_RKIND, 0.728323904597411_RKIND, 0.246672560639903_RKIND, 0.066803251012200_RKIND, & - 0.009540815400299_RKIND, 0.923655933587500_RKIND, 0.009540815400299_RKIND, 0.923655933587500_RKIND, & - 0.066803251012200_RKIND /) - - weights = (/ & - 0.090817990382754_RKIND, 0.036725957756467_RKIND, 0.036725957756467_RKIND, 0.036725957756467_RKIND, & - 0.045321059435528_RKIND, 0.045321059435528_RKIND, 0.045321059435528_RKIND, 0.072757916845420_RKIND, & - 0.072757916845420_RKIND, 0.072757916845420_RKIND, 0.072757916845420_RKIND, 0.072757916845420_RKIND, & - 0.072757916845420_RKIND, 0.028327242531057_RKIND, 0.028327242531057_RKIND, 0.028327242531057_RKIND, & - 0.028327242531057_RKIND, 0.028327242531057_RKIND, 0.028327242531057_RKIND, 0.009421666963733_RKIND, & - 0.009421666963733_RKIND, 0.009421666963733_RKIND, 0.009421666963733_RKIND, 0.009421666963733_RKIND, & - 0.009421666963733_RKIND /) - - case (12) - - nIntegrationPoints = 33 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.023565220452390_RKIND, 0.488217389773805_RKIND, 0.488217389773805_RKIND, 0.120551215411079_RKIND, & - 0.439724392294460_RKIND, 0.439724392294460_RKIND, 0.457579229975768_RKIND, 0.271210385012116_RKIND, & - 0.271210385012116_RKIND, 0.744847708916828_RKIND, 0.127576145541586_RKIND, 0.127576145541586_RKIND, & - 0.957365299093579_RKIND, 0.021317350453210_RKIND, 0.021317350453210_RKIND, 0.115343494534698_RKIND, & - 0.275713269685514_RKIND, 0.115343494534698_RKIND, 0.608943235779788_RKIND, 0.275713269685514_RKIND, & - 0.608943235779788_RKIND, 0.022838332222257_RKIND, 0.281325580989940_RKIND, 0.022838332222257_RKIND, & - 0.695836086787803_RKIND, 0.281325580989940_RKIND, 0.695836086787803_RKIND, 0.025734050548330_RKIND, & - 0.116251915907597_RKIND, 0.025734050548330_RKIND, 0.858014033544073_RKIND, 0.116251915907597_RKIND, & - 0.858014033544073_RKIND /) - - v = (/ & - 0.488217389773805_RKIND, 0.023565220452390_RKIND, 0.488217389773805_RKIND, 0.439724392294460_RKIND, & - 0.120551215411079_RKIND, 0.439724392294460_RKIND, 0.271210385012116_RKIND, 0.457579229975768_RKIND, & - 0.271210385012116_RKIND, 0.127576145541586_RKIND, 0.744847708916828_RKIND, 0.127576145541586_RKIND, & - 0.021317350453210_RKIND, 0.957365299093579_RKIND, 0.021317350453210_RKIND, 0.275713269685514_RKIND, & - 0.115343494534698_RKIND, 0.608943235779788_RKIND, 0.115343494534698_RKIND, 0.608943235779788_RKIND, & - 0.275713269685514_RKIND, 0.281325580989940_RKIND, 0.022838332222257_RKIND, 0.695836086787803_RKIND, & - 0.022838332222257_RKIND, 0.695836086787803_RKIND, 0.281325580989940_RKIND, 0.116251915907597_RKIND, & - 0.025734050548330_RKIND, 0.858014033544073_RKIND, 0.025734050548330_RKIND, 0.858014033544073_RKIND, & - 0.116251915907597_RKIND /) - - weights = (/ & - 0.025731066440455_RKIND, 0.025731066440455_RKIND, 0.025731066440455_RKIND, 0.043692544538038_RKIND, & - 0.043692544538038_RKIND, 0.043692544538038_RKIND, 0.062858224217885_RKIND, 0.062858224217885_RKIND, & - 0.062858224217885_RKIND, 0.034796112930709_RKIND, 0.034796112930709_RKIND, 0.034796112930709_RKIND, & - 0.006166261051559_RKIND, 0.006166261051559_RKIND, 0.006166261051559_RKIND, 0.040371557766381_RKIND, & - 0.040371557766381_RKIND, 0.040371557766381_RKIND, 0.040371557766381_RKIND, 0.040371557766381_RKIND, & - 0.040371557766381_RKIND, 0.022356773202303_RKIND, 0.022356773202303_RKIND, 0.022356773202303_RKIND, & - 0.022356773202303_RKIND, 0.022356773202303_RKIND, 0.022356773202303_RKIND, 0.017316231108659_RKIND, & - 0.017316231108659_RKIND, 0.017316231108659_RKIND, 0.017316231108659_RKIND, 0.017316231108659_RKIND, & - 0.017316231108659_RKIND /) - - case default - - call mpas_log_write(& - "get_integration_factors_dunavant: Unimplemented integration order for Dunavant wachspress integration", & - MPAS_LOG_CRIT) - - end select - - end subroutine get_integration_factors_dunavant - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! get_integration_factors -! -!> \brief -!> \author Adrian K. Turner, LANL -!> \date 18th October 2016 -!> \details -!> -! -!----------------------------------------------------------------------- - - subroutine get_integration_factors_fekete(& - integrationOrder, & - nIntegrationPoints, & - u, & - v, & - weights, & - normalizationFactor) - - integer, intent(in) :: & - integrationOrder - - integer, intent(out) :: & - nIntegrationPoints - - real(kind=RKIND), dimension(:), allocatable, intent(out) :: & - u, & - v, & - weights - - real(kind=RKIND), intent(out) :: & - normalizationFactor - - ! M. A. TAYLOR, B. A. WINGATE, AND R. E. VINCENT, (200), "AN ALGORITHM FOR COMPUTING FEKETE POINTS IN THE TRIANGLE", - ! SIAM J. NUMER. ANAL., Vol. 38, No. 5, pp. 1707–1720 - - normalizationFactor = 2.0_RKIND - - select case (integrationOrder) - case (1) - - nIntegrationPoints = 1 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 3.33333333333333333e-01_RKIND /) - - v = (/ & - 3.33333333333333333e-01_RKIND /) - - weights = (/ & - 1.0_RKIND /) - - case (2) - - nIntegrationPoints = 3 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 1.66666666666666666e-01_RKIND, 6.66666666666666666e-01_RKIND, 1.66666666666666666e-01_RKIND /) - - v = (/ & - 6.66666666666666666e-01_RKIND, 1.66666666666666666e-01_RKIND, 1.66666666666666666e-01_RKIND /) - - weights = (/ & - 3.33333333333333333e-01_RKIND, 3.33333333333333333e-01_RKIND, 3.33333333333333333e-01_RKIND /) - - case (3:4) - - nIntegrationPoints = 6 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 9.15762135097704655e-02_RKIND, 8.16847572980458514e-01_RKIND, & - 9.15762135097710761e-02_RKIND, 1.08103018168070275e-01_RKIND, & - 4.45948490915965612e-01_RKIND, 4.45948490915964113e-01_RKIND /) - - v = (/ & - 8.16847572980458514e-01_RKIND, 9.15762135097710761e-02_RKIND, & - 9.15762135097704655e-02_RKIND, 4.45948490915964113e-01_RKIND, & - 1.08103018168070275e-01_RKIND, 4.45948490915965612e-01_RKIND /) - - weights = (/ & - 1.09951743655321843e-01_RKIND, 1.09951743655321857e-01_RKIND, & - 1.09951743655321885e-01_RKIND, 2.23381589678011389e-01_RKIND, & - 2.23381589678011527e-01_RKIND, 2.23381589678011527e-01_RKIND /) - - case (5) - - nIntegrationPoints = 10 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 0.00000000000000000e+00_RKIND, 1.00000000000000000e+00_RKIND, & - 0.00000000000000000e+00_RKIND, 2.67327353118498978e-01_RKIND, & - 6.72817552946136210e-01_RKIND, 6.49236350054349654e-02_RKIND, & - 6.71649853904175198e-01_RKIND, 6.54032456800035522e-02_RKIND, & - 2.69376706913982855e-01_RKIND, 3.38673850389605513e-01_RKIND /) - - v = (/ & - 1.00000000000000000e+00_RKIND, 0.00000000000000000e+00_RKIND, & - 0.00000000000000000e+00_RKIND, 6.72819921871012694e-01_RKIND, & - 2.67328859948191944e-01_RKIND, 6.71653011149382917e-01_RKIND, & - 6.49251690028951334e-02_RKIND, 2.69378936645285116e-01_RKIND, & - 6.54054874919145490e-02_RKIND, 3.38679989302702156e-01_RKIND /) - - weights = (/ & - 1.31356049751916795e-02_RKIND, 1.31358306034076201e-02_RKIND, & - 1.37081973800151392e-02_RKIND, 1.17419193291163376e-01_RKIND, & - 1.17420611913379477e-01_RKIND, 1.24012589655715613e-01_RKIND, & - 1.24015246126072495e-01_RKIND, 1.25930230276426303e-01_RKIND, & - 1.25933026682913923e-01_RKIND, 2.25289469095714456e-01_RKIND /) - - case (6) - - nIntegrationPoints = 11 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 5.72549866774768601e-02_RKIND, 8.95362640024579104e-01_RKIND, 6.84475748456514044e-01_RKIND, & - 6.87462559150295305e-02_RKIND, 6.15676205575839575e-01_RKIND, 6.27946141197789465e-01_RKIND, & - 6.29091383418635686e-02_RKIND, 6.83782119205099126e-02_RKIND, 2.87529458374392255e-01_RKIND, & - 3.28783556413134614e-01_RKIND, 3.12290405013644801e-01_RKIND /) - - v = (/ & - 8.95498146789879490e-01_RKIND, 6.18282212503219533e-02_RKIND, 2.33437384976827311e-02_RKIND, & - 6.00302757472630025e-02_RKIND, 3.33461808341377175e-01_RKIND, 1.59189185992151483e-01_RKIND, & - 6.55295093705452469e-01_RKIND, 3.09117685428267230e-01_RKIND, 6.36426509179620181e-01_RKIND, & - 7.70240056424634223e-02_RKIND, 3.52344786445899505e-01_RKIND /) - - weights = (/ & - 3.80680718529555623e-02_RKIND, 3.83793553077528410e-02_RKIND, 4.62004567445618367e-02_RKIND, & - 5.34675894441989999e-02_RKIND, 8.37558269657456833e-02_RKIND, 1.01644833025517037e-01_RKIND, & - 1.01861524461366940e-01_RKIND, 1.11421831660001677e-01_RKIND, 1.12009450262946106e-01_RKIND, & - 1.24787571437558295e-01_RKIND, 1.88403488837394911e-01_RKIND /) - - case (8) - - nIntegrationPoints = 16 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 7.28492392955404355e-01_RKIND, 8.39477740995753056e-03_RKIND, 2.63112829634638112e-01_RKIND, & - 8.39477740995753056e-03_RKIND, 7.28492392955404355e-01_RKIND, 2.63112829634638112e-01_RKIND, & - 5.05472283170310122e-02_RKIND, 5.05472283170309566e-02_RKIND, 8.98905543365938087e-01_RKIND, & - 4.59292588292723236e-01_RKIND, 8.14148234145536387e-02_RKIND, 4.59292588292723125e-01_RKIND, & - 1.70569307751760324e-01_RKIND, 1.70569307751760046e-01_RKIND, 6.58861384496479685e-01_RKIND, & - 3.33333333333333370e-01_RKIND /) - - v = (/ & - 8.39477740995753056e-03_RKIND, 2.63112829634638112e-01_RKIND, 7.28492392955404355e-01_RKIND, & - 7.28492392955404355e-01_RKIND, 2.63112829634638112e-01_RKIND, 8.39477740995753056e-03_RKIND, & - 5.05472283170309566e-02_RKIND, 8.98905543365938087e-01_RKIND, 5.05472283170310122e-02_RKIND, & - 8.14148234145536387e-02_RKIND, 4.59292588292723125e-01_RKIND, 4.59292588292723236e-01_RKIND, & - 6.58861384496479685e-01_RKIND, 1.70569307751760324e-01_RKIND, 1.70569307751760046e-01_RKIND, & - 3.33333333333333370e-01_RKIND /) - - weights = (/ & - 2.72303141744348991e-02_RKIND, 2.72303141744349199e-02_RKIND, 2.72303141744349199e-02_RKIND, & - 2.72303141744349789e-02_RKIND, 2.72303141744349789e-02_RKIND, 2.72303141744349997e-02_RKIND, & - 3.24584976231980793e-02_RKIND, 3.24584976231980793e-02_RKIND, 3.24584976231981001e-02_RKIND, & - 9.50916342672845638e-02_RKIND, 9.50916342672846193e-02_RKIND, 9.50916342672846193e-02_RKIND, & - 1.03217370534718286e-01_RKIND, 1.03217370534718314e-01_RKIND, 1.03217370534718314e-01_RKIND, & - 1.44315607677787283e-01_RKIND /) - - case (9) - - nIntegrationPoints = 19 - - allocate(u(nIntegrationPoints)) - allocate(v(nIntegrationPoints)) - allocate(weights(nIntegrationPoints)) - - u = (/ & - 2.26739052759332704e-01_RKIND, 4.77345862087794129e-02_RKIND, 2.26577168977105115e-02_RKIND, & - 9.10074385862343016e-01_RKIND, 4.41452661673673585e-02_RKIND, 4.79944340675050984e-01_RKIND, & - 7.42657808541620557e-01_RKIND, 7.43369623518591927e-01_RKIND, 2.79454959355581213e-02_RKIND, & - 3.71861932583309532e-02_RKIND, 2.22639561442096401e-01_RKIND, 1.16082059855864395e-01_RKIND, & - 4.73822270420208358e-01_RKIND, 4.77758170054016440e-01_RKIND, 6.46387881792721997e-01_RKIND, & - 2.85357695207302253e-01_RKIND, 2.04236860041029755e-01_RKIND, 1.59370884213907937e-01_RKIND, & - 3.95698265017060125e-01_RKIND /) - - v = (/ & - 0.00000000000000000e+00_RKIND, 9.16183156802148568e-01_RKIND, 7.97193825386026345e-01_RKIND, & - 4.44666861644595901e-02_RKIND, 4.81588383854628099e-02_RKIND, 5.01294615157430568e-01_RKIND, & - 3.03405081749971196e-02_RKIND, 2.22245578824042445e-01_RKIND, 5.25527023486726308e-01_RKIND, & - 2.39263537482135413e-01_RKIND, 7.29063709376736702e-01_RKIND, 6.62507673462198188e-01_RKIND, & - 4.60334709656892230e-02_RKIND, 4.01038691325781238e-01_RKIND, 1.65342747538830548e-01_RKIND, & - 4.92973630851354261e-01_RKIND, 1.19056565447230756e-01_RKIND, 3.66261159763432431e-01_RKIND, & - 2.27511600022304139e-01_RKIND /) - - weights = (/ & - 1.58676858667487208e-02_RKIND, 2.19524732703951786e-02_RKIND, 2.40354401213296598e-02_RKIND, & - 2.58522468388647786e-02_RKIND, 2.71951393759608216e-02_RKIND, 3.02097786027936584e-02_RKIND, & - 3.70093240446550606e-02_RKIND, 4.11482921825866571e-02_RKIND, 4.26331605467379776e-02_RKIND, & - 4.71413336863812371e-02_RKIND, 5.45129844125978591e-02_RKIND, 6.26632599630084636e-02_RKIND, & - 6.31379657675310846e-02_RKIND, 7.14623133641135444e-02_RKIND, 7.51048615652924606e-02_RKIND, & - 7.98259878444318866e-02_RKIND, 8.16607475819435963e-02_RKIND, 9.37481686311500140e-02_RKIND, & - 1.04838836333477403e-01_RKIND /) - - case default - - call mpas_log_write(& - "get_integration_factors_fekete: Unimplemented integration order for Fekete wachspress integration", & - MPAS_LOG_CRIT) - - end select - - end subroutine get_integration_factors_fekete - !----------------------------------------------------------------------- end module seaice_velocity_solver_wachspress diff --git a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_weak.F b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_weak.F index bbb32833ac4e..f992278f6f24 100644 --- a/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_weak.F +++ b/components/mpas-seaice/src/shared/mpas_seaice_velocity_solver_weak.F @@ -45,24 +45,24 @@ module seaice_velocity_solver_weak ! !----------------------------------------------------------------------- - subroutine seaice_init_velocity_solver_weak(& - mesh, & - boundary, & - velocity_weak, & - rotateCartesianGrid)!{{{ + subroutine seaice_init_velocity_solver_weak(domain)!{{{ use seaice_mesh, only: & seaice_normal_vectors - type(MPAS_pool_type), pointer, intent(inout) :: & - mesh !< Input/Output: + type (domain_type), intent(inout) :: & + domain !< Input/Output: + + type(block_type), pointer :: & + blockPtr type(MPAS_pool_type), pointer :: & - velocity_weak, & !< Input/Output: - boundary !< Input/Output: + meshPool, & + velocityWeakPool, & + boundaryPool - logical, intent(in) :: & - rotateCartesianGrid !< Input: + logical, pointer :: & + config_rotate_cartesian_grid real(kind=RKIND), dimension(:,:,:), pointer :: & normalVectorPolygon, & @@ -75,21 +75,29 @@ subroutine seaice_init_velocity_solver_weak(& integer, dimension(:), pointer :: & interiorVertex - call MPAS_pool_get_array(velocity_weak, "normalVectorPolygon", normalVectorPolygon) - call MPAS_pool_get_array(velocity_weak, "normalVectorTriangle", normalVectorTriangle) - call MPAS_pool_get_array(velocity_weak, "latCellRotated", latCellRotated) - call MPAS_pool_get_array(velocity_weak, "latVertexRotated", latVertexRotated) - call MPAS_pool_get_array(boundary, "interiorVertex", interiorVertex) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call seaice_normal_vectors(& - mesh, & - normalVectorPolygon, & - normalVectorTriangle, & - interiorVertex, & - rotateCartesianGrid, & - .true., & - latCellRotated, & - latVertexRotated) + call MPAS_pool_get_config(domain % configs, "config_rotate_cartesian_grid", config_rotate_cartesian_grid) + + call MPAS_pool_get_array(velocityWeakPool, "normalVectorPolygon", normalVectorPolygon) + call MPAS_pool_get_array(velocityWeakPool, "normalVectorTriangle", normalVectorTriangle) + call MPAS_pool_get_array(velocityWeakPool, "latCellRotated", latCellRotated) + call MPAS_pool_get_array(velocityWeakPool, "latVertexRotated", latVertexRotated) + call MPAS_pool_get_array(boundaryPool, "interiorVertex", interiorVertex) + + call seaice_normal_vectors(& + meshPool, & + normalVectorPolygon, & + normalVectorTriangle, & + interiorVertex, & + config_rotate_cartesian_grid, & + .true., & + latCellRotated, & + latVertexRotated) + + blockPtr => blockPtr % next + enddo end subroutine seaice_init_velocity_solver_weak!}}} @@ -109,35 +117,33 @@ end subroutine seaice_init_velocity_solver_weak!}}} ! !----------------------------------------------------------------------- - subroutine seaice_strain_tensor_weak(& - mesh, & - strain11, & - strain22, & - strain12, & - uVelocity, & - vVelocity, & - normalVectorPolygon, & - latCellRotated, & - solveStress)!{{{ + subroutine seaice_strain_tensor_weak(domain)!{{{ - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: + use seaice_mesh_pool, only: & + solveStress, & + uVelocity, & + vVelocity + + type(domain_type), intent(inout) :: & + domain - real(kind=RKIND), dimension(:), intent(out) :: & - strain11, & !< Output: - strain22, & !< Output: - strain12 !< Output: + type(block_type), pointer :: & + blockPtr - real(kind=RKIND), dimension(:), intent(in) :: & - uVelocity, & !< Input: - vVelocity, & !< Input: - latCellRotated !< Input: + type(MPAS_pool_type), pointer :: & + meshPool, & + velocityWeakPool + + real(kind=RKIND), dimension(:), pointer :: & + strain11, & + strain22, & + strain12 - real(kind=RKIND), dimension(:,:,:), intent(in) :: & - normalVectorPolygon !< Input: + real(kind=RKIND), dimension(:), pointer :: & + latCellRotated - integer, dimension(:), intent(in) :: & - solveStress !< Input: + real(kind=RKIND), dimension(:,:,:), pointer :: & + normalVectorPolygon integer :: & iCell, & @@ -173,82 +179,97 @@ subroutine seaice_strain_tensor_weak(& dvEdge, & areaCell - call MPAS_pool_get_dimension(mesh, "nCells", nCells) - call MPAS_pool_get_config(mesh, "sphere_radius", sphere_radius) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_array(mesh, "nEdgesOnCell", nEdgesOnCell) - call MPAS_pool_get_array(mesh, "verticesOnCell", verticesOnCell) - call MPAS_pool_get_array(mesh, "edgesOnCell", edgesOnCell) - call MPAS_pool_get_array(mesh, "verticesOnEdge", verticesOnEdge) - call MPAS_pool_get_array(mesh, "dvEdge", dvEdge) - call MPAS_pool_get_array(mesh, "areaCell", areaCell) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) - ! planar cases with zero sphere radius - sphereRadius = sphere_radius - if (sphereRadius == 0.0_RKIND) sphereRadius = 1.0_RKIND + call MPAS_pool_get_dimension(meshPool, "nCells", nCells) + call MPAS_pool_get_config(meshPool, "sphere_radius", sphere_radius) - do iCell = 1, nCells + call MPAS_pool_get_array(meshPool, "nEdgesOnCell", nEdgesOnCell) + call MPAS_pool_get_array(meshPool, "verticesOnCell", verticesOnCell) + call MPAS_pool_get_array(meshPool, "edgesOnCell", edgesOnCell) + call MPAS_pool_get_array(meshPool, "verticesOnEdge", verticesOnEdge) + call MPAS_pool_get_array(meshPool, "dvEdge", dvEdge) + call MPAS_pool_get_array(meshPool, "areaCell", areaCell) - strain11(iCell) = 0.0_RKIND - strain22(iCell) = 0.0_RKIND - strain12(iCell) = 0.0_RKIND + call MPAS_pool_get_array(velocityWeakPool, "normalVectorPolygon", normalVectorPolygon) + call MPAS_pool_get_array(velocityWeakPool, "latCellRotated", latCellRotated) + call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11) + call MPAS_pool_get_array(velocityWeakPool, "strain22", strain22) + call MPAS_pool_get_array(velocityWeakPool, "strain12", strain12) - if (solveStress(iCell) == 1) then + ! planar cases with zero sphere radius + sphereRadius = sphere_radius + if (sphereRadius == 0.0_RKIND) sphereRadius = 1.0_RKIND - uCellCentre = 0.0_RKIND - vCellCentre = 0.0_RKIND + do iCell = 1, nCells - do iEdgeOnCell = 1, nEdgesOnCell(iCell) + strain11(iCell) = 0.0_RKIND + strain22(iCell) = 0.0_RKIND + strain12(iCell) = 0.0_RKIND + + if (solveStress(iCell) == 1) then - ! cell centre velocities - iVertex = verticesOnCell(iEdgeOnCell,iCell) + uCellCentre = 0.0_RKIND + vCellCentre = 0.0_RKIND - uCellCentre = uCellCentre + uVelocity(iVertex) - vCellCentre = vCellCentre + vVelocity(iVertex) + do iEdgeOnCell = 1, nEdgesOnCell(iCell) - ! interpolated edge velocity - iEdge = edgesOnCell(iEdgeOnCell,iCell) + ! cell centre velocities + iVertex = verticesOnCell(iEdgeOnCell,iCell) - uVelocityEdge = 0.0_RKIND - vVelocityEdge = 0.0_RKIND + uCellCentre = uCellCentre + uVelocity(iVertex) + vCellCentre = vCellCentre + vVelocity(iVertex) - do iVertexOnEdge = 1, 2 + ! interpolated edge velocity + iEdge = edgesOnCell(iEdgeOnCell,iCell) - iVertex = verticesOnEdge(iVertexOnEdge,iEdge) + uVelocityEdge = 0.0_RKIND + vVelocityEdge = 0.0_RKIND - uVelocityEdge = uVelocityEdge + uVelocity(iVertex) - vVelocityEdge = vVelocityEdge + vVelocity(iVertex) + do iVertexOnEdge = 1, 2 - enddo ! iVertexOnEdge + iVertex = verticesOnEdge(iVertexOnEdge,iEdge) - uVelocityEdge = uVelocityEdge / 2.0_RKIND - vVelocityEdge = vVelocityEdge / 2.0_RKIND + uVelocityEdge = uVelocityEdge + uVelocity(iVertex) + vVelocityEdge = vVelocityEdge + vVelocity(iVertex) - ! summation over edges - strain11(iCell) = strain11(iCell) + uVelocityEdge * normalVectorPolygon(1,iEdgeOnCell,iCell) * dvEdge(iEdge) - strain22(iCell) = strain22(iCell) + vVelocityEdge * normalVectorPolygon(2,iEdgeOnCell,iCell) * dvEdge(iEdge) - strain12(iCell) = strain12(iCell) + 0.5_RKIND * ( & - uVelocityEdge * normalVectorPolygon(2,iEdgeOnCell,iCell) + & - vVelocityEdge * normalVectorPolygon(1,iEdgeOnCell,iCell) ) * dvEdge(iEdge) + enddo ! iVertexOnEdge - enddo ! iEdgeOnCell + uVelocityEdge = uVelocityEdge / 2.0_RKIND + vVelocityEdge = vVelocityEdge / 2.0_RKIND - uCellCentre = uCellCentre / real(nEdgesOnCell(iCell), RKIND) - vCellCentre = vCellCentre / real(nEdgesOnCell(iCell), RKIND) + ! summation over edges + strain11(iCell) = strain11(iCell) + uVelocityEdge * normalVectorPolygon(1,iEdgeOnCell,iCell) * dvEdge(iEdge) + strain22(iCell) = strain22(iCell) + vVelocityEdge * normalVectorPolygon(2,iEdgeOnCell,iCell) * dvEdge(iEdge) + strain12(iCell) = strain12(iCell) + 0.5_RKIND * ( & + uVelocityEdge * normalVectorPolygon(2,iEdgeOnCell,iCell) + & + vVelocityEdge * normalVectorPolygon(1,iEdgeOnCell,iCell) ) * dvEdge(iEdge) - strain11(iCell) = strain11(iCell) / areaCell(iCell) - strain22(iCell) = strain22(iCell) / areaCell(iCell) - strain12(iCell) = strain12(iCell) / areaCell(iCell) + enddo ! iEdgeOnCell - ! metric terms - strain11(iCell) = strain11(iCell) - (vCellCentre * tan(latCellRotated(iCell))) / sphereRadius - strain12(iCell) = strain12(iCell) + (uCellCentre * tan(latCellRotated(iCell)) * 0.5_RKIND) / sphereRadius + uCellCentre = uCellCentre / real(nEdgesOnCell(iCell), RKIND) + vCellCentre = vCellCentre / real(nEdgesOnCell(iCell), RKIND) - !if (abs(strain11(iCell)) < 1e-10_RKIND) strain11(iCell) = 0.0_RKIND + strain11(iCell) = strain11(iCell) / areaCell(iCell) + strain22(iCell) = strain22(iCell) / areaCell(iCell) + strain12(iCell) = strain12(iCell) / areaCell(iCell) + + ! metric terms + strain11(iCell) = strain11(iCell) - (vCellCentre * tan(latCellRotated(iCell))) / sphereRadius + strain12(iCell) = strain12(iCell) + (uCellCentre * tan(latCellRotated(iCell)) * 0.5_RKIND) / sphereRadius + + !if (abs(strain11(iCell)) < 1e-10_RKIND) strain11(iCell) = 0.0_RKIND + + endif ! solveStress - endif ! solveStress + enddo ! iCell - enddo ! iCell + blockPtr => blockPtr % next + end do end subroutine seaice_strain_tensor_weak!}}} @@ -264,18 +285,11 @@ end subroutine seaice_strain_tensor_weak!}}} ! !----------------------------------------------------------------------- - subroutine seaice_stress_tensor_weak(& - mesh, & - stress11, & - stress22, & - stress12, & - strain11, & - strain22, & - strain12, & - icePressure, & - replacementPressure, & - solveStress, & - dtElastic)!{{{ + subroutine seaice_stress_tensor_weak(domain)!{{{ + + use seaice_mesh_pool, only: & + icePressure, & + solveStress use seaice_velocity_solver_constitutive_relation, only: & constitutiveRelationType, & @@ -286,26 +300,30 @@ subroutine seaice_stress_tensor_weak(& seaice_evp_constitutive_relation_revised, & seaice_linear_constitutive_relation - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: + type(domain_type), intent(inout) :: & + domain - real(kind=RKIND), dimension(:), intent(inout) :: & - stress11, & !< Input/Output: - stress22, & !< Input/Output: - stress12, & !< Input/Output: - replacementPressure !< Input/Output: + type(block_type), pointer :: & + blockPtr - real(kind=RKIND), dimension(:), intent(inout) :: & - strain11, & !< Input/Output: - strain22, & !< Input/Output: - strain12, & !< Input/Output: - icePressure !< Input/Output: + type(MPAS_pool_type), pointer :: & + meshPool, & + velocitySolverPool, & + velocityWeakPool + + real(kind=RKIND), dimension(:), pointer :: & + replacementPressure - integer, dimension(:), intent(in) :: & - solveStress !< Input: + real(kind=RKIND), dimension(:), pointer :: & + strain11, & + strain22, & + strain12, & + stress11, & + stress22, & + stress12 - real(kind=RKIND), intent(in) :: & - dtElastic !< Input: + real(kind=RKIND), pointer :: & + elasticTimeStep integer :: & iCell @@ -316,91 +334,110 @@ subroutine seaice_stress_tensor_weak(& real(kind=RKIND), dimension(:), pointer :: & areaCell - ! init variables - call MPAS_pool_get_dimension(mesh, "nCells", nCells) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_array(mesh, "areaCell", areaCell) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) - if (constitutiveRelationType == EVP_CONSTITUTIVE_RELATION) then + call MPAS_pool_get_dimension(meshPool, "nCells", nCells) - do iCell = 1, nCells + call MPAS_pool_get_array(meshPool, "areaCell", areaCell) - if (solveStress(iCell) == 1) then + call MPAS_pool_get_array(velocitySolverPool, "elasticTimeStep", elasticTimeStep) - call seaice_evp_constitutive_relation(& - stress11(iCell), & - stress22(iCell), & - stress12(iCell), & - strain11(iCell), & - strain22(iCell), & - strain12(iCell), & - icePressure(iCell), & - replacementPressure(iCell), & - areaCell(iCell), & - dtElastic) + call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11) + call MPAS_pool_get_array(velocityWeakPool, "strain22", strain22) + call MPAS_pool_get_array(velocityWeakPool, "strain12", strain12) + call MPAS_pool_get_array(velocityWeakPool, "stress11weak", stress11) + call MPAS_pool_get_array(velocityWeakPool, "stress22weak", stress22) + call MPAS_pool_get_array(velocityWeakPool, "stress12weak", stress12) + call MPAS_pool_get_array(velocityWeakPool, "replacementPressure", replacementPressure) - else + if (constitutiveRelationType == EVP_CONSTITUTIVE_RELATION) then - stress11(iCell) = 0.0_RKIND - stress22(iCell) = 0.0_RKIND - stress12(iCell) = 0.0_RKIND + do iCell = 1, nCells - endif ! solveStress + if (solveStress(iCell) == 1) then - end do ! iCell + call seaice_evp_constitutive_relation(& + stress11(iCell), & + stress22(iCell), & + stress12(iCell), & + strain11(iCell), & + strain22(iCell), & + strain12(iCell), & + icePressure(iCell), & + replacementPressure(iCell), & + areaCell(iCell), & + elasticTimeStep) - else if (constitutiveRelationType == REVISED_EVP_CONSTITUTIVE_RELATION) then + else - do iCell = 1, nCells + stress11(iCell) = 0.0_RKIND + stress22(iCell) = 0.0_RKIND + stress12(iCell) = 0.0_RKIND - if (solveStress(iCell) == 1) then + endif ! solveStress - call seaice_evp_constitutive_relation_revised(& - stress11(iCell), & - stress22(iCell), & - stress12(iCell), & - strain11(iCell), & - strain22(iCell), & - strain12(iCell), & - icePressure(iCell), & - replacementPressure(iCell), & - areaCell(iCell)) + end do ! iCell - else + else if (constitutiveRelationType == REVISED_EVP_CONSTITUTIVE_RELATION) then - stress11(iCell) = 0.0_RKIND - stress22(iCell) = 0.0_RKIND - stress12(iCell) = 0.0_RKIND + do iCell = 1, nCells - endif ! solveStress + if (solveStress(iCell) == 1) then - end do ! iCell + call seaice_evp_constitutive_relation_revised(& + stress11(iCell), & + stress22(iCell), & + stress12(iCell), & + strain11(iCell), & + strain22(iCell), & + strain12(iCell), & + icePressure(iCell), & + replacementPressure(iCell), & + areaCell(iCell)) - else if (constitutiveRelationType == LINEAR_CONSTITUTIVE_RELATION) then + else - do iCell = 1, nCells + stress11(iCell) = 0.0_RKIND + stress22(iCell) = 0.0_RKIND + stress12(iCell) = 0.0_RKIND - if (solveStress(iCell) == 1) then + endif ! solveStress - call seaice_linear_constitutive_relation(& - stress11(iCell), & - stress22(iCell), & - stress12(iCell), & - strain11(iCell), & - strain22(iCell), & - strain12(iCell)) + end do ! iCell - else + else if (constitutiveRelationType == LINEAR_CONSTITUTIVE_RELATION) then - stress11(iCell) = 0.0_RKIND - stress22(iCell) = 0.0_RKIND - stress12(iCell) = 0.0_RKIND + do iCell = 1, nCells - endif ! solveStress + if (solveStress(iCell) == 1) then - enddo ! iCell + call seaice_linear_constitutive_relation(& + stress11(iCell), & + stress22(iCell), & + stress12(iCell), & + strain11(iCell), & + strain22(iCell), & + strain12(iCell)) + + else + + stress11(iCell) = 0.0_RKIND + stress22(iCell) = 0.0_RKIND + stress12(iCell) = 0.0_RKIND - endif ! constitutiveRelationType + endif ! solveStress + + enddo ! iCell + + endif ! constitutiveRelationType + + blockPtr => blockPtr % next + end do end subroutine seaice_stress_tensor_weak!}}} @@ -416,65 +453,75 @@ end subroutine seaice_stress_tensor_weak!}}} ! !----------------------------------------------------------------------- - subroutine seaice_stress_tensor_weak_linear(& - mesh, & - stress11, & - stress22, & - stress12, & - strain11, & - strain22, & - strain12, & - solveStress)!{{{ + subroutine seaice_stress_tensor_weak_linear(domain)!{{{ use seaice_velocity_solver_constitutive_relation, only: & seaice_linear_constitutive_relation - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: + use seaice_mesh_pool, only: & + nCells, & + solveStress + + type(domain_type), intent(inout) :: & + domain + + type(block_type), pointer :: & + blockPtr + + type(MPAS_pool_type), pointer :: & + meshPool, & + velocityWeakPool - real(kind=RKIND), dimension(:), intent(out) :: & + real(kind=RKIND), dimension(:), pointer :: & stress11, & !< Output: stress22, & !< Output: stress12 !< Output: - real(kind=RKIND), dimension(:), intent(in) :: & + real(kind=RKIND), dimension(:), pointer :: & strain11, & !< Input: strain22, & !< Input: strain12 !< Input: - integer, dimension(:), intent(in) :: & - solveStress !< Input: - integer :: & iCell - integer, pointer :: & - nCells + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) - ! init variables - call MPAS_pool_get_dimension(mesh, "nCells", nCells) + call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11) + call MPAS_pool_get_array(velocityWeakPool, "strain22", strain22) + call MPAS_pool_get_array(velocityWeakPool, "strain12", strain12) + call MPAS_pool_get_array(velocityWeakPool, "stress11", stress11) + call MPAS_pool_get_array(velocityWeakPool, "stress22", stress22) + call MPAS_pool_get_array(velocityWeakPool, "stress12", stress12) + + do iCell = 1, nCells - do iCell = 1, nCells + if (solveStress(iCell) == 1) then - if (solveStress(iCell) == 1) then + call seaice_linear_constitutive_relation(& + stress11(iCell), & + stress22(iCell), & + stress12(iCell), & + strain11(iCell), & + strain22(iCell), & + strain12(iCell)) - call seaice_linear_constitutive_relation(& - stress11(iCell), & - stress22(iCell), & - stress12(iCell), & - strain11(iCell), & - strain22(iCell), & - strain12(iCell)) + else - else + stress11(iCell) = 0.0_RKIND + stress22(iCell) = 0.0_RKIND + stress12(iCell) = 0.0_RKIND - stress11(iCell) = 0.0_RKIND - stress22(iCell) = 0.0_RKIND - stress12(iCell) = 0.0_RKIND + endif ! solveStress - endif ! solveStress + enddo ! iCell - enddo ! iCell + blockPtr => blockPtr % next + end do end subroutine seaice_stress_tensor_weak_linear!}}} @@ -490,35 +537,34 @@ end subroutine seaice_stress_tensor_weak_linear!}}} ! !----------------------------------------------------------------------- - subroutine seaice_stress_divergence_weak(& - mesh, & - stressDivergenceU, & - stressDivergenceV, & - stress11, & - stress22, & - stress12, & - normalVectorTriangle, & - latVertexRotated, & - solveVelocity)!{{{ + subroutine seaice_stress_divergence_weak(domain)!{{{ - type(MPAS_pool_type), pointer, intent(in) :: & - mesh !< Input: + use seaice_mesh_pool, only: & + solveVelocity + + type(domain_type), intent(inout) :: & + domain - real(kind=RKIND), dimension(:), intent(out) :: & - stressDivergenceU, & !< Output: - stressDivergenceV !< Output: + type(block_type), pointer :: & + blockPtr + + type(MPAS_pool_type), pointer :: & + meshPool, & + velocitySolverPool, & + velocityWeakPool - real(kind=RKIND), dimension(:), intent(in) :: & - stress11, & !< Input: - stress22, & !< Input: - stress12, & !< Input: - latVertexRotated !< Input: + real(kind=RKIND), dimension(:), pointer :: & + stressDivergenceU, & + stressDivergenceV - real(kind=RKIND), dimension(:,:,:), intent(in) :: & - normalVectorTriangle !< Input: + real(kind=RKIND), dimension(:), pointer :: & + stress11, & + stress22, & + stress12, & + latVertexRotated - integer, dimension(:), intent(in) :: & - solveVelocity !< Input: + real(kind=RKIND), dimension(:,:,:), pointer :: & + normalVectorTriangle real(kind=RKIND) :: & stress11Edge, & @@ -554,88 +600,106 @@ subroutine seaice_stress_divergence_weak(& areaTriangle, & dcEdge - ! init variables - call MPAS_pool_get_dimension(mesh, "nVertices", nVerticesSolve) - call MPAS_pool_get_dimension(mesh, "vertexDegree", vertexDegree) - call MPAS_pool_get_config(mesh, "sphere_radius", sphere_radius) + blockPtr => domain % blocklist + do while (associated(blockPtr)) - call MPAS_pool_get_array(mesh, "cellsOnVertex", cellsOnVertex) - call MPAS_pool_get_array(mesh, "edgesOnVertex", edgesOnVertex) - call MPAS_pool_get_array(mesh, "cellsOnEdge", cellsOnEdge) - call MPAS_pool_get_array(mesh, "areaTriangle", areaTriangle) - call MPAS_pool_get_array(mesh, "dcEdge", dcEdge) + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) - ! planar cases with zero sphere radius - sphereRadius = sphere_radius - if (sphereRadius == 0.0_RKIND) sphereRadius = 1.0_RKIND + call MPAS_pool_get_dimension(meshPool, "nVertices", nVerticesSolve) + call MPAS_pool_get_dimension(meshPool, "vertexDegree", vertexDegree) + call MPAS_pool_get_config(meshPool, "sphere_radius", sphere_radius) - do iVertex = 1, nVerticesSolve + call MPAS_pool_get_array(meshPool, "cellsOnVertex", cellsOnVertex) + call MPAS_pool_get_array(meshPool, "edgesOnVertex", edgesOnVertex) + call MPAS_pool_get_array(meshPool, "cellsOnEdge", cellsOnEdge) + call MPAS_pool_get_array(meshPool, "areaTriangle", areaTriangle) + call MPAS_pool_get_array(meshPool, "dcEdge", dcEdge) - stressDivergenceU(iVertex) = 0.0_RKIND - stressDivergenceV(iVertex) = 0.0_RKIND + call MPAS_pool_get_array(velocitySolverPool, "stressDivergenceU", stressDivergenceU) + call MPAS_pool_get_array(velocitySolverPool, "stressDivergenceV", stressDivergenceV) - if (solveVelocity(iVertex) == 1) then + call MPAS_pool_get_array(velocityWeakPool, "normalVectorTriangle", normalVectorTriangle) + call MPAS_pool_get_array(velocityWeakPool, "latVertexRotated", latVertexRotated) + call MPAS_pool_get_array(velocityWeakPool, "stress11", stress11) + call MPAS_pool_get_array(velocityWeakPool, "stress22", stress22) + call MPAS_pool_get_array(velocityWeakPool, "stress12", stress12) - stress11Vertex = 0.0_RKIND - stress22Vertex = 0.0_RKIND - stress12Vertex = 0.0_RKIND + ! planar cases with zero sphere radius + sphereRadius = sphere_radius + if (sphereRadius == 0.0_RKIND) sphereRadius = 1.0_RKIND - do iVertexDegree = 1, vertexDegree + do iVertex = 1, nVerticesSolve - ! vertex stresses - iCell = cellsOnVertex(iVertexDegree,iVertex) + stressDivergenceU(iVertex) = 0.0_RKIND + stressDivergenceV(iVertex) = 0.0_RKIND - stress11Vertex = stress11Vertex + stress11(iCell) - stress22Vertex = stress22Vertex + stress22(iCell) - stress12Vertex = stress12Vertex + stress12(iCell) + if (solveVelocity(iVertex) == 1) then - ! interpolated edge velocity - iEdge = edgesOnVertex(iVertexDegree,iVertex) + stress11Vertex = 0.0_RKIND + stress22Vertex = 0.0_RKIND + stress12Vertex = 0.0_RKIND - stress11Edge = 0.0_RKIND - stress22Edge = 0.0_RKIND - stress12Edge = 0.0_RKIND + do iVertexDegree = 1, vertexDegree - do iCellOnEdge = 1, 2 + ! vertex stresses + iCell = cellsOnVertex(iVertexDegree,iVertex) - iCell = cellsOnEdge(iCellOnEdge,iEdge) + stress11Vertex = stress11Vertex + stress11(iCell) + stress22Vertex = stress22Vertex + stress22(iCell) + stress12Vertex = stress12Vertex + stress12(iCell) - stress11Edge = stress11Edge + stress11(iCell) - stress22Edge = stress22Edge + stress22(iCell) - stress12Edge = stress12Edge + stress12(iCell) + ! interpolated edge velocity + iEdge = edgesOnVertex(iVertexDegree,iVertex) - enddo ! iCellOnEdge + stress11Edge = 0.0_RKIND + stress22Edge = 0.0_RKIND + stress12Edge = 0.0_RKIND - stress11Edge = stress11Edge / 2.0_RKIND - stress22Edge = stress22Edge / 2.0_RKIND - stress12Edge = stress12Edge / 2.0_RKIND + do iCellOnEdge = 1, 2 - stressDivergenceU(iVertex) = stressDivergenceU(iVertex) + & - (stress11Edge * normalVectorTriangle(1,iVertexDegree,iVertex) + & - stress12Edge * normalVectorTriangle(2,iVertexDegree,iVertex)) * dcEdge(iEdge) + iCell = cellsOnEdge(iCellOnEdge,iEdge) - stressDivergenceV(iVertex) = stressDivergenceV(iVertex) + & - (stress22Edge * normalVectorTriangle(2,iVertexDegree,iVertex) + & - stress12Edge * normalVectorTriangle(1,iVertexDegree,iVertex)) * dcEdge(iEdge) + stress11Edge = stress11Edge + stress11(iCell) + stress22Edge = stress22Edge + stress22(iCell) + stress12Edge = stress12Edge + stress12(iCell) + + enddo ! iCellOnEdge - enddo ! iVertexDegree + stress11Edge = stress11Edge / 2.0_RKIND + stress22Edge = stress22Edge / 2.0_RKIND + stress12Edge = stress12Edge / 2.0_RKIND - stress11Vertex = stress11Vertex / real(vertexDegree, RKIND) - stress22Vertex = stress22Vertex / real(vertexDegree, RKIND) - stress12Vertex = stress12Vertex / real(vertexDegree, RKIND) + stressDivergenceU(iVertex) = stressDivergenceU(iVertex) + & + (stress11Edge * normalVectorTriangle(1,iVertexDegree,iVertex) + & + stress12Edge * normalVectorTriangle(2,iVertexDegree,iVertex)) * dcEdge(iEdge) - stressDivergenceU(iVertex) = stressDivergenceU(iVertex) / areaTriangle(iVertex) - stressDivergenceV(iVertex) = stressDivergenceV(iVertex) / areaTriangle(iVertex) + stressDivergenceV(iVertex) = stressDivergenceV(iVertex) + & + (stress22Edge * normalVectorTriangle(2,iVertexDegree,iVertex) + & + stress12Edge * normalVectorTriangle(1,iVertexDegree,iVertex)) * dcEdge(iEdge) - ! metric terms - stressDivergenceU(iVertex) = stressDivergenceU(iVertex) - & - (tan(latVertexRotated(iVertex)) * stress12Vertex) / sphereRadius - stressDivergenceV(iVertex) = stressDivergenceV(iVertex) + & - (tan(latVertexRotated(iVertex)) * stress11Vertex) / sphereRadius + enddo ! iVertexDegree - endif ! solveVelocity + stress11Vertex = stress11Vertex / real(vertexDegree, RKIND) + stress22Vertex = stress22Vertex / real(vertexDegree, RKIND) + stress12Vertex = stress12Vertex / real(vertexDegree, RKIND) - enddo ! iVertex + stressDivergenceU(iVertex) = stressDivergenceU(iVertex) / areaTriangle(iVertex) + stressDivergenceV(iVertex) = stressDivergenceV(iVertex) / areaTriangle(iVertex) + + ! metric terms + stressDivergenceU(iVertex) = stressDivergenceU(iVertex) - & + (tan(latVertexRotated(iVertex)) * stress12Vertex) / sphereRadius + stressDivergenceV(iVertex) = stressDivergenceV(iVertex) + & + (tan(latVertexRotated(iVertex)) * stress11Vertex) / sphereRadius + + endif ! solveVelocity + + enddo ! iVertex + + blockPtr => blockPtr % next + end do end subroutine seaice_stress_divergence_weak!}}} @@ -651,7 +715,7 @@ end subroutine seaice_stress_divergence_weak!}}} ! !----------------------------------------------------------------------- - subroutine seaice_final_divergence_shear_weak(block) + subroutine seaice_final_divergence_shear_weak(domain) use seaice_velocity_solver_constitutive_relation, only: & eccentricitySquared @@ -661,8 +725,11 @@ subroutine seaice_final_divergence_shear_weak(block) solveStress, & nEdgesOnCell - type(block_type), intent(inout) :: & - block + type(domain_type), intent(inout) :: & + domain + + type(block_type), pointer :: & + blockPtr type(MPAS_pool_type), pointer :: & meshPool, & @@ -693,71 +760,77 @@ subroutine seaice_final_divergence_shear_weak(block) integer :: & iCell - call MPAS_pool_get_subpool(block % structs, "mesh", meshPool) - call MPAS_pool_get_subpool(block % structs, "velocity_weak", velocityWeakPool) - call MPAS_pool_get_subpool(block % structs, "velocity_solver", velocitySolverPool) + blockPtr => domain % blocklist + do while (associated(blockPtr)) + + call MPAS_pool_get_subpool(blockPtr % structs, "mesh", meshPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_weak", velocityWeakPool) + call MPAS_pool_get_subpool(blockPtr % structs, "velocity_solver", velocitySolverPool) - call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11) - call MPAS_pool_get_array(velocityWeakPool, "strain22", strain22) - call MPAS_pool_get_array(velocityWeakPool, "strain12", strain12) + call MPAS_pool_get_array(velocityWeakPool, "strain11", strain11) + call MPAS_pool_get_array(velocityWeakPool, "strain22", strain22) + call MPAS_pool_get_array(velocityWeakPool, "strain12", strain12) - call MPAS_pool_get_array(velocitySolverPool, "divergence", divergence) - call MPAS_pool_get_array(velocitySolverPool, "shear", shear) + call MPAS_pool_get_array(velocitySolverPool, "divergence", divergence) + call MPAS_pool_get_array(velocitySolverPool, "shear", shear) - allocate(Delta(nCells)) + allocate(Delta(nCells)) + + do iCell = 1, nCells - do iCell = 1, nCells + if (solveStress(iCell) == 1) then - if (solveStress(iCell) == 1) then + strainDivergence = strain11(iCell) + strain22(iCell) + strainTension = strain11(iCell) - strain22(iCell) + strainShearing = strain12(iCell) * 2.0_RKIND - strainDivergence = strain11(iCell) + strain22(iCell) - strainTension = strain11(iCell) - strain22(iCell) - strainShearing = strain12(iCell) * 2.0_RKIND + Delta(iCell) = sqrt(strainDivergence**2 + (strainTension**2 + strainShearing**2) / eccentricitySquared) - Delta(iCell) = sqrt(strainDivergence**2 + (strainTension**2 + strainShearing**2) / eccentricitySquared) + divergence(iCell) = strainDivergence + shear(iCell) = sqrt(strainTension**2 + strainShearing**2) - divergence(iCell) = strainDivergence - shear(iCell) = sqrt(strainTension**2 + strainShearing**2) + else - else + divergence(iCell) = 0.0_RKIND + shear(iCell) = 0.0_RKIND - divergence(iCell) = 0.0_RKIND - shear(iCell) = 0.0_RKIND + endif - endif + enddo ! iCell - enddo ! iCell + ! ridging parameters + call MPAS_pool_get_config(blockPtr % configs, "config_use_column_package", config_use_column_package) - ! ridging parameters - call MPAS_pool_get_config(block % configs, "config_use_column_package", config_use_column_package) + if (config_use_column_package) then - if (config_use_column_package) then + call MPAS_pool_get_subpool(blockPtr % structs, "ridging", ridgingPool) - call MPAS_pool_get_subpool(block % structs, "ridging", ridgingPool) + call MPAS_pool_get_array(ridgingPool, "ridgeConvergence", ridgeConvergence) + call MPAS_pool_get_array(ridgingPool, "ridgeShear", ridgeShear) - call MPAS_pool_get_array(ridgingPool, "ridgeConvergence", ridgeConvergence) - call MPAS_pool_get_array(ridgingPool, "ridgeShear", ridgeShear) + do iCell = 1, nCells - do iCell = 1, nCells + if (solveStress(iCell) == 1) then - if (solveStress(iCell) == 1) then + ridgeConvergence(iCell) = -min(divergence(iCell),0.0_RKIND) + ridgeShear(iCell) = 0.5_RKIND * (Delta(iCell) - abs(divergence(iCell))) - ridgeConvergence(iCell) = -min(divergence(iCell),0.0_RKIND) - ridgeShear(iCell) = 0.5_RKIND * (Delta(iCell) - abs(divergence(iCell))) + else - else + ridgeConvergence(iCell) = 0.0_RKIND + ridgeShear(iCell) = 0.0_RKIND - ridgeConvergence(iCell) = 0.0_RKIND - ridgeShear(iCell) = 0.0_RKIND + endif - endif + enddo ! iCell - enddo ! iCell + endif ! config_use_column_package - endif ! config_use_column_package + ! cleanup + deallocate(Delta) - ! cleanup - deallocate(Delta) + blockPtr => blockPtr % next + enddo end subroutine seaice_final_divergence_shear_weak diff --git a/components/mpas-seaice/src/shared/mpas_seaice_wachspress_basis.F b/components/mpas-seaice/src/shared/mpas_seaice_wachspress_basis.F new file mode 100644 index 000000000000..7a390e86cdb5 --- /dev/null +++ b/components/mpas-seaice/src/shared/mpas_seaice_wachspress_basis.F @@ -0,0 +1,580 @@ +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_wachspress_basis +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 4th November 2022 +!> \details +!> +! +!----------------------------------------------------------------------- + +module seaice_wachspress_basis + + use mpas_derived_types + + implicit none + + private + save + + public :: & + seaice_calc_wachspress_coefficients, & + seaice_wachspress_indexes, & + seaice_wachspress_basis_function, & + seaice_wachspress_basis_derivative + +contains + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_calc_wachspress_coefficients +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine seaice_calc_wachspress_coefficients(& + wachspressKappa, & + wachspressA, & + wachspressB, & + nCells, & + nEdgesOnCell, & + xLocal, & + yLocal)!{{{ + + real(kind=RKIND), dimension(:,:,:), intent(out) :: & + wachspressKappa !< Output: + + real(kind=RKIND), dimension(:,:), intent(out) :: & + wachspressA, & !< Output: + wachspressB !< Output: + + integer, intent(in) :: & + nCells !< Input: + + integer, dimension(:), intent(in) :: & + nEdgesOnCell !< Input: + + real(kind=RKIND), dimension(:,:), intent(in) :: & + xLocal, & !< Input: + yLocal !< Input: + + integer :: & + iCell, & + iVertex, & + i0, & + i1, & + i2, & + jVertex + + ! loop over cells + do iCell = 1, nCells + + ! loop over vertices + do iVertex = 1, nEdgesOnCell(iCell) + + ! end points of line segment + i1 = iVertex - 1 + i2 = iVertex + if (i1 < 1) i1 = i1 + nEdgesOnCell(iCell) + + ! solve for the line segment equation + wachspressA(iVertex, iCell) = & + (yLocal(i2,iCell) - yLocal(i1,iCell)) / (xLocal(i1,iCell) * yLocal(i2,iCell) - xLocal(i2,iCell) * yLocal(i1,iCell)) + wachspressB(iVertex, iCell) = & + (xLocal(i1,iCell) - xLocal(i2,iCell)) / (xLocal(i1,iCell) * yLocal(i2,iCell) - xLocal(i2,iCell) * yLocal(i1,iCell)) + + enddo ! iVertex + + ! loop over vertices + do iVertex = 1, nEdgesOnCell(iCell) + + ! determine kappa + wachspressKappa(1,iVertex,iCell) = 1.0_RKIND + + do jVertex = 2, nEdgesOnCell(iCell) + + ! previous, this and next vertex + i0 = jVertex - 1 + i1 = jVertex + i2 = jVertex + 1 + if (i2 > nEdgesOnCell(iCell)) i2 = i2 - nEdgesOnCell(iCell) + + wachspressKappa(jVertex,iVertex,iCell) = wachspressKappa(jVertex-1,iVertex,iCell) * & + (wachspressA(i2,iCell) * (xLocal(i0,iCell) - xLocal(i1,iCell)) + & + wachspressB(i2,iCell) * (yLocal(i0,iCell) - yLocal(i1,iCell))) / & + (wachspressA(i0,iCell) * (xLocal(i1,iCell) - xLocal(i0,iCell)) + & + wachspressB(i0,iCell) * (yLocal(i1,iCell) - yLocal(i0,iCell))) + + enddo ! jVertex + + enddo ! iVertex + + enddo ! iCell + + end subroutine seaice_calc_wachspress_coefficients!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_wachspress_indexes +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine seaice_wachspress_indexes(& + nEdgesOnCell, & + nEdgesOnCellSubset, & + vertexIndexSubset) + + use seaice_mesh, only: & + seaice_wrapped_index + + integer, intent(in) :: & + nEdgesOnCell !< Input: + + integer, dimension(:), intent(out) :: & + nEdgesOnCellSubset !< Output: + + integer, dimension(:,:), intent(out) :: & + vertexIndexSubset !< Output: + + integer :: & + jVertex, & + kVertex, & + i1, i2 + + do jVertex = 1, nEdgesOnCell + + i1 = jVertex + i2 = seaice_wrapped_index(jVertex + 1, nEdgesOnCell) + + nEdgesOnCellSubset(jVertex) = 0 + + do kVertex = 1, nEdgesOnCell + + if (kVertex /= i1 .and. kVertex /= i2) then + nEdgesOnCellSubset(jVertex) = nEdgesOnCellSubset(jVertex) + 1 + vertexIndexSubset(jVertex,nEdgesOnCellSubset(jVertex)) = kVertex + endif + + enddo ! kVertex + + enddo ! jVertex + + end subroutine seaice_wachspress_indexes + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_wachspress_basis_function +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine seaice_wachspress_basis_function(& + nEdgesOnCell, & + iVertex, & + x, & + y, & + wachspressKappa, & + wachspressA, & + wachspressB, & + nEdgesOnCellSubset, & + vertexIndexSubset, & + wachpress)!{{{ + + use seaice_mesh, only: & + seaice_wrapped_index + + integer, intent(in) :: & + nEdgesOnCell, & !< Input: + iVertex !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + x, & !< Input: + y !< Input: + + real(kind=RKIND), dimension(:,:), intent(in) :: & + wachspressKappa !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + wachspressA, & !< Input: + wachspressB !< Input: + + integer, dimension(:), intent(in) :: & + nEdgesOnCellSubset !< Input: + + integer, dimension(:,:), intent(in) :: & + vertexIndexSubset !< Input: + + real(kind=RKIND), dimension(:), intent(out) :: & + wachpress !< Output: + + real(kind=RKIND), dimension(size(x),nEdgesOnCell) :: & + numerator + + real(kind=RKIND), dimension(size(x)) :: & + denominator, & + edgeEquation + + integer :: & + jVertex + + ! sum over numerators to get denominator + denominator(:) = 0.0_RKIND + + do jVertex = 1, nEdgesOnCell + + call wachspress_numerator(& + nEdgesOnCell, jVertex, iVertex, x(:), y(:), & + wachspressKappa, wachspressA, wachspressB, & + nEdgesOnCellSubset, vertexIndexSubset, & + edgeEquation(:), & + numerator(:,jVertex)) + + denominator(:) = denominator(:) + numerator(:,jVertex) + + enddo ! jVertex + + wachpress(:) = numerator(:,iVertex) / denominator(:) + + end subroutine seaice_wachspress_basis_function!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! seaice_wachspress_basis_derivative +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine seaice_wachspress_basis_derivative(& + nEdgesOnCell, & + iVertex, & + x, & + y, & + wachspressKappa, & + wachspressA, & + wachspressB, & + nEdgesOnCellSubset, & + vertexIndexSubset, & + wachspressU, & + wachspressV)!{{{ + + integer, intent(in) :: & + nEdgesOnCell, & !< Input: + iVertex !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + x, & !< Input: + y !< Input: + + real(kind=RKIND), dimension(:,:), intent(in) :: & + wachspressKappa !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + wachspressA, & !< Input: + wachspressB !< Input: + + integer, dimension(:), intent(in) :: & + nEdgesOnCellSubset !< Input: + + integer, dimension(:,:), intent(in) :: & + vertexIndexSubset !< Input: + + real(kind=RKIND), dimension(:), intent(out) :: & + wachspressU, & !< Output: + wachspressV !< Output: + + real(kind=RKIND), dimension(size(x),2,nEdgesOnCell) :: & + derivative + + real(kind=RKIND), dimension(size(x),nEdgesOnCell) :: & + numerator + + real(kind=RKIND), dimension(size(x),2) :: & + sum_of_derivatives, & + sum_of_products, & + product + + real(kind=RKIND), dimension(size(x)) :: & + denominator, & + edgeEquation + + integer :: & + jVertex + + ! sum over numerators to get denominator + denominator(:) = 0.0_RKIND + sum_of_derivatives(:,:) = 0.0_RKIND + + do jVertex = 1, nEdgesOnCell + + call wachspress_numerator(& + nEdgesOnCell, jVertex, iVertex, x(:), y(:), & + wachspressKappa, wachspressA, wachspressB, & + nEdgesOnCellSubset, vertexIndexSubset, & + edgeEquation, & + numerator(:,jVertex)) + + denominator(:) = denominator(:) + numerator(:,jVertex) + + call wachspress_numerator_derivative(& + nEdgesOnCell, jVertex, iVertex, x(:), y(:), & + wachspressKappa, wachspressA, wachspressB, & + nEdgesOnCellSubset, vertexIndexSubset, & + sum_of_products, product, edgeEquation, & + derivative(:,:,jVertex)) + + sum_of_derivatives(:,:) = sum_of_derivatives(:,:) + derivative(:,:,jVertex) + + enddo ! jVertex + + wachspressU(:) = derivative(:,1,iVertex) / denominator(:) - & + (numerator(:,iVertex) / denominator(:)**2) * sum_of_derivatives(:,1) + wachspressV(:) = derivative(:,2,iVertex) / denominator(:) - & + (numerator(:,iVertex) / denominator(:)**2) * sum_of_derivatives(:,2) + + end subroutine seaice_wachspress_basis_derivative!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! wachspress_numerator +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine wachspress_numerator(& + nEdgesOnCell, & + jVertex, & + iVertex, & + x, & + y, & + wachspressKappa, & + wachspressA, & + wachspressB, & + nEdgesOnCellSubset, & + vertexIndexSubset, & + edgeEquation, & + numerator)!{{{ + + integer, intent(in) :: & + nEdgesOnCell, & !< Input: + jVertex, & !< Input: + iVertex !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + x, & !< Input: + y !< Input: + + real(kind=RKIND), dimension(:,:), intent(in) :: & + wachspressKappa !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + wachspressA, & !< Input: + wachspressB !< Input: + + integer, dimension(:), intent(in) :: & + nEdgesOnCellSubset !< Input: + + integer, dimension(:,:), intent(in) :: & + vertexIndexSubset !< Input: + + real(kind=RKIND), dimension(:), intent(inout) :: & + edgeEquation + + real(kind=RKIND), dimension(:), intent(out) :: & + numerator !< Output: + + integer :: & + kVertex + + numerator(:) = 1.0_RKIND + + do kVertex = 1, nEdgesOnCellSubset(jVertex) + + call wachspress_edge_equation(& + x(:), y(:), & + wachspressA(vertexIndexSubset(jVertex,kVertex)), & + wachspressB(vertexIndexSubset(jVertex,kVertex)), & + edgeEquation(:)) + + numerator(:) = numerator(:) * edgeEquation(:) + + enddo ! jVertex + + numerator(:) = numerator(:) * wachspressKappa(jVertex,iVertex) + + end subroutine wachspress_numerator!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! wachspress_numerator_derivative +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine wachspress_numerator_derivative(& + nEdgesOnCell, & + jVertex, & + iVertex, & + x, & + y, & + wachspressKappa, & + wachspressA, & + wachspressB, & + nEdgesOnCellSubset, & + vertexIndexSubset, & + sum_of_products, & + product, & + edgeEquation, & + derivative)!{{{ + + integer, intent(in) :: & + nEdgesOnCell, & !< Input: + jVertex, & !< Input: + iVertex !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + x, & !< Input: + y !< Input: + + real(kind=RKIND), dimension(:,:), intent(in) :: & + wachspressKappa !< Input: + + real(kind=RKIND), dimension(:), intent(in) :: & + wachspressA, & !< Input: + wachspressB !< Input: + + integer, dimension(:), intent(in) :: & + nEdgesOnCellSubset !< Input: + + integer, dimension(:,:), intent(in) :: & + vertexIndexSubset !< Input: + + real(kind=RKIND), dimension(:,:), intent(out) :: & + derivative !< Output: + + real(kind=RKIND), dimension(:,:), intent(inout) :: & + sum_of_products, & !< Input/Output: + product !< Input/Output: + + real(kind=RKIND), dimension(:), intent(inout) :: & + edgeEquation !< Input/Output: + + integer :: & + kVertex, & + lVertex + + sum_of_products(:,:) = 0.0_RKIND + + do kVertex = 1, nEdgesOnCellSubset(jVertex) + + product(:,:) = 1.0_RKIND + + ! lVertex < kVertex + do lVertex = 1, kVertex - 1 + + call wachspress_edge_equation(& + x(:), y(:), & + wachspressA(vertexIndexSubset(jVertex,lVertex)), & + wachspressB(vertexIndexSubset(jVertex,lVertex)), & + edgeEquation(:)) + + product(:,1) = product(:,1) * edgeEquation(:) + product(:,2) = product(:,2) * edgeEquation(:) + + enddo ! lVertex + + ! lVertex == kVertex + product(:,1) = product(:,1) * (-wachspressA(vertexIndexSubset(jVertex,kVertex))) + product(:,2) = product(:,2) * (-wachspressB(vertexIndexSubset(jVertex,kVertex))) + + ! lVertex > kVertex + do lVertex = kVertex + 1, nEdgesOnCellSubset(jVertex) + + call wachspress_edge_equation(& + x(:), y(:), & + wachspressA(vertexIndexSubset(jVertex,lVertex)), & + wachspressB(vertexIndexSubset(jVertex,lVertex)), & + edgeEquation(:)) + + product(:,1) = product(:,1) * edgeEquation(:) + product(:,2) = product(:,2) * edgeEquation(:) + + enddo ! lVertex + + sum_of_products(:,:) = sum_of_products(:,:) + product(:,:) + + enddo ! jVertex + + derivative(:,:) = sum_of_products(:,:) * wachspressKappa(jVertex,iVertex) + + end subroutine wachspress_numerator_derivative!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! wachspress_edge_equation +! +!> \brief +!> \author Adrian K. Turner, LANL +!> \date 2013-2014 +!> \details +!> +! +!----------------------------------------------------------------------- + + subroutine wachspress_edge_equation(& + x, & + y, & + wachspressA, & + wachspressB, & + edgeEquation) + + real(kind=RKIND), dimension(:), intent(in) :: & + x, & !< Input: + y !< Input: + + real(kind=RKIND), intent(in) :: & + wachspressA, & !< Input: + wachspressB !< Input: + + real(kind=RKIND), dimension(:), intent(out) :: & + edgeEquation !< Output: + + edgeEquation(:) = 1.0_RKIND - wachspressA * x(:) - wachspressB * y(:) + + end subroutine wachspress_edge_equation!}}} + +!----------------------------------------------------------------------- + +end module seaice_wachspress_basis