From 2540695698e1a733af9ce74609365faf4cb35d66 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 16 Sep 2021 08:28:30 -0400 Subject: [PATCH] Update CICE for latest Consortium master (#38) * Implement advanced snow physics in icepack and CICE * Fix time-stamping of CICE history files * Fix CICE history file precision --- .../cicedynB/analysis/ice_diagnostics.F90 | 85 +- .../cicedynB/analysis/ice_diagnostics_bgc.F90 | 15 +- cicecore/cicedynB/analysis/ice_history.F90 | 226 +- .../cicedynB/analysis/ice_history_fsd.F90 | 2 +- .../cicedynB/analysis/ice_history_pond.F90 | 8 +- .../cicedynB/analysis/ice_history_shared.F90 | 99 +- .../cicedynB/analysis/ice_history_snow.F90 | 430 ++ cicecore/cicedynB/dynamics/ice_dyn_eap.F90 | 12 +- cicecore/cicedynB/dynamics/ice_dyn_evp.F90 | 227 +- cicecore/cicedynB/dynamics/ice_dyn_evp_1d.F90 | 3906 ++++++++--------- cicecore/cicedynB/dynamics/ice_dyn_shared.F90 | 47 +- cicecore/cicedynB/dynamics/ice_dyn_vp.F90 | 44 +- .../dynamics/ice_transport_driver.F90 | 25 +- cicecore/cicedynB/general/ice_flux.F90 | 7 + cicecore/cicedynB/general/ice_forcing.F90 | 209 +- cicecore/cicedynB/general/ice_init.F90 | 304 +- cicecore/cicedynB/general/ice_step_mod.F90 | 220 +- .../infrastructure/comm/mpi/ice_boundary.F90 | 133 +- .../comm/mpi/ice_gather_scatter.F90 | 138 +- .../comm/serial/ice_boundary.F90 | 133 +- .../comm/serial/ice_gather_scatter.F90 | 40 +- .../cicedynB/infrastructure/ice_domain.F90 | 2 +- cicecore/cicedynB/infrastructure/ice_grid.F90 | 54 +- .../infrastructure/ice_read_write.F90 | 765 +++- .../io/io_binary/ice_restart.F90 | 61 +- .../io/io_netcdf/ice_history_write.F90 | 357 +- .../io/io_netcdf/ice_restart.F90 | 15 +- .../io/io_pio2/ice_history_write.F90 | 448 +- .../infrastructure/io/io_pio2/ice_pio.F90 | 66 +- .../infrastructure/io/io_pio2/ice_restart.F90 | 23 +- .../drivers/nuopc/cmeps/ice_import_export.F90 | 2 +- .../drivers/standalone/cice/CICE_InitMod.F90 | 52 +- .../drivers/standalone/cice/CICE_RunMod.F90 | 27 +- cicecore/drivers/unittest/bcstchk/bcstchk.F90 | 32 +- cicecore/drivers/unittest/calchk/calchk.F90 | 33 +- .../unittest/helloworld/helloworld.F90 | 5 +- cicecore/drivers/unittest/sumchk/sumchk.F90 | 7 +- cicecore/shared/ice_arrays_column.F90 | 11 + cicecore/shared/ice_calendar.F90 | 33 +- cicecore/shared/ice_fileunits.F90 | 6 + cicecore/shared/ice_init_column.F90 | 77 +- cicecore/shared/ice_restart_column.F90 | 91 +- cicecore/version.txt | 2 +- configuration/scripts/cice.batch.csh | 17 + configuration/scripts/cice.launch.csh | 6 + configuration/scripts/cice.run.setup.csh | 2 +- configuration/scripts/ice_in | 41 +- .../scripts/machines/Macros.gaea_intel | 56 + .../scripts/machines/Macros.onyx_cray | 2 +- .../scripts/machines/Macros.onyx_gnu | 2 +- configuration/scripts/machines/env.gaea_intel | 34 + configuration/scripts/machines/env.onyx_cray | 13 +- configuration/scripts/machines/env.onyx_gnu | 13 +- configuration/scripts/machines/env.onyx_intel | 13 +- configuration/scripts/options/set_nml.alt04 | 2 +- configuration/scripts/options/set_nml.evp1d | 1 + configuration/scripts/options/set_nml.gx1prod | 4 +- .../scripts/options/set_nml.gx1prod15 | 19 + .../scripts/options/set_nml.histinst | 1 + configuration/scripts/options/set_nml.kevp102 | 1 - configuration/scripts/options/set_nml.qc | 10 +- .../scripts/options/set_nml.run10year | 7 + .../scripts/options/set_nml.snw30percent | 5 + .../scripts/options/set_nml.snwITDrdg | 10 + .../scripts/options/set_nml.snwgrain | 15 + configuration/scripts/tests/QC/cice.t-test.py | 9 + configuration/scripts/tests/base_suite.ts | 9 +- configuration/scripts/tests/comparelog.csh | 4 +- configuration/scripts/tests/io_suite.ts | 6 + configuration/scripts/tests/prod_suite.ts | 4 + configuration/scripts/tests/reprosum_suite.ts | 1 + .../scripts/tests/test_unittest.script | 27 +- doc/source/cice_index.rst | 34 +- doc/source/conf.py | 4 +- doc/source/developer_guide/dg_driver.rst | 11 +- doc/source/developer_guide/dg_dynamics.rst | 38 +- doc/source/developer_guide/dg_forcing.rst | 2 +- doc/source/science_guide/sg_dynamics.rst | 171 +- doc/source/science_guide/sg_tracers.rst | 6 +- doc/source/user_guide/figures/CICE_Bgrid.png | Bin 0 -> 53070 bytes doc/source/user_guide/ug_case_settings.rst | 39 +- doc/source/user_guide/ug_implementation.rst | 39 +- doc/source/user_guide/ug_testing.rst | 9 + doc/source/user_guide/ug_troubleshooting.rst | 3 - icepack | 2 +- 85 files changed, 5657 insertions(+), 3514 deletions(-) create mode 100644 cicecore/cicedynB/analysis/ice_history_snow.F90 mode change 100644 => 100755 cicecore/cicedynB/dynamics/ice_dyn_evp_1d.F90 mode change 100644 => 100755 cicecore/cicedynB/dynamics/ice_dyn_shared.F90 create mode 100644 configuration/scripts/machines/Macros.gaea_intel create mode 100755 configuration/scripts/machines/env.gaea_intel create mode 100644 configuration/scripts/options/set_nml.evp1d create mode 100644 configuration/scripts/options/set_nml.gx1prod15 create mode 100644 configuration/scripts/options/set_nml.histinst delete mode 100644 configuration/scripts/options/set_nml.kevp102 create mode 100644 configuration/scripts/options/set_nml.run10year create mode 100644 configuration/scripts/options/set_nml.snw30percent create mode 100644 configuration/scripts/options/set_nml.snwITDrdg create mode 100644 configuration/scripts/options/set_nml.snwgrain create mode 100644 configuration/scripts/tests/prod_suite.ts create mode 100755 doc/source/user_guide/figures/CICE_Bgrid.png diff --git a/cicecore/cicedynB/analysis/ice_diagnostics.F90 b/cicecore/cicedynB/analysis/ice_diagnostics.F90 index 6b9b32301..d4e7066fb 100644 --- a/cicecore/cicedynB/analysis/ice_diagnostics.F90 +++ b/cicecore/cicedynB/analysis/ice_diagnostics.F90 @@ -14,6 +14,7 @@ module ice_diagnostics use ice_communicate, only: my_task, master_task use ice_constants, only: c0, c1 use ice_calendar, only: istep1 + use ice_domain_size, only: nslyr use ice_fileunits, only: nu_diag use ice_fileunits, only: flush_fileunit use ice_exit, only: abort_ice @@ -142,15 +143,19 @@ subroutine runtime_diags (dt) i, j, k, n, iblk, nc, & ktherm, & nt_tsfc, nt_aero, nt_fbri, nt_apnd, nt_hpnd, nt_fsd, & - nt_isosno, nt_isoice + nt_isosno, nt_isoice, nt_rsnw, nt_rhos, nt_smice, nt_smliq logical (kind=log_kind) :: & - tr_pond_topo, tr_brine, tr_iso, tr_aero, calc_Tsfc, tr_fsd + tr_pond_topo, tr_brine, tr_iso, tr_aero, calc_Tsfc, tr_fsd, & + tr_snow, snwgrain real (kind=dbl_kind) :: & rhow, rhos, rhoi, puny, awtvdr, awtidr, awtvdf, awtidf, & rhofresh, lfresh, lvap, ice_ref_salinity, Tffresh + character (len=char_len) :: & + snwredist + ! hemispheric state quantities real (kind=dbl_kind) :: & umaxn, hmaxn, shmaxn, arean, snwmxn, extentn, shmaxnt, & @@ -190,7 +195,8 @@ subroutine runtime_diags (dt) pTsfc, pevap, pfswabs, pflwout, pflat, pfsens, & pfsurf, pfcondtop, psst, psss, pTf, hiavg, hsavg, hbravg, & pfhocn, psalt, fsdavg, & - pmeltt, pmeltb, pmeltl, psnoice, pdsnow, pfrazil, pcongel + pmeltt, pmeltb, pmeltl, psnoice, pdsnow, pfrazil, pcongel, & + prsnwavg, prhosavg, psmicetot, psmliqtot, psmtot real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & work1, work2 @@ -199,15 +205,19 @@ subroutine runtime_diags (dt) call icepack_query_parameters(ktherm_out=ktherm, calc_Tsfc_out=calc_Tsfc) call icepack_query_tracer_flags(tr_brine_out=tr_brine, tr_aero_out=tr_aero, & - tr_pond_topo_out=tr_pond_topo, tr_fsd_out=tr_fsd, tr_iso_out=tr_iso) + tr_pond_topo_out=tr_pond_topo, tr_fsd_out=tr_fsd, tr_iso_out=tr_iso, & + tr_snow_out=tr_snow) call icepack_query_tracer_indices(nt_fbri_out=nt_fbri, nt_Tsfc_out=nt_Tsfc, & nt_aero_out=nt_aero, nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, & - nt_fsd_out=nt_fsd,nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice) + nt_fsd_out=nt_fsd,nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice, & + nt_rsnw_out=nt_rsnw, nt_rhos_out=nt_rhos, & + nt_smice_out=nt_smice, nt_smliq_out=nt_smliq) call icepack_query_parameters(Tffresh_out=Tffresh, rhos_out=rhos, & rhow_out=rhow, rhoi_out=rhoi, puny_out=puny, & awtvdr_out=awtvdr, awtidr_out=awtidr, awtvdf_out=awtvdf, awtidf_out=awtidf, & rhofresh_out=rhofresh, lfresh_out=lfresh, lvap_out=lvap, & - ice_ref_salinity_out=ice_ref_salinity) + ice_ref_salinity_out=ice_ref_salinity,snwredist_out=snwredist, & + snwgrain_out=snwgrain) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) @@ -825,6 +835,27 @@ subroutine runtime_diags (dt) enddo endif endif + if (tr_snow) then ! snow tracer quantities + prsnwavg (n) = c0 ! avg snow grain radius + prhosavg (n) = c0 ! avg snow density + psmicetot(n) = c0 ! total mass of ice in snow (kg/m2) + psmliqtot(n) = c0 ! total mass of liquid in snow (kg/m2) + psmtot (n) = c0 ! total mass of snow volume (kg/m2) + if (vsno(i,j,iblk) > c0) then + do k = 1, nslyr + prsnwavg (n) = prsnwavg (n) + trcr(i,j,nt_rsnw +k-1,iblk) ! snow grain radius + prhosavg (n) = prhosavg (n) + trcr(i,j,nt_rhos +k-1,iblk) ! compacted snow density + psmicetot(n) = psmicetot(n) + trcr(i,j,nt_smice+k-1,iblk) * vsno(i,j,iblk) + psmliqtot(n) = psmliqtot(n) + trcr(i,j,nt_smliq+k-1,iblk) * vsno(i,j,iblk) + end do + endif + psmtot (n) = rhos * vsno(i,j,iblk) ! mass of ice in standard density snow + prsnwavg (n) = prsnwavg (n) / real(nslyr,kind=dbl_kind) ! snow grain radius + prhosavg (n) = prhosavg (n) / real(nslyr,kind=dbl_kind) ! compacted snow density + psmicetot(n) = psmicetot(n) / real(nslyr,kind=dbl_kind) ! mass of ice in snow + psmliqtot(n) = psmliqtot(n) / real(nslyr,kind=dbl_kind) ! mass of liquid in snow + end if + psalt(n) = c0 if (vice(i,j,iblk) /= c0) psalt(n) = work2(i,j,iblk)/vice(i,j,iblk) pTsfc(n) = trcr(i,j,nt_Tsfc,iblk) ! ice/snow sfc temperature pevap(n) = evap(i,j,iblk)*dt/rhoi ! sublimation/condensation @@ -876,6 +907,11 @@ subroutine runtime_diags (dt) call broadcast_scalar(pmeltl (n), pmloc(n)) call broadcast_scalar(psnoice (n), pmloc(n)) call broadcast_scalar(pdsnow (n), pmloc(n)) + call broadcast_scalar(psmtot (n), pmloc(n)) + call broadcast_scalar(prsnwavg (n), pmloc(n)) + call broadcast_scalar(prhosavg (n), pmloc(n)) + call broadcast_scalar(psmicetot(n), pmloc(n)) + call broadcast_scalar(psmliqtot(n), pmloc(n)) call broadcast_scalar(pfrazil (n), pmloc(n)) call broadcast_scalar(pcongel (n), pmloc(n)) call broadcast_scalar(pdhi (n), pmloc(n)) @@ -1059,6 +1095,26 @@ subroutine runtime_diags (dt) write(nu_diag,900) 'effective dhi (m) = ',pdhi(1),pdhi(2) write(nu_diag,900) 'effective dhs (m) = ',pdhs(1),pdhs(2) write(nu_diag,900) 'intnl enrgy chng(W/m^2)= ',pde (1),pde (2) + + if (tr_snow) then + if (trim(snwredist) /= 'none') then + write(nu_diag,900) 'avg snow density(kg/m3)= ',prhosavg(1) & + ,prhosavg(2) + endif + if (snwgrain) then + write(nu_diag,900) 'avg snow grain radius = ',prsnwavg(1) & + ,prsnwavg(2) + write(nu_diag,900) 'mass ice in snow(kg/m2)= ',psmicetot(1) & + ,psmicetot(2) + write(nu_diag,900) 'mass liq in snow(kg/m2)= ',psmliqtot(1) & + ,psmliqtot(2) + write(nu_diag,900) 'mass std snow (kg/m2)= ',psmtot(1) & + ,psmtot(2) + write(nu_diag,900) 'max ice+liq (kg/m2)= ',rhow * hsavg(1) & + ,rhow * hsavg(2) + endif + endif + write(nu_diag,*) '----------ocn----------' write(nu_diag,900) 'sst (C) = ',psst(1),psst(2) write(nu_diag,900) 'sss (ppt) = ',psss(1),psss(2) @@ -1596,19 +1652,21 @@ subroutine print_state(plabel,i,j,iblk) rad_to_deg, puny, rhoi, lfresh, rhos, cp_ice integer (kind=int_kind) :: n, k, nt_Tsfc, nt_qice, nt_qsno, nt_fsd, & - nt_isosno, nt_isoice, nt_sice + nt_isosno, nt_isoice, nt_sice, nt_smice, nt_smliq - logical (kind=log_kind) :: tr_fsd, tr_iso + logical (kind=log_kind) :: tr_fsd, tr_iso, tr_snow type (block) :: & this_block ! block information for current block character(len=*), parameter :: subname = '(print_state)' - call icepack_query_tracer_flags(tr_fsd_out=tr_fsd, tr_iso_out=tr_iso) + call icepack_query_tracer_flags(tr_fsd_out=tr_fsd, tr_iso_out=tr_iso, & + tr_snow_out=tr_snow) call icepack_query_tracer_indices(nt_Tsfc_out=nt_Tsfc, nt_qice_out=nt_qice, & nt_qsno_out=nt_qsno, nt_sice_out=nt_sice, nt_fsd_out=nt_fsd, & - nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice) + nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice, & + nt_smice_out=nt_smice, nt_smliq_out=nt_smliq) call icepack_query_parameters( & rad_to_deg_out=rad_to_deg, puny_out=puny, rhoi_out=rhoi, lfresh_out=lfresh, & rhos_out=rhos, cp_ice_out=cp_ice) @@ -1638,8 +1696,11 @@ subroutine print_state(plabel,i,j,iblk) endif write(nu_diag,*) 'Tsfcn',trcrn(i,j,nt_Tsfc,n,iblk) if (tr_fsd) write(nu_diag,*) 'afsdn',trcrn(i,j,nt_fsd,n,iblk) ! fsd cat 1 -! if (tr_iso) write(nu_diag,*) 'isosno',trcrn(i,j,nt_isosno,n,iblk) ! isotopes in snow -! if (tr_iso) write(nu_diag,*) 'isoice',trcrn(i,j,nt_isoice,n,iblk) ! isotopes in ice +! layer 1 diagnostics +! if (tr_iso) write(nu_diag,*) 'isosno',trcrn(i,j,nt_isosno,n,iblk) ! isotopes in snow +! if (tr_iso) write(nu_diag,*) 'isoice',trcrn(i,j,nt_isoice,n,iblk) ! isotopes in ice +! if (tr_snow) write(nu_diag,*) 'smice', trcrn(i,j,nt_smice, n,iblk) ! ice mass in snow +! if (tr_snow) write(nu_diag,*) 'smliq', trcrn(i,j,nt_smliq, n,iblk) ! liquid mass in snow write(nu_diag,*) ' ' ! dynamics (transport and/or ridging) causes the floe size distribution to become non-normal diff --git a/cicecore/cicedynB/analysis/ice_diagnostics_bgc.F90 b/cicecore/cicedynB/analysis/ice_diagnostics_bgc.F90 index fa965dfe0..74485a5e2 100644 --- a/cicecore/cicedynB/analysis/ice_diagnostics_bgc.F90 +++ b/cicecore/cicedynB/analysis/ice_diagnostics_bgc.F90 @@ -937,19 +937,18 @@ subroutine zsal_diags enddo if (aice(i,j,iblk) > c0) & psice_rho(n) = psice_rho(n)/aice(i,j,iblk) - if (tr_brine .and. aice(i,j,iblk) > c0) & + if (tr_brine .and. aice(i,j,iblk) > c0) then phinS(n) = trcr(i,j,nt_fbri,iblk)*vice(i,j,iblk)/aice(i,j,iblk) - - if (aicen(i,j,1,iblk)> c0) then - if (tr_brine) phinS1(n) = trcrn(i,j,nt_fbri,1,iblk) & - * vicen(i,j,1,iblk)/aicen(i,j,1,iblk) + phbrn(n) = (c1 - rhosi/rhow)*vice(i,j,iblk)/aice(i,j,iblk) & + - rhos/rhow *vsno(i,j,iblk)/aice(i,j,iblk) + endif + if (tr_brine .and. aicen(i,j,1,iblk)> c0) then + phinS1(n) = trcrn(i,j,nt_fbri,1,iblk) & + * vicen(i,j,1,iblk)/aicen(i,j,1,iblk) pdh_top1(n) = dhbr_top(i,j,1,iblk) pdh_bot1(n) = dhbr_bot(i,j,1,iblk) pdarcy_V1(n) = darcy_V(i,j,1,iblk) endif - if (tr_brine .AND. aice(i,j,iblk) > c0) & - phbrn(n) = (c1 - rhosi/rhow)*vice(i,j,iblk)/aice(i,j,iblk) & - - rhos/rhow *vsno(i,j,iblk)/aice(i,j,iblk) do k = 1, nblyr+1 pbTiz(n,k) = c0 piDin(n,k) = c0 diff --git a/cicecore/cicedynB/analysis/ice_history.F90 b/cicecore/cicedynB/analysis/ice_history.F90 index f91562449..0ecc2ee5a 100644 --- a/cicecore/cicedynB/analysis/ice_history.F90 +++ b/cicecore/cicedynB/analysis/ice_history.F90 @@ -32,7 +32,7 @@ module ice_history use ice_kinds_mod use ice_communicate, only: my_task, master_task use ice_constants, only: c0, c1, c2, c100, c360, c180, & - p001, p25, p5, mps_to_cmpdy, kg_to_g, spval + p001, p25, p5, mps_to_cmpdy, kg_to_g, spval_dbl use ice_fileunits, only: nu_nml, nml_filename, nu_diag, & get_fileunit, release_fileunit, flush_fileunit use ice_exit, only: abort_ice @@ -67,10 +67,11 @@ subroutine init_hist (dt) histfreq_n, nstreams use ice_domain_size, only: max_blocks, max_nstrm, nilyr, nslyr, nblyr, ncat, nfsd use ice_dyn_shared, only: kdyn - use ice_flux, only: mlt_onset, frz_onset, albcnt + use ice_flux, only: mlt_onset, frz_onset, albcnt, snwcnt use ice_history_shared ! everything use ice_history_mechred, only: init_hist_mechred_2D, init_hist_mechred_3Dc use ice_history_pond, only: init_hist_pond_2D, init_hist_pond_3Dc + use ice_history_snow, only: init_hist_snow_2D, init_hist_snow_3Dc use ice_history_bgc, only:init_hist_bgc_2D, init_hist_bgc_3Dc, & init_hist_bgc_3Db, init_hist_bgc_3Da use ice_history_drag, only: init_hist_drag_2D @@ -86,7 +87,7 @@ subroutine init_hist (dt) real (kind=dbl_kind) :: rhofresh, Tffresh, secday, rad_to_deg logical (kind=log_kind) :: formdrag logical (kind=log_kind) :: tr_iage, tr_FY, tr_lvl, tr_pond, tr_aero, tr_brine - logical (kind=log_kind) :: tr_fsd + logical (kind=log_kind) :: tr_fsd, tr_snow logical (kind=log_kind) :: skl_bgc, solve_zsal, solve_zbgc, z_tracers integer (kind=int_kind) :: n, ns, ns1, ns2 integer (kind=int_kind), dimension(max_nstrm) :: & @@ -115,7 +116,7 @@ subroutine init_hist (dt) solve_zsal_out=solve_zsal, solve_zbgc_out=solve_zbgc, z_tracers_out=z_tracers) call icepack_query_tracer_flags(tr_iage_out=tr_iage, tr_FY_out=tr_FY, & tr_lvl_out=tr_lvl, tr_pond_out=tr_pond, tr_aero_out=tr_aero, & - tr_brine_out=tr_brine, tr_fsd_out=tr_fsd) + tr_brine_out=tr_brine, tr_fsd_out=tr_fsd, tr_snow_out=tr_snow) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) @@ -1426,6 +1427,9 @@ subroutine init_hist (dt) ! floe size distribution call init_hist_fsd_2D + ! advanced snow physics + call init_hist_snow_2D (dt) + !----------------------------------------------------------------- ! 3D (category) variables looped separately for ordering !----------------------------------------------------------------- @@ -1501,6 +1505,9 @@ subroutine init_hist (dt) ! biogeochemistry call init_hist_bgc_3Dc + ! advanced snow physics + call init_hist_snow_3Dc + !----------------------------------------------------------------- ! 3D (vertical) variables must be looped separately !----------------------------------------------------------------- @@ -1688,6 +1695,7 @@ subroutine init_hist (dt) if (allocated(a4Df)) a4Df(:,:,:,:,:,:) = c0 avgct(:) = c0 albcnt(:,:,:,:) = c0 + snwcnt(:,:,:,:) = c0 if (restart .and. yday >= c2) then ! restarting midyear gives erroneous onset dates @@ -1726,7 +1734,7 @@ subroutine accum_hist (dt) fhocn, fhocn_ai, uatm, vatm, fbot, Tbot, Tsnice, & fswthru_ai, strairx, strairy, strtltx, strtlty, strintx, strinty, & taubx, tauby, strocnx, strocny, fm, daidtt, dvidtt, daidtd, dvidtd, fsurf, & - fcondtop, fcondbot, fsurfn, fcondtopn, flatn, fsensn, albcnt, & + fcondtop, fcondbot, fsurfn, fcondtopn, flatn, fsensn, albcnt, snwcnt, & stressp_1, stressm_1, stress12_1, & stressp_2, & stressp_3, & @@ -1739,6 +1747,8 @@ subroutine accum_hist (dt) use ice_history_bgc, only: accum_hist_bgc use ice_history_mechred, only: accum_hist_mechred use ice_history_pond, only: accum_hist_pond + use ice_history_snow, only: accum_hist_snow, & + f_rhos_cmp, f_rhos_cnt, n_rhos_cmp, n_rhos_cnt use ice_history_drag, only: accum_hist_drag use icepack_intfc, only: icepack_mushy_density_brine, icepack_mushy_liquid_fraction use icepack_intfc, only: icepack_mushy_temperature_mush @@ -1758,6 +1768,7 @@ subroutine accum_hist (dt) nstrm ! nstreams (1 if writing initial condition) real (kind=dbl_kind) :: & + timedbl , & ! temporary dbl for time bounds ravgct , & ! 1/avgct ravgctz ! 1/avgct @@ -1775,7 +1786,7 @@ subroutine accum_hist (dt) real (kind=dbl_kind) :: Tffresh, rhoi, rhos, rhow, ice_ref_salinity real (kind=dbl_kind) :: rho_ice, rho_ocn, Tice, Sbr, phi, rhob, dfresh, dfsalt logical (kind=log_kind) :: formdrag, skl_bgc - logical (kind=log_kind) :: tr_pond, tr_aero, tr_brine + logical (kind=log_kind) :: tr_pond, tr_aero, tr_brine, tr_snow integer (kind=int_kind) :: ktherm integer (kind=int_kind) :: nt_sice, nt_qice, nt_qsno, nt_iage, nt_FY, nt_Tsfc, & nt_alvl, nt_vlvl @@ -1791,7 +1802,7 @@ subroutine accum_hist (dt) rhow_out=rhow, ice_ref_salinity_out=ice_ref_salinity) call icepack_query_parameters(formdrag_out=formdrag, skl_bgc_out=skl_bgc, ktherm_out=ktherm) call icepack_query_tracer_flags(tr_pond_out=tr_pond, tr_aero_out=tr_aero, & - tr_brine_out=tr_brine) + tr_brine_out=tr_brine, tr_snow_out=tr_snow) call icepack_query_tracer_indices(nt_sice_out=nt_sice, nt_qice_out=nt_qice, & nt_qsno_out=nt_qsno, nt_iage_out=nt_iage, nt_FY_out=nt_FY, nt_Tsfc_out=nt_Tsfc, & nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl) @@ -1814,7 +1825,7 @@ subroutine accum_hist (dt) n4Dfcum = n4Dscum + num_avail_hist_fields_4Df ! should equal num_avail_hist_fields_tot do ns = 1,nstreams - if (.not. hist_avg .or. histfreq(ns) == '1') then ! write snapshots + if (.not. hist_avg) then ! write snapshots do n = 1,n2D if (avail_hist_fields(n)%vhistfreq == histfreq(ns)) & a2D(:,:,n,:) = c0 @@ -1862,11 +1873,10 @@ subroutine accum_hist (dt) avgct(ns) = c1 else ! write averages over time histfreq avgct(ns) = avgct(ns) + c1 -! if (avgct(ns) == c1) time_beg(ns) = (time-dt)/int(secday) - if (avgct(ns) == c1) then - time_beg(ns) = (timesecs-dt)/int(secday) - time_beg(ns) = real(time_beg(ns),kind=real_kind) - endif + endif + if (avgct(ns) == c1) then + timedbl = (timesecs-dt)/(secday) + time_beg(ns) = real(timedbl,kind=real_kind) endif enddo @@ -3040,6 +3050,9 @@ subroutine accum_hist (dt) ! floe size distribution call accum_hist_fsd (iblk) + ! advanced snow physics + call accum_hist_snow (iblk) + enddo ! iblk !$OMP END PARALLEL DO @@ -3105,7 +3118,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a2D(i,j,n,iblk) = spval + a2D(i,j,n,iblk) = spval_dbl else ! convert units a2D(i,j,n,iblk) = avail_hist_fields(n)%cona*a2D(i,j,n,iblk) & * ravgct + avail_hist_fields(n)%conb @@ -3122,7 +3135,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sithick(ns),iblk) = & a2D(i,j,n_sithick(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sithick(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sithick(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3135,7 +3148,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siage(ns),iblk) = & a2D(i,j,n_siage(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siage(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siage(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3148,7 +3161,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sisnthick(ns),iblk) = & a2D(i,j,n_sisnthick(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sisnthick(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sisnthick(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3161,7 +3174,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sitemptop(ns),iblk) = & a2D(i,j,n_sitemptop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sitemptop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sitemptop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3174,7 +3187,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sitempsnic(ns),iblk) = & a2D(i,j,n_sitempsnic(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sitempsnic(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sitempsnic(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3187,7 +3200,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sitempbot(ns),iblk) = & a2D(i,j,n_sitempbot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sitempbot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sitempbot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3200,7 +3213,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siu(ns),iblk) = & a2D(i,j,n_siu(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siu(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siu(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3213,7 +3226,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siv(ns),iblk) = & a2D(i,j,n_siv(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siv(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siv(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3226,7 +3239,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sistrxdtop(ns),iblk) = & a2D(i,j,n_sistrxdtop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sistrxdtop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sistrxdtop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3239,7 +3252,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sistrydtop(ns),iblk) = & a2D(i,j,n_sistrydtop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sistrydtop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sistrydtop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3252,7 +3265,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sistrxubot(ns),iblk) = & a2D(i,j,n_sistrxubot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sistrxubot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sistrxubot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3265,7 +3278,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sistryubot(ns),iblk) = & a2D(i,j,n_sistryubot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sistryubot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sistryubot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3278,7 +3291,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sicompstren(ns),iblk) = & a2D(i,j,n_sicompstren(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sicompstren(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sicompstren(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3291,7 +3304,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sispeed(ns),iblk) = & a2D(i,j,n_sispeed(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sispeed(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sispeed(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3304,8 +3317,8 @@ subroutine accum_hist (dt) a2D(i,j,n_sialb(ns),iblk) = & a2D(i,j,n_sialb(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sialb(ns),iblk) = spval - if (albcnt(i,j,iblk,ns) <= puny) a2D(i,j,n_sialb(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sialb(ns),iblk) = spval_dbl + if (albcnt(i,j,iblk,ns) <= puny) a2D(i,j,n_sialb(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3318,7 +3331,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflswdtop(ns),iblk) = & a2D(i,j,n_siflswdtop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflswdtop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflswdtop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3331,7 +3344,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflswutop(ns),iblk) = & a2D(i,j,n_siflswutop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflswutop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflswutop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3344,7 +3357,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflswdbot(ns),iblk) = & a2D(i,j,n_siflswdbot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflswdbot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflswdbot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3357,7 +3370,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sifllwdtop(ns),iblk) = & a2D(i,j,n_sifllwdtop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sifllwdtop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sifllwdtop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3370,7 +3383,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sifllwutop(ns),iblk) = & a2D(i,j,n_sifllwutop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sifllwutop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sifllwutop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3383,7 +3396,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflsenstop(ns),iblk) = & a2D(i,j,n_siflsenstop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflsenstop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflsenstop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3396,7 +3409,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflsensupbot(ns),iblk) = & a2D(i,j,n_siflsensupbot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflsensupbot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflsensupbot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3409,7 +3422,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sifllatstop(ns),iblk) = & a2D(i,j,n_sifllatstop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sifllatstop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sifllatstop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3422,7 +3435,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sipr(ns),iblk) = & a2D(i,j,n_sipr(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sipr(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sipr(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3435,7 +3448,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sifb(ns),iblk) = & a2D(i,j,n_sifb(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sifb(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sifb(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3448,7 +3461,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflcondtop(ns),iblk) = & a2D(i,j,n_siflcondtop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflcondtop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflcondtop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3461,7 +3474,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflcondbot(ns),iblk) = & a2D(i,j,n_siflcondbot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflcondbot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflcondbot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3474,7 +3487,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflsaltbot(ns),iblk) = & a2D(i,j,n_siflsaltbot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflsaltbot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflsaltbot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3487,7 +3500,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflfwbot(ns),iblk) = & a2D(i,j,n_siflfwbot(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflfwbot(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflfwbot(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3500,7 +3513,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siflfwdrain(ns),iblk) = & a2D(i,j,n_siflfwdrain(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siflfwdrain(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siflfwdrain(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3513,7 +3526,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sidragtop(ns),iblk) = & a2D(i,j,n_sidragtop(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sidragtop(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sidragtop(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3526,7 +3539,7 @@ subroutine accum_hist (dt) a2D(i,j,n_sirdgthick(ns),iblk) = & a2D(i,j,n_sirdgthick(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_sirdgthick(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_sirdgthick(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3539,7 +3552,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siforcetiltx(ns),iblk) = & a2D(i,j,n_siforcetiltx(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siforcetiltx(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siforcetiltx(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3552,7 +3565,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siforcetilty(ns),iblk) = & a2D(i,j,n_siforcetilty(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siforcetilty(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siforcetilty(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3565,7 +3578,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siforcecoriolx(ns),iblk) = & a2D(i,j,n_siforcecoriolx(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siforcecoriolx(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siforcecoriolx(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3578,7 +3591,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siforcecorioly(ns),iblk) = & a2D(i,j,n_siforcecorioly(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siforcecorioly(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siforcecorioly(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3591,7 +3604,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siforceintstrx(ns),iblk) = & a2D(i,j,n_siforceintstrx(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siforceintstrx(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siforceintstrx(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3604,7 +3617,7 @@ subroutine accum_hist (dt) a2D(i,j,n_siforceintstry(ns),iblk) = & a2D(i,j,n_siforceintstry(ns),iblk)*avgct(ns)*ravgip(i,j) endif - if (ravgip(i,j) == c0) a2D(i,j,n_siforceintstry(ns),iblk) = spval + if (ravgip(i,j) == c0) a2D(i,j,n_siforceintstry(ns),iblk) = spval_dbl enddo ! i enddo ! j endif @@ -3669,7 +3682,38 @@ subroutine accum_hist (dt) enddo ! j endif - endif +! snwcnt averaging is not working correctly +! for now, these history fields will have zeroes includes in the averages +! if (avail_hist_fields(n)%vname(1:8) == 'rhos_cmp') then +! do j = jlo, jhi +! do i = ilo, ihi +! if (tmask(i,j,iblk)) then +! ravgctz = c0 +! if (snwcnt(i,j,iblk,ns) > puny) & +! ravgctz = c1/snwcnt(i,j,iblk,ns) +! if (f_rhos_cmp (1:1) /= 'x' .and. n_rhos_cmp(ns) /= 0) & +! a2D(i,j,n_rhos_cmp(ns),iblk) = & +! a2D(i,j,n_rhos_cmp(ns),iblk)*avgct(ns)*ravgctz +! endif +! enddo ! i +! enddo ! j +! endif +! if (avail_hist_fields(n)%vname(1:8) == 'rhos_cnt') then +! do j = jlo, jhi +! do i = ilo, ihi +! if (tmask(i,j,iblk)) then +! ravgctz = c0 +! if (snwcnt(i,j,iblk,ns) > puny) & +! ravgctz = c1/snwcnt(i,j,iblk,ns) +! if (f_rhos_cnt (1:1) /= 'x' .and. n_rhos_cnt(ns) /= 0) & +! a2D(i,j,n_rhos_cnt(ns),iblk) = & +! a2D(i,j,n_rhos_cnt(ns),iblk)*avgct(ns)*ravgctz +! endif +! enddo ! i +! enddo ! j +! endif + + endif ! avail_hist_fields(n)%vhistfreq == histfreq(ns) enddo ! n do n = 1, num_avail_hist_fields_3Dc @@ -3680,7 +3724,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a3Dc(i,j,k,n,iblk) = spval + a3Dc(i,j,k,n,iblk) = spval_dbl else ! convert units a3Dc(i,j,k,n,iblk) = avail_hist_fields(nn)%cona*a3Dc(i,j,k,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3729,7 +3773,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a3Dz(i,j,k,n,iblk) = spval + a3Dz(i,j,k,n,iblk) = spval_dbl else ! convert units a3Dz(i,j,k,n,iblk) = avail_hist_fields(nn)%cona*a3Dz(i,j,k,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3746,7 +3790,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a3Db(i,j,k,n,iblk) = spval + a3Db(i,j,k,n,iblk) = spval_dbl else ! convert units a3Db(i,j,k,n,iblk) = avail_hist_fields(nn)%cona*a3Db(i,j,k,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3764,7 +3808,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a3Da(i,j,k,n,iblk) = spval + a3Da(i,j,k,n,iblk) = spval_dbl else ! convert units a3Da(i,j,k,n,iblk) = avail_hist_fields(nn)%cona*a3Da(i,j,k,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3782,7 +3826,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a3Df(i,j,k,n,iblk) = spval + a3Df(i,j,k,n,iblk) = spval_dbl else ! convert units a3Df(i,j,k,n,iblk) = avail_hist_fields(nn)%cona*a3Df(i,j,k,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3801,7 +3845,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a4Di(i,j,k,ic,n,iblk) = spval + a4Di(i,j,k,ic,n,iblk) = spval_dbl else ! convert units a4Di(i,j,k,ic,n,iblk) = avail_hist_fields(nn)%cona*a4Di(i,j,k,ic,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3821,7 +3865,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a4Ds(i,j,k,ic,n,iblk) = spval + a4Ds(i,j,k,ic,n,iblk) = spval_dbl else ! convert units a4Ds(i,j,k,ic,n,iblk) = avail_hist_fields(nn)%cona*a4Ds(i,j,k,ic,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3841,7 +3885,7 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - a4Df(i,j,k,ic,n,iblk) = spval + a4Df(i,j,k,ic,n,iblk) = spval_dbl else ! convert units a4Df(i,j,k,ic,n,iblk) = avail_hist_fields(nn)%cona*a4Df(i,j,k,ic,n,iblk) & * ravgct + avail_hist_fields(nn)%conb @@ -3871,32 +3915,32 @@ subroutine accum_hist (dt) do j = jlo, jhi do i = ilo, ihi if (.not. tmask(i,j,iblk)) then ! mask out land points - if (n_divu (ns) /= 0) a2D(i,j,n_divu(ns), iblk) = spval - if (n_shear (ns) /= 0) a2D(i,j,n_shear(ns), iblk) = spval - if (n_sig1 (ns) /= 0) a2D(i,j,n_sig1(ns), iblk) = spval - if (n_sig2 (ns) /= 0) a2D(i,j,n_sig2(ns), iblk) = spval - if (n_sigP (ns) /= 0) a2D(i,j,n_sigP(ns), iblk) = spval - if (n_sistreave(ns) /= 0) a2D(i,j,n_sistreave(ns),iblk) = spval - if (n_sistremax(ns) /= 0) a2D(i,j,n_sistremax(ns),iblk) = spval - if (n_mlt_onset(ns) /= 0) a2D(i,j,n_mlt_onset(ns),iblk) = spval - if (n_frz_onset(ns) /= 0) a2D(i,j,n_frz_onset(ns),iblk) = spval - if (n_hisnap (ns) /= 0) a2D(i,j,n_hisnap(ns), iblk) = spval - if (n_aisnap (ns) /= 0) a2D(i,j,n_aisnap(ns), iblk) = spval - if (n_trsig (ns) /= 0) a2D(i,j,n_trsig(ns), iblk) = spval - if (n_iage (ns) /= 0) a2D(i,j,n_iage(ns), iblk) = spval - if (n_FY (ns) /= 0) a2D(i,j,n_FY(ns), iblk) = spval - - if (n_a11 (ns) /= 0) a2D(i,j,n_a11(ns), iblk) = spval - if (n_a12 (ns) /= 0) a2D(i,j,n_a12(ns), iblk) = spval - if (n_e11 (ns) /= 0) a2D(i,j,n_e11(ns), iblk) = spval - if (n_e12 (ns) /= 0) a2D(i,j,n_e12(ns), iblk) = spval - if (n_e22 (ns) /= 0) a2D(i,j,n_e22(ns), iblk) = spval - if (n_s11 (ns) /= 0) a2D(i,j,n_s11(ns), iblk) = spval - if (n_s12 (ns) /= 0) a2D(i,j,n_s12(ns), iblk) = spval - if (n_s22 (ns) /= 0) a2D(i,j,n_s22(ns), iblk) = spval - if (n_yieldstress11 (ns) /= 0) a2D(i,j,n_yieldstress11(ns),iblk) = spval - if (n_yieldstress12 (ns) /= 0) a2D(i,j,n_yieldstress12(ns),iblk) = spval - if (n_yieldstress22 (ns) /= 0) a2D(i,j,n_yieldstress22(ns),iblk) = spval + if (n_divu (ns) /= 0) a2D(i,j,n_divu(ns), iblk) = spval_dbl + if (n_shear (ns) /= 0) a2D(i,j,n_shear(ns), iblk) = spval_dbl + if (n_sig1 (ns) /= 0) a2D(i,j,n_sig1(ns), iblk) = spval_dbl + if (n_sig2 (ns) /= 0) a2D(i,j,n_sig2(ns), iblk) = spval_dbl + if (n_sigP (ns) /= 0) a2D(i,j,n_sigP(ns), iblk) = spval_dbl + if (n_sistreave(ns) /= 0) a2D(i,j,n_sistreave(ns),iblk) = spval_dbl + if (n_sistremax(ns) /= 0) a2D(i,j,n_sistremax(ns),iblk) = spval_dbl + if (n_mlt_onset(ns) /= 0) a2D(i,j,n_mlt_onset(ns),iblk) = spval_dbl + if (n_frz_onset(ns) /= 0) a2D(i,j,n_frz_onset(ns),iblk) = spval_dbl + if (n_hisnap (ns) /= 0) a2D(i,j,n_hisnap(ns), iblk) = spval_dbl + if (n_aisnap (ns) /= 0) a2D(i,j,n_aisnap(ns), iblk) = spval_dbl + if (n_trsig (ns) /= 0) a2D(i,j,n_trsig(ns), iblk) = spval_dbl + if (n_iage (ns) /= 0) a2D(i,j,n_iage(ns), iblk) = spval_dbl + if (n_FY (ns) /= 0) a2D(i,j,n_FY(ns), iblk) = spval_dbl + + if (n_a11 (ns) /= 0) a2D(i,j,n_a11(ns), iblk) = spval_dbl + if (n_a12 (ns) /= 0) a2D(i,j,n_a12(ns), iblk) = spval_dbl + if (n_e11 (ns) /= 0) a2D(i,j,n_e11(ns), iblk) = spval_dbl + if (n_e12 (ns) /= 0) a2D(i,j,n_e12(ns), iblk) = spval_dbl + if (n_e22 (ns) /= 0) a2D(i,j,n_e22(ns), iblk) = spval_dbl + if (n_s11 (ns) /= 0) a2D(i,j,n_s11(ns), iblk) = spval_dbl + if (n_s12 (ns) /= 0) a2D(i,j,n_s12(ns), iblk) = spval_dbl + if (n_s22 (ns) /= 0) a2D(i,j,n_s22(ns), iblk) = spval_dbl + if (n_yieldstress11 (ns) /= 0) a2D(i,j,n_yieldstress11(ns),iblk) = spval_dbl + if (n_yieldstress12 (ns) /= 0) a2D(i,j,n_yieldstress12(ns),iblk) = spval_dbl + if (n_yieldstress22 (ns) /= 0) a2D(i,j,n_yieldstress22(ns),iblk) = spval_dbl else if (n_divu (ns) /= 0) a2D(i,j,n_divu(ns),iblk) = & divu (i,j,iblk)*avail_hist_fields(n_divu(ns))%cona @@ -3966,8 +4010,8 @@ subroutine accum_hist (dt) enddo ! iblk !$OMP END PARALLEL DO - time_end(ns) = timesecs/int(secday) - time_end(ns) = real(time_end(ns),kind=real_kind) + timedbl = timesecs/secday + time_end(ns) = real(timedbl,kind=real_kind) !--------------------------------------------------------------- ! write file @@ -3992,10 +4036,12 @@ subroutine accum_hist (dt) if (allocated(a4Df)) a4Df(:,:,:,:,:,:) = c0 avgct(:) = c0 albcnt(:,:,:,:) = c0 + snwcnt(:,:,:,:) = c0 write_ic = .false. ! write initial condition once at most else avgct(ns) = c0 albcnt(:,:,:,ns) = c0 + snwcnt(:,:,:,ns) = c0 endif ! if (write_history(ns)) albcnt(:,:,:,ns) = c0 diff --git a/cicecore/cicedynB/analysis/ice_history_fsd.F90 b/cicecore/cicedynB/analysis/ice_history_fsd.F90 index 43afc1e27..7ad81e7d2 100644 --- a/cicecore/cicedynB/analysis/ice_history_fsd.F90 +++ b/cicecore/cicedynB/analysis/ice_history_fsd.F90 @@ -303,7 +303,7 @@ subroutine accum_hist_fsd (iblk) integer (kind=int_kind) :: & i, j, n, k, & ! loop indices - nt_fsd ! ! fsd tracer index + nt_fsd ! fsd tracer index logical (kind=log_kind) :: tr_fsd real (kind=dbl_kind) :: floeshape, puny diff --git a/cicecore/cicedynB/analysis/ice_history_pond.F90 b/cicecore/cicedynB/analysis/ice_history_pond.F90 index de10eb9fb..182865fec 100644 --- a/cicecore/cicedynB/analysis/ice_history_pond.F90 +++ b/cicecore/cicedynB/analysis/ice_history_pond.F90 @@ -75,15 +75,15 @@ subroutine init_hist_pond_2D logical (kind=log_kind) :: tr_pond character(len=*), parameter :: subname = '(init_hist_pond_2D)' - !----------------------------------------------------------------- - ! read namelist - !----------------------------------------------------------------- - call icepack_query_tracer_flags(tr_pond_out=tr_pond) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) + !----------------------------------------------------------------- + ! read namelist + !----------------------------------------------------------------- + call get_fileunit(nu_nml) if (my_task == master_task) then open (nu_nml, file=nml_filename, status='old',iostat=nml_error) diff --git a/cicecore/cicedynB/analysis/ice_history_shared.F90 b/cicecore/cicedynB/analysis/ice_history_shared.F90 index 52d268990..9b58deeec 100644 --- a/cicecore/cicedynB/analysis/ice_history_shared.F90 +++ b/cicecore/cicedynB/analysis/ice_history_shared.F90 @@ -59,7 +59,7 @@ module ice_history_shared !--------------------------------------------------------------- ! Instructions for adding a field: (search for 'example') - ! Here: + ! Here or in ice_history_[process].F90: ! (1) Add to frequency flags (f_) ! (2) Add to namelist (here and also in ice_in) ! (3) Add to index list @@ -672,64 +672,67 @@ subroutine construct_filename(ncfile,suffix,ns) iday = mday isec = msec - dt - if (write_ic) isec = msec ! construct filename if (write_ic) then + isec = msec write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & incond_file(1:lenstr(incond_file)),'.',iyear,'-', & - imonth,'-',iday,'-',isec,'.',suffix + imonth,'-',iday,'-',isec,'.',trim(suffix) else - if (hist_avg .and. histfreq(ns) /= '1') then - if (histfreq(ns) == 'h'.or.histfreq(ns) == 'H') then - ! do nothing - elseif (new_year) then - iyear = iyear - 1 - imonth = 12 - iday = daymo(imonth) - elseif (new_month) then - imonth = mmonth - 1 - iday = daymo(imonth) - elseif (new_day) then - iday = iday - 1 - endif - endif - - cstream = '' + if (hist_avg) then + if (histfreq(ns) == '1' .or. histfreq(ns) == 'h'.or.histfreq(ns) == 'H') then + ! do nothing + elseif (new_year) then + iyear = iyear - 1 + imonth = 12 + iday = daymo(imonth) + elseif (new_month) then + imonth = mmonth - 1 + iday = daymo(imonth) + elseif (new_day) then + iday = iday - 1 + endif + endif + + cstream = '' !echmod ! this was implemented for CESM but it breaks post-processing software !echmod ! of other groups (including RASM which uses CESMCOUPLED) !echmod if (ns > 1) write(cstream,'(i1.1)') ns-1 - if (histfreq(ns) == '1') then ! instantaneous, write every dt - write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & - history_file(1:lenstr(history_file))//trim(cstream),'_inst.', & - iyear,'-',imonth,'-',iday,'-',msec,'.',suffix - - elseif (hist_avg) then ! write averaged data - - if (histfreq(ns) == 'd'.or.histfreq(ns) == 'D') then ! daily - write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,a)') & - history_file(1:lenstr(history_file))//trim(cstream), & - '.',iyear,'-',imonth,'-',iday,'.',suffix - elseif (histfreq(ns) == 'h'.or.histfreq(ns) == 'H') then ! hourly - write(ncfile,'(a,a,i2.2,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & - history_file(1:lenstr(history_file))//trim(cstream),'_', & - histfreq_n(ns),'h.',iyear,'-',imonth,'-',iday,'-',msec,'.',suffix - elseif (histfreq(ns) == 'm'.or.histfreq(ns) == 'M') then ! monthly - write(ncfile,'(a,a,i4.4,a,i2.2,a,a)') & - history_file(1:lenstr(history_file))//trim(cstream),'.', & - iyear,'-',imonth,'.',suffix - elseif (histfreq(ns) == 'y'.or.histfreq(ns) == 'Y') then ! yearly - write(ncfile,'(a,a,i4.4,a,a)') & - history_file(1:lenstr(history_file))//trim(cstream),'.', & - iyear,'.',suffix - endif + if (hist_avg) then ! write averaged data + if (histfreq(ns) == '1' .and. histfreq_n(ns) == 1) then ! timestep + write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & + history_file(1:lenstr(history_file))//trim(cstream),'_inst.', & + iyear,'-',imonth,'-',iday,'-',msec,'.',trim(suffix) + elseif (histfreq(ns) == '1' .and. histfreq_n(ns) > 1) then ! timestep + write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & + history_file(1:lenstr(history_file))//trim(cstream),'.', & + iyear,'-',imonth,'-',iday,'-',msec,'.',trim(suffix) + elseif (histfreq(ns) == 'h'.or.histfreq(ns) == 'H') then ! hourly + write(ncfile,'(a,a,i2.2,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & + history_file(1:lenstr(history_file))//trim(cstream),'_', & + histfreq_n(ns),'h.',iyear,'-',imonth,'-',iday,'-',msec,'.',trim(suffix) + elseif (histfreq(ns) == 'd'.or.histfreq(ns) == 'D') then ! daily + write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,a)') & + history_file(1:lenstr(history_file))//trim(cstream),'.', & + iyear,'-',imonth,'-',iday,'.',trim(suffix) + elseif (histfreq(ns) == 'm'.or.histfreq(ns) == 'M') then ! monthly + write(ncfile,'(a,a,i4.4,a,i2.2,a,a)') & + history_file(1:lenstr(history_file))//trim(cstream),'.', & + iyear,'-',imonth,'.',trim(suffix) + elseif (histfreq(ns) == 'y'.or.histfreq(ns) == 'Y') then ! yearly + write(ncfile,'(a,a,i4.4,a,a)') & + history_file(1:lenstr(history_file))//trim(cstream),'.', & + iyear,'.',trim(suffix) + endif + + else ! instantaneous + write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & + history_file(1:lenstr(history_file))//trim(cstream),'_inst.', & + iyear,'-',imonth,'-',iday,'-',msec,'.',trim(suffix) + endif - else ! instantaneous with histfreq > dt - write(ncfile,'(a,a,i4.4,a,i2.2,a,i2.2,a,i5.5,a,a)') & - history_file(1:lenstr(history_file)),'_inst.', & - iyear,'-',imonth,'-',iday,'-',msec,'.',suffix - endif endif end subroutine construct_filename diff --git a/cicecore/cicedynB/analysis/ice_history_snow.F90 b/cicecore/cicedynB/analysis/ice_history_snow.F90 new file mode 100644 index 000000000..5a590af2b --- /dev/null +++ b/cicecore/cicedynB/analysis/ice_history_snow.F90 @@ -0,0 +1,430 @@ +!======================================================================= + +! Snow tracer history output + + module ice_history_snow + + use ice_kinds_mod + use ice_constants, only: c0, c1, mps_to_cmpdy + use ice_domain_size, only: max_nstrm, nslyr + use ice_fileunits, only: nu_nml, nml_filename, & + get_fileunit, release_fileunit + use ice_fileunits, only: nu_diag + use ice_exit, only: abort_ice + use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted + use icepack_intfc, only: icepack_query_parameters, & + icepack_query_tracer_flags, icepack_query_tracer_indices + + implicit none + private + public :: accum_hist_snow, init_hist_snow_2D, init_hist_snow_3Dc + + !--------------------------------------------------------------- + ! flags: write to output file if true or histfreq value + !--------------------------------------------------------------- + + character (len=max_nstrm), public :: & + f_smassice = 'm', f_smassicen = 'x', & + f_smassliq = 'm', f_smassliqn = 'x', & + f_rhos_cmp = 'm', f_rhos_cmpn = 'x', & + f_rhos_cnt = 'm', f_rhos_cntn = 'x', & + f_rsnw = 'm', f_rsnwn = 'x', & + f_meltsliq = 'm', f_fsloss = 'x' + + !--------------------------------------------------------------- + ! namelist variables + !--------------------------------------------------------------- + + namelist / icefields_snow_nml / & + f_smassice, f_smassicen, & + f_smassliq, f_smassliqn, & + f_rhos_cmp, f_rhos_cmpn, & + f_rhos_cnt, f_rhos_cntn, & + f_rsnw, f_rsnwn, & + f_meltsliq, f_fsloss + + !--------------------------------------------------------------- + ! field indices + !--------------------------------------------------------------- + + integer (kind=int_kind), dimension(max_nstrm), public :: & + n_smassice, n_smassicen, & + n_smassliq, n_smassliqn, & + n_rhos_cmp, n_rhos_cmpn, & + n_rhos_cnt, n_rhos_cntn, & + n_rsnw, n_rsnwn, & + n_meltsliq, n_fsloss + +!======================================================================= + + contains + +!======================================================================= + + subroutine init_hist_snow_2D (dt) + + use ice_broadcast, only: broadcast_scalar + use ice_calendar, only: nstreams, histfreq + use ice_communicate, only: my_task, master_task + use ice_history_shared, only: tstr2D, tcstr, define_hist_field + use ice_fileunits, only: nu_nml, nml_filename, & + get_fileunit, release_fileunit + + real (kind=dbl_kind), intent(in) :: & + dt ! time step + + integer (kind=int_kind) :: ns + integer (kind=int_kind) :: nml_error ! namelist i/o error flag + real (kind=dbl_kind) :: rhofresh, secday + logical (kind=log_kind) :: tr_snow + character(len=*), parameter :: subname = '(init_hist_snow_2D)' + + call icepack_query_tracer_flags(tr_snow_out=tr_snow) + call icepack_query_parameters(rhofresh_out=rhofresh,secday_out=secday) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & + file=__FILE__, line=__LINE__) + + if (tr_snow) then + + !----------------------------------------------------------------- + ! read namelist + !----------------------------------------------------------------- + + call get_fileunit(nu_nml) + if (my_task == master_task) then + open (nu_nml, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nu_nml, nml=icefields_snow_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nu_nml) + endif + call release_fileunit(nu_nml) + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + close (nu_nml) + call abort_ice('ice: error reading icefields_snow_nml') + endif + + else ! .not. tr_snow + f_smassice = 'x' + f_smassliq = 'x' + f_rhos_cmp = 'x' + f_rhos_cnt = 'x' + f_rsnw = 'x' + f_smassicen= 'x' + f_smassliqn= 'x' + f_rhos_cmpn= 'x' + f_rhos_cntn= 'x' + f_rsnwn = 'x' + f_meltsliq = 'x' + f_fsloss = 'x' + endif + + call broadcast_scalar (f_smassice, master_task) + call broadcast_scalar (f_smassliq, master_task) + call broadcast_scalar (f_rhos_cmp, master_task) + call broadcast_scalar (f_rhos_cnt, master_task) + call broadcast_scalar (f_rsnw, master_task) + call broadcast_scalar (f_smassicen,master_task) + call broadcast_scalar (f_smassliqn,master_task) + call broadcast_scalar (f_rhos_cmpn,master_task) + call broadcast_scalar (f_rhos_cntn,master_task) + call broadcast_scalar (f_rsnwn, master_task) + call broadcast_scalar (f_meltsliq, master_task) + call broadcast_scalar (f_fsloss, master_task) + + if (tr_snow) then + + ! 2D variables + do ns = 1, nstreams + if (histfreq(ns) /= 'x') then + + if (f_smassice(1:1) /= 'x') & + call define_hist_field(n_smassice,"smassice","kg/m^2",tstr2D, tcstr, & + "ice mass per unit area in snow", & + "none", c1, c0, & + ns, f_smassice) + + if (f_smassliq(1:1) /= 'x') & + call define_hist_field(n_smassliq,"smassliq","kg/m^2",tstr2D, tcstr, & + "liquid mass per unit area in snow", & + "none", c1, c0, & + ns, f_smassliq) + + if (f_rhos_cmp(1:1) /= 'x') & + call define_hist_field(n_rhos_cmp,"rhos_cmp","kg/m^3",tstr2D, tcstr, & + "snow density: compaction", & + "none", c1, c0, & + ns, f_rhos_cmp) + + if (f_rhos_cnt(1:1) /= 'x') & + call define_hist_field(n_rhos_cnt,"rhos_cnt","kg/m^3",tstr2D, tcstr, & + "snow density: content", & + "none", c1, c0, & + ns, f_rhos_cnt) + + if (f_rsnw(1:1) /= 'x') & + call define_hist_field(n_rsnw,"rsnw","10^-6 m",tstr2D, tcstr, & + "average snow grain radius", & + "none", c1, c0, & + ns, f_rsnw) + + if (f_meltsliq(1:1) /= 'x') & + call define_hist_field(n_meltsliq,"meltsliq","kg/m^2/s",tstr2D, tcstr, & + "snow liquid contribution to meltponds", & + "none", c1/dt, c0, & + ns, f_meltsliq) + + if (f_fsloss(1:1) /= 'x') & + call define_hist_field(n_fsloss,"fsloss","kg/m^2/s",tstr2D, tcstr, & + "rate of snow loss to leads (liquid)", & + "none", c1, c0, & + ns, f_fsloss) + + endif ! histfreq(ns) /= 'x' + enddo ! nstreams + endif ! tr_snow + + end subroutine init_hist_snow_2D + +!======================================================================= + + subroutine init_hist_snow_3Dc + + use ice_calendar, only: nstreams, histfreq + use ice_history_shared, only: tstr3Dc, tcstr, define_hist_field + + integer (kind=int_kind) :: ns + logical (kind=log_kind) :: tr_snow + character(len=*), parameter :: subname = '(init_hist_pond_3Dc)' + + call icepack_query_tracer_flags(tr_snow_out=tr_snow) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & + file=__FILE__, line=__LINE__) + + if (tr_snow) then + + ! 3D (category) variables must be looped separately + do ns = 1, nstreams + if (histfreq(ns) /= 'x') then + + if (f_smassicen(1:1) /= 'x') & + call define_hist_field(n_smassicen,"smassicen","kg/m^2",tstr3Dc, tcstr, & + "ice mass per unit area in snow, category", & + "none", c1, c0, & + ns, f_smassicen) + + if (f_smassliqn(1:1) /= 'x') & + call define_hist_field(n_smassliqn,"smassliqn","kg/m^2",tstr3Dc, tcstr, & + "liquid mass per unit area in snow, category", & + "none", c1, c0, & + ns, f_smassliqn) + + if (f_rhos_cmpn(1:1) /= 'x') & + call define_hist_field(n_rhos_cmpn,"rhos_cmpn","kg/m^3",tstr3Dc, tcstr, & + "snow density: compaction, category", & + "none", c1, c0, & + ns, f_rhos_cmpn) + + if (f_rhos_cntn(1:1) /= 'x') & + call define_hist_field(n_rhos_cntn,"rhos_cntn","kg/m^3",tstr3Dc, tcstr, & + "snow density: content, category", & + "none", c1, c0, & + ns, f_rhos_cntn) + + if (f_rsnwn(1:1) /= 'x') & + call define_hist_field(n_rsnwn,"rsnwn","10^-6 m",tstr3Dc, tcstr, & + "average snow grain radius, category", & + "none", c1, c0, & + ns, f_rsnwn) + + endif ! histfreq(ns) /= 'x' + enddo ! ns + + endif ! tr_snow + + end subroutine init_hist_snow_3Dc + +!======================================================================= + +! accumulate average ice quantities or snapshots + + subroutine accum_hist_snow (iblk) + + use ice_arrays_column, only: meltsliq + use ice_blocks, only: block, nx_block, ny_block + use ice_domain, only: blocks_ice + use ice_flux, only: fsloss + use ice_history_shared, only: n2D, a2D, a3Dc, ncat_hist, & + accum_hist_field, nzslyr + use ice_state, only: vsno, vsnon, trcr, trcrn + + integer (kind=int_kind), intent(in) :: & + iblk ! block index + + ! local variables + + integer (kind=int_kind) :: & + i, j, k, n + + integer (kind=int_kind) :: & + nt_smice, nt_smliq, nt_rhos, nt_rsnw + + logical (kind=log_kind) :: tr_snow + + real (kind=dbl_kind), dimension (nx_block,ny_block) :: & + worka + + real (kind=dbl_kind), dimension (nx_block,ny_block,ncat_hist) :: & + workb + + character(len=*), parameter :: subname = '(accum_hist_snow)' + + !--------------------------------------------------------------- + ! increment field + !--------------------------------------------------------------- + + call icepack_query_tracer_flags(tr_snow_out=tr_snow) + call icepack_query_tracer_indices(nt_smice_out=nt_smice, & + nt_smliq_out=nt_smliq, nt_rhos_out=nt_rhos, nt_rsnw_out=nt_rsnw) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & + file=__FILE__, line=__LINE__) + + if (allocated(a2D)) then + if (tr_snow) then + + if (f_smassice(1:1)/= 'x') then + worka(:,:) = c0 + do k = 1, nzslyr + worka(:,:) = worka(:,:) & + + trcr(:,:,nt_smice+k-1,iblk) + enddo + worka(:,:) = worka(:,:) * vsno(:,:,iblk) / real(nslyr,kind=dbl_kind) + call accum_hist_field(n_smassice, iblk, worka, a2D) + endif + if (f_smassliq(1:1)/= 'x') then + worka(:,:) = c0 + do k = 1, nzslyr + worka(:,:) = worka(:,:) & + + trcr(:,:,nt_smliq+k-1,iblk) + enddo + worka(:,:) = worka(:,:) * vsno(:,:,iblk) / real(nslyr,kind=dbl_kind) + call accum_hist_field(n_smassliq, iblk, worka, a2D) + endif + if (f_rhos_cmp(1:1)/= 'x') then + worka(:,:) = c0 + do k = 1, nzslyr + worka(:,:) = worka(:,:) & + + trcr(:,:,nt_rhos+k-1,iblk) + enddo + worka(:,:) = worka(:,:) / real(nslyr,kind=dbl_kind) + call accum_hist_field(n_rhos_cmp, iblk, worka, a2D) + endif + if (f_rhos_cnt(1:1)/= 'x') then + worka(:,:) = c0 + do k = 1, nzslyr + worka(:,:) = worka(:,:) & + + trcr(:,:,nt_smice+k-1,iblk) & + + trcr(:,:,nt_smliq+k-1,iblk) + enddo + worka(:,:) = worka(:,:) / real(nslyr,kind=dbl_kind) + call accum_hist_field(n_rhos_cnt, iblk, worka, a2D) + endif + if (f_rsnw(1:1)/= 'x') then + worka(:,:) = c0 + do k = 1, nzslyr + worka(:,:) = worka(:,:) & + + trcr(:,:,nt_rsnw+k-1,iblk) + enddo + worka(:,:) = worka(:,:) / real(nslyr,kind=dbl_kind) + call accum_hist_field(n_rsnw, iblk, worka, a2D) + endif + if (f_meltsliq(1:1)/= 'x') & + call accum_hist_field(n_meltsliq, iblk, & + meltsliq(:,:,iblk), a2D) + if (f_fsloss(1:1)/= 'x') & + call accum_hist_field(n_fsloss, iblk, & + fsloss(:,:,iblk), a2D) + + endif ! allocated(a2D) + + ! 3D category fields + if (allocated(a3Dc)) then + if (f_smassicen(1:1)/= 'x') then + workb(:,:,:) = c0 + do n = 1, ncat_hist + do k = 1, nzslyr + workb(:,:,n) = workb(:,:,n) & + + trcrn(:,:,nt_smice+k-1,n,iblk) + enddo + workb(:,:,n) = workb(:,:,n) & + * vsnon(:,:,n,iblk) / real(nslyr,kind=dbl_kind) + enddo + call accum_hist_field(n_smassicen-n2D, iblk, ncat_hist, workb, a3Dc) + endif + if (f_smassliqn(1:1)/= 'x') then + workb(:,:,:) = c0 + do n = 1, ncat_hist + do k = 1, nzslyr + workb(:,:,n) = workb(:,:,n) & + + trcrn(:,:,nt_smliq+k-1,n,iblk) + enddo + workb(:,:,n) = workb(:,:,n) & + * vsnon(:,:,n,iblk) / real(nslyr,kind=dbl_kind) + enddo + call accum_hist_field(n_smassliqn-n2D, iblk, ncat_hist, workb, a3Dc) + endif + if (f_rhos_cmpn(1:1)/= 'x') then + workb(:,:,:) = c0 + do n = 1, ncat_hist + do k = 1, nzslyr + workb(:,:,n) = workb(:,:,n) & + + trcrn(:,:,nt_rhos+k-1,n,iblk) + enddo + workb(:,:,n) = workb(:,:,n) / real(nslyr,kind=dbl_kind) + enddo + call accum_hist_field(n_rhos_cmpn-n2D, iblk, ncat_hist, workb, a3Dc) + endif + if (f_rhos_cntn(1:1)/= 'x') then + workb(:,:,:) = c0 + do n = 1, ncat_hist + do k = 1, nzslyr + workb(:,:,n) = workb(:,:,n) & + + trcrn(:,:,nt_smice+k-1,n,iblk) & + + trcrn(:,:,nt_smliq+k-1,n,iblk) + enddo + workb(:,:,n) = workb(:,:,n) / real(nslyr,kind=dbl_kind) + enddo + call accum_hist_field(n_rhos_cntn-n2D, iblk, ncat_hist, workb, a3Dc) + endif + if (f_rsnwn(1:1)/= 'x') then + workb(:,:,:) = c0 + do n = 1, ncat_hist + do k = 1, nzslyr + workb(:,:,n) = workb(:,:,n) & + + trcrn(:,:,nt_rsnw+k-1,n,iblk) + enddo + workb(:,:,n) = workb(:,:,n) / real(nslyr,kind=dbl_kind) + enddo + call accum_hist_field(n_rsnwn-n2D, iblk, ncat_hist, workb, a3Dc) + endif + endif ! allocated(a3Dc) + + endif ! tr_snow + + end subroutine accum_hist_snow + +!======================================================================= + + end module ice_history_snow + +!======================================================================= diff --git a/cicecore/cicedynB/dynamics/ice_dyn_eap.F90 b/cicecore/cicedynB/dynamics/ice_dyn_eap.F90 index 2face07c2..9c52bb888 100644 --- a/cicecore/cicedynB/dynamics/ice_dyn_eap.F90 +++ b/cicecore/cicedynB/dynamics/ice_dyn_eap.F90 @@ -1206,12 +1206,12 @@ subroutine stress_eap (nx_block, ny_block, & vvel , & ! y-component of velocity (m/s) dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - dxhy , & ! 0.5*(HTE - HTE) - dyhx , & ! 0.5*(HTN - HTN) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm , & ! 0.5*HTN - 1.5*HTN + dxhy , & ! 0.5*(HTE - HTW) + dyhx , & ! 0.5*(HTN - HTS) + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm , & ! 0.5*HTN - 1.5*HTS tarear ! 1/tarea real (kind=dbl_kind), dimension (nx_block,ny_block), intent(inout) :: & diff --git a/cicecore/cicedynB/dynamics/ice_dyn_evp.F90 b/cicecore/cicedynB/dynamics/ice_dyn_evp.F90 index 2206e0de7..276c8bb79 100644 --- a/cicecore/cicedynB/dynamics/ice_dyn_evp.F90 +++ b/cicecore/cicedynB/dynamics/ice_dyn_evp.F90 @@ -34,7 +34,7 @@ module ice_dyn_evp use ice_kinds_mod - use ice_communicate, only: my_task + use ice_communicate, only: my_task, master_task use ice_constants, only: field_loc_center, field_loc_NEcorner, & field_type_scalar, field_type_vector use ice_constants, only: c0, p027, p055, p111, p166, & @@ -88,14 +88,14 @@ subroutine evp (dt) stress12_1, stress12_2, stress12_3, stress12_4 use ice_grid, only: tmask, umask, dxt, dyt, dxhy, dyhx, cxp, cyp, cxm, cym, & tarear, uarear, tinyarea, to_ugrid, t2ugrid_vector, u2tgrid_vector, & - grid_type, HTE, HTN + grid_type use ice_state, only: aice, vice, vsno, uvel, vvel, divu, shear, & aice_init, aice0, aicen, vicen, strength use ice_timers, only: timer_dynamics, timer_bound, & ice_timer_start, ice_timer_stop, timer_evp_1d, timer_evp_2d use ice_dyn_evp_1d, only: ice_dyn_evp_1d_copyin, ice_dyn_evp_1d_kernel, & ice_dyn_evp_1d_copyout - use ice_dyn_shared, only: kevp_kernel, stack_velocity_field, unstack_velocity_field + use ice_dyn_shared, only: evp_algorithm, stack_velocity_field, unstack_velocity_field real (kind=dbl_kind), intent(in) :: & dt ! time step @@ -331,7 +331,7 @@ subroutine evp (dt) if (seabed_stress) then - !$OMP PARALLEL DO PRIVATE(iblk) + !$OMP PARALLEL DO PRIVATE(iblk) do iblk = 1, nblocks if ( seabed_stress_method == 'LKD' ) then @@ -351,118 +351,115 @@ subroutine evp (dt) hwater(:,:,iblk), Tbu(:,:,iblk)) endif - enddo + enddo !$OMP END PARALLEL DO endif + call ice_timer_start(timer_evp_2d) - if (kevp_kernel > 0) then - if (first_time .and. my_task == 0) then - write(nu_diag,'(2a,i6)') subname,' Entering kevp_kernel version ',kevp_kernel - first_time = .false. - endif - if (trim(grid_type) == 'tripole') then - call abort_ice(trim(subname)//' Kernel not tested on tripole grid. Set kevp_kernel=0') - endif - call ice_dyn_evp_1d_copyin( & - nx_block,ny_block,nblocks,nx_global+2*nghost,ny_global+2*nghost, & - HTE,HTN, & -!v1 dxhy,dyhx,cyp,cxp,cym,cxm,tinyarea, & -!v1 waterx,watery, & - icetmask, iceumask, & - cdn_ocn,aiu,uocn,vocn,forcex,forcey,Tbu, & - umassdti,fm,uarear,tarear,strintx,strinty,uvel_init,vvel_init,& - strength,uvel,vvel,dxt,dyt, & - stressp_1 ,stressp_2, stressp_3, stressp_4, & - stressm_1 ,stressm_2, stressm_3, stressm_4, & - stress12_1,stress12_2,stress12_3,stress12_4 ) - if (kevp_kernel == 2) then - call ice_timer_start(timer_evp_1d) - call ice_dyn_evp_1d_kernel() - call ice_timer_stop(timer_evp_1d) -!v1 else if (kevp_kernel == 1) then -!v1 call evp_kernel_v1() - else - if (my_task == 0) write(nu_diag,*) subname,' ERROR: kevp_kernel = ',kevp_kernel - call abort_ice(subname//' kevp_kernel not supported.') - endif - call ice_dyn_evp_1d_copyout( & - nx_block,ny_block,nblocks,nx_global+2*nghost,ny_global+2*nghost,& -!strocn uvel,vvel, strocnx,strocny, strintx,strinty, & - uvel,vvel, strintx,strinty, & - stressp_1, stressp_2, stressp_3, stressp_4, & - stressm_1, stressm_2, stressm_3, stressm_4, & - stress12_1,stress12_2,stress12_3,stress12_4, & - divu,rdg_conv,rdg_shear,shear,taubx,tauby ) - - else ! kevp_kernel == 0 (Standard CICE) - - do ksub = 1,ndte ! subcycling - - !----------------------------------------------------------------- - ! stress tensor equation, total surface stress - !----------------------------------------------------------------- - - !$TCXOMP PARALLEL DO PRIVATE(iblk,strtmp) - do iblk = 1, nblocks -! if (trim(yield_curve) == 'ellipse') then - call stress (nx_block, ny_block, & - ksub, icellt(iblk), & - indxti (:,iblk), indxtj (:,iblk), & - uvel (:,:,iblk), vvel (:,:,iblk), & - dxt (:,:,iblk), dyt (:,:,iblk), & - dxhy (:,:,iblk), dyhx (:,:,iblk), & - cxp (:,:,iblk), cyp (:,:,iblk), & - cxm (:,:,iblk), cym (:,:,iblk), & - tarear (:,:,iblk), tinyarea (:,:,iblk), & - strength (:,:,iblk), & - stressp_1 (:,:,iblk), stressp_2 (:,:,iblk), & - stressp_3 (:,:,iblk), stressp_4 (:,:,iblk), & - stressm_1 (:,:,iblk), stressm_2 (:,:,iblk), & - stressm_3 (:,:,iblk), stressm_4 (:,:,iblk), & - stress12_1(:,:,iblk), stress12_2(:,:,iblk), & - stress12_3(:,:,iblk), stress12_4(:,:,iblk), & - shear (:,:,iblk), divu (:,:,iblk), & - rdg_conv (:,:,iblk), rdg_shear (:,:,iblk), & - strtmp (:,:,:) ) -! endif ! yield_curve - - !----------------------------------------------------------------- - ! momentum equation - !----------------------------------------------------------------- - - call stepu (nx_block, ny_block, & - icellu (iblk), Cdn_ocn (:,:,iblk), & - indxui (:,iblk), indxuj (:,iblk), & - ksub, & - aiu (:,:,iblk), strtmp (:,:,:), & - uocn (:,:,iblk), vocn (:,:,iblk), & - waterx (:,:,iblk), watery (:,:,iblk), & - forcex (:,:,iblk), forcey (:,:,iblk), & - umassdti (:,:,iblk), fm (:,:,iblk), & - uarear (:,:,iblk), & - strintx (:,:,iblk), strinty (:,:,iblk), & - taubx (:,:,iblk), tauby (:,:,iblk), & - uvel_init(:,:,iblk), vvel_init(:,:,iblk),& - uvel (:,:,iblk), vvel (:,:,iblk), & - Tbu (:,:,iblk)) - enddo - !$TCXOMP END PARALLEL DO + if (evp_algorithm == "shared_mem_1d" ) then - call stack_velocity_field(uvel, vvel, fld2) - call ice_timer_start(timer_bound) - if (maskhalo_dyn) then - call ice_HaloUpdate (fld2, halo_info_mask, & - field_loc_NEcorner, field_type_vector) - else - call ice_HaloUpdate (fld2, halo_info, & - field_loc_NEcorner, field_type_vector) + if (first_time .and. my_task == master_task) then + write(nu_diag,'(3a)') subname,' Entering evp_algorithm version ',evp_algorithm + first_time = .false. endif - call ice_timer_stop(timer_bound) - call unstack_velocity_field(fld2, uvel, vvel) + if (trim(grid_type) == 'tripole') then + call abort_ice(trim(subname)//' & + & Kernel not tested on tripole grid. Set evp_algorithm=standard_2d') + endif + + call ice_dyn_evp_1d_copyin( & + nx_block,ny_block,nblocks,nx_global+2*nghost,ny_global+2*nghost, & + icetmask, iceumask, & + cdn_ocn,aiu,uocn,vocn,forcex,forcey,Tbu, & + umassdti,fm,uarear,tarear,strintx,strinty,uvel_init,vvel_init,& + strength,uvel,vvel,dxt,dyt, & + stressp_1 ,stressp_2, stressp_3, stressp_4, & + stressm_1 ,stressm_2, stressm_3, stressm_4, & + stress12_1,stress12_2,stress12_3,stress12_4 ) + call ice_timer_start(timer_evp_1d) + call ice_dyn_evp_1d_kernel() + call ice_timer_stop(timer_evp_1d) + call ice_dyn_evp_1d_copyout( & + nx_block,ny_block,nblocks,nx_global+2*nghost,ny_global+2*nghost,& +!strocn uvel,vvel, strocnx,strocny, strintx,strinty, & + uvel,vvel, strintx,strinty, & + stressp_1, stressp_2, stressp_3, stressp_4, & + stressm_1, stressm_2, stressm_3, stressm_4, & + stress12_1,stress12_2,stress12_3,stress12_4, & + divu,rdg_conv,rdg_shear,shear,taubx,tauby ) + + else ! evp_algorithm == standard_2d (Standard CICE) + + do ksub = 1,ndte ! subcycling + + !----------------------------------------------------------------- + ! stress tensor equation, total surface stress + !----------------------------------------------------------------- + + !$TCXOMP PARALLEL DO PRIVATE(iblk,strtmp) + do iblk = 1, nblocks + +! if (trim(yield_curve) == 'ellipse') then + call stress (nx_block, ny_block, & + ksub, icellt(iblk), & + indxti (:,iblk), indxtj (:,iblk), & + uvel (:,:,iblk), vvel (:,:,iblk), & + dxt (:,:,iblk), dyt (:,:,iblk), & + dxhy (:,:,iblk), dyhx (:,:,iblk), & + cxp (:,:,iblk), cyp (:,:,iblk), & + cxm (:,:,iblk), cym (:,:,iblk), & + tarear (:,:,iblk), tinyarea (:,:,iblk), & + strength (:,:,iblk), & + stressp_1 (:,:,iblk), stressp_2 (:,:,iblk), & + stressp_3 (:,:,iblk), stressp_4 (:,:,iblk), & + stressm_1 (:,:,iblk), stressm_2 (:,:,iblk), & + stressm_3 (:,:,iblk), stressm_4 (:,:,iblk), & + stress12_1(:,:,iblk), stress12_2(:,:,iblk), & + stress12_3(:,:,iblk), stress12_4(:,:,iblk), & + shear (:,:,iblk), divu (:,:,iblk), & + rdg_conv (:,:,iblk), rdg_shear (:,:,iblk), & + strtmp (:,:,:) ) +! endif ! yield_curve + + !----------------------------------------------------------------- + ! momentum equation + !----------------------------------------------------------------- + + call stepu (nx_block, ny_block, & + icellu (iblk), Cdn_ocn (:,:,iblk), & + indxui (:,iblk), indxuj (:,iblk), & + ksub, & + aiu (:,:,iblk), strtmp (:,:,:), & + uocn (:,:,iblk), vocn (:,:,iblk), & + waterx (:,:,iblk), watery (:,:,iblk), & + forcex (:,:,iblk), forcey (:,:,iblk), & + umassdti (:,:,iblk), fm (:,:,iblk), & + uarear (:,:,iblk), & + strintx (:,:,iblk), strinty (:,:,iblk), & + taubx (:,:,iblk), tauby (:,:,iblk), & + uvel_init(:,:,iblk), vvel_init(:,:,iblk),& + uvel (:,:,iblk), vvel (:,:,iblk), & + Tbu (:,:,iblk)) + + enddo + !$TCXOMP END PARALLEL DO + + call stack_velocity_field(uvel, vvel, fld2) + call ice_timer_start(timer_bound) + if (maskhalo_dyn) then + call ice_HaloUpdate (fld2, halo_info_mask, & + field_loc_NEcorner, field_type_vector) + else + call ice_HaloUpdate (fld2, halo_info, & + field_loc_NEcorner, field_type_vector) + endif + call ice_timer_stop(timer_bound) + call unstack_velocity_field(fld2, uvel, vvel) - enddo ! subcycling - endif ! kevp_kernel + enddo ! subcycling + endif ! evp_algorithm + call ice_timer_stop(timer_evp_2d) deallocate(fld2) @@ -610,12 +607,12 @@ subroutine stress (nx_block, ny_block, & vvel , & ! y-component of velocity (m/s) dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - dxhy , & ! 0.5*(HTE - HTE) - dyhx , & ! 0.5*(HTN - HTN) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm , & ! 0.5*HTN - 1.5*HTN + dxhy , & ! 0.5*(HTE - HTW) + dyhx , & ! 0.5*(HTN - HTS) + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm , & ! 0.5*HTN - 1.5*HTS tarear , & ! 1/tarea tinyarea ! puny*tarea diff --git a/cicecore/cicedynB/dynamics/ice_dyn_evp_1d.F90 b/cicecore/cicedynB/dynamics/ice_dyn_evp_1d.F90 old mode 100644 new mode 100755 index 78469cc86..c691453cb --- a/cicecore/cicedynB/dynamics/ice_dyn_evp_1d.F90 +++ b/cicecore/cicedynB/dynamics/ice_dyn_evp_1d.F90 @@ -1,2135 +1,1941 @@ -! ice_dyn_evp_1d +!======================================================================= ! -! Contained 3 Fortran modules, -! * dmi_omp -! * bench_v2 -! * ice_dyn_evp_1d -! These were merged into one module, ice_dyn_evp_1d to support some -! coupled build systems. +! Elastic-viscous-plastic sea ice dynamics model (1D implementations) +! Computes ice velocity and deformation ! -! Modules used for: -! * convert 2D arrays into 1D vectors -! * Do stress/stepu/halo_update interations -! * convert 1D vectors into 2D matrices -! -! Call from ice_dyn_evp.F90: -! call ice_dyn_evp_1d_copyin(...) -! call ice_dyn_evp_1d_kernel() -! call ice_dyn_evp_1d_copyout(...) -! -! * REAL4 internal version: -! mv evp_kernel1d.F90 evp_kernel1d_r8.F90 -! cat evp_kernel1d_r8.F90 | sed s/DBL_KIND/REAL_KIND/g > evp_kernel1d.F90 -! -! * !v1 : a) "dxhy,dyhx,cyp,cxp,cym,cxm,tinyarea" input variables is replaced by -! "HTE,HTN"->"HTE,HTN,HTEm1,HTNm1" and variables are calculated in-line -! b) "waterx,watery" is calculated using existing input "uocn,vocn" -! -! Jacob Weismann Poulsen (JWP), Mads Hvid Ribergaard (MHRI), DMI -!=============================================================================== +! authors: Jacob Weismann Poulsen, DMI +! Mads Hvid Ribergaard, DMI -!=============================================================================== - -!-- One dimension representation of EVP 2D arrays used for EVP kernels module ice_dyn_evp_1d - use ice_kinds_mod - use ice_fileunits, only: nu_diag - use ice_exit, only: abort_ice - use icepack_intfc, only: icepack_query_parameters - use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted - - implicit none - private - public :: ice_dyn_evp_1d_copyin, ice_dyn_evp_1d_copyout, ice_dyn_evp_1d_kernel - - interface ice_dyn_evp_1d_copyin -! module procedure evp_copyin_v1 - module procedure evp_copyin_v2 - end interface - - interface ice_dyn_evp_1d_kernel -! module procedure evp_kernel_v1 - module procedure evp_kernel_v2 - end interface - - interface ice_dyn_evp_1d_copyout - module procedure evp_copyout - end interface - - interface convert_2d_1d -! module procedure convert_2d_1d_v1 - module procedure convert_2d_1d_v2 - end interface - - integer(kind=int_kind) :: & - NA_len, NAVEL_len - logical(kind=log_kind), dimension(:), allocatable :: & - skipucell - integer(kind=int_kind), dimension(:), allocatable :: & - ee,ne,se,nw,sw,sse,indi,indj,indij , halo_parent - real (kind=dbl_kind), dimension(:), allocatable :: & - cdn_ocn,aiu,uocn,vocn,forcex,forcey,Tbu,tarear, & - umassdti,fm,uarear,strintx,strinty,uvel_init,vvel_init - real (kind=dbl_kind), dimension(:), allocatable :: & - strength,uvel,vvel,dxt,dyt, & -!v1 dxhy,dyhx,cyp,cxp,cym,cxm,tinyarea, & -!v1 waterx,watery, & - stressp_1, stressp_2, stressp_3, stressp_4, & - stressm_1, stressm_2, stressm_3, stressm_4, & - stress12_1,stress12_2,stress12_3,stress12_4, & - divu,rdg_conv,rdg_shear,shear,taubx,tauby - real (kind=DBL_KIND), dimension(:), allocatable :: & - str1, str2, str3, str4, str5, str6, str7, str8 - real (kind=dbl_kind), dimension(:), allocatable :: & - HTE,HTN, & - HTEm1,HTNm1 - logical(kind=log_kind),parameter :: dbug = .false. - - -!--- dmi_omp --------------------------- - interface domp_get_domain - module procedure domp_get_domain_rlu - end interface - - INTEGER, PARAMETER :: JPIM = SELECTED_INT_KIND(9) - integer(int_kind) :: domp_iam, domp_nt + use ice_kinds_mod + use ice_fileunits, only : nu_diag + use ice_exit, only : abort_ice + use icepack_intfc, only : icepack_query_parameters + use icepack_intfc, only : icepack_warnings_flush, & + icepack_warnings_aborted + implicit none + private + public :: ice_dyn_evp_1d_copyin, ice_dyn_evp_1d_copyout, & + ice_dyn_evp_1d_kernel + + integer(kind=int_kind) :: NA_len, NAVEL_len, domp_iam, domp_nt #if defined (_OPENMP) - ! Please note, this constant will create a compiler info for a constant - ! expression in IF statements: - real(kind=dbl_kind) :: rdomp_iam, rdomp_nt - !$OMP THREADPRIVATE(domp_iam,domp_nt,rdomp_iam,rdomp_nt) + real(kind=dbl_kind) :: rdomp_iam, rdomp_nt + !$OMP THREADPRIVATE(domp_iam, domp_nt, rdomp_iam, rdomp_nt) #endif -!--- dmi_omp --------------------------- - -!--- bench_v2 -------------------------- - interface evp1d_stress - module procedure stress_i - module procedure stress_l - end interface - interface evp1d_stepu - module procedure stepu_iter - module procedure stepu_last - end interface -!--- bench_v2 -------------------------- + logical(kind=log_kind), dimension(:), allocatable :: skiptcell, skipucell + integer(kind=int_kind), dimension(:), allocatable :: ee, ne, se, & + nw, sw, sse, indi, indj, indij, halo_parent + real(kind=dbl_kind), dimension(:), allocatable :: cdn_ocn, aiu, & + uocn, vocn, forcex, forcey, Tbu, tarear, umassdti, fm, uarear, & + strintx, strinty, uvel_init, vvel_init, strength, uvel, vvel, & + dxt, dyt, stressp_1, stressp_2, stressp_3, stressp_4, stressm_1, & + stressm_2, stressm_3, stressm_4, stress12_1, stress12_2, & + stress12_3, stress12_4, divu, rdg_conv, rdg_shear, shear, taubx, & + tauby, str1, str2, str3, str4, str5, str6, str7, str8, HTE, HTN, & + HTEm1, HTNm1 + integer, parameter :: JPIM = selected_int_kind(9) + + interface evp1d_stress + module procedure stress_iter + module procedure stress_last + end interface + + interface evp1d_stepu + module procedure stepu_iter + module procedure stepu_last + end interface + +!======================================================================= + +contains + +!======================================================================= + + subroutine domp_init +#if defined (_OPENMP) - contains + use omp_lib, only : omp_get_thread_num, omp_get_num_threads +#endif -!=============================================================================== -!former module dmi_omp + implicit none - subroutine domp_init(nt_out) + character(len=*), parameter :: subname = '(domp_init)' + !$OMP PARALLEL DEFAULT(none) #if defined (_OPENMP) - use omp_lib, only : omp_get_thread_num, omp_get_num_threads + domp_iam = omp_get_thread_num() + rdomp_iam = real(domp_iam, dbl_kind) + domp_nt = omp_get_num_threads() + rdomp_nt = real(domp_nt, dbl_kind) +#else + domp_iam = 0 + domp_nt = 1 #endif + !$OMP END PARALLEL - integer(int_kind), intent(out) :: nt_out + end subroutine domp_init - character(len=*), parameter :: subname = '(domp_init)' - !--------------------------------------- +!======================================================================= - !$OMP PARALLEL DEFAULT(none) + subroutine domp_get_domain(lower, upper, d_lower, d_upper) #if defined (_OPENMP) - domp_iam = omp_get_thread_num() - rdomp_iam = real(domp_iam,dbl_kind) - domp_nt = omp_get_num_threads() - rdomp_nt = real(domp_nt,dbl_kind) -#else - domp_iam = 0 - domp_nt = 1 -#endif - !$OMP END PARALLEL - - if (dbug) then -#if defined (_OPENACC) - write(nu_diag,'(2a)') subname,' Build with openACC support' -!#elif defined (_OPENMP) -! write(nu_diag,'(2a)') subname,' Build with openMP support' -!#else -! write(nu_diag,'(2a)') subname,' Build without openMP and openACC support' + + use omp_lib, only : omp_in_parallel + use ice_constants, only : p5 #endif - !- echo #threads: - if (domp_nt > 1) then - write(nu_diag,'(2a,i5,a)') subname,' Running openMP with ', domp_nt, ' threads' - else + implicit none + + integer(kind=JPIM), intent(in) :: lower, upper + integer(kind=JPIM), intent(out) :: d_lower, d_upper + + ! local variables #if defined (_OPENMP) - write(nu_diag,'(2a)') subname,' Running openMP with a single thread' -#else - write(nu_diag,'(2a)') subname,' Running without openMP' -#endif - endif - endif - !- return value of #threads: - nt_out = domp_nt + real(kind=dbl_kind) :: dlen +#endif - end subroutine domp_init - -!---------------------------------------------------------------------------- + character(len=*), parameter :: subname = '(domp_get_domain)' - subroutine domp_get_domain_rlu(lower,upper,d_lower,d_upper) + ! proper action in "null" case + if (upper <= 0 .or. upper < lower) then + d_lower = 0 + d_upper = -1 + return + end if + ! proper action in serial case + d_lower = lower + d_upper = upper #if defined (_OPENMP) - use omp_lib, only : omp_in_parallel - use ice_constants, only: p5 + + if (omp_in_parallel()) then + dlen = real((upper - lower + 1), dbl_kind) + d_lower = lower + floor(((rdomp_iam * dlen + p5) / rdomp_nt), JPIM) + d_upper = lower - 1 + floor(((rdomp_iam * dlen + dlen + p5) / rdomp_nt), JPIM) + end if #endif - integer(KIND=JPIM), intent(in) :: lower,upper - integer(KIND=JPIM), intent(out) :: d_lower,d_upper + end subroutine domp_get_domain + +!======================================================================= + + subroutine stress_iter(NA_len, ee, ne, se, lb, ub, uvel, vvel, dxt, & + dyt, hte, htn, htem1, htnm1, strength, stressp_1, stressp_2, & + stressp_3, stressp_4, stressm_1, stressm_2, stressm_3, & + stressm_4, stress12_1, stress12_2, stress12_3, stress12_4, str1, & + str2, str3, str4, str5, str6, str7, str8, skiptcell) + + use ice_kinds_mod + use ice_constants, only : p027, p055, p111, p166, p222, p25, & + p333, p5, c1p5, c1 + use ice_dyn_shared, only : ecci, denom1, arlx1i, Ktens, revp + + implicit none + + integer(kind=int_kind), intent(in) :: NA_len, lb, ub + integer(kind=int_kind), dimension(:), intent(in), contiguous :: & + ee, ne, se + real(kind=dbl_kind), dimension(:), intent(in), contiguous :: & + strength, uvel, vvel, dxt, dyt, hte, htn, htem1, htnm1 + logical(kind=log_kind), intent(in), dimension(:) :: skiptcell + real(kind=dbl_kind), dimension(:), intent(inout), contiguous :: & + stressp_1, stressp_2, stressp_3, stressp_4, stressm_1, & + stressm_2, stressm_3, stressm_4, stress12_1, stress12_2, & + stress12_3, stress12_4 + real(kind=dbl_kind), dimension(:), intent(out), contiguous :: & + str1, str2, str3, str4, str5, str6, str7, str8 + + ! local variables + + integer(kind=int_kind) :: iw, il, iu + real(kind=dbl_kind) :: puny, divune, divunw, divuse, divusw, & + tensionne, tensionnw, tensionse, tensionsw, shearne, shearnw, & + shearse, shearsw, Deltane, Deltanw, Deltase, Deltasw, c0ne, & + c0nw, c0se, c0sw, c1ne, c1nw, c1se, c1sw, ssigpn, ssigps, & + ssigpe, ssigpw, ssigmn, ssigms, ssigme, ssigmw, ssig12n, & + ssig12s, ssig12e, ssig12w, ssigp1, ssigp2, ssigm1, ssigm2, & + ssig121, ssig122, csigpne, csigpnw, csigpse, csigpsw, & + csigmne, csigmnw, csigmse, csigmsw, csig12ne, csig12nw, & + csig12se, csig12sw, str12ew, str12we, str12ns, str12sn, & + strp_tmp, strm_tmp, tmp_uvel_ee, tmp_vvel_se, tmp_vvel_ee, & + tmp_vvel_ne, tmp_uvel_ne, tmp_uvel_se, dxhy, dyhx, cxp, cyp, & + cxm, cym, tinyarea,tmparea + + character(len=*), parameter :: subname = '(stress_iter)' + + call icepack_query_parameters(puny_out=puny) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) then + call abort_ice(error_message=subname, file=__FILE__, & + line=__LINE__) + end if -#if defined (_OPENMP) - !-- local variables - real(kind=dbl_kind) :: dlen +#ifdef _OPENACC + !$acc parallel & + !$acc present(ee, ne, se, strength, uvel, vvel, dxt, dyt, hte, & + !$acc htn, htem1, htnm1, str1, str2, str3, str4, str5, str6, & + !$acc str7, str8, stressp_1, stressp_2, stressp_3, stressp_4, & + !$acc stressm_1, stressm_2, stressm_3, stressm_4, stress12_1, & + !$acc stress12_2, stress12_3, stress12_4, skiptcell) + !$acc loop + do iw = 1, NA_len +#else + call domp_get_domain(lb, ub, il, iu) + do iw = il, iu #endif - character(len=*), parameter :: subname = '(domp_get_domain_rlu)' - !--------------------------------------- + if (skiptcell(iw)) cycle + + tmparea = dxt(iw) * dyt(iw) ! necessary to split calc of tinyarea. Otherwize not binary identical + tinyarea = puny * tmparea + dxhy = p5 * (hte(iw) - htem1(iw)) + dyhx = p5 * (htn(iw) - htnm1(iw)) + cxp = c1p5 * htn(iw) - p5 * htnm1(iw) + cyp = c1p5 * hte(iw) - p5 * htem1(iw) + cxm = -(c1p5 * htnm1(iw) - p5 * htn(iw)) + cym = -(c1p5 * htem1(iw) - p5 * hte(iw)) + + !-------------------------------------------------------------- + ! strain rates + ! NOTE: these are actually strain rates * area (m^2/s) + !-------------------------------------------------------------- + + tmp_uvel_ne = uvel(ne(iw)) + tmp_uvel_se = uvel(se(iw)) + tmp_uvel_ee = uvel(ee(iw)) + + tmp_vvel_ee = vvel(ee(iw)) + tmp_vvel_se = vvel(se(iw)) + tmp_vvel_ne = vvel(ne(iw)) + ! divergence = e_11 + e_22 + divune = cyp * uvel(iw) - dyt(iw) * tmp_uvel_ee & + + cxp * vvel(iw) - dxt(iw) * tmp_vvel_se + divunw = cym * tmp_uvel_ee + dyt(iw) * uvel(iw) & + + cxp * tmp_vvel_ee - dxt(iw) * tmp_vvel_ne + divusw = cym * tmp_uvel_ne + dyt(iw) * tmp_uvel_se & + + cxm * tmp_vvel_ne + dxt(iw) * tmp_vvel_ee + divuse = cyp * tmp_uvel_se - dyt(iw) * tmp_uvel_ne & + + cxm * tmp_vvel_se + dxt(iw) * vvel(iw) + + ! tension strain rate = e_11 - e_22 + tensionne = -cym * uvel(iw) - dyt(iw) * tmp_uvel_ee & + + cxm * vvel(iw) + dxt(iw) * tmp_vvel_se + tensionnw = -cyp * tmp_uvel_ee + dyt(iw) * uvel(iw) & + + cxm * tmp_vvel_ee + dxt(iw) * tmp_vvel_ne + tensionsw = -cyp * tmp_uvel_ne + dyt(iw) * tmp_uvel_se & + + cxp * tmp_vvel_ne - dxt(iw) * tmp_vvel_ee + tensionse = -cym * tmp_uvel_se - dyt(iw) * tmp_uvel_ne & + + cxp * tmp_vvel_se - dxt(iw) * vvel(iw) + + ! shearing strain rate = 2 * e_12 + shearne = -cym * vvel(iw) - dyt(iw) * tmp_vvel_ee & + - cxm * uvel(iw) - dxt(iw) * tmp_uvel_se + shearnw = -cyp * tmp_vvel_ee + dyt(iw) * vvel(iw) & + - cxm * tmp_uvel_ee - dxt(iw) * tmp_uvel_ne + shearsw = -cyp * tmp_vvel_ne + dyt(iw) * tmp_vvel_se & + - cxp * tmp_uvel_ne + dxt(iw) * tmp_uvel_ee + shearse = -cym * tmp_vvel_se - dyt(iw) * tmp_vvel_ne & + - cxp * tmp_uvel_se + dxt(iw) * uvel(iw) + + ! Delta (in the denominator of zeta and eta) + Deltane = sqrt(divune**2 + ecci * (tensionne**2 + shearne**2)) + Deltanw = sqrt(divunw**2 + ecci * (tensionnw**2 + shearnw**2)) + Deltasw = sqrt(divusw**2 + ecci * (tensionsw**2 + shearsw**2)) + Deltase = sqrt(divuse**2 + ecci * (tensionse**2 + shearse**2)) + + !-------------------------------------------------------------- + ! replacement pressure/Delta (kg/s) + ! save replacement pressure for principal stress calculation + !-------------------------------------------------------------- + + c0ne = strength(iw) / max(Deltane, tinyarea) + c0nw = strength(iw) / max(Deltanw, tinyarea) + c0sw = strength(iw) / max(Deltasw, tinyarea) + c0se = strength(iw) / max(Deltase, tinyarea) + + c1ne = c0ne * arlx1i + c1nw = c0nw * arlx1i + c1sw = c0sw * arlx1i + c1se = c0se * arlx1i + + c0ne = c1ne * ecci + c0nw = c1nw * ecci + c0sw = c1sw * ecci + c0se = c1se * ecci + + !-------------------------------------------------------------- + ! the stresses (kg/s^2) + ! (1) northeast, (2) northwest, (3) southwest, (4) southeast + !-------------------------------------------------------------- + + stressp_1(iw) = (stressp_1(iw) * (c1 - arlx1i * revp) & + + c1ne * (divune * (c1 + Ktens) - Deltane * (c1 - Ktens))) * denom1 + stressp_2(iw) = (stressp_2(iw) * (c1 - arlx1i * revp) & + + c1nw * (divunw * (c1 + Ktens) - Deltanw * (c1 - Ktens))) * denom1 + stressp_3(iw) = (stressp_3(iw) * (c1 - arlx1i * revp) & + + c1sw * (divusw * (c1 + Ktens) - Deltasw * (c1 - Ktens))) * denom1 + stressp_4(iw) = (stressp_4(iw) * (c1 - arlx1i * revp) & + + c1se * (divuse * (c1 + Ktens) - Deltase * (c1 - Ktens))) * denom1 + + stressm_1(iw) = (stressm_1(iw) * (c1 - arlx1i * revp) + c0ne * tensionne * (c1 + Ktens)) * denom1 + stressm_2(iw) = (stressm_2(iw) * (c1 - arlx1i * revp) + c0nw * tensionnw * (c1 + Ktens)) * denom1 + stressm_3(iw) = (stressm_3(iw) * (c1 - arlx1i * revp) + c0sw * tensionsw * (c1 + Ktens)) * denom1 + stressm_4(iw) = (stressm_4(iw) * (c1 - arlx1i * revp) + c0se * tensionse * (c1 + Ktens)) * denom1 + + stress12_1(iw) = (stress12_1(iw) * (c1 - arlx1i * revp) + c0ne * shearne * p5 * (c1 + Ktens)) * denom1 + stress12_2(iw) = (stress12_2(iw) * (c1 - arlx1i * revp) + c0nw * shearnw * p5 * (c1 + Ktens)) * denom1 + stress12_3(iw) = (stress12_3(iw) * (c1 - arlx1i * revp) + c0sw * shearsw * p5 * (c1 + Ktens)) * denom1 + stress12_4(iw) = (stress12_4(iw) * (c1 - arlx1i * revp) + c0se * shearse * p5 * (c1 + Ktens)) * denom1 + + !-------------------------------------------------------------- + ! combinations of the stresses for the momentum equation + ! (kg/s^2) + !-------------------------------------------------------------- + + ssigpn = stressp_1(iw) + stressp_2(iw) + ssigps = stressp_3(iw) + stressp_4(iw) + ssigpe = stressp_1(iw) + stressp_4(iw) + ssigpw = stressp_2(iw) + stressp_3(iw) + ssigp1 = (stressp_1(iw) + stressp_3(iw)) * p055 + ssigp2 = (stressp_2(iw) + stressp_4(iw)) * p055 + + ssigmn = stressm_1(iw) + stressm_2(iw) + ssigms = stressm_3(iw) + stressm_4(iw) + ssigme = stressm_1(iw) + stressm_4(iw) + ssigmw = stressm_2(iw) + stressm_3(iw) + ssigm1 = (stressm_1(iw) + stressm_3(iw)) * p055 + ssigm2 = (stressm_2(iw) + stressm_4(iw)) * p055 + + ssig12n = stress12_1(iw) + stress12_2(iw) + ssig12s = stress12_3(iw) + stress12_4(iw) + ssig12e = stress12_1(iw) + stress12_4(iw) + ssig12w = stress12_2(iw) + stress12_3(iw) + ssig121 = (stress12_1(iw) + stress12_3(iw)) * p111 + ssig122 = (stress12_2(iw) + stress12_4(iw)) * p111 + + csigpne = p111 * stressp_1(iw) + ssigp2 + p027 * stressp_3(iw) + csigpnw = p111 * stressp_2(iw) + ssigp1 + p027 * stressp_4(iw) + csigpsw = p111 * stressp_3(iw) + ssigp2 + p027 * stressp_1(iw) + csigpse = p111 * stressp_4(iw) + ssigp1 + p027 * stressp_2(iw) + + csigmne = p111 * stressm_1(iw) + ssigm2 + p027 * stressm_3(iw) + csigmnw = p111 * stressm_2(iw) + ssigm1 + p027 * stressm_4(iw) + csigmsw = p111 * stressm_3(iw) + ssigm2 + p027 * stressm_1(iw) + csigmse = p111 * stressm_4(iw) + ssigm1 + p027 * stressm_2(iw) + + csig12ne = p222 * stress12_1(iw) + ssig122 + p055 * stress12_3(iw) + csig12nw = p222 * stress12_2(iw) + ssig121 + p055 * stress12_4(iw) + csig12sw = p222 * stress12_3(iw) + ssig122 + p055 * stress12_1(iw) + csig12se = p222 * stress12_4(iw) + ssig121 + p055 * stress12_2(iw) + + str12ew = p5 * dxt(iw) * (p333 * ssig12e + p166 * ssig12w) + str12we = p5 * dxt(iw) * (p333 * ssig12w + p166 * ssig12e) + str12ns = p5 * dyt(iw) * (p333 * ssig12n + p166 * ssig12s) + str12sn = p5 * dyt(iw) * (p333 * ssig12s + p166 * ssig12n) + + !-------------------------------------------------------------- + ! for dF/dx (u momentum) + !-------------------------------------------------------------- + + strp_tmp = p25 * dyt(iw) * (p333 * ssigpn + p166 * ssigps) + strm_tmp = p25 * dyt(iw) * (p333 * ssigmn + p166 * ssigms) + + ! northeast (i,j) + str1(iw) = -strp_tmp - strm_tmp - str12ew & + + dxhy * (-csigpne + csigmne) + dyhx * csig12ne + + ! northwest (i+1,j) + str2(iw) = strp_tmp + strm_tmp - str12we & + + dxhy * (-csigpnw + csigmnw) + dyhx * csig12nw + + strp_tmp = p25 * dyt(iw) * (p333 * ssigps + p166 * ssigpn) + strm_tmp = p25 * dyt(iw) * (p333 * ssigms + p166 * ssigmn) + + ! southeast (i,j+1) + str3(iw) = -strp_tmp - strm_tmp + str12ew & + + dxhy * (-csigpse + csigmse) + dyhx * csig12se + + ! southwest (i+1,j+1) + str4(iw) = strp_tmp + strm_tmp + str12we & + + dxhy * (-csigpsw + csigmsw) + dyhx * csig12sw + + !-------------------------------------------------------------- + ! for dF/dy (v momentum) + !-------------------------------------------------------------- + + strp_tmp = p25 * dxt(iw) * (p333 * ssigpe + p166 * ssigpw) + strm_tmp = p25 * dxt(iw) * (p333 * ssigme + p166 * ssigmw) + + ! northeast (i,j) + str5(iw) = -strp_tmp + strm_tmp - str12ns & + - dyhx * (csigpne + csigmne) + dxhy * csig12ne + + ! southeast (i,j+1) + str6(iw) = strp_tmp - strm_tmp - str12sn & + - dyhx * (csigpse + csigmse) + dxhy * csig12se + + strp_tmp = p25 * dxt(iw) * (p333 * ssigpw + p166 * ssigpe) + strm_tmp = p25 * dxt(iw) * (p333 * ssigmw + p166 * ssigme) + + ! northwest (i+1,j) + str7(iw) = -strp_tmp + strm_tmp + str12ns & + - dyhx * (csigpnw + csigmnw) + dxhy * csig12nw + + ! southwest (i+1,j+1) + str8(iw) = strp_tmp - strm_tmp + str12sn & + - dyhx * (csigpsw + csigmsw) + dxhy * csig12sw + + end do +#ifdef _OPENACC + !$acc end parallel +#endif - ! proper action in "null" cases: - if (upper <= 0 .or. upper < lower) then - d_lower = 0 - d_upper = -1 - return - endif + end subroutine stress_iter + +!======================================================================= + + subroutine stress_last(NA_len, ee, ne, se, lb, ub, uvel, vvel, dxt, & + dyt, hte, htn, htem1, htnm1, strength, stressp_1, stressp_2, & + stressp_3, stressp_4, stressm_1, stressm_2, stressm_3, & + stressm_4, stress12_1, stress12_2, stress12_3, stress12_4, str1, & + str2, str3, str4, str5, str6, str7, str8, skiptcell, tarear, divu, & + rdg_conv, rdg_shear, shear) + + use ice_kinds_mod + use ice_constants, only : p027, p055, p111, p166, p222, p25, & + p333, p5, c1p5, c1, c0 + use ice_dyn_shared, only : ecci, denom1, arlx1i, Ktens, revp + + implicit none + + integer(kind=int_kind), intent(in) :: NA_len, lb, ub + integer(kind=int_kind), dimension(:), intent(in), contiguous :: & + ee, ne, se + real(kind=dbl_kind), dimension(:), intent(in), contiguous :: & + strength, uvel, vvel, dxt, dyt, hte, htn, htem1, htnm1, tarear + logical(kind=log_kind), intent(in), dimension(:) :: skiptcell + real(kind=dbl_kind), dimension(:), intent(inout), contiguous :: & + stressp_1, stressp_2, stressp_3, stressp_4, stressm_1, & + stressm_2, stressm_3, stressm_4, stress12_1, stress12_2, & + stress12_3, stress12_4 + real(kind=dbl_kind), dimension(:), intent(out), contiguous :: & + str1, str2, str3, str4, str5, str6, str7, str8, divu, & + rdg_conv, rdg_shear, shear + + ! local variables + + integer(kind=int_kind) :: iw, il, iu + real(kind=dbl_kind) :: puny, divune, divunw, divuse, divusw, & + tensionne, tensionnw, tensionse, tensionsw, shearne, shearnw, & + shearse, shearsw, Deltane, Deltanw, Deltase, Deltasw, c0ne, & + c0nw, c0se, c0sw, c1ne, c1nw, c1se, c1sw, ssigpn, ssigps, & + ssigpe, ssigpw, ssigmn, ssigms, ssigme, ssigmw, ssig12n, & + ssig12s, ssig12e, ssig12w, ssigp1, ssigp2, ssigm1, ssigm2, & + ssig121, ssig122, csigpne, csigpnw, csigpse, csigpsw, & + csigmne, csigmnw, csigmse, csigmsw, csig12ne, csig12nw, & + csig12se, csig12sw, str12ew, str12we, str12ns, str12sn, & + strp_tmp, strm_tmp, tmp_uvel_ee, tmp_vvel_se, tmp_vvel_ee, & + tmp_vvel_ne, tmp_uvel_ne, tmp_uvel_se, dxhy, dyhx, cxp, cyp, & + cxm, cym, tinyarea, tmparea + + character(len=*), parameter :: subname = '(stress_last)' + + call icepack_query_parameters(puny_out=puny) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) then + call abort_ice(error_message=subname, file=__FILE__, & + line=__LINE__) + end if - ! proper action in serial sections - d_lower = lower - d_upper = upper +#ifdef _OPENACC + !$acc parallel & + !$acc present(ee, ne, se, strength, uvel, vvel, dxt, dyt, hte, & + !$acc htn, htem1, htnm1, str1, str2, str3, str4, str5, str6, & + !$acc str7, str8, stressp_1, stressp_2, stressp_3, stressp_4, & + !$acc stressm_1, stressm_2, stressm_3, stressm_4, stress12_1, & + !$acc stress12_2, stress12_3, stress12_4, tarear, divu, & + !$acc rdg_conv, rdg_shear, shear, skiptcell) + !$acc loop + do iw = 1, NA_len +#else + call domp_get_domain(lb, ub, il, iu) + do iw = il, iu +#endif -#if defined (_OPENMP) - if (omp_in_parallel()) then - dlen = real(upper-lower+1, dbl_kind) - d_lower = lower + floor((rdomp_iam*dlen+p5)/rdomp_nt, JPIM) - d_upper = lower -1 + floor((rdomp_iam*dlen+dlen+p5)/rdomp_nt, JPIM) - endif + if (skiptcell(iw)) cycle + + tmparea = dxt(iw) * dyt(iw) ! necessary to split calc of tinyarea. Otherwize not binary identical + tinyarea = puny * tmparea + dxhy = p5 * (hte(iw) - htem1(iw)) + dyhx = p5 * (htn(iw) - htnm1(iw)) + cxp = c1p5 * htn(iw) - p5 * htnm1(iw) + cyp = c1p5 * hte(iw) - p5 * htem1(iw) + cxm = -(c1p5 * htnm1(iw) - p5 * htn(iw)) + cym = -(c1p5 * htem1(iw) - p5 * hte(iw)) + + !-------------------------------------------------------------- + ! strain rates + ! NOTE: these are actually strain rates * area (m^2/s) + !-------------------------------------------------------------- + + tmp_uvel_ne = uvel(ne(iw)) + tmp_uvel_se = uvel(se(iw)) + tmp_uvel_ee = uvel(ee(iw)) + + tmp_vvel_ee = vvel(ee(iw)) + tmp_vvel_se = vvel(se(iw)) + tmp_vvel_ne = vvel(ne(iw)) + + ! divergence = e_11 + e_22 + divune = cyp * uvel(iw) - dyt(iw) * tmp_uvel_ee & + + cxp * vvel(iw) - dxt(iw) * tmp_vvel_se + divunw = cym * tmp_uvel_ee + dyt(iw) * uvel(iw) & + + cxp * tmp_vvel_ee - dxt(iw) * tmp_vvel_ne + divusw = cym * tmp_uvel_ne + dyt(iw) * tmp_uvel_se & + + cxm * tmp_vvel_ne + dxt(iw) * tmp_vvel_ee + divuse = cyp * tmp_uvel_se - dyt(iw) * tmp_uvel_ne & + + cxm * tmp_vvel_se + dxt(iw) * vvel(iw) + + ! tension strain rate = e_11 - e_22 + tensionne = -cym * uvel(iw) - dyt(iw) * tmp_uvel_ee & + + cxm * vvel(iw) + dxt(iw) * tmp_vvel_se + tensionnw = -cyp * tmp_uvel_ee + dyt(iw) * uvel(iw) & + + cxm * tmp_vvel_ee + dxt(iw) * tmp_vvel_ne + tensionsw = -cyp * tmp_uvel_ne + dyt(iw) * tmp_uvel_se & + + cxp * tmp_vvel_ne - dxt(iw) * tmp_vvel_ee + tensionse = -cym * tmp_uvel_se - dyt(iw) * tmp_uvel_ne & + + cxp * tmp_vvel_se - dxt(iw) * vvel(iw) + + ! shearing strain rate = 2 * e_12 + shearne = -cym * vvel(iw) - dyt(iw) * tmp_vvel_ee & + - cxm * uvel(iw) - dxt(iw) * tmp_uvel_se + shearnw = -cyp * tmp_vvel_ee + dyt(iw) * vvel(iw) & + - cxm * tmp_uvel_ee - dxt(iw) * tmp_uvel_ne + shearsw = -cyp * tmp_vvel_ne + dyt(iw) * tmp_vvel_se & + - cxp * tmp_uvel_ne + dxt(iw) * tmp_uvel_ee + shearse = -cym * tmp_vvel_se - dyt(iw) * tmp_vvel_ne & + - cxp * tmp_uvel_se + dxt(iw) * uvel(iw) + + ! Delta (in the denominator of zeta and eta) + Deltane = sqrt(divune**2 + ecci * (tensionne**2 + shearne**2)) + Deltanw = sqrt(divunw**2 + ecci * (tensionnw**2 + shearnw**2)) + Deltasw = sqrt(divusw**2 + ecci * (tensionsw**2 + shearsw**2)) + Deltase = sqrt(divuse**2 + ecci * (tensionse**2 + shearse**2)) + + !-------------------------------------------------------------- + ! on last subcycle, save quantities for mechanical + ! redistribution + !-------------------------------------------------------------- + + divu(iw) = p25 * (divune + divunw + divuse + divusw) * tarear(iw) + rdg_conv(iw) = -min(divu(iw), c0) ! TODO: Could move outside the entire kernel + rdg_shear(iw) = p5 * (p25 * (Deltane + Deltanw + Deltase + Deltasw) * tarear(iw) - abs(divu(iw))) + + ! diagnostic only + ! shear = sqrt(tension**2 + shearing**2) + shear(iw) = p25 * tarear(iw) * sqrt((tensionne + tensionnw + tensionse + tensionsw)**2 & + + (shearne + shearnw + shearse + shearsw)**2) + + !-------------------------------------------------------------- + ! replacement pressure/Delta (kg/s) + ! save replacement pressure for principal stress calculation + !-------------------------------------------------------------- + + c0ne = strength(iw) / max(Deltane, tinyarea) + c0nw = strength(iw) / max(Deltanw, tinyarea) + c0sw = strength(iw) / max(Deltasw, tinyarea) + c0se = strength(iw) / max(Deltase, tinyarea) + + c1ne = c0ne * arlx1i + c1nw = c0nw * arlx1i + c1sw = c0sw * arlx1i + c1se = c0se * arlx1i + + c0ne = c1ne * ecci + c0nw = c1nw * ecci + c0sw = c1sw * ecci + c0se = c1se * ecci + + !-------------------------------------------------------------- + ! the stresses (kg/s^2) + ! (1) northeast, (2) northwest, (3) southwest, (4) southeast + !-------------------------------------------------------------- + + stressp_1(iw) = (stressp_1(iw) * (c1 - arlx1i * revp) & + + c1ne * (divune * (c1 + Ktens) - Deltane * (c1 - Ktens))) * denom1 + stressp_2(iw) = (stressp_2(iw) * (c1 - arlx1i * revp) & + + c1nw * (divunw * (c1 + Ktens) - Deltanw * (c1 - Ktens))) * denom1 + stressp_3(iw) = (stressp_3(iw) * (c1 - arlx1i * revp) & + + c1sw * (divusw * (c1 + Ktens) - Deltasw * (c1 - Ktens))) * denom1 + stressp_4(iw) = (stressp_4(iw) * (c1 - arlx1i * revp) & + + c1se * (divuse * (c1 + Ktens) - Deltase * (c1 - Ktens))) * denom1 + + stressm_1(iw) = (stressm_1(iw) * (c1 - arlx1i * revp) + c0ne * tensionne * (c1 + Ktens)) * denom1 + stressm_2(iw) = (stressm_2(iw) * (c1 - arlx1i * revp) + c0nw * tensionnw * (c1 + Ktens)) * denom1 + stressm_3(iw) = (stressm_3(iw) * (c1 - arlx1i * revp) + c0sw * tensionsw * (c1 + Ktens)) * denom1 + stressm_4(iw) = (stressm_4(iw) * (c1 - arlx1i * revp) + c0se * tensionse * (c1 + Ktens)) * denom1 + + stress12_1(iw) = (stress12_1(iw) * (c1 - arlx1i * revp) + c0ne * shearne * p5 * (c1 + Ktens)) * denom1 + stress12_2(iw) = (stress12_2(iw) * (c1 - arlx1i * revp) + c0nw * shearnw * p5 * (c1 + Ktens)) * denom1 + stress12_3(iw) = (stress12_3(iw) * (c1 - arlx1i * revp) + c0sw * shearsw * p5 * (c1 + Ktens)) * denom1 + stress12_4(iw) = (stress12_4(iw) * (c1 - arlx1i * revp) + c0se * shearse * p5 * (c1 + Ktens)) * denom1 + + !-------------------------------------------------------------- + ! combinations of the stresses for the momentum equation + ! (kg/s^2) + !-------------------------------------------------------------- + + ssigpn = stressp_1(iw) + stressp_2(iw) + ssigps = stressp_3(iw) + stressp_4(iw) + ssigpe = stressp_1(iw) + stressp_4(iw) + ssigpw = stressp_2(iw) + stressp_3(iw) + ssigp1 = (stressp_1(iw) + stressp_3(iw)) * p055 + ssigp2 = (stressp_2(iw) + stressp_4(iw)) * p055 + + ssigmn = stressm_1(iw) + stressm_2(iw) + ssigms = stressm_3(iw) + stressm_4(iw) + ssigme = stressm_1(iw) + stressm_4(iw) + ssigmw = stressm_2(iw) + stressm_3(iw) + ssigm1 = (stressm_1(iw) + stressm_3(iw)) * p055 + ssigm2 = (stressm_2(iw) + stressm_4(iw)) * p055 + + ssig12n = stress12_1(iw) + stress12_2(iw) + ssig12s = stress12_3(iw) + stress12_4(iw) + ssig12e = stress12_1(iw) + stress12_4(iw) + ssig12w = stress12_2(iw) + stress12_3(iw) + ssig121 = (stress12_1(iw) + stress12_3(iw)) * p111 + ssig122 = (stress12_2(iw) + stress12_4(iw)) * p111 + + csigpne = p111 * stressp_1(iw) + ssigp2 + p027 * stressp_3(iw) + csigpnw = p111 * stressp_2(iw) + ssigp1 + p027 * stressp_4(iw) + csigpsw = p111 * stressp_3(iw) + ssigp2 + p027 * stressp_1(iw) + csigpse = p111 * stressp_4(iw) + ssigp1 + p027 * stressp_2(iw) + + csigmne = p111 * stressm_1(iw) + ssigm2 + p027 * stressm_3(iw) + csigmnw = p111 * stressm_2(iw) + ssigm1 + p027 * stressm_4(iw) + csigmsw = p111 * stressm_3(iw) + ssigm2 + p027 * stressm_1(iw) + csigmse = p111 * stressm_4(iw) + ssigm1 + p027 * stressm_2(iw) + + csig12ne = p222 * stress12_1(iw) + ssig122 + p055 * stress12_3(iw) + csig12nw = p222 * stress12_2(iw) + ssig121 + p055 * stress12_4(iw) + csig12sw = p222 * stress12_3(iw) + ssig122 + p055 * stress12_1(iw) + csig12se = p222 * stress12_4(iw) + ssig121 + p055 * stress12_2(iw) + + str12ew = p5 * dxt(iw) * (p333 * ssig12e + p166 * ssig12w) + str12we = p5 * dxt(iw) * (p333 * ssig12w + p166 * ssig12e) + str12ns = p5 * dyt(iw) * (p333 * ssig12n + p166 * ssig12s) + str12sn = p5 * dyt(iw) * (p333 * ssig12s + p166 * ssig12n) + + !-------------------------------------------------------------- + ! for dF/dx (u momentum) + !-------------------------------------------------------------- + + strp_tmp = p25 * dyt(iw) * (p333 * ssigpn + p166 * ssigps) + strm_tmp = p25 * dyt(iw) * (p333 * ssigmn + p166 * ssigms) + + ! northeast (i,j) + str1(iw) = -strp_tmp - strm_tmp - str12ew & + + dxhy * (-csigpne + csigmne) + dyhx * csig12ne + + ! northwest (i+1,j) + str2(iw) = strp_tmp + strm_tmp - str12we & + + dxhy * (-csigpnw + csigmnw) + dyhx * csig12nw + + strp_tmp = p25 * dyt(iw) * (p333 * ssigps + p166 * ssigpn) + strm_tmp = p25 * dyt(iw) * (p333 * ssigms + p166 * ssigmn) + + ! southeast (i,j+1) + str3(iw) = -strp_tmp - strm_tmp + str12ew & + + dxhy * (-csigpse + csigmse) + dyhx * csig12se + + ! southwest (i+1,j+1) + str4(iw) = strp_tmp + strm_tmp + str12we & + + dxhy * (-csigpsw + csigmsw) + dyhx * csig12sw + + !-------------------------------------------------------------- + ! for dF/dy (v momentum) + !-------------------------------------------------------------- + + strp_tmp = p25 * dxt(iw) * (p333 * ssigpe + p166 * ssigpw) + strm_tmp = p25 * dxt(iw) * (p333 * ssigme + p166 * ssigmw) + + ! northeast (i,j) + str5(iw) = -strp_tmp + strm_tmp - str12ns & + - dyhx * (csigpne + csigmne) + dxhy * csig12ne + + ! southeast (i,j+1) + str6(iw) = strp_tmp - strm_tmp - str12sn & + - dyhx * (csigpse + csigmse) + dxhy * csig12se + + strp_tmp = p25 * dxt(iw) * (p333 * ssigpw + p166 * ssigpe) + strm_tmp = p25 * dxt(iw) * (p333 * ssigmw + p166 * ssigme) + + ! northwest (i+1,j) + str7(iw) = -strp_tmp + strm_tmp + str12ns & + - dyhx * (csigpnw + csigmnw) + dxhy * csig12nw + + ! southwest (i+1,j+1) + str8(iw) = strp_tmp - strm_tmp + str12sn & + - dyhx * (csigpsw + csigmsw) + dxhy * csig12sw + + end do +#ifdef _OPENACC + !$acc end parallel #endif - if (.false.) then - write(nu_diag,'(2a,i3,a,2i10)') subname,' openMP thread ', domp_iam, & - ' handles range: ', d_lower, d_upper - endif + end subroutine stress_last - end subroutine domp_get_domain_rlu +!======================================================================= -!---------------------------------------------------------------------------- + subroutine stepu_iter(NA_len, rhow, lb, ub, Cw, aiu, uocn, vocn, & + forcex, forcey, umassdti, fm, uarear, Tbu, uvel_init, vvel_init, & + uvel, vvel, str1, str2, str3, str4, str5, str6, str7, str8, nw, & + sw, sse, skipucell) - subroutine domp_get_thread_no (tnum) + use ice_kinds_mod + use ice_constants, only : c0, c1 + use ice_dyn_shared, only : brlx, revp, u0, cosw, sinw - implicit none - integer(int_kind), intent(out) :: tnum - character(len=*), parameter :: subname = '(domp_get_thread_no)' + implicit none - tnum = domp_iam + 1 + integer(kind=int_kind), intent(in) :: NA_len, lb, ub + real(kind=dbl_kind), intent(in) :: rhow + logical(kind=log_kind), intent(in), dimension(:) :: skipucell + integer(kind=int_kind), dimension(:), intent(in), contiguous :: & + nw, sw, sse + real(kind=dbl_kind), dimension(:), intent(in), contiguous :: & + uvel_init, vvel_init, aiu, forcex, forcey, umassdti, Tbu, & + uocn, vocn, fm, uarear, Cw, str1, str2, str3, str4, str5, & + str6, str7, str8 + real(kind=dbl_kind), dimension(:), intent(inout), contiguous :: & + uvel, vvel - end subroutine domp_get_thread_no + ! local variables -!---------------------------------------------------------------------------- + integer(kind=int_kind) :: iw, il, iu + real(kind=dbl_kind) :: uold, vold, vrel, cca, ccb, ab2, cc1, & + cc2, taux, tauy, Cb, tmp_str2_nw, tmp_str3_sse, tmp_str4_sw, & + tmp_str6_sse, tmp_str7_nw, tmp_str8_sw, waterx, watery, & + tmp_strintx, tmp_strinty -!former end module dmi_omp + character(len=*), parameter :: subname = '(stepu_iter)' -!=============================================================================== +#ifdef _OPENACC + !$acc parallel & + !$acc present(Cw, aiu, uocn, vocn, forcex, forcey, umassdti, fm, & + !$acc uarear, Tbu, uvel_init, vvel_init, nw, sw, sse, skipucell, & + !$acc str1, str2, str3, str4, str5, str6, str7, str8, uvel, & + !$acc vvel) + !$acc loop + do iw = 1, NA_len +#else + call domp_get_domain(lb, ub, il, iu) + do iw = il, iu +#endif -!former module bench_v2 + if (skipucell(iw)) cycle -!---------------------------------------------------------------------------- + uold = uvel(iw) + vold = vvel(iw) - subroutine stress_i(NA_len, & - ee,ne,se,lb,ub,uvel,vvel,dxt,dyt, & - hte,htn,htem1,htnm1, & - strength,stressp_1,stressp_2,stressp_3,stressp_4, & - stressm_1,stressm_2,stressm_3,stressm_4,stress12_1, & - stress12_2,stress12_3,stress12_4,str1,str2,str3,str4,str5, & - str6,str7,str8) + vrel = aiu(iw) * rhow * Cw(iw) * sqrt((uocn(iw) - uold)**2 + (vocn(iw) - vold)**2) - use ice_kinds_mod - use ice_constants, only: p027, p055, p111, p166, p222, p25, p333, p5, c1p5, c1 - use ice_dyn_shared, only: ecci, denom1, arlx1i, Ktens, revp + waterx = uocn(iw) * cosw - vocn(iw) * sinw * sign(c1, fm(iw)) + watery = vocn(iw) * cosw + uocn(iw) * sinw * sign(c1, fm(iw)) - implicit none + taux = vrel * waterx + tauy = vrel * watery - integer (kind=int_kind), intent(in) :: NA_len - integer (kind=int_kind), intent(in) :: lb,ub - integer (kind=int_kind), dimension(:), intent(in), contiguous :: ee,ne,se - real (kind=dbl_kind), dimension(:), intent(in), contiguous :: & - strength, uvel, vvel, dxt, dyt, & - hte,htn,htem1,htnm1 - real (kind=dbl_kind), dimension(:), intent(inout), contiguous :: & - stressp_1,stressp_2, stressp_3, stressp_4, stressm_1, stressm_2, & - stressm_3,stressm_4, stress12_1,stress12_2,stress12_3, stress12_4 - real (kind=DBL_KIND), dimension(:), intent(out), contiguous :: & - str1,str2,str3,str4,str5,str6,str7,str8 + Cb = Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) - !-- local variables + cca = (brlx + revp) * umassdti(iw) + vrel * cosw + Cb + ccb = fm(iw) + sign(c1, fm(iw)) * vrel * sinw - integer (kind=int_kind) :: iw,il,iu - real (kind=dbl_kind) :: & - puny - real (kind=DBL_KIND) :: & - divune, divunw, divuse, divusw,tensionne, tensionnw, tensionse, tensionsw, & - shearne, shearnw, shearse, shearsw, Deltane, Deltanw, Deltase, Deltasw , & - c0ne, c0nw, c0se, c0sw, c1ne, c1nw, c1se, c1sw , & - ssigpn, ssigps, ssigpe, ssigpw, ssigmn, ssigms, ssigme, ssigmw , & - ssig12n, ssig12s, ssig12e, ssig12w, ssigp1, ssigp2,ssigm1, ssigm2,ssig121, & - ssig122, csigpne, csigpnw, csigpse, csigpsw,csigmne, csigmnw, csigmse , & - csigmsw, csig12ne, csig12nw, csig12se, csig12sw, str12ew, str12we,str12ns, & - str12sn, strp_tmp, strm_tmp, tmp_uvel_ee, tmp_vvel_se, tmp_vvel_ee, & - tmp_vvel_ne, tmp_uvel_ne, tmp_uvel_se - real (kind=DBL_KIND) :: dxhy,dyhx,cxp,cyp,cxm,cym,tinyarea - - character(len=*), parameter :: subname = '(stress_i)' - !--------------------------------------- + ab2 = cca**2 + ccb**2 - call icepack_query_parameters(puny_out=puny) - call icepack_warnings_flush(nu_diag) - if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & - file=__FILE__, line=__LINE__) + tmp_str2_nw = str2(nw(iw)) + tmp_str3_sse = str3(sse(iw)) + tmp_str4_sw = str4(sw(iw)) + tmp_str6_sse = str6(sse(iw)) + tmp_str7_nw = str7(nw(iw)) + tmp_str8_sw = str8(sw(iw)) -#ifdef _OPENACC - !$acc parallel & - !$acc present(ee,ne,se,strength,uvel,vvel,dxt,dyt, & - !$acc hte, htn, htem1, htnm1, & - !$acc str1,str2,str3,str4,str5,str6,str7,str8, & - !$acc stressp_1,stressp_2,stressp_3,stressp_4, & - !$acc stressm_1,stressm_2,stressm_3,stressm_4, & - !$acc stress12_1,stress12_2,stress12_3,stress12_4) - !$acc loop - do iw = 1,NA_len -#else - call domp_get_domain(lb,ub,il,iu) - do iw = il, iu -#endif - tinyarea = puny*dxt(iw)*dyt(iw) - dxhy = p5*(hte(iw) - htem1(iw)) - dyhx = p5*(htn(iw) - htnm1(iw)) - cxp = c1p5*htn(iw) - p5*htnm1(iw) - cyp = c1p5*hte(iw) - p5*htem1(iw) - cxm = -(c1p5*htnm1(iw) - p5*htn(iw)) - cym = -(c1p5*htem1(iw) - p5*hte(iw)) - - !----------------------------------------------------------------- - ! strain rates - ! NOTE these are actually strain rates * area (m^2/s) - !----------------------------------------------------------------- - ! divergence = e_11 + e_22 - tmp_uvel_ee = uvel(ee(iw)) - tmp_vvel_ee = vvel(ee(iw)) - - tmp_vvel_se = vvel(se(iw)) - tmp_uvel_se = uvel(se(iw)) - - ! ne - divune = cyp*uvel(iw) - dyt(iw)*tmp_uvel_ee & - + cxp*vvel(iw) - dxt(iw)*tmp_vvel_se - ! tension strain rate = e_11 - e_22 - tensionne = -cym*uvel(iw) - dyt(iw)*tmp_uvel_ee & - + cxm*vvel(iw) + dxt(iw)*tmp_vvel_se - ! shearing strain rate = 2*e_12 - shearne = -cym*vvel(iw) - dyt(iw)*tmp_vvel_ee & - - cxm*uvel(iw) - dxt(iw)*tmp_uvel_se - ! Delta (in the denominator of zeta, eta) - Deltane = sqrt(divune**2 + ecci*(tensionne**2 + shearne**2)) - - ! These two can move after ne block - ! - tmp_uvel_ne = uvel(ne(iw)) - tmp_vvel_ne = vvel(ne(iw)) - - ! nw - divunw = cym*tmp_uvel_ee + dyt(iw)*uvel(iw) & - + cxp*tmp_vvel_ee - dxt(iw)*tmp_vvel_ne - tensionnw = -cyp*tmp_uvel_ee + dyt(iw)*uvel(iw) & - + cxm*tmp_vvel_ee + dxt(iw)*tmp_vvel_ne - shearnw = -cyp*tmp_vvel_ee + dyt(iw)*vvel(iw) & - - cxm*tmp_uvel_ee - dxt(iw)*tmp_uvel_ne - Deltanw = sqrt(divunw**2 + ecci*(tensionnw**2 + shearnw**2)) - - ! sw - divusw = cym*tmp_uvel_ne + dyt(iw)*tmp_uvel_se & - + cxm*tmp_vvel_ne + dxt(iw)*tmp_vvel_ee - tensionsw = -cyp*tmp_uvel_ne + dyt(iw)*tmp_uvel_se & - + cxp*tmp_vvel_ne - dxt(iw)*tmp_vvel_ee - shearsw = -cyp*tmp_vvel_ne + dyt(iw)*tmp_vvel_se & - - cxp*tmp_uvel_ne + dxt(iw)*tmp_uvel_ee - Deltasw = sqrt(divusw**2 + ecci*(tensionsw**2 + shearsw**2)) - - ! se - divuse = cyp*tmp_uvel_se - dyt(iw)*tmp_uvel_ne & - + cxm*tmp_vvel_se + dxt(iw)*vvel(iw) - tensionse = -cym*tmp_uvel_se - dyt(iw)*tmp_uvel_ne & - + cxp*tmp_vvel_se - dxt(iw)*vvel(iw) - shearse = -cym*tmp_vvel_se - dyt(iw)*tmp_vvel_ne & - - cxp*tmp_uvel_se + dxt(iw)*uvel(iw) - Deltase = sqrt(divuse**2 + ecci*(tensionse**2 + shearse**2)) - - !----------------------------------------------------------------- - ! replacement pressure/Delta ! kg/s - ! save replacement pressure for principal stress calculation - !----------------------------------------------------------------- - c0ne = strength(iw)/max(Deltane,tinyarea) - c0nw = strength(iw)/max(Deltanw,tinyarea) - c0sw = strength(iw)/max(Deltasw,tinyarea) - c0se = strength(iw)/max(Deltase,tinyarea) - - c1ne = c0ne*arlx1i - c1nw = c0nw*arlx1i - c1sw = c0sw*arlx1i - c1se = c0se*arlx1i - - c0ne = c1ne*ecci - c0nw = c1nw*ecci - c0sw = c1sw*ecci - c0se = c1se*ecci - - !----------------------------------------------------------------- - ! the stresses ! kg/s^2 - ! (1) northeast, (2) northwest, (3) southwest, (4) southeast - !----------------------------------------------------------------- - - stressp_1(iw) = (stressp_1(iw)*(c1-arlx1i*revp) + c1ne*(divune*(c1+Ktens) - Deltane*(c1-Ktens))) * denom1 - stressp_2(iw) = (stressp_2(iw)*(c1-arlx1i*revp) + c1nw*(divunw*(c1+Ktens) - Deltanw*(c1-Ktens))) * denom1 - stressp_3(iw) = (stressp_3(iw)*(c1-arlx1i*revp) + c1sw*(divusw*(c1+Ktens) - Deltasw*(c1-Ktens))) * denom1 - stressp_4(iw) = (stressp_4(iw)*(c1-arlx1i*revp) + c1se*(divuse*(c1+Ktens) - Deltase*(c1-Ktens))) * denom1 - - stressm_1(iw) = (stressm_1(iw)*(c1-arlx1i*revp) + c0ne*tensionne*(c1+Ktens)) * denom1 - stressm_2(iw) = (stressm_2(iw)*(c1-arlx1i*revp) + c0nw*tensionnw*(c1+Ktens)) * denom1 - stressm_3(iw) = (stressm_3(iw)*(c1-arlx1i*revp) + c0sw*tensionsw*(c1+Ktens)) * denom1 - stressm_4(iw) = (stressm_4(iw)*(c1-arlx1i*revp) + c0se*tensionse*(c1+Ktens)) * denom1 - - stress12_1(iw) = (stress12_1(iw)*(c1-arlx1i*revp) + c0ne*shearne*p5*(c1+Ktens)) * denom1 - stress12_2(iw) = (stress12_2(iw)*(c1-arlx1i*revp) + c0nw*shearnw*p5*(c1+Ktens)) * denom1 - stress12_3(iw) = (stress12_3(iw)*(c1-arlx1i*revp) + c0sw*shearsw*p5*(c1+Ktens)) * denom1 - stress12_4(iw) = (stress12_4(iw)*(c1-arlx1i*revp) + c0se*shearse*p5*(c1+Ktens)) * denom1 - - !----------------------------------------------------------------- - ! combinations of the stresses for the momentum equation ! kg/s^2 - !----------------------------------------------------------------- - - ssigpn = stressp_1(iw) + stressp_2(iw) - ssigps = stressp_3(iw) + stressp_4(iw) - ssigpe = stressp_1(iw) + stressp_4(iw) - ssigpw = stressp_2(iw) + stressp_3(iw) - ssigp1 =(stressp_1(iw) + stressp_3(iw))*p055 - ssigp2 =(stressp_2(iw) + stressp_4(iw))*p055 - - ssigmn = stressm_1(iw) + stressm_2(iw) - ssigms = stressm_3(iw) + stressm_4(iw) - ssigme = stressm_1(iw) + stressm_4(iw) - ssigmw = stressm_2(iw) + stressm_3(iw) - ssigm1 =(stressm_1(iw) + stressm_3(iw))*p055 - ssigm2 =(stressm_2(iw) + stressm_4(iw))*p055 - - ssig12n = stress12_1(iw) + stress12_2(iw) - ssig12s = stress12_3(iw) + stress12_4(iw) - ssig12e = stress12_1(iw) + stress12_4(iw) - ssig12w = stress12_2(iw) + stress12_3(iw) - ssig121 =(stress12_1(iw) + stress12_3(iw))*p111 - ssig122 =(stress12_2(iw) + stress12_4(iw))*p111 - - csigpne = p111*stressp_1(iw) + ssigp2 + p027*stressp_3(iw) - csigpnw = p111*stressp_2(iw) + ssigp1 + p027*stressp_4(iw) - csigpsw = p111*stressp_3(iw) + ssigp2 + p027*stressp_1(iw) - csigpse = p111*stressp_4(iw) + ssigp1 + p027*stressp_2(iw) - - csigmne = p111*stressm_1(iw) + ssigm2 + p027*stressm_3(iw) - csigmnw = p111*stressm_2(iw) + ssigm1 + p027*stressm_4(iw) - csigmsw = p111*stressm_3(iw) + ssigm2 + p027*stressm_1(iw) - csigmse = p111*stressm_4(iw) + ssigm1 + p027*stressm_2(iw) - - csig12ne = p222*stress12_1(iw) + ssig122 + p055*stress12_3(iw) - csig12nw = p222*stress12_2(iw) + ssig121 + p055*stress12_4(iw) - csig12sw = p222*stress12_3(iw) + ssig122 + p055*stress12_1(iw) - csig12se = p222*stress12_4(iw) + ssig121 + p055*stress12_2(iw) - - str12ew = p5*dxt(iw)*(p333*ssig12e + p166*ssig12w) - str12we = p5*dxt(iw)*(p333*ssig12w + p166*ssig12e) - str12ns = p5*dyt(iw)*(p333*ssig12n + p166*ssig12s) - str12sn = p5*dyt(iw)*(p333*ssig12s + p166*ssig12n) - - !----------------------------------------------------------------- - ! for dF/dx (u momentum) - !----------------------------------------------------------------- - strp_tmp = p25*dyt(iw)*(p333*ssigpn + p166*ssigps) - strm_tmp = p25*dyt(iw)*(p333*ssigmn + p166*ssigms) - - ! northeast (iw) - str1(iw) = -strp_tmp - strm_tmp - str12ew & - + dxhy*(-csigpne + csigmne) + dyhx*csig12ne - - ! northwest (i+1,j) - str2(iw) = strp_tmp + strm_tmp - str12we & - + dxhy*(-csigpnw + csigmnw) + dyhx*csig12nw - - strp_tmp = p25*dyt(iw)*(p333*ssigps + p166*ssigpn) - strm_tmp = p25*dyt(iw)*(p333*ssigms + p166*ssigmn) - - ! southeast (i,j+1) - str3(iw) = -strp_tmp - strm_tmp + str12ew & - + dxhy*(-csigpse + csigmse) + dyhx*csig12se - - ! southwest (i+1,j+1) - str4(iw) = strp_tmp + strm_tmp + str12we & - + dxhy*(-csigpsw + csigmsw) + dyhx*csig12sw - - !----------------------------------------------------------------- - ! for dF/dy (v momentum) - !----------------------------------------------------------------- - strp_tmp = p25*dxt(iw)*(p333*ssigpe + p166*ssigpw) - strm_tmp = p25*dxt(iw)*(p333*ssigme + p166*ssigmw) - - ! northeast (i,j) - str5(iw) = -strp_tmp + strm_tmp - str12ns & - - dyhx*(csigpne + csigmne) + dxhy*csig12ne - - ! southeast (i,j+1) - str6(iw) = strp_tmp - strm_tmp - str12sn & - - dyhx*(csigpse + csigmse) + dxhy*csig12se - - strp_tmp = p25*dxt(iw)*(p333*ssigpw + p166*ssigpe) - strm_tmp = p25*dxt(iw)*(p333*ssigmw + p166*ssigme) - - ! northwest (i+1,j) - str7(iw) = -strp_tmp + strm_tmp + str12ns & - - dyhx*(csigpnw + csigmnw) + dxhy*csig12nw - - ! southwest (i+1,j+1) - str8(iw) = strp_tmp - strm_tmp + str12sn & - - dyhx*(csigpsw + csigmsw) + dxhy*csig12sw - enddo -#ifdef _OPENACC - !$acc end parallel -#endif + tmp_strintx = uarear(iw) * (str1(iw) + tmp_str2_nw + tmp_str3_sse + tmp_str4_sw) + tmp_strinty = uarear(iw) * (str5(iw) + tmp_str6_sse + tmp_str7_nw + tmp_str8_sw) - end subroutine stress_i - -!---------------------------------------------------------------------------- - - subroutine stress_l(NA_len, tarear, & - ee,ne,se,lb,ub,uvel,vvel,dxt,dyt, & - hte,htn,htem1,htnm1, & - strength,stressp_1,stressp_2,stressp_3,stressp_4, & - stressm_1,stressm_2,stressm_3,stressm_4,stress12_1, & - stress12_2,stress12_3,stress12_4, & - divu,rdg_conv,rdg_shear,shear, & - str1,str2,str3,str4,str5,str6,str7,str8 ) - - use ice_kinds_mod - use ice_constants, only: p027, p055, p111, p166, p222, p25, p333, p5, c1p5, c0, c1 - use ice_dyn_shared, only: ecci, denom1, arlx1i, Ktens, revp - - implicit none - - integer (kind=int_kind), intent(in) :: NA_len - integer (kind=int_kind), intent(in) :: lb,ub - integer (kind=int_kind), dimension(:), intent(in), contiguous :: ee,ne,se - real (kind=dbl_kind), dimension(:), intent(in), contiguous :: & - strength, uvel, vvel, dxt, dyt, tarear, & - hte,htn,htem1,htnm1 - real (kind=dbl_kind), dimension(:), intent(inout), contiguous :: & - stressp_1,stressp_2, stressp_3, stressp_4, stressm_1, stressm_2, & - stressm_3,stressm_4, stress12_1,stress12_2,stress12_3, stress12_4 - real (kind=DBL_KIND), dimension(:), intent(out), contiguous :: & - str1,str2,str3,str4,str5,str6,str7,str8 - real (kind=dbl_kind), dimension(:), intent(out), contiguous :: & - divu,rdg_conv,rdg_shear,shear - - !-- local variables - - integer (kind=int_kind) :: iw,il,iu - real (kind=dbl_kind) :: & - puny - real (kind=DBL_KIND) :: & - divune, divunw, divuse, divusw,tensionne, tensionnw, tensionse, tensionsw, & - shearne, shearnw, shearse, shearsw, Deltane, Deltanw, Deltase, Deltasw , & - c0ne, c0nw, c0se, c0sw, c1ne, c1nw, c1se, c1sw , & - ssigpn, ssigps, ssigpe, ssigpw, ssigmn, ssigms, ssigme, ssigmw , & - ssig12n, ssig12s, ssig12e, ssig12w, ssigp1, ssigp2,ssigm1, ssigm2,ssig121, & - ssig122, csigpne, csigpnw, csigpse, csigpsw,csigmne, csigmnw, csigmse , & - csigmsw, csig12ne, csig12nw, csig12se, csig12sw, str12ew, str12we,str12ns, & - str12sn, strp_tmp, strm_tmp, tmp_uvel_ee, tmp_vvel_se, tmp_vvel_ee, & - tmp_vvel_ne, tmp_uvel_ne, tmp_uvel_se - real (kind=DBL_KIND) :: dxhy,dyhx,cxp,cyp,cxm,cym,tinyarea - - character(len=*), parameter :: subname = '(stress_l)' - !--------------------------------------- - - call icepack_query_parameters(puny_out=puny) - call icepack_warnings_flush(nu_diag) - if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & - file=__FILE__, line=__LINE__) + cc1 = tmp_strintx + forcex(iw) + taux & + + umassdti(iw) * (brlx * uold + revp * uvel_init(iw)) + cc2 = tmp_strinty + forcey(iw) + tauy & + + umassdti(iw) * (brlx * vold + revp * vvel_init(iw)) -#ifdef _OPENACC - !$acc parallel & - !$acc present(ee,ne,se,strength,uvel,vvel,dxt,dyt,tarear, & - !$acc hte,htn,htem1,htnm1, & - !$acc str1,str2,str3,str4,str5,str6,str7,str8, & - !$acc stressp_1,stressp_2,stressp_3,stressp_4, & - !$acc stressm_1,stressm_2,stressm_3,stressm_4, & - !$acc stress12_1,stress12_2,stress12_3,stress12_4, & - !$acc divu,rdg_conv,rdg_shear,shear) - !$acc loop - do iw = 1,NA_len -#else - call domp_get_domain(lb,ub,il,iu) - do iw = il, iu -#endif - tinyarea = puny*dxt(iw)*dyt(iw) - dxhy = p5*(hte(iw) - htem1(iw)) - dyhx = p5*(htn(iw) - htnm1(iw)) - cxp = c1p5*htn(iw) - p5*htnm1(iw) - cyp = c1p5*hte(iw) - p5*htem1(iw) - cxm = -(c1p5*htnm1(iw) - p5*htn(iw)) - cym = -(c1p5*htem1(iw) - p5*hte(iw)) - - !----------------------------------------------------------------- - ! strain rates - ! NOTE these are actually strain rates * area (m^2/s) - !----------------------------------------------------------------- - ! divergence = e_11 + e_22 - tmp_uvel_ee = uvel(ee(iw)) - tmp_vvel_se = vvel(se(iw)) - tmp_vvel_ee = vvel(ee(iw)) - tmp_vvel_ne = vvel(ne(iw)) - tmp_uvel_ne = uvel(ne(iw)) - tmp_uvel_se = uvel(se(iw)) - - divune = cyp*uvel(iw) - dyt(iw)*tmp_uvel_ee & - + cxp*vvel(iw) - dxt(iw)*tmp_vvel_se - divunw = cym*tmp_uvel_ee + dyt(iw)*uvel(iw) & - + cxp*tmp_vvel_ee - dxt(iw)*tmp_vvel_ne - divusw = cym*tmp_uvel_ne + dyt(iw)*tmp_uvel_se & - + cxm*tmp_vvel_ne + dxt(iw)*tmp_vvel_ee - divuse = cyp*tmp_uvel_se - dyt(iw)*tmp_uvel_ne & - + cxm*tmp_vvel_se + dxt(iw)*vvel(iw) - - ! tension strain rate = e_11 - e_22 - tensionne = -cym*uvel(iw) - dyt(iw)*tmp_uvel_ee & - + cxm*vvel(iw) + dxt(iw)*tmp_vvel_se - tensionnw = -cyp*tmp_uvel_ee + dyt(iw)*uvel(iw) & - + cxm*tmp_vvel_ee + dxt(iw)*tmp_vvel_ne - tensionsw = -cyp*tmp_uvel_ne + dyt(iw)*tmp_uvel_se & - + cxp*tmp_vvel_ne - dxt(iw)*tmp_vvel_ee - tensionse = -cym*tmp_uvel_se - dyt(iw)*tmp_uvel_ne & - + cxp*tmp_vvel_se - dxt(iw)*vvel(iw) - - ! shearing strain rate = 2*e_12 - shearne = -cym*vvel(iw) - dyt(iw)*tmp_vvel_ee & - - cxm*uvel(iw) - dxt(iw)*tmp_uvel_se - shearnw = -cyp*tmp_vvel_ee + dyt(iw)*vvel(iw) & - - cxm*tmp_uvel_ee - dxt(iw)*tmp_uvel_ne - shearsw = -cyp*tmp_vvel_ne + dyt(iw)*tmp_vvel_se & - - cxp*tmp_uvel_ne + dxt(iw)*tmp_uvel_ee - shearse = -cym*tmp_vvel_se - dyt(iw)*tmp_vvel_ne & - - cxp*tmp_uvel_se + dxt(iw)*uvel(iw) - - ! Delta (in the denominator of zeta, eta) - Deltane = sqrt(divune**2 + ecci*(tensionne**2 + shearne**2)) - Deltanw = sqrt(divunw**2 + ecci*(tensionnw**2 + shearnw**2)) - Deltase = sqrt(divuse**2 + ecci*(tensionse**2 + shearse**2)) - Deltasw = sqrt(divusw**2 + ecci*(tensionsw**2 + shearsw**2)) - - !----------------------------------------------------------------- - ! on last subcycle, save quantities for mechanical redistribution - !----------------------------------------------------------------- - divu(iw) = p25*(divune + divunw + divuse + divusw) * tarear(iw) - rdg_conv(iw) = -min(divu(iw),c0) ! Could move outside the entire "kernel" - rdg_shear(iw) = p5*( p25*(Deltane + Deltanw + Deltase + Deltasw) * tarear(iw) -abs(divu(iw)) ) - - ! diagnostic only - ! shear = sqrt(tension**2 + shearing**2) - shear(iw) = p25*tarear(iw)*sqrt( & - (tensionne + tensionnw + tensionse + tensionsw)**2 & - + (shearne + shearnw + shearse + shearsw)**2) - - !----------------------------------------------------------------- - ! replacement pressure/Delta ! kg/s - ! save replacement pressure for principal stress calculation - !----------------------------------------------------------------- - c0ne = strength(iw)/max(Deltane,tinyarea) - c0nw = strength(iw)/max(Deltanw,tinyarea) - c0sw = strength(iw)/max(Deltasw,tinyarea) - c0se = strength(iw)/max(Deltase,tinyarea) - - c1ne = c0ne*arlx1i - c1nw = c0nw*arlx1i - c1sw = c0sw*arlx1i - c1se = c0se*arlx1i - - c0ne = c1ne*ecci - c0nw = c1nw*ecci - c0sw = c1sw*ecci - c0se = c1se*ecci - - !----------------------------------------------------------------- - ! the stresses ! kg/s^2 - ! (1) northeast, (2) northwest, (3) southwest, (4) southeast - !----------------------------------------------------------------- - - stressp_1(iw) = (stressp_1(iw)*(c1-arlx1i*revp) + c1ne*(divune*(c1+Ktens) - Deltane*(c1-Ktens))) * denom1 - stressp_2(iw) = (stressp_2(iw)*(c1-arlx1i*revp) + c1nw*(divunw*(c1+Ktens) - Deltanw*(c1-Ktens))) * denom1 - stressp_3(iw) = (stressp_3(iw)*(c1-arlx1i*revp) + c1sw*(divusw*(c1+Ktens) - Deltasw*(c1-Ktens))) * denom1 - stressp_4(iw) = (stressp_4(iw)*(c1-arlx1i*revp) + c1se*(divuse*(c1+Ktens) - Deltase*(c1-Ktens))) * denom1 - - stressm_1(iw) = (stressm_1(iw)*(c1-arlx1i*revp) + c0ne*tensionne*(c1+Ktens)) * denom1 - stressm_2(iw) = (stressm_2(iw)*(c1-arlx1i*revp) + c0nw*tensionnw*(c1+Ktens)) * denom1 - stressm_3(iw) = (stressm_3(iw)*(c1-arlx1i*revp) + c0sw*tensionsw*(c1+Ktens)) * denom1 - stressm_4(iw) = (stressm_4(iw)*(c1-arlx1i*revp) + c0se*tensionse*(c1+Ktens)) * denom1 - - stress12_1(iw) = (stress12_1(iw)*(c1-arlx1i*revp) + c0ne*shearne*p5*(c1+Ktens)) * denom1 - stress12_2(iw) = (stress12_2(iw)*(c1-arlx1i*revp) + c0nw*shearnw*p5*(c1+Ktens)) * denom1 - stress12_3(iw) = (stress12_3(iw)*(c1-arlx1i*revp) + c0sw*shearsw*p5*(c1+Ktens)) * denom1 - stress12_4(iw) = (stress12_4(iw)*(c1-arlx1i*revp) + c0se*shearse*p5*(c1+Ktens)) * denom1 - - !----------------------------------------------------------------- - ! combinations of the stresses for the momentum equation ! kg/s^2 - !----------------------------------------------------------------- - - ssigpn = stressp_1(iw) + stressp_2(iw) - ssigps = stressp_3(iw) + stressp_4(iw) - ssigpe = stressp_1(iw) + stressp_4(iw) - ssigpw = stressp_2(iw) + stressp_3(iw) - ssigp1 =(stressp_1(iw) + stressp_3(iw))*p055 - ssigp2 =(stressp_2(iw) + stressp_4(iw))*p055 - - ssigmn = stressm_1(iw) + stressm_2(iw) - ssigms = stressm_3(iw) + stressm_4(iw) - ssigme = stressm_1(iw) + stressm_4(iw) - ssigmw = stressm_2(iw) + stressm_3(iw) - ssigm1 =(stressm_1(iw) + stressm_3(iw))*p055 - ssigm2 =(stressm_2(iw) + stressm_4(iw))*p055 - - ssig12n = stress12_1(iw) + stress12_2(iw) - ssig12s = stress12_3(iw) + stress12_4(iw) - ssig12e = stress12_1(iw) + stress12_4(iw) - ssig12w = stress12_2(iw) + stress12_3(iw) - ssig121 =(stress12_1(iw) + stress12_3(iw))*p111 - ssig122 =(stress12_2(iw) + stress12_4(iw))*p111 - - csigpne = p111*stressp_1(iw) + ssigp2 + p027*stressp_3(iw) - csigpnw = p111*stressp_2(iw) + ssigp1 + p027*stressp_4(iw) - csigpsw = p111*stressp_3(iw) + ssigp2 + p027*stressp_1(iw) - csigpse = p111*stressp_4(iw) + ssigp1 + p027*stressp_2(iw) - - csigmne = p111*stressm_1(iw) + ssigm2 + p027*stressm_3(iw) - csigmnw = p111*stressm_2(iw) + ssigm1 + p027*stressm_4(iw) - csigmsw = p111*stressm_3(iw) + ssigm2 + p027*stressm_1(iw) - csigmse = p111*stressm_4(iw) + ssigm1 + p027*stressm_2(iw) - - csig12ne = p222*stress12_1(iw) + ssig122 + p055*stress12_3(iw) - csig12nw = p222*stress12_2(iw) + ssig121 + p055*stress12_4(iw) - csig12sw = p222*stress12_3(iw) + ssig122 + p055*stress12_1(iw) - csig12se = p222*stress12_4(iw) + ssig121 + p055*stress12_2(iw) - - str12ew = p5*dxt(iw)*(p333*ssig12e + p166*ssig12w) - str12we = p5*dxt(iw)*(p333*ssig12w + p166*ssig12e) - str12ns = p5*dyt(iw)*(p333*ssig12n + p166*ssig12s) - str12sn = p5*dyt(iw)*(p333*ssig12s + p166*ssig12n) - - !----------------------------------------------------------------- - ! for dF/dx (u momentum) - !----------------------------------------------------------------- - strp_tmp = p25*dyt(iw)*(p333*ssigpn + p166*ssigps) - strm_tmp = p25*dyt(iw)*(p333*ssigmn + p166*ssigms) - - ! northeast (iw) - str1(iw) = -strp_tmp - strm_tmp - str12ew & - + dxhy*(-csigpne + csigmne) + dyhx*csig12ne - - ! northwest (i+1,j) - str2(iw) = strp_tmp + strm_tmp - str12we & - + dxhy*(-csigpnw + csigmnw) + dyhx*csig12nw - - strp_tmp = p25*dyt(iw)*(p333*ssigps + p166*ssigpn) - strm_tmp = p25*dyt(iw)*(p333*ssigms + p166*ssigmn) - - ! southeast (i,j+1) - str3(iw) = -strp_tmp - strm_tmp + str12ew & - + dxhy*(-csigpse + csigmse) + dyhx*csig12se - - ! southwest (i+1,j+1) - str4(iw) = strp_tmp + strm_tmp + str12we & - + dxhy*(-csigpsw + csigmsw) + dyhx*csig12sw - - !----------------------------------------------------------------- - ! for dF/dy (v momentum) - !----------------------------------------------------------------- - strp_tmp = p25*dxt(iw)*(p333*ssigpe + p166*ssigpw) - strm_tmp = p25*dxt(iw)*(p333*ssigme + p166*ssigmw) - - ! northeast (i,j) - str5(iw) = -strp_tmp + strm_tmp - str12ns & - - dyhx*(csigpne + csigmne) + dxhy*csig12ne - - ! southeast (i,j+1) - str6(iw) = strp_tmp - strm_tmp - str12sn & - - dyhx*(csigpse + csigmse) + dxhy*csig12se - - strp_tmp = p25*dxt(iw)*(p333*ssigpw + p166*ssigpe) - strm_tmp = p25*dxt(iw)*(p333*ssigmw + p166*ssigme) - - ! northwest (i+1,j) - str7(iw) = -strp_tmp + strm_tmp + str12ns & - - dyhx*(csigpnw + csigmnw) + dxhy*csig12nw - - ! southwest (i+1,j+1) - str8(iw) = strp_tmp - strm_tmp + str12sn & - - dyhx*(csigpsw + csigmsw) + dxhy*csig12sw - enddo -#ifdef _OPENACC - !$acc end parallel -#endif - end subroutine stress_l - -!---------------------------------------------------------------------------- - - subroutine stepu_iter(NA_len,rhow, & - lb,ub,Cw,aiu,uocn,vocn,forcex,forcey,umassdti,fm,uarear,Tbu, & - uvel_init,vvel_init,uvel,vvel, & - str1,str2,str3,str4,str5,str6,str7,str8, nw,sw,se,skipme) - - use ice_kinds_mod - use ice_dyn_shared, only: brlx, revp - use ice_constants, only: c0, c1 - - implicit none - - integer (kind=int_kind), intent(in) :: NA_len - real (kind=dbl_kind), intent(in) :: rhow - integer(kind=int_kind),intent(in) :: lb,ub - logical(kind=log_kind),intent(in), dimension(:) :: skipme - integer(kind=int_kind),dimension(:), intent(in), contiguous :: nw,sw,se - real(kind=dbl_kind),dimension(:), intent(in), contiguous :: & - uvel_init, vvel_init, aiu, forcex, forcey, umassdti, Tbu, & - uocn, vocn, fm, uarear,Cw - real(kind=DBL_KIND),dimension(:), intent(in), contiguous :: & - str1,str2,str3,str4,str5,str6,str7,str8 - real(kind=dbl_kind),dimension(:), intent(inout), contiguous :: & - uvel,vvel - real (kind=dbl_kind), parameter :: & - cosw = c1 , & ! cos(ocean turning angle) ! turning angle = 0 - sinw = c0 - - !-- local variables - - integer (kind=int_kind) :: iw,il,iu - real (kind=dbl_kind) :: uold, vold, vrel,cca,ccb,ab2,cc1,cc2,taux,tauy,Cb - real (kind=dbl_kind) :: tmp_str2_nw,tmp_str3_se,tmp_str4_sw, tmp_strintx - real (kind=dbl_kind) :: tmp_str6_se,tmp_str7_nw,tmp_str8_sw, tmp_strinty - real (kind=dbl_kind) :: waterx,watery - real (kind=dbl_kind) :: u0 = 5.e-5_dbl_kind ! residual velocity for seabed stress (m/s) - - character(len=*), parameter :: subname = '(stepu_iter)' - !--------------------------------------- + uvel(iw) = (cca * cc1 + ccb * cc2) / ab2 + vvel(iw) = (cca * cc2 - ccb * cc1) / ab2 + end do #ifdef _OPENACC - !$acc parallel & - !$acc present(Cw,aiu,uocn,vocn,forcex,forcey,umassdti,fm,uarear,Tbu, & - !$acc uvel_init,vvel_init,nw,sw,se,skipme, & - !$acc str1,str2,str3,str4,str5,str6,str7,str8,uvel,vvel) - !$acc loop - do iw = 1,NA_len -#else - call domp_get_domain(lb,ub,il,iu) - do iw = il, iu -#endif - if (skipme(iw)) cycle - uold = uvel(iw) - vold = vvel(iw) - vrel = aiu(iw)*rhow*Cw(iw)*sqrt((uocn(iw)-uold)**2+(vocn(iw)-vold)**2) - waterx = uocn(iw)*cosw - vocn(iw)*sinw*sign(c1,fm(iw)) - watery = vocn(iw)*cosw + uocn(iw)*sinw*sign(c1,fm(iw)) - taux = vrel*waterx - tauy = vrel*watery - Cb = Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) - cca = (brlx + revp)*umassdti(iw) + vrel * cosw + Cb - ccb = fm(iw) + sign(c1,fm(iw)) * vrel * sinw - ab2 = cca**2 + ccb**2 - ! southeast(i,j+1) = se - ! northwest(i+1,j) = nw - ! southwest(i+1,j+1) = sw - tmp_str2_nw = str2(nw(iw)) - tmp_str3_se = str3(se(iw)) - tmp_str4_sw = str4(sw(iw)) - tmp_str6_se = str6(se(iw)) - tmp_str7_nw = str7(nw(iw)) - tmp_str8_sw = str8(sw(iw)) - - tmp_strintx = uarear(iw)*(str1(iw)+tmp_str2_nw+tmp_str3_se+tmp_str4_sw) - tmp_strinty = uarear(iw)*(str5(iw)+tmp_str6_se+tmp_str7_nw+tmp_str8_sw) - cc1 = tmp_strintx + forcex(iw) + taux & - + umassdti(iw)*(brlx*uold + revp*uvel_init(iw)) - cc2 = tmp_strinty + forcey(iw) + tauy & - + umassdti(iw)*(brlx*vold + revp*vvel_init(iw)) - uvel(iw) = (cca*cc1 + ccb*cc2) / ab2 - vvel(iw) = (cca*cc2 - ccb*cc1) / ab2 - enddo -#ifdef _OPENACC - !$acc end parallel + !$acc end parallel #endif - end subroutine stepu_iter - -!---------------------------------------------------------------------------- - - subroutine stepu_last(NA_len, rhow, & - lb,ub,Cw,aiu,uocn,vocn,forcex,forcey,umassdti,fm,uarear,Tbu, & - strintx,strinty,taubx,tauby, & - uvel_init,vvel_init,uvel,vvel, & - str1,str2,str3,str4,str5,str6,str7,str8, nw,sw,se,skipme) - - use ice_kinds_mod - use ice_constants, only: c0, c1 - use ice_dyn_shared, only: brlx, revp, seabed_stress - - implicit none - - integer (kind=int_kind), intent(in) :: NA_len - real (kind=dbl_kind), intent(in) :: rhow - logical(kind=log_kind),intent(in), dimension(:) :: skipme - integer(kind=int_kind),intent(in) :: lb,ub - integer(kind=int_kind),dimension(:), intent(in), contiguous :: nw,sw,se - real(kind=dbl_kind),dimension(:), intent(in), contiguous :: & - uvel_init, vvel_init, aiu, forcex, forcey, umassdti, Tbu, & - uocn, vocn, fm, uarear,Cw - real(kind=DBL_KIND),dimension(:), intent(in), contiguous :: & - str1,str2,str3,str4,str5,str6,str7,str8 - real(kind=dbl_kind),dimension(:), intent(inout), contiguous :: & - uvel,vvel, strintx,strinty, taubx,tauby - real (kind=dbl_kind), parameter :: & - cosw = c1 , & ! cos(ocean turning angle) ! turning angle = 0 - sinw = c0 - - !-- local variables - - integer (kind=int_kind) :: iw,il,iu - real (kind=dbl_kind) :: uold, vold, vrel,cca,ccb,ab2,cc1,cc2,taux,tauy,Cb - real (kind=dbl_kind) :: tmp_str2_nw,tmp_str3_se,tmp_str4_sw - real (kind=dbl_kind) :: tmp_str6_se,tmp_str7_nw,tmp_str8_sw - real (kind=dbl_kind) :: waterx,watery - real (kind=dbl_kind) :: u0 = 5.e-5_dbl_kind ! residual velocity for seabed stress (m/s) - - character(len=*), parameter :: subname = '(stepu_last)' - !--------------------------------------- + end subroutine stepu_iter + +!======================================================================= + + subroutine stepu_last(NA_len, rhow, lb, ub, Cw, aiu, uocn, vocn, & + forcex, forcey, umassdti, fm, uarear, Tbu, uvel_init, vvel_init, & + uvel, vvel, str1, str2, str3, str4, str5, str6, str7, str8, nw, & + sw, sse, skipucell, strintx, strinty, taubx, tauby) + + use ice_kinds_mod + use ice_constants, only : c0, c1 + use ice_dyn_shared, only : brlx, revp, u0, cosw, sinw, & + seabed_stress + + implicit none + + integer(kind=int_kind), intent(in) :: NA_len, lb, ub + real(kind=dbl_kind), intent(in) :: rhow + logical(kind=log_kind), intent(in), dimension(:) :: skipucell + integer(kind=int_kind), dimension(:), intent(in), contiguous :: & + nw, sw, sse + real(kind=dbl_kind), dimension(:), intent(in), contiguous :: & + uvel_init, vvel_init, aiu, forcex, forcey, umassdti, Tbu, & + uocn, vocn, fm, uarear, Cw, str1, str2, str3, str4, str5, & + str6, str7, str8 + real(kind=dbl_kind), dimension(:), intent(inout), contiguous :: & + uvel, vvel, strintx, strinty, taubx, tauby + + ! local variables + + integer(kind=int_kind) :: iw, il, iu + real(kind=dbl_kind) :: uold, vold, vrel, cca, ccb, ab2, cc1, & + cc2, taux, tauy, Cb, tmp_str2_nw, tmp_str3_sse, tmp_str4_sw, & + tmp_str6_sse, tmp_str7_nw, tmp_str8_sw, waterx, watery + + character(len=*), parameter :: subname = '(stepu_last)' #ifdef _OPENACC - !$acc parallel & - !$acc present(Cw,aiu,uocn,vocn,forcex,forcey,umassdti,fm,uarear,Tbu, & - !$acc strintx,strinty,taubx,tauby,uvel_init,vvel_init,nw,sw,se,skipme, & - !$acc str1,str2,str3,str4,str5,str6,str7,str8,uvel,vvel ) - !$acc loop - do iw = 1,NA_len + !$acc parallel & + !$acc present(Cw, aiu, uocn, vocn, forcex, forcey, umassdti, fm, & + !$acc uarear, Tbu, uvel_init, vvel_init, nw, sw, sse, skipucell, & + !$acc str1, str2, str3, str4, str5, str6, str7, str8, uvel, & + !$acc vvel, strintx, strinty, taubx, tauby) + !$acc loop + do iw = 1, NA_len #else - call domp_get_domain(lb,ub,il,iu) - do iw = il, iu + call domp_get_domain(lb, ub, il, iu) + do iw = il, iu #endif - if (skipme(iw)) cycle - uold = uvel(iw) - vold = vvel(iw) - vrel = aiu(iw)*rhow*Cw(iw)*sqrt((uocn(iw)-uold)**2+(vocn(iw)-vold)**2) - waterx = uocn(iw)*cosw - vocn(iw)*sinw*sign(c1,fm(iw)) - watery = vocn(iw)*cosw + uocn(iw)*sinw*sign(c1,fm(iw)) - taux = vrel*waterx - tauy = vrel*watery - Cb = Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) - cca = (brlx + revp)*umassdti(iw) + vrel * cosw + Cb - ccb = fm(iw) + sign(c1,fm(iw)) * vrel * sinw - ab2 = cca**2 + ccb**2 - ! southeast(i,j+1) = se - ! northwest(i+1,j) = nw - ! southwest(i+1,j+1) = sw - tmp_str2_nw = str2(nw(iw)) - tmp_str3_se = str3(se(iw)) - tmp_str4_sw = str4(sw(iw)) - tmp_str6_se = str6(se(iw)) - tmp_str7_nw = str7(nw(iw)) - tmp_str8_sw = str8(sw(iw)) - - strintx(iw) = uarear(iw)*(str1(iw)+tmp_str2_nw+tmp_str3_se+tmp_str4_sw) - strinty(iw) = uarear(iw)*(str5(iw)+tmp_str6_se+tmp_str7_nw+tmp_str8_sw) - cc1 = strintx(iw) + forcex(iw) + taux & - + umassdti(iw)*(brlx*uold + revp*uvel_init(iw)) - cc2 = strinty(iw) + forcey(iw) + tauy & - + umassdti(iw)*(brlx*vold + revp*vvel_init(iw)) - uvel(iw) = (cca*cc1 + ccb*cc2) / ab2 - vvel(iw) = (cca*cc2 - ccb*cc1) / ab2 - ! calculate seabed stress component for outputs - if ( seabed_stress ) then - taubx(iw) = -uvel(iw)*Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) - tauby(iw) = -vvel(iw)*Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) - endif - enddo + + if (skipucell(iw)) cycle + + uold = uvel(iw) + vold = vvel(iw) + + vrel = aiu(iw) * rhow * Cw(iw) * sqrt((uocn(iw) - uold)**2 + (vocn(iw) - vold)**2) + + waterx = uocn(iw) * cosw - vocn(iw) * sinw * sign(c1, fm(iw)) + watery = vocn(iw) * cosw + uocn(iw) * sinw * sign(c1, fm(iw)) + + taux = vrel * waterx + tauy = vrel * watery + + Cb = Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) + + cca = (brlx + revp) * umassdti(iw) + vrel * cosw + Cb + ccb = fm(iw) + sign(c1, fm(iw)) * vrel * sinw + + ab2 = cca**2 + ccb**2 + + tmp_str2_nw = str2(nw(iw)) + tmp_str3_sse = str3(sse(iw)) + tmp_str4_sw = str4(sw(iw)) + tmp_str6_sse = str6(sse(iw)) + tmp_str7_nw = str7(nw(iw)) + tmp_str8_sw = str8(sw(iw)) + + strintx(iw) = uarear(iw) * (str1(iw) + tmp_str2_nw + tmp_str3_sse + tmp_str4_sw) + strinty(iw) = uarear(iw) * (str5(iw) + tmp_str6_sse + tmp_str7_nw + tmp_str8_sw) + + cc1 = strintx(iw) + forcex(iw) + taux & + + umassdti(iw) * (brlx * uold + revp * uvel_init(iw)) + cc2 = strinty(iw) + forcey(iw) + tauy & + + umassdti(iw) * (brlx * vold + revp * vvel_init(iw)) + + uvel(iw) = (cca * cc1 + ccb * cc2) / ab2 + vvel(iw) = (cca * cc2 - ccb * cc1) / ab2 + + ! calculate seabed stress component for outputs + if (seabed_stress) then + taubx(iw) = -uvel(iw) * Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) + tauby(iw) = -vvel(iw) * Tbu(iw) / (sqrt(uold**2 + vold**2) + u0) + end if + + end do #ifdef _OPENACC - !$acc end parallel + !$acc end parallel #endif - end subroutine stepu_last + end subroutine stepu_last -!---------------------------------------------------------------------------- +!======================================================================= - subroutine evp1d_halo_update(NAVEL_len,lb,ub,uvel,vvel, halo_parent) + subroutine evp1d_halo_update(NAVEL_len, lb, ub, uvel, vvel, & + halo_parent) - use ice_kinds_mod + use ice_kinds_mod - implicit none + implicit none - integer (kind=int_kind), intent(in) :: NAVEL_len - integer(kind=int_kind),intent(in) :: lb,ub - integer(kind=int_kind),dimension(:), intent(in), contiguous :: halo_parent - real(kind=dbl_kind),dimension(:), intent(inout), contiguous :: uvel,vvel + integer(kind=int_kind), intent(in) :: NAVEL_len, lb, ub + integer(kind=int_kind), dimension(:), intent(in), contiguous :: & + halo_parent + real(kind=dbl_kind), dimension(:), intent(inout), contiguous :: & + uvel, vvel - !-- local variables + ! local variables - integer (kind=int_kind) :: iw,il,iu + integer (kind=int_kind) :: iw, il, iu - character(len=*), parameter :: subname = '(evp1d_halo_update)' - !--------------------------------------- + character(len=*), parameter :: subname = '(evp1d_halo_update)' #ifdef _OPENACC - !$acc parallel & - !$acc present(uvel,vvel) & - !$acc loop - do iw = 1,NAVEL_len + !$acc parallel & + !$acc present(uvel, vvel) & + !$acc loop + do iw = 1, NAVEL_len + if (halo_parent(iw) == 0) cycle + uvel(iw) = uvel(halo_parent(iw)) + vvel(iw) = vvel(halo_parent(iw)) + end do + !$acc end parallel #else - call domp_get_domain(lb,ub,il,iu) - do iw = il, iu -#endif - if (halo_parent(iw)==0) cycle - uvel(iw) = uvel(halo_parent(iw)) - vvel(iw) = vvel(halo_parent(iw)) - enddo -#ifdef _OPENACC - !$acc end parallel + call domp_get_domain(lb, ub, il, iu) + do iw = il, iu + if (halo_parent(iw) == 0) cycle + uvel(iw) = uvel(halo_parent(iw)) + vvel(iw) = vvel(halo_parent(iw)) + end do + call domp_get_domain(ub + 1, NAVEL_len, il, iu) + do iw = il, iu + if (halo_parent(iw) == 0) cycle + uvel(iw) = uvel(halo_parent(iw)) + vvel(iw) = vvel(halo_parent(iw)) + end do #endif - end subroutine evp1d_halo_update - -!---------------------------------------------------------------------------- - -!former end module bench_v2 - -!=============================================================================== -!---------------------------------------------------------------------------- - - subroutine alloc1d(na) - - implicit none - - integer(kind=int_kind),intent(in) :: na - integer(kind=int_kind) :: ierr,nb - - character(len=*), parameter :: subname = '(alloc1d)' - !--------------------------------------- - - nb=na - allocate( & - ! U+T cells - ! Helper index for neighbours - indj(1:na),indi(1:na), & - ee(1:na),ne(1:na),se(1:na), & - nw(1:nb),sw(1:nb),sse(1:nb), & - skipucell(1:na), & - ! Grid distances: HTE,HTN + "-1 neighbours" - HTE(1:na),HTN(1:na), & - HTEm1(1:na),HTNm1(1:na), & - ! T cells -!v1 dxhy(1:na),dyhx(1:na),cyp(1:na),cxp(1:na),cym(1:na),cxm(1:na),tinyarea(1:na),& - strength(1:na),dxt(1:na),dyt(1:na), tarear(1:na), & - stressp_1(1:na), stressp_2(1:na), stressp_3(1:na), stressp_4(1:na), & - stressm_1(1:na), stressm_2(1:na), stressm_3(1:na), stressm_4(1:na), & - stress12_1(1:na),stress12_2(1:na),stress12_3(1:na),stress12_4(1:na),& - divu(1:na),rdg_conv(1:na),rdg_shear(1:na),shear(1:na), & - ! U cells -!v1 waterx(1:nb),watery(1:nb), & - cdn_ocn(1:nb),aiu(1:nb),uocn(1:nb),vocn(1:nb), & - forcex(1:nb),forcey(1:nb),Tbu(1:nb), & - umassdti(1:nb),fm(1:nb),uarear(1:nb), & - strintx(1:nb),strinty(1:nb), & - uvel_init(1:nb),vvel_init(1:nb), & - taubx(1:nb),tauby(1:nb), & - stat=ierr) - - if (ierr/=0) call abort_ice(subname//': ERROR allocating 1D') - - end subroutine alloc1d - -!---------------------------------------------------------------------------- - - subroutine alloc1d_navel(navel) - - implicit none - - integer(kind=int_kind),intent(in) :: navel - integer(kind=int_kind) :: ierr - - character(len=*), parameter :: subname = '(alloc1d_navel)' - !--------------------------------------- - - allocate( & - uvel(1:navel),vvel(1:navel), indij(1:navel), halo_parent(1:navel), & - str1(1:navel),str2(1:navel),str3(1:navel),str4(1:navel), & - str5(1:navel),str6(1:navel),str7(1:navel),str8(1:navel), & - stat=ierr) - if (ierr/=0) call abort_ice(subname// ': Error allocating 1D navel') - - end subroutine alloc1d_navel - -!---------------------------------------------------------------------------- - - subroutine dealloc1d - - implicit none - - integer(kind=int_kind) :: ierr - - character(len=*), parameter :: subname = '(dealloc1d)' - !--------------------------------------- - - deallocate( & - ! U+T cells - ! Helper index for neighbours - indj,indi, & - ee,ne,se, & - nw,sw,sse, & - skipucell, & - ! T cells - strength,dxt,dyt,tarear, & - stressp_1, stressp_2, stressp_3, stressp_4, & - stressm_1, stressm_2, stressm_3, stressm_4, & - stress12_1,stress12_2,stress12_3,stress12_4,& - str1, str2,str3,str4, & - str5, str6,str7,str8, & - divu,rdg_conv,rdg_shear,shear, & - ! U cells - cdn_ocn,aiu,uocn,vocn, & - forcex,forcey,Tbu, & - umassdti,fm,uarear, & - strintx,strinty, & - uvel_init,vvel_init, & - taubx,tauby, & - ! NAVEL - uvel,vvel, indij, halo_parent, & - stat=ierr) - - if (ierr/=0) call abort_ice(subname//': Error de-allocating 1D') - -!v1 if (allocated(tinyarea)) then -!v1 deallocate( & -!v1 dxhy,dyhx,cyp,cxp,cym,cxm,tinyarea, & -!v1 waterx,watery, & -!v1 stat=ierr) -!v1 if (ierr/=0) call abort_ice(subname//': Error de-allocating 1D, v1') -!v1 endif - - if (allocated(HTE)) then - deallocate( & - ! Grid distances: HTE,HTN + "-1 neighbours" - HTE,HTN, HTEm1,HTNm1, & - stat=ierr) - if (ierr/=0) call abort_ice(subname//': Error de-allocating 1D, v2') - endif - - end subroutine dealloc1d - -!---------------------------------------------------------------------------- - - subroutine evp_copyin_v2(nx,ny,nblk,nx_glob,ny_glob, & - I_HTE,I_HTN, & -!v1 I_dxhy,I_dyhx,I_cyp,I_cxp,I_cym,I_cxm,I_tinyarea, & -!v1 I_waterx,I_watery, & - I_icetmask,I_iceumask, & - I_cdn_ocn,I_aiu,I_uocn,I_vocn,I_forcex,I_forcey,I_Tbu, & - I_umassdti,I_fm,I_uarear,I_tarear,I_strintx,I_strinty,I_uvel_init,I_vvel_init, & - I_strength,I_uvel,I_vvel,I_dxt,I_dyt, & - I_stressp_1 ,I_stressp_2, I_stressp_3, I_stressp_4, & - I_stressm_1 ,I_stressm_2, I_stressm_3, I_stressm_4, & - I_stress12_1,I_stress12_2,I_stress12_3,I_stress12_4 ) - - use ice_gather_scatter, only: gather_global_ext - use ice_domain, only: distrb_info - use ice_communicate, only: my_task, master_task - - implicit none - - integer(int_kind), intent(in) :: nx, ny, nblk, nx_glob, ny_glob - integer (kind=int_kind),dimension (nx,ny,nblk), intent(in) :: I_icetmask - logical (kind=log_kind),dimension (nx,ny,nblk), intent(in) :: I_iceumask - real (kind=dbl_kind), dimension(nx,ny,nblk), intent(in) :: & - I_HTE,I_HTN, & -!v1 I_dxhy,I_dyhx,I_cyp,I_cxp,I_cym,I_cxm,I_tinyarea, & -!v1 I_waterx,I_watery, & - I_cdn_ocn,I_aiu,I_uocn,I_vocn,I_forcex,I_forcey,I_Tbu, & - I_umassdti,I_fm,I_uarear,I_tarear,I_strintx,I_strinty,I_uvel_init,I_vvel_init, & - I_strength,I_uvel,I_vvel,I_dxt,I_dyt, & - I_stressp_1, I_stressp_2, I_stressp_3, I_stressp_4, & - I_stressm_1, I_stressm_2, I_stressm_3, I_stressm_4, & - I_stress12_1,I_stress12_2,I_stress12_3,I_stress12_4 - - !-- local variables - - integer (kind=int_kind),dimension (nx_glob,ny_glob) :: G_icetmask - logical (kind=log_kind),dimension (nx_glob,ny_glob) :: G_iceumask - real (kind=dbl_kind), dimension(nx_glob,ny_glob) :: & - G_HTE,G_HTN, & -!v1 G_dxhy,G_dyhx,G_cyp,G_cxp,G_cym,G_cxm,G_tinyarea, & -!v1 G_waterx,G_watery, & - G_cdn_ocn,G_aiu,G_uocn,G_vocn,G_forcex,G_forcey,G_Tbu, & - G_umassdti,G_fm,G_uarear,G_tarear,G_strintx,G_strinty,G_uvel_init,G_vvel_init, & - G_strength,G_uvel,G_vvel,G_dxt,G_dyt, & - G_stressp_1, G_stressp_2, G_stressp_3, G_stressp_4, & - G_stressm_1, G_stressm_2, G_stressm_3, G_stressm_4, & - G_stress12_1,G_stress12_2,G_stress12_3,G_stress12_4 - integer(kind=int_kind) :: na, navel - - character(len=*), parameter :: subname = '(evp_copyin_v2)' - !--------------------------------------- - !-- Gather data into one single block -- - - call gather_global_ext(G_icetmask, I_icetmask, master_task, distrb_info) - call gather_global_ext(G_iceumask, I_iceumask, master_task, distrb_info) - call gather_global_ext(G_HTE, I_HTE, master_task, distrb_info) - call gather_global_ext(G_HTN, I_HTN, master_task, distrb_info) -!v1 call gather_global_ext(G_dxhy, I_dxhy, master_task, distrb_info) -!v1 call gather_global_ext(G_dyhx, I_dyhx, master_task, distrb_info) -!v1 call gather_global_ext(G_cyp, I_cyp, master_task, distrb_info) -!v1 call gather_global_ext(G_cxp, I_cxp, master_task, distrb_info) -!v1 call gather_global_ext(G_cym, I_cym, master_task, distrb_info) -!v1 call gather_global_ext(G_cxm, I_cxm, master_task, distrb_info) -!v1 call gather_global_ext(G_tinyarea, I_tinyarea, master_task, distrb_info) -!v1 call gather_global_ext(G_waterx, I_waterx, master_task, distrb_info) -!v1 call gather_global_ext(G_watery, I_watery, master_task, distrb_info) - call gather_global_ext(G_cdn_ocn, I_cdn_ocn, master_task, distrb_info) - call gather_global_ext(G_aiu, I_aiu, master_task, distrb_info) - call gather_global_ext(G_uocn, I_uocn, master_task, distrb_info) - call gather_global_ext(G_vocn, I_vocn, master_task, distrb_info) - call gather_global_ext(G_forcex, I_forcex, master_task, distrb_info) - call gather_global_ext(G_forcey, I_forcey, master_task, distrb_info) - call gather_global_ext(G_Tbu, I_Tbu, master_task, distrb_info) - call gather_global_ext(G_umassdti, I_umassdti, master_task, distrb_info) - call gather_global_ext(G_fm, I_fm, master_task, distrb_info) - call gather_global_ext(G_uarear, I_uarear, master_task, distrb_info) - call gather_global_ext(G_tarear, I_tarear, master_task, distrb_info) - call gather_global_ext(G_strintx, I_strintx, master_task, distrb_info) - call gather_global_ext(G_strinty, I_strinty, master_task, distrb_info) - call gather_global_ext(G_uvel_init, I_uvel_init, master_task, distrb_info) - call gather_global_ext(G_vvel_init, I_vvel_init, master_task, distrb_info) - call gather_global_ext(G_strength, I_strength, master_task, distrb_info) - call gather_global_ext(G_uvel, I_uvel, master_task, distrb_info) - call gather_global_ext(G_vvel, I_vvel, master_task, distrb_info) - call gather_global_ext(G_dxt, I_dxt, master_task, distrb_info) - call gather_global_ext(G_dyt, I_dyt, master_task, distrb_info) - call gather_global_ext(G_stressp_1, I_stressp_1, master_task, distrb_info) - call gather_global_ext(G_stressp_2, I_stressp_2, master_task, distrb_info) - call gather_global_ext(G_stressp_3, I_stressp_3, master_task, distrb_info) - call gather_global_ext(G_stressp_4, I_stressp_4, master_task, distrb_info) - call gather_global_ext(G_stressm_1, I_stressm_1, master_task, distrb_info) - call gather_global_ext(G_stressm_2, I_stressm_2, master_task, distrb_info) - call gather_global_ext(G_stressm_3, I_stressm_3, master_task, distrb_info) - call gather_global_ext(G_stressm_4, I_stressm_4, master_task, distrb_info) - call gather_global_ext(G_stress12_1, I_stress12_1, master_task, distrb_info) - call gather_global_ext(G_stress12_2, I_stress12_2, master_task, distrb_info) - call gather_global_ext(G_stress12_3, I_stress12_3, master_task, distrb_info) - call gather_global_ext(G_stress12_4, I_stress12_4, master_task, distrb_info) - - !-- All calculations has to be done on the master-task -- - - if (my_task == master_task) then - !-- Find number of active points and allocate vectors -- - call calc_na(nx_glob,ny_glob,na,G_icetmask) - call alloc1d(na) - call calc_2d_indices(nx_glob,ny_glob,na, G_icetmask, G_iceumask) - call calc_navel(nx_glob,ny_glob,na,navel) - call alloc1d_navel(navel) -!MHRI !$OMP PARALLEL DEFAULT(shared) - call numainit(1,na,navel) -!MHRI !$OMP END PARALLEL - ! Remap 2d to 1d and fill in - call convert_2d_1d(nx_glob,ny_glob,na,navel, & - G_HTE,G_HTN, & -!v1 G_dxhy,G_dyhx,G_cyp,G_cxp,G_cym,G_cxm,G_tinyarea, & -!v1 G_waterx,G_watery, & - G_cdn_ocn,G_aiu,G_uocn,G_vocn,G_forcex,G_forcey,G_Tbu, & - G_umassdti,G_fm,G_uarear,G_tarear,G_strintx,G_strinty,G_uvel_init,G_vvel_init, & - G_strength,G_uvel,G_vvel,G_dxt,G_dyt, & - G_stressp_1, G_stressp_2, G_stressp_3, G_stressp_4, & - G_stressm_1, G_stressm_2, G_stressm_3, G_stressm_4, & - G_stress12_1,G_stress12_2,G_stress12_3,G_stress12_4 ) - call calc_halo_parent(nx_glob,ny_glob,na,navel, G_icetmask) - NA_len=na - NAVEL_len=navel - endif - - !-- write check -!if (1 == 1) then -! write(nu_diag,*) subname,' MHRI: INDICES start:' -! write(nu_diag,*) 'na,navel ', na,navel -! write(nu_diag,*) 'Min/max ee', minval(ee(1:na)), maxval(ee(1:na)) -! write(nu_diag,*) 'Min/max ne', minval(ne(1:na)), maxval(ne(1:na)) -! write(nu_diag,*) 'Min/max se', minval(se(1:na)), maxval(se(1:na)) -! write(nu_diag,*) 'Min/max nw', minval(nw(1:na)), maxval(nw(1:na)) -! write(nu_diag,*) 'Min/max sw', minval(sw(1:na)), maxval(sw(1:na)) -! write(nu_diag,*) 'Min/max sse', minval(sse(1:na)), maxval(sse(1:na)) -! write(nu_diag,*) subname,' MHRI: INDICES end:' -!endif - - end subroutine evp_copyin_v2 - -!---------------------------------------------------------------------------- - - subroutine evp_copyout(nx,ny,nblk,nx_glob,ny_glob, & - I_uvel,I_vvel, I_strintx,I_strinty, & - I_stressp_1, I_stressp_2, I_stressp_3, I_stressp_4, & - I_stressm_1, I_stressm_2, I_stressm_3, I_stressm_4, & - I_stress12_1,I_stress12_2,I_stress12_3,I_stress12_4, & - I_divu,I_rdg_conv,I_rdg_shear,I_shear,I_taubx,I_tauby ) - - use ice_constants, only : c0 - use ice_gather_scatter, only: scatter_global_ext - use ice_domain, only: distrb_info - use ice_communicate, only: my_task, master_task - - implicit none - - integer(int_kind), intent(in) :: nx,ny,nblk, nx_glob,ny_glob - real(dbl_kind), dimension(nx,ny,nblk), intent(out) :: & - I_uvel,I_vvel, I_strintx,I_strinty, & - I_stressp_1, I_stressp_2, I_stressp_3, I_stressp_4, & - I_stressm_1, I_stressm_2, I_stressm_3, I_stressm_4, & - I_stress12_1,I_stress12_2,I_stress12_3,I_stress12_4, & - I_divu,I_rdg_conv, I_rdg_shear,I_shear, I_taubx,I_tauby - - !-- local variables - - real(dbl_kind), dimension(nx_glob,ny_glob) :: & - G_uvel,G_vvel, G_strintx,G_strinty, & - G_stressp_1, G_stressp_2, G_stressp_3, G_stressp_4, & - G_stressm_1, G_stressm_2, G_stressm_3, G_stressm_4, & - G_stress12_1,G_stress12_2,G_stress12_3,G_stress12_4, & - G_divu,G_rdg_conv, G_rdg_shear,G_shear, G_taubx,G_tauby - integer(int_kind) :: i,j,iw, nx_block - - character(len=*), parameter :: subname = '(evp_copyout)' - !--------------------------------------- - ! Remap 1d to 2d and fill in - nx_block=nx_glob ! Total block size in x-dir - - if (my_task == master_task) then - G_uvel = c0 - G_vvel = c0 - G_strintx = c0 - G_strinty = c0 - G_stressp_1 = c0 - G_stressp_2 = c0 - G_stressp_3 = c0 - G_stressp_4 = c0 - G_stressm_1 = c0 - G_stressm_2 = c0 - G_stressm_3 = c0 - G_stressm_4 = c0 - G_stress12_1 = c0 - G_stress12_2 = c0 - G_stress12_3 = c0 - G_stress12_4 = c0 - G_divu = c0 - G_rdg_conv = c0 - G_rdg_shear = c0 - G_shear = c0 - G_taubx = c0 - G_tauby = c0 - !$OMP PARALLEL PRIVATE(iw,i,j) - do iw=1,NAVEL_len - j=int((indij(iw)-1)/(nx_block))+1 - i=indij(iw)-(j-1)*nx_block - G_uvel(i,j) = uvel(iw) - G_vvel(i,j) = vvel(iw) - enddo - !$OMP END PARALLEL - !$OMP PARALLEL PRIVATE(iw,i,j) - do iw=1,NA_len - i=indi(iw) - j=indj(iw) -! G_uvel(i,j) = uvel(iw) ! done above -! G_vvel(i,j) = vvel(iw) ! done above - G_strintx(i,j) = strintx(iw) - G_strinty(i,j) = strinty(iw) - G_stressp_1(i,j) = stressp_1(iw) - G_stressp_2(i,j) = stressp_2(iw) - G_stressp_3(i,j) = stressp_3(iw) - G_stressp_4(i,j) = stressp_4(iw) - G_stressm_1(i,j) = stressm_1(iw) - G_stressm_2(i,j) = stressm_2(iw) - G_stressm_3(i,j) = stressm_3(iw) - G_stressm_4(i,j) = stressm_4(iw) - G_stress12_1(i,j) = stress12_1(iw) - G_stress12_2(i,j) = stress12_2(iw) - G_stress12_3(i,j) = stress12_3(iw) - G_stress12_4(i,j) = stress12_4(iw) - G_divu(i,j) = divu(iw) - G_rdg_conv(i,j) = rdg_conv(iw) - G_rdg_shear(i,j) = rdg_shear(iw) - G_shear(i,j) = shear(iw) - G_taubx(i,j) = taubx(iw) - G_tauby(i,j) = tauby(iw) - enddo - !$OMP END PARALLEL - call dealloc1d() - endif - - !-- Scatter data into blocks -- - !-- has to be done on all tasks -- - - call scatter_global_ext(I_uvel, G_uvel, master_task, distrb_info) - call scatter_global_ext(I_vvel, G_vvel, master_task, distrb_info) - call scatter_global_ext(I_strintx, G_strintx, master_task, distrb_info) - call scatter_global_ext(I_strinty, G_strinty, master_task, distrb_info) - call scatter_global_ext(I_stressp_1, G_stressp_1, master_task, distrb_info) - call scatter_global_ext(I_stressp_2, G_stressp_2, master_task, distrb_info) - call scatter_global_ext(I_stressp_3, G_stressp_3, master_task, distrb_info) - call scatter_global_ext(I_stressp_4, G_stressp_4, master_task, distrb_info) - call scatter_global_ext(I_stressm_1, G_stressm_1, master_task, distrb_info) - call scatter_global_ext(I_stressm_2, G_stressm_2, master_task, distrb_info) - call scatter_global_ext(I_stressm_3, G_stressm_3, master_task, distrb_info) - call scatter_global_ext(I_stressm_4, G_stressm_4, master_task, distrb_info) - call scatter_global_ext(I_stress12_1, G_stress12_1, master_task, distrb_info) - call scatter_global_ext(I_stress12_2, G_stress12_2, master_task, distrb_info) - call scatter_global_ext(I_stress12_3, G_stress12_3, master_task, distrb_info) - call scatter_global_ext(I_stress12_4, G_stress12_4, master_task, distrb_info) - call scatter_global_ext(I_divu, G_divu, master_task, distrb_info) - call scatter_global_ext(I_rdg_conv, G_rdg_conv, master_task, distrb_info) - call scatter_global_ext(I_rdg_shear, G_rdg_shear, master_task, distrb_info) - call scatter_global_ext(I_shear, G_shear, master_task, distrb_info) - call scatter_global_ext(I_taubx, G_taubx, master_task, distrb_info) - call scatter_global_ext(I_tauby, G_tauby, master_task, distrb_info) - - end subroutine evp_copyout - -!---------------------------------------------------------------------------- - - subroutine evp_kernel_v2 - - use ice_constants, only : c0 - use ice_dyn_shared, only: ndte - use ice_communicate, only: my_task, master_task - implicit none - - real(kind=dbl_kind) :: rhow - integer (kind=int_kind) :: i, nthreads - integer (kind=int_kind) :: na,nb,navel - - character(len=*), parameter :: subname = '(evp_kernel_v2)' - !--------------------------------------- - !-- All calculations has to be done on one single node (choose master-task) -- - - if (my_task == master_task) then - - !- Read constants... - call icepack_query_parameters(rhow_out=rhow) - call icepack_warnings_flush(nu_diag) - if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & - file=__FILE__, line=__LINE__) - na=NA_len - nb=NA_len - navel=NAVEL_len - - !- Initialize openmp --------------------------------------------------------- - call domp_init(nthreads) ! ought to be called from main - - !- Initialize timers --------------------------------------------------------- - str1=c0 - str2=c0 - str3=c0 - str4=c0 - str5=c0 - str6=c0 - str7=c0 - str8=c0 - - if (ndte<2) call abort_ice(subname//' ERROR: ndte must be 2 or higher for this kernel') - - !$OMP PARALLEL PRIVATE(i) - do i = 1, ndte-1 - call evp1d_stress(NA_len, & - ee,ne,se,1,na,uvel,vvel,dxt,dyt, & - hte,htn,htem1,htnm1, & - strength,stressp_1,stressp_2,stressp_3,stressp_4, & - stressm_1,stressm_2,stressm_3,stressm_4,stress12_1, & - stress12_2,stress12_3,stress12_4,str1,str2,str3, & - str4,str5,str6,str7,str8) - !$OMP BARRIER - call evp1d_stepu(NA_len, rhow, & - 1,nb,cdn_ocn,aiu,uocn,vocn,forcex,forcey,umassdti,fm,uarear,Tbu,& - uvel_init,vvel_init,uvel,vvel, & - str1,str2,str3,str4,str5,str6,str7,str8, nw,sw,sse,skipucell) - !$OMP BARRIER - call evp1d_halo_update(NA_len,1,navel,uvel,vvel, halo_parent) - !$OMP BARRIER - enddo - - call evp1d_stress(NA_len, tarear, & - ee,ne,se,1,na,uvel,vvel,dxt,dyt, & - hte,htn,htem1,htnm1, & - strength,stressp_1,stressp_2,stressp_3,stressp_4, & - stressm_1,stressm_2,stressm_3,stressm_4,stress12_1, & - stress12_2,stress12_3,stress12_4, & - divu,rdg_conv,rdg_shear,shear, & - str1,str2,str3,str4,str5,str6,str7,str8) - !$OMP BARRIER - call evp1d_stepu(NA_len, rhow, & - 1,nb,cdn_ocn,aiu,uocn,vocn,forcex,forcey,umassdti,fm,uarear,Tbu,& - strintx,strinty,taubx,tauby, & - uvel_init,vvel_init,uvel,vvel, & - str1,str2,str3,str4,str5,str6,str7,str8, nw,sw,sse,skipucell) - !$OMP BARRIER - call evp1d_halo_update(NA_len,1,navel,uvel,vvel, halo_parent) + end subroutine evp1d_halo_update + +!======================================================================= + + subroutine alloc1d(na) + + implicit none + + integer(kind=int_kind), intent(in) :: na + + ! local variables + + integer(kind=int_kind) :: ierr + + character(len=*), parameter :: subname = '(alloc1d)' + + allocate( & + ! helper indices for neighbours + indj(1:na), indi(1:na), ee(1:na), ne(1:na), se(1:na), & + nw(1:na), sw(1:na), sse(1:na), skipucell(1:na), & + skiptcell(1:na), & + ! grid distances and their "-1 neighbours" + HTE(1:na), HTN(1:na), HTEm1(1:na), HTNm1(1:na), & + ! T cells + strength(1:na), dxt(1:na), dyt(1:na), tarear(1:na), & + stressp_1(1:na), stressp_2(1:na), stressp_3(1:na), & + stressp_4(1:na), stressm_1(1:na), stressm_2(1:na), & + stressm_3(1:na), stressm_4(1:na), stress12_1(1:na), & + stress12_2(1:na), stress12_3(1:na), stress12_4(1:na), & + divu(1:na), rdg_conv(1:na), rdg_shear(1:na), shear(1:na), & + ! U cells + cdn_ocn(1:na), aiu(1:na), uocn(1:na), vocn(1:na), & + forcex(1:na), forcey(1:na), Tbu(1:na), umassdti(1:na), & + fm(1:na), uarear(1:na), strintx(1:na), strinty(1:na), & + uvel_init(1:na), vvel_init(1:na), taubx(1:na), tauby(1:na), & + ! error handling + stat=ierr) + + if (ierr /= 0) call abort_ice(subname & + // ' ERROR: could not allocate 1D arrays') + + end subroutine alloc1d + +!======================================================================= + + subroutine alloc1d_navel(navel) + + implicit none + + integer(kind=int_kind), intent(in) :: navel + + ! local variables + + integer(kind=int_kind) :: ierr + + character(len=*), parameter :: subname = '(alloc1d_navel)' + + allocate(uvel(1:navel), vvel(1:navel), indij(1:navel), & + halo_parent(1:navel), str1(1:navel), str2(1:navel), & + str3(1:navel), str4(1:navel), str5(1:navel), str6(1:navel), & + str7(1:navel), str8(1:navel), stat=ierr) + + if (ierr /= 0) call abort_ice(subname & + // ' ERROR: could not allocate 1D arrays') + + end subroutine alloc1d_navel + +!======================================================================= + + subroutine dealloc1d + + implicit none + + ! local variables + + integer(kind=int_kind) :: ierr + + character(len=*), parameter :: subname = '(dealloc1d)' + + deallocate( & + ! helper indices for neighbours + indj, indi, ee, ne, se, nw, sw, sse, skipucell, skiptcell, & + ! grid distances and their "-1 neighbours" + HTE, HTN, HTEm1, HTNm1, & + ! T cells + strength, dxt, dyt, tarear, stressp_1, stressp_2, stressp_3, & + stressp_4, stressm_1, stressm_2, stressm_3, stressm_4, & + stress12_1, stress12_2, stress12_3, stress12_4, str1, str2, & + str3, str4, str5, str6, str7, str8, divu, rdg_conv, & + rdg_shear, shear, & + ! U cells + cdn_ocn, aiu, uocn, vocn, forcex, forcey, Tbu, umassdti, fm, & + uarear, strintx, strinty, uvel_init, vvel_init, taubx, tauby, & + uvel, vvel, indij, halo_parent, & + ! error handling + stat=ierr) + + if (ierr /= 0) call abort_ice(subname & + // ' ERROR: could not deallocate 1D arrays') + + end subroutine dealloc1d + +!======================================================================= + + subroutine ice_dyn_evp_1d_copyin(nx, ny, nblk, nx_glob, ny_glob, & + I_icetmask, I_iceumask, I_cdn_ocn, I_aiu, I_uocn, I_vocn, & + I_forcex, I_forcey, I_Tbu, I_umassdti, I_fm, I_uarear, I_tarear, & + I_strintx, I_strinty, I_uvel_init, I_vvel_init, I_strength, & + I_uvel, I_vvel, I_dxt, I_dyt, I_stressp_1, I_stressp_2, & + I_stressp_3, I_stressp_4, I_stressm_1, I_stressm_2, I_stressm_3, & + I_stressm_4, I_stress12_1, I_stress12_2, I_stress12_3, & + I_stress12_4) + + use ice_gather_scatter, only : gather_global_ext + use ice_domain, only : distrb_info + use ice_communicate, only : my_task, master_task + use ice_grid, only : G_HTE, G_HTN + use ice_constants, only : c0 + + implicit none + + integer(int_kind), intent(in) :: nx, ny, nblk, nx_glob, ny_glob + logical(kind=log_kind), dimension(nx, ny, nblk), intent(in) :: & + I_iceumask + integer(kind=int_kind), dimension(nx, ny, nblk), intent(in) :: & + I_icetmask + real(kind=dbl_kind), dimension(nx, ny, nblk), intent(in) :: & + I_cdn_ocn, I_aiu, I_uocn, I_vocn, I_forcex, I_forcey, I_Tbu, & + I_umassdti, I_fm, I_uarear, I_tarear, I_strintx, I_strinty, & + I_uvel_init, I_vvel_init, I_strength, I_uvel, I_vvel, I_dxt, & + I_dyt, I_stressp_1, I_stressp_2, I_stressp_3, I_stressp_4, & + I_stressm_1, I_stressm_2, I_stressm_3, I_stressm_4, & + I_stress12_1, I_stress12_2, I_stress12_3, I_stress12_4 + + ! local variables + + logical(kind=log_kind), dimension(nx_glob, ny_glob) :: & + G_iceumask + integer(kind=int_kind), dimension(nx_glob, ny_glob) :: & + G_icetmask + real(kind=dbl_kind), dimension(nx_glob, ny_glob) :: & + G_cdn_ocn, G_aiu, G_uocn, G_vocn, G_forcex, G_forcey, G_Tbu, & + G_umassdti, G_fm, G_uarear, G_tarear, G_strintx, G_strinty, & + G_uvel_init, G_vvel_init, G_strength, G_uvel, G_vvel, G_dxt, & + G_dyt, G_stressp_1, G_stressp_2, G_stressp_3, G_stressp_4, & + G_stressm_1, G_stressm_2, G_stressm_3, G_stressm_4, & + G_stress12_1, G_stress12_2, G_stress12_3, G_stress12_4 + + character(len=*), parameter :: & + subname = '(ice_dyn_evp_1d_copyin)' + + call gather_global_ext(G_icetmask, I_icetmask, master_task, distrb_info ) + call gather_global_ext(G_iceumask, I_iceumask, master_task, distrb_info ) + call gather_global_ext(G_cdn_ocn, I_cdn_ocn, master_task, distrb_info ) + call gather_global_ext(G_aiu, I_aiu, master_task, distrb_info ) + call gather_global_ext(G_uocn, I_uocn, master_task, distrb_info ) + call gather_global_ext(G_vocn, I_vocn, master_task, distrb_info ) + call gather_global_ext(G_forcex, I_forcex, master_task, distrb_info ) + call gather_global_ext(G_forcey, I_forcey, master_task, distrb_info ) + call gather_global_ext(G_Tbu, I_Tbu, master_task, distrb_info ) + call gather_global_ext(G_umassdti, I_umassdti, master_task, distrb_info ) + call gather_global_ext(G_fm, I_fm, master_task, distrb_info ) + call gather_global_ext(G_uarear, I_uarear, master_task, distrb_info ) + call gather_global_ext(G_tarear, I_tarear, master_task, distrb_info ) + call gather_global_ext(G_strintx, I_strintx, master_task, distrb_info ) + call gather_global_ext(G_strinty, I_strinty, master_task, distrb_info ) + call gather_global_ext(G_uvel_init, I_uvel_init, master_task, distrb_info ) + call gather_global_ext(G_vvel_init, I_vvel_init, master_task, distrb_info ) + call gather_global_ext(G_strength, I_strength, master_task, distrb_info ) + call gather_global_ext(G_uvel, I_uvel, master_task, distrb_info, c0) + call gather_global_ext(G_vvel, I_vvel, master_task, distrb_info, c0) + call gather_global_ext(G_dxt, I_dxt, master_task, distrb_info ) + call gather_global_ext(G_dyt, I_dyt, master_task, distrb_info ) + call gather_global_ext(G_stressp_1, I_stressp_1, master_task, distrb_info ) + call gather_global_ext(G_stressp_2, I_stressp_2, master_task, distrb_info ) + call gather_global_ext(G_stressp_3, I_stressp_3, master_task, distrb_info ) + call gather_global_ext(G_stressp_4, I_stressp_4, master_task, distrb_info ) + call gather_global_ext(G_stressm_1, I_stressm_1, master_task, distrb_info ) + call gather_global_ext(G_stressm_2, I_stressm_2, master_task, distrb_info ) + call gather_global_ext(G_stressm_3, I_stressm_3, master_task, distrb_info ) + call gather_global_ext(G_stressm_4, I_stressm_4, master_task, distrb_info ) + call gather_global_ext(G_stress12_1, I_stress12_1, master_task, distrb_info ) + call gather_global_ext(G_stress12_2, I_stress12_2, master_task, distrb_info ) + call gather_global_ext(G_stress12_3, I_stress12_3, master_task, distrb_info ) + call gather_global_ext(G_stress12_4, I_stress12_4, master_task, distrb_info ) + + ! all calculations id done on master task + if (my_task == master_task) then + ! find number of active points and allocate 1D vectors + call calc_na(nx_glob, ny_glob, NA_len, G_icetmask, G_iceumask) + call alloc1d(NA_len) + call calc_2d_indices(nx_glob, ny_glob, NA_len, G_icetmask, G_iceumask) + call calc_navel(nx_glob, ny_glob, NA_len, NAVEL_len) + call alloc1d_navel(NAVEL_len) + ! initialize OpenMP. FIXME: ought to be called from main + call domp_init() + !$OMP PARALLEL DEFAULT(shared) + call numainit(1, NA_len, NAVEL_len) + !$OMP END PARALLEL + ! map 2D arrays to 1D arrays + call convert_2d_1d(nx_glob, ny_glob, NA_len, NAVEL_len, & + G_HTE, G_HTN, G_cdn_ocn, G_aiu, G_uocn, G_vocn, G_forcex, & + G_forcey, G_Tbu, G_umassdti, G_fm, G_uarear, G_tarear, & + G_strintx, G_strinty, G_uvel_init, G_vvel_init, & + G_strength, G_uvel, G_vvel, G_dxt, G_dyt, G_stressp_1, & + G_stressp_2, G_stressp_3, G_stressp_4, G_stressm_1, & + G_stressm_2, G_stressm_3, G_stressm_4, G_stress12_1, & + G_stress12_2, G_stress12_3, G_stress12_4) + call calc_halo_parent(nx_glob, ny_glob, NA_len, NAVEL_len, G_icetmask) + end if + + end subroutine ice_dyn_evp_1d_copyin + +!======================================================================= + + subroutine ice_dyn_evp_1d_copyout(nx, ny, nblk, nx_glob, ny_glob, & + I_uvel, I_vvel, I_strintx, I_strinty, I_stressp_1, I_stressp_2, & + I_stressp_3, I_stressp_4, I_stressm_1, I_stressm_2, I_stressm_3, & + I_stressm_4, I_stress12_1, I_stress12_2, I_stress12_3, & + I_stress12_4, I_divu, I_rdg_conv, I_rdg_shear, I_shear, I_taubx, & + I_tauby) + + use ice_constants, only : c0 + use ice_gather_scatter, only : scatter_global_ext + use ice_domain, only : distrb_info + use ice_communicate, only : my_task, master_task + + implicit none + + integer(int_kind), intent(in) :: nx, ny, nblk, nx_glob, ny_glob + real(dbl_kind), dimension(nx, ny, nblk), intent(out) :: I_uvel, & + I_vvel, I_strintx, I_strinty, I_stressp_1, I_stressp_2, & + I_stressp_3, I_stressp_4, I_stressm_1, I_stressm_2, & + I_stressm_3, I_stressm_4, I_stress12_1, I_stress12_2, & + I_stress12_3, I_stress12_4, I_divu, I_rdg_conv, I_rdg_shear, & + I_shear, I_taubx, I_tauby + + ! local variables + + integer(int_kind) :: iw, lo, up, j, i + real(dbl_kind), dimension(nx_glob, ny_glob) :: G_uvel, G_vvel, & + G_strintx, G_strinty, G_stressp_1, G_stressp_2, G_stressp_3, & + G_stressp_4, G_stressm_1, G_stressm_2, G_stressm_3, & + G_stressm_4, G_stress12_1, G_stress12_2, G_stress12_3, & + G_stress12_4, G_divu, G_rdg_conv, G_rdg_shear, G_shear, & + G_taubx, G_tauby + + character(len=*), parameter :: & + subname = '(ice_dyn_evp_1d_copyout)' + + ! remap 1D arrays into 2D arrays + if (my_task == master_task) then + + G_uvel = c0 + G_vvel = c0 + G_strintx = c0 + G_strinty = c0 + G_stressp_1 = c0 + G_stressp_2 = c0 + G_stressp_3 = c0 + G_stressp_4 = c0 + G_stressm_1 = c0 + G_stressm_2 = c0 + G_stressm_3 = c0 + G_stressm_4 = c0 + G_stress12_1 = c0 + G_stress12_2 = c0 + G_stress12_3 = c0 + G_stress12_4 = c0 + G_divu = c0 + G_rdg_conv = c0 + G_rdg_shear = c0 + G_shear = c0 + G_taubx = c0 + G_tauby = c0 + + !$OMP PARALLEL PRIVATE(iw, lo, up, j, i) + call domp_get_domain(1, NA_len, lo, up) + do iw = lo, up + ! get 2D indices + i = indi(iw) + j = indj(iw) + ! remap + G_strintx(i, j) = strintx(iw) + G_strinty(i, j) = strinty(iw) + G_stressp_1(i, j) = stressp_1(iw) + G_stressp_2(i, j) = stressp_2(iw) + G_stressp_3(i, j) = stressp_3(iw) + G_stressp_4(i, j) = stressp_4(iw) + G_stressm_1(i, j) = stressm_1(iw) + G_stressm_2(i, j) = stressm_2(iw) + G_stressm_3(i, j) = stressm_3(iw) + G_stressm_4(i, j) = stressm_4(iw) + G_stress12_1(i, j) = stress12_1(iw) + G_stress12_2(i, j) = stress12_2(iw) + G_stress12_3(i, j) = stress12_3(iw) + G_stress12_4(i, j) = stress12_4(iw) + G_divu(i, j) = divu(iw) + G_rdg_conv(i, j) = rdg_conv(iw) + G_rdg_shear(i, j) = rdg_shear(iw) + G_shear(i, j) = shear(iw) + G_taubx(i, j) = taubx(iw) + G_tauby(i, j) = tauby(iw) + G_uvel(i, j) = uvel(iw) + G_vvel(i, j) = vvel(iw) + end do + call domp_get_domain(NA_len + 1, NAVEL_len, lo, up) + do iw = lo, up + ! get 2D indices + j = int((indij(iw) - 1) / (nx_glob)) + 1 + i = indij(iw) - (j - 1) * nx_glob + ! remap + G_uvel(i, j) = uvel(iw) + G_vvel(i, j) = vvel(iw) + end do + !$OMP END PARALLEL + + call dealloc1d() + + end if + + ! scatter data on all tasks + call scatter_global_ext(I_uvel, G_uvel, master_task, distrb_info) + call scatter_global_ext(I_vvel, G_vvel, master_task, distrb_info) + call scatter_global_ext(I_strintx, G_strintx, master_task, distrb_info) + call scatter_global_ext(I_strinty, G_strinty, master_task, distrb_info) + call scatter_global_ext(I_stressp_1, G_stressp_1, master_task, distrb_info) + call scatter_global_ext(I_stressp_2, G_stressp_2, master_task, distrb_info) + call scatter_global_ext(I_stressp_3, G_stressp_3, master_task, distrb_info) + call scatter_global_ext(I_stressp_4, G_stressp_4, master_task, distrb_info) + call scatter_global_ext(I_stressm_1, G_stressm_1, master_task, distrb_info) + call scatter_global_ext(I_stressm_2, G_stressm_2, master_task, distrb_info) + call scatter_global_ext(I_stressm_3, G_stressm_3, master_task, distrb_info) + call scatter_global_ext(I_stressm_4, G_stressm_4, master_task, distrb_info) + call scatter_global_ext(I_stress12_1, G_stress12_1, master_task, distrb_info) + call scatter_global_ext(I_stress12_2, G_stress12_2, master_task, distrb_info) + call scatter_global_ext(I_stress12_3, G_stress12_3, master_task, distrb_info) + call scatter_global_ext(I_stress12_4, G_stress12_4, master_task, distrb_info) + call scatter_global_ext(I_divu, G_divu, master_task, distrb_info) + call scatter_global_ext(I_rdg_conv, G_rdg_conv, master_task, distrb_info) + call scatter_global_ext(I_rdg_shear, G_rdg_shear, master_task, distrb_info) + call scatter_global_ext(I_shear, G_shear, master_task, distrb_info) + call scatter_global_ext(I_taubx, G_taubx, master_task, distrb_info) + call scatter_global_ext(I_tauby, G_tauby, master_task, distrb_info) + + end subroutine ice_dyn_evp_1d_copyout + +!======================================================================= + + subroutine ice_dyn_evp_1d_kernel + + use ice_constants, only : c0 + use ice_dyn_shared, only : ndte + use ice_communicate, only : my_task, master_task + + implicit none + + ! local variables + + real(kind=dbl_kind) :: rhow + integer(kind=int_kind) :: ksub + + character(len=*), parameter :: & + subname = '(ice_dyn_evp_1d_kernel)' + + ! all calculations is done on master task + if (my_task == master_task) then + + ! read constants + call icepack_query_parameters(rhow_out = rhow) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) then + call abort_ice(error_message=subname, file=__FILE__, & + line=__LINE__) + end if + + if (ndte < 2) call abort_ice(subname & + // ' ERROR: ndte must be 2 or higher for this kernel') + + !$OMP PARALLEL PRIVATE(ksub) + do ksub = 1, ndte - 1 + call evp1d_stress(NA_len, ee, ne, se, 1, NA_len, uvel, & + vvel, dxt, dyt, hte, htn, htem1, htnm1, strength, & + stressp_1, stressp_2, stressp_3, stressp_4, stressm_1, & + stressm_2, stressm_3, stressm_4, stress12_1, & + stress12_2, stress12_3, stress12_4, str1, str2, str3, & + str4, str5, str6, str7, str8, skiptcell) + !$OMP BARRIER + call evp1d_stepu(NA_len, rhow, 1, NA_len, cdn_ocn, aiu, & + uocn, vocn, forcex, forcey, umassdti, fm, uarear, Tbu, & + uvel_init, vvel_init, uvel, vvel, str1, str2, str3, & + str4, str5, str6, str7, str8, nw, sw, sse, skipucell) + !$OMP BARRIER + call evp1d_halo_update(NAVEL_len, 1, NA_len, uvel, vvel, & + halo_parent) + !$OMP BARRIER + end do + + call evp1d_stress(NA_len, ee, ne, se, 1, NA_len, uvel, vvel, & + dxt, dyt, hte, htn, htem1, htnm1, strength, stressp_1, & + stressp_2, stressp_3, stressp_4, stressm_1, stressm_2, & + stressm_3, stressm_4, stress12_1, stress12_2, stress12_3, & + stress12_4, str1, str2, str3, str4, str5, str6, str7, & + str8, skiptcell, tarear, divu, rdg_conv, rdg_shear, shear) + !$OMP BARRIER + call evp1d_stepu(NA_len, rhow, 1, NA_len, cdn_ocn, aiu, uocn, & + vocn, forcex, forcey, umassdti, fm, uarear, Tbu, & + uvel_init, vvel_init, uvel, vvel, str1, str2, str3, str4, & + str5, str6, str7, str8, nw, sw, sse, skipucell, strintx, & + strinty, taubx, tauby) + !$OMP BARRIER + call evp1d_halo_update(NAVEL_len, 1, NA_len, uvel, vvel, & + halo_parent) + !$OMP END PARALLEL + + end if ! master task + + end subroutine ice_dyn_evp_1d_kernel + +!======================================================================= + + subroutine calc_na(nx, ny, na, icetmask, iceumask) + ! Calculate number of active points + + use ice_blocks, only : nghost + + implicit none + + integer(kind=int_kind), intent(in) :: nx, ny + integer(kind=int_kind), dimension(nx, ny), intent(in) :: & + icetmask + logical(kind=log_kind), dimension(nx, ny), intent(in) :: & + iceumask + integer(kind=int_kind), intent(out) :: na + + ! local variables + + integer(kind=int_kind) :: i, j + + character(len=*), parameter :: subname = '(calc_na)' + + na = 0 + ! NOTE: T mask includes northern and eastern ghost cells + do j = 1 + nghost, ny + do i = 1 + nghost, nx + if (icetmask(i,j) == 1 .or. iceumask(i,j)) na = na + 1 + end do + end do + + end subroutine calc_na + +!======================================================================= + + subroutine calc_2d_indices(nx, ny, na, icetmask, iceumask) + + use ice_blocks, only : nghost + + implicit none + + integer(kind=int_kind), intent(in) :: nx, ny, na + integer(kind=int_kind), dimension(nx, ny), intent(in) :: & + icetmask + logical(kind=log_kind), dimension(nx, ny), intent(in) :: & + iceumask + + ! local variables + + integer(kind=int_kind) :: i, j, Nmaskt + + character(len=*), parameter :: subname = '(calc_2d_indices)' + + skipucell(:) = .false. + skiptcell(:) = .false. + indi = 0 + indj = 0 + Nmaskt = 0 + ! NOTE: T mask includes northern and eastern ghost cells + do j = 1 + nghost, ny + do i = 1 + nghost, nx + if (icetmask(i,j) == 1 .or. iceumask(i,j)) then + Nmaskt = Nmaskt + 1 + indi(Nmaskt) = i + indj(Nmaskt) = j + if (icetmask(i,j) /= 1) skiptcell(Nmaskt) = .true. + if (.not. iceumask(i,j)) skipucell(Nmaskt) = .true. + ! NOTE: U mask does not include northern and eastern + ! ghost cells. Skip northern and eastern ghost cells + if (i == nx) skipucell(Nmaskt) = .true. + if (j == ny) skipucell(Nmaskt) = .true. + end if + end do + end do + + end subroutine calc_2d_indices + +!======================================================================= + + subroutine calc_navel(nx_block, ny_block, na, navel) + ! Calculate number of active points, including halo points + + implicit none + + integer(kind=int_kind), intent(in) :: nx_block, ny_block, na + integer(kind=int_kind), intent(out) :: navel + + ! local variables + + integer(kind=int_kind) :: iw, i, j + integer(kind=int_kind), dimension(1:na) :: Iin, Iee, Ine, Ise, & + Inw, Isw, Isse + integer(kind=int_kind), dimension(1:7 * na) :: util1, util2 + + character(len=*), parameter :: subname = '(calc_navel)' + + ! calculate additional 1D indices used for finite differences + do iw = 1, na + ! get 2D indices + i = indi(iw) + j = indj(iw) + ! calculate 1D indices + Iin(iw) = i + (j - 1) * nx_block ! ( 0, 0) target point + Iee(iw) = i - 1 + (j - 1) * nx_block ! (-1, 0) + Ine(iw) = i - 1 + (j - 2) * nx_block ! (-1, -1) + Ise(iw) = i + (j - 2) * nx_block ! ( 0, -1) + Inw(iw) = i + 1 + (j - 1) * nx_block ! (+1, 0) + Isw(iw) = i + 1 + (j - 0) * nx_block ! (+1, +1) + Isse(iw) = i + (j - 0) * nx_block ! ( 0, +1) + end do + + ! find number of points needed for finite difference calculations + call union(Iin, Iee, na, na, util1, i ) + call union(util1, Ine, i, na, util2, j ) + call union(util2, Ise, j, na, util1, i ) + call union(util1, Inw, i, na, util2, j ) + call union(util2, Isw, j, na, util1, i ) + call union(util1, Isse, i, na, util2, navel) + + end subroutine calc_navel + +!======================================================================= + + subroutine convert_2d_1d(nx, ny, na, navel, I_HTE, I_HTN, & + I_cdn_ocn, I_aiu, I_uocn, I_vocn, I_forcex, I_forcey, I_Tbu, & + I_umassdti, I_fm, I_uarear, I_tarear, I_strintx, I_strinty, & + I_uvel_init, I_vvel_init, I_strength, I_uvel, I_vvel, I_dxt, & + I_dyt, I_stressp_1, I_stressp_2, I_stressp_3, I_stressp_4, & + I_stressm_1, I_stressm_2, I_stressm_3, I_stressm_4, & + I_stress12_1, I_stress12_2, I_stress12_3, I_stress12_4) + + implicit none + + integer(kind=int_kind), intent(in) :: nx, ny, na, navel + real (kind=dbl_kind), dimension(nx, ny), intent(in) :: I_HTE, & + I_HTN, I_cdn_ocn, I_aiu, I_uocn, I_vocn, I_forcex, I_forcey, & + I_Tbu, I_umassdti, I_fm, I_uarear, I_tarear, I_strintx, & + I_strinty, I_uvel_init, I_vvel_init, I_strength, I_uvel, & + I_vvel, I_dxt, I_dyt, I_stressp_1, I_stressp_2, I_stressp_3, & + I_stressp_4, I_stressm_1, I_stressm_2, I_stressm_3, & + I_stressm_4, I_stress12_1, I_stress12_2, I_stress12_3, & + I_stress12_4 + + ! local variables + + integer(kind=int_kind) :: iw, lo, up, j, i, nachk + integer(kind=int_kind), dimension(1:na) :: Iin, Iee, Ine, Ise, & + Inw, Isw, Isse + integer(kind=int_kind), dimension(1:7 * na) :: util1, util2 + + character(len=*), parameter :: subname = '(convert_2d_1d)' + + ! calculate additional 1D indices used for finite differences + do iw = 1, na + ! get 2D indices + i = indi(iw) + j = indj(iw) + ! calculate 1D indices + Iin(iw) = i + (j - 1) * nx ! ( 0, 0) target point + Iee(iw) = i - 1 + (j - 1) * nx ! (-1, 0) + Ine(iw) = i - 1 + (j - 2) * nx ! (-1,-1) + Ise(iw) = i + (j - 2) * nx ! ( 0,-1) + Inw(iw) = i + 1 + (j - 1) * nx ! (+1, 0) + Isw(iw) = i + 1 + (j - 0) * nx ! (+1,+1) + Isse(iw) = i + (j - 0) * nx ! ( 0,+1) + end do + + ! find number of points needed for finite difference calculations + call union(Iin, Iee, na, na, util1, i ) + call union(util1, Ine, i, na, util2, j ) + call union(util2, Ise, j, na, util1, i ) + call union(util1, Inw, i, na, util2, j ) + call union(util2, Isw, j, na, util1, i ) + call union(util1, Isse, i, na, util2, nachk) + + ! index vector with sorted target points + do iw = 1, na + indij(iw) = Iin(iw) + end do + + ! sorted additional points + call setdiff(util2, Iin, navel, na, util1, j) + do iw = na + 1, navel + indij(iw) = util1(iw - na) + end do + + ! indices for additional points needed for uvel and vvel + call findXinY(Iee, indij, na, navel, ee) + call findXinY(Ine, indij, na, navel, ne) + call findXinY(Ise, indij, na, navel, se) + call findXinY(Inw, indij, na, navel, nw) + call findXinY(Isw, indij, na, navel, sw) + call findXinY(Isse, indij, na, navel, sse) + + !$OMP PARALLEL PRIVATE(iw, lo, up, j, i) + ! write 1D arrays from 2D arrays (target points) + call domp_get_domain(1, na, lo, up) + do iw = lo, up + ! get 2D indices + i = indi(iw) + j = indj(iw) + ! map + uvel(iw) = I_uvel(i, j) + vvel(iw) = I_vvel(i, j) + cdn_ocn(iw) = I_cdn_ocn(i, j) + aiu(iw) = I_aiu(i, j) + uocn(iw) = I_uocn(i, j) + vocn(iw) = I_vocn(i, j) + forcex(iw) = I_forcex(i, j) + forcey(iw) = I_forcey(i, j) + Tbu(iw) = I_Tbu(i, j) + umassdti(iw) = I_umassdti(i, j) + fm(iw) = I_fm(i, j) + tarear(iw) = I_tarear(i, j) + uarear(iw) = I_uarear(i, j) + strintx(iw) = I_strintx(i, j) + strinty(iw) = I_strinty(i, j) + uvel_init(iw) = I_uvel_init(i, j) + vvel_init(iw) = I_vvel_init(i, j) + strength(iw) = I_strength(i, j) + dxt(iw) = I_dxt(i, j) + dyt(iw) = I_dyt(i, j) + stressp_1(iw) = I_stressp_1(i, j) + stressp_2(iw) = I_stressp_2(i, j) + stressp_3(iw) = I_stressp_3(i, j) + stressp_4(iw) = I_stressp_4(i, j) + stressm_1(iw) = I_stressm_1(i, j) + stressm_2(iw) = I_stressm_2(i, j) + stressm_3(iw) = I_stressm_3(i, j) + stressm_4(iw) = I_stressm_4(i, j) + stress12_1(iw) = I_stress12_1(i, j) + stress12_2(iw) = I_stress12_2(i, j) + stress12_3(iw) = I_stress12_3(i, j) + stress12_4(iw) = I_stress12_4(i, j) + HTE(iw) = I_HTE(i, j) + HTN(iw) = I_HTN(i, j) + HTEm1(iw) = I_HTE(i - 1, j) + HTNm1(iw) = I_HTN(i, j - 1) + end do + ! write 1D arrays from 2D arrays (additional points) + call domp_get_domain(na + 1, navel, lo, up) + do iw = lo, up + ! get 2D indices + j = int((indij(iw) - 1) / (nx)) + 1 + i = indij(iw) - (j - 1) * nx + ! map + uvel(iw) = I_uvel(i, j) + vvel(iw) = I_vvel(i, j) + end do !$OMP END PARALLEL - endif - - end subroutine evp_kernel_v2 - -!---------------------------------------------------------------------------- - - subroutine calc_na(nx,ny,na,icetmask) - ! Calculate number of active points (na) - use ice_blocks, only: nghost - - implicit none - - integer(int_kind),intent(in) :: nx,ny - integer(int_kind),intent(out) :: na - integer (kind=int_kind),dimension (nx,ny), intent(in) :: icetmask - integer(int_kind) :: i,j - - character(len=*), parameter :: subname = '(calc_na)' - !--------------------------------------- - - na = 0 -! Note: The icellt mask includes north and east ghost cells. (ice_dyn_shared.F90) - do j = 1+nghost, ny ! -nghost - do i = 1+nghost, nx ! -nghost - if (icetmask(i,j)==1) then - na=na+1 - endif - enddo - enddo - - end subroutine calc_na - -!---------------------------------------------------------------------------- - - subroutine calc_2d_indices(nx,ny,na,icetmask,iceumask) - - use ice_blocks, only: nghost - - implicit none - - integer(int_kind),intent(in) :: nx,ny,na - integer (kind=int_kind),dimension (nx,ny), intent(in) :: icetmask - logical (kind=log_kind),dimension (nx,ny), intent(in) :: iceumask - integer(int_kind) :: i,j,Nmaskt - - character(len=*), parameter :: subname = '(calc_2d_indices)' - !--------------------------------------- - - skipucell(:)=.false. - indi=0 - indj=0 - Nmaskt=0 -! Note: The icellt mask includes north and east ghost cells. (ice_dyn_shared.F90) - do j = 1+nghost, ny ! -nghost - do i = 1+nghost, nx ! -nghost - if (icetmask(i,j)==1) then - Nmaskt=Nmaskt+1 - indi(Nmaskt) = i - indj(Nmaskt) = j - ! Umask do NOT include north/east ghost cells ... skip these as well - if (iceumask(i,j) .eqv. .false. ) skipucell(Nmaskt) = .true. - if (i==nx) skipucell(Nmaskt) = .true. - if (j==ny) skipucell(Nmaskt) = .true. - endif - enddo - enddo - if (Nmaskt.ne.na) then - write(nu_diag,*) subname,' Nmaskt,na: ',Nmaskt,na - call abort_ice(subname//': ERROR Problem Nmaskt != na') - endif - if (Nmaskt==0) then - write(nu_diag,*) subname,' WARNING: NO ICE' - endif - - end subroutine calc_2d_indices - -!---------------------------------------------------------------------------- - - subroutine calc_navel(nx_block,ny_block,na,navel) - ! Calculate number of active points including needed halo points (navel) - - implicit none - - integer(int_kind),intent(in) :: nx_block,ny_block,na - integer(int_kind),intent(out) :: navel - - integer(int_kind) :: iw,i,j - integer(int_kind),dimension(1:na) :: Iin,Iee,Ine,Ise,Inw,Isw,Isse - integer(int_kind),dimension(1:7*na) :: util1,util2 - - character(len=*), parameter :: subname = '(calc_navel)' - - !--------------------------------------- - ! Additional indices used for finite differences (FD) - do iw=1,na - i=indi(iw) - j=indj(iw) - Iin(iw) = i + (j-1)*nx_block ! ( 0, 0) Target point - Iee(iw) = i-1 + (j-1)*nx_block ! (-1, 0) - Ine(iw) = i-1 + (j-2)*nx_block ! (-1,-1) - Ise(iw) = i + (j-2)*nx_block ! ( 0,-1) - Inw(iw) = i+1 + (j-1)*nx_block ! (+1, 0) - Isw(iw) = i+1 + (j-0)*nx_block ! (+1,+1) - Isse(iw)= i + (j-0)*nx_block ! ( 0,+1) - enddo - - !-- Find number of points needed for finite difference calculations - call union(Iin, Iee,na,na,util1,i) - call union(util1,Ine, i,na,util2,j) - call union(util2,Ise, j,na,util1,i) - call union(util1,Inw, i,na,util2,j) - call union(util2,Isw, j,na,util1,i) - call union(util1,Isse,i,na,util2,navel) - - !-- Check bounds - do iw=1,navel - if (util2(iw)>nx_block*ny_block .or. util2(iw)<1) then - write(nu_diag,*) subname,' nx_block,ny_block,nx_block*ny_block: ',nx_block,ny_block,nx_block*ny_block - write(nu_diag,*) subname,' na,navel,iw,util2(iw): ',na,navel,iw,util2(iw) - call abort_ice(subname//': Problem with boundary. Check halo zone values') - endif - enddo - - end subroutine calc_navel - -!---------------------------------------------------------------------------- - - subroutine convert_2d_1d_v2(nx,ny, na,navel, & - I_HTE,I_HTN, & -!v1 I_dxhy,I_dyhx,I_cyp,I_cxp,I_cym,I_cxm,I_tinyarea, & -!v1 I_waterx,I_watery, & - I_cdn_ocn,I_aiu,I_uocn,I_vocn,I_forcex,I_forcey,I_Tbu, & - I_umassdti,I_fm,I_uarear,I_tarear,I_strintx,I_strinty, & - I_uvel_init,I_vvel_init, & - I_strength,I_uvel,I_vvel,I_dxt,I_dyt, & - I_stressp_1 ,I_stressp_2, I_stressp_3, I_stressp_4, & - I_stressm_1 ,I_stressm_2, I_stressm_3, I_stressm_4, & - I_stress12_1,I_stress12_2,I_stress12_3,I_stress12_4 ) - - implicit none - - integer(int_kind),intent(in) :: nx,ny,na,navel - real (kind=dbl_kind), dimension(nx,ny), intent(in) :: & - I_HTE,I_HTN, & -!v1 I_dxhy,I_dyhx,I_cyp,I_cxp,I_cym,I_cxm,I_tinyarea, & -!v1 I_waterx,I_watery, & - I_cdn_ocn,I_aiu,I_uocn,I_vocn,I_forcex,I_forcey,I_Tbu, & - I_umassdti,I_fm,I_uarear,I_tarear,I_strintx,I_strinty, & - I_uvel_init,I_vvel_init, & - I_strength,I_uvel,I_vvel,I_dxt,I_dyt, & - I_stressp_1 ,I_stressp_2, I_stressp_3, I_stressp_4, & - I_stressm_1 ,I_stressm_2, I_stressm_3, I_stressm_4, & - I_stress12_1,I_stress12_2,I_stress12_3,I_stress12_4 - - integer(int_kind) :: iw,i,j, nx_block - integer(int_kind),dimension(1:na) :: Iin,Iee,Ine,Ise,Inw,Isw,Isse - integer(int_kind),dimension(1:7*na) :: util1,util2 - integer(int_kind) :: nachk - - character(len=*), parameter :: subname = '(convert_2d_1d_v2)' - - !--------------------------------------- - ! Additional indices used for finite differences (FD) - nx_block=nx ! Total block size in x-dir - do iw=1,na - i=indi(iw) - j=indj(iw) - Iin(iw) = i + (j-1)*nx_block ! ( 0, 0) Target point - Iee(iw) = i-1 + (j-1)*nx_block ! (-1, 0) - Ine(iw) = i-1 + (j-2)*nx_block ! (-1,-1) - Ise(iw) = i + (j-2)*nx_block ! ( 0,-1) - Inw(iw) = i+1 + (j-1)*nx_block ! (+1, 0) - Isw(iw) = i+1 + (j-0)*nx_block ! (+1,+1) - Isse(iw)= i + (j-0)*nx_block ! ( 0,+1) - enddo - - !-- Find number of points needed for finite difference calculations - call union(Iin, Iee,na,na,util1,i) - call union(util1,Ine, i,na,util2,j) - call union(util2,Ise, j,na,util1,i) - call union(util1,Inw, i,na,util2,j) - call union(util2,Isw, j,na,util1,i) - call union(util1,Isse,i,na,util2,nachk) - - if (nachk .ne. navel) then - write(nu_diag,*) subname,' ERROR: navel badly chosen: na,navel,nachk = ',na,navel,nachk - call abort_ice(subname//': ERROR: navel badly chosen') - endif - - ! indij: vector with target points (sorted) ... - do iw=1,na - indij(iw)=Iin(iw) - enddo - - ! indij: ... followed by extra points (sorted) - call setdiff(util2,Iin,navel,na,util1,j) - do iw=na+1,navel - indij(iw)=util1(iw-na) - enddo - - !-- Create indices for additional points needed for uvel,vvel: - call findXinY(Iee ,indij,na,navel, ee) - call findXinY(Ine ,indij,na,navel, ne) - call findXinY(Ise ,indij,na,navel, se) - call findXinY(Inw ,indij,na,navel, nw) - call findXinY(Isw ,indij,na,navel, sw) - call findXinY(Isse,indij,na,navel,sse) - - !-- write check -!if (1 == 2) then -! write(nu_diag,*) subname,' MHRI: INDICES start:' -! write(nu_diag,*) 'Min/max ee', minval(ee), maxval(ee) -! write(nu_diag,*) 'Min/max ne', minval(ne), maxval(ne) -! write(nu_diag,*) 'Min/max se', minval(se), maxval(se) -! write(nu_diag,*) 'Min/max nw', minval(nw), maxval(nw) -! write(nu_diag,*) 'Min/max sw', minval(sw), maxval(sw) -! write(nu_diag,*) 'Min/max sse',minval(sse),maxval(sse) -! write(nu_diag,*) subname,' MHRI: INDICES end:' -!endif - - ! Write 1D data from 2D: Here only extra FD part, the rest follows... - !$OMP PARALLEL DO PRIVATE(iw,i,j) - do iw=na+1,navel - j=int((indij(iw)-1)/(nx_block))+1 - i=indij(iw)-(j-1)*nx_block - uvel(iw)= I_uvel(i,j) - vvel(iw)= I_vvel(i,j) - enddo - !$OMP END PARALLEL DO - - ! Write 1D data from 2D - !$OMP PARALLEL DO PRIVATE(iw,i,j) - do iw=1,na - i=indi(iw) - j=indj(iw) - uvel(iw)= I_uvel(i,j) - vvel(iw)= I_vvel(i,j) - cdn_ocn(iw)= I_cdn_ocn(i,j) - aiu(iw)= I_aiu(i,j) - uocn(iw)= I_uocn(i,j) - vocn(iw)= I_vocn(i,j) - forcex(iw)= I_forcex(i,j) - forcey(iw)= I_forcey(i,j) - Tbu(iw)= I_Tbu(i,j) - umassdti(iw)= I_umassdti(i,j) - fm(iw)= I_fm(i,j) - tarear(iw)= I_tarear(i,j) - uarear(iw)= I_uarear(i,j) - strintx(iw)= I_strintx(i,j) - strinty(iw)= I_strinty(i,j) - uvel_init(iw)= I_uvel_init(i,j) - vvel_init(iw)= I_vvel_init(i,j) - strength(iw)= I_strength(i,j) - dxt(iw)= I_dxt(i,j) - dyt(iw)= I_dyt(i,j) - stressp_1(iw)= I_stressp_1(i,j) - stressp_2(iw)= I_stressp_2(i,j) - stressp_3(iw)= I_stressp_3(i,j) - stressp_4(iw)= I_stressp_4(i,j) - stressm_1(iw)= I_stressm_1(i,j) - stressm_2(iw)= I_stressm_2(i,j) - stressm_3(iw)= I_stressm_3(i,j) - stressm_4(iw)= I_stressm_4(i,j) - stress12_1(iw)=I_stress12_1(i,j) - stress12_2(iw)=I_stress12_2(i,j) - stress12_3(iw)=I_stress12_3(i,j) - stress12_4(iw)=I_stress12_4(i,j) -!v1 dxhy(iw)= I_dxhy(i,j) -!v1 dyhx(iw)= I_dyhx(i,j) -!v1 cyp(iw)= I_cyp(i,j) -!v1 cxp(iw)= I_cxp(i,j) -!v1 cym(iw)= I_cym(i,j) -!v1 cxm(iw)= I_cxm(i,j) -!v1 tinyarea(iw)= I_tinyarea(i,j) -!v1 waterx(iw)= I_waterx(i,j) -!v1 watery(iw)= I_watery(i,j) - HTE(iw) = I_HTE(i,j) - HTN(iw) = I_HTN(i,j) - HTEm1(iw) = I_HTE(i-1,j) - HTNm1(iw) = I_HTN(i,j-1) - enddo - !$OMP END PARALLEL DO - - end subroutine convert_2d_1d_v2 - -!---------------------------------------------------------------------------- - - subroutine calc_halo_parent(nx,ny,na,navel, I_icetmask) - - implicit none - - integer(kind=int_kind),intent(in) :: nx,ny,na,navel - integer(kind=int_kind), dimension(nx,ny), intent(in) :: I_icetmask - - integer(kind=int_kind) :: iw,i,j !,masku,maskt - integer(kind=int_kind),dimension(1:navel) :: Ihalo - - character(len=*), parameter :: subname = '(calc_halo_parent)' - - !--------------------------------------- - ! Indices for halo update: - ! 0: no halo point - ! >0: index for halo point parent. Finally related to indij vector - ! TODO: ONLY for nghost==1 - ! TODO: ONLY for circular grids - NOT tripole grids - - Ihalo(:)=0 - halo_parent(:)=0 - - !$OMP PARALLEL DO PRIVATE(iw,i,j) - do iw=1,navel - j=int((indij(iw)-1)/(nx))+1 - i=indij(iw)-(j-1)*nx - ! If within ghost-zone: - if (i==nx .and. I_icetmask( 2,j)==1) Ihalo(iw)= 2+ (j-1)*nx - if (i==1 .and. I_icetmask(nx-1,j)==1) Ihalo(iw)=(nx-1)+ (j-1)*nx - if (j==ny .and. I_icetmask(i, 2)==1) Ihalo(iw)= i+ nx - if (j==1 .and. I_icetmask(i,ny-1)==1) Ihalo(iw)= i+(ny-2)*nx - enddo - !$OMP END PARALLEL DO - - ! Relate halo indices to indij vector - call findXinY_halo(Ihalo,indij,navel,navel,halo_parent) - - !-- write check -!if (1 == 1) then -! integer(kind=int_kind) :: iiw,ii,jj !,masku,maskt MHRI -! write(nu_diag,*) subname,' MHRI: halo boundary start:' -! do iw=1,navel -! if (halo_parent(iw)>0) then -! iiw=halo_parent(iw) -! j=int((indij(iiw)-1)/(nx))+1 -! i=indij(iiw)-(j-1)*nx -! ii=i -! jj=j -! j=int((indij(iw)-1)/(nx))+1 -! i=indij(iw)-(j-1)*nx -! write(nu_diag,*)iw,i,j,iiw,ii,jj -! endif -! enddo -! write(nu_diag,*) subname,' MHRI: halo boundary end:' -!endif - - end subroutine calc_halo_parent - -!---------------------------------------------------------------------------- - - subroutine union(x,y,nx,ny,xy,nxy) - ! Find union (xy) of two sorted integer vectors (x and y) - ! ie. Combined values of the two vectors with no repetitions. - !use ice_kinds_mod - - implicit none - - integer (int_kind) :: i,j,k - integer (int_kind),intent(in) :: nx,ny - integer (int_kind),intent(in) :: x(1:nx),y(1:ny) - integer (int_kind),intent(out) :: xy(1:nx+ny) - integer (int_kind),intent(out) :: nxy - - character(len=*), parameter :: subname = '(union)' - - !--------------------------------------- - - i=1 - j=1 - k=1 - do while (i<=nx .and. j<=ny) - if (x(i)y(j)) then - xy(k)=y(j) - j=j+1 - else !if (x(i)==y(j)) then - xy(k)=x(i) - i=i+1 - j=j+1 - endif - k=k+1 - enddo - - ! The rest - do while (i<=nx) - xy(k)=x(i) - i=i+1 - k=k+1 - enddo - do while (j<=ny) - xy(k)=y(j) - j=j+1 - k=k+1 - enddo - nxy=k-1 - - end subroutine union - -!---------------------------------------------------------------------------- - - subroutine setdiff(x,y,nx,ny,xy,nxy) - ! Find element (xy) of two sorted integer vectors (x and y) - ! that are in x, but not in y ... or in y, but not in x - !use ice_kinds_mod - - implicit none - - integer (int_kind) :: i,j,k - integer (int_kind),intent(in) :: nx,ny - integer (int_kind),intent(in) :: x(1:nx),y(1:ny) - integer (int_kind),intent(out) :: xy(1:nx+ny) - integer (int_kind),intent(out) :: nxy - - character(len=*), parameter :: subname = '(setdiff)' - !--------------------------------------- - - i=1 - j=1 - k=1 - do while (i<=nx .and. j<=ny) - if (x(i)y(j)) then - xy(k)=y(j) - j=j+1 - k=k+1 - else !if (x(i)==y(j)) then - i=i+1 - j=j+1 - endif - enddo - - ! The rest - do while (i<=nx) - xy(k)=x(i) - i=i+1 - k=k+1 - enddo - do while (j<=ny) - xy(k)=y(j) - j=j+1 - k=k+1 - enddo - nxy=k-1 - - end subroutine setdiff - -!---------------------------------------------------------------------------- - - subroutine findXinY(x,y,nx,ny,indx) - ! Find indx vector so that x(1:na)=y(indx(1:na)) - ! - ! Conditions: - ! * EVERY item in x is found in y. - ! * x(1:nx) is a sorted integer vector. - ! * y(1:ny) consists of two sorted integer vectors: - ! [y(1:nx) ; y(nx+1:ny)] - ! * ny>=nx - ! Return: indx(1:na) - ! - !use ice_kinds_mod - - implicit none - - integer (int_kind),intent(in) :: nx,ny - integer (int_kind),intent(in) :: x(1:nx),y(1:ny) - integer (int_kind),intent(out) :: indx(1:nx) - integer (int_kind) :: i,j1,j2 - - character(len=*), parameter :: subname = '(findXinY)' - !--------------------------------------- - - i=1 - j1=1 - j2=nx+1 - do while (i<=nx) - if (x(i)==y(j1)) then - indx(i)=j1 - i=i+1 - j1=j1+1 - else if (x(i)==y(j2)) then - indx(i)=j2 - i=i+1 - j2=j2+1 - else if (x(i)>y(j1) ) then !.and. j1y(j2) ) then !.and. j2=nx - ! Return: indx(1:na) - ! - !use ice_kinds_mod - - implicit none - - integer (int_kind),intent(in) :: nx,ny - integer (int_kind),intent(in) :: x(1:nx),y(1:ny) - integer (int_kind),intent(out) :: indx(1:nx) - integer (int_kind) :: i,j1,nloop - - character(len=*), parameter :: subname = '(findXinY_halo)' - !--------------------------------------- - - nloop=1 - i=1 - j1=int((ny+1)/2) ! initial guess in the middle - do while (i<=nx) - if (x(i)==0) then - indx(i)=0 - i=i+1 - nloop=1 - else if (x(i)==y(j1)) then - indx(i)=j1 - i=i+1 - j1=j1+1 - if (j1>ny) j1=int((ny+1)/2) ! initial guess in the middle - nloop=1 - else if (x(i)y(j1) ) then - j1=j1+1 - if (j1>ny) then - j1=1 - nloop=nloop+1 - if (nloop>2) then - ! Stop for inf. loop. This check should not be necessary for halo - write(nu_diag,*) subname,' nx,ny: ',nx,ny - write(nu_diag,*) subname,' i,j1: ',i,j1 - write(nu_diag,*) subname,' x(i),y(j1): ',x(i),y(j1) - call abort_ice(subname//': ERROR too many loops') - endif - endif - endif - end do - - end subroutine findXinY_halo - -!---------------------------------------------------------------------------- - - subroutine numainit(l,u,uu) - - use ice_constants, only: c0 - - implicit none - - integer(kind=int_kind),intent(in) :: l,u,uu - - integer(kind=int_kind) :: lo,up - - character(len=*), parameter :: subname = '(numainit)' - !--------------------------------------- - - call domp_get_domain(l,u,lo,up) - ee(lo:up)=0 - ne(lo:up)=0 - se(lo:up)=0 - sse(lo:up)=0 - nw(lo:up)=0 - sw(lo:up)=0 - halo_parent(lo:up)=0 - strength(lo:up)=c0 - uvel(lo:up)=c0 - vvel(lo:up)=c0 - uvel_init(lo:up)=c0 - vvel_init(lo:up)=c0 - uocn(lo:up)=c0 - vocn(lo:up)=c0 - dxt(lo:up)=c0 - dyt(lo:up)=c0 - HTE(lo:up)=c0 - HTN(lo:up)=c0 - HTEm1(lo:up)=c0 - HTNm1(lo:up)=c0 -!v1 dxhy(lo:up)=c0 -!v1 dyhx(lo:up)=c0 -!v1 cyp(lo:up)=c0 -!v1 cxp(lo:up)=c0 -!v1 cym(lo:up)=c0 -!v1 cxm(lo:up)=c0 -!v1 tinyarea(lo:up)=c0 - stressp_1(lo:up)=c0 - stressp_2(lo:up)=c0 - stressp_3(lo:up)=c0 - stressp_4(lo:up)=c0 - stressm_1(lo:up)=c0 - stressm_2(lo:up)=c0 - stressm_3(lo:up)=c0 - stressm_4(lo:up)=c0 - stress12_1(lo:up)=c0 - stress12_2(lo:up)=c0 - stress12_3(lo:up)=c0 - stress12_4(lo:up)=c0 - tarear(lo:up)=c0 - Tbu(lo:up)=c0 - taubx(lo:up)=c0 - tauby(lo:up)=c0 - divu(lo:up)=c0 - rdg_conv(lo:up)=c0 - rdg_shear(lo:up)=c0 - shear(lo:up)=c0 - str1(lo:up)=c0 - str2(lo:up)=c0 - str3(lo:up)=c0 - str4(lo:up)=c0 - str5(lo:up)=c0 - str6(lo:up)=c0 - str7(lo:up)=c0 - str8(lo:up)=c0 - call domp_get_domain(u+1,uu,lo,up) - halo_parent(lo:up)=0 - uvel(lo:up)=c0 - vvel(lo:up)=c0 - str1(lo:up)=c0 - str2(lo:up)=c0 - str3(lo:up)=c0 - str4(lo:up)=c0 - str5(lo:up)=c0 - str6(lo:up)=c0 - str7(lo:up)=c0 - str8(lo:up)=c0 - - end subroutine numainit - -!---------------------------------------------------------------------------- -!=============================================================================== + end subroutine convert_2d_1d -end module ice_dyn_evp_1d +!======================================================================= + + subroutine calc_halo_parent(nx, ny, na, navel, I_icetmask) + + implicit none + integer(kind=int_kind), intent(in) :: nx, ny, na, navel + integer(kind=int_kind), dimension(nx, ny), intent(in) :: & + I_icetmask + + ! local variables + + integer(kind=int_kind) :: iw, i, j + integer(kind=int_kind), dimension(1:navel) :: Ihalo + + character(len=*), parameter :: subname = '(calc_halo_parent)' + + !----------------------------------------------------------------- + ! Indices for halo update: + ! 0: no halo point + ! >0: index for halo point parent, related to indij vector + ! + ! TODO: Implement for nghost > 1 + ! TODO: Implement for tripole grids + !----------------------------------------------------------------- + + Ihalo(:) = 0 + halo_parent(:) = 0 + + do iw = 1, navel + j = int((indij(iw) - 1) / (nx)) + 1 + i = indij(iw) - (j - 1) * nx + ! if within ghost zone + if (i == nx .and. I_icetmask(2, j) == 1) Ihalo(iw) = 2 + (j - 1) * nx + if (i == 1 .and. I_icetmask(nx - 1, j) == 1) Ihalo(iw) = (nx - 1) + (j - 1) * nx + if (j == ny .and. I_icetmask(i, 2) == 1) Ihalo(iw) = i + nx + if (j == 1 .and. I_icetmask(i, ny - 1) == 1) Ihalo(iw) = i + (ny - 2) * nx + end do + + ! relate halo indices to indij vector + call findXinY_halo(Ihalo, indij, navel, navel, halo_parent) + + end subroutine calc_halo_parent + +!======================================================================= + + subroutine union(x, y, nx, ny, xy, nxy) + ! Find union (xy) of two sorted integer vectors (x and y), i.e. + ! combined values of the two vectors with no repetitions + + implicit none + + integer(int_kind), intent(in) :: nx, ny + integer(int_kind), intent(in) :: x(1:nx), y(1:ny) + integer(int_kind), intent(out) :: xy(1:nx + ny) + integer(int_kind), intent(out) :: nxy + + ! local variables + + integer(int_kind) :: i, j, k + + character(len=*), parameter :: subname = '(union)' + + i = 1 + j = 1 + k = 1 + do while (i <= nx .and. j <= ny) + if (x(i) < y(j)) then + xy(k) = x(i) + i = i + 1 + else if (x(i) > y(j)) then + xy(k) = y(j) + j = j + 1 + else + xy(k) = x(i) + i = i + 1 + j = j + 1 + end if + k = k + 1 + end do + + ! the rest + do while (i <= nx) + xy(k) = x(i) + i = i + 1 + k = k + 1 + end do + do while (j <= ny) + xy(k) = y(j) + j = j + 1 + k = k + 1 + end do + nxy = k - 1 + + end subroutine union + +!======================================================================= + + subroutine setdiff(x, y, nx, ny, xy, nxy) + ! Find element (xy) of two sorted integer vectors (x and y) that + ! are in x, but not in y, or in y, but not in x + + implicit none + + integer(kind=int_kind), intent(in) :: nx, ny + integer(kind=int_kind), intent(in) :: x(1:nx), y(1:ny) + integer(kind=int_kind), intent(out) :: xy(1:nx + ny) + integer(kind=int_kind), intent(out) :: nxy + + ! local variables + + integer(kind=int_kind) :: i, j, k + + character(len=*), parameter :: subname = '(setdiff)' + + i = 1 + j = 1 + k = 1 + do while (i <= nx .and. j <= ny) + if (x(i) < y(j)) then + xy(k) = x(i) + i = i + 1 + k = k + 1 + else if (x(i) > y(j)) then + xy(k) = y(j) + j = j + 1 + k = k + 1 + else + i = i + 1 + j = j + 1 + end if + end do + + ! the rest + do while (i <= nx) + xy(k) = x(i) + i = i + 1 + k = k + 1 + end do + do while (j <= ny) + xy(k) = y(j) + j = j + 1 + k = k + 1 + end do + nxy = k - 1 + + end subroutine setdiff + +!======================================================================== + + subroutine findXinY(x, y, nx, ny, indx) + ! Find indx vector so that x(1:na) = y(indx(1:na)) + ! + ! Conditions: + ! * EVERY item in x is found in y + ! * x(1:nx) is a sorted integer vector + ! * y(1:ny) consists of two sorted integer vectors: + ! [y(1:nx); y(nx + 1:ny)] + ! * ny >= nx + ! + ! Return: indx(1:na) + + implicit none + + integer (kind=int_kind), intent(in) :: nx, ny + integer (kind=int_kind), intent(in) :: x(1:nx), y(1:ny) + integer (kind=int_kind), intent(out) :: indx(1:nx) + + ! local variables + + integer (kind=int_kind) :: i, j1, j2 + + character(len=*), parameter :: subname = '(findXinY)' + + i = 1 + j1 = 1 + j2 = nx + 1 + do while (i <= nx) + if (x(i) == y(j1)) then + indx(i) = j1 + i = i + 1 + j1 = j1 + 1 + else if (x(i) == y(j2)) then + indx(i) = j2 + i = i + 1 + j2 = j2 + 1 + else if (x(i) > y(j1)) then + j1 = j1 + 1 + else if (x(i) > y(j2)) then + j2 = j2 + 1 + else + call abort_ice(subname & + // ': ERROR: conditions not met') + end if + end do + + end subroutine findXinY + +!======================================================================= + + subroutine findXinY_halo(x, y, nx, ny, indx) + ! Find indx vector so that x(1:na) = y(indx(1:na)) + ! + ! Conditions: + ! * EVERY item in x is found in y, + ! except for x == 0, where indx = 0 is returned + ! * x(1:nx) is a non-sorted integer vector + ! * y(1:ny) is a sorted integer vector + ! * ny >= nx + ! + ! Return: indx(1:na) + + implicit none + + integer (kind=int_kind), intent(in) :: nx, ny + integer (kind=int_kind), intent(in) :: x(1:nx), y(1:ny) + integer (kind=int_kind), intent(out) :: indx(1:nx) + + ! local variables + + integer (kind=int_kind) :: i, j1, nloop + + character(len=*), parameter :: subname = '(findXinY_halo)' + + nloop = 1 + i = 1 + j1 = int((ny + 1) / 2) ! initial guess in the middle + do while (i <= nx) + if (x(i) == 0) then + indx(i) = 0 + i = i + 1 + nloop = 1 + else if (x(i) == y(j1)) then + indx(i) = j1 + i = i + 1 + j1 = j1 + 1 + ! initial guess in the middle + if (j1 > ny) j1 = int((ny + 1) / 2) + nloop = 1 + else if (x(i) < y(j1)) then + j1 = 1 + else if (x(i) > y(j1)) then + j1 = j1 + 1 + if (j1 > ny) then + j1 = 1 + nloop = nloop + 1 + if (nloop > 2) then + ! stop for infinite loop. This check should not be + ! necessary for halo + call abort_ice(subname // ' ERROR: too many loops') + end if + end if + end if + end do + + end subroutine findXinY_halo + +!======================================================================= + + subroutine numainit(l, u, uu) + + use ice_constants, only : c0 + + implicit none + + integer(kind=int_kind), intent(in) :: l, u, uu + + ! local variables + + integer(kind=int_kind) :: lo, up + + character(len=*), parameter :: subname = '(numainit)' + + call domp_get_domain(l, u, lo, up) + ee(lo:up) = 0 + ne(lo:up) = 0 + se(lo:up) = 0 + sse(lo:up) = 0 + nw(lo:up) = 0 + sw(lo:up) = 0 + halo_parent(lo:up) = 0 + strength(lo:up) = c0 + uvel(lo:up) = c0 + vvel(lo:up) = c0 + uvel_init(lo:up) = c0 + vvel_init(lo:up) = c0 + uocn(lo:up) = c0 + vocn(lo:up) = c0 + dxt(lo:up) = c0 + dyt(lo:up) = c0 + HTE(lo:up) = c0 + HTN(lo:up) = c0 + HTEm1(lo:up) = c0 + HTNm1(lo:up) = c0 + stressp_1(lo:up) = c0 + stressp_2(lo:up) = c0 + stressp_3(lo:up) = c0 + stressp_4(lo:up) = c0 + stressm_1(lo:up) = c0 + stressm_2(lo:up) = c0 + stressm_3(lo:up) = c0 + stressm_4(lo:up) = c0 + stress12_1(lo:up) = c0 + stress12_2(lo:up) = c0 + stress12_3(lo:up) = c0 + stress12_4(lo:up) = c0 + tarear(lo:up) = c0 + Tbu(lo:up) = c0 + taubx(lo:up) = c0 + tauby(lo:up) = c0 + divu(lo:up) = c0 + rdg_conv(lo:up) = c0 + rdg_shear(lo:up) = c0 + shear(lo:up) = c0 + str1(lo:up) = c0 + str2(lo:up) = c0 + str3(lo:up) = c0 + str4(lo:up) = c0 + str5(lo:up) = c0 + str6(lo:up) = c0 + str7(lo:up) = c0 + str8(lo:up) = c0 + + call domp_get_domain(u + 1, uu, lo, up) + halo_parent(lo:up) = 0 + uvel(lo:up) = c0 + vvel(lo:up) = c0 + str1(lo:up) = c0 + str2(lo:up) = c0 + str3(lo:up) = c0 + str4(lo:up) = c0 + str5(lo:up) = c0 + str6(lo:up) = c0 + str7(lo:up) = c0 + str8(lo:up) = c0 + + end subroutine numainit + +!======================================================================= + +end module ice_dyn_evp_1d diff --git a/cicecore/cicedynB/dynamics/ice_dyn_shared.F90 b/cicecore/cicedynB/dynamics/ice_dyn_shared.F90 old mode 100644 new mode 100755 index f3685ed61..bb65f122c --- a/cicecore/cicedynB/dynamics/ice_dyn_shared.F90 +++ b/cicecore/cicedynB/dynamics/ice_dyn_shared.F90 @@ -40,13 +40,11 @@ module ice_dyn_shared ssh_stress ! 'geostrophic' or 'coupled' logical (kind=log_kind), public :: & - revised_evp ! if true, use revised evp procedure + revised_evp ! if true, use revised evp procedure - integer (kind=int_kind), public :: & - kevp_kernel ! 0 = 2D org version - ! 1 = 1D representation raw (not implemented) - ! 2 = 1D + calculate distances inline (implemented) - ! 3 = 1D + calculate distances inline + real*4 internal (not implemented yet) + character (len=char_len), public :: & + evp_algorithm ! standard_2d = 2D org version (standard) + ! shared_mem_1d = 1d without mpi call and refactorization to 1d ! other EVP parameters character (len=char_len), public :: & @@ -55,12 +53,12 @@ module ice_dyn_shared ! LKD: Lemieux et al. 2015, probabilistic: Dupont et al. in prep. real (kind=dbl_kind), parameter, public :: & - eyc = 0.36_dbl_kind, & - ! coefficient for calculating the parameter E - cosw = c1 , & ! cos(ocean turning angle) ! turning angle = 0 - sinw = c0 , & ! sin(ocean turning angle) ! turning angle = 0 - a_min = p001, & ! minimum ice area - m_min = p01 ! minimum ice mass (kg/m^2) + eyc = 0.36_dbl_kind, & ! coefficient for calculating the parameter E + u0 = 5e-5_dbl_kind, & ! residual velocity for seabed stress (m/s) + cosw = c1 , & ! cos(ocean turning angle) ! turning angle = 0 + sinw = c0 , & ! sin(ocean turning angle) ! turning angle = 0 + a_min = p001 , & ! minimum ice area + m_min = p01 ! minimum ice mass (kg/m^2) real (kind=dbl_kind), public :: & revp , & ! 0 for classic EVP, 1 for revised EVP @@ -91,12 +89,11 @@ module ice_dyn_shared seabed_stress ! if true, seabed stress for landfast on real (kind=dbl_kind), public :: & - k1, & ! 1st free parameter for seabed1 grounding parameterization - k2, & ! second free parameter (N/m^3) for seabed1 grounding parametrization - alphab, & ! alphab=Cb factor in Lemieux et al 2015 - threshold_hw, & ! max water depth for grounding + k1 , & ! 1st free parameter for seabed1 grounding parameterization + k2 , & ! second free parameter (N/m^3) for seabed1 grounding parametrization + alphab , & ! alphab=Cb factor in Lemieux et al 2015 + threshold_hw ! max water depth for grounding ! see keel data from Amundrud et al. 2004 (JGR) - u0 = 5e-5_dbl_kind ! residual velocity for seabed stress (m/s) !======================================================================= @@ -1204,10 +1201,10 @@ subroutine deformations (nx_block, ny_block, & vvel , & ! y-component of velocity (m/s) dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm , & ! 0.5*HTN - 1.5*HTN + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm , & ! 0.5*HTN - 1.5*HTS tarear ! 1/tarea real (kind=dbl_kind), dimension (nx_block,ny_block), & @@ -1305,10 +1302,10 @@ subroutine strain_rates (nx_block, ny_block, & vvel , & ! y-component of velocity (m/s) dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm ! 0.5*HTN - 1.5*HTN + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm ! 0.5*HTN - 1.5*HTS real (kind=dbl_kind), intent(out):: & ! at each corner : divune, divunw, divuse, divusw , & ! divergence diff --git a/cicecore/cicedynB/dynamics/ice_dyn_vp.F90 b/cicecore/cicedynB/dynamics/ice_dyn_vp.F90 index 457a73ade..860865dba 100644 --- a/cicecore/cicedynB/dynamics/ice_dyn_vp.F90 +++ b/cicecore/cicedynB/dynamics/ice_dyn_vp.F90 @@ -1149,12 +1149,12 @@ subroutine calc_zeta_dPr (nx_block, ny_block, & vvel , & ! y-component of velocity (m/s) dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - dxhy , & ! 0.5*(HTE - HTE) - dyhx , & ! 0.5*(HTN - HTN) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm , & ! 0.5*HTN - 1.5*HTN + dxhy , & ! 0.5*(HTE - HTW) + dyhx , & ! 0.5*(HTN - HTS) + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm , & ! 0.5*HTN - 1.5*HTS tinyarea ! min_strain_rate*tarea real (kind=dbl_kind), dimension(nx_block,ny_block,4), intent(out) :: & @@ -1335,10 +1335,10 @@ subroutine stress_vp (nx_block , ny_block , & vvel , & ! y-component of velocity (m/s) dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm ! 0.5*HTN - 1.5*HTN + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm ! 0.5*HTN - 1.5*HTS real (kind=dbl_kind), dimension(nx_block,ny_block,4), intent(in) :: & zetaD ! 2*zeta @@ -1555,12 +1555,12 @@ subroutine matvec (nx_block, ny_block, & real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - dxhy , & ! 0.5*(HTE - HTE) - dyhx , & ! 0.5*(HTN - HTN) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm ! 0.5*HTN - 1.5*HTN + dxhy , & ! 0.5*(HTE - HTW) + dyhx , & ! 0.5*(HTN - HTS) + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm ! 0.5*HTN - 1.5*HTS real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & uvel , & ! x-component of velocity (m/s) @@ -2004,12 +2004,12 @@ subroutine formDiag_step1 (nx_block, ny_block, & real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & dxt , & ! width of T-cell through the middle (m) dyt , & ! height of T-cell through the middle (m) - dxhy , & ! 0.5*(HTE - HTE) - dyhx , & ! 0.5*(HTN - HTN) - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm ! 0.5*HTN - 1.5*HTN + dxhy , & ! 0.5*(HTE - HTW) + dyhx , & ! 0.5*(HTN - HTS) + cyp , & ! 1.5*HTE - 0.5*HTW + cxp , & ! 1.5*HTN - 0.5*HTS + cym , & ! 0.5*HTE - 1.5*HTW + cxm ! 0.5*HTN - 1.5*HTS real (kind=dbl_kind), dimension(nx_block,ny_block,4), intent(in) :: & zetaD ! 2*zeta diff --git a/cicecore/cicedynB/dynamics/ice_transport_driver.F90 b/cicecore/cicedynB/dynamics/ice_transport_driver.F90 index e3da6390b..f2dff2367 100644 --- a/cicecore/cicedynB/dynamics/ice_transport_driver.F90 +++ b/cicecore/cicedynB/dynamics/ice_transport_driver.F90 @@ -85,7 +85,9 @@ subroutine init_transport integer (kind=int_kind) :: ntrcr, nt_Tsfc, nt_qice, nt_qsno, & nt_sice, nt_fbri, nt_iage, nt_FY, nt_alvl, nt_vlvl, & - nt_apnd, nt_hpnd, nt_ipnd, nt_fsd, nt_isosno, nt_isoice, nt_bgc_Nit, nt_bgc_S + nt_apnd, nt_hpnd, nt_ipnd, nt_fsd, & + nt_smice, nt_smliq, nt_rhos, nt_rsnw, & + nt_isosno, nt_isoice, nt_bgc_Nit, nt_bgc_S character(len=*), parameter :: subname = '(init_transport)' @@ -94,9 +96,12 @@ subroutine init_transport call icepack_query_tracer_sizes(ntrcr_out=ntrcr) call icepack_query_tracer_indices(nt_Tsfc_out=nt_Tsfc, nt_qice_out=nt_qice, & nt_qsno_out=nt_qsno, nt_sice_out=nt_sice, nt_fbri_out=nt_fbri, & - nt_iage_out=nt_iage, nt_FY_out=nt_FY, nt_alvl_out=nt_alvl, nt_fsd_out=nt_fsd, & - nt_vlvl_out=nt_vlvl, nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, & - nt_ipnd_out=nt_ipnd, nt_bgc_Nit_out=nt_bgc_Nit, nt_bgc_S_out=nt_bgc_S, & + nt_iage_out=nt_iage, nt_FY_out=nt_FY, nt_fsd_out=nt_fsd, & + nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl, & + nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, nt_ipnd_out=nt_ipnd, & + nt_smice_out=nt_smice, nt_smliq_out=nt_smliq, nt_rhos_out=nt_rhos, & + nt_rsnw_out=nt_rsnw, & + nt_bgc_Nit_out=nt_bgc_Nit, nt_bgc_S_out=nt_bgc_S, & nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & @@ -195,6 +200,18 @@ subroutine init_transport if (nt-k==nt_ipnd) & write(nu_diag,1000) 'nt_ipnd ',nt,depend(nt),tracer_type(nt),& has_dependents(nt) + if (nt-k==nt_smice) & + write(nu_diag,1000) 'nt_smice ',nt,depend(nt),tracer_type(nt),& + has_dependents(nt) + if (nt-k==nt_smliq) & + write(nu_diag,1000) 'nt_smliq ',nt,depend(nt),tracer_type(nt),& + has_dependents(nt) + if (nt-k==nt_rhos) & + write(nu_diag,1000) 'nt_rhos ',nt,depend(nt),tracer_type(nt),& + has_dependents(nt) + if (nt-k==nt_rsnw) & + write(nu_diag,1000) 'nt_rsnw ',nt,depend(nt),tracer_type(nt),& + has_dependents(nt) if (nt-k==nt_fsd) & write(nu_diag,1000) 'nt_fsd ',nt,depend(nt),tracer_type(nt),& has_dependents(nt) diff --git a/cicecore/cicedynB/general/ice_flux.F90 b/cicecore/cicedynB/general/ice_flux.F90 index bcc7305ff..23fb9df63 100644 --- a/cicecore/cicedynB/general/ice_flux.F90 +++ b/cicecore/cicedynB/general/ice_flux.F90 @@ -218,6 +218,7 @@ module ice_flux fresh , & ! fresh water flux to ocean (kg/m^2/s) fsalt , & ! salt flux to ocean (kg/m^2/s) fhocn , & ! net heat flux to ocean (W/m^2) + fsloss , & ! rate of snow loss to leads (kg/m^2/s) fswthru , & ! shortwave penetrating to ocean (W/m^2) fswthru_vdr , & ! vis dir shortwave penetrating to ocean (W/m^2) fswthru_vdf , & ! vis dif shortwave penetrating to ocean (W/m^2) @@ -294,6 +295,10 @@ module ice_flux fsensn, & ! category sensible heat flux flatn ! category latent heat flux + real (kind=dbl_kind), & + dimension (:,:,:,:), allocatable, public :: & + snwcnt ! counter for presence of snow + ! As above but these remain grid box mean values i.e. they are not ! divided by aice at end of ice_dynamics. These are used in ! CICE_IN_NEMO for coupling and also for generating @@ -448,6 +453,7 @@ subroutine alloc_flux fresh (nx_block,ny_block,max_blocks), & ! fresh water flux to ocean (kg/m^2/s) fsalt (nx_block,ny_block,max_blocks), & ! salt flux to ocean (kg/m^2/s) fhocn (nx_block,ny_block,max_blocks), & ! net heat flux to ocean (W/m^2) + fsloss (nx_block,ny_block,max_blocks), & ! rate of snow loss to leads (kg/m^2/s) fswthru (nx_block,ny_block,max_blocks), & ! shortwave penetrating to ocean (W/m^2) fswthru_vdr (nx_block,ny_block,max_blocks), & ! vis dir shortwave penetrating to ocean (W/m^2) fswthru_vdf (nx_block,ny_block,max_blocks), & ! vis dif shortwave penetrating to ocean (W/m^2) @@ -525,6 +531,7 @@ subroutine alloc_flux fsensn (nx_block,ny_block,ncat,max_blocks), & ! category sensible heat flux flatn (nx_block,ny_block,ncat,max_blocks), & ! category latent heat flux albcnt (nx_block,ny_block,max_blocks,max_nstrm), & ! counter for zenith angle + snwcnt (nx_block,ny_block,max_blocks,max_nstrm), & ! counter for snow salinz (nx_block,ny_block,nilyr+1,max_blocks), & ! initial salinity profile (ppt) Tmltz (nx_block,ny_block,nilyr+1,max_blocks), & ! initial melting temperature (^oC) stat=ierr) diff --git a/cicecore/cicedynB/general/ice_forcing.F90 b/cicecore/cicedynB/general/ice_forcing.F90 index a71e6dd17..84bf1d461 100755 --- a/cicecore/cicedynB/general/ice_forcing.F90 +++ b/cicecore/cicedynB/general/ice_forcing.F90 @@ -41,7 +41,7 @@ module ice_forcing field_type_vector, field_loc_NEcorner use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted use icepack_intfc, only: icepack_sea_freezing_temperature - use icepack_intfc, only: icepack_init_wave + use icepack_intfc, only: icepack_init_wave, icepack_init_parameters use icepack_intfc, only: icepack_query_tracer_indices, icepack_query_parameters implicit none @@ -50,7 +50,8 @@ module ice_forcing get_forcing_atmo, get_forcing_ocn, get_wave_spec, & read_clim_data, read_clim_data_nc, & interpolate_data, interp_coeff_monthly, & - read_data_nc_point, interp_coeff + read_data_nc_point, interp_coeff, & + init_snowtable integer (kind=int_kind), public :: & ycycle , & ! number of years in forcing cycle, set by namelist @@ -166,6 +167,16 @@ module ice_forcing integer (kind=int_kind), public :: & Njday_atm ! Number of atm forcing timesteps + character (len=char_len_long), public :: & + snw_filename ! filename for snow lookup table + + character (char_len), public :: & + snw_rhos_fname , & ! snow table 1d rhos field name + snw_Tgrd_fname , & ! snow table 1d Tgrd field name + snw_T_fname , & ! snow table 1d T field name + snw_tau_fname , & ! snow table 3d tau field name + snw_kappa_fname, & ! snow table 3d kappa field name + snw_drdt0_fname ! snow table 3d drdt0 field name ! PRIVATE: @@ -5398,7 +5409,199 @@ end subroutine get_wave_spec !======================================================================= - end module ice_forcing +! initial snow aging lookup table +! +! Dry snow metamorphism table +! snicar_drdt_bst_fit_60_c070416.nc +! Flanner (file metadata units mislabelled) +! drdsdt0 (10^-6 m/hr) tau (10^-6 m) +! + subroutine init_snowtable + + use ice_broadcast, only: broadcast_array, broadcast_scalar + integer (kind=int_kind) :: & + idx_T_max , & ! Table dimensions + idx_rhos_max, & + idx_Tgrd_max + real (kind=dbl_kind), allocatable :: & + snowage_rhos (:), & + snowage_Tgrd (:), & + snowage_T (:), & + snowage_tau (:,:,:), & + snowage_kappa(:,:,:), & + snowage_drdt0(:,:,:) + + ! local variables + + logical (kind=log_kind) :: diag = .false. + + integer (kind=int_kind) :: & + fid ! file id for netCDF file + + character (char_len) :: & + snw_aging_table, & ! aging table setting + fieldname ! field name in netcdf file + + integer (kind=int_kind) :: & + j, k ! indices + + character(len=*), parameter :: subname = '(init_snowtable)' + + !----------------------------------------------------------------- + ! read table of snow aging parameters + !----------------------------------------------------------------- + + call icepack_query_parameters(snw_aging_table_out=snw_aging_table, & + isnw_rhos_out=idx_rhos_max, isnw_Tgrd_out=idx_Tgrd_max, isnw_T_out=idx_T_max) + + if (my_task == master_task) then + write (nu_diag,*) ' ' + write (nu_diag,*) 'Snow aging file:', trim(snw_filename) + endif + + if (snw_aging_table == 'snicar') then + ! just read the 3d data and pass it in + + call ice_open_nc(snw_filename,fid) + + allocate(snowage_tau (idx_rhos_max, idx_Tgrd_max, idx_T_max)) + allocate(snowage_kappa(idx_rhos_max, idx_Tgrd_max, idx_T_max)) + allocate(snowage_drdt0(idx_rhos_max, idx_Tgrd_max, idx_T_max)) + + fieldname = trim(snw_tau_fname) + call ice_read_nc(fid,fieldname,snowage_tau, diag, & + idx_rhos_max,idx_Tgrd_max,idx_T_max) + fieldname = trim(snw_kappa_fname) + call ice_read_nc(fid,fieldname,snowage_kappa,diag, & + idx_rhos_max,idx_Tgrd_max,idx_T_max) + fieldname = trim(snw_drdt0_fname) + call ice_read_nc(fid,fieldname,snowage_drdt0,diag, & + idx_rhos_max,idx_Tgrd_max,idx_T_max) + + call ice_close_nc(fid) + + call broadcast_array(snowage_tau , master_task) + call broadcast_array(snowage_kappa, master_task) + call broadcast_array(snowage_drdt0, master_task) + + if (my_task == master_task) then + write(nu_diag,*) subname,' ' + write(nu_diag,*) subname,' Successfully read snow aging properties:' + write(nu_diag,*) subname,' snw_aging_table = ',trim(snw_aging_table) + write(nu_diag,*) subname,' idx_rhos_max = ',idx_rhos_max + write(nu_diag,*) subname,' idx_Tgrd_max = ',idx_Tgrd_max + write(nu_diag,*) subname,' idx_T_max = ',idx_T_max + write(nu_diag,*) subname,' Data at rhos, Tgrd, T at first index ' + write(nu_diag,*) subname,' snoage_tau (1,1,1) = ',snowage_tau (1,1,1) + write(nu_diag,*) subname,' snoage_kappa (1,1,1) = ',snowage_kappa(1,1,1) + write(nu_diag,*) subname,' snoage_drdt0 (1,1,1) = ',snowage_drdt0(1,1,1) + write(nu_diag,*) subname,' Data at rhos, Tgrd, T at max index' + write(nu_diag,*) subname,' snoage_tau (max,max,max) = ',snowage_tau (idx_rhos_max, idx_Tgrd_max, idx_T_max) + write(nu_diag,*) subname,' snoage_kappa (max,max,max) = ',snowage_kappa(idx_rhos_max, idx_Tgrd_max, idx_T_max) + write(nu_diag,*) subname,' snoage_drdt0 (max,max,max) = ',snowage_drdt0(idx_rhos_max, idx_Tgrd_max, idx_T_max) + endif + + call icepack_init_parameters( & + snowage_tau_in = snowage_tau, & + snowage_kappa_in = snowage_kappa, & + snowage_drdt0_in = snowage_drdt0 ) + + deallocate(snowage_tau) + deallocate(snowage_kappa) + deallocate(snowage_drdt0) + + else + ! read everything and pass it in + + call ice_open_nc(snw_filename,fid) + + fieldname = trim(snw_rhos_fname) + call ice_get_ncvarsize(fid,fieldname,idx_rhos_max) + fieldname = trim(snw_Tgrd_fname) + call ice_get_ncvarsize(fid,fieldname,idx_Tgrd_max) + fieldname = trim(snw_T_fname) + call ice_get_ncvarsize(fid,fieldname,idx_T_max) + + call broadcast_scalar(idx_rhos_max, master_task) + call broadcast_scalar(idx_Tgrd_max, master_task) + call broadcast_scalar(idx_T_max , master_task) + + allocate(snowage_rhos (idx_rhos_max)) + allocate(snowage_Tgrd (idx_Tgrd_max)) + allocate(snowage_T (idx_T_max)) + allocate(snowage_tau (idx_rhos_max, idx_Tgrd_max, idx_T_max)) + allocate(snowage_kappa(idx_rhos_max, idx_Tgrd_max, idx_T_max)) + allocate(snowage_drdt0(idx_rhos_max, idx_Tgrd_max, idx_T_max)) + + fieldname = trim(snw_rhos_fname) + call ice_read_nc(fid,fieldname,snowage_rhos, diag, & + idx_rhos_max) + fieldname = trim(snw_Tgrd_fname) + call ice_read_nc(fid,fieldname,snowage_Tgrd, diag, & + idx_Tgrd_max) + fieldname = trim(snw_T_fname) + call ice_read_nc(fid,fieldname,snowage_T, diag, & + idx_T_max) + + fieldname = trim(snw_tau_fname) + call ice_read_nc(fid,fieldname,snowage_tau, diag, & + idx_rhos_max,idx_Tgrd_max,idx_T_max) + fieldname = trim(snw_kappa_fname) + call ice_read_nc(fid,fieldname,snowage_kappa,diag, & + idx_rhos_max,idx_Tgrd_max,idx_T_max) + fieldname = trim(snw_drdt0_fname) + call ice_read_nc(fid,fieldname,snowage_drdt0,diag, & + idx_rhos_max,idx_Tgrd_max,idx_T_max) + + call ice_close_nc(fid) + + call broadcast_array(snowage_rhos , master_task) + call broadcast_array(snowage_Tgrd , master_task) + call broadcast_array(snowage_T , master_task) + call broadcast_array(snowage_tau , master_task) + call broadcast_array(snowage_kappa, master_task) + call broadcast_array(snowage_drdt0, master_task) + + if (my_task == master_task) then + write(nu_diag,*) subname,' ' + write(nu_diag,*) subname,' Successfully read snow aging properties:' + write(nu_diag,*) subname,' idx_rhos_max = ',idx_rhos_max + write(nu_diag,*) subname,' idx_Tgrd_max = ',idx_Tgrd_max + write(nu_diag,*) subname,' idx_T_max = ',idx_T_max + write(nu_diag,*) subname,' Data at rhos, Tgrd, T = ',snowage_rhos(1),snowage_Tgrd(1),snowage_T(1) + write(nu_diag,*) subname,' snoage_tau (1,1,1) = ',snowage_tau (1,1,1) + write(nu_diag,*) subname,' snoage_kappa (1,1,1) = ',snowage_kappa(1,1,1) + write(nu_diag,*) subname,' snoage_drdt0 (1,1,1) = ',snowage_drdt0(1,1,1) + write(nu_diag,*) subname,' Data at rhos, Tgrd, T = ',snowage_rhos(idx_rhos_max),snowage_Tgrd(idx_Tgrd_max),snowage_T(idx_T_max) + write(nu_diag,*) subname,' snoage_tau (max,max,max) = ',snowage_tau (idx_rhos_max, idx_Tgrd_max, idx_T_max) + write(nu_diag,*) subname,' snoage_kappa (max,max,max) = ',snowage_kappa(idx_rhos_max, idx_Tgrd_max, idx_T_max) + write(nu_diag,*) subname,' snoage_drdt0 (max,max,max) = ',snowage_drdt0(idx_rhos_max, idx_Tgrd_max, idx_T_max) + endif + + call icepack_init_parameters( & + isnw_t_in = idx_T_max, & + isnw_Tgrd_in = idx_Tgrd_max, & + isnw_rhos_in = idx_rhos_max, & + snowage_rhos_in = snowage_rhos, & + snowage_Tgrd_in = snowage_Tgrd, & + snowage_T_in = snowage_T, & + snowage_tau_in = snowage_tau, & + snowage_kappa_in = snowage_kappa, & + snowage_drdt0_in = snowage_drdt0 ) + + deallocate(snowage_rhos) + deallocate(snowage_Tgrd) + deallocate(snowage_T) + deallocate(snowage_tau) + deallocate(snowage_kappa) + deallocate(snowage_drdt0) + + endif + + end subroutine init_snowtable !======================================================================= + end module ice_forcing + +!======================================================================= diff --git a/cicecore/cicedynB/general/ice_init.F90 b/cicecore/cicedynB/general/ice_init.F90 index b896c3bb9..3d102217a 100644 --- a/cicecore/cicedynB/general/ice_init.F90 +++ b/cicecore/cicedynB/general/ice_init.F90 @@ -74,7 +74,7 @@ subroutine input_data use ice_arrays_column, only: oceanmixed_ice use ice_restart_column, only: restart_age, restart_FY, restart_lvl, & restart_pond_cesm, restart_pond_lvl, restart_pond_topo, restart_aero, & - restart_fsd, restart_iso + restart_fsd, restart_iso, restart_snow use ice_restart_shared, only: & restart, restart_ext, restart_coszen, restart_dir, restart_file, pointer_file, & runid, runtype, use_restart_time, restart_format, lcdf64 @@ -91,15 +91,19 @@ subroutine input_data bgc_data_type, & ocn_data_type, ocn_data_dir, wave_spec_file, & oceanmixed_file, restore_ocn, trestore, & - ice_data_type + ice_data_type, & + snw_filename, & + snw_tau_fname, snw_kappa_fname, snw_drdt0_fname, & + snw_rhos_fname, snw_Tgrd_fname, snw_T_fname use ice_arrays_column, only: bgc_data_dir, fe_data_type use ice_grid, only: grid_file, gridcpl_file, kmt_file, & bathymetry_file, use_bathymetry, & bathymetry_format, & grid_type, grid_format, & - dxrect, dyrect + dxrect, dyrect, & + pgl_global_ext use ice_dyn_shared, only: ndte, kdyn, revised_evp, yield_curve, & - kevp_kernel, & + evp_algorithm, & seabed_stress, seabed_stress_method, & k1, k2, alphab, threshold_hw, & Ktens, e_ratio, coriolis, ssh_stress, & @@ -128,19 +132,21 @@ subroutine input_data mu_rdg, hs0, dpscale, rfracmin, rfracmax, pndaspect, hs1, hp1, & a_rapid_mode, Rac_rapid_mode, aspect_rapid_mode, dSdt_slow_mode, & phi_c_slow_mode, phi_i_mushy, kalg, atmiter_conv, Pstar, Cstar, & - sw_frac, sw_dtemp, floediam, hfrazilmin, iceruf, iceruf_ocn + sw_frac, sw_dtemp, floediam, hfrazilmin, iceruf, iceruf_ocn, & + rsnw_fall, rsnw_tmax, rhosnew, rhosmin, rhosmax, & + windmin, drhosdwind, snwlvlfac integer (kind=int_kind) :: ktherm, kstrength, krdg_partic, krdg_redist, natmiter, & kitd, kcatbound, ktransport character (len=char_len) :: shortwave, albedo_type, conduct, fbot_xfer_type, & - tfrz_option, frzpnd, atmbndy, wave_spec_type + tfrz_option, frzpnd, atmbndy, wave_spec_type, snwredist, snw_aging_table logical (kind=log_kind) :: calc_Tsfc, formdrag, highfreq, calc_strair, wave_spec, & - sw_redist, calc_dragio + sw_redist, calc_dragio, use_smliq_pnd, snwgrain logical (kind=log_kind) :: tr_iage, tr_FY, tr_lvl, tr_pond - logical (kind=log_kind) :: tr_iso, tr_aero, tr_fsd + logical (kind=log_kind) :: tr_iso, tr_aero, tr_fsd, tr_snow logical (kind=log_kind) :: tr_pond_cesm, tr_pond_lvl, tr_pond_topo integer (kind=int_kind) :: numin, numax ! unit number limits @@ -187,6 +193,7 @@ subroutine input_data tr_pond_cesm, restart_pond_cesm, & tr_pond_lvl, restart_pond_lvl, & tr_pond_topo, restart_pond_topo, & + tr_snow, restart_snow, & tr_iso, restart_iso, & tr_aero, restart_aero, & tr_fsd, restart_fsd, & @@ -201,7 +208,7 @@ subroutine input_data namelist /dynamics_nml/ & kdyn, ndte, revised_evp, yield_curve, & - kevp_kernel, & + evp_algorithm, & brlx, arlx, ssh_stress, & advection, coriolis, kridge, ktransport, & kstrength, krdg_partic, krdg_redist, mu_rdg, & @@ -227,6 +234,13 @@ subroutine input_data rfracmin, rfracmax, pndaspect, hs1, & hp1 + namelist /snow_nml/ & + snwredist, snwgrain, rsnw_fall, rsnw_tmax, & + rhosnew, rhosmin, rhosmax, snwlvlfac, & + windmin, drhosdwind, use_smliq_pnd, snw_aging_table,& + snw_filename, snw_rhos_fname, snw_Tgrd_fname,snw_T_fname, & + snw_tau_fname, snw_kappa_fname, snw_drdt0_fname + namelist /forcing_nml/ & formdrag, atmbndy, calc_strair, calc_Tsfc, & highfreq, natmiter, atmiter_conv, calc_dragio, & @@ -329,7 +343,8 @@ subroutine input_data kdyn = 1 ! type of dynamics (-1, 0 = off, 1 = evp, 2 = eap, 3 = vp) ndtd = 1 ! dynamic time steps per thermodynamic time step ndte = 120 ! subcycles per dynamics timestep: ndte=dt_dyn/dte - kevp_kernel = 0 ! EVP kernel (0 = 2D, >0: 1D. Only ver. 2 is implemented yet) + evp_algorithm = 'standard_2d' ! EVP kernel (=standard_2d: standard cice evp; =shared_mem_1d: 1d shared memory and no mpi. if more mpi processors then executed on master + pgl_global_ext = .false. ! if true, init primary grid lengths (global ext.) brlx = 300.0_dbl_kind ! revised_evp values. Otherwise overwritten in ice_dyn_shared arlx = 300.0_dbl_kind ! revised_evp values. Otherwise overwritten in ice_dyn_shared revised_evp = .false. ! if true, use revised procedure for evp dynamics @@ -409,6 +424,25 @@ subroutine input_data rfracmin = 0.15_dbl_kind ! minimum retained fraction of meltwater rfracmax = 0.85_dbl_kind ! maximum retained fraction of meltwater pndaspect = 0.8_dbl_kind ! ratio of pond depth to area fraction + snwredist = 'none' ! type of snow redistribution + snw_aging_table = 'test' ! snow aging lookup table + snw_filename = 'unknown' ! snowtable filename + snw_tau_fname = 'unknown' ! snowtable file tau fieldname + snw_kappa_fname = 'unknown' ! snowtable file kappa fieldname + snw_drdt0_fname = 'unknown' ! snowtable file drdt0 fieldname + snw_rhos_fname = 'unknown' ! snowtable file rhos fieldname + snw_Tgrd_fname = 'unknown' ! snowtable file Tgrd fieldname + snw_T_fname = 'unknown' ! snowtable file T fieldname + snwgrain = .false. ! snow metamorphosis + use_smliq_pnd = .false. ! use liquid in snow for ponds + rsnw_fall = 100.0_dbl_kind ! radius of new snow (10^-6 m) ! advanced snow physics: 54.526 x 10^-6 m + rsnw_tmax = 1500.0_dbl_kind ! maximum snow radius (10^-6 m) + rhosnew = 100.0_dbl_kind ! new snow density (kg/m^3) + rhosmin = 100.0_dbl_kind ! minimum snow density (kg/m^3) + rhosmax = 450.0_dbl_kind ! maximum snow density (kg/m^3) + windmin = 10.0_dbl_kind ! minimum wind speed to compact snow (m/s) + drhosdwind= 27.3_dbl_kind ! wind compaction factor for snow (kg s/m^4) + snwlvlfac = 0.3_dbl_kind ! fractional increase in snow depth for bulk redistribution albicev = 0.78_dbl_kind ! visible ice albedo for h > ahmax albicei = 0.36_dbl_kind ! near-ir ice albedo for h > ahmax albsnowv = 0.98_dbl_kind ! cold snow albedo, visible @@ -472,6 +506,8 @@ subroutine input_data restart_pond_lvl = .false. ! melt ponds restart tr_pond_topo = .false. ! explicit melt ponds (topographic) restart_pond_topo = .false. ! melt ponds restart + tr_snow = .false. ! advanced snow physics + restart_snow = .false. ! advanced snow physics restart tr_iso = .false. ! isotopes restart_iso = .false. ! isotopes restart tr_aero = .false. ! aerosols @@ -545,6 +581,9 @@ subroutine input_data print*,'Reading ponds_nml' read(nu_nml, nml=ponds_nml,iostat=nml_error) if (nml_error /= 0) exit + print*,'Reading snow_nml' + read(nu_nml, nml=snow_nml,iostat=nml_error) + if (nml_error /= 0) exit print*,'Reading forcing_nml' read(nu_nml, nml=forcing_nml,iostat=nml_error) if (nml_error /= 0) exit @@ -669,7 +708,8 @@ subroutine input_data call broadcast_scalar(kdyn, master_task) call broadcast_scalar(ndtd, master_task) call broadcast_scalar(ndte, master_task) - call broadcast_scalar(kevp_kernel, master_task) + call broadcast_scalar(evp_algorithm, master_task) + call broadcast_scalar(pgl_global_ext, master_task) call broadcast_scalar(brlx, master_task) call broadcast_scalar(arlx, master_task) call broadcast_scalar(revised_evp, master_task) @@ -734,6 +774,25 @@ subroutine input_data call broadcast_scalar(rfracmin, master_task) call broadcast_scalar(rfracmax, master_task) call broadcast_scalar(pndaspect, master_task) + call broadcast_scalar(snwredist, master_task) + call broadcast_scalar(snw_aging_table, master_task) + call broadcast_scalar(snw_filename, master_task) + call broadcast_scalar(snw_tau_fname, master_task) + call broadcast_scalar(snw_kappa_fname, master_task) + call broadcast_scalar(snw_drdt0_fname, master_task) + call broadcast_scalar(snw_rhos_fname, master_task) + call broadcast_scalar(snw_Tgrd_fname, master_task) + call broadcast_scalar(snw_T_fname, master_task) + call broadcast_scalar(snwgrain, master_task) + call broadcast_scalar(use_smliq_pnd, master_task) + call broadcast_scalar(rsnw_fall, master_task) + call broadcast_scalar(rsnw_tmax, master_task) + call broadcast_scalar(rhosnew, master_task) + call broadcast_scalar(rhosmin, master_task) + call broadcast_scalar(rhosmax, master_task) + call broadcast_scalar(windmin, master_task) + call broadcast_scalar(drhosdwind, master_task) + call broadcast_scalar(snwlvlfac, master_task) call broadcast_scalar(albicev, master_task) call broadcast_scalar(albicei, master_task) call broadcast_scalar(albsnowv, master_task) @@ -797,6 +856,8 @@ subroutine input_data call broadcast_scalar(restart_pond_lvl, master_task) call broadcast_scalar(tr_pond_topo, master_task) call broadcast_scalar(restart_pond_topo, master_task) + call broadcast_scalar(tr_snow, master_task) + call broadcast_scalar(restart_snow, master_task) call broadcast_scalar(tr_iso, master_task) call broadcast_scalar(restart_iso, master_task) call broadcast_scalar(tr_aero, master_task) @@ -877,6 +938,7 @@ subroutine input_data restart_pond_cesm = .false. restart_pond_lvl = .false. restart_pond_topo = .false. + restart_snow = .false. ! tcraig, OK to leave as true, needed for boxrestore case ! restart_ext = .false. else @@ -985,6 +1047,59 @@ subroutine input_data abort_list = trim(abort_list)//":8" endif + if (snwredist(1:4) /= 'none' .and. .not. tr_snow) then + if (my_task == master_task) then + write (nu_diag,*) 'ERROR: snwredist on but tr_snow=F' + write (nu_diag,*) 'ERROR: Use tr_snow=T for snow redistribution' + endif + abort_list = trim(abort_list)//":37" + endif + if (snwredist(1:4) == 'bulk' .and. .not. tr_lvl) then + if (my_task == master_task) then + write (nu_diag,*) 'ERROR: snwredist=bulk but tr_lvl=F' + write (nu_diag,*) 'ERROR: Use tr_lvl=T for snow redistribution' + endif + abort_list = trim(abort_list)//":38" + endif + if (snwredist(1:6) == 'ITDrdg' .and. .not. tr_lvl) then + if (my_task == master_task) then + write (nu_diag,*) 'ERROR: snwredist=ITDrdg but tr_lvl=F' + write (nu_diag,*) 'ERROR: Use tr_lvl=T for snow redistribution' + endif + abort_list = trim(abort_list)//":39" + endif + if (use_smliq_pnd .and. .not. snwgrain) then + if (my_task == master_task) then + write (nu_diag,*) 'ERROR: use_smliq_pnd = T but' + write (nu_diag,*) 'ERROR: snow metamorphosis not used' + write (nu_diag,*) 'ERROR: Use snwgrain=T with smliq for ponds' + endif + abort_list = trim(abort_list)//":40" + endif + if (use_smliq_pnd .and. .not. tr_snow) then + if (my_task == master_task) then + write (nu_diag,*) 'ERROR: use_smliq_pnd = T but' + write (nu_diag,*) 'ERROR: snow tracers are not active' + write (nu_diag,*) 'ERROR: Use tr_snow=T with smliq for ponds' + endif + abort_list = trim(abort_list)//":41" + endif + if (snwgrain .and. .not. tr_snow) then + if (my_task == master_task) then + write (nu_diag,*) 'ERROR: snwgrain=T but tr_snow=F' + write (nu_diag,*) 'ERROR: Use tr_snow=T for snow metamorphosis' + endif + abort_list = trim(abort_list)//":42" + endif + if (trim(snw_aging_table) /= 'test' .and. & + trim(snw_aging_table) /= 'snicar' .and. & + trim(snw_aging_table) /= 'file') then + if (my_task == master_task) then + write (nu_diag,*) 'ERROR: unknown snw_aging_table = '//trim(snw_aging_table) + endif + abort_list = trim(abort_list)//":43" + endif + if (tr_iso .and. n_iso==0) then if (my_task == master_task) then write(nu_diag,*) subname//' ERROR: isotopes activated but' @@ -1014,7 +1129,7 @@ subroutine input_data if (my_task == master_task) then write(nu_diag,*) subname//' ERROR: nilyr < 1' endif - abort_list = trim(abort_list)//":33" + abort_list = trim(abort_list)//":2" endif if (nslyr < 1) then @@ -1048,6 +1163,13 @@ subroutine input_data abort_list = trim(abort_list)//":10" endif + if (trim(shortwave) /= 'dEdd' .and. snwgrain) then + if (my_task == master_task) then + write (nu_diag,*) 'WARNING: snow grain radius activated but' + write (nu_diag,*) 'WARNING: dEdd shortwave is not.' + endif + endif + if ((rfracmin < -puny .or. rfracmin > c1+puny) .or. & (rfracmax < -puny .or. rfracmax > c1+puny) .or. & (rfracmin > rfracmax)) then @@ -1293,16 +1415,16 @@ subroutine input_data tmpstr2 = ' : revised EVP formulation not used' endif write(nu_diag,1010) ' revised_evp = ', revised_evp,trim(tmpstr2) - - if (kevp_kernel == 0) then - tmpstr2 = ' : original EVP solver' - elseif (kevp_kernel == 2 .or. kevp_kernel == 102) then - tmpstr2 = ' : vectorized EVP solver' + + if (evp_algorithm == 'standard_2d') then + tmpstr2 = ' : standard 2d EVP solver' + elseif (evp_algorithm == 'shared_mem_1d') then + tmpstr2 = ' : vectorized 1d EVP solver' + pgl_global_ext = .true. else tmpstr2 = ' : unknown value' endif - write(nu_diag,1020) ' kevp_kernel = ', kevp_kernel,trim(tmpstr2) - + write(nu_diag,1031) ' evp_algorithm = ', trim(evp_algorithm),trim(tmpstr2) write(nu_diag,1020) ' ndtd = ', ndtd, ' : number of dynamics/advection/ridging/steps per thermo timestep' write(nu_diag,1020) ' ndte = ', ndte, ' : number of EVP or EAP subcycles' endif @@ -1652,6 +1774,78 @@ subroutine input_data write(nu_diag,1002) ' rfracmin = ', rfracmin,' : minimum fraction of melt water added to ponds' write(nu_diag,1002) ' rfracmax = ', rfracmax,' : maximum fraction of melt water added to ponds' + write(nu_diag,*) ' ' + write(nu_diag,*) ' Snow redistribution/metamorphism tracers' + write(nu_diag,*) '-----------------------------------------' + if (tr_snow) then + write(nu_diag,1010) ' tr_snow = ', tr_snow, & + ' : advanced snow physics' + if (snwredist(1:4) == 'none') then + write(nu_diag,1030) ' snwredist = ', trim(snwredist), & + ' : Snow redistribution scheme turned off' + else + if (snwredist(1:4) == 'bulk') then + write(nu_diag,1030) ' snwredist = ', trim(snwredist), & + ' : Using bulk snow redistribution scheme' + elseif (snwredist(1:6) == 'ITDrdg') then + write(nu_diag,1030) ' snwredist = ', trim(snwredist), & + ' : Using ridging based snow redistribution scheme' + write(nu_diag,1002) ' rhosnew = ', rhosnew, & + ' : new snow density (kg/m^3)' + write(nu_diag,1002) ' rhosmin = ', rhosmin, & + ' : minimum snow density (kg/m^3)' + write(nu_diag,1002) ' rhosmax = ', rhosmax, & + ' : maximum snow density (kg/m^3)' + write(nu_diag,1002) ' windmin = ', windmin, & + ' : minimum wind speed to compact snow (m/s)' + write(nu_diag,1002) ' drhosdwind = ', drhosdwind, & + ' : wind compaction factor (kg s/m^4)' + endif + write(nu_diag,1002) ' snwlvlfac = ', snwlvlfac, & + ' : fractional increase in snow depth for redistribution on ridges' + endif + if (.not. snwgrain) then + write(nu_diag,1010) ' snwgrain = ', snwgrain, & + ' : Snow metamorphosis turned off' + else + write(nu_diag,1010) ' snwgrain = ', snwgrain, & + ' : Using snow metamorphosis scheme' + write(nu_diag,1002) ' rsnw_tmax = ', rsnw_tmax, & + ' : maximum snow radius (10^-6 m)' + endif + write(nu_diag,1002) ' rsnw_fall = ', rsnw_fall, & + ' : radius of new snow (10^-6 m)' + if (snwgrain) then + if (use_smliq_pnd) then + tmpstr2 = ' : Using liquid water in snow for melt ponds' + else + tmpstr2 = ' : NOT using liquid water in snow for melt ponds' + endif + write(nu_diag,1010) ' use_smliq_pnd = ', use_smliq_pnd, trim(tmpstr2) + if (snw_aging_table == 'test') then + tmpstr2 = ' : Using 5x5x1 test matrix of internallly defined snow aging parameters' + write(nu_diag,1030) ' snw_aging_table = ', trim(snw_aging_table),trim(tmpstr2) + elseif (snw_aging_table == 'snicar') then + tmpstr2 = ' : Reading 3D snow aging parameters from SNICAR file' + write(nu_diag,1030) ' snw_aging_table = ', trim(snw_aging_table),trim(tmpstr2) + write(nu_diag,1031) ' snw_filename = ',trim(snw_filename) + write(nu_diag,1031) ' snw_tau_fname = ',trim(snw_tau_fname) + write(nu_diag,1031) ' snw_kappa_fname = ',trim(snw_kappa_fname) + write(nu_diag,1031) ' snw_drdt0_fname = ',trim(snw_drdt0_fname) + elseif (snw_aging_table == 'file') then + tmpstr2 = ' : Reading 1D and 3D snow aging dimensions and parameters from external file' + write(nu_diag,1030) ' snw_aging_table = ', trim(snw_aging_table),trim(tmpstr2) + write(nu_diag,1031) ' snw_filename = ',trim(snw_filename) + write(nu_diag,1031) ' snw_rhos_fname = ',trim(snw_rhos_fname) + write(nu_diag,1031) ' snw_Tgrd_fname = ',trim(snw_Tgrd_fname) + write(nu_diag,1031) ' snw_T_fname = ',trim(snw_T_fname) + write(nu_diag,1031) ' snw_tau_fname = ',trim(snw_tau_fname) + write(nu_diag,1031) ' snw_kappa_fname = ',trim(snw_kappa_fname) + write(nu_diag,1031) ' snw_drdt0_fname = ',trim(snw_drdt0_fname) + endif + endif + endif + write(nu_diag,*) ' ' write(nu_diag,*) ' Primary state variables, tracers' write(nu_diag,*) ' (excluding biogeochemistry)' @@ -1665,6 +1859,7 @@ subroutine input_data if (tr_pond_lvl) write(nu_diag,1010) ' tr_pond_lvl = ', tr_pond_lvl,' : level-ice pond formulation' if (tr_pond_topo) write(nu_diag,1010) ' tr_pond_topo = ', tr_pond_topo,' : topo pond formulation' if (tr_pond_cesm) write(nu_diag,1010) ' tr_pond_cesm = ', tr_pond_cesm,' : CESM pond formulation' + if (tr_snow) write(nu_diag,1010) ' tr_snow = ', tr_snow,' : advanced snow physics' if (tr_iage) write(nu_diag,1010) ' tr_iage = ', tr_iage,' : chronological ice age' if (tr_FY) write(nu_diag,1010) ' tr_FY = ', tr_FY,' : first-year ice area' if (tr_iso) write(nu_diag,1010) ' tr_iso = ', tr_iso,' : diagnostic isotope tracers' @@ -1702,13 +1897,13 @@ subroutine input_data write(nu_diag,1023) ' histfreq_n = ', histfreq_n(:) write(nu_diag,1031) ' histfreq_base = ', trim(histfreq_base) write(nu_diag,1011) ' hist_avg = ', hist_avg - if (.not. hist_avg) write(nu_diag,1031) ' History data will be snapshots' + if (.not. hist_avg) write(nu_diag,1039) ' History data will be snapshots' write(nu_diag,1031) ' history_dir = ', trim(history_dir) write(nu_diag,1031) ' history_file = ', trim(history_file) write(nu_diag,1021) ' history_precision= ', history_precision write(nu_diag,1031) ' history_format = ', trim(history_format) if (write_ic) then - write(nu_diag,1031) ' Initial condition will be written in ', & + write(nu_diag,1039) ' Initial condition will be written in ', & trim(incond_dir) endif write(nu_diag,1031) ' dumpfreq = ', trim(dumpfreq) @@ -1786,6 +1981,7 @@ subroutine input_data write(nu_diag,1011) ' restart_pond_cesm= ', restart_pond_cesm write(nu_diag,1011) ' restart_pond_lvl = ', restart_pond_lvl write(nu_diag,1011) ' restart_pond_topo= ', restart_pond_topo + write(nu_diag,1011) ' restart_snow = ', restart_snow write(nu_diag,1011) ' restart_iso = ', restart_iso write(nu_diag,1011) ' restart_aero = ', restart_aero write(nu_diag,1011) ' restart_fsd = ', restart_fsd @@ -1815,19 +2011,11 @@ subroutine input_data abort_list = trim(abort_list)//":20" endif - ! check for valid kevp_kernel - ! tcraig, kevp_kernel=2 is not validated, do not allow use - ! use "102" to test "2" for now - if (kevp_kernel /= 0) then - if (kevp_kernel == 102) then - kevp_kernel = 2 - else - if (my_task == master_task) write(nu_diag,*) subname//' ERROR: kevp_kernel = ',kevp_kernel - if (kevp_kernel == 2) then - if (my_task == master_task) write(nu_diag,*) subname//' kevp_kernel=2 not validated, use kevp_kernel=102 for testing until it is validated' - endif - abort_list = trim(abort_list)//":21" - endif + if (kdyn == 1 .and. & + evp_algorithm /= 'standard_2d' .and. & + evp_algorithm /= 'shared_mem_1d') then + if (my_task == master_task) write(nu_diag,*) subname//' ERROR: unknown evp_algorithm=',trim(evp_algorithm) + abort_list = trim(abort_list)//":21" endif if (abort_list /= "") then @@ -1858,10 +2046,14 @@ subroutine input_data wave_spec_in=wave_spec, nfreq_in=nfreq, & tfrz_option_in=tfrz_option, kalg_in=kalg, fbot_xfer_type_in=fbot_xfer_type, & Pstar_in=Pstar, Cstar_in=Cstar, iceruf_in=iceruf, iceruf_ocn_in=iceruf_ocn, calc_dragio_in=calc_dragio, & + windmin_in=windmin, drhosdwind_in=drhosdwind, & + rsnw_fall_in=rsnw_fall, rsnw_tmax_in=rsnw_tmax, rhosnew_in=rhosnew, & + snwlvlfac_in=snwlvlfac, rhosmin_in=rhosmin, rhosmax_in=rhosmax, & + snwredist_in=snwredist, snwgrain_in=snwgrain, snw_aging_table_in=trim(snw_aging_table), & sw_redist_in=sw_redist, sw_frac_in=sw_frac, sw_dtemp_in=sw_dtemp) call icepack_init_tracer_flags(tr_iage_in=tr_iage, tr_FY_in=tr_FY, & tr_lvl_in=tr_lvl, tr_iso_in=tr_iso, tr_aero_in=tr_aero, & - tr_fsd_in=tr_fsd, tr_pond_in=tr_pond, & + tr_fsd_in=tr_fsd, tr_snow_in=tr_snow, tr_pond_in=tr_pond, & tr_pond_cesm_in=tr_pond_cesm, tr_pond_lvl_in=tr_pond_lvl, tr_pond_topo_in=tr_pond_topo) call icepack_init_tracer_sizes(ncat_in=ncat, nilyr_in=nilyr, nslyr_in=nslyr, nblyr_in=nblyr, & nfsd_in=nfsd, n_algae_in=n_algae, n_iso_in=n_iso, n_aero_in=n_aero, & @@ -1883,6 +2075,7 @@ subroutine input_data 1030 format (a20,a14,1x,a) ! character 1031 format (a20,1x,a,a) 1033 format (a20,1x,6a6) + 1039 format (a,1x,a,1x,a,1x,a) end subroutine input_data @@ -1918,10 +2111,12 @@ subroutine init_state heat_capacity ! from icepack integer (kind=int_kind) :: ntrcr - logical (kind=log_kind) :: tr_iage, tr_FY, tr_lvl, tr_iso, tr_aero, tr_fsd + logical (kind=log_kind) :: tr_iage, tr_FY, tr_lvl, tr_iso, tr_aero logical (kind=log_kind) :: tr_pond_cesm, tr_pond_lvl, tr_pond_topo + logical (kind=log_kind) :: tr_snow, tr_fsd integer (kind=int_kind) :: nt_Tsfc, nt_sice, nt_qice, nt_qsno, nt_iage, nt_FY integer (kind=int_kind) :: nt_alvl, nt_vlvl, nt_apnd, nt_hpnd, nt_ipnd + integer (kind=int_kind) :: nt_smice, nt_smliq, nt_rhos, nt_rsnw integer (kind=int_kind) :: nt_isosno, nt_isoice, nt_aero, nt_fsd type (block) :: & @@ -1934,12 +2129,15 @@ subroutine init_state call icepack_query_parameters(heat_capacity_out=heat_capacity) call icepack_query_tracer_sizes(ntrcr_out=ntrcr) call icepack_query_tracer_flags(tr_iage_out=tr_iage, tr_FY_out=tr_FY, & - tr_lvl_out=tr_lvl, tr_iso_out=tr_iso, tr_aero_out=tr_aero, tr_fsd_out=tr_fsd, & - tr_pond_cesm_out=tr_pond_cesm, tr_pond_lvl_out=tr_pond_lvl, tr_pond_topo_out=tr_pond_topo) + tr_lvl_out=tr_lvl, tr_iso_out=tr_iso, tr_aero_out=tr_aero, & + tr_pond_cesm_out=tr_pond_cesm, tr_pond_lvl_out=tr_pond_lvl, tr_pond_topo_out=tr_pond_topo, & + tr_snow_out=tr_snow, tr_fsd_out=tr_fsd) call icepack_query_tracer_indices(nt_Tsfc_out=nt_Tsfc, nt_sice_out=nt_sice, & nt_qice_out=nt_qice, nt_qsno_out=nt_qsno, nt_iage_out=nt_iage, nt_fy_out=nt_fy, & nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl, nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, & nt_ipnd_out=nt_ipnd, nt_aero_out=nt_aero, nt_fsd_out=nt_fsd, & + nt_smice_out=nt_smice, nt_smliq_out=nt_smliq, & + nt_rhos_out=nt_rhos, nt_rsnw_out=nt_rsnw, & nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice) call icepack_warnings_flush(nu_diag) @@ -2016,6 +2214,14 @@ subroutine init_state trcr_depend(nt_hpnd) = 2+nt_apnd ! melt pond depth trcr_depend(nt_ipnd) = 2+nt_apnd ! refrozen pond lid endif + if (tr_snow) then ! snow-volume-weighted snow tracers + do k = 1, nslyr + trcr_depend(nt_smice + k - 1) = 2 ! ice mass in snow + trcr_depend(nt_smliq + k - 1) = 2 ! liquid mass in snow + trcr_depend(nt_rhos + k - 1) = 2 ! effective snow density + trcr_depend(nt_rsnw + k - 1) = 2 ! snow radius + enddo + endif if (tr_fsd) then do it = 1, nfsd trcr_depend(nt_fsd + it - 1) = 0 ! area-weighted floe size distribution @@ -2246,7 +2452,7 @@ subroutine set_state_var (nx_block, ny_block, & indxi, indxj ! compressed indices for cells with aicen > puny real (kind=dbl_kind) :: & - Tsfc, sum, hbar, puny, rhos, Lfresh, rad_to_deg + Tsfc, sum, hbar, puny, rhos, Lfresh, rad_to_deg, rsnw_fall real (kind=dbl_kind), dimension(ncat) :: & ainit, hinit ! initial area, thickness @@ -2262,22 +2468,26 @@ subroutine set_state_var (nx_block, ny_block, & edge_init_nh = 70._dbl_kind, & ! initial ice edge, N.Hem. (deg) edge_init_sh = -60._dbl_kind ! initial ice edge, S.Hem. (deg) - logical (kind=log_kind) :: tr_brine, tr_lvl + logical (kind=log_kind) :: tr_brine, tr_lvl, tr_snow integer (kind=int_kind) :: ntrcr integer (kind=int_kind) :: nt_Tsfc, nt_qice, nt_qsno, nt_sice integer (kind=int_kind) :: nt_fbri, nt_alvl, nt_vlvl + integer (kind=int_kind) :: nt_smice, nt_smliq, nt_rhos, nt_rsnw character(len=*), parameter :: subname='(set_state_var)' !----------------------------------------------------------------- call icepack_query_tracer_sizes(ntrcr_out=ntrcr) - call icepack_query_tracer_flags(tr_brine_out=tr_brine, tr_lvl_out=tr_lvl) + call icepack_query_tracer_flags(tr_brine_out=tr_brine, tr_lvl_out=tr_lvl, & + tr_snow_out=tr_snow) call icepack_query_tracer_indices( nt_Tsfc_out=nt_Tsfc, nt_qice_out=nt_qice, & nt_qsno_out=nt_qsno, nt_sice_out=nt_sice, & - nt_fbri_out=nt_fbri, nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl) + nt_fbri_out=nt_fbri, nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl, & + nt_smice_out=nt_smice, nt_smliq_out=nt_smliq, & + nt_rhos_out=nt_rhos, nt_rsnw_out=nt_rsnw) call icepack_query_parameters(rhos_out=rhos, Lfresh_out=Lfresh, puny_out=puny, & - rad_to_deg_out=rad_to_deg) + rad_to_deg_out=rad_to_deg, rsnw_fall_out=rsnw_fall) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) @@ -2309,6 +2519,14 @@ subroutine set_state_var (nx_block, ny_block, & do k = 1, nslyr trcrn(i,j,nt_qsno+k-1,n) = -rhos * Lfresh enddo + if (tr_snow) then + do k = 1, nslyr + trcrn(i,j,nt_rsnw +k-1,n) = rsnw_fall + trcrn(i,j,nt_rhos +k-1,n) = rhos + trcrn(i,j,nt_smice+k-1,n) = rhos + trcrn(i,j,nt_smliq+k-1,n) = c0 + enddo ! nslyr + endif enddo enddo enddo diff --git a/cicecore/cicedynB/general/ice_step_mod.F90 b/cicecore/cicedynB/general/ice_step_mod.F90 index d65cf52d3..976e95361 100644 --- a/cicecore/cicedynB/general/ice_step_mod.F90 +++ b/cicecore/cicedynB/general/ice_step_mod.F90 @@ -36,7 +36,7 @@ module ice_step_mod private public :: step_therm1, step_therm2, step_dyn_horiz, step_dyn_ridge, & - prep_radiation, step_radiation, ocean_mixed_layer, & + step_snow, prep_radiation, step_radiation, ocean_mixed_layer, & update_state, biogeochemistry, save_init, step_dyn_wave !======================================================================= @@ -163,7 +163,7 @@ subroutine step_therm1 (dt, iblk) Cdn_ocn, Cdn_ocn_skin, Cdn_ocn_floe, Cdn_ocn_keel, Cdn_atm_ratio, & Cdn_atm, Cdn_atm_skin, Cdn_atm_floe, Cdn_atm_rdg, Cdn_atm_pond, & hfreebd, hdraft, hridge, distrdg, hkeel, dkeel, lfloe, dfloe, & - fswsfcn, fswintn, Sswabsn, Iswabsn, & + fswsfcn, fswintn, Sswabsn, Iswabsn, meltsliqn, meltsliq, & fswthrun, fswthrun_vdr, fswthrun_vdf, fswthrun_idr, fswthrun_idf use ice_blocks, only: block, get_block, nx_block, ny_block use ice_calendar, only: yday @@ -172,13 +172,13 @@ subroutine step_therm1 (dt, iblk) use ice_flux, only: frzmlt, sst, Tf, strocnxT, strocnyT, rside, fbot, Tbot, Tsnice, & meltsn, melttn, meltbn, congeln, snoicen, uatm, vatm, fside, & wind, rhoa, potT, Qa, zlvl, zlvs, strax, stray, flatn, fsensn, fsurfn, fcondtopn, & - flw, fsnow, fpond, sss, mlt_onset, frz_onset, fcondbotn, fcondbot, & + flw, fsnow, fpond, sss, mlt_onset, frz_onset, fcondbotn, fcondbot, fsloss, & frain, Tair, strairxT, strairyT, fsurf, fcondtop, fsens, & flat, fswabs, flwout, evap, evaps, evapi, Tref, Qref, Uref, fresh, fsalt, fhocn, & fswthru, fswthru_vdr, fswthru_vdf, fswthru_idr, fswthru_idf, & meltt, melts, meltb, congel, snoice, & flatn_f, fsensn_f, fsurfn_f, fcondtopn_f, & - send_i2x_per_cat, fswthrun_ai + send_i2x_per_cat, fswthrun_ai, dsnow use ice_flux_bgc, only: dsnown, faero_atm, faero_ocn, fiso_atm, fiso_ocn, & Qa_iso, Qref_iso, fiso_evap, HDO_ocn, H2_16O_ocn, H2_18O_ocn use ice_grid, only: lmask_n, lmask_s, tmask @@ -211,11 +211,11 @@ subroutine step_therm1 (dt, iblk) integer (kind=int_kind) :: & ntrcr, nt_apnd, nt_hpnd, nt_ipnd, nt_alvl, nt_vlvl, nt_Tsfc, & nt_iage, nt_FY, nt_qice, nt_sice, nt_aero, nt_qsno, & - nt_isosno, nt_isoice + nt_isosno, nt_isoice, nt_rsnw, nt_smice, nt_smliq logical (kind=log_kind) :: & tr_iage, tr_FY, tr_iso, tr_aero, tr_pond, tr_pond_cesm, & - tr_pond_lvl, tr_pond_topo, calc_Tsfc, highfreq + tr_pond_lvl, tr_pond_topo, calc_Tsfc, highfreq, tr_snow real (kind=dbl_kind) :: & uvel_center, & ! cell-centered velocity, x component (m/s) @@ -228,6 +228,9 @@ subroutine step_therm1 (dt, iblk) real (kind=dbl_kind), dimension(n_iso,ncat) :: & isosno, isoice ! kg/m^2 + real (kind=dbl_kind), dimension(nslyr,ncat) :: & + rsnwn, smicen, smliqn + type (block) :: & this_block ! block information for current block @@ -240,13 +243,15 @@ subroutine step_therm1 (dt, iblk) call icepack_query_tracer_flags( & tr_iage_out=tr_iage, tr_FY_out=tr_FY, tr_iso_out=tr_iso, & tr_aero_out=tr_aero, tr_pond_out=tr_pond, tr_pond_cesm_out=tr_pond_cesm, & - tr_pond_lvl_out=tr_pond_lvl, tr_pond_topo_out=tr_pond_topo) + tr_pond_lvl_out=tr_pond_lvl, tr_pond_topo_out=tr_pond_topo, & + tr_snow_out=tr_snow) call icepack_query_tracer_indices( & nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, nt_ipnd_out=nt_ipnd, & nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl, nt_Tsfc_out=nt_Tsfc, & nt_iage_out=nt_iage, nt_FY_out=nt_FY, & nt_qice_out=nt_qice, nt_sice_out=nt_sice, & nt_aero_out=nt_aero, nt_qsno_out=nt_qsno, & + nt_rsnw_out=nt_rsnw, nt_smice_out=nt_smice, nt_smliq_out=nt_smliq, & nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & @@ -256,7 +261,9 @@ subroutine step_therm1 (dt, iblk) prescribed_ice = .false. #endif - isosno (:,:) = c0 + rsnwn (:,:) = c0 + smicen (:,:) = c0 + smliqn (:,:) = c0 isoice (:,:) = c0 aerosno(:,:,:) = c0 aeroice(:,:,:) = c0 @@ -302,6 +309,16 @@ subroutine step_therm1 (dt, iblk) vvel_center = c0 endif ! highfreq + if (tr_snow) then + do n = 1, ncat + do k = 1, nslyr + rsnwn (k,n) = trcrn(i,j,nt_rsnw +k-1,n,iblk) + smicen(k,n) = trcrn(i,j,nt_smice+k-1,n,iblk) + smliqn(k,n) = trcrn(i,j,nt_smliq+k-1,n,iblk) + enddo + enddo + endif ! tr_snow + if (tr_iso) then ! trcrn(nt_iso*) has units kg/m^3 do n=1,ncat do k=1,n_iso @@ -350,6 +367,9 @@ subroutine step_therm1 (dt, iblk) ipnd = trcrn (i,j,nt_ipnd,:,iblk), & iage = trcrn (i,j,nt_iage,:,iblk), & FY = trcrn (i,j,nt_FY ,:,iblk), & + rsnwn = rsnwn (:,:), & + smicen = smicen (:,:), & + smliqn = smliqn (:,:), & aerosno = aerosno (:,:,:), & aeroice = aeroice (:,:,:), & isosno = isosno (:,:), & @@ -397,13 +417,14 @@ subroutine step_therm1 (dt, iblk) strocnyT = strocnyT (i,j, iblk), & fbot = fbot (i,j, iblk), & Tbot = Tbot (i,j, iblk), & - Tsnice = Tsnice (i,j, iblk), & + Tsnice = Tsnice (i,j, iblk), & frzmlt = frzmlt (i,j, iblk), & rside = rside (i,j, iblk), & fside = fside (i,j, iblk), & fsnow = fsnow (i,j, iblk), & frain = frain (i,j, iblk), & fpond = fpond (i,j, iblk), & + fsloss = fsloss (i,j, iblk), & fsurf = fsurf (i,j, iblk), & fsurfn = fsurfn (i,j,:,iblk), & fcondtop = fcondtop (i,j, iblk), & @@ -433,10 +454,10 @@ subroutine step_therm1 (dt, iblk) fsalt = fsalt (i,j, iblk), & fhocn = fhocn (i,j, iblk), & fswthru = fswthru (i,j, iblk), & - fswthru_vdr = fswthru_vdr (i,j, iblk),& - fswthru_vdf = fswthru_vdf (i,j, iblk),& - fswthru_idr = fswthru_idr (i,j, iblk),& - fswthru_idf = fswthru_idf (i,j, iblk),& + fswthru_vdr = fswthru_vdr (i,j, iblk), & + fswthru_vdf = fswthru_vdf (i,j, iblk), & + fswthru_idr = fswthru_idr (i,j, iblk), & + fswthru_idf = fswthru_idf (i,j, iblk), & flatn_f = flatn_f (i,j,:,iblk), & fsensn_f = fsensn_f (i,j,:,iblk), & fsurfn_f = fsurfn_f (i,j,:,iblk), & @@ -461,7 +482,10 @@ subroutine step_therm1 (dt, iblk) congeln = congeln (i,j,:,iblk), & snoice = snoice (i,j, iblk), & snoicen = snoicen (i,j,:,iblk), & + dsnow = dsnow (i,j, iblk), & dsnown = dsnown (i,j,:,iblk), & + meltsliq = meltsliq (i,j, iblk), & + meltsliqn = meltsliqn (i,j,:,iblk), & lmask_n = lmask_n (i,j, iblk), & lmask_s = lmask_s (i,j, iblk), & mlt_onset = mlt_onset (i,j, iblk), & @@ -483,6 +507,16 @@ subroutine step_therm1 (dt, iblk) endif + if (tr_snow) then + do n = 1, ncat + do k = 1, nslyr + trcrn(i,j,nt_rsnw +k-1,n,iblk) = rsnwn (k,n) + trcrn(i,j,nt_smice+k-1,n,iblk) = smicen(k,n) + trcrn(i,j,nt_smliq+k-1,n,iblk) = smliqn(k,n) + enddo + enddo + endif ! tr_snow + if (tr_iso) then do n = 1, ncat if (vicen(i,j,n,iblk) > puny) & @@ -685,13 +719,15 @@ subroutine update_state (dt, daidt, dvidt, dagedt, offset) use ice_timers, only: ice_timer_start, ice_timer_stop, timer_bound real (kind=dbl_kind), intent(in) :: & - dt , & ! time step - offset ! d(age)/dt time offset = dt for thermo, 0 for dyn + dt ! time step - real (kind=dbl_kind), dimension(:,:,:), intent(inout) :: & - daidt, & ! change in ice area per time step - dvidt, & ! change in ice volume per time step - dagedt ! change in ice age per time step + real (kind=dbl_kind), dimension(:,:,:), intent(inout), optional :: & + daidt, & ! change in ice area per time step + dvidt, & ! change in ice volume per time step + dagedt ! change in ice age per time step + + real (kind=dbl_kind), intent(in), optional :: & + offset ! d(age)/dt time offset = dt for thermo, 0 for dyn integer (kind=int_kind) :: & iblk, & ! block index @@ -747,6 +783,8 @@ subroutine update_state (dt, daidt, dvidt, dagedt, offset) n_trcr_strata = n_trcr_strata(:), & nt_strata = nt_strata(:,:)) + if (present(offset)) then + !----------------------------------------------------------------- ! Compute thermodynamic area and volume tendencies. !----------------------------------------------------------------- @@ -762,7 +800,8 @@ subroutine update_state (dt, daidt, dvidt, dagedt, offset) dagedt(i,j,iblk) = (trcr(i,j,nt_iage,iblk) & - dagedt(i,j,iblk)) / dt endif - endif + endif ! tr_iage + endif ! present(offset) enddo ! i enddo ! j @@ -1022,6 +1061,118 @@ subroutine step_dyn_ridge (dt, ndtd, iblk) end subroutine step_dyn_ridge +!======================================================================= +! +! Updates snow tracers +! +! authors: Elizabeth C. Hunke, LANL +! Nicole Jeffery, LANL + + subroutine step_snow (dt, iblk) + + use ice_blocks, only: block, get_block + use ice_calendar, only: nstreams + use ice_domain, only: blocks_ice + use ice_domain_size, only: ncat, nslyr, nilyr + use ice_flux, only: snwcnt, wind, fresh, fhocn, fsloss, fsnow + use ice_state, only: trcrn, vsno, vsnon, vicen, aicen, aice + use icepack_intfc, only: icepack_step_snow + + real (kind=dbl_kind), intent(in) :: & + dt ! time step + + integer (kind=int_kind), intent(in) :: & + iblk ! block index + + ! local variables + + integer (kind=int_kind) :: & + nt_smice, nt_smliq, nt_rsnw, & + nt_Tsfc, nt_qice, nt_sice, nt_qsno, & + nt_alvl, nt_vlvl, nt_rhos + + integer (kind=int_kind) :: & + ilo,ihi,jlo,jhi, & ! beginning and end of physical domain + i, j, & ! horizontal indices + n, & ! category index + ns, & ! history streams index + ipoint ! index for print diagnostic + + real (kind=dbl_kind) :: & + puny + + real (kind=dbl_kind) :: & + fhs ! flag for presence of snow + + character(len=*), parameter :: subname = '(step_snow)' + + type (block) :: & + this_block ! block information for current block + + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + !----------------------------------------------------------------- + ! query icepack values + !----------------------------------------------------------------- + + call icepack_query_parameters(puny_out=puny) + call icepack_query_tracer_indices( & + nt_smice_out=nt_smice, nt_smliq_out=nt_smliq, & + nt_rsnw_out=nt_rsnw, nt_Tsfc_out=nt_Tsfc, & + nt_qice_out=nt_qice, nt_sice_out=nt_sice, nt_qsno_out=nt_qsno, & + nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl, nt_rhos_out=nt_rhos) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & + file=__FILE__, line=__LINE__) + + !----------------------------------------------------------------- + ! Snow redistribution and metamorphosis + !----------------------------------------------------------------- + + do j = jlo, jhi + do i = ilo, ihi + + call icepack_step_snow (dt, nilyr, & + nslyr, ncat, & + wind (i,j, iblk), & + aice (i,j, iblk), & + aicen(i,j,:,iblk), & + vicen(i,j,:,iblk), & + vsnon(i,j,:,iblk), & + trcrn(i,j,nt_Tsfc,:,iblk), & + trcrn(i,j,nt_qice,:,iblk), & ! top layer only + trcrn(i,j,nt_sice,:,iblk), & ! top layer only + trcrn(i,j,nt_qsno:nt_qsno+nslyr-1,:,iblk), & + trcrn(i,j,nt_alvl,:,iblk), & + trcrn(i,j,nt_vlvl,:,iblk), & + trcrn(i,j,nt_smice:nt_smice+nslyr-1,:,iblk), & + trcrn(i,j,nt_smliq:nt_smliq+nslyr-1,:,iblk), & + trcrn(i,j,nt_rsnw:nt_rsnw+nslyr-1,:,iblk), & + trcrn(i,j,nt_rhos:nt_rhos+nslyr-1,:,iblk), & + fresh (i,j,iblk), & + fhocn (i,j,iblk), & + fsloss (i,j,iblk), & + fsnow (i,j,iblk)) + enddo + enddo + + ! increment counter for history averaging + do j = jlo, jhi + do i = ilo, ihi + fhs = c0 + if (vsno(i,j,iblk) > puny) fhs = c1 + do ns = 1, nstreams + snwcnt(i,j,iblk,ns) = snwcnt(i,j,iblk,ns) + fhs + enddo + enddo + enddo + + end subroutine step_snow + !======================================================================= ! ! Computes radiation fields @@ -1067,7 +1218,7 @@ subroutine step_radiation (dt, iblk) this_block ! block information for current block integer (kind=int_kind) :: & - nt_Tsfc, nt_alvl, & + nt_Tsfc, nt_alvl, nt_rsnw, & nt_apnd, nt_hpnd, nt_ipnd, nt_aero, nlt_chl_sw, & ntrcr, nbtrcr, nbtrcr_sw, nt_fbri @@ -1078,13 +1229,14 @@ subroutine step_radiation (dt, iblk) nlt_zaero_sw, nt_zaero logical (kind=log_kind) :: & - tr_bgc_N, tr_zaero, tr_brine, dEdd_algae, modal_aero + tr_bgc_N, tr_zaero, tr_brine, dEdd_algae, modal_aero, snwgrain real (kind=dbl_kind), dimension(ncat) :: & - fbri ! brine height to ice thickness + fbri ! brine height to ice thickness real(kind= dbl_kind), dimension(:,:), allocatable :: & - ztrcr_sw + ztrcr_sw, & ! zaerosols (kg/m^3) and chla (mg/m^3) + rsnow ! snow grain radius tracer (10^-6 m) logical (kind=log_kind) :: & debug, & ! flag for printing debugging information @@ -1099,16 +1251,18 @@ subroutine step_radiation (dt, iblk) call icepack_query_tracer_flags( & tr_brine_out=tr_brine, tr_bgc_N_out=tr_bgc_N, tr_zaero_out=tr_zaero) call icepack_query_tracer_indices( & - nt_Tsfc_out=nt_Tsfc, nt_alvl_out=nt_alvl, & + nt_Tsfc_out=nt_Tsfc, nt_alvl_out=nt_alvl, nt_rsnw_out=nt_rsnw, & nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, nt_ipnd_out=nt_ipnd, nt_aero_out=nt_aero, & nlt_chl_sw_out=nlt_chl_sw, nlt_zaero_sw_out=nlt_zaero_sw, & nt_fbri_out=nt_fbri, nt_zaero_out=nt_zaero, nt_bgc_N_out=nt_bgc_N) - call icepack_query_parameters(dEdd_algae_out=dEdd_algae, modal_aero_out=modal_aero) + call icepack_query_parameters(dEdd_algae_out=dEdd_algae, modal_aero_out=modal_aero, & + snwgrain_out=snwgrain) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) allocate(ztrcr_sw(nbtrcr_sw,ncat)) + allocate(rsnow(nslyr,ncat)) this_block = get_block(blocks_ice(iblk),iblk) ilo = this_block%ilo @@ -1130,10 +1284,16 @@ subroutine step_radiation (dt, iblk) write (nu_diag, *) 'my_task = ',my_task enddo ! ipoint endif - fbri(:) = c0 + fbri (:) = c0 ztrcr_sw(:,:) = c0 + rsnow (:,:) = c0 do n = 1, ncat - if (tr_brine) fbri(n) = trcrn(i,j,nt_fbri,n,iblk) + if (tr_brine) fbri(n) = trcrn(i,j,nt_fbri,n,iblk) + if (snwgrain) then + do k = 1, nslyr + rsnow(k,n) = trcrn(i,j,nt_rsnw+k-1,n,iblk) + enddo + endif enddo if (tmask(i,j,iblk)) then @@ -1182,8 +1342,7 @@ subroutine step_radiation (dt, iblk) albpndn =albpndn (i,j,: ,iblk), apeffn =apeffn (i,j,: ,iblk), & snowfracn=snowfracn(i,j,: ,iblk), & dhsn =dhsn (i,j,: ,iblk), ffracn =ffracn(i,j,:,iblk), & - l_print_point=l_print_point) - + rsnow =rsnow (:,:), l_print_point=l_print_point) endif if (dEdd_algae .and. (tr_zaero .or. tr_bgc_N)) then @@ -1202,6 +1361,7 @@ subroutine step_radiation (dt, iblk) file=__FILE__, line=__LINE__) deallocate(ztrcr_sw) + deallocate(rsnow) call ice_timer_stop(timer_sw) ! shortwave diff --git a/cicecore/cicedynB/infrastructure/comm/mpi/ice_boundary.F90 b/cicecore/cicedynB/infrastructure/comm/mpi/ice_boundary.F90 index 635bbbeb4..3959f12cf 100644 --- a/cicecore/cicedynB/infrastructure/comm/mpi/ice_boundary.F90 +++ b/cicecore/cicedynB/infrastructure/comm/mpi/ice_boundary.F90 @@ -74,7 +74,8 @@ module ice_boundary ice_HaloUpdate, & ice_HaloUpdate_stress, & ice_HaloExtrapolate, & - ice_HaloDestroy + ice_HaloDestroy, & + primary_grid_lengths_global_ext interface ice_HaloUpdate ! generic interface module procedure ice_HaloUpdate2DR8, & @@ -6807,6 +6808,136 @@ subroutine ice_HaloDestroy(halo) endif end subroutine ice_HaloDestroy +!*********************************************************************** + + subroutine primary_grid_lengths_global_ext( & + ARRAY_O, ARRAY_I, ew_boundary_type, ns_boundary_type) + +! This subroutine adds ghost cells to global primary grid lengths array +! ARRAY_I and outputs result to array ARRAY_O + +! Note duplicate implementation of this subroutine in: +! cicecore/cicedynB/infrastructure/comm/serial/ice_boundary.F90 + + use ice_constants, only: c0 + use ice_domain_size, only: nx_global, ny_global + + real (kind=dbl_kind), dimension(:,:), intent(in) :: & + ARRAY_I + + character (*), intent(in) :: & + ew_boundary_type, ns_boundary_type + + real (kind=dbl_kind), dimension(:,:), intent(out) :: & + ARRAY_O + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: & + ii, io, ji, jo + + character(len=*), parameter :: & + subname = '(primary_grid_lengths_global_ext)' + +!----------------------------------------------------------------------- +! +! add ghost cells to global primary grid lengths array +! +!----------------------------------------------------------------------- + + if (trim(ns_boundary_type) == 'tripole' .or. & + trim(ns_boundary_type) == 'tripoleT') then + call abort_ice(subname//' ERROR: '//ns_boundary_type & + //' boundary type not implemented for configuration') + endif + + do jo = 1,ny_global+2*nghost + ji = -nghost + jo + + !*** Southern ghost cells + + if (ji < 1) then + select case (trim(ns_boundary_type)) + case ('cyclic') + ji = ji + ny_global + case ('open') + ji = nghost - jo + 1 + case ('closed') + ji = 0 + case default + call abort_ice( & + subname//' ERROR: unknown north-south boundary type') + end select + endif + + !*** Northern ghost cells + + if (ji > ny_global) then + select case (trim(ns_boundary_type)) + case ('cyclic') + ji = ji - ny_global + case ('open') + ji = 2 * ny_global - ji + 1 + case ('closed') + ji = 0 + case default + call abort_ice( & + subname//' ERROR: unknown north-south boundary type') + end select + endif + + do io = 1,nx_global+2*nghost + ii = -nghost + io + + !*** Western ghost cells + + if (ii < 1) then + select case (trim(ew_boundary_type)) + case ('cyclic') + ii = ii + nx_global + case ('open') + ii = nghost - io + 1 + case ('closed') + ii = 0 + case default + call abort_ice( & + subname//' ERROR: unknown east-west boundary type') + end select + endif + + !*** Eastern ghost cells + + if (ii > nx_global) then + select case (trim(ew_boundary_type)) + case ('cyclic') + ii = ii - nx_global + case ('open') + ii = 2 * nx_global - ii + 1 + case ('closed') + ii = 0 + case default + call abort_ice( & + subname//' ERROR: unknown east-west boundary type') + end select + endif + + if (ii == 0 .or. ji == 0) then + ARRAY_O(io, jo) = c0 + else + ARRAY_O(io, jo) = ARRAY_I(ii, ji) + endif + + enddo + enddo + +!----------------------------------------------------------------------- + + end subroutine primary_grid_lengths_global_ext + !*********************************************************************** end module ice_boundary diff --git a/cicecore/cicedynB/infrastructure/comm/mpi/ice_gather_scatter.F90 b/cicecore/cicedynB/infrastructure/comm/mpi/ice_gather_scatter.F90 index 010a5c8c4..0a58769db 100644 --- a/cicecore/cicedynB/infrastructure/comm/mpi/ice_gather_scatter.F90 +++ b/cicecore/cicedynB/infrastructure/comm/mpi/ice_gather_scatter.F90 @@ -636,6 +636,7 @@ subroutine gather_global_ext_dbl(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) else special_value = spval_dbl endif + ARRAY_G = special_value nx = nx_global + 2*nghost ny = ny_global + 2*nghost @@ -744,92 +745,7 @@ subroutine gather_global_ext_dbl(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) endif endif - !*** fill land blocks with special values - - else if (src_dist%blockLocation(n) == 0) then - - this_block = get_block(n,n) - - ! interior - do j=this_block%jlo,this_block%jhi - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost, & - this_block%j_glob(j)+nghost) = special_value - end do - end do - -#ifdef CICE_IN_NEMO -!echmod: this code is temporarily wrapped for nemo pending further testing elsewhere - ! fill ghost cells - if (this_block%jblock == 1) then - ! south block - do j=1, nghost - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost,j) = special_value - end do - end do - if (this_block%iblock == 1) then - ! southwest corner - do j=1, nghost - do i=1, nghost - ARRAY_G(i,j) = special_value - end do - end do - endif - endif - if (this_block%jblock == nblocks_y) then - ! north block - do j=1, nghost - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost, & - ny_global + nghost + j) = special_value - end do - end do - if (this_block%iblock == nblocks_x) then - ! northeast corner - do j=1, nghost - do i=1, nghost - ARRAY_G(nx-i+1, ny-j+1) = special_value - end do - end do - endif - endif - if (this_block%iblock == 1) then - ! west block - do j=this_block%jlo,this_block%jhi - do i=1, nghost - ARRAY_G(i,this_block%j_glob(j)+nghost) = special_value - end do - end do - if (this_block%jblock == nblocks_y) then - ! northwest corner - do j=1, nghost - do i=1, nghost - ARRAY_G(i, ny-j+1) = special_value - end do - end do - endif - endif - if (this_block%iblock == nblocks_x) then - ! east block - do j=this_block%jlo,this_block%jhi - do i=1, nghost - ARRAY_G(nx_global + nghost + i, & - this_block%j_glob(j)+nghost) = special_value - end do - end do - if (this_block%jblock == 1) then - ! southeast corner - do j=1, nghost - do i=1, nghost - ARRAY_G( nx-i+1,j) = special_value - end do - end do - endif - endif -#endif - - endif + endif ! src_dist%blockLocation end do @@ -939,7 +855,7 @@ subroutine gather_global_ext_dbl(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) ! !----------------------------------------------------------------------- - else + else ! master task allocate(snd_request(nblocks_tot), & snd_status (MPI_STATUS_SIZE, nblocks_tot)) @@ -960,7 +876,7 @@ subroutine gather_global_ext_dbl(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) call MPI_WAITALL(nsends, snd_request, snd_status, ierr) deallocate(snd_request, snd_status) - endif + endif ! master task if (add_mpi_barriers) then call ice_barrier() @@ -1028,8 +944,9 @@ subroutine gather_global_ext_int(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) if (present(spc_val)) then special_value = spc_val else - special_value = 0 !MHRI NOTE: 0,1,-999,??? + special_value = -9999 endif + ARRAY_G = special_value nx = nx_global + 2*nghost ny = ny_global + 2*nghost @@ -1138,21 +1055,7 @@ subroutine gather_global_ext_int(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) endif endif - !*** fill land blocks with special values - - else if (src_dist%blockLocation(n) == 0) then - - this_block = get_block(n,n) - - ! interior - do j=this_block%jlo,this_block%jhi - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost, & - this_block%j_glob(j)+nghost) = special_value - end do - end do - - endif + endif ! src_dist%blockLocation end do @@ -1262,7 +1165,7 @@ subroutine gather_global_ext_int(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) ! !----------------------------------------------------------------------- - else + else ! master task allocate(snd_request(nblocks_tot), & snd_status (MPI_STATUS_SIZE, nblocks_tot)) @@ -1283,7 +1186,7 @@ subroutine gather_global_ext_int(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) call MPI_WAITALL(nsends, snd_request, snd_status, ierr) deallocate(snd_request, snd_status) - endif + endif ! master task if (add_mpi_barriers) then call ice_barrier() @@ -1351,8 +1254,9 @@ subroutine gather_global_ext_log(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) if (present(spc_val)) then special_value = spc_val else - special_value = .false. !MHRI NOTE: .true./.false. ??? + special_value = .false. endif + ARRAY_G = special_value nx = nx_global + 2*nghost ny = ny_global + 2*nghost @@ -1461,21 +1365,7 @@ subroutine gather_global_ext_log(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) endif endif - !*** fill land blocks with special values - - else if (src_dist%blockLocation(n) == 0) then - - this_block = get_block(n,n) - - ! interior - do j=this_block%jlo,this_block%jhi - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost, & - this_block%j_glob(j)+nghost) = special_value - end do - end do - - endif + endif ! src_dist%blockLocation end do @@ -1585,7 +1475,7 @@ subroutine gather_global_ext_log(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) ! !----------------------------------------------------------------------- - else + else ! master task allocate(snd_request(nblocks_tot), & snd_status (MPI_STATUS_SIZE, nblocks_tot)) @@ -1606,7 +1496,7 @@ subroutine gather_global_ext_log(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) call MPI_WAITALL(nsends, snd_request, snd_status, ierr) deallocate(snd_request, snd_status) - endif + endif ! master task if (add_mpi_barriers) then call ice_barrier() diff --git a/cicecore/cicedynB/infrastructure/comm/serial/ice_boundary.F90 b/cicecore/cicedynB/infrastructure/comm/serial/ice_boundary.F90 index c66cdd13c..f3fffba59 100644 --- a/cicecore/cicedynB/infrastructure/comm/serial/ice_boundary.F90 +++ b/cicecore/cicedynB/infrastructure/comm/serial/ice_boundary.F90 @@ -61,7 +61,8 @@ module ice_boundary ice_HaloUpdate, & ice_HaloUpdate_stress, & ice_HaloExtrapolate, & - ice_HaloDestroy + ice_HaloDestroy, & + primary_grid_lengths_global_ext interface ice_HaloUpdate ! generic interface module procedure ice_HaloUpdate2DR8, & @@ -4587,6 +4588,136 @@ subroutine ice_HaloDestroy(halo) end subroutine ice_HaloDestroy +!*********************************************************************** + + subroutine primary_grid_lengths_global_ext( & + ARRAY_O, ARRAY_I, ew_boundary_type, ns_boundary_type) + +! This subroutine adds ghost cells to global primary grid lengths array +! ARRAY_I and outputs result to array ARRAY_O + +! Note duplicate implementation of this subroutine in: +! cicecore/cicedynB/infrastructure/comm/mpi/ice_boundary.F90 + + use ice_constants, only: c0 + use ice_domain_size, only: nx_global, ny_global + + real (kind=dbl_kind), dimension(:,:), intent(in) :: & + ARRAY_I + + character (*), intent(in) :: & + ew_boundary_type, ns_boundary_type + + real (kind=dbl_kind), dimension(:,:), intent(out) :: & + ARRAY_O + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: & + ii, io, ji, jo + + character(len=*), parameter :: & + subname = '(primary_grid_lengths_global_ext)' + +!----------------------------------------------------------------------- +! +! add ghost cells to global primary grid lengths array +! +!----------------------------------------------------------------------- + + if (trim(ns_boundary_type) == 'tripole' .or. & + trim(ns_boundary_type) == 'tripoleT') then + call abort_ice(subname//' ERROR: '//ns_boundary_type & + //' boundary type not implemented for configuration') + endif + + do jo = 1,ny_global+2*nghost + ji = -nghost + jo + + !*** Southern ghost cells + + if (ji < 1) then + select case (trim(ns_boundary_type)) + case ('cyclic') + ji = ji + ny_global + case ('open') + ji = nghost - jo + 1 + case ('closed') + ji = 0 + case default + call abort_ice( & + subname//' ERROR: unknown north-south boundary type') + end select + endif + + !*** Northern ghost cells + + if (ji > ny_global) then + select case (trim(ns_boundary_type)) + case ('cyclic') + ji = ji - ny_global + case ('open') + ji = 2 * ny_global - ji + 1 + case ('closed') + ji = 0 + case default + call abort_ice( & + subname//' ERROR: unknown north-south boundary type') + end select + endif + + do io = 1,nx_global+2*nghost + ii = -nghost + io + + !*** Western ghost cells + + if (ii < 1) then + select case (trim(ew_boundary_type)) + case ('cyclic') + ii = ii + nx_global + case ('open') + ii = nghost - io + 1 + case ('closed') + ii = 0 + case default + call abort_ice( & + subname//' ERROR: unknown east-west boundary type') + end select + endif + + !*** Eastern ghost cells + + if (ii > nx_global) then + select case (trim(ew_boundary_type)) + case ('cyclic') + ii = ii - nx_global + case ('open') + ii = 2 * nx_global - ii + 1 + case ('closed') + ii = 0 + case default + call abort_ice( & + subname//' ERROR: unknown east-west boundary type') + end select + endif + + if (ii == 0 .or. ji == 0) then + ARRAY_O(io, jo) = c0 + else + ARRAY_O(io, jo) = ARRAY_I(ii, ji) + endif + + enddo + enddo + +!----------------------------------------------------------------------- + + end subroutine primary_grid_lengths_global_ext + !*********************************************************************** end module ice_boundary diff --git a/cicecore/cicedynB/infrastructure/comm/serial/ice_gather_scatter.F90 b/cicecore/cicedynB/infrastructure/comm/serial/ice_gather_scatter.F90 index 418c80f61..4b0bb1f9e 100644 --- a/cicecore/cicedynB/infrastructure/comm/serial/ice_gather_scatter.F90 +++ b/cicecore/cicedynB/infrastructure/comm/serial/ice_gather_scatter.F90 @@ -373,6 +373,7 @@ subroutine gather_global_ext_dbl(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) else special_value = spval_dbl endif + ARRAY_G = special_value nx = nx_global + 2*nghost ny = ny_global + 2*nghost @@ -477,16 +478,7 @@ subroutine gather_global_ext_dbl(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) endif endif - else !*** fill land blocks with special values - - do j=this_block%jlo,this_block%jhi - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost, & - this_block%j_glob(j)+nghost) = special_value - end do - end do - - endif + endif ! src_dist%blockLocation end do @@ -537,8 +529,9 @@ subroutine gather_global_ext_int(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) if (present(spc_val)) then special_value = spc_val else - special_value = 0 !MHRI: 0,1,999,-999 ?? + special_value = -9999 endif + ARRAY_G = special_value nx = nx_global + 2*nghost ny = ny_global + 2*nghost @@ -643,16 +636,7 @@ subroutine gather_global_ext_int(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) endif endif - else !*** fill land blocks with special values - - do j=this_block%jlo,this_block%jhi - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost, & - this_block%j_glob(j)+nghost) = special_value - end do - end do - - endif + endif ! src_dist%blockLocation end do @@ -703,8 +687,9 @@ subroutine gather_global_ext_log(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) if (present(spc_val)) then special_value = spc_val else - special_value = .false. !MHRI: true/false + special_value = .false. endif + ARRAY_G = special_value nx = nx_global + 2*nghost ny = ny_global + 2*nghost @@ -809,16 +794,7 @@ subroutine gather_global_ext_log(ARRAY_G, ARRAY, dst_task, src_dist, spc_val) endif endif - else !*** fill land blocks with special values - - do j=this_block%jlo,this_block%jhi - do i=this_block%ilo,this_block%ihi - ARRAY_G(this_block%i_glob(i)+nghost, & - this_block%j_glob(j)+nghost) = special_value - end do - end do - - endif + endif ! src_dist%blockLocation end do diff --git a/cicecore/cicedynB/infrastructure/ice_domain.F90 b/cicecore/cicedynB/infrastructure/ice_domain.F90 index 52f0da850..1dfdd0428 100644 --- a/cicecore/cicedynB/infrastructure/ice_domain.F90 +++ b/cicecore/cicedynB/infrastructure/ice_domain.F90 @@ -441,7 +441,7 @@ subroutine init_domain_distribution(KMTG,ULATG) !---------------------------------------------------------------------- if (distribution_wght == 'latitude') then - flat = NINT(abs(ULATG*rad_to_deg), int_kind) ! linear function + flat = max(NINT(abs(ULATG*rad_to_deg), int_kind),1) ! linear function else flat = 1 endif diff --git a/cicecore/cicedynB/infrastructure/ice_grid.F90 b/cicecore/cicedynB/infrastructure/ice_grid.F90 index 2124bbebe..18dbaaefe 100644 --- a/cicecore/cicedynB/infrastructure/ice_grid.F90 +++ b/cicecore/cicedynB/infrastructure/ice_grid.F90 @@ -19,7 +19,8 @@ module ice_grid use ice_kinds_mod use ice_broadcast, only: broadcast_scalar, broadcast_array - use ice_boundary, only: ice_HaloUpdate, ice_HaloExtrapolate + use ice_boundary, only: ice_HaloUpdate, ice_HaloExtrapolate, & + primary_grid_lengths_global_ext use ice_communicate, only: my_task, master_task use ice_blocks, only: block, get_block, nx_block, ny_block, nghost use ice_domain_size, only: nx_global, ny_global, max_blocks @@ -77,13 +78,17 @@ module ice_grid ocn_gridcell_frac ! only relevant for lat-lon grids ! gridcell value of [1 - (land fraction)] (T-cell) + real (kind=dbl_kind), dimension (:,:), allocatable, public :: & + G_HTE , & ! length of eastern edge of T-cell (global ext.) + G_HTN ! length of northern edge of T-cell (global ext.) + real (kind=dbl_kind), dimension (:,:,:), allocatable, public :: & - cyp , & ! 1.5*HTE - 0.5*HTE - cxp , & ! 1.5*HTN - 0.5*HTN - cym , & ! 0.5*HTE - 1.5*HTE - cxm , & ! 0.5*HTN - 1.5*HTN - dxhy , & ! 0.5*(HTE - HTE) - dyhx ! 0.5*(HTN - HTN) + cyp , & ! 1.5*HTE(i,j)-0.5*HTW(i,j) = 1.5*HTE(i,j)-0.5*HTE(i-1,j) + cxp , & ! 1.5*HTN(i,j)-0.5*HTS(i,j) = 1.5*HTN(i,j)-0.5*HTN(i,j-1) + cym , & ! 0.5*HTE(i,j)-1.5*HTW(i,j) = 0.5*HTE(i,j)-1.5*HTE(i-1,j) + cxm , & ! 0.5*HTN(i,j)-1.5*HTS(i,j) = 0.5*HTN(i,j)-1.5*HTN(i,j-1) + dxhy , & ! 0.5*(HTE(i,j) - HTW(i,j)) = 0.5*(HTE(i,j) - HTE(i-1,j)) + dyhx ! 0.5*(HTN(i,j) - HTS(i,j)) = 0.5*(HTN(i,j) - HTN(i,j-1)) ! grid dimensions for rectangular grid real (kind=dbl_kind), public :: & @@ -125,7 +130,8 @@ module ice_grid kmt ! ocean topography mask for bathymetry (T-cell) logical (kind=log_kind), public :: & - use_bathymetry ! flag for reading in bathymetry_file + use_bathymetry, & ! flag for reading in bathymetry_file + pgl_global_ext ! flag for init primary grid lengths (global ext.) logical (kind=log_kind), & dimension (:,:,:), allocatable, public :: & @@ -153,6 +159,8 @@ subroutine alloc_grid integer (int_kind) :: ierr + character(len=*), parameter :: subname = '(alloc_grid)' + allocate( & dxt (nx_block,ny_block,max_blocks), & ! width of T-cell through the middle (m) dyt (nx_block,ny_block,max_blocks), & ! height of T-cell through the middle (m) @@ -175,12 +183,12 @@ subroutine alloc_grid ANGLET (nx_block,ny_block,max_blocks), & ! ANGLE converted to T-cells bathymetry(nx_block,ny_block,max_blocks),& ! ocean depth, for grounding keels and bergs (m) ocn_gridcell_frac(nx_block,ny_block,max_blocks),& ! only relevant for lat-lon grids - cyp (nx_block,ny_block,max_blocks), & ! 1.5*HTE - 0.5*HTE - cxp (nx_block,ny_block,max_blocks), & ! 1.5*HTN - 0.5*HTN - cym (nx_block,ny_block,max_blocks), & ! 0.5*HTE - 1.5*HTE - cxm (nx_block,ny_block,max_blocks), & ! 0.5*HTN - 1.5*HTN - dxhy (nx_block,ny_block,max_blocks), & ! 0.5*(HTE - HTE) - dyhx (nx_block,ny_block,max_blocks), & ! 0.5*(HTN - HTN) + cyp (nx_block,ny_block,max_blocks), & ! 1.5*HTE - 0.5*HTW + cxp (nx_block,ny_block,max_blocks), & ! 1.5*HTN - 0.5*HTS + cym (nx_block,ny_block,max_blocks), & ! 0.5*HTE - 1.5*HTW + cxm (nx_block,ny_block,max_blocks), & ! 0.5*HTN - 1.5*HTS + dxhy (nx_block,ny_block,max_blocks), & ! 0.5*(HTE - HTW) + dyhx (nx_block,ny_block,max_blocks), & ! 0.5*(HTN - HTS) xav (nx_block,ny_block,max_blocks), & ! mean T-cell value of x yav (nx_block,ny_block,max_blocks), & ! mean T-cell value of y xxav (nx_block,ny_block,max_blocks), & ! mean T-cell value of xx @@ -203,7 +211,15 @@ subroutine alloc_grid mse (2,2,nx_block,ny_block,max_blocks), & msw (2,2,nx_block,ny_block,max_blocks), & stat=ierr) - if (ierr/=0) call abort_ice('(alloc_grid): Out of memory') + if (ierr/=0) call abort_ice(subname//'ERROR: Out of memory') + + if (pgl_global_ext) then + allocate( & + G_HTE(nx_global+2*nghost, ny_global+2*nghost), & ! length of eastern edge of T-cell (global ext.) + G_HTN(nx_global+2*nghost, ny_global+2*nghost), & ! length of northern edge of T-cell (global ext.) + stat=ierr) + if (ierr/=0) call abort_ice(subname//'ERROR: Out of memory') + endif end subroutine alloc_grid @@ -1499,6 +1515,10 @@ subroutine primary_grid_lengths_HTN(work_g) enddo enddo endif + if (pgl_global_ext) then + call primary_grid_lengths_global_ext( & + G_HTN, work_g, ew_boundary_type, ns_boundary_type) + endif call scatter_global(HTN, work_g, master_task, distrb_info, & field_loc_Nface, field_type_scalar) call scatter_global(dxu, work_g2, master_task, distrb_info, & @@ -1573,6 +1593,10 @@ subroutine primary_grid_lengths_HTE(work_g) enddo endif endif + if (pgl_global_ext) then + call primary_grid_lengths_global_ext( & + G_HTE, work_g, ew_boundary_type, ns_boundary_type) + endif call scatter_global(HTE, work_g, master_task, distrb_info, & field_loc_Eface, field_type_scalar) call scatter_global(dyu, work_g2, master_task, distrb_info, & diff --git a/cicecore/cicedynB/infrastructure/ice_read_write.F90 b/cicecore/cicedynB/infrastructure/ice_read_write.F90 index d902c62f8..bf0361cf1 100644 --- a/cicecore/cicedynB/infrastructure/ice_read_write.F90 +++ b/cicecore/cicedynB/infrastructure/ice_read_write.F90 @@ -68,6 +68,9 @@ module ice_read_write ice_read_nc_xyz, & !ice_read_nc_xyf, & ice_read_nc_point, & + ice_read_nc_1D, & + ice_read_nc_2D, & + ice_read_nc_3D, & ice_read_nc_z end interface @@ -285,7 +288,7 @@ subroutine ice_read_xyt(nu, nrec, work, atype, diag, & read(nu) ((work_g1(i,j),i=1,nx_global),j=1,ny_global) endif else - write(nu_diag,*) ' ERROR: reading unknown atype ',atype + write(nu_diag,*) subname,' ERROR: reading unknown atype ',atype endif endif ! my_task = master_task @@ -304,7 +307,7 @@ subroutine ice_read_xyt(nu, nrec, work, atype, diag, & amin = minval(work_g1) amax = maxval(work_g1, mask = work_g1 /= spval_dbl) asum = sum(work_g1, mask = work_g1 /= spval_dbl) - write(nu_diag,*) ' read_global ',nu, nrec, amin, amax, asum + write(nu_diag,*) subname,' read_global ',nu, nrec, amin, amax, asum endif !------------------------------------------------------------------- @@ -433,7 +436,7 @@ subroutine ice_read_xyzt(nu, nrec, work, atype, diag, & k=1,nblyr+2) endif else - write(nu_diag,*) ' ERROR: reading unknown atype ',atype + write(nu_diag,*) subname,' ERROR: reading unknown atype ',atype endif endif ! my_task = master_task @@ -452,7 +455,7 @@ subroutine ice_read_xyzt(nu, nrec, work, atype, diag, & amin = minval(work_g4) amax = maxval(work_g4, mask = work_g4 /= spval_dbl) asum = sum (work_g4, mask = work_g4 /= spval_dbl) - write(nu_diag,*) ' read_global ',nu, nrec, amin, amax, asum + write(nu_diag,*) subname,' read_global ',nu, nrec, amin, amax, asum endif !------------------------------------------------------------------- @@ -566,7 +569,7 @@ subroutine ice_read_global (nu, nrec, work_g, atype, diag, & read(nu) ((work_g(i,j),i=1,nx_global),j=1,ny_global) endif else - write(nu_diag,*) ' ERROR: reading unknown atype ',atype + write(nu_diag,*) subname,' ERROR: reading unknown atype ',atype endif endif ! my_task = master_task @@ -582,7 +585,7 @@ subroutine ice_read_global (nu, nrec, work_g, atype, diag, & amin = minval(work_g) amax = maxval(work_g, mask = work_g /= spval_dbl) asum = sum (work_g, mask = work_g /= spval_dbl) - write(nu_diag,*) ' read_global ',nu, nrec, amin, amax,asum + write(nu_diag,*) subname,' read_global ',nu, nrec, amin, amax,asum endif end subroutine ice_read_global @@ -686,7 +689,7 @@ subroutine ice_read_ext(nu, nrec, work, atype, diag, & read(nu) ((work_g1(i,j),i=1,nx),j=1,ny) endif else - write(nu_diag,*) ' ERROR: reading unknown atype ',atype + write(nu_diag,*) subname,' ERROR: reading unknown atype ',atype endif endif ! my_task = master_task @@ -705,7 +708,7 @@ subroutine ice_read_ext(nu, nrec, work, atype, diag, & amin = minval(work_g1) amax = maxval(work_g1, mask = work_g1 /= spval_dbl) asum = sum (work_g1, mask = work_g1 /= spval_dbl) - write(nu_diag,*) ' read_global ',nu, nrec, amin, amax, asum + write(nu_diag,*) subname,' read_global ',nu, nrec, amin, amax, asum endif !------------------------------------------------------------------- @@ -800,7 +803,7 @@ subroutine ice_write_xyt(nu, nrec, work, atype, diag) elseif (atype == 'ruf8') then write(nu) ((work_g1(i,j),i=1,nx_global),j=1,ny_global) else - write(nu_diag,*) ' ERROR: writing unknown atype ',atype + write(nu_diag,*) subname,' ERROR: writing unknown atype ',atype endif !------------------------------------------------------------------- @@ -810,7 +813,7 @@ subroutine ice_write_xyt(nu, nrec, work, atype, diag) amin = minval(work_g1) amax = maxval(work_g1, mask = work_g1 /= spval_dbl) asum = sum (work_g1, mask = work_g1 /= spval_dbl) - write(nu_diag,*) ' write_global ', nu, nrec, amin, amax, asum + write(nu_diag,*) subname,' write_global ', nu, nrec, amin, amax, asum endif endif ! my_task = master_task @@ -905,7 +908,7 @@ subroutine ice_write_xyzt(nu, nrec, work, atype, diag) write(nu)(((work_g4(i,j,k),i=1,nx_global),j=1,ny_global), & k=1,nblyr+2) else - write(nu_diag,*) ' ERROR: writing unknown atype ',atype + write(nu_diag,*) subname,' ERROR: writing unknown atype ',atype endif !------------------------------------------------------------------- @@ -915,7 +918,7 @@ subroutine ice_write_xyzt(nu, nrec, work, atype, diag) amin = minval(work_g4) amax = maxval(work_g4, mask = work_g4 /= spval_dbl) asum = sum (work_g4, mask = work_g4 /= spval_dbl) - write(nu_diag,*) ' write_global ', nu, nrec, amin, amax, asum + write(nu_diag,*) subname,' write_global ', nu, nrec, amin, amax, asum endif endif ! my_task = master_task @@ -1011,7 +1014,7 @@ subroutine ice_write_ext(nu, nrec, work, atype, diag) elseif (atype == 'ruf8') then write(nu) ((work_g1(i,j),i=1,nx),j=1,ny) else - write(nu_diag,*) ' ERROR: writing unknown atype ',atype + write(nu_diag,*) subname,' ERROR: writing unknown atype ',atype endif !------------------------------------------------------------------- @@ -1021,7 +1024,7 @@ subroutine ice_write_ext(nu, nrec, work, atype, diag) amin = minval(work_g1) amax = maxval(work_g1, mask = work_g1 /= spval_dbl) asum = sum (work_g1, mask = work_g1 /= spval_dbl) - write(nu_diag,*) ' write_global ', nu, nrec, amin, amax, asum + write(nu_diag,*) subname,' write_global ', nu, nrec, amin, amax, asum endif endif ! my_task = master_task @@ -1055,14 +1058,15 @@ subroutine ice_open_nc(filename, fid) status = nf90_open(filename, NF90_NOWRITE, fid) if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot open '//trim(filename) ) + call abort_ice(subname//' ERROR: Cannot open '//trim(filename), & + file=__FILE__, line=__LINE__) endif endif ! my_task = master_task #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined for '//trim(filename), & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined for '//trim(filename), & + file=__FILE__, line=__LINE__) fid = -999 ! to satisfy intent(out) attribute #endif end subroutine ice_open_nc @@ -1110,26 +1114,29 @@ subroutine ice_read_nc_xy(fid, nrec, varname, work, diag, & ! netCDF file diagnostics: integer (kind=int_kind) :: & varid , & ! variable id - status ! status output from netcdf routines -! ndim, nvar, & ! sizes of netcdf file -! id, & ! dimension index -! dimlen ! dimension size + status , & ! status output from netcdf routines + ndims , & ! number of dimensions + dimlen ! dimension size + + integer (kind=int_kind), dimension(10) :: & + dimids ! generic size dimids real (kind=dbl_kind) :: & missingvalue, & amin, amax, asum ! min, max values and sum of input array -! character (char_len) :: & -! dimname ! dimension name - real (kind=dbl_kind), dimension(:,:), allocatable :: & work_g1 integer (kind=int_kind) :: nx, ny + integer (kind=int_kind) :: lnrec ! local value of nrec + real (kind=dbl_kind), dimension(:,:), allocatable :: & work_g2 + lnrec = nrec + if (orca_halogrid .and. .not. present(restart_ext)) then if (my_task == master_task) then allocate(work_g2(nx_global+2,ny_global+1)) @@ -1164,9 +1171,31 @@ subroutine ice_read_nc_xy(fid, nrec, varname, work, diag, & !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + + !------------------------------------------------------------- + ! Check nrec axis size + !------------------------------------------------------------- + + status = nf90_inquire_variable(fid, varid, ndims=ndims, dimids=dimids) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire variable dimids '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (ndims > 2) then + status = nf90_inquire_dimension(fid, dimids(3), len=dimlen) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire dimension size 3 '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (lnrec > dimlen) then + write(nu_diag,*) subname,' ERROR not enough records, ',trim(varname),lnrec,dimlen + call abort_ice(subname//' ERROR: not enough records '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif !-------------------------------------------------------------- @@ -1175,13 +1204,21 @@ subroutine ice_read_nc_xy(fid, nrec, varname, work, diag, & if (orca_halogrid .and. .not. present(restart_ext)) then status = nf90_get_var( fid, varid, work_g2, & - start=(/1,1,nrec/), & - count=(/nx_global+2,ny_global+1,1/) ) + start=(/1,1,lnrec/), & + count=(/nx_global+2,ny_global+1,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif work_g1 = work_g2(2:nx_global+1,1:ny_global) else status = nf90_get_var( fid, varid, work_g1, & - start=(/1,1,nrec/), & - count=(/nx,ny,1/) ) + start=(/1,1,lnrec/), & + count=(/nx,ny,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif status = nf90_get_att(fid, varid, "_FillValue", missingvalue) @@ -1192,19 +1229,19 @@ subroutine ice_read_nc_xy(fid, nrec, varname, work, diag, & !------------------------------------------------------------------- if (my_task==master_task .and. diag) then - write(nu_diag,*) & - 'ice_read_nc_xy, fid= ',fid, ', nrec = ',nrec, & + write(nu_diag,'(2a,i8,a,i8,2a)') & + subname,' fid= ',fid, ', lnrec = ',lnrec, & ', varname = ',trim(varname) ! status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) -! write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar +! write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar ! do id=1,ndim ! status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) -! write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen +! write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen ! enddo amin = minval(work_g1) amax = maxval(work_g1, mask = work_g1 /= missingvalue) asum = sum (work_g1, mask = work_g1 /= missingvalue) - write(nu_diag,*) ' min, max, sum =', amin, amax, asum, trim(varname) + write(nu_diag,*) subname,' min, max, sum =', amin, amax, asum, trim(varname) endif !------------------------------------------------------------------- @@ -1234,8 +1271,8 @@ subroutine ice_read_nc_xy(fid, nrec, varname, work, diag, & if (orca_halogrid .and. .not. present(restart_ext)) deallocate(work_g2) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) #endif end subroutine ice_read_nc_xy @@ -1282,27 +1319,33 @@ subroutine ice_read_nc_xyz(fid, nrec, varname, work, diag, & ! netCDF file diagnostics: integer (kind=int_kind) :: & n, & ! ncat index - varid , & ! variable id - status ! status output from netcdf routines -! ndim, nvar, & ! sizes of netcdf file -! id, & ! dimension index -! dimlen ! size of dimension + varid , & ! variable id + status , & ! status output from netcdf routines + ndims , & ! number of dimensions + dimlen ! dimension size + + integer (kind=int_kind), dimension(10) :: & + dimids ! generic size dimids real (kind=dbl_kind) :: & missingvalue, & ! missing value amin, amax, asum ! min, max values and sum of input array ! character (char_len) :: & -! dimname ! dimension name +! dimname ! dimension name real (kind=dbl_kind), dimension(:,:,:), allocatable :: & work_g1 integer (kind=int_kind) :: nx, ny + integer (kind=int_kind) :: lnrec ! local value of nrec + real (kind=dbl_kind), dimension(:,:,:), allocatable :: & work_g2 + lnrec = nrec + if (orca_halogrid .and. .not. present(restart_ext)) then if (my_task == master_task) then allocate(work_g2(nx_global+2,ny_global+1,ncat)) @@ -1335,9 +1378,31 @@ subroutine ice_read_nc_xyz(fid, nrec, varname, work, diag, & !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + + !------------------------------------------------------------- + ! Check nrec axis size + !------------------------------------------------------------- + + status = nf90_inquire_variable(fid, varid, ndims=ndims, dimids=dimids) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire variable dimids '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (ndims > 3) then + status = nf90_inquire_dimension(fid, dimids(4), len=dimlen) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire dimension size 4 '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (lnrec > dimlen) then + write(nu_diag,*) subname,' ERROR not enough records, ',trim(varname),lnrec,dimlen + call abort_ice(subname//' ERROR: not enough records '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif !-------------------------------------------------------------- @@ -1346,13 +1411,21 @@ subroutine ice_read_nc_xyz(fid, nrec, varname, work, diag, & if (orca_halogrid .and. .not. present(restart_ext)) then status = nf90_get_var( fid, varid, work_g2, & - start=(/1,1,1,nrec/), & - count=(/nx_global+2,ny_global+1,ncat,1/) ) + start=(/1,1,1,lnrec/), & + count=(/nx_global+2,ny_global+1,ncat,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif work_g1 = work_g2(2:nx_global+1,1:ny_global,:) else status = nf90_get_var( fid, varid, work_g1, & - start=(/1,1,1,nrec/), & - count=(/nx,ny,ncat,1/) ) + start=(/1,1,1,lnrec/), & + count=(/nx,ny,ncat,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif status = nf90_get_att(fid, varid, "_FillValue", missingvalue) @@ -1363,20 +1436,20 @@ subroutine ice_read_nc_xyz(fid, nrec, varname, work, diag, & !------------------------------------------------------------------- if (my_task==master_task .and. diag) then - write(nu_diag,*) & - 'ice_read_nc_xyz, fid= ',fid, ', nrec = ',nrec, & + write(nu_diag,'(2a,i8,a,i8,2a)') & + subname,' fid= ',fid, ', lnrec = ',lnrec, & ', varname = ',trim(varname) ! status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) -! write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar +! write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar ! do id=1,ndim ! status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) -! write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen +! write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen ! enddo do n=1,ncat amin = minval(work_g1(:,:,n)) amax = maxval(work_g1(:,:,n), mask = work_g1(:,:,n) /= missingvalue) asum = sum (work_g1(:,:,n), mask = work_g1(:,:,n) /= missingvalue) - write(nu_diag,*) ' min, max, sum =', amin, amax, asum, trim(varname) + write(nu_diag,*) subname,' min, max, sum =', amin, amax, asum, trim(varname) enddo endif @@ -1410,8 +1483,8 @@ subroutine ice_read_nc_xyz(fid, nrec, varname, work, diag, & if (orca_halogrid .and. .not. present(restart_ext)) deallocate(work_g2) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) work = c0 ! to satisfy intent(out) attribute #endif end subroutine ice_read_nc_xyz @@ -1465,26 +1538,34 @@ subroutine ice_read_nc_xyf(fid, nrec, varname, work, diag, & ndim, nvar, & ! sizes of netcdf file id, & ! dimension index n, & ! ncat index - dimlen ! size of dimension + ndims, & ! number of dimensions + dimlen ! dimension size + + integer (kind=int_kind), dimension(10) :: & + dimids ! generic size dimids real (kind=dbl_kind) :: & missingvalue, & ! missing value amin, amax, asum ! min, max values and sum of input array character (char_len) :: & - dimname ! dimension name + dimname ! dimension name real (kind=dbl_kind), dimension(:,:,:), allocatable :: & work_g1 integer (kind=int_kind) :: nx, ny + integer (kind=int_kind) :: lnrec ! local value of nrec + character(len=*), parameter :: subname = '(ice_read_nc_xyf)' #ifdef USE_NETCDF real (kind=dbl_kind), dimension(:,:,:), allocatable :: & work_g2 + lnrec = nrec + if (orca_halogrid .and. .not. present(restart_ext)) then if (my_task == master_task) then allocate(work_g2(nx_global+2,ny_global+1,nfreq)) @@ -1517,10 +1598,31 @@ subroutine ice_read_nc_xyf(fid, nrec, varname, work, diag, & !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice ( & - 'ice_read_nc_xyf: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + + !------------------------------------------------------------- + ! Check nrec axis size + !------------------------------------------------------------- + + status = nf90_inquire_variable(fid, varid, ndims=ndims, dimids=dimids) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire variable dimids '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (ndims > 3) then + status = nf90_inquire_dimension(fid, dimids(4), len=dimlen) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire dimension size 4 '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (lnrec > dimlen) then + write(nu_diag,*) subname,' ERROR not enough records, ',trim(varname),lnrec,dimlen + call abort_ice(subname//' ERROR: not enough records '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif !-------------------------------------------------------------- @@ -1529,13 +1631,21 @@ subroutine ice_read_nc_xyf(fid, nrec, varname, work, diag, & if (orca_halogrid .and. .not. present(restart_ext)) then status = nf90_get_var( fid, varid, work_g2, & - start=(/1,1,1,nrec/), & - count=(/nx_global+2,ny_global+1,nfreq,1/) ) + start=(/1,1,1,lnrec/), & + count=(/nx_global+2,ny_global+1,nfreq,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif work_g1 = work_g2(2:nx_global+1,1:ny_global,:) else status = nf90_get_var( fid, varid, work_g1, & - start=(/1,1,1,nrec/), & - count=(/nx,ny,nfreq,1/) ) + start=(/1,1,1,lnrec/), & + count=(/nx,ny,nfreq,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif status = nf90_get_att(fid, varid, "missing_value", missingvalue) @@ -1546,21 +1656,21 @@ subroutine ice_read_nc_xyf(fid, nrec, varname, work, diag, & !------------------------------------------------------------------- if (my_task==master_task .and. diag) then - write(nu_diag,*) & - 'ice_read_nc_xyf, fid= ',fid, ', nrec = ',nrec, & + write(nu_diag,'(2a,i8,a,i8,2a)') & + subname,' fid= ',fid, ', lnrec = ',lnrec, & ', varname = ',trim(varname) status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) - write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar + write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar do id=1,ndim status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) - write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen + write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen enddo - write(nu_diag,*) 'missingvalue= ',missingvalue + write(nu_diag,*) subname,' missingvalue= ',missingvalue do n = 1, nfreq amin = minval(work_g1(:,:,n)) amax = maxval(work_g1(:,:,n), mask = work_g1(:,:,n) /= missingvalue) asum = sum (work_g1(:,:,n), mask = work_g1(:,:,n) /= missingvalue) - write(nu_diag,*) ' min, max, sum =', amin, amax, asum + write(nu_diag,*) subname,' min, max, sum =', amin, amax, asum enddo endif @@ -1597,8 +1707,8 @@ subroutine ice_read_nc_xyf(fid, nrec, varname, work, diag, & if (orca_halogrid .and. .not. present(restart_ext)) deallocate(work_g2) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) work = c0 ! to satisfy intent(out) attribute #endif @@ -1640,24 +1750,54 @@ subroutine ice_read_nc_point(fid, nrec, varname, work, diag, & status, & ! status output from netcdf routines ndim, nvar, & ! sizes of netcdf file id, & ! dimension index - dimlen ! size of dimension + ndims, & ! number of dimensions + dimlen ! dimension size + + integer (kind=int_kind), dimension(10) :: & + dimids ! generic size dimids real (kind=dbl_kind), dimension(1) :: & workg ! temporary work variable + integer (kind=int_kind) :: lnrec ! local value of nrec + character (char_len) :: & - dimname ! dimension name + dimname ! dimension name - if (my_task == master_task) then + lnrec = nrec + + if (my_task == master_task) then !------------------------------------------------------------- ! Find out ID of required variable !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + + !------------------------------------------------------------- + ! Check nrec axis size + !------------------------------------------------------------- + + status = nf90_inquire_variable(fid, varid, ndims=ndims, dimids=dimids) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire variable dimids '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (ndims > 0) then + status = nf90_inquire_dimension(fid, dimids(1), len=dimlen) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire dimension size 1 '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (lnrec > dimlen) then + write(nu_diag,*) subname,' ERROR not enough records, ',trim(varname),lnrec,dimlen + call abort_ice(subname//' ERROR: not enough records '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif !-------------------------------------------------------------- @@ -1665,11 +1805,11 @@ subroutine ice_read_nc_point(fid, nrec, varname, work, diag, & !-------------------------------------------------------------- status = nf90_get_var(fid, varid, workg, & - start= (/ nrec /), & - count=(/ 1 /) ) - - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot get variable '//trim(varname) ) + start= (/ lnrec /), & + count=(/ 1 /)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) endif endif ! my_task = master_task @@ -1678,28 +1818,299 @@ subroutine ice_read_nc_point(fid, nrec, varname, work, diag, & !------------------------------------------------------------------- if (my_task==master_task .and. diag) then - write(nu_diag,*) & - 'ice_read_nc_point, fid= ',fid, ', nrec = ',nrec, & + write(nu_diag,'(2a,i8,a,i8,2a)') & + subname,' fid= ',fid, ', lnrec = ',lnrec, & ', varname = ',trim(varname) status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) - write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar + write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar do id=1,ndim status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) - write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen + write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen enddo endif work = workg(1) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) work = c0 ! to satisfy intent(out) attribute #endif end subroutine ice_read_nc_point !======================================================================= +! Written by T. Craig + + subroutine ice_read_nc_1D(fid, varname, work, diag, & + xdim) + + use ice_fileunits, only: nu_diag + + integer (kind=int_kind), intent(in) :: & + fid , & ! file id + xdim ! field dimensions + + logical (kind=log_kind), intent(in) :: & + diag ! if true, write diagnostic output + + character (char_len), intent(in) :: & + varname ! field name in netcdf file + + real (kind=dbl_kind), dimension(:), intent(out) :: & + work ! output array + + ! local variables + + character(len=*), parameter :: subname = '(ice_read_nc_1D)' + +#ifdef USE_NETCDF +! netCDF file diagnostics: + integer (kind=int_kind) :: & + varid, & ! netcdf id for field + status, & ! status output from netcdf routines + ndim, nvar, & ! sizes of netcdf file + dimlen ! size of dimension + + character (char_len) :: & + dimname ! dimension name + + real (kind=dbl_kind), dimension(xdim) :: & + workg ! output array (real, 8-byte) + + !-------------------------------------------------------------- + + if (my_task == master_task) then + + if (size(work,dim=1) < xdim) then + write(nu_diag,*) subname,' work, dim=1 ',size(work,dim=1),xdim + call abort_ice (subname//' ERROR: work array wrong size '//trim(varname), & + file=__FILE__, line=__LINE__ ) + endif + !------------------------------------------------------------- + ! Find out ID of required variable + !------------------------------------------------------------- + + status = nf90_inq_varid(fid, trim(varname), varid) + + if (status /= nf90_noerr) then + call abort_ice (subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__ ) + endif + + !-------------------------------------------------------------- + ! Read array + !-------------------------------------------------------------- + status = nf90_get_var( fid, varid, workg, & + start=(/1/), & + count=(/xdim/) ) + work(1:xdim) = workg(1:xdim) + + !------------------------------------------------------------------- + ! optional diagnostics + !------------------------------------------------------------------- + + if (diag) then + write(nu_diag,*) subname, & + ' fid= ',fid, ', xdim = ',xdim, & + ' varname = ',trim(varname) + status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) + write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar + endif + endif +#else + call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) + work = c0 ! to satisfy intent(out) attribute +#endif + + end subroutine ice_read_nc_1D + +!======================================================================= + +! Written by T. Craig + + subroutine ice_read_nc_2D(fid, varname, work, diag, & + xdim, ydim) + + use ice_fileunits, only: nu_diag + + integer (kind=int_kind), intent(in) :: & + fid , & ! file id + xdim, ydim ! field dimensions + + logical (kind=log_kind), intent(in) :: & + diag ! if true, write diagnostic output + + character (char_len), intent(in) :: & + varname ! field name in netcdf file + + real (kind=dbl_kind), dimension(:,:), intent(out) :: & + work ! output array + + ! local variables + + character(len=*), parameter :: subname = '(ice_read_nc_2D)' + +#ifdef USE_NETCDF +! netCDF file diagnostics: + integer (kind=int_kind) :: & + varid, & ! netcdf id for field + status, & ! status output from netcdf routines + ndim, nvar, & ! sizes of netcdf file + dimlen ! size of dimension + + character (char_len) :: & + dimname ! dimension name + + real (kind=dbl_kind), dimension(xdim,ydim) :: & + workg ! output array (real, 8-byte) + + !-------------------------------------------------------------- + + if (my_task == master_task) then + + if (size(work,dim=1) < xdim .or. & + size(work,dim=2) < ydim) then + write(nu_diag,*) subname,' work, dim=1 ',size(work,dim=1),xdim + write(nu_diag,*) subname,' work, dim=2 ',size(work,dim=2),ydim + call abort_ice (subname//' ERROR: work array wrong size '//trim(varname), & + file=__FILE__, line=__LINE__ ) + endif + !------------------------------------------------------------- + ! Find out ID of required variable + !------------------------------------------------------------- + + status = nf90_inq_varid(fid, trim(varname), varid) + + if (status /= nf90_noerr) then + call abort_ice (subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__ ) + endif + + !-------------------------------------------------------------- + ! Read array + !-------------------------------------------------------------- + status = nf90_get_var( fid, varid, workg, & + start=(/1,1/), & + count=(/xdim,ydim/) ) + work(1:xdim,1:ydim) = workg(1:xdim, 1:ydim) + + !------------------------------------------------------------------- + ! optional diagnostics + !------------------------------------------------------------------- + + if (diag) then + write(nu_diag,*) subname, & + ' fid= ',fid, ', xdim = ',xdim, & + ' ydim= ', ydim, ' varname = ',trim(varname) + status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) + write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar + endif + endif +#else + call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) + work = c0 ! to satisfy intent(out) attribute +#endif + + end subroutine ice_read_nc_2D + +!======================================================================= +!======================================================================= + +! Written by T. Craig + + subroutine ice_read_nc_3D(fid, varname, work, diag, & + xdim, ydim, zdim) + + use ice_fileunits, only: nu_diag + + integer (kind=int_kind), intent(in) :: & + fid , & ! file id + xdim, ydim,zdim ! field dimensions + + logical (kind=log_kind), intent(in) :: & + diag ! if true, write diagnostic output + + character (char_len), intent(in) :: & + varname ! field name in netcdf file + + real (kind=dbl_kind), dimension(:,:,:), intent(out) :: & + work ! output array + + ! local variables + + character(len=*), parameter :: subname = '(ice_read_nc_3D)' + +#ifdef USE_NETCDF +! netCDF file diagnostics: + integer (kind=int_kind) :: & + varid, & ! netcdf id for field + status, & ! status output from netcdf routines + ndim, nvar, & ! sizes of netcdf file + dimlen ! size of dimension + + character (char_len) :: & + dimname ! dimension name + + real (kind=dbl_kind), dimension(xdim,ydim,zdim) :: & + workg ! output array (real, 8-byte) + + !-------------------------------------------------------------- + + if (my_task == master_task) then + + if (size(work,dim=1) < xdim .or. & + size(work,dim=2) < ydim .or. & + size(work,dim=3) < zdim ) then + write(nu_diag,*) subname,' work, dim=1 ',size(work,dim=1),xdim + write(nu_diag,*) subname,' work, dim=2 ',size(work,dim=2),ydim + write(nu_diag,*) subname,' work, dim=3 ',size(work,dim=3),zdim + call abort_ice (subname//' ERROR: work array wrong size '//trim(varname), & + file=__FILE__, line=__LINE__ ) + endif + !------------------------------------------------------------- + ! Find out ID of required variable + !------------------------------------------------------------- + + status = nf90_inq_varid(fid, trim(varname), varid) + + if (status /= nf90_noerr) then + call abort_ice (subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__ ) + endif + + !-------------------------------------------------------------- + ! Read array + !-------------------------------------------------------------- + status = nf90_get_var( fid, varid, workg, & + start=(/1,1,1/), & + count=(/xdim,ydim,zdim/) ) + work(1:xdim,1:ydim,1:zdim) = workg(1:xdim, 1:ydim, 1:zdim) + + !------------------------------------------------------------------- + ! optional diagnostics + !------------------------------------------------------------------- + + if (diag) then + write(nu_diag,*) subname, & + ' fid= ',fid, ', xdim = ',xdim, & + ' ydim= ', ydim,' zdim = ',zdim, ' varname = ',trim(varname) + status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) + write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar + endif + endif +#else + call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) + work = c0 ! to satisfy intent(out) attribute +#endif + + end subroutine ice_read_nc_3D + +!======================================================================= + ! Adapted by Nicole Jeffery, LANL subroutine ice_read_nc_z(fid, nrec, varname, work, diag, & @@ -1736,16 +2147,25 @@ subroutine ice_read_nc_z(fid, nrec, varname, work, diag, & status, & ! status output from netcdf routines ndim, nvar, & ! sizes of netcdf file id, & ! dimension index - dimlen ! size of dimension + ndims, & ! number of dimensions + dimlen ! dimension size + + integer (kind=int_kind), dimension(10) :: & + dimids ! generic size dimids character (char_len) :: & dimname ! dimension name + + integer (kind=int_kind) :: lnrec ! local value of nrec + #endif character(len=*), parameter :: subname = '(ice_read_nc_z)' #ifdef USE_NETCDF + lnrec = nrec + allocate(work_z(nilyr)) if (my_task == master_task) then @@ -1755,9 +2175,31 @@ subroutine ice_read_nc_z(fid, nrec, varname, work, diag, & !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + + !------------------------------------------------------------- + ! Check nrec axis size + !------------------------------------------------------------- + + status = nf90_inquire_variable(fid, varid, ndims=ndims, dimids=dimids) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire variable dimids '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (ndims > 1) then + status = nf90_inquire_dimension(fid, dimids(2), len=dimlen) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: inquire dimension size 2 '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + if (lnrec > dimlen) then + write(nu_diag,*) subname,' ERROR not enough records, ',trim(varname),lnrec,dimlen + call abort_ice(subname//' ERROR: not enough records '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif !-------------------------------------------------------------- @@ -1765,9 +2207,12 @@ subroutine ice_read_nc_z(fid, nrec, varname, work, diag, & !-------------------------------------------------------------- status = nf90_get_var( fid, varid, work_z, & - start=(/1,nrec/), & - count=(/nilyr,1/) ) - + start=(/1,lnrec/), & + count=(/nilyr,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif ! my_task = master_task !------------------------------------------------------------------- @@ -1775,14 +2220,14 @@ subroutine ice_read_nc_z(fid, nrec, varname, work, diag, & !------------------------------------------------------------------- if (my_task==master_task .and. diag) then - write(nu_diag,*) & - 'ice_read_nc_z, fid= ',fid, ', nrec = ',nrec, & + write(nu_diag,'(2a,i8,a,i8,2a)') & + subname,' fid= ',fid, ', lnrec = ',lnrec, & ', varname = ',trim(varname) status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) - write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar + write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar do id=1,ndim status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) - write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen + write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen enddo endif @@ -1790,8 +2235,8 @@ subroutine ice_read_nc_z(fid, nrec, varname, work, diag, & deallocate(work_z) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) work = c0 ! to satisfy intent(out) attribute #endif end subroutine ice_read_nc_z @@ -1826,7 +2271,7 @@ subroutine ice_write_nc_xy(fid, nrec, varid, work, diag, & ! local variables - character(len=*), parameter :: subname = '(ice_read_nc_xy)' + character(len=*), parameter :: subname = '(ice_write_nc_xy)' #ifdef USE_NETCDF ! netCDF file diagnostics: @@ -1841,7 +2286,7 @@ subroutine ice_write_nc_xy(fid, nrec, varid, work, diag, & character (char_len) :: & lvarname ! variable name -! dimname ! dimension name +! dimname ! dimension name real (kind=dbl_kind), dimension(:,:), allocatable :: & work_g1 @@ -1886,7 +2331,7 @@ subroutine ice_write_nc_xy(fid, nrec, varid, work, diag, & status = nf90_put_var( fid, varid, work_g1, & start=(/1,1,nrec/), & - count=(/nx,ny,1/) ) + count=(/nx,ny,1/)) endif ! my_task = master_task @@ -1896,25 +2341,25 @@ subroutine ice_write_nc_xy(fid, nrec, varid, work, diag, & if (my_task==master_task .and. diag) then ! write(nu_diag,*) & -! 'ice_write_nc_xy, fid= ',fid, ', nrec = ',nrec, & +! subname,' fid= ',fid, ', nrec = ',nrec, & ! ', varid = ',varid ! status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) -! write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar +! write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar ! do id=1,ndim ! status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) -! write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen +! write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen ! enddo amin = minval(work_g1) amax = maxval(work_g1, mask = work_g1 /= spval_dbl) asum = sum (work_g1, mask = work_g1 /= spval_dbl) - write(nu_diag,*) ' min, max, sum =', amin, amax, asum, trim(lvarname) + write(nu_diag,*) subname,' min, max, sum =', amin, amax, asum, trim(lvarname) endif deallocate(work_g1) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) #endif end subroutine ice_write_nc_xy @@ -1949,7 +2394,7 @@ subroutine ice_write_nc_xyz(fid, nrec, varid, work, diag, & ! local variables - character(len=*), parameter :: subname = '(ice_read_nc_xyz)' + character(len=*), parameter :: subname = '(ice_write_nc_xyz)' #ifdef USE_NETCDF ! netCDF file diagnostics: @@ -1965,7 +2410,7 @@ subroutine ice_write_nc_xyz(fid, nrec, varid, work, diag, & character (char_len) :: & lvarname ! variable name -! dimname ! dimension name +! dimname ! dimension name real (kind=dbl_kind), dimension(:,:,:), allocatable :: & work_g1 @@ -2016,7 +2461,7 @@ subroutine ice_write_nc_xyz(fid, nrec, varid, work, diag, & status = nf90_put_var( fid, varid, work_g1, & start=(/1,1,1,nrec/), & - count=(/nx,ny,ncat,1/) ) + count=(/nx,ny,ncat,1/)) endif ! my_task = master_task @@ -2026,13 +2471,13 @@ subroutine ice_write_nc_xyz(fid, nrec, varid, work, diag, & if (my_task==master_task .and. diag) then ! write(nu_diag,*) & -! 'ice_write_nc_xyz, fid= ',fid, ', nrec = ',nrec, & +! subname,' fid= ',fid, ', nrec = ',nrec, & ! ', varid = ',varid ! status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) -! write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar +! write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar ! do id=1,ndim ! status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) -! write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen +! write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen ! enddo amin = 10000._dbl_kind amax = -10000._dbl_kind @@ -2040,15 +2485,15 @@ subroutine ice_write_nc_xyz(fid, nrec, varid, work, diag, & amin = minval(work_g1(:,:,n)) amax = maxval(work_g1(:,:,n), mask = work_g1(:,:,n) /= spval_dbl) asum = sum (work_g1(:,:,n), mask = work_g1(:,:,n) /= spval_dbl) - write(nu_diag,*) ' min, max, sum =', amin, amax, asum, trim(lvarname) + write(nu_diag,*) subname,' min, max, sum =', amin, amax, asum, trim(lvarname) enddo endif deallocate(work_g1) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) #endif end subroutine ice_write_nc_xyz @@ -2094,7 +2539,7 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) amin, amax, asum ! min, max values and sum of input array ! character (char_len) :: & -! dimname ! dimension name +! dimname ! dimension name ! real (kind=dbl_kind), dimension(:,:), allocatable :: & work_g3 @@ -2117,9 +2562,9 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) endif !-------------------------------------------------------------- @@ -2129,12 +2574,20 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) if (orca_halogrid) then status = nf90_get_var( fid, varid, work_g3, & start=(/1,1,nrec/), & - count=(/nx_global+2,ny_global+1,1/) ) + count=(/nx_global+2,ny_global+1,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif work_g=work_g3(2:nx_global+1,1:ny_global) else status = nf90_get_var( fid, varid, work_g, & start=(/1,1,nrec/), & - count=(/nx_global,ny_global,1/) ) + count=(/nx_global,ny_global,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif endif ! my_task = master_task @@ -2144,25 +2597,25 @@ subroutine ice_read_global_nc (fid, nrec, varname, work_g, diag) if (my_task == master_task .and. diag) then ! write(nu_diag,*) & -! 'ice_read_global_nc, fid= ',fid, ', nrec = ',nrec, & +! subname,' fid= ',fid, ', nrec = ',nrec, & ! ', varname = ',trim(varname) ! status = nf90_inquire(fid, nDimensions=ndim, nVariables=nvar) -! write(nu_diag,*) 'ndim= ',ndim,', nvar= ',nvar +! write(nu_diag,*) subname,' ndim= ',ndim,', nvar= ',nvar ! do id=1,ndim ! status = nf90_inquire_dimension(fid,id,name=dimname,len=dimlen) -! write(nu_diag,*) 'Dim name = ',trim(dimname),', size = ',dimlen +! write(nu_diag,*) subname,' Dim name = ',trim(dimname),', size = ',dimlen ! enddo amin = minval(work_g) amax = maxval(work_g, mask = work_g /= spval_dbl) asum = sum (work_g, mask = work_g /= spval_dbl) - write(nu_diag,*) 'min, max, sum = ', amin, amax, asum, trim(varname) + write(nu_diag,*) subname,' min, max, sum = ', amin, amax, asum, trim(varname) endif if (orca_halogrid) deallocate(work_g3) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) work_g = c0 ! to satisfy intent(out) attribute #endif @@ -2190,8 +2643,8 @@ subroutine ice_close_nc(fid) status = nf90_close(fid) endif #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) #endif end subroutine ice_close_nc @@ -2249,7 +2702,7 @@ subroutine ice_read_nc_uv(fid, nrec, nzlev, varname, work, diag, & amin, amax, asum ! min, max values and sum of input array ! character (char_len) :: & -! dimname ! dimension name +! dimname ! dimension name real (kind=dbl_kind), dimension(:,:), allocatable :: & work_g1 @@ -2279,9 +2732,9 @@ subroutine ice_read_nc_uv(fid, nrec, nzlev, varname, work, diag, & !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) endif !-------------------------------------------------------------- @@ -2290,7 +2743,11 @@ subroutine ice_read_nc_uv(fid, nrec, nzlev, varname, work, diag, & status = nf90_get_var( fid, varid, work_g1, & start=(/1,1,nzlev,nrec/), & - count=(/nx,ny,1,1/) ) + count=(/nx,ny,1,1/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif endif ! my_task = master_task @@ -2302,7 +2759,7 @@ subroutine ice_read_nc_uv(fid, nrec, nzlev, varname, work, diag, & amin = minval(work_g1) amax = maxval(work_g1, mask = work_g1 /= spval_dbl) asum = sum (work_g1, mask = work_g1 /= spval_dbl) - write(nu_diag,*) ' min, max, sum =', amin, amax, asum, trim(varname) + write(nu_diag,*) subname,' min, max, sum =', amin, amax, asum, trim(varname) endif !------------------------------------------------------------------- @@ -2327,8 +2784,8 @@ subroutine ice_read_nc_uv(fid, nrec, nzlev, varname, work, diag, & deallocate(work_g1) #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) work = c0 ! to satisfy intent(out) attribute #endif @@ -2380,9 +2837,9 @@ subroutine ice_read_vec_nc (fid, nrec, varname, work_g, diag) !------------------------------------------------------------- status = nf90_inq_varid(fid, trim(varname), varid) - if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: Cannot find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Cannot find variable '//trim(varname), & + file=__FILE__, line=__LINE__) endif !-------------------------------------------------------------- @@ -2391,7 +2848,12 @@ subroutine ice_read_vec_nc (fid, nrec, varname, work_g, diag) status = nf90_get_var( fid, varid, work_g, & start=(/1/), & - count=(/nrec/) ) + count=(/nrec/)) + if (status /= nf90_noerr) then + call abort_ice(subname//' ERROR: Cannot get variable '//trim(varname), & + file=__FILE__, line=__LINE__) + endif + endif ! my_task = master_task !------------------------------------------------------------------- @@ -2401,12 +2863,12 @@ subroutine ice_read_vec_nc (fid, nrec, varname, work_g, diag) if (my_task == master_task .and. diag) then amin = minval(work_g) amax = maxval(work_g) - write(nu_diag,*) 'min, max, nrec = ', amin, amax, nrec + write(nu_diag,*) subname,' min, max, nrec = ', amin, amax, nrec endif #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) work_g = c0 ! to satisfy intent(out) attribute #endif @@ -2437,22 +2899,25 @@ subroutine ice_get_ncvarsize(fid,varname,recsize) if (my_task == master_task) then status=nf90_inquire(fid, nDimensions = nDims) if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: inquire nDimensions' ) + call abort_ice(subname//' ERROR: inquire nDimensions', & + file=__FILE__, line=__LINE__ ) endif do i=1,nDims status = nf90_inquire_dimension(fid,i,name=cvar,len=recsize) if (status /= nf90_noerr) then - call abort_ice (subname//'ERROR: inquire len for variable '//trim(cvar) ) + call abort_ice(subname//' ERROR: inquire len for variable '//trim(cvar), & + file=__FILE__, line=__LINE__) endif if (trim(cvar) == trim(varname)) exit enddo if (trim(cvar) .ne. trim(varname)) then - call abort_ice (subname//'ERROR: Did not find variable '//trim(varname) ) + call abort_ice(subname//' ERROR: Did not find variable '//trim(varname), & + file=__FILE__, line=__LINE__) endif endif #else - call abort_ice(subname//'ERROR: USE_NETCDF cpp not defined', & - file=__FILE__, line=__LINE__) + call abort_ice(subname//' ERROR: USE_NETCDF cpp not defined', & + file=__FILE__, line=__LINE__) recsize = 0 ! to satisfy intent(out) attribute #endif diff --git a/cicecore/cicedynB/infrastructure/io/io_binary/ice_restart.F90 b/cicecore/cicedynB/infrastructure/io/io_binary/ice_restart.F90 index 91d57ea48..a6f42a6a5 100644 --- a/cicecore/cicedynB/infrastructure/io/io_binary/ice_restart.F90 +++ b/cicecore/cicedynB/infrastructure/io/io_binary/ice_restart.F90 @@ -15,11 +15,12 @@ module ice_restart use ice_fileunits, only: nu_diag, nu_rst_pointer use ice_fileunits, only: nu_dump, nu_dump_eap, nu_dump_FY, nu_dump_age use ice_fileunits, only: nu_dump_lvl, nu_dump_pond, nu_dump_hbrine - use ice_fileunits, only: nu_dump_bgc, nu_dump_aero, nu_dump_fsd, nu_dump_iso + use ice_fileunits, only: nu_dump_iso, nu_dump_snow + use ice_fileunits, only: nu_dump_bgc, nu_dump_aero, nu_dump_fsd use ice_fileunits, only: nu_restart, nu_restart_eap, nu_restart_FY, nu_restart_age use ice_fileunits, only: nu_restart_lvl, nu_restart_pond, nu_restart_hbrine use ice_fileunits, only: nu_restart_bgc, nu_restart_aero, nu_restart_fsd - use ice_fileunits, only: nu_restart_iso + use ice_fileunits, only: nu_restart_iso, nu_restart_snow use ice_exit, only: abort_ice use icepack_intfc, only: icepack_query_parameters use icepack_intfc, only: icepack_query_tracer_sizes @@ -57,7 +58,7 @@ subroutine init_restart_read(ice_ic) logical (kind=log_kind) :: & solve_zsal, tr_fsd, & tr_iage, tr_FY, tr_lvl, tr_iso, tr_aero, tr_pond_cesm, & - tr_pond_topo, tr_pond_lvl, tr_brine + tr_pond_topo, tr_pond_lvl, tr_brine, tr_snow character(len=char_len_long) :: & filename, filename0 @@ -82,7 +83,8 @@ subroutine init_restart_read(ice_ic) call icepack_query_tracer_flags( & tr_iage_out=tr_iage, tr_FY_out=tr_FY, tr_lvl_out=tr_lvl, tr_fsd_out=tr_fsd, & tr_iso_out=tr_iso, tr_aero_out=tr_aero, tr_pond_cesm_out=tr_pond_cesm, & - tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, tr_brine_out=tr_brine) + tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, & + tr_snow_out=tr_snow, tr_brine_out=tr_brine) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) @@ -285,6 +287,26 @@ subroutine init_restart_read(ice_ic) endif endif + if (tr_snow) then + if (my_task == master_task) then + n = index(filename0,trim(restart_file)) + if (n == 0) call abort_ice(subname//'ERROR: snow restart: filename discrepancy') + string1 = trim(filename0(1:n-1)) + string2 = trim(filename0(n+lenstr(restart_file):lenstr(filename0))) + write(filename,'(a,a,a,a)') & + string1(1:lenstr(string1)), & + restart_file(1:lenstr(restart_file)),'.snow', & + string2(1:lenstr(string2)) + if (restart_ext) then + call ice_open_ext(nu_restart_snow,filename,0) + else + call ice_open(nu_restart_snow,filename,0) + endif + read (nu_restart_snow) iignore,rignore,rignore + write(nu_diag,*) 'Reading ',filename(1:lenstr(filename)) + endif + endif + if (tr_brine) then if (my_task == master_task) then n = index(filename0,trim(restart_file)) @@ -392,7 +414,7 @@ subroutine init_restart_write(filename_spec) logical (kind=log_kind) :: & solve_zsal, tr_fsd, & tr_iage, tr_FY, tr_lvl, tr_iso, tr_aero, tr_pond_cesm, & - tr_pond_topo, tr_pond_lvl, tr_brine + tr_pond_topo, tr_pond_lvl, tr_brine, tr_snow integer (kind=int_kind) :: & nbtrcr ! number of bgc tracers @@ -408,7 +430,8 @@ subroutine init_restart_write(filename_spec) call icepack_query_tracer_flags( & tr_iage_out=tr_iage, tr_FY_out=tr_FY, tr_lvl_out=tr_lvl, tr_fsd_out=tr_fsd, & tr_iso_out=tr_iso, tr_aero_out=tr_aero, tr_pond_cesm_out=tr_pond_cesm, & - tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, tr_brine_out=tr_brine) + tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, & + tr_snow_out=tr_snow, tr_brine_out=tr_brine) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) @@ -599,6 +622,26 @@ subroutine init_restart_write(filename_spec) endif + if (tr_snow) then + + write(filename,'(a,a,a,i4.4,a,i2.2,a,i2.2,a,i5.5)') & + restart_dir(1:lenstr(restart_dir)), & + restart_file(1:lenstr(restart_file)),'.snow.', & + myear,'-',mmonth,'-',mday,'-',msec + + if (restart_ext) then + call ice_open_ext(nu_dump_snow,filename,0) + else + call ice_open(nu_dump_snow,filename,0) + endif + + if (my_task == master_task) then + write(nu_dump_snow) istep1,timesecs,time_forc + write(nu_diag,*) 'Writing ',filename(1:lenstr(filename)) + endif + + endif + if (tr_brine) then write(filename,'(a,a,a,i4.4,a,i2.2,a,i2.2,a,i5.5)') & @@ -808,7 +851,7 @@ subroutine final_restart() logical (kind=log_kind) :: & solve_zsal, & tr_iage, tr_FY, tr_lvl, tr_iso, tr_aero, tr_pond_cesm, & - tr_pond_topo, tr_pond_lvl, tr_brine + tr_pond_topo, tr_pond_lvl, tr_brine, tr_snow integer (kind=int_kind) :: & nbtrcr ! number of bgc tracers @@ -822,7 +865,8 @@ subroutine final_restart() call icepack_query_tracer_flags( & tr_iage_out=tr_iage, tr_FY_out=tr_FY, tr_lvl_out=tr_lvl, & tr_iso_out=tr_iso, tr_aero_out=tr_aero, tr_pond_cesm_out=tr_pond_cesm, & - tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, tr_brine_out=tr_brine) + tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, & + tr_snow_out=tr_snow, tr_brine_out=tr_brine) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) @@ -838,6 +882,7 @@ subroutine final_restart() if (tr_pond_cesm) close(nu_dump_pond) if (tr_pond_lvl) close(nu_dump_pond) if (tr_pond_topo) close(nu_dump_pond) + if (tr_snow) close(nu_dump_snow) if (tr_brine) close(nu_dump_hbrine) if (solve_zsal .or. nbtrcr > 0) & close(nu_dump_bgc) diff --git a/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_history_write.F90 b/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_history_write.F90 index 9c6b30ee1..493a91c1e 100644 --- a/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_history_write.F90 +++ b/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_history_write.F90 @@ -48,8 +48,8 @@ subroutine ice_write_hist (ns) use ice_blocks, only: nx_block, ny_block use ice_broadcast, only: broadcast_scalar use ice_calendar, only: msec, timesecs, idate, idate0, write_ic, & - histfreq, days_per_year, use_leap_years, dayyr, & - year_init, month_init, day_init + histfreq, histfreq_n, days_per_year, use_leap_years, dayyr, & + hh_init, mm_init, ss_init use ice_communicate, only: my_task, master_task use ice_domain, only: distrb_info use ice_domain_size, only: nx_global, ny_global, max_nstrm, max_blocks @@ -67,11 +67,9 @@ subroutine ice_write_hist (ns) ! local variables - real (kind=dbl_kind), dimension(:,:), allocatable :: work_g1 - real (kind=real_kind), dimension(:,:), allocatable :: work_gr - real (kind=real_kind), dimension(:,:,:), allocatable :: work_gr3 - real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & - work1 + real (kind=dbl_kind), dimension(:,:), allocatable :: work_g1 + real (kind=dbl_kind), dimension(:,:,:), allocatable :: work1_3 + real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: work1 integer (kind=int_kind) :: i,k,ic,n,nn, & ncid,status,imtid,jmtid,kmtidi,kmtids,kmtidb, cmtid,timid,varid, & @@ -205,7 +203,6 @@ subroutine ice_write_hist (ns) ! define coordinate variables !----------------------------------------------------------------- -!sgl status = nf90_def_var(ncid,'time',nf90_float,timid,varid) status = nf90_def_var(ncid,'time',nf90_double,timid,varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining var time') @@ -215,8 +212,9 @@ subroutine ice_write_hist (ns) 'ice Error: time long_name') write(cdate,'(i8.8)') idate0 - write(title,'(a,a,a,a,a,a,a,a)') 'days since ', & - cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' 00:00:00' + write(title,'(a,a4,a1,a2,a1,a2,a1,i2.2,a1,i2.2,a1,i2.2)') 'days since ', & + cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' ', & + hh_init,':',mm_init,':',ss_init status = nf90_put_att(ncid,varid,'units',title) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: time units') @@ -258,8 +256,9 @@ subroutine ice_write_hist (ns) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: time_bounds long_name') write(cdate,'(i8.8)') idate0 - write(title,'(a,a,a,a,a,a,a,a)') 'days since ', & - cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' 00:00:00' + write(title,'(a,a4,a1,a2,a1,a2,a1,i2.2,a1,i2.2,a1,i2.2)') 'days since ', & + cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' ', & + hh_init,':',mm_init,':',ss_init status = nf90_put_att(ncid,varid,'units',title) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: time_bounds units') @@ -361,20 +360,7 @@ subroutine ice_write_hist (ns) status = nf90_put_att(ncid, varid, 'units', coord_var(i)%units) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining units for '//coord_var(i)%short_name) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//coord_var(i)%short_name) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//coord_var(i)%short_name) + call ice_write_hist_fill(ncid,varid,coord_var(i)%short_name,history_precision) if (coord_var(i)%short_name == 'ULAT') then status = nf90_put_att(ncid,varid,'comment', & 'Latitude of NE corner of T grid cell') @@ -421,18 +407,7 @@ subroutine ice_write_hist (ns) if (status /= nf90_noerr) call abort_ice(subname//'ERROR: tmask units') status = nf90_put_att(ncid,varid,'comment', '0 = land, 1 = ocean') if (status /= nf90_noerr) call abort_ice(subname//'ERROR: tmask comment') - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname//'ERROR: defining missing_value for tmask') - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname//'ERROR: defining _FillValue for tmask') + call ice_write_hist_fill(ncid,varid,'tmask',history_precision) endif if (igrd(n_blkmask)) then @@ -444,18 +419,7 @@ subroutine ice_write_hist (ns) if (status /= nf90_noerr) call abort_ice(subname//'ERROR: blkmask units') status = nf90_put_att(ncid,varid,'comment', 'mytask + iblk/100') if (status /= nf90_noerr) call abort_ice(subname//'ERROR: blkmask comment') - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname//'ERROR: defining missing_value for blkmask') - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname//'ERROR: defining _FillValue for blkmask') + call ice_write_hist_fill(ncid,varid,'blkmask',history_precision) endif do i = 3, nvar ! note n_tmask=1, n_blkmask=2 @@ -473,20 +437,7 @@ subroutine ice_write_hist (ns) status = nf90_put_att(ncid, varid, 'coordinates', var(i)%coordinates) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining coordinates for '//var(i)%req%short_name) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//var(i)%req%short_name) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//var(i)%req%short_name) + call ice_write_hist_fill(ncid,varid,var(i)%req%short_name,history_precision) endif enddo @@ -506,20 +457,7 @@ subroutine ice_write_hist (ns) status = nf90_put_att(ncid, varid, 'units', var_nverts(i)%units) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining units for '//var_nverts(i)%short_name) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//var_nverts(i)%short_name) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//var_nverts(i)%short_name) + call ice_write_hist_fill(ncid,varid,var_nverts(i)%short_name,history_precision) endif enddo @@ -545,20 +483,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) !----------------------------------------------------------------- ! Add cell_methods attribute to variables if averaged @@ -575,7 +500,8 @@ subroutine ice_write_hist (ns) endif endif - if (histfreq(ns) == '1' .or. .not. hist_avg & + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg & .or. n==n_divu(ns) .or. n==n_shear(ns) & ! snapshots .or. n==n_sig1(ns) .or. n==n_sig2(ns) & .or. n==n_sigP(ns) .or. n==n_trsig(ns) & @@ -616,20 +542,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) !----------------------------------------------------------------- ! Add cell_methods attribute to variables if averaged @@ -640,7 +553,8 @@ subroutine ice_write_hist (ns) 'ERROR: defining cell methods for '//avail_hist_fields(n)%vname) endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = nf90_put_att(ncid,varid,'time_rep','instantaneous') else status = nf90_put_att(ncid,varid,'time_rep','averaged') @@ -675,20 +589,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) endif enddo ! num_avail_hist_fields_3Dz @@ -720,20 +621,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) endif enddo ! num_avail_hist_fields_3Db @@ -765,20 +653,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) endif enddo ! num_avail_hist_fields_3Da @@ -810,20 +685,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) endif enddo ! num_avail_hist_fields_3Df @@ -857,20 +719,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) !----------------------------------------------------------------- ! Add cell_methods attribute to variables if averaged @@ -881,7 +730,8 @@ subroutine ice_write_hist (ns) 'ERROR: defining cell methods for '//avail_hist_fields(n)%vname) endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = nf90_put_att(ncid,varid,'time_rep','instantaneous') else status = nf90_put_att(ncid,varid,'time_rep','averaged') @@ -918,20 +768,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) !----------------------------------------------------------------- ! Add cell_methods attribute to variables if averaged @@ -942,7 +779,8 @@ subroutine ice_write_hist (ns) 'ERROR: defining cell methods for '//avail_hist_fields(n)%vname) endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = nf90_put_att(ncid,varid,'time_rep','instantaneous') else status = nf90_put_att(ncid,varid,'time_rep','averaged') @@ -979,20 +817,7 @@ subroutine ice_write_hist (ns) avail_hist_fields(n)%vcellmeas) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: defining cell measures for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'missing_value',spval) - else - status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining missing_value for '//avail_hist_fields(n)%vname) - if (lprecision == nf90_float) then - status = nf90_put_att(ncid,varid,'_FillValue',spval) - else - status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) - endif - if (status /= nf90_noerr) call abort_ice(subname// & - 'ERROR: defining _FillValue for '//avail_hist_fields(n)%vname) + call ice_write_hist_fill(ncid,varid,avail_hist_fields(n)%vname,history_precision) !----------------------------------------------------------------- ! Add cell_methods attribute to variables if averaged @@ -1003,7 +828,8 @@ subroutine ice_write_hist (ns) 'ERROR: defining cell methods for '//avail_hist_fields(n)%vname) endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = nf90_put_att(ncid,varid,'time_rep','instantaneous') else status = nf90_put_att(ncid,varid,'time_rep','averaged') @@ -1114,9 +940,7 @@ subroutine ice_write_hist (ns) if (my_task==master_task) then allocate(work_g1(nx_global,ny_global)) - allocate(work_gr(nx_global,ny_global)) else - allocate(work_gr(1,1)) ! to save memory allocate(work_g1(1,1)) endif @@ -1147,11 +971,10 @@ subroutine ice_write_hist (ns) END SELECT if (my_task == master_task) then - work_gr = work_g1 status = nf90_inq_varid(ncid, coord_var(i)%short_name, varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: getting varid for '//coord_var(i)%short_name) - status = nf90_put_var(ncid,varid,work_gr) + status = nf90_put_var(ncid,varid,work_g1) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: writing'//coord_var(i)%short_name) endif @@ -1193,11 +1016,10 @@ subroutine ice_write_hist (ns) if (igrd(n_tmask)) then call gather_global(work_g1, hm, master_task, distrb_info) if (my_task == master_task) then - work_gr=work_g1 status = nf90_inq_varid(ncid, 'tmask', varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: getting varid for tmask') - status = nf90_put_var(ncid,varid,work_gr) + status = nf90_put_var(ncid,varid,work_g1) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: writing variable tmask') endif @@ -1206,11 +1028,10 @@ subroutine ice_write_hist (ns) if (igrd(n_blkmask)) then call gather_global(work_g1, bm, master_task, distrb_info) if (my_task == master_task) then - work_gr=work_g1 status = nf90_inq_varid(ncid, 'blkmask', varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: getting varid for blkmask') - status = nf90_put_var(ncid,varid,work_gr) + status = nf90_put_var(ncid,varid,work_g1) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: writing variable blkmask') endif @@ -1243,31 +1064,28 @@ subroutine ice_write_hist (ns) END SELECT if (my_task == master_task) then - work_gr=work_g1 status = nf90_inq_varid(ncid, var(i)%req%short_name, varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: getting varid for '//var(i)%req%short_name) - status = nf90_put_var(ncid,varid,work_gr) + status = nf90_put_var(ncid,varid,work_g1) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: writing variable '//var(i)%req%short_name) endif endif enddo - deallocate(work_gr) - !---------------------------------------------------------------- ! Write coordinates of grid box vertices !---------------------------------------------------------------- if (f_bounds) then if (my_task==master_task) then - allocate(work_gr3(nverts,nx_global,ny_global)) + allocate(work1_3(nverts,nx_global,ny_global)) else - allocate(work_gr3(1,1,1)) ! to save memory + allocate(work1_3(1,1,1)) ! to save memory endif - work_gr3(:,:,:) = c0 + work1_3(:,:,:) = c0 work1 (:,:,:) = c0 do i = 1, nvar_verts @@ -1277,25 +1095,25 @@ subroutine ice_write_hist (ns) do ivertex = 1, nverts work1(:,:,:) = lont_bounds(ivertex,:,:,:) call gather_global(work_g1, work1, master_task, distrb_info) - if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + if (my_task == master_task) work1_3(ivertex,:,:) = work_g1(:,:) enddo CASE ('latt_bounds') do ivertex = 1, nverts work1(:,:,:) = latt_bounds(ivertex,:,:,:) call gather_global(work_g1, work1, master_task, distrb_info) - if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + if (my_task == master_task) work1_3(ivertex,:,:) = work_g1(:,:) enddo CASE ('lonu_bounds') do ivertex = 1, nverts work1(:,:,:) = lonu_bounds(ivertex,:,:,:) call gather_global(work_g1, work1, master_task, distrb_info) - if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + if (my_task == master_task) work1_3(ivertex,:,:) = work_g1(:,:) enddo CASE ('latu_bounds') do ivertex = 1, nverts work1(:,:,:) = latu_bounds(ivertex,:,:,:) call gather_global(work_g1, work1, master_task, distrb_info) - if (my_task == master_task) work_gr3(ivertex,:,:) = work_g1(:,:) + if (my_task == master_task) work1_3(ivertex,:,:) = work_g1(:,:) enddo END SELECT @@ -1303,24 +1121,18 @@ subroutine ice_write_hist (ns) status = nf90_inq_varid(ncid, var_nverts(i)%short_name, varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: getting varid for '//var_nverts(i)%short_name) - status = nf90_put_var(ncid,varid,work_gr3) + status = nf90_put_var(ncid,varid,work1_3) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: writing variable '//var_nverts(i)%short_name) endif enddo - deallocate(work_gr3) + deallocate(work1_3) endif !----------------------------------------------------------------- ! write variable data !----------------------------------------------------------------- - if (my_task==master_task) then - allocate(work_gr(nx_global,ny_global)) - else - allocate(work_gr(1,1)) ! to save memory - endif - work_gr(:,:) = c0 work_g1(:,:) = c0 do n=1,num_avail_hist_fields_2D @@ -1328,19 +1140,18 @@ subroutine ice_write_hist (ns) call gather_global(work_g1, a2D(:,:,n,:), & master_task, distrb_info) if (my_task == master_task) then - work_gr(:,:) = work_g1(:,:) status = nf90_inq_varid(ncid,avail_hist_fields(n)%vname,varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: getting varid for '//avail_hist_fields(n)%vname) - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & count=(/nx_global,ny_global/)) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: writing variable '//avail_hist_fields(n)%vname) endif + endif enddo ! num_avail_hist_fields_2D - work_gr(:,:) = c0 work_g1(:,:) = c0 do n = n2D + 1, n3Dccum @@ -1354,13 +1165,12 @@ subroutine ice_write_hist (ns) do k = 1, ncat_hist call gather_global(work_g1, a3Dc(:,:,k,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then status = nf90_inq_varid(ncid,avail_hist_fields(n)%vname,varid) if (status /= nf90_noerr) call abort_ice(subname// & 'ERROR: getting varid for '//avail_hist_fields(n)%vname) - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k/), & count=(/nx_global,ny_global,1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1370,7 +1180,6 @@ subroutine ice_write_hist (ns) endif enddo ! num_avail_hist_fields_3Dc - work_gr(:,:) = c0 work_g1(:,:) = c0 do n = n3Dccum+1, n3Dzcum @@ -1384,10 +1193,9 @@ subroutine ice_write_hist (ns) do k = 1, nzilyr call gather_global(work_g1, a3Dz(:,:,k,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k/), & count=(/nx_global,ny_global,1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1397,7 +1205,6 @@ subroutine ice_write_hist (ns) endif enddo ! num_avail_hist_fields_3Dz - work_gr(:,:) = c0 work_g1(:,:) = c0 do n = n3Dzcum+1, n3Dbcum @@ -1411,10 +1218,9 @@ subroutine ice_write_hist (ns) do k = 1, nzblyr call gather_global(work_g1, a3Db(:,:,k,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k/), & count=(/nx_global,ny_global,1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1424,7 +1230,6 @@ subroutine ice_write_hist (ns) endif enddo ! num_avail_hist_fields_3Db - work_gr(:,:) = c0 work_g1(:,:) = c0 do n = n3Dbcum+1, n3Dacum @@ -1438,10 +1243,9 @@ subroutine ice_write_hist (ns) do k = 1, nzalyr call gather_global(work_g1, a3Da(:,:,k,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k/), & count=(/nx_global,ny_global,1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1451,7 +1255,6 @@ subroutine ice_write_hist (ns) endif enddo ! num_avail_hist_fields_3Da - work_gr(:,:) = c0 work_g1(:,:) = c0 do n = n3Dacum+1, n3Dfcum @@ -1465,9 +1268,8 @@ subroutine ice_write_hist (ns) do k = 1, nfsd_hist call gather_global(work_g1, a3Df(:,:,k,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k/), & count=(/nx_global,ny_global,1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1477,7 +1279,6 @@ subroutine ice_write_hist (ns) endif enddo ! num_avail_hist_fields_3Df - work_gr(:,:) = c0 work_g1(:,:) = c0 do n = n3Dfcum+1, n4Dicum @@ -1492,9 +1293,8 @@ subroutine ice_write_hist (ns) do k = 1, nzilyr call gather_global(work_g1, a4Di(:,:,k,ic,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k,ic/), & count=(/nx_global,ny_global,1, 1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1505,7 +1305,6 @@ subroutine ice_write_hist (ns) endif enddo ! num_avail_hist_fields_4Di - work_gr(:,:) = c0 work_g1(:,:) = c0 do n = n4Dicum+1, n4Dscum @@ -1520,9 +1319,8 @@ subroutine ice_write_hist (ns) do k = 1, nzslyr call gather_global(work_g1, a4Ds(:,:,k,ic,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k,ic/), & count=(/nx_global,ny_global,1, 1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1545,9 +1343,8 @@ subroutine ice_write_hist (ns) do k = 1, nfsd_hist call gather_global(work_g1, a4Df(:,:,k,ic,nn,:), & master_task, distrb_info) - work_gr(:,:) = work_g1(:,:) if (my_task == master_task) then - status = nf90_put_var(ncid,varid,work_gr(:,:), & + status = nf90_put_var(ncid,varid,work_g1, & start=(/ 1, 1,k,ic/), & count=(/nx_global,ny_global,1, 1/)) if (status /= nf90_noerr) call abort_ice(subname// & @@ -1558,7 +1355,6 @@ subroutine ice_write_hist (ns) endif enddo ! num_avail_hist_fields_4Df - deallocate(work_gr) deallocate(work_g1) !----------------------------------------------------------------- @@ -1580,6 +1376,43 @@ subroutine ice_write_hist (ns) end subroutine ice_write_hist +!======================================================================= + + subroutine ice_write_hist_fill(ncid,varid,vname,precision) + + use ice_kinds_mod +#ifdef USE_NETCDF + use netcdf +#endif + + integer (kind=int_kind), intent(in) :: ncid ! netcdf file id + integer (kind=int_kind), intent(in) :: varid ! netcdf var id + character(len=*), intent(in) :: vname ! var name + integer (kind=int_kind), intent(in) :: precision ! precision + + ! local variables + + integer (kind=int_kind) :: status + character(len=*), parameter :: subname = '(ice_write_hist_fill)' + + if (precision == 8) then + status = nf90_put_att(ncid,varid,'missing_value',spval_dbl) + else + status = nf90_put_att(ncid,varid,'missing_value',spval) + endif + if (status /= nf90_noerr) call abort_ice(subname// & + 'ERROR: defining missing_value for '//trim(vname)) + + if (precision == 8) then + status = nf90_put_att(ncid,varid,'_FillValue',spval_dbl) + else + status = nf90_put_att(ncid,varid,'_FillValue',spval) + endif + if (status /= nf90_noerr) call abort_ice(subname// & + 'ERROR: defining _FillValue for '//trim(vname)) + + end subroutine ice_write_hist_fill + !======================================================================= end module ice_history_write diff --git a/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_restart.F90 b/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_restart.F90 index e744caf09..f6002ff40 100644 --- a/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_restart.F90 +++ b/cicecore/cicedynB/infrastructure/io/io_netcdf/ice_restart.F90 @@ -145,7 +145,7 @@ subroutine init_restart_write(filename_spec) logical (kind=log_kind) :: & solve_zsal, skl_bgc, z_tracers, tr_fsd, & tr_iage, tr_FY, tr_lvl, tr_iso, tr_aero, tr_pond_cesm, & - tr_pond_topo, tr_pond_lvl, tr_brine, & + tr_pond_topo, tr_pond_lvl, tr_brine, tr_snow, & tr_bgc_N, tr_bgc_C, tr_bgc_Nit, & tr_bgc_Sil, tr_bgc_DMS, & tr_bgc_chl, tr_bgc_Am, & @@ -181,7 +181,8 @@ subroutine init_restart_write(filename_spec) call icepack_query_tracer_flags( & tr_iage_out=tr_iage, tr_FY_out=tr_FY, tr_lvl_out=tr_lvl, tr_fsd_out=tr_fsd, & tr_iso_out=tr_iso, tr_aero_out=tr_aero, tr_pond_cesm_out=tr_pond_cesm, & - tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, tr_brine_out=tr_brine, & + tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, & + tr_snow_out=tr_snow, tr_brine_out=tr_brine, & tr_bgc_N_out=tr_bgc_N, tr_bgc_C_out=tr_bgc_C, tr_bgc_Nit_out=tr_bgc_Nit, & tr_bgc_Sil_out=tr_bgc_Sil, tr_bgc_DMS_out=tr_bgc_DMS, & tr_bgc_chl_out=tr_bgc_chl, tr_bgc_Am_out=tr_bgc_Am, & @@ -480,6 +481,16 @@ subroutine init_restart_write(filename_spec) call define_rest_field(ncid,'qsno'//trim(nchar),dims) enddo + if (tr_snow) then + do k=1,nslyr + write(nchar,'(i3.3)') k + call define_rest_field(ncid,'smice'//trim(nchar),dims) + call define_rest_field(ncid,'smliq'//trim(nchar),dims) + call define_rest_field(ncid, 'rhos'//trim(nchar),dims) + call define_rest_field(ncid, 'rsnw'//trim(nchar),dims) + enddo + endif + if (tr_fsd) then do k=1,nfsd write(nchar,'(i3.3)') k diff --git a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_history_write.F90 b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_history_write.F90 index 72a1ed97f..0e91d42d0 100644 --- a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_history_write.F90 +++ b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_history_write.F90 @@ -18,6 +18,7 @@ module ice_history_write use ice_kinds_mod + use ice_constants, only: c0, c360, spval, spval_dbl use ice_fileunits, only: nu_diag use ice_exit, only: abort_ice use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted @@ -42,9 +43,9 @@ subroutine ice_write_hist (ns) use ice_blocks, only: nx_block, ny_block use ice_broadcast, only: broadcast_scalar use ice_calendar, only: msec, timesecs, idate, idate0, write_ic, & - histfreq, days_per_year, use_leap_years, dayyr + histfreq, histfreq_n, days_per_year, use_leap_years, dayyr, & + hh_init, mm_init, ss_init use ice_communicate, only: my_task, master_task - use ice_constants, only: c0, c360, spval, spval_dbl use ice_domain, only: distrb_info, nblocks use ice_domain_size, only: nx_global, ny_global, max_blocks, max_nstrm use ice_gather_scatter, only: gather_global @@ -70,7 +71,6 @@ subroutine ice_write_hist (ns) integer (kind=int_kind), dimension(5) :: dimidcz integer (kind=int_kind), dimension(3) :: dimid_nverts integer (kind=int_kind), dimension(6) :: dimidex - real (kind=real_kind) :: ltime real (kind= dbl_kind) :: ltime2 character (char_len) :: title character (char_len_long) :: ncfile(max_nstrm) @@ -116,10 +116,15 @@ subroutine ice_write_hist (ns) TYPE(coord_attributes), dimension(nvarz) :: var_nz CHARACTER (char_len), dimension(ncoord) :: coord_bounds - real (kind=dbl_kind), allocatable :: workr2(:,:,:) - real (kind=dbl_kind), allocatable :: workr3(:,:,:,:) - real (kind=dbl_kind), allocatable :: workr4(:,:,:,:,:) - real (kind=dbl_kind), allocatable :: workr3v(:,:,:,:) + real (kind=dbl_kind) , allocatable :: workd2(:,:,:) + real (kind=dbl_kind) , allocatable :: workd3(:,:,:,:) + real (kind=dbl_kind) , allocatable :: workd4(:,:,:,:,:) + real (kind=dbl_kind) , allocatable :: workd3v(:,:,:,:) + + real (kind=real_kind), allocatable :: workr2(:,:,:) + real (kind=real_kind), allocatable :: workr3(:,:,:,:) + real (kind=real_kind), allocatable :: workr4(:,:,:,:,:) + real (kind=real_kind), allocatable :: workr3v(:,:,:,:) character(len=char_len_long) :: & filename @@ -164,19 +169,18 @@ subroutine ice_write_hist (ns) call ice_pio_init(mode='write', filename=trim(filename), File=File, & clobber=.true., cdf64=lcdf64, iotype=iotype) - call ice_pio_initdecomp(iodesc=iodesc2d) - call ice_pio_initdecomp(ndim3=ncat_hist, iodesc=iodesc3dc) - call ice_pio_initdecomp(ndim3=nzilyr, iodesc=iodesc3di) - call ice_pio_initdecomp(ndim3=nzblyr, iodesc=iodesc3db) - call ice_pio_initdecomp(ndim3=nzalyr, iodesc=iodesc3da) - call ice_pio_initdecomp(ndim3=nfsd_hist, iodesc=iodesc3df) - call ice_pio_initdecomp(ndim3=nverts, iodesc=iodesc3dv, inner_dim=.true.) - call ice_pio_initdecomp(ndim3=nzilyr, ndim4=ncat_hist, iodesc=iodesc4di) - call ice_pio_initdecomp(ndim3=nzslyr, ndim4=ncat_hist, iodesc=iodesc4ds) - call ice_pio_initdecomp(ndim3=nfsd_hist, ndim4=ncat_hist, iodesc=iodesc4df) + call ice_pio_initdecomp(iodesc=iodesc2d, precision=history_precision) + call ice_pio_initdecomp(ndim3=ncat_hist, iodesc=iodesc3dc, precision=history_precision) + call ice_pio_initdecomp(ndim3=nzilyr, iodesc=iodesc3di, precision=history_precision) + call ice_pio_initdecomp(ndim3=nzblyr, iodesc=iodesc3db, precision=history_precision) + call ice_pio_initdecomp(ndim3=nzalyr, iodesc=iodesc3da, precision=history_precision) + call ice_pio_initdecomp(ndim3=nfsd_hist, iodesc=iodesc3df, precision=history_precision) + call ice_pio_initdecomp(ndim3=nverts, iodesc=iodesc3dv, inner_dim=.true., precision=history_precision) + call ice_pio_initdecomp(ndim3=nzilyr, ndim4=ncat_hist, iodesc=iodesc4di, precision=history_precision) + call ice_pio_initdecomp(ndim3=nzslyr, ndim4=ncat_hist, iodesc=iodesc4ds, precision=history_precision) + call ice_pio_initdecomp(ndim3=nfsd_hist, ndim4=ncat_hist, iodesc=iodesc4df, precision=history_precision) ltime2 = timesecs/secday - ltime = real(timesecs/secday,kind=real_kind) ! option of turning on double precision history files lprecision = pio_real @@ -186,7 +190,7 @@ subroutine ice_write_hist (ns) ! define dimensions !----------------------------------------------------------------- - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_def_dim(File,'d2',2,boundid) endif @@ -205,13 +209,13 @@ subroutine ice_write_hist (ns) ! define coordinate variables: time, time_bounds !----------------------------------------------------------------- -!sgl status = pio_def_var(File,'time',pio_real,(/timid/),varid) status = pio_def_var(File,'time',pio_double,(/timid/),varid) status = pio_put_att(File,varid,'long_name','model time') write(cdate,'(i8.8)') idate0 - write(title,'(a,a,a,a,a,a,a)') 'days since ', & - cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' 00:00:00' + write(title,'(a,a4,a1,a2,a1,a2,a1,i2.2,a1,i2.2,a1,i2.2)') 'days since ', & + cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' ', & + hh_init,':',mm_init,':',ss_init status = pio_put_att(File,varid,'units',trim(title)) if (days_per_year == 360) then @@ -224,21 +228,21 @@ subroutine ice_write_hist (ns) call abort_ice(subname//'ERROR: invalid calendar settings') endif - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'bounds','time_bounds') endif ! Define attributes for time_bounds if hist_avg is true - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then dimid2(1) = boundid dimid2(2) = timid -!sgl status = pio_def_var(File,'time_bounds',pio_real,dimid2,varid) status = pio_def_var(File,'time_bounds',pio_double,dimid2,varid) status = pio_put_att(File,varid,'long_name', & 'boundaries for time-averaging interval') write(cdate,'(i8.8)') idate0 - write(title,'(a,a,a,a,a,a,a,a)') 'days since ', & - cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' 00:00:00' + write(title,'(a,a4,a1,a2,a1,a2,a1,i2.2,a1,i2.2,a1,i2.2)') 'days since ', & + cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),' ', & + hh_init,':',mm_init,':',ss_init status = pio_put_att(File,varid,'units',trim(title)) endif @@ -340,13 +344,7 @@ subroutine ice_write_hist (ns) dimid2, varid) status = pio_put_att(File,varid,'long_name',trim(coord_var(i)%long_name)) status = pio_put_att(File, varid, 'units', trim(coord_var(i)%units)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,coord_var(i)%short_name,history_precision) if (coord_var(i)%short_name == 'ULAT') then status = pio_put_att(File,varid,'comment', & trim('Latitude of NE corner of T grid cell')) @@ -378,13 +376,7 @@ subroutine ice_write_hist (ns) status = pio_def_var(File, 'tmask', lprecision, dimid2, varid) status = pio_put_att(File,varid, 'long_name', 'ocean grid mask') status = pio_put_att(File, varid, 'coordinates', 'TLON TLAT') - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,'tmask',history_precision) status = pio_put_att(File,varid,'comment', '0 = land, 1 = ocean') endif if (igrd(n_blkmask)) then @@ -392,13 +384,7 @@ subroutine ice_write_hist (ns) status = pio_put_att(File,varid, 'long_name', 'ice grid block mask') status = pio_put_att(File, varid, 'coordinates', 'TLON TLAT') status = pio_put_att(File,varid,'comment', 'mytask + iblk/100') - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,'blkmask',history_precision) endif do i = 3, nvar ! note: n_tmask=1, n_blkmask=2 @@ -408,13 +394,7 @@ subroutine ice_write_hist (ns) status = pio_put_att(File,varid, 'long_name', trim(var(i)%req%long_name)) status = pio_put_att(File, varid, 'units', trim(var(i)%req%units)) status = pio_put_att(File, varid, 'coordinates', trim(var(i)%coordinates)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,var(i)%req%short_name,history_precision) endif enddo @@ -430,13 +410,7 @@ subroutine ice_write_hist (ns) pio_put_att(File,varid, 'long_name', trim(var_nverts(i)%long_name)) status = & pio_put_att(File, varid, 'units', trim(var_nverts(i)%units)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,var_nverts(i)%short_name,history_precision) endif enddo @@ -464,16 +438,10 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then if (TRIM(avail_hist_fields(n)%vname)/='sig1' & .or.TRIM(avail_hist_fields(n)%vname)/='sig2' & .or.TRIM(avail_hist_fields(n)%vname)/='sistreave' & @@ -483,7 +451,8 @@ subroutine ice_write_hist (ns) endif endif - if (histfreq(ns) == '1' .or. .not. hist_avg & + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg & .or. n==n_divu(ns) .or. n==n_shear(ns) & ! snapshots .or. n==n_sig1(ns) .or. n==n_sig2(ns) & .or. n==n_sigP(ns) .or. n==n_trsig(ns) & @@ -518,20 +487,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -560,20 +524,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -602,20 +561,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -644,20 +598,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -686,20 +635,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -734,20 +678,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -777,20 +716,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -821,20 +755,15 @@ subroutine ice_write_hist (ns) trim(avail_hist_fields(n)%vcoord)) status = pio_put_att(File,varid,'cell_measures', & trim(avail_hist_fields(n)%vcellmeas)) - if (lprecision == pio_real) then - status = pio_put_att(File, varid, 'missing_value', spval) - status = pio_put_att(File, varid,'_FillValue',spval) - else - status = pio_put_att(File, varid, 'missing_value', spval_dbl) - status = pio_put_att(File, varid,'_FillValue',spval_dbl) - endif + call ice_write_hist_fill(File,varid,avail_hist_fields(n)%vname,history_precision) ! Add cell_methods attribute to variables if averaged - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_put_att(File,varid,'cell_methods','time: mean') endif - if (histfreq(ns) == '1' .or. .not. hist_avg) then + if ((histfreq(ns) == '1' .and. histfreq_n(ns) == 1) & + .or..not. hist_avg) then status = pio_put_att(File,varid,'time_rep','instantaneous') else status = pio_put_att(File,varid,'time_rep','averaged') @@ -901,14 +830,13 @@ subroutine ice_write_hist (ns) !----------------------------------------------------------------- status = pio_inq_varid(File,'time',varid) -!sgl status = pio_put_var(File,varid,(/1/),ltime) status = pio_put_var(File,varid,(/1/),ltime2) !----------------------------------------------------------------- ! write time_bounds info !----------------------------------------------------------------- - if (hist_avg .and. histfreq(ns) /= '1') then + if (hist_avg) then status = pio_inq_varid(File,'time_bounds',varid) time_bounds=(/time_beg(ns),time_end(ns)/) bnd_start = (/1,1/) @@ -921,6 +849,7 @@ subroutine ice_write_hist (ns) ! write coordinate variables !----------------------------------------------------------------- + allocate(workd2(nx_block,ny_block,nblocks)) allocate(workr2(nx_block,ny_block,nblocks)) do i = 1,ncoord @@ -928,16 +857,22 @@ subroutine ice_write_hist (ns) SELECT CASE (coord_var(i)%short_name) CASE ('TLON') ! Convert T grid longitude from -180 -> 180 to 0 to 360 - workr2(:,:,:) = mod(tlon(:,:,1:nblocks)*rad_to_deg + c360, c360) + workd2(:,:,:) = mod(tlon(:,:,1:nblocks)*rad_to_deg + c360, c360) CASE ('TLAT') - workr2(:,:,:) = tlat(:,:,1:nblocks)*rad_to_deg + workd2(:,:,:) = tlat(:,:,1:nblocks)*rad_to_deg CASE ('ULON') - workr2(:,:,:) = ulon(:,:,1:nblocks)*rad_to_deg + workd2(:,:,:) = ulon(:,:,1:nblocks)*rad_to_deg CASE ('ULAT') - workr2(:,:,:) = ulat(:,:,1:nblocks)*rad_to_deg + workd2(:,:,:) = ulat(:,:,1:nblocks)*rad_to_deg END SELECT - call pio_write_darray(File, varid, iodesc2d, & - workr2, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc2d, & + workd2, status, fillval=spval_dbl) + else + workr2 = workd2 + call pio_write_darray(File, varid, iodesc2d, & + workr2, status, fillval=spval) + endif enddo ! Extra dimensions (NCAT, NFSD, VGRD*) @@ -981,33 +916,39 @@ subroutine ice_write_hist (ns) if (igrd(i)) then SELECT CASE (var(i)%req%short_name) CASE ('tmask') - workr2 = hm(:,:,1:nblocks) + workd2 = hm(:,:,1:nblocks) CASE ('blkmask') - workr2 = bm(:,:,1:nblocks) + workd2 = bm(:,:,1:nblocks) CASE ('tarea') - workr2 = tarea(:,:,1:nblocks) + workd2 = tarea(:,:,1:nblocks) CASE ('uarea') - workr2 = uarea(:,:,1:nblocks) + workd2 = uarea(:,:,1:nblocks) CASE ('dxu') - workr2 = dxu(:,:,1:nblocks) + workd2 = dxu(:,:,1:nblocks) CASE ('dyu') - workr2 = dyu(:,:,1:nblocks) + workd2 = dyu(:,:,1:nblocks) CASE ('dxt') - workr2 = dxt(:,:,1:nblocks) + workd2 = dxt(:,:,1:nblocks) CASE ('dyt') - workr2 = dyt(:,:,1:nblocks) + workd2 = dyt(:,:,1:nblocks) CASE ('HTN') - workr2 = HTN(:,:,1:nblocks) + workd2 = HTN(:,:,1:nblocks) CASE ('HTE') - workr2 = HTE(:,:,1:nblocks) + workd2 = HTE(:,:,1:nblocks) CASE ('ANGLE') - workr2 = ANGLE(:,:,1:nblocks) + workd2 = ANGLE(:,:,1:nblocks) CASE ('ANGLET') - workr2 = ANGLET(:,:,1:nblocks) + workd2 = ANGLET(:,:,1:nblocks) END SELECT status = pio_inq_varid(File, var(i)%req%short_name, varid) - call pio_write_darray(File, varid, iodesc2d, & - workr2, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc2d, & + workd2, status, fillval=spval_dbl) + else + workr2 = workd2 + call pio_write_darray(File, varid, iodesc2d, & + workr2, status, fillval=spval) + endif endif enddo @@ -1016,32 +957,40 @@ subroutine ice_write_hist (ns) !---------------------------------------------------------------- if (f_bounds) then + allocate(workd3v(nverts,nx_block,ny_block,nblocks)) allocate(workr3v(nverts,nx_block,ny_block,nblocks)) - workr3v (:,:,:,:) = c0 + workd3v (:,:,:,:) = c0 do i = 1, nvar_verts SELECT CASE (var_nverts(i)%short_name) CASE ('lont_bounds') do ivertex = 1, nverts - workr3v(ivertex,:,:,:) = lont_bounds(ivertex,:,:,1:nblocks) + workd3v(ivertex,:,:,:) = lont_bounds(ivertex,:,:,1:nblocks) enddo CASE ('latt_bounds') do ivertex = 1, nverts - workr3v(ivertex,:,:,:) = latt_bounds(ivertex,:,:,1:nblocks) + workd3v(ivertex,:,:,:) = latt_bounds(ivertex,:,:,1:nblocks) enddo CASE ('lonu_bounds') do ivertex = 1, nverts - workr3v(ivertex,:,:,:) = lonu_bounds(ivertex,:,:,1:nblocks) + workd3v(ivertex,:,:,:) = lonu_bounds(ivertex,:,:,1:nblocks) enddo CASE ('latu_bounds') do ivertex = 1, nverts - workr3v(ivertex,:,:,:) = latu_bounds(ivertex,:,:,1:nblocks) + workd3v(ivertex,:,:,:) = latu_bounds(ivertex,:,:,1:nblocks) enddo END SELECT status = pio_inq_varid(File, var_nverts(i)%short_name, varid) - call pio_write_darray(File, varid, iodesc3dv, & - workr3v, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc3dv, & + workd3v, status, fillval=spval_dbl) + else + workr3v = workd3v + call pio_write_darray(File, varid, iodesc3dv, & + workr3v, status, fillval=spval) + endif enddo + deallocate(workd3v) deallocate(workr3v) endif ! f_bounds @@ -1056,20 +1005,28 @@ subroutine ice_write_hist (ns) status = pio_inq_varid(File,avail_hist_fields(n)%vname,varid) if (status /= pio_noerr) call abort_ice(subname// & 'ERROR getting varid for '//avail_hist_fields(n)%vname) - workr2(:,:,:) = a2D(:,:,n,1:nblocks) + workd2(:,:,:) = a2D(:,:,n,1:nblocks) #ifdef CESM1_PIO call pio_setframe(varid, int(1,kind=PIO_OFFSET)) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc2d,& - workr2, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc2d,& + workd2, status, fillval=spval_dbl) + else + workr2 = workd2 + call pio_write_darray(File, varid, iodesc2d,& + workr2, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_2D + deallocate(workd2) deallocate(workr2) ! 3D (category) + allocate(workd3(nx_block,ny_block,nblocks,ncat_hist)) allocate(workr3(nx_block,ny_block,nblocks,ncat_hist)) do n = n2D + 1, n3Dccum nn = n - n2D @@ -1079,7 +1036,7 @@ subroutine ice_write_hist (ns) 'ERROR: getting varid for '//avail_hist_fields(n)%vname) do j = 1, nblocks do i = 1, ncat_hist - workr3(:,:,j,i) = a3Dc(:,:,i,nn,j) + workd3(:,:,j,i) = a3Dc(:,:,i,nn,j) enddo enddo #ifdef CESM1_PIO @@ -1087,13 +1044,21 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc3dc,& - workr3, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc3dc,& + workd3, status, fillval=spval_dbl) + else + workr3 = workd3 + call pio_write_darray(File, varid, iodesc3dc,& + workr3, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_3Dc + deallocate(workd3) deallocate(workr3) ! 3D (vertical ice) + allocate(workd3(nx_block,ny_block,nblocks,nzilyr)) allocate(workr3(nx_block,ny_block,nblocks,nzilyr)) do n = n3Dccum+1, n3Dzcum nn = n - n3Dccum @@ -1103,7 +1068,7 @@ subroutine ice_write_hist (ns) 'ERROR: getting varid for '//avail_hist_fields(n)%vname) do j = 1, nblocks do i = 1, nzilyr - workr3(:,:,j,i) = a3Dz(:,:,i,nn,j) + workd3(:,:,j,i) = a3Dz(:,:,i,nn,j) enddo enddo #ifdef CESM1_PIO @@ -1111,13 +1076,21 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc3di,& - workr3, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc3di,& + workd3, status, fillval=spval_dbl) + else + workr3 = workd3 + call pio_write_darray(File, varid, iodesc3di,& + workr3, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_3Dz + deallocate(workd3) deallocate(workr3) ! 3D (vertical ice biology) + allocate(workd3(nx_block,ny_block,nblocks,nzblyr)) allocate(workr3(nx_block,ny_block,nblocks,nzblyr)) do n = n3Dzcum+1, n3Dbcum nn = n - n3Dzcum @@ -1127,7 +1100,7 @@ subroutine ice_write_hist (ns) 'ERROR: getting varid for '//avail_hist_fields(n)%vname) do j = 1, nblocks do i = 1, nzblyr - workr3(:,:,j,i) = a3Db(:,:,i,nn,j) + workd3(:,:,j,i) = a3Db(:,:,i,nn,j) enddo enddo #ifdef CESM1_PIO @@ -1135,13 +1108,21 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc3db,& - workr3, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc3db,& + workd3, status, fillval=spval_dbl) + else + workr3 = workd3 + call pio_write_darray(File, varid, iodesc3db,& + workr3, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_3Db + deallocate(workd3) deallocate(workr3) ! 3D (vertical snow biology) + allocate(workd3(nx_block,ny_block,nblocks,nzalyr)) allocate(workr3(nx_block,ny_block,nblocks,nzalyr)) do n = n3Dbcum+1, n3Dacum nn = n - n3Dbcum @@ -1151,7 +1132,7 @@ subroutine ice_write_hist (ns) 'ERROR: getting varid for '//avail_hist_fields(n)%vname) do j = 1, nblocks do i = 1, nzalyr - workr3(:,:,j,i) = a3Da(:,:,i,nn,j) + workd3(:,:,j,i) = a3Da(:,:,i,nn,j) enddo enddo #ifdef CESM1_PIO @@ -1159,13 +1140,21 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc3da,& - workr3, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc3da,& + workd3, status, fillval=spval_dbl) + else + workr3 = workd3 + call pio_write_darray(File, varid, iodesc3da,& + workr3, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_3Db + deallocate(workd3) deallocate(workr3) ! 3D (fsd) + allocate(workd3(nx_block,ny_block,nblocks,nfsd_hist)) allocate(workr3(nx_block,ny_block,nblocks,nfsd_hist)) do n = n3Dacum+1, n3Dfcum nn = n - n3Dacum @@ -1175,7 +1164,7 @@ subroutine ice_write_hist (ns) 'ERROR: getting varid for '//avail_hist_fields(n)%vname) do j = 1, nblocks do i = 1, nfsd_hist - workr3(:,:,j,i) = a3Df(:,:,i,nn,j) + workd3(:,:,j,i) = a3Df(:,:,i,nn,j) enddo enddo #ifdef CESM1_PIO @@ -1183,12 +1172,20 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc3df,& - workr3, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc3df,& + workd3, status, fillval=spval_dbl) + else + workr3 = workd3 + call pio_write_darray(File, varid, iodesc3df,& + workr3, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_3Df + deallocate(workd3) deallocate(workr3) + allocate(workd4(nx_block,ny_block,nblocks,ncat_hist,nzilyr)) allocate(workr4(nx_block,ny_block,nblocks,ncat_hist,nzilyr)) ! 4D (categories, fsd) do n = n3Dfcum+1, n4Dicum @@ -1200,7 +1197,7 @@ subroutine ice_write_hist (ns) do j = 1, nblocks do i = 1, ncat_hist do k = 1, nzilyr - workr4(:,:,j,i,k) = a4Di(:,:,k,i,nn,j) + workd4(:,:,j,i,k) = a4Di(:,:,k,i,nn,j) enddo ! k enddo ! i enddo ! j @@ -1209,12 +1206,20 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc4di,& - workr4, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc4di,& + workd4, status, fillval=spval_dbl) + else + workr4 = workd4 + call pio_write_darray(File, varid, iodesc4di,& + workr4, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_4Di + deallocate(workd4) deallocate(workr4) + allocate(workd4(nx_block,ny_block,nblocks,ncat_hist,nzslyr)) allocate(workr4(nx_block,ny_block,nblocks,ncat_hist,nzslyr)) ! 4D (categories, vertical ice) do n = n4Dicum+1, n4Dscum @@ -1226,7 +1231,7 @@ subroutine ice_write_hist (ns) do j = 1, nblocks do i = 1, ncat_hist do k = 1, nzslyr - workr4(:,:,j,i,k) = a4Ds(:,:,k,i,nn,j) + workd4(:,:,j,i,k) = a4Ds(:,:,k,i,nn,j) enddo ! k enddo ! i enddo ! j @@ -1235,12 +1240,20 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc4ds,& - workr4, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc4ds,& + workd4, status, fillval=spval_dbl) + else + workr4 = workd4 + call pio_write_darray(File, varid, iodesc4ds,& + workr4, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_4Ds + deallocate(workd4) deallocate(workr4) + allocate(workd4(nx_block,ny_block,nblocks,ncat_hist,nfsd_hist)) allocate(workr4(nx_block,ny_block,nblocks,ncat_hist,nfsd_hist)) ! 4D (categories, vertical ice) do n = n4Dscum+1, n4Dfcum @@ -1252,7 +1265,7 @@ subroutine ice_write_hist (ns) do j = 1, nblocks do i = 1, ncat_hist do k = 1, nfsd_hist - workr4(:,:,j,i,k) = a4Df(:,:,k,i,nn,j) + workd4(:,:,j,i,k) = a4Df(:,:,k,i,nn,j) enddo ! k enddo ! i enddo ! j @@ -1261,13 +1274,20 @@ subroutine ice_write_hist (ns) #else call pio_setframe(File, varid, int(1,kind=PIO_OFFSET_KIND)) #endif - call pio_write_darray(File, varid, iodesc4df,& - workr4, status, fillval=spval_dbl) + if (history_precision == 8) then + call pio_write_darray(File, varid, iodesc4df,& + workd4, status, fillval=spval_dbl) + else + workr4 = workd4 + call pio_write_darray(File, varid, iodesc4df,& + workr4, status, fillval=spval) + endif endif enddo ! num_avail_hist_fields_4Df + deallocate(workd4) deallocate(workr4) -! similarly for num_avail_hist_fields_4Db (define workr4b, iodesc4db) +! similarly for num_avail_hist_fields_4Db (define workd4b, iodesc4db) !----------------------------------------------------------------- @@ -1297,6 +1317,34 @@ subroutine ice_write_hist (ns) end subroutine ice_write_hist +!======================================================================= + + subroutine ice_write_hist_fill(File,varid,vname,precision) + + use ice_kinds_mod + use ice_pio + use pio + + type(file_desc_t) , intent(inout) :: File + type(var_desc_t) , intent(in) :: varid + character(len=*), intent(in) :: vname ! var name + integer (kind=int_kind), intent(in) :: precision ! precision + + ! local variables + + integer (kind=int_kind) :: status + character(len=*), parameter :: subname = '(ice_write_hist_fill)' + + if (precision == 8) then + status = pio_put_att(File, varid, 'missing_value', spval_dbl) + status = pio_put_att(File, varid,'_FillValue',spval_dbl) + else + status = pio_put_att(File, varid, 'missing_value', spval) + status = pio_put_att(File, varid,'_FillValue',spval) + endif + + end subroutine ice_write_hist_fill + !======================================================================= end module ice_history_write diff --git a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_pio.F90 b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_pio.F90 index 9c65b2ce1..d4149f7bf 100644 --- a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_pio.F90 +++ b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_pio.F90 @@ -197,9 +197,10 @@ end subroutine ice_pio_init !================================================================================ - subroutine ice_pio_initdecomp_2d(iodesc) + subroutine ice_pio_initdecomp_2d(iodesc, precision) type(io_desc_t), intent(out) :: iodesc + integer(kind=int_kind), optional, intent(in) :: precision integer (kind=int_kind) :: & iblk,ilo,ihi,jlo,jhi,lon,lat,i,j,n,k @@ -207,8 +208,12 @@ subroutine ice_pio_initdecomp_2d(iodesc) type(block) :: this_block integer(kind=int_kind), pointer :: dof2d(:) + integer(kind=int_kind) :: lprecision character(len=*), parameter :: subname = '(ice_pio_initdecomp_2d)' + lprecision = 8 + if (present(precision)) lprecision = precision + allocate(dof2d(nx_block*ny_block*nblocks)) n=0 @@ -235,8 +240,13 @@ subroutine ice_pio_initdecomp_2d(iodesc) enddo !j end do - call pio_initdecomp(ice_pio_subsystem, pio_double, (/nx_global,ny_global/), & - dof2d, iodesc) + if (lprecision == 8) then + call pio_initdecomp(ice_pio_subsystem, pio_double, (/nx_global,ny_global/), & + dof2d, iodesc) + else + call pio_initdecomp(ice_pio_subsystem, pio_real, (/nx_global,ny_global/), & + dof2d, iodesc) + endif deallocate(dof2d) @@ -244,19 +254,24 @@ end subroutine ice_pio_initdecomp_2d !================================================================================ - subroutine ice_pio_initdecomp_3d (ndim3, iodesc, remap) + subroutine ice_pio_initdecomp_3d (ndim3, iodesc, remap, precision) integer(kind=int_kind), intent(in) :: ndim3 type(io_desc_t), intent(out) :: iodesc logical, optional :: remap + integer(kind=int_kind), optional, intent(in) :: precision integer (kind=int_kind) :: & iblk,ilo,ihi,jlo,jhi,lon,lat,i,j,n,k type(block) :: this_block logical :: lremap integer(kind=int_kind), pointer :: dof3d(:) + integer(kind=int_kind) :: lprecision character(len=*), parameter :: subname = '(ice_pio_initdecomp_2d)' + lprecision = 8 + if (present(precision)) lprecision = precision + allocate(dof3d(nx_block*ny_block*nblocks*ndim3)) lremap=.false. if (present(remap)) lremap=remap @@ -313,8 +328,13 @@ subroutine ice_pio_initdecomp_3d (ndim3, iodesc, remap) enddo !ndim3 endif - call pio_initdecomp(ice_pio_subsystem, pio_double, (/nx_global,ny_global,ndim3/), & - dof3d, iodesc) + if (lprecision == 8) then + call pio_initdecomp(ice_pio_subsystem, pio_double, (/nx_global,ny_global,ndim3/), & + dof3d, iodesc) + else + call pio_initdecomp(ice_pio_subsystem, pio_real, (/nx_global,ny_global,ndim3/), & + dof3d, iodesc) + endif deallocate(dof3d) @@ -322,11 +342,12 @@ end subroutine ice_pio_initdecomp_3d !================================================================================ - subroutine ice_pio_initdecomp_3d_inner(ndim3, inner_dim, iodesc) + subroutine ice_pio_initdecomp_3d_inner(ndim3, inner_dim, iodesc, precision) integer(kind=int_kind), intent(in) :: ndim3 logical, intent(in) :: inner_dim type(io_desc_t), intent(out) :: iodesc + integer(kind=int_kind), optional, intent(in) :: precision integer (kind=int_kind) :: & iblk,ilo,ihi,jlo,jhi,lon,lat,i,j,n,k @@ -334,9 +355,12 @@ subroutine ice_pio_initdecomp_3d_inner(ndim3, inner_dim, iodesc) type(block) :: this_block integer(kind=int_kind), pointer :: dof3d(:) - + integer(kind=int_kind) :: lprecision character(len=*), parameter :: subname = '(ice_pio_initdecomp_3d_inner)' + lprecision = 8 + if (present(precision)) lprecision = precision + allocate(dof3d(nx_block*ny_block*nblocks*ndim3)) n=0 @@ -365,8 +389,13 @@ subroutine ice_pio_initdecomp_3d_inner(ndim3, inner_dim, iodesc) enddo !j end do !iblk - call pio_initdecomp(ice_pio_subsystem, pio_double, (/ndim3,nx_global,ny_global/), & - dof3d, iodesc) + if (lprecision == 8) then + call pio_initdecomp(ice_pio_subsystem, pio_double, (/ndim3,nx_global,ny_global/), & + dof3d, iodesc) + else + call pio_initdecomp(ice_pio_subsystem, pio_real, (/ndim3,nx_global,ny_global/), & + dof3d, iodesc) + endif deallocate(dof3d) @@ -374,10 +403,11 @@ end subroutine ice_pio_initdecomp_3d_inner !================================================================================ - subroutine ice_pio_initdecomp_4d (ndim3, ndim4, iodesc) + subroutine ice_pio_initdecomp_4d (ndim3, ndim4, iodesc, precision) integer(kind=int_kind), intent(in) :: ndim3, ndim4 type(io_desc_t), intent(out) :: iodesc + integer(kind=int_kind), optional, intent(in) :: precision integer (kind=int_kind) :: & iblk,ilo,ihi,jlo,jhi,lon,lat,i,j,n,k,l @@ -385,9 +415,12 @@ subroutine ice_pio_initdecomp_4d (ndim3, ndim4, iodesc) type(block) :: this_block integer(kind=int_kind), pointer :: dof4d(:) - + integer(kind=int_kind) :: lprecision character(len=*), parameter :: subname = '(ice_pio_initdecomp_4d)' + lprecision = 8 + if (present(precision)) lprecision = precision + allocate(dof4d(nx_block*ny_block*nblocks*ndim3*ndim4)) n=0 @@ -420,8 +453,13 @@ subroutine ice_pio_initdecomp_4d (ndim3, ndim4, iodesc) enddo !ndim3 enddo !ndim4 - call pio_initdecomp(ice_pio_subsystem, pio_double, & - (/nx_global,ny_global,ndim3,ndim4/), dof4d, iodesc) + if (lprecision == 8) then + call pio_initdecomp(ice_pio_subsystem, pio_double, & + (/nx_global,ny_global,ndim3,ndim4/), dof4d, iodesc) + else + call pio_initdecomp(ice_pio_subsystem, pio_real, & + (/nx_global,ny_global,ndim3,ndim4/), dof4d, iodesc) + endif deallocate(dof4d) diff --git a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 index 12d5d8e71..0ec6b7628 100644 --- a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 +++ b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 @@ -83,8 +83,8 @@ subroutine init_restart_read(ice_ic) File%fh=-1 call ice_pio_init(mode='read', filename=trim(filename), File=File, iotype=iotype) - call ice_pio_initdecomp(iodesc=iodesc2d) - call ice_pio_initdecomp(ndim3=ncat , iodesc=iodesc3d_ncat,remap=.true.) + call ice_pio_initdecomp(iodesc=iodesc2d, precision=8) + call ice_pio_initdecomp(ndim3=ncat , iodesc=iodesc3d_ncat,remap=.true., precision=8) if (use_restart_time) then status1 = PIO_noerr @@ -151,7 +151,7 @@ subroutine init_restart_write(filename_spec) logical (kind=log_kind) :: & tr_iage, tr_FY, tr_lvl, tr_iso, tr_aero, tr_pond_cesm, & - tr_pond_topo, tr_pond_lvl, tr_brine, & + tr_pond_topo, tr_pond_lvl, tr_brine, tr_snow, & tr_bgc_N, tr_bgc_C, tr_bgc_Nit, & tr_bgc_Sil, tr_bgc_DMS, & tr_bgc_chl, tr_bgc_Am, & @@ -187,7 +187,8 @@ subroutine init_restart_write(filename_spec) call icepack_query_tracer_flags( & tr_iage_out=tr_iage, tr_FY_out=tr_FY, tr_lvl_out=tr_lvl, & tr_iso_out=tr_iso, tr_aero_out=tr_aero, tr_pond_cesm_out=tr_pond_cesm, & - tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, tr_brine_out=tr_brine, & + tr_pond_topo_out=tr_pond_topo, tr_pond_lvl_out=tr_pond_lvl, & + tr_snow_out=tr_snow, tr_brine_out=tr_brine, & tr_bgc_N_out=tr_bgc_N, tr_bgc_C_out=tr_bgc_C, tr_bgc_Nit_out=tr_bgc_Nit, & tr_bgc_Sil_out=tr_bgc_Sil, tr_bgc_DMS_out=tr_bgc_DMS, & tr_bgc_chl_out=tr_bgc_chl, tr_bgc_Am_out=tr_bgc_Am, & @@ -483,6 +484,16 @@ subroutine init_restart_write(filename_spec) call define_rest_field(File,'qsno'//trim(nchar),dims) enddo + if (tr_snow) then + do k=1,nslyr + write(nchar,'(i3.3)') k + call define_rest_field(File,'smice'//trim(nchar),dims) + call define_rest_field(File,'smliq'//trim(nchar),dims) + call define_rest_field(File, 'rhos'//trim(nchar),dims) + call define_rest_field(File, 'rsnw'//trim(nchar),dims) + enddo + endif + if (tr_fsd) then do k=1,nfsd write(nchar,'(i3.3)') k @@ -638,8 +649,8 @@ subroutine init_restart_write(filename_spec) deallocate(dims) status = pio_enddef(File) - call ice_pio_initdecomp(iodesc=iodesc2d) - call ice_pio_initdecomp(ndim3=ncat , iodesc=iodesc3d_ncat, remap=.true.) + call ice_pio_initdecomp(iodesc=iodesc2d, precision=8) + call ice_pio_initdecomp(ndim3=ncat , iodesc=iodesc3d_ncat, remap=.true., precision=8) ! endif ! restart_format diff --git a/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 b/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 index 62ff2727d..f8627d690 100644 --- a/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 +++ b/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 @@ -582,7 +582,7 @@ subroutine ice_import( importState, rc ) rhoa(i,j,iblk) = inst_pres_height_lowest / & (287.058_ESMF_KIND_R8*(1._ESMF_KIND_R8+0.608_ESMF_KIND_R8*Qa(i,j,iblk))*Tair(i,j,iblk)) else - rhoa(i,j,iblk) = 0._ESMF_KIND_R8 + rhoa(i,j,iblk) = 1.2_ESMF_KIND_R8 endif end do !i end do !j diff --git a/cicecore/drivers/standalone/cice/CICE_InitMod.F90 b/cicecore/drivers/standalone/cice/CICE_InitMod.F90 index 60f71fa8a..363025b9b 100644 --- a/cicecore/drivers/standalone/cice/CICE_InitMod.F90 +++ b/cicecore/drivers/standalone/cice/CICE_InitMod.F90 @@ -18,6 +18,7 @@ module CICE_InitMod use icepack_intfc, only: icepack_aggregate use icepack_intfc, only: icepack_init_itd, icepack_init_itd_hist use icepack_intfc, only: icepack_init_fsd_bounds, icepack_init_wave + use icepack_intfc, only: icepack_init_snow use icepack_intfc, only: icepack_configure use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted use icepack_intfc, only: icepack_query_parameters, icepack_query_tracer_flags, & @@ -76,7 +77,7 @@ subroutine cice_init use ice_flux, only: init_coupler_flux, init_history_therm, & init_history_dyn, init_flux_atm, init_flux_ocn, alloc_flux use ice_forcing, only: init_forcing_ocn, init_forcing_atmo, & - get_forcing_atmo, get_forcing_ocn, get_wave_spec + get_forcing_atmo, get_forcing_ocn, get_wave_spec, init_snowtable use ice_forcing_bgc, only: get_forcing_bgc, get_atm_bgc, & faero_default, faero_optics, alloc_forcing_bgc, fiso_default use ice_grid, only: init_grid1, init_grid2, alloc_grid @@ -90,7 +91,8 @@ subroutine cice_init use ice_transport_driver, only: init_transport logical(kind=log_kind) :: tr_aero, tr_zaero, skl_bgc, z_tracers, & - tr_iso, tr_fsd, wave_spec + tr_iso, tr_fsd, wave_spec, tr_snow + character(len=char_len) :: snw_aging_table character(len=*), parameter :: subname = '(cice_init)' call init_communicate ! initial setup for message passing @@ -162,7 +164,7 @@ subroutine cice_init call ice_HaloRestore_init ! restored boundary conditions call icepack_query_parameters(skl_bgc_out=skl_bgc, z_tracers_out=z_tracers, & - wave_spec_out=wave_spec) + wave_spec_out=wave_spec, snw_aging_table_out=snw_aging_table) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(trim(subname), & file=__FILE__,line= __LINE__) @@ -176,7 +178,7 @@ subroutine cice_init call calc_timesteps ! update timestep counter if not using npt_unit="1" call icepack_query_tracer_flags(tr_aero_out=tr_aero, tr_zaero_out=tr_zaero) - call icepack_query_tracer_flags(tr_iso_out=tr_iso) + call icepack_query_tracer_flags(tr_iso_out=tr_iso, tr_snow_out=tr_snow) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(trim(subname), & file=__FILE__,line= __LINE__) @@ -207,8 +209,20 @@ subroutine cice_init call get_forcing_atmo ! atmospheric forcing from data call get_forcing_ocn(dt) ! ocean forcing from data + ! snow aging lookup table initialization + if (tr_snow) then ! advanced snow physics + call icepack_init_snow() + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & + file=__FILE__, line=__LINE__) + if (snw_aging_table(1:4) /= 'test') then + call init_snowtable() + endif + endif + ! isotopes if (tr_iso) call fiso_default ! default values + ! aerosols ! if (tr_aero) call faero_data ! data file ! if (tr_zaero) call fzaero_data ! data file (gx1) @@ -235,12 +249,12 @@ subroutine init_restart use ice_calendar, only: calendar use ice_constants, only: c0 use ice_domain, only: nblocks - use ice_domain_size, only: ncat, n_iso, n_aero, nfsd + use ice_domain_size, only: ncat, n_iso, n_aero, nfsd, nslyr use ice_dyn_eap, only: read_restart_eap use ice_dyn_shared, only: kdyn use ice_grid, only: tmask use ice_init, only: ice_ic - use ice_init_column, only: init_age, init_FY, init_lvl, & + use ice_init_column, only: init_age, init_FY, init_lvl, init_snowtracers, & init_meltponds_cesm, init_meltponds_lvl, init_meltponds_topo, & init_isotope, init_aerosol, init_hbrine, init_bgc, init_fsd use ice_restart_column, only: restart_age, read_restart_age, & @@ -248,6 +262,7 @@ subroutine init_restart restart_pond_cesm, read_restart_pond_cesm, & restart_pond_lvl, read_restart_pond_lvl, & restart_pond_topo, read_restart_pond_topo, & + restart_snow, read_restart_snow, & restart_fsd, read_restart_fsd, & restart_iso, read_restart_iso, & restart_aero, read_restart_aero, & @@ -262,12 +277,13 @@ subroutine init_restart iblk ! block index logical(kind=log_kind) :: & tr_iage, tr_FY, tr_lvl, tr_pond_cesm, tr_pond_lvl, & - tr_pond_topo, tr_fsd, tr_iso, tr_aero, tr_brine, & + tr_pond_topo, tr_snow, tr_fsd, tr_iso, tr_aero, tr_brine, & skl_bgc, z_tracers, solve_zsal integer(kind=int_kind) :: & ntrcr integer(kind=int_kind) :: & nt_alvl, nt_vlvl, nt_apnd, nt_hpnd, nt_ipnd, & + nt_smice, nt_smliq, nt_rhos, nt_rsnw, & nt_iage, nt_FY, nt_aero, nt_fsd, nt_isosno, nt_isoice character(len=*), parameter :: subname = '(init_restart)' @@ -282,10 +298,12 @@ subroutine init_restart call icepack_query_tracer_flags(tr_iage_out=tr_iage, tr_FY_out=tr_FY, & tr_lvl_out=tr_lvl, tr_pond_cesm_out=tr_pond_cesm, tr_pond_lvl_out=tr_pond_lvl, & tr_pond_topo_out=tr_pond_topo, tr_aero_out=tr_aero, tr_brine_out=tr_brine, & - tr_fsd_out=tr_fsd, tr_iso_out=tr_iso) + tr_snow_out=tr_snow, tr_fsd_out=tr_fsd, tr_iso_out=tr_iso) call icepack_query_tracer_indices(nt_alvl_out=nt_alvl, nt_vlvl_out=nt_vlvl, & nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, nt_ipnd_out=nt_ipnd, & nt_iage_out=nt_iage, nt_FY_out=nt_FY, nt_aero_out=nt_aero, nt_fsd_out=nt_fsd, & + nt_smice_out=nt_smice, nt_smliq_out=nt_smliq, & + nt_rhos_out=nt_rhos, nt_rsnw_out=nt_rsnw, & nt_isosno_out=nt_isosno, nt_isoice_out=nt_isoice) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & @@ -382,6 +400,22 @@ subroutine init_restart enddo ! iblk endif ! .not. restart_pond endif + + ! snow redistribution/metamorphism + if (tr_snow) then + if (trim(runtype) == 'continue') restart_snow = .true. + if (restart_snow) then + call read_restart_snow + else + do iblk = 1, nblocks + call init_snowtracers(trcrn(:,:,nt_smice:nt_smice+nslyr-1,:,iblk), & + trcrn(:,:,nt_smliq:nt_smliq+nslyr-1,:,iblk), & + trcrn(:,:,nt_rhos :nt_rhos +nslyr-1,:,iblk), & + trcrn(:,:,nt_rsnw :nt_rsnw +nslyr-1,:,iblk)) + enddo ! iblk + endif + endif + ! floe size distribution if (tr_fsd) then if (trim(runtype) == 'continue') restart_fsd = .true. @@ -398,7 +432,7 @@ subroutine init_restart if (restart_iso) then call read_restart_iso else - do iblk = 1, nblocks + do iblk = 1, nblocks call init_isotope(trcrn(:,:,nt_isosno:nt_isosno+n_iso-1,:,iblk), & trcrn(:,:,nt_isoice:nt_isoice+n_iso-1,:,iblk)) enddo ! iblk diff --git a/cicecore/drivers/standalone/cice/CICE_RunMod.F90 b/cicecore/drivers/standalone/cice/CICE_RunMod.F90 index 08059435f..0fde18e04 100644 --- a/cicecore/drivers/standalone/cice/CICE_RunMod.F90 +++ b/cicecore/drivers/standalone/cice/CICE_RunMod.F90 @@ -151,12 +151,13 @@ subroutine ice_step use ice_restart_column, only: write_restart_age, write_restart_FY, & write_restart_lvl, write_restart_pond_cesm, write_restart_pond_lvl, & write_restart_pond_topo, write_restart_aero, write_restart_fsd, & - write_restart_iso, write_restart_bgc, write_restart_hbrine + write_restart_iso, write_restart_bgc, write_restart_hbrine, & + write_restart_snow use ice_restart_driver, only: dumpfile use ice_restoring, only: restore_ice, ice_HaloRestore use ice_step_mod, only: prep_radiation, step_therm1, step_therm2, & update_state, step_dyn_horiz, step_dyn_ridge, step_radiation, & - biogeochemistry, save_init, step_dyn_wave + biogeochemistry, save_init, step_dyn_wave, step_snow use ice_timers, only: ice_timer_start, ice_timer_stop, & timer_diags, timer_column, timer_thermo, timer_bound, & timer_hist, timer_readwrite @@ -170,7 +171,7 @@ subroutine ice_step offset ! d(age)/dt time offset logical (kind=log_kind) :: & - tr_iage, tr_FY, tr_lvl, tr_fsd, & + tr_iage, tr_FY, tr_lvl, tr_fsd, tr_snow, & tr_pond_cesm, tr_pond_lvl, tr_pond_topo, tr_brine, tr_iso, tr_aero, & calc_Tsfc, skl_bgc, solve_zsal, z_tracers, wave_spec @@ -191,7 +192,7 @@ subroutine ice_step call icepack_query_tracer_flags(tr_iage_out=tr_iage, tr_FY_out=tr_FY, & tr_lvl_out=tr_lvl, tr_pond_cesm_out=tr_pond_cesm, tr_pond_lvl_out=tr_pond_lvl, & tr_pond_topo_out=tr_pond_topo, tr_brine_out=tr_brine, tr_aero_out=tr_aero, & - tr_iso_out=tr_iso, tr_fsd_out=tr_fsd) + tr_iso_out=tr_iso, tr_fsd_out=tr_fsd, tr_snow_out=tr_snow) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) @@ -317,17 +318,28 @@ subroutine ice_step enddo endif + call ice_timer_start(timer_column) ! column physics + call ice_timer_start(timer_thermo) ! thermodynamics + !----------------------------------------------------------------- - ! albedo, shortwave radiation + ! snow redistribution and metamorphosis !----------------------------------------------------------------- - call ice_timer_start(timer_column) ! column physics - call ice_timer_start(timer_thermo) ! thermodynamics + if (tr_snow) then ! advanced snow physics + do iblk = 1, nblocks + call step_snow (dt, iblk) + enddo + call update_state (dt) ! clean up + endif !MHRI: CHECK THIS OMP !$OMP PARALLEL DO PRIVATE(iblk) do iblk = 1, nblocks + !----------------------------------------------------------------- + ! albedo, shortwave radiation + !----------------------------------------------------------------- + if (ktherm >= 0) call step_radiation (dt, iblk) if (debug_model) then @@ -383,6 +395,7 @@ subroutine ice_step if (tr_pond_cesm) call write_restart_pond_cesm if (tr_pond_lvl) call write_restart_pond_lvl if (tr_pond_topo) call write_restart_pond_topo + if (tr_snow) call write_restart_snow if (tr_fsd) call write_restart_fsd if (tr_iso) call write_restart_iso if (tr_aero) call write_restart_aero diff --git a/cicecore/drivers/unittest/bcstchk/bcstchk.F90 b/cicecore/drivers/unittest/bcstchk/bcstchk.F90 index e5cadc805..264931780 100644 --- a/cicecore/drivers/unittest/bcstchk/bcstchk.F90 +++ b/cicecore/drivers/unittest/bcstchk/bcstchk.F90 @@ -51,7 +51,7 @@ program bcstchk write(6,*) ' ' write(6,*) '==========================================================' write(6,*) ' ' - write(6,*) 'Running BCSTCHK' + write(6,*) 'RunningUnitTest BCSTCHK' write(6,*) ' ' write(6,*) ' npes = ',npes write(6,*) ' my_task = ',my_task @@ -257,36 +257,16 @@ program bcstchk write(6,*) errorflag1(k),stringflag1(k) enddo write(6,*) ' ' + write(6,*) 'BCSTCHK COMPLETED SUCCESSFULLY' if (errorflag0 == passflag) then - write(6,*) 'BCSTCHK COMPLETED SUCCESSFULLY' + write(6,*) 'BCSTCHK TEST COMPLETED SUCCESSFULLY' else - write(6,*) 'BCSTCHK FAILED' + write(6,*) 'BCSTCHK TEST FAILED' endif endif - ! Test abort_ice, regardless of test outcome - ! Set doabort to false to support code coverage stats, aborted runs don't seem to generate - ! gcov statistics - - call flush_fileunit(6) - call ice_barrier() - if (my_task == master_task) then - write(6,*) ' ' - write(6,*) '==========================================================' - write(6,*) ' ' - write(6,*) 'NOTE: We are testing the abort now so you should see an abort to follow' - write(6,*) 'The BCSTCHK passed, so please ignore the abort' - write(6,*) ' ' - call abort_ice(subname//' Test abort ',file=__FILE__,line=__LINE__, doabort=.false.) - endif - call flush_fileunit(6) - call ice_barrier() - - if (my_task == master_task) then - write(6,*) ' ' - write(6,*) 'BCSTCHK done' - write(6,*) ' ' - endif + ! --------------------------- + ! exit gracefully call end_run() diff --git a/cicecore/drivers/unittest/calchk/calchk.F90 b/cicecore/drivers/unittest/calchk/calchk.F90 index 09a297f1f..d669dbad3 100644 --- a/cicecore/drivers/unittest/calchk/calchk.F90 +++ b/cicecore/drivers/unittest/calchk/calchk.F90 @@ -15,13 +15,14 @@ program calchk use ice_calendar, only: init_calendar, calendar use ice_calendar, only: set_date_from_timesecs use ice_calendar, only: calendar_date2time, calendar_time2date - use ice_calendar, only: compute_calendar_data + use ice_calendar, only: compute_calendar_data, calendar_sec2hms implicit none integer(kind=int_kind) :: yearmax integer(kind=int_kind) :: nday,nptc integer(kind=int_kind) :: n,m,ny,nm,nd,nf1,nf2,xadd,nfa,nfb,nfc,ns1,ns2 integer(kind=int_kind) :: yi,mi,di,si + integer(kind=int_kind) :: hh,mm,ss integer(kind=int_kind) :: dyear,dmon,dday,dsec integer(kind=int_kind) :: fyear,fmon,fday,fsec character(len=32) :: calstr,unitstr,signstr @@ -29,7 +30,7 @@ program calchk integer (kind=int_kind) :: tdaycal(months_per_year+1) ! day count per month integer (kind=int_kind) :: tdayyr ! days in year - integer(kind=int_kind), parameter :: ntests = 8 + integer(kind=int_kind), parameter :: ntests = 9 character(len=8) :: errorflag0,errorflag(1:ntests),errorflagtmp character(len=32) :: testname(ntests) integer(kind=int_kind) :: yearv(ntests),monv(ntests),dayv(ntests),secv(ntests),ndayv(ntests) ! computed values @@ -40,7 +41,7 @@ program calchk failflag = 'FAIL' write(6,*) ' ' - write(6,*) 'Running CALCHK' + write(6,*) 'RunningUnitTest CALCHK' write(6,*) ' ' errorflag0 = passflag @@ -54,6 +55,7 @@ program calchk testname(6) = 'small add/sub update_date' testname(7) = 'special checks' testname(8) = 'calc_timesteps' + testname(9) = 'seconds_to_hms' ! test yearmax years from year 0 ! yearmax = 1000 @@ -561,6 +563,26 @@ program calchk endif enddo + !------------------------- + ! calc hms + !------------------------- + + write(6,*) ' ' + do ns1 = 0,86399 + call calendar_sec2hms(ns1,hh,mm,ss) + if (ns1 < 10 .or. ns1 > 86390 .or. (ns1 > 7195 .and. ns1 < 7205)) then + write(6,'(a,i8,2x,i2.2,a,i2.2,a,i2.2)') ' CHECK9 ',ns1,hh,':',mm,':',ss + endif + enddo + monc(9) = 23 ! hh correct result for 86399 + dayc(9) = 59 ! mm correct result for 86399 + secc(9) = 59 ! ss correct result for 86399 + if (hh /= monc(9) .or. mm /= dayc(9) .or. ss /= secc(9)) then + errorflag(9) = failflag + write(6,*) 'ERROR9: hms expected',ns1,monc(9),dayc(9),secc(9) + write(6,*) 'ERROR9: hms error ',ns1,hh,mm,ss + endif + !------------------------- ! write test results !------------------------- @@ -579,10 +601,11 @@ program calchk 1002 format(a,i10,1x,a) write(6,*) ' ' + write(6,*) 'CALCHK COMPLETED SUCCESSFULLY' if (errorflag0 == passflag) then - write(6,*) 'CALCHK COMPLETED SUCCESSFULLY' + write(6,*) 'CALCHK TEST COMPLETED SUCCESSFULLY' else - write(6,*) 'CALCHK FAILED' + write(6,*) 'CALCHK TEST FAILED' endif end program diff --git a/cicecore/drivers/unittest/helloworld/helloworld.F90 b/cicecore/drivers/unittest/helloworld/helloworld.F90 index 651436bea..c4e4ae91f 100644 --- a/cicecore/drivers/unittest/helloworld/helloworld.F90 +++ b/cicecore/drivers/unittest/helloworld/helloworld.F90 @@ -1,8 +1,9 @@ program hello_world - write(6,*) 'hello_world' - write(6,*) 'COMPLETED SUCCESSFULLY' + write(6,*) 'RunningUnitTest hello_world' + write(6,*) 'hello_world COMPLETED SUCCESSFULLY' + write(6,*) 'hello_world TEST COMPLETED SUCCESSFULLY' end program diff --git a/cicecore/drivers/unittest/sumchk/sumchk.F90 b/cicecore/drivers/unittest/sumchk/sumchk.F90 index e3b99b59d..f314959cb 100644 --- a/cicecore/drivers/unittest/sumchk/sumchk.F90 +++ b/cicecore/drivers/unittest/sumchk/sumchk.F90 @@ -107,7 +107,7 @@ program sumchk write(6,*) ' ' write(6,*) '==========================================================' write(6,*) ' ' - write(6,*) 'Running SUMCHK' + write(6,*) 'RunningUnitTest SUMCHK' write(6,*) ' ' write(6,*) ' npes = ',npes write(6,*) ' my_task = ',my_task @@ -674,10 +674,11 @@ program sumchk write(6,*) errorflag4(k),stringflag4(k) enddo write(6,*) ' ' + write(6,*) 'SUMCHK COMPLETED SUCCESSFULLY' if (errorflag0 == passflag) then - write(6,*) 'SUMCHK COMPLETED SUCCESSFULLY' + write(6,*) 'SUMCHK TEST COMPLETED SUCCESSFULLY' else - write(6,*) 'SUMCHK FAILED' + write(6,*) 'SUMCHK TEST FAILED' endif write(6,*) ' ' write(6,*) '==========================================================' diff --git a/cicecore/shared/ice_arrays_column.F90 b/cicecore/shared/ice_arrays_column.F90 index 46ea6f62e..dbad4292c 100644 --- a/cicecore/shared/ice_arrays_column.F90 +++ b/cicecore/shared/ice_arrays_column.F90 @@ -67,6 +67,15 @@ module ice_arrays_column character (len=35), public, allocatable :: c_hi_range(:) + ! icepack_snow.F90 + real (kind=dbl_kind), public, & + dimension (:,:,:), allocatable :: & + meltsliq ! snow melt mass (kg/m^2/step-->kg/m^2/day) + + real (kind=dbl_kind), public, & + dimension (:,:,:,:), allocatable :: & + meltsliqn ! snow melt mass in category n (kg/m^2) + ! icepack_meltpond_lvl.F90 real (kind=dbl_kind), public, & dimension (:,:,:,:), allocatable :: & @@ -354,6 +363,8 @@ subroutine alloc_arrays_column fzsal_g (nx_block,ny_block,max_blocks), & ! Total gravity drainage flux upNO (nx_block,ny_block,max_blocks), & ! nitrate uptake rate (mmol/m^2/d) times aice upNH (nx_block,ny_block,max_blocks), & ! ammonium uptake rate (mmol/m^2/d) times aice + meltsliq (nx_block,ny_block,max_blocks), & ! snow melt mass (kg/m^2) + meltsliqn (nx_block,ny_block,ncat,max_blocks), & ! snow melt mass in category n (kg/m^2) dhsn (nx_block,ny_block,ncat,max_blocks), & ! depth difference for snow on sea ice and pond ice ffracn (nx_block,ny_block,ncat,max_blocks), & ! fraction of fsurfn used to melt ipond alvdrn (nx_block,ny_block,ncat,max_blocks), & ! visible direct albedo (fraction) diff --git a/cicecore/shared/ice_calendar.F90 b/cicecore/shared/ice_calendar.F90 index f76b3b30b..7684fef67 100644 --- a/cicecore/shared/ice_calendar.F90 +++ b/cicecore/shared/ice_calendar.F90 @@ -47,6 +47,7 @@ module ice_calendar public :: update_date ! input date and delta date, compute new date public :: calendar_date2time ! convert date to time relative to init date public :: calendar_time2date ! convert time to date relative to init date + public :: calendar_sec2hms ! convert seconds to hour, minute, seconds public :: compute_calendar_data ! compute info about calendar for a given year ! private functions @@ -61,8 +62,10 @@ module ice_calendar ice_calendar_360day = '360day' ! 360 day calendar with 30 days per month integer (kind=int_kind), public, parameter :: & - months_per_year = 12, & ! months per year - hours_per_day = 24 ! hours per day + months_per_year = 12, & ! months per year + hours_per_day = 24, & ! hours per day + minutes_per_hour = 60, & ! minutes per hour + seconds_per_minute = 60 ! seconds per minute integer (kind=int_kind), public :: & seconds_per_day , & ! seconds per day @@ -87,6 +90,9 @@ module ice_calendar day_init, & ! initial day of month sec_init , & ! initial seconds ! other stuff + hh_init , & ! initial hour derived from sec_init + mm_init , & ! initial minute derived from sec_init + ss_init , & ! initial second derived from sec_init idate , & ! date (yyyymmdd) idate0 , & ! initial date (yyyymmdd), associated with year_init, month_init, day_init dayyr , & ! number of days in the current year @@ -189,6 +195,7 @@ subroutine init_calendar mmonth=month_init ! month mday=day_init ! day of the month msec=sec_init ! seconds into date + call calendar_sec2hms(sec_init,hh_init,mm_init,ss_init) ! initialize hh,mm,ss _init hour=0 ! computed in calendar, but needs some reasonable initial value istep1 = istep0 ! number of steps at current timestep ! real (dumped) or imagined (use to set calendar) @@ -948,6 +955,28 @@ subroutine calendar_time2date(atimesecs,ayear,amon,aday,asec,year_ref,mon_ref,da end subroutine calendar_time2date +!======================================================================= +! Compute hours, minutes, seconds from seconds + + subroutine calendar_sec2hms(seconds, hh, mm, ss) + + integer(kind=int_kind), intent(in) :: & + seconds ! calendar seconds in day + integer(kind=int_kind), intent(out) :: & + hh, mm, ss ! output hours, minutes, seconds + + character(len=*),parameter :: subname='(calendar_sec2hms)' + + if (seconds >= seconds_per_day) then + write(nu_diag,*) trim(subname),' ERROR seconds >= seconds_per_day, ',seconds,seconds_per_day + call abort_ice(subname//'ERROR: in seconds') + endif + hh = seconds/(seconds_per_hour) + mm = (seconds - hh*seconds_per_hour)/seconds_per_minute + ss = (seconds - hh*seconds_per_hour - mm*seconds_per_minute) + + end subroutine calendar_sec2hms + !======================================================================= ! Compute relative elapsed years, months, days, hours from base time diff --git a/cicecore/shared/ice_fileunits.F90 b/cicecore/shared/ice_fileunits.F90 index b6b30d47a..ccb518807 100644 --- a/cicecore/shared/ice_fileunits.F90 +++ b/cicecore/shared/ice_fileunits.F90 @@ -51,6 +51,8 @@ module ice_fileunits nu_restart_lvl, & ! restart input file for level ice tracers nu_dump_pond , & ! dump file for restarting melt pond tracer nu_restart_pond,& ! restart input file for melt pond tracer + nu_dump_snow , & ! dump file for restarting snow redist/metamorph tracers + nu_restart_snow,& ! restart input file for snow redist/metamorph tracers nu_dump_fsd , & ! dump file for restarting floe size distribution nu_restart_fsd, & ! restart input file for floe size distribution nu_dump_iso , & ! dump file for restarting isotope tracers @@ -129,6 +131,8 @@ subroutine init_fileunits call get_fileunit(nu_restart_lvl) call get_fileunit(nu_dump_pond) call get_fileunit(nu_restart_pond) + call get_fileunit(nu_dump_snow) + call get_fileunit(nu_restart_snow) call get_fileunit(nu_dump_fsd) call get_fileunit(nu_restart_fsd) call get_fileunit(nu_dump_iso) @@ -218,6 +222,8 @@ subroutine release_all_fileunits call release_fileunit(nu_restart_lvl) call release_fileunit(nu_dump_pond) call release_fileunit(nu_restart_pond) + call release_fileunit(nu_dump_snow) + call release_fileunit(nu_restart_snow) call release_fileunit(nu_dump_fsd) call release_fileunit(nu_restart_fsd) call release_fileunit(nu_dump_iso) diff --git a/cicecore/shared/ice_init_column.F90 b/cicecore/shared/ice_init_column.F90 index 4f4641467..eff39a464 100644 --- a/cicecore/shared/ice_init_column.F90 +++ b/cicecore/shared/ice_init_column.F90 @@ -46,7 +46,7 @@ module ice_init_column init_age, init_FY, init_lvl, init_fsd, & init_meltponds_cesm, init_meltponds_lvl, init_meltponds_topo, & init_aerosol, init_bgc, init_hbrine, init_zbgc, input_zbgc, & - count_tracers, init_isotope + count_tracers, init_isotope, init_snowtracers ! namelist parameters needed locally @@ -214,8 +214,9 @@ subroutine init_shortwave logical (kind=log_kind) :: & l_print_point, & ! flag to print designated grid point diagnostics debug, & ! if true, print diagnostics - dEdd_algae, & ! from icepack - modal_aero ! from icepack + dEdd_algae, & ! use prognostic chla in dEdd radiation + modal_aero, & ! use modal aerosol optical treatment + snwgrain ! use variable snow radius character (char_len) :: shortwave @@ -225,12 +226,13 @@ subroutine init_shortwave real (kind=dbl_kind), dimension(ncat) :: & fbri ! brine height to ice thickness - real(kind=dbl_kind), allocatable :: & - ztrcr_sw(:,:) ! + real(kind= dbl_kind), dimension(:,:), allocatable :: & + ztrcr_sw, & ! zaerosols (kg/m^3) and chla (mg/m^3) + rsnow ! snow grain radius tracer (10^-6 m) logical (kind=log_kind) :: tr_brine, tr_zaero, tr_bgc_n integer (kind=int_kind) :: nt_alvl, nt_apnd, nt_hpnd, nt_ipnd, nt_aero, & - nt_fbri, nt_tsfc, ntrcr, nbtrcr, nbtrcr_sw + nt_fbri, nt_tsfc, ntrcr, nbtrcr, nbtrcr_sw, nt_rsnw integer (kind=int_kind), dimension(icepack_max_algae) :: & nt_bgc_N integer (kind=int_kind), dimension(icepack_max_aero) :: & @@ -243,17 +245,19 @@ subroutine init_shortwave call icepack_query_parameters(shortwave_out=shortwave) call icepack_query_parameters(dEdd_algae_out=dEdd_algae) call icepack_query_parameters(modal_aero_out=modal_aero) + call icepack_query_parameters(snwgrain_out=snwgrain) call icepack_query_tracer_sizes(ntrcr_out=ntrcr, nbtrcr_out=nbtrcr, nbtrcr_sw_out=nbtrcr_sw) call icepack_query_tracer_flags(tr_brine_out=tr_brine, tr_zaero_out=tr_zaero, & tr_bgc_n_out=tr_bgc_n) call icepack_query_tracer_indices(nt_alvl_out=nt_alvl, nt_apnd_out=nt_apnd, nt_hpnd_out=nt_hpnd, & nt_ipnd_out=nt_ipnd, nt_aero_out=nt_aero, nt_fbri_out=nt_fbri, nt_tsfc_out=nt_tsfc, & - nt_bgc_N_out=nt_bgc_N, nt_zaero_out=nt_zaero) + nt_bgc_N_out=nt_bgc_N, nt_zaero_out=nt_zaero, nt_rsnw_out=nt_rsnw) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__,line= __LINE__) allocate(ztrcr_sw(nbtrcr_sw, ncat)) + allocate(rsnow(nslyr,ncat)) do iblk=1,nblocks @@ -330,8 +334,14 @@ subroutine init_shortwave fbri(:) = c0 ztrcr_sw(:,:) = c0 + rsnow (:,:) = c0 do n = 1, ncat - if (tr_brine) fbri(n) = trcrn(i,j,nt_fbri,n,iblk) + if (tr_brine) fbri(n) = trcrn(i,j,nt_fbri,n,iblk) + if (snwgrain) then + do k = 1, nslyr + rsnow(k,n) = trcrn(i,j,nt_rsnw+k-1,n,iblk) + enddo + endif enddo if (tmask(i,j,iblk)) then @@ -379,6 +389,7 @@ subroutine init_shortwave albpndn=albpndn(i,j,:,iblk), apeffn=apeffn(i,j,:,iblk), & snowfracn=snowfracn(i,j,:,iblk), & dhsn=dhsn(i,j,:,iblk), ffracn=ffracn(i,j,:,iblk), & + rsnow=rsnow(:,:), & l_print_point=l_print_point, & initonly = .true.) endif @@ -475,6 +486,7 @@ subroutine init_shortwave enddo ! iblk deallocate(ztrcr_sw) + deallocate(rsnow) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & @@ -587,6 +599,29 @@ end subroutine init_meltponds_topo !======================================================================= +! Initialize snow redistribution/metamorphosis tracers (call prior to reading restart data) + + subroutine init_snowtracers(smice, smliq, rhos_cmp, rsnw) + + real(kind=dbl_kind), dimension(:,:,:,:), intent(out) :: & + smice, smliq, rhos_cmp, rsnw + character(len=*),parameter :: subname='(init_snowtracers)' + + real (kind=dbl_kind) :: & + rsnw_fall, & ! snow grain radius of new fallen snow (10^-6 m) + rhos ! snow density (kg/m^3) + + call icepack_query_parameters(rsnw_fall_out=rsnw_fall, rhos_out=rhos) + + rsnw (:,:,:,:) = rsnw_fall + rhos_cmp(:,:,:,:) = rhos + smice (:,:,:,:) = rhos + smliq (:,:,:,:) = c0 + + end subroutine init_snowtracers + +!======================================================================= + ! Initialize floe size distribution tracer (call prior to reading restart data) subroutine init_fsd(floesize) @@ -1776,10 +1811,12 @@ subroutine count_tracers integer (kind=int_kind) :: ntrcr logical (kind=log_kind) :: tr_iage, tr_FY, tr_lvl, tr_pond, tr_aero, tr_fsd + logical (kind=log_kind) :: tr_snow logical (kind=log_kind) :: tr_iso, tr_pond_cesm, tr_pond_lvl, tr_pond_topo integer (kind=int_kind) :: nt_Tsfc, nt_sice, nt_qice, nt_qsno, nt_iage, nt_FY integer (kind=int_kind) :: nt_alvl, nt_vlvl, nt_apnd, nt_hpnd, nt_ipnd, nt_aero integer (kind=int_kind) :: nt_fsd, nt_isosno, nt_isoice + integer (kind=int_kind) :: nt_smice, nt_smliq, nt_rhos, nt_rsnw integer (kind=int_kind) :: & nbtrcr, nbtrcr_sw, & @@ -1862,7 +1899,7 @@ subroutine count_tracers tr_lvl_out=tr_lvl, tr_aero_out=tr_aero, tr_pond_out=tr_pond, & tr_pond_cesm_out=tr_pond_cesm, tr_pond_lvl_out=tr_pond_lvl, & tr_pond_topo_out=tr_pond_topo, tr_brine_out=tr_brine, tr_fsd_out=tr_fsd, & - tr_iso_out=tr_iso, & + tr_snow_out=tr_snow, tr_iso_out=tr_iso, & tr_bgc_Nit_out=tr_bgc_Nit, tr_bgc_Am_out =tr_bgc_Am, tr_bgc_Sil_out=tr_bgc_Sil, & tr_bgc_DMS_out=tr_bgc_DMS, tr_bgc_PON_out=tr_bgc_PON, & tr_bgc_N_out =tr_bgc_N, tr_bgc_C_out =tr_bgc_C, tr_bgc_chl_out=tr_bgc_chl, & @@ -1925,6 +1962,21 @@ subroutine count_tracers endif endif + nt_smice = 0 + nt_smliq = 0 + nt_rhos = 0 + nt_rsnw = 0 + if (tr_snow) then + nt_smice = ntrcr + 1 + ntrcr = ntrcr + nslyr ! mass of ice in nslyr snow layers + nt_smliq = ntrcr + 1 + ntrcr = ntrcr + nslyr ! mass of liquid in nslyr snow layers + nt_rhos = ntrcr + 1 + ntrcr = ntrcr + nslyr ! snow density in nslyr layers + nt_rsnw = ntrcr + 1 + ntrcr = ntrcr + nslyr ! snow grain radius in nslyr layers + endif + nt_fsd = 0 if (tr_fsd) then nt_fsd = ntrcr + 1 ! floe size distribution @@ -2212,7 +2264,7 @@ subroutine count_tracers !tcx, +1 here is the unused tracer, want to get rid of it ntrcr = ntrcr + 1 -!tcx, reset unusaed tracer index, eventually get rid of it. +!tcx, reset unused tracer index, eventually get rid of it. if (nt_iage <= 0) nt_iage = ntrcr if (nt_FY <= 0) nt_FY = ntrcr if (nt_alvl <= 0) nt_alvl = ntrcr @@ -2220,6 +2272,10 @@ subroutine count_tracers if (nt_apnd <= 0) nt_apnd = ntrcr if (nt_hpnd <= 0) nt_hpnd = ntrcr if (nt_ipnd <= 0) nt_ipnd = ntrcr + if (nt_smice <= 0) nt_smice = ntrcr + if (nt_smliq <= 0) nt_smliq = ntrcr + if (nt_rhos <= 0) nt_rhos = ntrcr + if (nt_rsnw <= 0) nt_rsnw = ntrcr if (nt_fsd <= 0) nt_fsd = ntrcr if (nt_isosno<= 0) nt_isosno= ntrcr if (nt_isoice<= 0) nt_isoice= ntrcr @@ -2246,6 +2302,7 @@ subroutine count_tracers nt_qice_in=nt_qice, nt_qsno_in=nt_qsno, nt_iage_in=nt_iage, nt_fy_in=nt_fy, & nt_alvl_in=nt_alvl, nt_vlvl_in=nt_vlvl, nt_apnd_in=nt_apnd, nt_hpnd_in=nt_hpnd, & nt_ipnd_in=nt_ipnd, nt_fsd_in=nt_fsd, nt_aero_in=nt_aero, & + nt_smice_in=nt_smice, nt_smliq_in=nt_smliq, nt_rhos_in=nt_rhos, nt_rsnw_in=nt_rsnw, & nt_isosno_in=nt_isosno, nt_isoice_in=nt_isoice, nt_fbri_in=nt_fbri, & nt_bgc_Nit_in=nt_bgc_Nit, nt_bgc_Am_in=nt_bgc_Am, nt_bgc_Sil_in=nt_bgc_Sil, & nt_bgc_DMS_in=nt_bgc_DMS, nt_bgc_PON_in=nt_bgc_PON, nt_bgc_S_in=nt_bgc_S, & diff --git a/cicecore/shared/ice_restart_column.F90 b/cicecore/shared/ice_restart_column.F90 index e819b1098..074b37dbe 100644 --- a/cicecore/shared/ice_restart_column.F90 +++ b/cicecore/shared/ice_restart_column.F90 @@ -12,7 +12,7 @@ module ice_restart_column use ice_communicate, only: my_task, master_task use ice_constants, only: c0, c1, p5 use ice_constants, only: field_loc_center, field_type_scalar - use ice_domain_size, only: ncat, nfsd, nblyr + use ice_domain_size, only: ncat, nslyr, nfsd, nblyr use ice_restart,only: read_restart_field, write_restart_field use ice_exit, only: abort_ice use ice_fileunits, only: nu_diag @@ -32,6 +32,7 @@ module ice_restart_column write_restart_pond_cesm, read_restart_pond_cesm, & write_restart_pond_lvl, read_restart_pond_lvl, & write_restart_pond_topo, read_restart_pond_topo, & + write_restart_snow, read_restart_snow, & write_restart_fsd, read_restart_fsd, & write_restart_iso, read_restart_iso, & write_restart_aero, read_restart_aero, & @@ -45,6 +46,7 @@ module ice_restart_column restart_pond_cesm, & ! if .true., read meltponds restart file restart_pond_lvl , & ! if .true., read meltponds restart file restart_pond_topo, & ! if .true., read meltponds restart file + restart_snow , & ! if .true., read snow tracer restart file restart_fsd , & ! if .true., read floe size restart file restart_iso , & ! if .true., read isotope tracer restart file restart_aero , & ! if .true., read aerosol tracer restart file @@ -483,6 +485,93 @@ end subroutine read_restart_pond_topo !======================================================================= +! Dumps all values needed for restarting snow redistribution/metamorphism +! author Elizabeth C. Hunke, LANL + + subroutine write_restart_snow() + + use ice_fileunits, only: nu_dump_snow + use ice_state, only: trcrn + + ! local variables + + logical (kind=log_kind) :: diag + integer (kind=int_kind) :: nt_smice, nt_smliq, nt_rhos, nt_rsnw, k + character*3 ck + character(len=*),parameter :: subname='(write_restart_snow)' + + call icepack_query_tracer_indices(nt_smice_out=nt_smice, & + nt_smliq_out=nt_smliq, nt_rhos_out=nt_rhos, nt_rsnw_out=nt_rsnw) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & + file=__FILE__, line=__LINE__) + + diag = .true. + + !----------------------------------------------------------------- + + do k = 1,nslyr + write(ck,'(i3.3)') k + call write_restart_field(nu_dump_snow,0, trcrn(:,:,nt_smice+k-1,:,:), & + 'ruf8','smice'//trim(ck),ncat,diag) + call write_restart_field(nu_dump_snow,0, trcrn(:,:,nt_smliq+k-1,:,:), & + 'ruf8','smliq'//trim(ck),ncat,diag) + call write_restart_field(nu_dump_snow,0, trcrn(:,:,nt_rhos+k-1,:,:), & + 'ruf8','rhos'//trim(ck),ncat,diag) + call write_restart_field(nu_dump_snow,0, trcrn(:,:,nt_rsnw+k-1,:,:), & + 'ruf8','rsnw'//trim(ck),ncat,diag) + enddo + + end subroutine write_restart_snow + +!======================================================================= + +! Reads all values needed for a restart with snow redistribution/metamorphism +! author Elizabeth C. Hunke, LANL + + subroutine read_restart_snow() + + use ice_fileunits, only: nu_restart_snow + use ice_state, only: trcrn + + ! local variables + + logical (kind=log_kind) :: & + diag + integer (kind=int_kind) :: nt_smice, nt_smliq, nt_rhos, nt_rsnw, k + character*3 ck + character(len=*),parameter :: subname='(read_restart_snow)' + + call icepack_query_tracer_indices(nt_smice_out=nt_smice, & + nt_smliq_out=nt_smliq, nt_rhos_out=nt_rhos, nt_rsnw_out=nt_rsnw) + call icepack_warnings_flush(nu_diag) + if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & + file=__FILE__, line=__LINE__) + + diag = .true. + + if (my_task == master_task) write(nu_diag,*) subname,'min/max snow tracers' + + do k=1,nslyr + write(ck,'(i3.3)') k + call read_restart_field(nu_restart_snow,0,trcrn(:,:,nt_smice+k-1,:,:), & + 'ruf8','smice'//trim(ck),ncat,diag, & + field_type=field_type_scalar,field_loc=field_loc_center) + call read_restart_field(nu_restart_snow,0,trcrn(:,:,nt_smliq+k-1,:,:), & + 'ruf8','smliq'//trim(ck),ncat,diag, & + field_type=field_type_scalar,field_loc=field_loc_center) + call read_restart_field(nu_restart_snow,0,trcrn(:,:,nt_rhos+k-1,:,:), & + 'ruf8','rhos'//trim(ck),ncat,diag, & + field_type=field_type_scalar,field_loc=field_loc_center) + call read_restart_field(nu_restart_snow,0,trcrn(:,:,nt_rsnw+k-1,:,:), & + 'ruf8','rsnw'//trim(ck),ncat,diag, & + field_type=field_type_scalar,field_loc=field_loc_center) + enddo + + end subroutine read_restart_snow + +!======================================================================= + ! Dumps all values needed for restarting ! author Elizabeth C. Hunke, LANL diff --git a/cicecore/version.txt b/cicecore/version.txt index cfd991555..04a90ef1a 100644 --- a/cicecore/version.txt +++ b/cicecore/version.txt @@ -1 +1 @@ -CICE 6.2.0 +CICE 6.3.0 diff --git a/configuration/scripts/cice.batch.csh b/configuration/scripts/cice.batch.csh index 902abb56b..024270039 100755 --- a/configuration/scripts/cice.batch.csh +++ b/configuration/scripts/cice.batch.csh @@ -226,6 +226,23 @@ cat >> ${jobfile} << EOFB #PBS -l walltime=${batchtime} EOFB +else if (${ICE_MACHINE} =~ gaea*) then +cat >> ${jobfile} << EOFB +#SBATCH -J ${ICE_CASENAME} +#SBATCH --partition=batch +#SBATCH --qos=${queue} +#SBATCH --account=nggps_emc +#SBATCH --clusters=c3 +#SBATCH --time=${batchtime} +#SBATCH --nodes=${nnodes} +#SBATCH --ntasks-per-node=${taskpernodelimit} +#SBATCH --cpus-per-task=${nthrds} +#SBATCH -e slurm%j.err +#SBATCH -o slurm%j.out +##SBATCH --mail-type FAIL +##SBATCH --mail-user=xxx@noaa.gov +EOFB + else if (${ICE_MACHINE} =~ hera*) then cat >> ${jobfile} << EOFB #SBATCH -J ${ICE_CASENAME} diff --git a/configuration/scripts/cice.launch.csh b/configuration/scripts/cice.launch.csh index 7d45a387f..40b8996b4 100755 --- a/configuration/scripts/cice.launch.csh +++ b/configuration/scripts/cice.launch.csh @@ -165,6 +165,12 @@ aprun -n ${ntasks} -N ${taskpernodelimit} -d ${nthrds} ./cice >&! \$ICE_RUNLOG_F EOFR endif +#======= +else if (${ICE_MACHINE} =~ gaea*) then +cat >> ${jobfile} << EOFR +srun -n ${ntasks} -c ${nthrds} ./cice >&! \$ICE_RUNLOG_FILE +EOFR + #======= else if (${ICE_MACHINE} =~ hera*) then cat >> ${jobfile} << EOFR diff --git a/configuration/scripts/cice.run.setup.csh b/configuration/scripts/cice.run.setup.csh index ea8efeb03..aa578b5ca 100755 --- a/configuration/scripts/cice.run.setup.csh +++ b/configuration/scripts/cice.run.setup.csh @@ -100,7 +100,7 @@ else echo "Run completed successfully" echo "\`date\` \${0}: Run completed successfully" >> \${ICE_CASEDIR}/README.case else - echo "CICE run did NOT complete" + echo "Run did NOT complete" echo "\`date\` \${0}: CICE run did NOT complete" >> \${ICE_CASEDIR}/README.case exit -1 endif diff --git a/configuration/scripts/ice_in b/configuration/scripts/ice_in index e918a694c..3dec72963 100644 --- a/configuration/scripts/ice_in +++ b/configuration/scripts/ice_in @@ -100,6 +100,8 @@ restart_pond_topo = .false. tr_pond_lvl = .true. restart_pond_lvl = .false. + tr_snow = .false. + restart_snow = .false. tr_iso = .false. restart_iso = .false. tr_aero = .false. @@ -127,7 +129,7 @@ kdyn = 1 ndte = 240 revised_evp = .false. - kevp_kernel = 0 + evp_algorithm = 'standard_2d' brlx = 300.0 arlx = 300.0 advection = 'remap' @@ -197,6 +199,28 @@ pndaspect = 0.8 / +&snow_nml + snwredist = 'none' + snwgrain = .false. + use_smliq_pnd = .false. + rsnw_fall = 100.0 + rsnw_tmax = 1500.0 + rhosnew = 100.0 + rhosmin = 100.0 + rhosmax = 450.0 + windmin = 10.0 + drhosdwind = 27.3 + snwlvlfac = 0.3 + snw_aging_table = 'test' + snw_filename = 'unknown' + snw_rhos_fname = 'unknown' + snw_Tgrd_fname = 'unknown' + snw_T_fname = 'unknown' + snw_tau_fname = 'unknown' + snw_kappa_fname = 'unknown' + snw_drdt0_fname = 'unknown' +/ + &forcing_nml formdrag = .false. atmbndy = 'default' @@ -584,6 +608,21 @@ f_apeff_ai = 'm' / +&icefields_snow_nml + f_smassicen = 'x' + f_smassliqn = 'x' + f_rhos_cmpn = 'x' + f_rhos_cntn = 'x' + f_rsnwn = 'x' + f_smassice = 'm' + f_smassliq = 'm' + f_rhos_cmp = 'm' + f_rhos_cnt = 'm' + f_rsnw = 'm' + f_meltsliq = 'm' + f_fsloss = 'm' +/ + &icefields_bgc_nml f_fiso_atm = 'x' f_fiso_ocn = 'x' diff --git a/configuration/scripts/machines/Macros.gaea_intel b/configuration/scripts/machines/Macros.gaea_intel new file mode 100644 index 000000000..f4c4d2cbe --- /dev/null +++ b/configuration/scripts/machines/Macros.gaea_intel @@ -0,0 +1,56 @@ +#============================================================================== +# Makefile macros for NOAA hera, intel compiler +#============================================================================== + +CPP := fpp +CPPDEFS := -DFORTRANUNDERSCORE ${ICE_CPPDEFS} +CFLAGS := -c -O2 -fp-model precise -xHost + +FIXEDFLAGS := -132 +FREEFLAGS := -FR +FFLAGS := -fp-model precise -convert big_endian -assume byterecl -ftz -traceback -align array64byte -xHost +FFLAGS_NOOPT:= -O0 + +ifeq ($(ICE_BLDDEBUG), true) + FFLAGS += -O0 -g -check uninit -check bounds -check pointers -fpe0 -check noarg_temp_created -link_mpi=dbg +else + FFLAGS += -O2 +endif + +SCC := cc +SFC := ftn +MPICC := cc +MPIFC := ftn + +ifeq ($(ICE_COMMDIR), mpi) + FC := $(MPIFC) + CC := $(MPICC) +else + FC := $(SFC) + CC := $(SCC) +endif +LD:= $(FC) + +NETCDF_PATH := $(NETCDF) + +PIO_CONFIG_OPTS:= --enable-filesystem-hints=gpfs + +#PNETCDF_PATH := $(PNETCDF) +#PNETCDF_PATH := /glade/u/apps/ch/opt/pio/2.2/mpt/2.15f/intel/17.0.1/lib + +INC_NETCDF := $(NETCDF_PATH)/include +LIB_NETCDF := $(NETCDF_PATH)/lib + +#LIB_PNETCDF := $(PNETCDF_PATH)/lib +#LIB_MPI := $(IMPILIBDIR) + +INCLDIR := $(INCLDIR) -I$(INC_NETCDF) +#SLIBS := -L$(LIB_NETCDF) -lnetcdf -lnetcdff -L$(LIB_PNETCDF) -lpnetcdf -lgptl +SLIBS := -L$(LIB_NETCDF) -lnetcdf -lnetcdff + +ifeq ($(ICE_THREADED), true) + LDFLAGS += -qopenmp + CFLAGS += -qopenmp + FFLAGS += -qopenmp +endif + diff --git a/configuration/scripts/machines/Macros.onyx_cray b/configuration/scripts/machines/Macros.onyx_cray index 6753a78e5..c088d1fd4 100644 --- a/configuration/scripts/machines/Macros.onyx_cray +++ b/configuration/scripts/machines/Macros.onyx_cray @@ -3,7 +3,7 @@ #============================================================================== CPP := ftn -e P -CPPDEFS := -DFORTRANUNDERSCORE ${ICE_CPPDEFS} +CPPDEFS := -DFORTRANUNDERSCORE -DNO_R16 ${ICE_CPPDEFS} CFLAGS := -c -O2 -h fp0 FIXEDFLAGS := -132 diff --git a/configuration/scripts/machines/Macros.onyx_gnu b/configuration/scripts/machines/Macros.onyx_gnu index 890e29e31..31d0e64aa 100644 --- a/configuration/scripts/machines/Macros.onyx_gnu +++ b/configuration/scripts/machines/Macros.onyx_gnu @@ -8,7 +8,7 @@ CFLAGS := -c FIXEDFLAGS := -ffixed-line-length-132 FREEFLAGS := -ffree-form -FFLAGS := -fconvert=big-endian -fbacktrace -ffree-line-length-none +FFLAGS := -fconvert=big-endian -fbacktrace -ffree-line-length-none -fallow-argument-mismatch FFLAGS_NOOPT:= -O0 ifeq ($(ICE_BLDDEBUG), true) diff --git a/configuration/scripts/machines/env.gaea_intel b/configuration/scripts/machines/env.gaea_intel new file mode 100755 index 000000000..d143270d7 --- /dev/null +++ b/configuration/scripts/machines/env.gaea_intel @@ -0,0 +1,34 @@ +#!/bin/csh -f + +set inp = "undefined" +if ($#argv == 1) then + set inp = $1 +endif + +if ("$inp" != "-nomodules") then + +source /lustre/f2/pdata/esrl/gsd/contrib/lua-5.1.4.9/init/init_lmod.csh +#module list +module purge +module load intel +module load cray-mpich +module load cray-netcdf +module load PrgEnv-intel/6.0.5 +module list + +endif + +setenv ICE_MACHINE_MACHNAME gaea +setenv ICE_MACHINE_MACHINFO "Cray Intel SkyLake 6148" +setenv ICE_MACHINE_ENVNAME intel +setenv ICE_MACHINE_ENVINFO "ifort 18.0.5 20180823, cray-mpich, cray-netcdf" +setenv ICE_MACHINE_MAKE gmake +setenv ICE_MACHINE_WKDIR $HOME/scratch/CICE_RUNS +setenv ICE_MACHINE_INPUTDATA /ncrc/home1/Robert.Grumbine/rgdev/CICE_INPUTDATA +setenv ICE_MACHINE_BASELINE $HOME/scratch/CICE_BASELINE +setenv ICE_MACHINE_SUBMIT "sbatch" +setenv ICE_MACHINE_TPNODE 40 +setenv ICE_MACHINE_ACCT P0000000 +setenv ICE_MACHINE_QUEUE "normal" +setenv ICE_MACHINE_BLDTHRDS 1 +setenv ICE_MACHINE_QSTAT "squeue --jobs=" diff --git a/configuration/scripts/machines/env.onyx_cray b/configuration/scripts/machines/env.onyx_cray index b155c1d1e..38785a27d 100755 --- a/configuration/scripts/machines/env.onyx_cray +++ b/configuration/scripts/machines/env.onyx_cray @@ -13,14 +13,14 @@ module unload PrgEnv-cray module unload PrgEnv-gnu module unload PrgEnv-intel module unload PrgEnv-pgi -module load PrgEnv-cray/6.0.4 +module load PrgEnv-cray/6.0.9 module unload cce -module load cce/8.6.4 +module load cce/11.0.2 module unload cray-mpich module unload cray-mpich2 -module load cray-mpich/7.6.3 +module load cray-mpich/7.7.16 module unload netcdf module unload cray-netcdf @@ -28,10 +28,11 @@ module unload cray-hdf5 module unload cray-hdf5-parallel module unload cray-netcdf-hdf5parallel module unload cray-parallel-netcdf -module load cray-netcdf/4.4.1.1.3 -module load cray-hdf5/1.10.0.3 +module load cray-netcdf/4.7.4.0 +module load cray-hdf5/1.12.0.0 module unload cray-libsci +module unload craype-hugepages2M module load craype-broadwell @@ -44,7 +45,7 @@ endif setenv ICE_MACHINE_MACHNAME onyx setenv ICE_MACHINE_MACHINFO "Cray XC40/50 Xeon E5-2699v4 Broadwell" setenv ICE_MACHINE_ENVNAME cray -setenv ICE_MACHINE_ENVINFO "Cray cce/8.6.4, cray-mpich/7.6.3, netcdf/4.4.1.1.3" +setenv ICE_MACHINE_ENVINFO "Cray cce/11.0.2, cray-mpich/7.7.16, netcdf/4.7.4.0" setenv ICE_MACHINE_MAKE gmake setenv ICE_MACHINE_WKDIR $WORKDIR/CICE_RUNS setenv ICE_MACHINE_INPUTDATA /p/app/unsupported/RASM/cice_consortium diff --git a/configuration/scripts/machines/env.onyx_gnu b/configuration/scripts/machines/env.onyx_gnu index de7bcc787..699c01559 100755 --- a/configuration/scripts/machines/env.onyx_gnu +++ b/configuration/scripts/machines/env.onyx_gnu @@ -13,14 +13,14 @@ module unload PrgEnv-cray module unload PrgEnv-gnu module unload PrgEnv-intel module unload PrgEnv-pgi -module load PrgEnv-gnu/6.0.4 +module load PrgEnv-gnu/6.0.9 module unload gcc -module load gcc/7.2.0 +module load gcc/10.2.0 module unload cray-mpich module unload cray-mpich2 -module load cray-mpich/7.6.2 +module load cray-mpich/7.7.16 module unload netcdf module unload cray-netcdf @@ -28,10 +28,11 @@ module unload cray-hdf5 module unload cray-hdf5-parallel module unload cray-netcdf-hdf5parallel module unload cray-parallel-netcdf -module load cray-netcdf/4.4.1.1.3 -module load cray-hdf5/1.10.0.3 +module load cray-netcdf/4.7.4.0 +module load cray-hdf5/1.12.0.0 module unload cray-libsci +module unload craype-hugepages2M module load craype-broadwell @@ -44,7 +45,7 @@ endif setenv ICE_MACHINE_MACHNAME onyx setenv ICE_MACHINE_MACHINFO "Cray XC40/50 Xeon E5-2699v4 Broadwell" setenv ICE_MACHINE_ENVNAME gnu -setenv ICE_MACHINE_ENVINFO "GNU Fortran (GCC) 7.2.0 20170814, cray-mpich/7.6.2, netcdf/4.4.1.1.3" +setenv ICE_MACHINE_ENVINFO "GNU Fortran (GCC) 10.2.0, cray-mpich/7.7.16, netcdf/4.7.4.0" setenv ICE_MACHINE_MAKE gmake setenv ICE_MACHINE_WKDIR $WORKDIR/CICE_RUNS setenv ICE_MACHINE_INPUTDATA /p/app/unsupported/RASM/cice_consortium diff --git a/configuration/scripts/machines/env.onyx_intel b/configuration/scripts/machines/env.onyx_intel index df42fe9f8..39f25e8e5 100755 --- a/configuration/scripts/machines/env.onyx_intel +++ b/configuration/scripts/machines/env.onyx_intel @@ -13,14 +13,14 @@ module unload PrgEnv-cray module unload PrgEnv-gnu module unload PrgEnv-intel module unload PrgEnv-pgi -module load PrgEnv-intel/6.0.4 +module load PrgEnv-intel/6.0.9 module unload intel -module load intel/17.0.1.132 +module load intel/19.1.3.304 module unload cray-mpich module unload cray-mpich2 -module load cray-mpich/7.6.2 +module load cray-mpich/7.7.16 module unload netcdf module unload cray-netcdf @@ -28,10 +28,11 @@ module unload cray-hdf5 module unload cray-hdf5-parallel module unload cray-netcdf-hdf5parallel module unload cray-parallel-netcdf -module load cray-netcdf/4.4.1.1.3 -module load cray-hdf5/1.10.0.3 +module load cray-netcdf/4.7.4.0 +module load cray-hdf5/1.12.0.0 module unload cray-libsci +module unload craype-hugepages2M module load craype-broadwell @@ -44,7 +45,7 @@ endif setenv ICE_MACHINE_MACHNAME onyx setenv ICE_MACHINE_MACHINFO "Cray XC40/50 Xeon E5-2699v4 Broadwell" setenv ICE_MACHINE_ENVNAME intel -setenv ICE_MACHINE_ENVINFO "ifort 17.0.1 20161005, cray-mpich/7.6.2, netcdf/4.4.1.1.3" +setenv ICE_MACHINE_ENVINFO "ifort 19.1.3.304, cray-mpich/7.7.16, netcdf/4.7.4.0" setenv ICE_MACHINE_MAKE gmake setenv ICE_MACHINE_WKDIR $WORKDIR/CICE_RUNS setenv ICE_MACHINE_INPUTDATA /p/app/unsupported/RASM/cice_consortium diff --git a/configuration/scripts/options/set_nml.alt04 b/configuration/scripts/options/set_nml.alt04 index 53372f124..98eb311cb 100644 --- a/configuration/scripts/options/set_nml.alt04 +++ b/configuration/scripts/options/set_nml.alt04 @@ -17,7 +17,7 @@ sw_frac = 0.9d0 sw_dtemp = 0.02d0 conduct = 'MU71' kdyn = 1 -kevp_kernel = 102 +evp_algorithm = 'shared_mem_1d' fbot_xfer_type = 'Cdn_ocn' shortwave = 'dEdd' formdrag = .true. diff --git a/configuration/scripts/options/set_nml.evp1d b/configuration/scripts/options/set_nml.evp1d new file mode 100644 index 000000000..e7d38e86b --- /dev/null +++ b/configuration/scripts/options/set_nml.evp1d @@ -0,0 +1 @@ +evp_algorithm = 'shared_mem_1d' diff --git a/configuration/scripts/options/set_nml.gx1prod b/configuration/scripts/options/set_nml.gx1prod index eca527a64..94e4bbf89 100644 --- a/configuration/scripts/options/set_nml.gx1prod +++ b/configuration/scripts/options/set_nml.gx1prod @@ -1,11 +1,11 @@ year_init = 2005 use_leap_years = .true. npt_unit = 'y' -npt = 1 +npt = 4 dumpfreq = 'm' dumpfreq_base = 'zero' fyear_init = 2005 -ycycle = 5 +ycycle = 4 ocn_data_dir = 'ICE_MACHINE_INPUTDATA/CICE_data/forcing/gx1/CESM/MONTHLY/' use_bathymetry = .true. seabed_stress = .true. diff --git a/configuration/scripts/options/set_nml.gx1prod15 b/configuration/scripts/options/set_nml.gx1prod15 new file mode 100644 index 000000000..edbf5e5de --- /dev/null +++ b/configuration/scripts/options/set_nml.gx1prod15 @@ -0,0 +1,19 @@ +year_init = 1995 +use_leap_years = .true. +npt_unit = 'y' +npt = 15 +dumpfreq = 'm' +dumpfreq_base = 'zero' +fyear_init = 1995 +ycycle = 16 +ocn_data_dir = 'ICE_MACHINE_INPUTDATA/CICE_data/forcing/gx1/CESM/MONTHLY/' +use_bathymetry = .true. +seabed_stress = .true. +seabed_stress_method = 'LKD' +ocn_data_type = 'ncar' +ocn_data_format = 'nc' +oceanmixed_ice = .true. +oceanmixed_file = 'ocean_forcing_clim_2D_gx1.20210330.nc' +tr_brine = .true. +f_taubx = 'm' +f_tauby = 'm' diff --git a/configuration/scripts/options/set_nml.histinst b/configuration/scripts/options/set_nml.histinst new file mode 100644 index 000000000..f2f0995c8 --- /dev/null +++ b/configuration/scripts/options/set_nml.histinst @@ -0,0 +1 @@ +hist_avg = .false. diff --git a/configuration/scripts/options/set_nml.kevp102 b/configuration/scripts/options/set_nml.kevp102 deleted file mode 100644 index 3a5dc3dbd..000000000 --- a/configuration/scripts/options/set_nml.kevp102 +++ /dev/null @@ -1 +0,0 @@ -kevp_kernel = 102 diff --git a/configuration/scripts/options/set_nml.qc b/configuration/scripts/options/set_nml.qc index 2b1528cc5..70ba1b429 100644 --- a/configuration/scripts/options/set_nml.qc +++ b/configuration/scripts/options/set_nml.qc @@ -1,4 +1,12 @@ -npt = 43800 +npt_unit = 'y' +npt = 5 +year_init = 2005 +month_init = 1 +day_init = 1 +sec_init = 0 +use_leap_years = .false. +fyear_init = 2005 +ycycle = 1 dumpfreq = 'm' dumpfreq_n = 12 diagfreq = 24 diff --git a/configuration/scripts/options/set_nml.run10year b/configuration/scripts/options/set_nml.run10year new file mode 100644 index 000000000..cf672e991 --- /dev/null +++ b/configuration/scripts/options/set_nml.run10year @@ -0,0 +1,7 @@ +npt_unit = 'y' +npt = 10 +dumpfreq = 'y' +dumpfreq_n = 12 +diagfreq = 24 +histfreq = 'm','x','x','x','x' + diff --git a/configuration/scripts/options/set_nml.snw30percent b/configuration/scripts/options/set_nml.snw30percent new file mode 100644 index 000000000..ecf88ad4e --- /dev/null +++ b/configuration/scripts/options/set_nml.snw30percent @@ -0,0 +1,5 @@ +tr_snow = .true. +snwredist = 'bulk' +snwlvlfac = 0.3 +nslyr = 5 + diff --git a/configuration/scripts/options/set_nml.snwITDrdg b/configuration/scripts/options/set_nml.snwITDrdg new file mode 100644 index 000000000..cddeedec3 --- /dev/null +++ b/configuration/scripts/options/set_nml.snwITDrdg @@ -0,0 +1,10 @@ +tr_snow = .true. +snwredist = 'ITDrdg' +nslyr = 5 +rhosnew = 100.0 +rhosmin = 100.0 +rhosmax = 450.0 +windmin = 10.0 +drhosdwind = 27.3 +snwlvlfac = 0.3 + diff --git a/configuration/scripts/options/set_nml.snwgrain b/configuration/scripts/options/set_nml.snwgrain new file mode 100644 index 000000000..653030385 --- /dev/null +++ b/configuration/scripts/options/set_nml.snwgrain @@ -0,0 +1,15 @@ +tr_snow = .true. +snwgrain = .true. +use_smliq_pnd = .true. +rsnw_fall = 54.526 +rsnw_tmax = 1500.0 +snw_aging_table = 'file' +snw_filename = 'ICE_MACHINE_INPUTDATA/CICE_data/forcing/snicar_drdt_bst_fit_60_c04262019.nc' +snw_tau_fname = 'snowEmpiricalGrowthParameterTau' +snw_kappa_fname = 'snowEmpiricalGrowthParameterKappa' +snw_drdt0_fname = 'snowPropertyRate' +snw_rhos_fname = 'nGrainAgingSnowDensity' +snw_Tgrd_fname = 'nGrainAgingTempGradient' +snw_T_fname = 'nGrainAgingTemperature' +nslyr = 5 + diff --git a/configuration/scripts/tests/QC/cice.t-test.py b/configuration/scripts/tests/QC/cice.t-test.py index 987175245..6f2c7e89b 100755 --- a/configuration/scripts/tests/QC/cice.t-test.py +++ b/configuration/scripts/tests/QC/cice.t-test.py @@ -57,6 +57,15 @@ def gen_filenames(base_dir, test_dir): " # of files: {}".format(len(files_b))) sys.exit(-1) + if len(files_a) < 1825: + logger.error("Number of output files too small, expecting at least 1825." + \ + " Exiting...\n" + \ + "Baseline directory: {}\n".format(path_a) + \ + " # of files: {}\n".format(len(files_a)) + \ + "Test directory: {}\n".format(path_b) + \ + " # of files: {}".format(len(files_b))) + sys.exit(-1) + logger.info("Number of files: %d", len(files_a)) return path_a, path_b, files_a, files_b diff --git a/configuration/scripts/tests/base_suite.ts b/configuration/scripts/tests/base_suite.ts index 69252f9fb..4da4dd110 100644 --- a/configuration/scripts/tests/base_suite.ts +++ b/configuration/scripts/tests/base_suite.ts @@ -9,9 +9,9 @@ smoke gx3 7x2 diag1,bigdiag,run1day,diagpt1 decomp gx3 4x2x25x29x5 none smoke gx3 4x2 diag1,run5day smoke_gx3_8x2_diag1_run5day smoke gx3 4x1 diag1,run5day,thread smoke_gx3_8x2_diag1_run5day -restart gx1 40x4 droundrobin -restart tx1 40x4 dsectrobin -restart tx1 60x2 droundrobin,maskhalo +smoke gx3 1x8 diag1,run5day,evp1d +restart gx1 40x4 droundrobin,medium +restart tx1 40x4 dsectrobin,medium restart gx3 4x4 none restart gx3 10x4 maskhalo restart gx3 6x2 alt01 @@ -58,6 +58,9 @@ restart gx3 4x2 fsd12,debug,short smoke gx3 8x2 fsd12ww3,diag24,run1day smoke gx3 4x1 isotope,debug restart gx3 8x2 isotope +smoke gx3 4x1 snwITDrdg,snwgrain,icdefault,debug +smoke gx3 4x1 snw30percent,icdefault,debug +restart gx3 8x2 snwITDrdg,icdefault,snwgrain restart gx3 4x4 gx3ncarbulk,iobinary restart gx3 4x4 histall,precision8,cdf64 smoke gx3 30x1 bgcz,histall diff --git a/configuration/scripts/tests/comparelog.csh b/configuration/scripts/tests/comparelog.csh index d9e4a7a89..af6b2d76e 100755 --- a/configuration/scripts/tests/comparelog.csh +++ b/configuration/scripts/tests/comparelog.csh @@ -58,8 +58,8 @@ if (${filearg} == 1) then cat ${base_data} | grep -A 99999999 "total ice area (km^2)" | grep -e istep1: -e = | grep -iv "min, max, sum" >&! ${base_out} cat ${test_data} | grep -A 99999999 "total ice area (km^2)" | grep -e istep1: -e = | grep -iv "min, max, sum" >&! ${test_out} else - cp -f ${base_data} ${base_out} - cp -f ${test_data} ${test_out} + sed -n '/RunningUnitTest/,$p' ${base_data} >! ${base_out} + sed -n '/RunningUnitTest/,$p' ${test_data} >! ${test_out} endif set basenum = `cat ${base_out} | wc -l` diff --git a/configuration/scripts/tests/io_suite.ts b/configuration/scripts/tests/io_suite.ts index 6fe1f589a..4d5129578 100644 --- a/configuration/scripts/tests/io_suite.ts +++ b/configuration/scripts/tests/io_suite.ts @@ -12,6 +12,7 @@ restart gx3 32x1 gx3ncarbulk,bgcz,histall,iobinary,precision8 restart gx3 16x2 gx3ncarbulk,bgcskl,histall,iobinary restart gx3 14x2 gx3ncarbulk,isotope,histall,iobinary,precision8 restart gx3 16x2 gx3ncarbulk,fsd12,histall,iobinary +restart gx3 8x4 gx3ncarbulk,debug,histall,iobinary,precision8,histinst restart gx3 32x1 debug,histall,ionetcdf restart gx3 15x2 alt01,histall,ionetcdf,precision8,cdf64 @@ -24,6 +25,7 @@ restart gx3 30x1 bgcz,histall,ionetcdf restart gx3 15x2 bgcskl,histall,ionetcdf,precision8 restart gx3 31x1 isotope,histall,ionetcdf,cdf64 restart gx3 14x2 fsd12,histall,ionetcdf,precision8 +restart gx3 32x1 debug,histall,ionetcdf,histinst restart gx3 16x2 debug,histall,iopio1,precision8,cdf64 restart gx3 14x2 alt01,histall,iopio1,cdf64 @@ -36,6 +38,7 @@ restart gx3 16x2 bgcz,histall,iopio1,precision8 restart gx3 30x1 bgcskl,histall,iopio1 restart gx3 8x4 isotope,histall,iopio1,precision8,cdf64 restart gx3 12x2 fsd12,histall,iopio1,cdf64 +restart gx3 16x2 debug,histall,iopio1,precision8,cdf64,histinst restart gx3 16x2 debug,histall,iopio2 restart gx3 14x2 alt01,histall,iopio2,precision8,cdf64 @@ -48,6 +51,7 @@ restart gx3 16x2 bgcz,histall,iopio2,cdf64 restart gx3 30x1 bgcskl,histall,iopio2,precision8 restart gx3 8x4 isotope,histall,iopio2 restart gx3 12x2 fsd12,histall,iopio2,precision8,cdf64 +restart gx3 16x2 debug,histall,iopio2,histinst restart gx3 16x2 debug,histall,iopio1p,precision8 restart gx3 14x2 alt01,histall,iopio1p @@ -60,6 +64,7 @@ restart gx3 16x2 bgcz,histall,iopio1p,precision8,cdf64 restart gx3 30x1 bgcskl,histall,iopio1p,cdf64 restart gx3 8x4 isotope,histall,iopio1p,precision8 restart gx3 12x2 fsd12,histall,iopio1p +restart gx3 16x2 debug,histall,iopio1p,precision8,histinst restart gx3 16x2 debug,histall,iopio2p,cdf64 restart gx3 14x2 alt01,histall,iopio2p,precision8 @@ -72,4 +77,5 @@ restart gx3 16x2 bgcz,histall,iopio2p restart gx3 30x1 bgcskl,histall,iopio2p,precision8,cdf64 restart gx3 8x4 isotope,histall,iopio2p,cdf64 restart gx3 12x2 fsd12,histall,iopio2p,precision8 +restart gx3 16x2 debug,histall,iopio2p,cdf64,histinst diff --git a/configuration/scripts/tests/prod_suite.ts b/configuration/scripts/tests/prod_suite.ts new file mode 100644 index 000000000..8793dfed2 --- /dev/null +++ b/configuration/scripts/tests/prod_suite.ts @@ -0,0 +1,4 @@ +# Test Grid PEs Sets BFB-compare +smoke gx1 64x1 qc,medium +smoke gx1 64x2 gx1prod,long,run10year + diff --git a/configuration/scripts/tests/reprosum_suite.ts b/configuration/scripts/tests/reprosum_suite.ts index d65370e0a..dd6a6d56b 100644 --- a/configuration/scripts/tests/reprosum_suite.ts +++ b/configuration/scripts/tests/reprosum_suite.ts @@ -8,4 +8,5 @@ logbfb gx3 1x20x5x29x80 dsectrobin,diag1,short,reprosum l logbfb gx3 8x2x8x10x20 droundrobin,diag1,reprosum logbfb_gx3_4x2x25x29x4_diag1_dslenderX2_reprosum logbfb gx3 6x2x50x58x1 droundrobin,diag1,reprosum logbfb_gx3_4x2x25x29x4_diag1_dslenderX2_reprosum logbfb gx3 6x2x4x29x18 dspacecurve,diag1,maskhalo,reprosum logbfb_gx3_4x2x25x29x4_diag1_dslenderX2_reprosum +logbfb gx3 17x2x1x1x800 droundrobin,diag1,maskhalo,reprosum logbfb_gx3_4x2x25x29x4_diag1_dslenderX2_reprosum #logbfb gx3 8x2x8x10x20 droundrobin,diag1 logbfb_gx3_4x2x25x29x4_diag1_dslenderX2 diff --git a/configuration/scripts/tests/test_unittest.script b/configuration/scripts/tests/test_unittest.script index 5f37b15ac..1db8dfe60 100644 --- a/configuration/scripts/tests/test_unittest.script +++ b/configuration/scripts/tests/test_unittest.script @@ -4,24 +4,33 @@ # cice.run returns -1 if run did not complete successfully ./cice.run -set res="$status" +set rres="$status" set log_file = `ls -t1 ${ICE_RUNDIR}/cice.runlog* | head -1` +grep ' TEST COMPLETED SUCCESSFULLY' ${log_file} +set tres="$status" + mv -f ${ICE_CASEDIR}/test_output ${ICE_CASEDIR}/test_output.prev cat ${ICE_CASEDIR}/test_output.prev | grep -iv "${ICE_TESTNAME} run" >! ${ICE_CASEDIR}/test_output mv -f ${ICE_CASEDIR}/test_output ${ICE_CASEDIR}/test_output.prev cat ${ICE_CASEDIR}/test_output.prev | grep -iv "${ICE_TESTNAME} test" >! ${ICE_CASEDIR}/test_output rm -f ${ICE_CASEDIR}/test_output.prev -set grade = PASS -if ( $res != 0 ) then - set grade = FAIL - echo "$grade ${ICE_TESTNAME} run " >> ${ICE_CASEDIR}/test_output - echo "$grade ${ICE_TESTNAME} test " >> ${ICE_CASEDIR}/test_output - exit 99 +set rgrade = PASS +if ( $rres != 0 ) then + set rgrade = FAIL +endif +set tgrade = PASS +if ( $tres != 0 ) then + set tgrade = FAIL endif -echo "$grade ${ICE_TESTNAME} run " >> ${ICE_CASEDIR}/test_output -echo "$grade ${ICE_TESTNAME} test " >> ${ICE_CASEDIR}/test_output +echo "$rgrade ${ICE_TESTNAME} run " >> ${ICE_CASEDIR}/test_output +echo "$tgrade ${ICE_TESTNAME} test " >> ${ICE_CASEDIR}/test_output + +if ( "$rgrade" == "FAIL" || "$tgrade" == "FAIL") then + echo "ERROR: Test failed" + exit 99 +endif diff --git a/doc/source/cice_index.rst b/doc/source/cice_index.rst index 2efcd0335..0a04b5e26 100644 --- a/doc/source/cice_index.rst +++ b/doc/source/cice_index.rst @@ -168,6 +168,7 @@ either Celsius or Kelvin units). "dms", "dimethyl sulfide concentration", "mmol/m\ :math:`^3`" "dmsp", "dimethyl sulfoniopropionate concentration", "mmol/m\ :math:`^3`" "dpscale", "time scale for flushing in permeable ice", ":math:`1\times 10^{-3}`" + "drhosdwind", "wind compaction factor for snow", "27.3 kg s/m\ :math:`^{4}`" "dragio", "drag coefficient for water on ice", "0.00536" "dSdt_slow_mode", "drainage strength parameter", "" "dsnow", "change in snow thickness", "m" @@ -256,6 +257,7 @@ either Celsius or Kelvin units). "fsnow", "snowfall rate", "kg/m\ :math:`^2`/s" "fsnowrdg", "snow fraction that survives in ridging", "0.5" "fsurf(n)(_f)", "net surface heat flux excluding fcondtop", "W/m\ :math:`^2`" + "fsloss", "rate of snow loss to leads", "kg/m\ :math:`^{2}` s" "fsw", "incoming shortwave radiation", "W/m\ :math:`^2`" "fswabs", "total absorbed shortwave radiation", "W/m\ :math:`^2`" "fswfac", "scaling factor to adjust ice quantities for updated data", "" @@ -393,6 +395,8 @@ either Celsius or Kelvin units). "meltb", "basal ice melt", "m" "meltl", "lateral ice melt", "m" "melts", "snow melt", "m" + "meltsliq", "snow melt mass", "kg/m\ :math:`^{2}`" + "meltsliqn", "snow melt mass in category n", "kg/m\ :math:`^{2}`" "meltt", "top ice melt", "m" "min_salin", "threshold for brine pockets", "0.1 ppt" "mlt_onset", "day of year that surface melt begins", "" @@ -556,14 +560,21 @@ either Celsius or Kelvin units). "rhofresh", "density of fresh water", "1000.0 kg/m\ :math:`^3`" "rhoi", "density of ice", "917. kg/m\ :math:`^3`" "rhos", "density of snow", "330. kg/m\ :math:`^3`" + "rhos_cmp", "density of snow due to wind compaction", "kg/m\ :math:`^3`" + "rhos_cnt", "density of ice and liquid content of snow", "kg/m\ :math:`^3`" "rhosi", "average sea ice density (for hbrine tracer)", "940. kg/m\ :math:`^3`" + "rhosmax", "maximum snow density", "450 kg/m\ :math:`^{3}`" + "rhosmin", "minimum snow density", "100 kg/m\ :math:`^{3}`" + "rhosnew", "new snow density", "100 kg/m\ :math:`^{3}`" "rhow", "density of seawater", "1026. kg/m\ :math:`^3`" "rnilyr", "real(nlyr)", "" "rside", "fraction of ice that melts laterally", "" - "rsnw_fresh", "freshly fallen snow grain radius", "100. :math:`\times` 10\ :math:`^{-6}` m" + "rsnw", "snow grain radius", "10\ :math:`^{-6}` m" + "rsnw_fall", "freshly fallen snow grain radius", "100. :math:`\times` 10\ :math:`^{-6}` m" "rsnw_melt", "melting snow grain radius", "1000. :math:`\times` 10\ :math:`^{-6}` m" "rsnw_nonmelt", "nonmelting snow grain radius", "500. :math:`\times` 10\ :math:`^{-6}` m" "rsnw_sig", "standard deviation of snow grain radius", "250. :math:`\times` 10\ :math:`^{-6}` m" + "rsnw_tmax", "maximum snow radius", "1500. :math:`\times` 10\ :math:`^{-6}` m" "runid", "identifier for run", "" "runtype", "type of initialization used", "" "**S**", "", "" @@ -586,6 +597,25 @@ either Celsius or Kelvin units). "snoice", "snow–ice formation", "m" "snowpatch", "length scale for parameterizing nonuniform snow coverage", "0.02 m" "skl_bgc", "biogeochemistry on/off", "" + "smassice", "mass of ice in snow from smice tracer", "kg/m\ :math:`^2`" + "smassliq", "mass of liquid in snow from smliq tracer", "kg/m\ :math:`^2`" + "snowage_drdt0", "initial rate of change of effective snow radius", " " + "snowage_rhos", "snow aging parameter (density)", " " + "snowage_kappa", "snow aging best-fit parameter", " " + "snowage_tau", "snow aging best-fit parameter", " " + "snowage_T", "snow aging parameter (temperature)", " " + "snowage_Tgrd", "snow aging parameter (temperature gradient)", " " + "snw_aging_table", "snow aging lookup table", " " + "snw_filename", "snowtable filename", " " + "snw_tau_fname", "snowtable file tau fieldname", " " + "snw_kappa_fname", "snowtable file kappa fieldname", " " + "snw_drdt0_fname", "snowtable file drdt0 fieldname", " " + "snw_rhos_fname", "snowtable file rhos fieldname", " " + "snw_Tgrd_fname", "snowtable file Tgrd fieldname", " " + "snw_T_fname", "snowtable file T fieldname", " " + "snwgrain", "activate snow metamorphosis", " " + "snwlvlfac", "fractional increase in snow depth for redistribution on ridges", "0.3" + "snwredist", "type of snow redistribution", " " "spval", "special value (single precision)", ":math:`10^{30}`", "" "spval_dbl", "special value (double precision)", ":math:`10^{30}`", "" "ss_tltx(y)", "sea surface in the x(y) direction", "m/m" @@ -666,6 +696,7 @@ either Celsius or Kelvin units). "update_ocn_f", "if true, include frazil ice fluxes in ocean flux fields", "" "use_leap_years", "if true, include leap days", "" "use_restart_time", "if true, use date from restart file", "" + "use_smliq_pnd", "use liquid in snow for ponds", " " "ustar_min", "minimum friction velocity under ice", "" "ucstr", "string identifying U grid for history variables", "" "uvel", "x-component of ice velocity", "m/s" @@ -691,6 +722,7 @@ either Celsius or Kelvin units). "wave_spectrum", "wave spectrum", "m\ :math:`^2`/s" "wavefreq", "wave frequencies", "1/s" "wind", "wind speed", "m/s" + "windmin", "minimum wind speed to compact snow", "10 m/s" "write_history", "if true, write history now", "" "write_ic", "if true, write initial conditions", "" "write_restart", "if 1, write restart now", "" diff --git a/doc/source/conf.py b/doc/source/conf.py index 4cf2f580d..099f65403 100644 --- a/doc/source/conf.py +++ b/doc/source/conf.py @@ -62,9 +62,9 @@ # built documents. # # The short X.Y version. -version = u'6.2.0' +version = u'6.3.0' # The full version, including alpha/beta/rc tags. -version = u'6.2.0' +version = u'6.3.0' # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages. diff --git a/doc/source/developer_guide/dg_driver.rst b/doc/source/developer_guide/dg_driver.rst index a10cb319a..637e91b68 100644 --- a/doc/source/developer_guide/dg_driver.rst +++ b/doc/source/developer_guide/dg_driver.rst @@ -65,7 +65,6 @@ The initialize calling sequence looks something like:: call init_thermo_vertical ! initialize vertical thermodynamics call icepack_init_itd(ncat, hin_max) ! ice thickness distribution if (tr_fsd) call icepack_init_fsd_bounds ! floe size distribution - call calendar(time) ! determine the initial date call init_forcing_ocn(dt) ! initialize sss and sst from data call init_state ! initialize the ice state call init_transport ! initialize horizontal transport @@ -74,10 +73,13 @@ The initialize calling sequence looks something like:: call init_diags ! initialize diagnostic output points call init_history_therm ! initialize thermo history variables call init_history_dyn ! initialize dynamic history variables + call calc_timesteps ! update timestep counter if not using npt_unit="1" call init_shortwave ! initialize radiative transfer + call advance_timestep ! advance the time step call init_forcing_atmo ! initialize atmospheric forcing (standalone) if (tr_fsd .and. wave_spec) call get_wave_spec ! wave spectrum in ice call get_forcing* ! read forcing data (standalone) + if (tr_snow) call icepack_init_snow ! advanced snow physics See a **CICE_InitMod.F90** file for the latest. @@ -105,6 +107,13 @@ The run sequence within a time loop looks something like:: call update_state (dt_dyn, daidtd, dvidtd, dagedtd, offset) enddo + if (tr_snow) then ! advanced snow physics + do iblk = 1, nblocks + call step_snow (dt, iblk) + enddo + call update_state (dt) ! clean up + endif + do iblk = 1, nblocks call step_radiation (dt, iblk) call coupling_prep (iblk) diff --git a/doc/source/developer_guide/dg_dynamics.rst b/doc/source/developer_guide/dg_dynamics.rst index 47b54bde2..48dead1cb 100644 --- a/doc/source/developer_guide/dg_dynamics.rst +++ b/doc/source/developer_guide/dg_dynamics.rst @@ -6,7 +6,7 @@ Dynamics ============================ -The CICE **cicecore/** directory consists of the non icepack source code. Within that +The CICE **cicecore/** directory consists of the non icepack source code. Within that directory there are the following subdirectories **cicecore/cicedynB/analysis** contains higher level history and diagnostic routines. @@ -30,28 +30,19 @@ Dynamical Solvers -------------------- The dynamics solvers are found in **cicecore/cicedynB/dynamics/**. A couple of different solvers are -available including EVP, revised EVP, EAP and VP. The dynamics solver is specified in namelist with the -``kdyn`` variable. ``kdyn=1`` is evp, ``kdyn=2`` is eap, ``kdyn=3`` is VP and revised EVP requires -the ``revised_evp`` namelist flag be set to true. - -Multiple EVP solvers are supported thru the namelist flag ``kevp_kernel``. The standard implementation -and current default is ``kevp_kernel=0``. In this case, the stress is solved on the regular decomposition -via subcycling and calls to subroutine ``stress`` and subroutine ``stepu`` with MPI global sums required in each -subcycling call. With ``kevp_kernel=2``, the data required to compute the stress is gathered to the root -MPI process and the stress calculation is performed on the root task without any MPI global sums. OpenMP -parallelism is supported in ``kevp_kernel=2``. The solutions with ``kevp_kernel`` set to 0 or 2 will -not be bit-for-bit -identical but should be the same to roundoff and produce the same climate. ``kevp_kernel=2`` may perform -better for some configurations, some machines, and some pe counts. ``kevp_kernel=2`` is not supported -with the tripole grid and is still being validated. Until ``kevp_kernel=2`` is fully validated, it will -abort if set. To override the abort, use value 102 for testing. +available including EVP, EAP and VP. The dynamics solver is specified in namelist with the +``kdyn`` variable. ``kdyn=1`` is evp, ``kdyn=2`` is eap, ``kdyn=3`` is VP. + +Two alternative implementations of EVP are included. The first alternative is the Revised EVP, triggered when the ``revised_evp`` is set to true. The second alternative is the 1d EVP solver triggered when the ``evp_algorithm`` is set to ``shared_mem_1d`` as oppose to the default setting of ``evp_standard_2d``. The solutions with ``evp_algorithm`` set to ``standard_2d`` or ``shared_mem_1d`` will +not be bit-for-bit identical when compared to each other. The reason for this is floating point round off errors that occur unless strict compiler flags are used. ``evp_algorithm=shared_mem_1d`` is primarily built for OpenMP. If MPI domain splitting is used then the solver will only run on the master processor. ``evp_algorithm=shared_mem_1d`` is not supported +with the tripole grid. Transport ----------------- -The transport (advection) methods are found in **cicecore/cicedynB/dynamics/**. Two methods are supported, -upwind and remap. These are set in namelist via the ``advection`` variable. +The transport (advection) methods are found in **cicecore/cicedynB/dynamics/**. Two methods are supported, +upwind and remap. These are set in namelist via the ``advection`` variable. Transport can be disabled with the ``ktransport`` namelist variable. @@ -90,7 +81,7 @@ Time Manager Time manager data is module data in **cicecore/shared/ice_calendar.F90**. Much of the time manager data is public and operated on during the model timestepping. The model timestepping actually takes -place in the **CICE_RunMod.F90** file which is part of the driver code. +place in the **CICE_RunMod.F90** file which is part of the driver code. The time manager was updated in early 2021. Additional information about the time manager can be found here, :ref:`timemanagerplus` @@ -100,12 +91,12 @@ Communication ------------------ Two low-level communications packages, mpi and serial, are provided as part of CICE. This software -provides a middle layer between the model and the underlying libraries. Only the CICE mpi or +provides a middle layer between the model and the underlying libraries. Only the CICE mpi or serial directories are compiled with CICE, not both. -**cicedynB/infrastructure/comm/mpi/** +**cicedynB/infrastructure/comm/mpi/** is based on MPI and provides various methods to do halo updates, global sums, gather/scatter, broadcasts -and similar using some fairly generic interfaces to isolate the MPI calls in the code. +and similar using some fairly generic interfaces to isolate the MPI calls in the code. **cicedynB/infrastructure/comm/serial/** support the same interfaces, but operates in shared memory mode with no MPI. The serial library will be used, by default in the CICE scripts, @@ -124,7 +115,7 @@ case. This has to be set before CICE is built. **cicedynB/infrastructure/io/io_netcdf/** is the default for the standalone CICE model, and it supports writing history and restart files in netcdf format using standard netcdf calls. It does this by writing from and reading to the root task and -gathering and scattering fields from the root task to support model parallelism. +gathering and scattering fields from the root task to support model parallelism. **cicedynB/infrastructure/io/io_binary/** supports files in binary format using a gather/scatter approach and reading to and writing from the root task. @@ -134,4 +125,3 @@ is a parallel io library (https://github.com/NCAR/ParallelIO) that supports read binary and netcdf file through various interfaces including netcdf and pnetcdf. pio is generally more parallel in memory even when using serial netcdf than the standard gather/scatter methods, and it provides parallel read/write capabilities by optionally linking and using pnetcdf. - diff --git a/doc/source/developer_guide/dg_forcing.rst b/doc/source/developer_guide/dg_forcing.rst index 0c0380538..aea6d8ef6 100644 --- a/doc/source/developer_guide/dg_forcing.rst +++ b/doc/source/developer_guide/dg_forcing.rst @@ -180,7 +180,7 @@ constant thereafter. Different conditions can be specified thru the .. _box2001forcing: Box2001 Atmosphere Forcing -------------------------- +--------------------------- The box2001 forcing dataset in generated internally. No files are read. The dataset is used to test an idealized box case as defined in :cite:`Hunke01`. diff --git a/doc/source/science_guide/sg_dynamics.rst b/doc/source/science_guide/sg_dynamics.rst index ecef531b4..d4e209d8a 100644 --- a/doc/source/science_guide/sg_dynamics.rst +++ b/doc/source/science_guide/sg_dynamics.rst @@ -6,10 +6,9 @@ Dynamics ======== There are different approaches in the CICE code for representing sea ice -rheology and for solving the sea ice momentum equation. The -elastic-viscous-plastic (EVP) model represents a modification of the -standard viscous-plastic (VP) model for sea ice dynamics -:cite:`Hibler79`. The elastic-anisotropic-plastic (EAP) model, +rheology and for solving the sea ice momentum equation. The viscous-plastic (VP) originally developed by :cite:`Hibler79`, +the elastic-viscous-plastic (EVP) :cite:`Hunke97` model represents a modification of the +standard viscous-plastic (VP) model for sea ice dynamics. The elastic-anisotropic-plastic (EAP) model, on the other hand, explicitly accounts for the observed sub-continuum anisotropy of the sea ice cover :cite:`Wilchinsky06,Weiss09`. If ``kdyn`` = 1 in the namelist then the EVP model is used (module @@ -68,7 +67,7 @@ vertical direction: where :math:`m` is the combined mass of ice and snow per unit area and :math:`\vec{\tau}_a` and :math:`\vec{\tau}_w` are wind and ocean -stresses, respectively. The term :math:`\vec{\tau}_b` is a +stresses, respectively. The term :math:`\vec{\tau}_b` is a seabed stress (also referred to as basal stress) that represents the grounding of pressure ridges in shallow water :cite:`Lemieux16`. The mechanical properties of the ice are represented by the internal stress tensor :math:`\sigma_{ij}`. The other two terms on @@ -84,11 +83,11 @@ For clarity, the two components of Equation :eq:`vpmom` are .. math:: \begin{aligned} - m{\partial u\over\partial t} &= {\partial\sigma_{1j}\over\partial x_j} + \tau_{ax} + + m{\partial u\over\partial t} &= {\partial\sigma_{1j}\over\partial x_j} + \tau_{ax} + a_i c_w \rho_w \left|{\bf U}_w - {\bf u}\right| \left[\left(U_w-u\right)\cos\theta - \left(V_w-v\right)\sin\theta\right] -C_bu +mfv - mg{\partial H_\circ\over\partial x}, \\ - m{\partial v\over\partial t} &= {\partial\sigma_{2j}\over\partial x_j} + \tau_{ay} + + m{\partial v\over\partial t} &= {\partial\sigma_{2j}\over\partial x_j} + \tau_{ay} + a_i c_w \rho_w \left|{\bf U}_w - {\bf u}\right| \left[\left(U_w-u\right)\sin\theta + \left(V_w-v\right)\cos\theta\right] -C_bv-mfu - mg{\partial H_\circ\over\partial y}. \end{aligned} @@ -111,14 +110,14 @@ Elastic-Viscous-Plastic The momentum equation is discretized in time as follows, for the classic EVP approach. In the code, -:math:`{\tt vrel}=a_i c_w \rho_w\left|{\bf U}_w - {\bf u}^k\right|` and -:math:`C_b=T_b \left( \sqrt{(u^k)^2+(v^k)^2}+u_0 \right)^{-1}`, +:math:`{\tt vrel}=a_i c_w \rho_w\left|{\bf U}_w - {\bf u}^k\right|` and +:math:`C_b=T_b \left( \sqrt{(u^k)^2+(v^k)^2}+u_0 \right)^{-1}`, where :math:`k` denotes the subcycling step. The following equations illustrate the time discretization and define some of the other variables used in the code. .. math:: - \underbrace{\left({m\over\Delta t_e}+{\tt vrel} \cos\theta\ + C_b \right)}_{\tt cca} u^{k+1} + \underbrace{\left({m\over\Delta t_e}+{\tt vrel} \cos\theta\ + C_b \right)}_{\tt cca} u^{k+1} - \underbrace{\left(mf+{\tt vrel}\sin\theta\right)}_{\tt ccb}v^{k+1} = &\underbrace{{\partial\sigma_{1j}^{k+1}\over\partial x_j}}_{\tt strintx} + \underbrace{\tau_{ax} - mg{\partial H_\circ\over\partial x} }_{\tt forcex} \\ @@ -126,7 +125,7 @@ variables used in the code. :label: umom .. math:: - \underbrace{\left(mf+{\tt vrel}\sin\theta\right)}_{\tt ccb} u^{k+1} + \underbrace{\left(mf+{\tt vrel}\sin\theta\right)}_{\tt ccb} u^{k+1} + \underbrace{\left({m\over\Delta t_e}+{\tt vrel} \cos\theta + C_b \right)}_{\tt cca}v^{k+1} = &\underbrace{{\partial\sigma_{2j}^{k+1}\over\partial x_j}}_{\tt strinty} + \underbrace{\tau_{ay} - mg{\partial H_\circ\over\partial y} }_{\tt forcey} \\ @@ -139,7 +138,7 @@ We solve this system of equations analytically for :math:`u^{k+1}` and :math:`v^{k+1}`. Define .. math:: - \hat{u} = F_u + \tau_{ax} - mg{\partial H_\circ\over\partial x} + {\tt vrel} \left(U_w\cos\theta - V_w\sin\theta\right) + {m\over\Delta t_e}u^k + \hat{u} = F_u + \tau_{ax} - mg{\partial H_\circ\over\partial x} + {\tt vrel} \left(U_w\cos\theta - V_w\sin\theta\right) + {m\over\Delta t_e}u^k :label: cevpuhat .. math:: @@ -169,7 +168,7 @@ where .. math:: b = mf + {\tt vrel}\sin\theta. :label: cevpb - + .. _vp-momentum: Viscous-Plastic @@ -248,52 +247,52 @@ stress are expressed as :math:`\tau_{bx}=C_bu` and coefficient. The two parameterizations differ in their calculation of -the :math:`C_b` coefficients. +the :math:`C_b` coefficients. Note that the user must provide a bathymetry field for using these grounding schemes. It is suggested to have a bathymetry field with water depths larger than 5 m that represents well shallow water (less than 30 m) regions such as the Laptev Sea -and the East Siberian Sea. +and the East Siberian Sea. Seabed stress based on linear keel draft (LKD) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This parameterization for the seabed stress is described in :cite:`Lemieux16`. It assumes that the largest keel draft varies linearly with the mean thickness in a grid cell (i.e. sea ice volume). The :math:`C_b` coefficients are expressed as .. math:: C_b= k_2 \max [0,(h_u - h_{cu})] e^{-\alpha_b * (1 - a_u)} (\sqrt{u^2+v^2}+u_0)^{-1}, \\ - :label: Cb + :label: Cb -where :math:`k_2` determines the maximum seabed stress that can be sustained by the grounded parameterized ridge(s), :math:`u_0` -is a small residual velocity and :math:`\alpha_b` is a parameter to ensure that the seabed stress quickly drops when -the ice concentration is smaller than 1. In the code, :math:`k_2 \max [0,(h_u - h_{cu})] e^{-\alpha_b * (1 - a_u)}` is defined as -:math:`T_b`. The quantities :math:`h_u`, :math:`a_{u}` and :math:`h_{cu}` are calculated at -the 'u' point based on local ice conditions (surrounding tracer points). They are respectively given by +where :math:`k_2` determines the maximum seabed stress that can be sustained by the grounded parameterized ridge(s), :math:`u_0` +is a small residual velocity and :math:`\alpha_b` is a parameter to ensure that the seabed stress quickly drops when +the ice concentration is smaller than 1. In the code, :math:`k_2 \max [0,(h_u - h_{cu})] e^{-\alpha_b * (1 - a_u)}` is defined as +:math:`T_b`. The quantities :math:`h_u`, :math:`a_{u}` and :math:`h_{cu}` are calculated at +the 'u' point based on local ice conditions (surrounding tracer points). They are respectively given by .. math:: h_u=\max[v_i(i,j),v_i(i+1,j),v_i(i,j+1),v_i(i+1,j+1)], \\ - :label: hu - + :label: hu + .. math:: a_u=\max[a_i(i,j),a_i(i+1,j),a_i(i,j+1),a_i(i+1,j+1)]. \\ - :label: au - + :label: au + .. math:: h_{cu}=a_u h_{wu} / k_1, \\ :label: hcu -where the :math:`a_i` and :math:`v_i` are the total ice concentrations and ice volumes around the :math:`u` point :math:`i,j` and -:math:`k_1` is a parameter that defines the critical ice thickness :math:`h_{cu}` at which the parameterized -ridge(s) reaches the seafloor for a water depth :math:`h_{wu}=\min[h_w(i,j),h_w(i+1,j),h_w(i,j+1),h_w(i+1,j+1)]`. Given the formulation of :math:`C_b` in equation :eq:`Cb`, the seabed stress components are non-zero only -when :math:`h_u > h_{cu}`. +where the :math:`a_i` and :math:`v_i` are the total ice concentrations and ice volumes around the :math:`u` point :math:`i,j` and +:math:`k_1` is a parameter that defines the critical ice thickness :math:`h_{cu}` at which the parameterized +ridge(s) reaches the seafloor for a water depth :math:`h_{wu}=\min[h_w(i,j),h_w(i+1,j),h_w(i,j+1),h_w(i+1,j+1)]`. Given the formulation of :math:`C_b` in equation :eq:`Cb`, the seabed stress components are non-zero only +when :math:`h_u > h_{cu}`. -The maximum seabed stress depends on the weight of the ridge -above hydrostatic balance and the value of :math:`k_2`. It is, however, the parameter :math:`k_1` that has the most notable impact on the simulated extent of landfast ice. -The value of :math:`k_1` can be changed at runtime using the namelist variable ``k1``. +The maximum seabed stress depends on the weight of the ridge +above hydrostatic balance and the value of :math:`k_2`. It is, however, the parameter :math:`k_1` that has the most notable impact on the simulated extent of landfast ice. +The value of :math:`k_1` can be changed at runtime using the namelist variable ``k1``. -To prevent unrealistic grounding, :math:`T_b` is set to zero when :math:`h_{wu}` -is larger than 30 m. This maximum value is chosen based on observations of large +To prevent unrealistic grounding, :math:`T_b` is set to zero when :math:`h_{wu}` +is larger than 30 m. This maximum value is chosen based on observations of large keels in the Arctic Ocean :cite:`Amundrud04`. Seabed stress based on probabilistic approach @@ -304,11 +303,11 @@ on the probability of contact between the ice thickness distribution (ITD) and the seabed. Multi-thickness category models such as CICE typically use a few thickness categories (5-10). This crude representation of the ITD does not resolve the tail of the ITD, which is crucial for grounding -events. +events. To represent the tail of the distribution, the simulated ITD is converted to a positively skewed probability function :math:`f(x)` -with :math:`x` the sea ice thickness. The mean and variance are set +with :math:`x` the sea ice thickness. The mean and variance are set equal to the ones of the original ITD. A log-normal distribution is used for :math:`f(x)`. @@ -317,7 +316,7 @@ distribution :math:`b(y)`. The mean of :math:`b(y)` comes from the user's bathym standard deviation :math:`\sigma_b` is currently fixed to 2.5 m. Two possible improvements would be to specify a distribution based on high resolution bathymetry data and to take into account variations of the -water depth due to changes in the sea surface height. +water depth due to changes in the sea surface height. Assuming hydrostatic balance and neglecting the impact of snow, the draft of floating ice of thickness :math:`x` is :math:`D(x)=\rho_i x / \rho_w` where :math:`\rho_i` is the sea ice density. Hence, the probability of contact (:math:`P_c`) between the @@ -337,7 +336,7 @@ and then obtains :math:`T_{bt}` by multiplying :math:`T_{bt}^*` by :math:`e^{-\a To calculate :math:`T_{bt}^*` in equation :eq:`Tbt`, :math:`f(x)` and :math:`b(y)` are discretized using many small categories (100). :math:`f(x)` is discretized between 0 and 50 m while :math:`b(y)` is truncated at plus and minus three :math:`\sigma_b`. :math:`f(x)` is also modified by setting it to zero after a certain percentile of the log-normal distribution. This percentile, which is currently set to 99.7%, notably affects the simulation of landfast ice and is used as a tuning parameter. Its impact is similar to the one of the parameter :math:`k_1` for the LKD method. -:math:`T_b` at the 'u' point is calculated from the 't' point values around it according to +:math:`T_b` at the 'u' point is calculated from the 't' point values around it according to .. math:: T_b=\max[T_{bt}(i,j),T_{bt}(i+1,j),T_{bt}(i,j+1),T_{bt}(i+1,j+1)]. \\ @@ -362,13 +361,13 @@ divergence, :math:`D_D`, and the horizontal tension and shearing strain rates, :math:`D_T` and :math:`D_S` respectively: .. math:: - D_D = \dot{\epsilon}_{11} + \dot{\epsilon}_{22}, + D_D = \dot{\epsilon}_{11} + \dot{\epsilon}_{22}, .. math:: - D_T = \dot{\epsilon}_{11} - \dot{\epsilon}_{22}, + D_T = \dot{\epsilon}_{11} - \dot{\epsilon}_{22}, .. math:: - D_S = 2\dot{\epsilon}_{12}, + D_S = 2\dot{\epsilon}_{12}, where @@ -376,12 +375,12 @@ where \dot{\epsilon}_{ij} = {1\over 2}\left({{\partial u_i}\over{\partial x_j}} + {{\partial u_j}\over{\partial x_i}}\right) CICE can output the internal ice pressure which is an important field to support navigation in ice-infested water. -The internal ice pressure (``sigP``) is the average of the normal stresses multiplied by :math:`-1` and +The internal ice pressure (``sigP``) is the average of the normal stresses multiplied by :math:`-1` and is therefore simply equal to :math:`-\sigma_1/2`. -Following the approach of :cite:`Konig10` (see also :cite:`Lemieux16`), the -elliptical yield curve can be modified such that the ice has isotropic tensile strength. -The tensile strength :math:`T_p` is expressed as a fraction of the ice strength :math:`P`, that is :math:`T_p=k_t P` +Following the approach of :cite:`Konig10` (see also :cite:`Lemieux16`), the +elliptical yield curve can be modified such that the ice has isotropic tensile strength. +The tensile strength :math:`T_p` is expressed as a fraction of the ice strength :math:`P`, that is :math:`T_p=k_t P` where :math:`k_t` should be set to a value between 0 and 1 (this can be changed at runtime with the namelist parameter ``Ktens``). The ice strength :math:`P` is a function of the ice thickness distribution as @@ -403,10 +402,10 @@ where :math:`\eta` and :math:`\zeta` are the bulk and shear viscosities. An elliptical yield curve is used, with the viscosities given by .. math:: - \zeta = {P(1+k_t)\over 2\Delta}, + \zeta = {P(1+k_t)\over 2\Delta}, .. math:: - \eta = {P(1+k_t)\over {2\Delta e^2}}, + \eta = {P(1+k_t)\over {2\Delta e^2}}, where @@ -447,7 +446,7 @@ dynamics component is subcycled within the time step, and the elastic parameter :math:`E` is defined in terms of a damping timescale :math:`T` for elastic waves, :math:`\Delta t_e < T < \Delta t`, as -.. math:: +.. math:: E = {\zeta\over T}, where :math:`T=E_\circ\Delta t` and :math:`E_\circ` (eyc) is a tunable @@ -455,7 +454,7 @@ parameter less than one. Including the modification proposed by :cite:`Bouillon1 .. math:: \begin{aligned} - {\partial\sigma_1\over\partial t} + {\sigma_1\over 2T} + {\partial\sigma_1\over\partial t} + {\sigma_1\over 2T} + {P_R(1-k_t)\over 2T} &=& {P(1+k_t)\over 2T\Delta} D_D, \\ {\partial\sigma_2\over\partial t} + {\sigma_2\over 2T} &=& {P(1+k_t)\over 2Te^2\Delta} D_T,\\ @@ -466,14 +465,14 @@ Once discretized in time, these last three equations are written as .. math:: \begin{aligned} - {(\sigma_1^{k+1}-\sigma_1^{k})\over\Delta t_e} + {\sigma_1^{k+1}\over 2T} + {(\sigma_1^{k+1}-\sigma_1^{k})\over\Delta t_e} + {\sigma_1^{k+1}\over 2T} + {P_R^k(1-k_t)\over 2T} &=& {P(1+k_t)\over 2T\Delta^k} D_D^k, \\ {(\sigma_2^{k+1}-\sigma_2^{k})\over\Delta t_e} + {\sigma_2^{k+1}\over 2T} &=& {P(1+k_t)\over 2Te^2\Delta^k} D_T^k,\\ {(\sigma_{12}^{k+1}-\sigma_{12}^{k})\over\Delta t_e} + {\sigma_{12}^{k+1}\over 2T} &=& {P(1+k_t)\over 4Te^2\Delta^k}D_S^k,\end{aligned} - :label: sigdisc - + :label: sigdisc + where :math:`k` denotes again the subcycling step. All coefficients on the left-hand side are constant except for :math:`P_R`. This modification compensates for the decreased efficiency of including @@ -498,7 +497,7 @@ anisotropy of the sea ice cover is accounted for by an additional prognostic variable, the structure tensor :math:`\mathbf{A}` defined by -.. math:: +.. math:: {\mathbf A}=\int_{\mathbb{S}}\vartheta(\mathbf r)\mathbf r\mathbf r d\mathbf r\label{structuretensor}. where :math:`\mathbb{S}` is a unit-radius circle; **A** is a unit @@ -517,7 +516,7 @@ components of :math:`\mathbf{A}`, :math:`A_{1}/A_{2}`, are derived from the phenomenological evolution equation for the structure tensor :math:`\mathbf A`, -.. math:: +.. math:: \frac{D\mathbf{A}}{D t}=\mathbf{F}_{iso}(\mathbf{A})+\mathbf{F}_{frac}(\mathbf{A},\boldsymbol\sigma), :label: evolutionA @@ -581,7 +580,7 @@ of two equations: .. math:: \begin{aligned} - \frac{\partial A_{11}}{\partial t}&=&-k_{t}\left(A_{11}-\frac{1}{2}\right)+M_{11} \mbox{,} \\ + \frac{\partial A_{11}}{\partial t}&=&-k_{t}\left(A_{11}-\frac{1}{2}\right)+M_{11} \mbox{,} \\ \frac{\partial A_{12}}{\partial t}&=&-k_{t} A_{12}+M_{12} \mbox{,}\end{aligned} where the first terms on the right hand side correspond to the @@ -618,7 +617,7 @@ but in a continuum-scale sea ice region the floes can possess different orientations in different places and we take the mean sea ice stress over a collection of floes to be given by the average -.. math:: +.. math:: \boldsymbol\sigma^{EAP}(h)=P_{r}(h)\int_{\mathbb{S}}\vartheta(\mathbf r)\left[\boldsymbol\sigma_{r}^{b}(\mathbf r)+ k \boldsymbol\sigma_{s}^{b}(\mathbf r)\right]d\mathbf r :label: stressaverage @@ -633,11 +632,11 @@ efficient, explicit numerical algorithm used to solve the full sea ice momentum balance. We use the analogous EAP stress equations, .. math:: - \frac{\partial \sigma_{1}}{\partial t}+\frac{\sigma_1}{2T} = \frac{\sigma^{EAP}_{1}}{2T} \mbox{,} + \frac{\partial \sigma_{1}}{\partial t}+\frac{\sigma_1}{2T} = \frac{\sigma^{EAP}_{1}}{2T} \mbox{,} :label: EAPsigma1 .. math:: - \frac{\partial \sigma_{2}}{\partial t}+\frac{\sigma_2}{2T} = \frac{\sigma^{EAP}_{2}}{2T} \mbox{,} + \frac{\partial \sigma_{2}}{\partial t}+\frac{\sigma_2}{2T} = \frac{\sigma^{EAP}_{2}}{2T} \mbox{,} :label: EAPsigma2 .. math:: @@ -676,44 +675,44 @@ of the dynamics. Revised approach **************** -The revised EVP approach is based on a pseudo-time iterative scheme :cite:`Lemieux12`, :cite:`Bouillon13`, :cite:`Kimmritz15`. By construction, the revised EVP approach should lead to the VP solution -(given the right numerical parameters and a sufficiently large number of iterations). To do so, the inertial term is formulated such that it matches the backward Euler approach of -implicit solvers and there is an additional term for the pseudo-time iteration. Hence, with the revised approach, the discretized momentum equations :eq:`umom` and :eq:`vmom` become +The revised EVP approach is based on a pseudo-time iterative scheme :cite:`Lemieux12`, :cite:`Bouillon13`, :cite:`Kimmritz15`. By construction, the revised EVP approach should lead to the VP solution +(given the right numerical parameters and a sufficiently large number of iterations). To do so, the inertial term is formulated such that it matches the backward Euler approach of +implicit solvers and there is an additional term for the pseudo-time iteration. Hence, with the revised approach, the discretized momentum equations :eq:`umom` and :eq:`vmom` become .. math:: - {\beta^*(u^{k+1}-u^k)\over\Delta t_e} + {m(u^{k+1}-u^n)\over\Delta t} + {\left({\tt vrel} \cos\theta + C_b \right)} u^{k+1} + {\beta^*(u^{k+1}-u^k)\over\Delta t_e} + {m(u^{k+1}-u^n)\over\Delta t} + {\left({\tt vrel} \cos\theta + C_b \right)} u^{k+1} - {\left(mf+{\tt vrel}\sin\theta\right)} v^{k+1} - = {{\partial\sigma_{1j}^{k+1}\over\partial x_j}} + = {{\partial\sigma_{1j}^{k+1}\over\partial x_j}} + {\tau_{ax} - mg{\partial H_\circ\over\partial x} } + {\tt vrel} {\left(U_w\cos\theta-V_w\sin\theta\right)}, :label: umomr .. math:: - {\beta^*(v^{k+1}-v^k)\over\Delta t_e} + {m(v^{k+1}-v^n)\over\Delta t} + {\left({\tt vrel} \cos\theta + C_b \right)}v^{k+1} - + {\left(mf+{\tt vrel}\sin\theta\right)} u^{k+1} - = {{\partial\sigma_{2j}^{k+1}\over\partial x_j}} + {\beta^*(v^{k+1}-v^k)\over\Delta t_e} + {m(v^{k+1}-v^n)\over\Delta t} + {\left({\tt vrel} \cos\theta + C_b \right)}v^{k+1} + + {\left(mf+{\tt vrel}\sin\theta\right)} u^{k+1} + = {{\partial\sigma_{2j}^{k+1}\over\partial x_j}} + {\tau_{ay} - mg{\partial H_\circ\over\partial y} } + {\tt vrel}{\left(U_w\sin\theta+V_w\cos\theta\right)}, :label: vmomr -where :math:`\beta^*` is a numerical parameter and :math:`u^n, v^n` are the components of the previous time level solution. +where :math:`\beta^*` is a numerical parameter and :math:`u^n, v^n` are the components of the previous time level solution. With :math:`\beta=\beta^* \Delta t \left( m \Delta t_e \right)^{-1}` :cite:`Bouillon13`, these equations can be written as - + .. math:: - \underbrace{\left((\beta+1){m\over\Delta t}+{\tt vrel} \cos\theta\ + C_b \right)}_{\tt cca} u^{k+1} + \underbrace{\left((\beta+1){m\over\Delta t}+{\tt vrel} \cos\theta\ + C_b \right)}_{\tt cca} u^{k+1} - \underbrace{\left(mf+{\tt vrel}\sin\theta\right)}_{\tt ccb}v^{k+1} - = \underbrace{{\partial\sigma_{1j}^{k+1}\over\partial x_j}}_{\tt strintx} + = \underbrace{{\partial\sigma_{1j}^{k+1}\over\partial x_j}}_{\tt strintx} + \underbrace{\tau_{ax} - mg{\partial H_\circ\over\partial x} }_{\tt forcex} + {\tt vrel}\underbrace{\left(U_w\cos\theta-V_w\sin\theta\right)}_{\tt waterx} + {m\over\Delta t}(\beta u^k + u^n), :label: umomr2 .. math:: - \underbrace{\left(mf+{\tt vrel}\sin\theta\right)}_{\tt ccb} u^{k+1} + \underbrace{\left(mf+{\tt vrel}\sin\theta\right)}_{\tt ccb} u^{k+1} + \underbrace{\left((\beta+1){m\over\Delta t}+{\tt vrel} \cos\theta + C_b \right)}_{\tt cca}v^{k+1} - = \underbrace{{\partial\sigma_{2j}^{k+1}\over\partial x_j}}_{\tt strinty} + = \underbrace{{\partial\sigma_{2j}^{k+1}\over\partial x_j}}_{\tt strinty} + \underbrace{\tau_{ay} - mg{\partial H_\circ\over\partial y} }_{\tt forcey} + {\tt vrel}\underbrace{\left(U_w\sin\theta+V_w\cos\theta\right)}_{\tt watery} + {m\over\Delta t}(\beta v^k + v^n), - :label: vmomr2 + :label: vmomr2 At this point, the solutions :math:`u^{k+1}` and :math:`v^{k+1}` are obtained in the same manner as for the standard EVP approach (see equations :eq:`cevpuhat` to :eq:`cevpb`). @@ -721,16 +720,26 @@ Introducing another numerical parameter :math:`\alpha=2T \Delta t_e ^{-1}` :cite .. math:: \begin{aligned} - {\alpha (\sigma_1^{k+1}-\sigma_1^{k})} + {\sigma_1^{k}} + {\alpha (\sigma_1^{k+1}-\sigma_1^{k})} + {\sigma_1^{k}} + {P_R^k(1-k_t)} &=& {P(1+k_t)\over \Delta^k} D_D^k, \\ {\alpha (\sigma_2^{k+1}-\sigma_2^{k})} + {\sigma_2^{k}} &=& {P(1+k_t)\over e^2\Delta^k} D_T^k,\\ {\alpha (\sigma_{12}^{k+1}-\sigma_{12}^{k})} + {\sigma_{12}^{k}} &=& {P(1+k_t)\over 2e^2\Delta^k}D_S^k,\end{aligned} - -where as opposed to the classic EVP, the second term in each equation is at iteration :math:`k` :cite:`Bouillon13`. Also, as opposed to the classic EVP, -:math:`\Delta t_e` times the number of subcycles (or iterations) does not need to be equal to the advective time step :math:`\Delta t`. -Finally, as with the classic EVP approach, the stresses are initialized using the previous time level values. -The revised EVP is activated by setting the namelist parameter ``revised_evp = true``. -In the code :math:`\alpha` is ``arlx`` and :math:`\beta` is ``brlx``. The values of ``arlx`` and ``brlx`` can be set in the namelist. + +where as opposed to the classic EVP, the second term in each equation is at iteration :math:`k` :cite:`Bouillon13`. Also, as opposed to the classic EVP, +:math:`\Delta t_e` times the number of subcycles (or iterations) does not need to be equal to the advective time step :math:`\Delta t`. +Finally, as with the classic EVP approach, the stresses are initialized using the previous time level values. +The revised EVP is activated by setting the namelist parameter ``revised_evp = true``. +In the code :math:`\alpha` is ``arlx`` and :math:`\beta` is ``brlx``. The values of ``arlx`` and ``brlx`` can be set in the namelist. It is recommended to use large values of these parameters and to set :math:`\alpha=\beta` :cite:`Kimmritz15`. + +.. _evp1d: + +**************** +1d EVP solver +**************** + +The standard EVP solver iterates hundreds of times, where each iteration includes a communication through MPI and a limited number of calculations. This limits how much the solver can be optimized as the speed is primarily determined by the communication. The 1d EVP solver avoids the communication by utilizing shared memory, which removes the requirement for calls to the MPI communicator. As a consequence of this the potential scalability of the code is improved. The performance is best on shared memory but the solver is also functional on MPI and hybrid MPI/OpenMP setups as it will run on the master processor alone. + +The scalability of geophysical models is in general terms limited by the memory usage. In order to optimize this the 1d EVP solver solves the same equations that are outlined in the section :ref:`stress-evp` but it transforms all matrices to vectors (1d matrices) as this compiles better with the computer hardware. The vectorization and the contiguous placement of arrays in the memory makes it easier for the compiler to optimize the code and pass pointers instead of copying the vectors. The 1d solver is not supported for tripole grids and the code will abort if this combination is attempted. diff --git a/doc/source/science_guide/sg_tracers.rst b/doc/source/science_guide/sg_tracers.rst index bbd18eb1f..215c13d08 100644 --- a/doc/source/science_guide/sg_tracers.rst +++ b/doc/source/science_guide/sg_tracers.rst @@ -90,6 +90,10 @@ is not in use. "tr_iso", "n_iso", "vice, vsno", "nt_iso"," " "tr_brine", " ", "vice", "nt_fbri", " " "tr_fsd","nfsd","aice","nt_fsd"," " + "tr_snow","nslyr","vsno","nt_rsnw"," " + " ","nslyr","vsno","nt_rhos"," " + " ","nslyr","vsno","nt_smice"," " + " ","nslyr","vsno","nt_smliq"," " "solve_zsal", "n_trzs", "fbri or (a,v)ice", "nt_bgc_S", " " "tr_bgc_N", "n_algae", "fbri or (a,v)ice", "nt_bgc_N", "nlt_bgc_N" "tr_bgc_Nit", " ", "fbri or (a,v)ice", "nt_bgc_Nit", "nlt_bgc_Nit" @@ -115,4 +119,4 @@ Users may add any number of additional tracers that are transported conservative provided that the dependency ``trcr_depend`` is defined appropriately. See Section :ref:`addtrcr` for guidance on adding tracers. -Please see the `Icepack documentation `_ for additional information about tracers that depend on other tracers, the floe size distribution, age of the ice, aerosols, water isotopes, brine height, and the sea ice ecosystem. +Please see the `Icepack documentation `_ for additional information about tracers that depend on other tracers, the floe size distribution, advanced snow physics, age of the ice, aerosols, water isotopes, brine height, and the sea ice ecosystem. diff --git a/doc/source/user_guide/figures/CICE_Bgrid.png b/doc/source/user_guide/figures/CICE_Bgrid.png new file mode 100755 index 0000000000000000000000000000000000000000..09356a0c6223beccd539393ca28e722c0767c861 GIT binary patch literal 53070 zcmd?R2UJsAyC@ozA|Oo!R5~a~M+}52NU|AkgW;GlU=z-V^iAkH7=G=MQenf-+kfu)qbr*-hw85GW^zbjOGQxF)u}qx~EN zqNBq7hu6%pA`Jqy{<uV>zgB z&k|B{ZnA-ObSIK|#rSqM=VOl1oy8#WP0jIb?5<{cRG4;Hnw?4J)b{R@~n!;|CQaTYIs~8jBM(iyz9$Ox7KnN0uGB|mh8y)*#x-;Y{hL0=Lr*|Kkf6LHeX(*`a>&c(D^>$b7is)*g=XP{MV0bP) ze*4UidTh7fNtAUbH{WwJnt0zf*)qmt>!FiqVgw^UC&E$4C2I+7k=z{VSY(v*e53wJ zL!Db2zqIV=Y;XS3%ty2FhALKRJs%^%DM|F!QsrKyN2~Q2j;XA@hRQQ3WPy;%-9cUH zy%9fVrm)F{UCbDdljK}0eQva&wATdlSsOo|XOOcfjb*EFhnm{Kt4dl;-?Y2C>?}4f zE$=SpLk8Ye+lNWUnCM@DI^LNR(vg_IWmKXV-;!$`P+^lBLfn6i7pxCgI~q0^YU`() zN9}^lq;dKpsDGu+R2!l&!4{LecxX;MCuBYdTrM-%n0(1mBw>cb=AevDe5ho_D8 z@y=ZOMW!igP?5=a3`*%}_@Ll32+6-vO-AkX#ZL8Bm_MdW9Y-^65ch4r++TNb^hOrZ zhowQ7U902bKYld(mQK%c%nITC80;CozfgdGX|?&X4L;k_v=7d+}+)3 zSOX8Lm(f=LK#Vxt=yLOY()raJM>9zZx4TL^ivtY*sTCZ5e`NZf3*z4mv^+Cy!@MlQ z`^75j$-w<*5QK_~)Y{LCjR<|mz5*8wCQ;k(aW`%qC=Ea`t+orLr>B3ulD=M;QpA`O z3gctooxin~x(8RNY-v?_Ch?dHtt0yIaO7ly*WQ3++U^{e^=)1gT~eaJQdJN7z0B)v zlF#jyn>cM^%uq=sjMx4^N&YPL;!M|2MRBnh#O6n{qsnvZPsdu=>u_5^Gd~$}Q@I^) zT{~VF8;QmY5E z{I$fG=J%XOW~r&0|Ep=$VK(&07Dwy=+teRSkUz2#tCVi*lA5Np*+=W&DhxG_uw@rJ z-bT2okU?q&uUc6TDm$XeRjkX+{9;C|&x>pzog}XhCXT^LVf6tI3thDJi`7b3jEV`{{J%Y#ZLY9I?i0T7H-&&KXMY~;|sB2_G}+4O5}zF zb)c2=B1<_2EZV6fl1PIqEhr-Rhmwbz@@YHw=q)6zYv1 z8k0KAX-EHlzmR%~>QTzjgNo`R^N$;G>@|Vq0@@o(izHbVRjBVda#6En|XX_+Vh5mZ2ksNZRJPw7vs?@`VEa`u%59quolqYu zOB4`}MFInk1941fHe~Ne{lq+dLQJ>yGD1SH=+~OY3e5q)v{_0=?b4c5qi6@6Cl@93 z0y1;udQD==3{!AO-l_H_URF*+k8Jf~0}kPqDp;3nG&PMwHio($9L#Xk-(FRXaiKkc z_x6AsLH$E2)T6&=@*R-bH*&7-Pz}8!4?;WG-i!izNV*FJXn$Zg*&2uH8BJ+zNei+5 z0Eh))6PS=c=kNiFdUvz0yLx04ranX~{S^K5w}GVX@b`kYL~tqq;OHi11(BB7zaGWN zuUhtQ8a-+Tb0Zs?Oy8mKsR2||!ROgs(1Wm;E}o2+fV?|Ez-P(>?Go}2tlN5b+=upH4tHa7AwKWqBiC9d87h0dvgxzX| zePQjJhjge5oq@|YtA%h!gF(BrAEi?zbUQ_7SGYlRBDaKIvA$y0c5sQyyVNZq8$Z;9hG<|@uAng&;huoheHE8N0iGuUOyCnNzW&Jv69);+EoXXR zLfG4`ZjJDFume+4EWGpC8HiThb~v>ro6|`s1xV;0T3J`?az;%MrvvCfo#f5rypZ_y zi3}9ZY94?!Gwgw4hv#XV1GwsNF7uMspp)a8+o3@?I0jC&CS|Q-zHb?HnS|#z3ON=H zbTKx~-yb3Gu50BuGz)zbTk5sa>V+qM&v8Bm&#l2i&-RTdmI1}(p@CfF`*;;|>s^(D zNa{=;4#;_vyhEA~?Xok8BcM>#IQT%xN0a^-KMT|n;7*wE@bZuGsYd@i@UYyPE5O9a z%md=D4xY3;oZbODIuCz(D5Q{R90@lai-3tFr~_8cC+l7Ytm@LM1B(Mp_Tcgezr_RU z@wSTl`%lIb#k(2jBRm&gg)n;Ub!kQPK^R&w`5Toq0y>We-qGh84~!`9McDK=XT_C@ z>=ipRl1uM2Yr%G%8R9w1N5huI864*^+gf$V)rJTO=F6=%Wj1Zy9D6|1~v(JXCm2G`RcJ|x>U=5vgOc%4;;eVKJOZa}Z+kAK@xkiKf@lfN4*{A(90 zTU7Jz*>*Y1aK^DY!pHDyf(@5p&(^E%7lTaOn6wdP9)@4*e)}(9Uvf|(T!>vHnlh8{ z;C+oos0*hWZ&6q&m8?r4wqk*gGG}pqYZu~tMhp|Y?5F?4k z9}W322&6|7?XqpM(Gerl=pyg5KTbtXj&(5VECkwOR#9&e??_S%Rj;Bdq<6u_*~s^aF`^AFnhcOF3xtev4^W$F*B4b=^`=?%3#bl`C=HEKwv#Y23bU zYLjxmD*0|?gljK?27Q&iC|H4hyrrk+Txp1$tMg{R0s-e#Vvr0$1V`XC_K#aO-Z5FX5J&i(Se<-Agl6p>01 z>KYWF$hCLV_0`!9gBb1vxz$W|R|>IR2KZXIzP+;q_kdEB{Wzt=L&b|c`aWCohIlgc7wpz>zxutDx@TY|4Jeb0Rs0r%#XyDy_ecPn41i+O@gd<6R zLy(HQxC@XJiPW$u37g}WeMx~ z`>=-PGuUPqv8yKO=Uoq^S~1V@nFbZH;B30(vM|`d&65^0?~!X~(6ySw{bx|EhQ~f3 z#aG&6EYWtWUpg*^p^-=Ap@dUvO0OLOm7l!@X#P-w%k5D{Tt~>X$W{IRvg$JRBm3XU zLrk6#r=tV8Iri`8GUt(IXsPqe(^<(uV7OWZa`W*4Zw_kX=4@# z_EXf0r~tPK#ue(J9G>}$^B$2lA;LJpx}VSB>57Gjh)lpW?h-(FuMFM$R)y~UMlxr= zz1Jzby-75l#)2}bIG1@_Os~Qh=XEaIQnxuIoNSalCONYlP>);ziIb(qcp_)#LVt~? zQNjxo(z^2<5fyost`DnxUayQj7o96x7JkCRep!e`{Ek`^r%LK<*=ld4PPme%&rfLK z&A_^QSwCBJc}k4pnF6^*Q%4;3#KzOy3l`FP!&%jBv70Fgl{c5$)^2-_rVN_+P7K~= zLYtyoh{&aKTKFfLv@K_HSMnrxYiEYiH)(SD1Wrd}49mJDP6wvJ1rWpdQC<#-?|$0r zFrtNsQR-~MO=<1h?-?9W#^TXCB&jhsexKn_LM$i+?|tKtzM=G7VT9{jVHm)w{~%yK z;3VskxmVvBB~y7M5#3?JI3HZ^dbbEv6s4#fgJY{&*QoNCpIA`dGbGw?iu3C_vcry* za{8f|*@`7GC#J2VnX`yX;D-l&sj69+{T?+ze%xn&&;mN=}7i%f9r!Qc)pe zmR#!hR|#pYquWIYoe}+KPcfVvNk`#O{HI*?BKKlTy$Nr z7pGykieuZAz-`L1Zq*0U0Rk3ExXXww&2_Vdvp_><%YZ^| z?Ri)U({7o|<#$ibj;KD6=%JTu(PupRD~~Xo7ySt=Cqthx1BcMxfZxnIee9m_nTLLF z-fH}jKg(mt(R5Up+|LvK&0TbSaWV)9DLpwx_%AbXj`{xuut4!SNWUJGfa@9!wXi73 zrS{5}+eiBL40#TXHK@4M6bNaCOZYd%4DHRsyh^&#ehcy?KVE?wi^n^5Gnb<35~Nos z#%LZtn{c}!y^)fZCkRUWX55p%e{V@htD@Fxn=>I?%m1$G2dQm#=_Qn|*OtI8hKN&w zzj%T!)mNui(B`KY<7_cmrbXT8A2dr}Ym36SW1oO<|gn$kq zXiE;6e|20><(zLXczVR{(utDsKl}NX(8WFy6J8Wx8;_~(eNgzm#NqV!tyG>YSy7dE z^hk1qpW+q63J2qIPBUUV3dcZr;i9eC3!{-Rclzn!P(N%zIM^Z%Tf;8>FZ} zLRPZN37Q$hyc!;02c%4;IYG*YQu$wsA!VVHL*#5;HOyQIbKoqNsf5o{ZZ2KY&8>cU z!DZN7Z|bs4()E}2Ir>B&RYbDN+@Ff`iB&VFdT{E1%Dh?bTuS{h8`5DCohhIvko2m> z@Sc9WaFfbiW0bHq;TG#GeZI@&xGu_~X=JxCjnt$>-O+(27Gd6yoUzIxbvfv>!bO87_Ws)KJ6>m#?rBu;_tW*WVA1@iXTBi3(=L_ihDD5A>`iJ9 zA?WP)t+^3eK*Nv}G^RUCqTJAUQ^y?g@u5ajpGOTm>m19)JRfo=rHtS*Moq%C=GANo z*{?dc?vywXfj}?d2RjNDx;K#T*id}sCK-1jy&h@nx8!xA> z5i$^Ol|b1qDRgt>9l;!?i9Kgkov2Y7kY*C^Jq=mj0AR~wv~C;4ndLc1KMvd;!}XB# zHXk_6V~~p(4`&DRHkKNiq$&_kO=?s-cj6OYF9XStv$b;}esgqguFJ z)0VJFWPQs>TyY%kx^j&VN$rGAN^pZVay{MrrXlc3kWrv=ytaVky`uGnexZV2A8mGw zw09o8E4ui~La|OnGWl&wz@^ofK<0p}+t#Qx_ojcn$qXb=3q=CR!9$&t#*F4P{!Xpg zx-AFD%mrK)jW+n^@+0m&mfOTi^QR_TS&weWTC=;`7av}mlB04|TUGZ`@%2J^EB)+g zn~MzA@PjxXLzAD3EqTz4`1l;iJN9i=)bsXAT3p88J{OS1@i&v%5J*5jR9xT2mFk~o z3c%XdU>q^ccYQ~=aL6XwU37>oOiWSe%>WGE0GzaAGFel@)^6n|FHqN_LP@Nh6)yrv z#OyJjNm|*JCRta~xQi5!?+JlI8k#!n3slwGsxfkts#OZLz%oD$$QUX(^df$(U%UhT zW4Qc#-#w@|Re+Jl6@K*&A*%Fyjg@?IgC;iO#FLb;;Ip-401e@Sae7^p7_&@kZDpZH zu0Uq`gML*hWm>^jobR$yO2Qls#d0yi8+ky2Sd-v^So=Hkv~Q#j^T(DC64Efhxo8F! zLxn_mEbp;X5N~iJf){nv7Tmre2JlbPt@}oy=dNHR@|({uo)*JQl+RMA(DheVPx9E-iiD6|gEVr1=894%AD>?&v{Az4_ziLaT<-R$tn1 zwf$B+33)ee*$Ma1IIF|ex6sozVq_ZGsz^XIQxB*SRl!Y|5jwjuGl?LX-=!CT+LS*5 z%)F`uSK;Ml1>EGhvc0<{mOeZ^@%OF~8)R^MOs_5}VTQZN7N{1}=>cPr%YVFl7Uelo z@N3>a$GZ5haBu2qyxA(l79aTHfu6z8U2C>WVIEs>v&o5Z1kSq-OalcTuMv0a<@z;I zy;*!hIneSUMPJ{>acxYQUKq~c53LMtP&HC^LdK!<9NsMl4uO0ACv^N9OO~`ZJ@B|c zR&wNB|6xS?^Y9-|a8O_VQQX05`iPBCBes)K@i-72GN0^Cf8cos_GC4$p{1X{wl@}{ z5Q1SE0)mO=amg_EgO|7VwCS)TJ?_MD$-x@n%=5p7pPAi zd&;`{I)>|a?lQBsNq=fee90PyTQv?c$c>B#R=LknbbOq+uoS*ch8tHjxajq<4YwOw zU?J|&;l+Iz9_>CFIfrkONR611SVMLa#=i9kaH8mTQ-l&o_?eOJKJkFF7t-&kXza%* z8LlQYyK@)0^RCdiR=1oVu>LLGGUf^vV8f{o|9c8H>#E=tISRuDvc)L z+p$XVL&;tQ+!g5o!eQ03irJsfMe?Iv1&}U&g(D`0@v%=X#D5%m(Ef=TpukjQbH5sl z5rVF~#H9obt*i==M_QzIS5bpl&CP_hO7i^`5f>RC$sx=9aO|OuH9dZ_ix8Qo3v}cd z1Ppxy%RMVf+GFUHsmm+?(MQHF?2P4y#Fawe8226{2pRk^qtwKBY9<18vZ0Q-^!_Jz znkTMZTiuFX6dx>d@tBOZN}Ai!R;PQzFB+EYM!^!Uk$G(nsN9LSUfGZ?Z-WNzZih+4 zV_Xds`3}L%hKkm-rHwLsYR9T%SX%a^y2H>ichi>c)KWS*#f3}R!+8-Npu-O#m zF2p;mD9j~1qDbcRmK|W~yOdF;4OQAtFrSxrHD>exe>tuOY+OajTkVRnt@SZwh}Aw^ zqO@?HAV;0ZYus@?m_NnLVY0MHpkWA`u{%yge+!U5A(BC_L^;`;l&Eg>@p0hykC%To zcN`g6Tn)V1Le%Z}j_*8*h6^fsJip1u2*0_+76cWPXV@t&4#ZaSn~;FwKZ zxfuwZlm7TO2Rx|iD*YjpbCOeWr6(Gdw&*1o4N76#FfuKD^|>h2pwhKxwmINFv?t}5 zt6GOkns*k4oSQO|X7fm66R%=~Ja}*gBQ8$g)Qh-O-WQNMO{tOMgR0rYlvNz3mPgU= zmlCfV%Jd z?q|rm;juNiTfzWshl`x7J!2qS<&9%X|JO+n*J*J)K^WH>pV9Rb*Z;n-|C0udnK*=i zj_;qc<79nwGAF{h{!#d$LPO4;Op8a0g@2oOn*~1{7VihT!1ee4r2Uf|2|~w-)i;Tn_A5ayT&qtBrr${zu+bQp2UzBV|{C2RG&xl-{=!L9YJiY+;8mj_!6q zsamok2JUfly5KxYWY{S4!Z4U;nw<8IrLt?!?NsB0_#3>dI=b?5}Gi-*lvh8 z^*tbVGrrBu8bF~O1pG!U$-Qfw=bC-?v9=_omos)UxEX*6yK15P5OBFl_3 z$@ftY%ky3hm&q>p`Ju|l%CfU9zoY>GoHwsFf^~s>8lN$IdB_K`CKC;A$wEjnJi#;v zb=Q#IE4ro;7Nvw@G#C-QqJOy(v7BQ;kfNSJ+9}uY#ka9TyYcI?y3+%{n>b78V15aY13>dH>x`hb$u@837)hE%oQxbf0GHX5wB zvB`@HPaVeBR_>t}2@NKXz8$!Hcf!vZMd2O9g7?fVViF$Y^WX79 zxFe9#Q3eih{m@%b3XkfL`@tfYnzXCi!m9`bbFT@}@+VodmosW_FM?R0Wy@TsY8g0! z0fO~|lJ{NE;O1j&ntd0fifH}V>3TXTF#P$O`nBoT*>)&ul5^R;)MO>R|5-QlfB$*< z8x%L>>jkI z2hh|vi}$-~2bF2&Z$N#nd^nr!HAX>#W^!MLB$Lzsy{X+ z@C|d6`t2*U7<5U*g7O;W+6U?FLZz{ zyHeGoIHhbs?PvMapv`HFsB@2J0x0$Cb(NPU`o?QHXw8|}u#rt+~G;S{x3%!J2mB}+(K-T7i&SSkag(veoPcq}u_pU@F@3&Y=a^Fn3 z3F_~7;1t9U`>t-Z1DHx&X0Nd%pnY#-yfw#71@PU|WWmyQstQ-7Ohul9dp~Z#P8HcodB;8= zbE2(!|L%kC>odz0*iZLB&KLRa!C*DqNFVbo_pYrcm+%;5o=1m9Y4p36GNco4ev8q3 zE%NmN8sF9%->M|taZoc6TZ@pP0MULKH$Nj~ODo~o9qzTM1R`pW6)`c5D!{;fgju~D z(E;tI>S&O1HWF#k!QHP{MFQ$Fzj#Rpl+x>P&m%bt)c)24M{mxlq5^E9{OP2UG!;bq zGfO1Ctt@Jxi+!;Kz%l(n=x1IT{K9wQ5j;kKu`jaiy(= z6*JyV3-kR&U!5sHpmv@-lVC=mTU;dJK&_=sOGTB#BVmpN`T8*Am(5W~3l+)kHC5 z$xRe-_MHRo`B6_W3tp}Xy0(-#QFOCz&vX|}cY*cSpb2G8@xs<>K58A2$;Z=Qy07X^ zc!3Yah~Z)J?`_=TcDm5Eq)?KrKntDo;Dr^-3%R#n32iZw@_PEP21UHw zmmuK5SiKXvok9-(|TpNsIDUy?x3G2>~11<7rC?&3+;ePbcctjk^@AZ~ZOmT>H7kTElDu#grL+cs%jCyn zc&rDI1yd~2yKtuI!Z$%^BcG3W7B;e=WKCE>;3H)WV4-wFq;IaZ+|RntGCFRqJtMyD#q0m`2&(T@!;z+6wXRZ9QK`~b`S6@y_sDQs@BTVt{btp9m8S|J5Co@a|vD;1Q1 zOOyjFK64-*ru>DNduTy&2gF&K9GJq?3k!KP8?fx59~3P~Gg{rJd*M2Yv4-cozrTNK z+T24f84=3wtZbu?jtz?HSvG)*B$x~^Gb)p_hsq&nBm`*i|0DT7mU;D$=KkG72LDTE z`Io=+R0{SzU#uOQiBW;hm+fD3()Tx3Ju+>Es6s|h_vQT3_-H*(`$jyysYD{?LE0a4+v`pP_Wm>KM^wC>iaaGc)8ZG;5?pin=doLfcY~C7 ze?r@!g$qDGz+sZTUh`;1Z5V@FaDc^sF1_(pwgb~X77$EpKd3!uXt6AY>DdQB=ck^W z24pBNEVDE*o=%3Tbs(@EtNZT|FVtxX30FXz6$GyEIUiV4U> z?jz9af>3=BrzXMUEuAZP1HX^SV~^Htx9!-YD_Q%7MS&U125j@ryA zzG6jiET=*CLLF@8YbQVZhT}@-!@1odb%}*EC#iBiDRPw~q*Pz7-qgMz*`z=$)TSKr zLWN)6{E||W5cKqoF3%w$q;biy7l>ZH0s@W)#2??F>SAKHVbY|J_wB;&L|ix)`YrHT znd~S#L&)wzx`ECQ-6K>$$Y%O?A^RYnQ&AD66&NRj`eZ5YNsgPYKUfCk&-$8Yq-DlgEG z)D}$dspqTQ6--(YD4i98K&L)Ch-mb5h`i8UbHfEwOQa>Mj7a)`3@f5UT4PQvaKerM z+uM{(<0#NPaQfU11^$2w;05Wlr=A=#^H>)kq(6nWWkb*OqKZBd9>Zu+o=H9>3;kh` zMkBV>x^9>>73Y=SdO)q^6hKJ>d@tcGPjV%4$YVb`}5Tt3=*LZ~{gJ(+y77W^|; z2MFV+I1CW&bAGC&LbK#y2z)aQyy*EE=qXVsy6#K-=VfHpjO(Xy-F4w z)^=3qgjXislw=9GDuu68x~_yDFsf5<4=*H7`ZV8TIY>agoJWXtSebBO#SMJ5OwK+MTD?Hm z|3k{)DoU!AE6<{Cg@kWpr+_nL-uMnOFOF zkyzO__qIt+uT6@=;u%?aLyM3bF2HsGoWLZF7zsDLt@H_*r*EB?w<`yp6BoJ{j43QJ zX}kJ!^RxT1PJv2Ggb7j}d7-`P#wI;n+Hx{is|E%YY z|BCM%s>3grY`8zuDI2^icOF`r2~uu1DIa&}{|t7Ja@J7lN%8pw95n`O$;j)z0D@Io z;oGU?d{?CZ|KU$x?EY}4M+md$c$(Fw)fny!)EI6XW|#cwZx2L7_cR~7t3?Jz==1;C zPrA*1NSOjsgW5{W${P-4eG#GtN2WVv^KQw>0>sAHD6=XSj|L8YAgZlZvemPchuyr8ycbeJhgZif@wNO$^T z#jT8FYR5x!Y;nh6JjXaa`@`E{&0VP7tU-hiBspy!_#F z>;M=k4LY7P(YL&dH6k+`0B0{M+raD(k5%*7#AAfyLpNglm~2sOqszDw5=X;@@A>-s zpMqmn`=pcR;T|Jh@sC5?5H65`4AKf(Ryy{^1-;kqZ3rc=tiNTmLJ|XYBdof5oYtb@ zhn%UB)2V}6eEQK-8z#2Q%%co;p@ZRck;=g0j(yBNt_<7s*Z-TvzzrbfLT&4_^DVb$ zAN);@VuZF%F`OmND^#V&RatFo7%Bz-SrPeBH6j1@^S~LsSEBVbM!bLTO#^R;_L7Xv zmnA%V)|+vnqOt`lD!AmSyZaPO9e(%&aRw>7vsh%pDn6FqGf23T7#c&SV`)eM}qzYL93S1cJ#0}@Ud#E&> z^1R5xBU;!v7R)Hzopfb3Fl3qLby3In$(4%(x(Mw*uXYYT+y7*Pd(2a-^oG(o0P~pXRwrMSlTF@RQ)q|q4r>pUo ztDY0ctkMtE`gb`wC4R|ew!4KLZ3DJiu~h}pwUUz2#uzK6D zDI4QACX2Z8V&%AyyXF={XbL+esv6Hh1-Cg@_GZKm-?ri}w z#&tu$nip5r$0g$XwgyZ$1sVTmfbn+YsbtaVoq-c;-_*b z8~T=!B4)?T$}^-Nk<7+M{?`mnRB{(o>v<1WssDww(%XM5q~!l=&<~fH|2@z<0yEu= z#0lr;*@KE#sGbQQG5)`^06bZ~{=dJx{4YU2SiUuUXB1t1Ex}BsrFK+V|5M)oAyfYs zC`0v6N8!Io)xfJdN)6xjaT`5B{%I#d%%8TzpC#&_z5>^G(Y~e4w#w02pudL(&RK`x zJ~9!)yq(&k;tA}pMDL8Xl{?tsPELQodabRY2W7qe=YS=_EXHlY%XS&q--(O$Sb}iu zPs1vuHa{f%#-=VCz~=_?m)az5YLg70&q^zlxpgZ>_v6jQd2Q1%wRz$@Xj;GwDiDBE3XBRD#aHme{u8_~`3VScYBVtJ%eaBjbT>K-;v5 z#p!`F?zL02zzptaYY5xi{#DHBx2KEqO3t+JmEv2xUoFA|$t)k7leH_QOks?fEplGy zGZ8v&x`H0kYn|WwbiehRSLKeoVxpbFre&0bH1k&m{?!RxsWN+Rkh(Fl*+MAMmy{H? zMH$DxR-Ig*M(Pk>R=9FGqm@)F<^JT|{%_4%aqv^$?e0Vs&SjQG*jW=JBSYn&l>ylt z;71ZScELfj_)wvG%`pcoevGmsg2Q~A9MqCMo=zOy%@d+AlTA}mwh=7T`WZVT`o&iD z5-9REG9r|f0vp)@4s3pivJa@o%O(UHN8_trYV1m!p{}_jT?>bKC#|@G@V=Wx32}%> zeLWYAZ_66(smhpRegkB68>va1=T}CqZ-{arfpu1s^!~_6QA{gJcF(BE{6EJ&Gnh9n=s4|?G`TcqX?7H?G=kL&AGopGy4x62!#ox4U|ZXh8h z-p-D{t#2UkNhwP_f&$dlo7;ttE3of0Wkl!DaW zIlEkCg;xp+jvO)FYzb-nnE)0_Z9~ILOEL^GQOJZv=qqPFFX}Keg{=gKHR?-Z_;`S^dcyn=P3=e^QwJ8 zdK5?0=U$miEafV>75=g|SjpnjTjJ;sFlCD=AxlOPMjD8WTUpGAuTI%!H{#QedrvcJ!eL@}NNre@ zgXjShxoGLia)s!AU~^h)*1cb>Z0$jy>yn zeA6QZaaYsM{5A9c%YW63q*wEhaK3CHjj`29O#c-wTe_3%BcvbP1FUX0KP#cY-sv;d z)q-)(4vEmGAF#_FA|6H70LywG)@>PK#iJxDyccy~J}pK4t&+7V$*lQo zhj-^hE}#1;eDm}Jkom3Ig7{%r%WE1-XAQ+Js*-lFa|pX-X)AX%`(BBR%0$nu2(ag- znCiMKy#5bBGI*y-_6qWh3O3CI@*nChB*rAgaXRZ#3CIz&;CFq25?DH&EB0rVcbmkA zrXGHhsMP@eZ%T_Cy$czoFJ2ClePYZ( zyXrQ8KMcbZ5JKu_PG@E}q{9d-duZ5DV3v>`L|%a(IVjqQr<=pPzrX|!%34Auk*OuYobjEfx^=KQVXiR||TJe%!&Zb@?Q3shHl8X)( z(}$-GL$fOt{FErm@bcIlb!}!Ycozz{bIAEDS`fp+HTrpnIQT%ndjs-`k+|W=;TC$H zd&lDGC$tIdCL@PkSI?%S=3PngYtu-pfu~I;o_^s9Fov%?-~S0|f3b|%NKW?eq)@NB zNXEFTo^-$6(nGA&dqs(#T2&}j>wUylGH3|?IN0xw~rOuuMuLSSS z5T(?|VJ2wxiZpi$&|7xgsLu65ys;nLCh(@*=v$$7C1>20*ue72V*cyb)IYDLkY zd}G){(~CeHcyW`Z{L!V^uj?HU+Tz^nk^$C2k)rNNVMXSWX^*^gV=&_N&Hoy*znk{~ z-+ZY64*GJe%zJ!NIt2m+gMmF=0trX2UxiN^JW)1#iRAv6iMHMT1r?_q#?s7P!+?WA z>837W-zSM}V7v8W={MazEFOqO!5qoL6FonRND?pr;@8KQ1!r?_))S~Z2xx77t6VOv zQ?AsCZvnnh*De9zpc(&g`>EJtJkSgEPkgV^ANdi1UL?xt5^Cp+k_Y+w_m<+@1k>Q# z`1_066JuC-H2X%FJ%1a?>s6&KxHiYV_n*7${3<=T6k55YH6&Ij*R#3hwX(oDxlr7} zC*$AygJRC@nH}&J(cyO24K|StxqWO*h)KUtrif2f=eoa-0i?ET=f_L4l$SBCtE|$D zY$8rk1?kQN7dY%9ut1AAX}jU{MiBuK6`fnlL=Nm_%yhCs?Sz5bOkzD=Y!dp}QhjM4 zP=zX-E`sbV_sze*F=N1CE2mfI#^n5yY@n7xZ~J5ESvC=^(?trfi!bTll8EgKNH|_K z9-!3fA?;5uwQ+CNC#OPl!NPmOuho;)w|0LB&=RD~i90wxZTX#6dGZut?K~KEQHGYX zjP;iKD+tiyar|O|1m(UMCIdDzZ2XsmkDi7CcPij~ryEasLx81J8Ebt{o(V`>X3_V8 zDsbm_bOG-bWv(*Ybw~Ok0ezqABqnaowM9aP`1DklqJK$#s<%{KyKagtoi(jcilow;nbbGav+GTy`K{)K5hd$x*%O; zOxYV0#>@+fAo+zIh|XIp@U=e?72En*p@XDRG;nPy2H#rna|d z+A)RC;R%n??3nH({SbUgr8wJ{-YbZs?^Z;Dciv z8@RWWfi)-~o4{aHv`D$e(!?9P7z&EGq18~Vh0nRg4A%e+fjj2jd$(MNZh4!2)n%c4 zCM-}g?}PQg%;P>Nb~qcFgLFnJzMyH{@P;tXaPZ4!0tsAK#QEDs0Ch~eh}7j)O#P<$VN{==|;FL)7-yHJY+MwTx5) z8dARAe!Q|179d>5ua<8mDt#7XWfR`RGuffFXj)l_6$%#Ajl%vLA^}G|`{zlE$IxEu zSageV2>Wg3XOrxsI2Hflje7xn$lY<)_}mDst1>q>}?sPB-~5z{npu#<)&97TfmO#!nI0tnXPs+x?mX4FDIbfMf|v^`^L5!N4JluC-7u5z*}m zr8Dg=nn4OHa^MX7Ai-0I?l5X;mvG>T>3l{i5gre`7PX3XvEa;SDry5&#)W)iw^0oRT#eFr`WCF7~;B_ob;s!CjT$iuqA6#*J1MFvXrZx zknZkOAuoye*vy|KA5Qpfr<+Z{@zBYD{cVI13vQbnMJj; zad-OB>nY_Cz%`H1^3se^sbf4w`p+4V@!U*QN+TVhjkEKi%Fb7F#(B!~p~A}R#ilF0 zV~riR2R8kSO5l9=$co=AAnveyMROVhqY1~Cv@V{E5`@772PwiFs{3F3NwvE?*QT`2 zAbG8COq12W<2byo0>_IWjiZORq)+t*RUOE_^ju)bG7 zg&)ixeX;7DU*I|F3+!NdO`<}GnAyJ8JTpH65e3A!sj(8bitC$b^m`S@AyNA0g^dE| zEr=&h3Ghm5h{OW3vPyRkBq6%Y$=Ho@qw1+)^gx>rMda7xEJVJ0!)64lK|DJ3 zrsn4nf?M{y5NsHeJbkVHvl;1PEai6lG4LEIqmdOj=REG?JMf!&g~yQIFD*T^d-;mc z_HzW`v$!KJ*u^KzVieox@fhHrj)e1z4|r1f5=1oJb-zoXZOp-CHL+ucX_ zR9&L0j@9r#*n9IpD8IIGe3Vjzd?ZPdC8Q9A8qs2DVW=1qLn+BJCNlP|M3S`F%7pA0 zYr-a|L6AQUe z^*4bJt510EcOZ3@#=R$%KnaqkeUrY=0%8UJ(?2C6btqE}%OLZhJ)!}cb6G{V?`wKX z>%Fn<;>EZ%MBpp3!mxjkA1QgB6X{50!>!^NJb@dXt1yZDi+Gju$L9g{$Z4kX?UHfF zdz^Dhe`QgZ*>{?Np2zUMCw+O^dX2b={2}fKu;?-QF7%jLd3sED{VG&yL7uB5bGyvr zV_&MO8?g+SX{R;sur-gsJqTkz-HM{3kfPVBw{O675o?r9jb{-w1!@&j#$e&q)g=^z z2yogPG~F|L3%JI*oDNw90y_U@FlW)sXDI1KRoLv6&|s5kR~oWys`KEgRAba9&iJHo z#vnungkCyyjlY!P3I9$LN<$4GfM>q&O8nVsT+8H*e8c?i7vBw=oQxiursBdvRa59lk;cC~^ipP62&`k$ z`srPI?8CcnZXLZ#_-eX}-gU8W%4k<-SErTqnI&FGn0EA}3v4%1ij_XfjIVHv4L~ zZ0fle&h2TQJhkD|=^y{wOb$9k-0MwmVV%q7Fd9=zTqQ!4fKIdndMwuQaoedM@C5gy zdq309EP<+1g_BzN;Eg|6onD>!Copx+_ zBVnUz7*75avNH&O{P9@@&>1pEECY3ym&M+nRD%C_jlc4uWr_1oN8zO2eco`8r(!WX zPU9mW8d7EU~Is$b{JZeY- z=m%$mFTaYW>jl*`2dhpOPl71Lt$UbOp2$S1qstf5MeO}G1D>hh-HUMzH+wPmp_9+Z z(d>m7{l~j2S`<3HyMExVtkZ^g*#b-oalAa*jhEk2r@|bprRL04;Q>zuGt^kDY1Od_ zH9J?v0gT!kldWuogkBIl^?fFp3wICZN;tGl!V!*HLpB;SUj1DGw*_(#Ej=Nn% zxfm0R!m5!$Jm+&rTpkChP0KRfWdkOwy0lop8VVkEbX+?Mgyi|I=mrnT+49jNyL z=*SAhG;=ATWr5E5HvKQ(JxOn1Y_yMf%oN(mzxK)DD{tho_hKdHEd z49-~@=FT2h%<{g~)CSP${jj+fKj#nWis|~MiM%7i9~%LMt*wEL;H5g# z@c{a{{9%PSYF?)papB{aFJJU`zCn-K&QjwD=N@}6fS5jj@tdzwHHQ`UR&xZJ+-o~g z6`MVjR*{LI1?)bC;7vZAUcCodbl8a0iKtJWz2d0kn-bLg_e4#p!inOY&&Wx)!bCZ@ zw4Bz8ue)ucam~?m$gu$!GG}4Qj8km zBzlYtZ0ZZ)=^ViF3Z>dKo#D&8pdMfDN-(PqLVAc}3~-$Yr;Q08sxzKKTKDD5ze!Ck zmrT2kLh58^ZYB#NbO;Q5kW?Qu{9~m%G^wr6Tv9|k&7yq6<)9!%hscc>tf>+eJ2=k2 zVMQ$m{9|RKebCmxiaYsS#K=d+8A|Wj;*l;imrW*B;s}Y$ykq<)-l323m8^eb6FGd+ zzZxs={8v^ZY9VLkK`Fx@AKM)NvdzMJlmM6Bx+N+1;HkUBOBxq|QsA4iZ*Ud4KuZGW zb3IIbg!bh-oAtdn!HE9g)3;6ADyt@T;bfPorw<`tChUU9N4Rl^Ejh+BNRzSX@OU=k zSqyMUHYr;qk$zZGl%sdDZyG17zWrFsfAXp2^#u1DpnPbK_}u;d*b3Aok^1ToSH~AQ z#@ld0`eemA=~nft<{gmnp?ALDE#Ei|qzt~4>QH^`T>*4KAt*G-1SK?7vl%GhdbFFV zZYuSirZ{j`PZ+Gs53 zlN?!=QIs0^gdxv{dyh*^TiZW9T)?CY4#T-mRP>PXx=;cicjtfkrb+Q-w z_##s#BU{HCv>Yj0apr(gjfUSW*JA&$l_)*a;bC&-yTED@Tb7w3xdL9tDVL0W-k3KQA(oSG zdMEoUS-6kUYv*?H#_wZj|2^El`4dD!y(g*t7lzU6bI@_qsnBBg+C@CO>)@>3JrS9x zwl**0U`?CWF|!LVVrfrm4@W9Tj^!jE6Iw2ZZx5Nt!qI7oSiabAk-8ye(m_wY|?l`F%;7Kg4q4cykm;* zGZENGM*zBo^;XJct!^4(S%;cVp9 zUZnP6o)f1~oECxcaJR3aqv7*k`;zUN!G_(ea5cgY87yGGzu~yRR3}2?4j#$L*K+uC znnh9(;EpZoM_pzUmcB|@w7#6sS^W0Q6pnFFvPjuyh}fYwCS=k_WawrM!_hiy7O;W^(^Q+$>Q$86-G{IEH}6l$t3cfMPA~<`)pwu0 ze-*BloT{@3TR7C?Q>A?K@*Cy~an48rgKmHo$~ic>2pGFpEaVU?Zh2>2>*)<&bP0%4 zL$d~64%VG!(~5i<2BOxt^1ly~f3#2hc9H(W#A|GSp=DdY4z$cx0?w|aqz04+G5+4? z@8-~mds|w++lC$b79JzQ%f5kRd)pPe?sw%uRQ9jHxr>eRliX}Nf7=lBJqSS3Z4dR^ zv8uiSRhXH49jA=hZPdJ~`w4_x1ESDzDu_e9{6k}*I!yEl*v7B1Q7k$ai?3=CDu-#E z!?R9dHa|TB3~4ryR9*In_JyN(2;>&^yA)-t>c_<*W@FPdJ8KUk--J~QPL%yve(Sz# zU;7nZcNUAU>UBnkk6U*z=|KYL8>Ur_YzLB=tZ-{sb;P+Cxw;G^8)^64E0l-Oz15dh zw31~ype(D06!=J0wKCU)3hS;9b*pxj3ocp>p!!T_RdpFKj<+&)DoHSZmihsTb7L|o z%$@nzZ&tF*M%=4&1MB0&!q_4wVOa4U=W!(0Xq zvV^6_voXM$RnOP73I<>X(mQnAaiKzXf@9Qa?1C&$tm4a zu-Cf?zB=G@q8+(l0k3sox7?SQlKEBOeZDg3_<1>Q_aP5)^7;MMA$GmA-v9KL+Dj4H z#i_dPtX24{Xx-g%G>=Bmm*lFHa2@=nzg0NT%An17VF0C3?Q-97rt)R}@T#f6NGZFT zG#jwgHvPfDRJ)Ps^Ct4_8t)jvl{izwJ~Amjv>%Ae|Y!A6Wt41g^J78qCoR&)<{cFpjn) zI|tJzoy_AND-OHv`i+`KiJf9w+La`D{vw`qg&cdpmhjy1PQ3|>vmIRGbL3=0N@4JiN$n;x-m-0jjevhb{aNEpZoeyk7u(jjg(pKSJ zTnJDm%NSI682KJ&r)Ws>7Y;|y*4%1Urr!Qx7QNITIxt!1X*!^8=w+%L>I&M~RK*ay zDjpcXze7mrz?SuUNvhhx$>R3@Ffla=?IhBGSYM3d3Ye5YobveretY)3{il1kB?UL_ z6c=!${s0tY!d|wR7UT_Q$??`pZV3RY9Py0}piR@HE|9gr0(`>9AJu(v!K1d4Y@JVT8>R3 zZ$~Ugp3RxDjWZ{g-KK=D9UIRX`P)3aE9;Qh1hwzTXAR~knl!_uXaBI_0#djYP-^J; z{-Qmy-;e@#iVn;Wx38~{nbp0Ub<1JKAlG+iEc;KxUgg@TI*qTvJ7s!S3uTngj}_j# z8d%8ez{fYxO7V{Zq6 z&650`Ad5dj%6Q`{6K#bkf9eY#K&9f}HbRvkNU8sU;(v32|Ad~VfkRp|4+yrvqqrO(0m8}C|Bau;A4h;G z3opyM#*(T#GO-rL{{({nWP$%j@c(=p{2#$X-eKQW271uaR^NJ97b?mjRIt#egK+J3 zaT0>^=-NTeh~+?@>Vkr=BV|wr%I8Dvd6FQ^YqVR=cGN|q^%I@%eb5ADF>t7-U}mx4 z#d4;=coC?9(o^a>FtwaWP#?O)D&8TRy>utalJ8{kG+@EDqj8IiO{Tc1{cg@>%axqd z`w#}bx4AwJhi5p#*2lF(EL9XNjRjk9PP|N;sPJ=J7^Y=!*vK}R2gGDOI=w(p2ka=w z<e( zJ5}t+3ZxJH&S|K}iz%Dc8!4e&v>sFzi;HV%dTBqH@nPm^(E+F?wZEZ#sZ%>(EG?i` z{mZ0x!vV4j+_KF4GPheZ6ZKiHTsn|jwDeJ9ezJ$4@GTrX*z)PE!hE=}330A_02Q5P1ZH$+m?g+w)(^+MA{)8tlZK=Ubo6g%LXVpqhKYK;!QU@H^x76 z2owt^fW!={?9#36S;LDTFdX4@AMU(l3FIMtEtuE=deH7z2VQIMOTXsn#4FJC^+xR+}`6}Tht^EtMS{UtD~1WWDuw?Wwq`I(zdhv1L3g4iWSeb zk{`ZiBKNq*<6UcviM`uQ)wacR3l2x75pRaV4n7X*#(N|k6iF~oK<5Zyy;E<7*06<0 zK3udYJA%;jl)oGlmIXf?dI>wp!*7ZXmVh-x8Cx`VCRsW_YkZ2`KPzt=a$iOYRC{u| zVa^tkoIFgxo&v$=j^B>RZRgq?0y0HXMbP%=(pj8Buoqql-^B2Me1eJ={Cho~9JTu1 zHfN1`?7DXqMQkBK+-IAyV?ya?nN;_<-NN|>o&5B$ZeX@J#~>|r(3b64tl2Ie*teTA z=l0o~AF_y~!s%W)WM33S`F1k%U-KXc z$@ICtXNq8{@JuynEhhy(@nJ68z_j;E!UO)Um zUUx#e3&k7aD?cb@FYr!JKqjgYxxYqeFfCXr0r~M57yV|~@TQ7Onxxbr>$^Nr*Ln*D z-Fr7xTx>+fA#So0&uW0+iI6v3Xw>xK80JrS+g&d>$#z0S$=Cc7uvhYzGcOK0ylr8M zOGMnahP|segTd*9MLQE>5Mxb(%u25YHrcnn?no|DjFZ?&Or+ZlOFvzKEPs!?*w_zZ ztMM$}#WE&uEJACP?h?XY{43Ulv$opa=jzRlCfB=+rrdb*tN_4v=+Xz|qsi89?At~)Me9YnV% zGQfswqyjIGHTB%3*IR+-u(k+e(Tq++zB$`7%NLaOATP%{Mw>?s#7W!}GJUmP@S>%)z;Qm}tBB3ycvc7I z(s!GuMf89drz*Mv_Rjj|3$u&y$%pLCpJ}^k)O#qqx0_zxSfu^}FV!St?;*|iUJv*F zoy=RDQE=^*Dn$?J4E%C@eTA04Pcw_9rH6RE%~4=B#|ya5k?3A=q03eMOB>jTdws&z zV|;EH;fxCtPy?3oM)ePnG?(@6B`pauxc2eVAo&!#c7bDeF?X5CS}%mAo(4FOm{?(z zPo?T_ynY(=7N3@RZcJ#3Rq2$6Y`i<})e8}sy@~BW*YqN60!cD0Qaz@%@K@@rdht%> z^P+_+C)Ua2DmYMVjxfN8zCjVOH)rvOZh>G*HASI!%bX9ZFxY zklJ;w%?e>ylJ*`K-SKU+X5mi((b+Ik?X+fMZq4b^a0xT> z;n@(s$ITD9`S_7>YJzP+B6?d=)}glR=9}G0Qx1O!^#`x4&4g>MlQ6B$5KvAs_a9bP z#3z^5`(eNo*9GmFqAa9^_%dAEgWx9ml`DZWk}fU|IVCFZEt>R~v@;}4G|Y+V_7 z-1tE0l(q9<<)ET_|4W^33#Tv)S}Eeb59Ynb6$M|&Gz_9ORh;0w#GU5PD=}%SB>jbD zpXbSf)1r?u?KhwTu@XgGp5)mE@y$*PxeA8>F+f-MjsDUppM|_8Va5ymlb{A!CK@Sjle2?`;m3XB`}HW;aUWe6>B- zKV0*Y>~*ANy9m!|R1K0Zi90^?9LBbBDfL`jSR{|vxEq)*{e5P5h3MexLRHF#gU`{9 z2e&HDh@lrHj?Oe~sIWN106r*{QSo?kikX}#@72RCq52+H`x0&MvkphD$0wW;{n-0z znx-3^7aVe+FG)i`Mzh)v@4p1{E3P01+TJ5cAvyl~2zWxFv0!Jgt>Im&XpwPoj&YBj zJp&i=t7q|^ak;`tqhJO>AKwrHg<#eWw#`<4^ux?UipP=(1r*WYWA8-97~?P6X-HcI zy60C^$wuH)&mGJMGNsE4b$PuREY_9>*|`Y&5K)tkR@ZMGJx`*i%r>Me zlO#edkfFCw3wAyWtVQ-9x$+8f=!#HCyZUKZRa;n2WPWh zZVttaa}SNCWs2Q=Shdx=0#sXCDn*8^1FP%o+K_}wPq{mMBu)I(>8Awdfud11Qf9C9 ztJ)s=m$U-i+#J5QkDQ3h6LEOC>KiuhPH8iZ75GMV_8+}3O?M~O}{{BqBqhC+MXV9w->Si1?Pdr;$*}DBY?ZgLp#4Hz z@`UD8CVQ9T_1z#hS@TSwvZA)JD+hoRYhJ0ZNh2n$LJRv0iQHt}^omh$OegR91~33) z%A*0iOQ5^7K4AybXs*$Q%Gm;kC1l6Rvm|yinGsWN3;^bV!Vh#S6qR#sPNI|oKX|`N zwm%dJC<}RBskJpvJq~Ow4lIW^%_+p@S(#1l?gSma)>>;U2LxQaJ=#iV*gQEDa}K3e zo9;res!m%53CHs4T^j9D+7<^#qb8Ug;~oOA?A?J?)Gp$dwMCv8e4XPbKd;~vo~3-! zrbCgZXG^xx>AJ>8z5wd|ck!>JW8aMBCsbF-#ta+}`W81(9BR}ZhWsoBpvFp4Vg8zx zkAE~Axe$Cu#wP#ds15Q=Al@nJ!A0*Wg?#|0%38=>jvBHv^6(_;qkx2w_17d$)^;V0 zFM!wIe1!-|XY(bnDZm{2J;B}?c@-`0mujWK39a6}WECjq;<$Xhl9}R-B)Yc*IzZ#L zRArp!KA~!&%bk8(Osk5%<*5xK%nO{5siMo2a;}eb49l>01(U(cqh0BC=iA*(qF`bs zm{k-LPl+~!@?<7oJcGL;SA?Hj*9#xmJ@Cp)(Hfw`2--v$DK_~?P3(F8`r(+@Hu)e+ zTy2%WlHSNsdbVF^7h-HW_30E|Ys2t>sAu{bxH2p8WSv0y(Gwb)%ZO zo9uB{)*E6Q4J>sPj*;?)md7(*fjt;c)9!p^9kedgp~>#qTPU;o`}{H|+YFtC$h|pq zqVbF@%^X|XguQGz#$?{Rrr3PI-kA&gF%wDh(}|8Ep%}1LIRHBj zc8ZsPo9^YgF)sfXQ~Cv0jm8|~P}qer+pO4fKkoHOA~`JfoO~u5az=WaR1w#4fE=10 z$#*B&Hs))i)VZL2Qo=vZTQ+-bL)Y{xC4ey)ENHKVW?Ku*%BAB$JhlQI3EqLd;=r=P zE@J}-cDfJRrXC!K7%;#aH4A4IE+r+fedQa^MfWW)3VId>dr()R+nrOzE8)UTdWj59 zC&SxX0*sdk;&SDaG8_>-GuoXH! z&VF1z&+rkk+~mb#=J9!uYbmaI7-qNqQ4#KjIsNjA++}X*Z-gB@WjjPZg6T_s@Q_)_!ZD$zM3mx5gL?nom*IM8*#y;}pB|-ypgF z_~N5*vG3zvXI&mQ*7;o3KEy?4|DZ}AJ~$yrXJ zzR?A;4CJ8p2k{^csEurFR;ZDJ;hIT%Q&g$3ocPQK-tE8?as>s|>@^$(#XQ{3?VSgR zBPG2Kp6aWf_b}~UoC_z*9?fznAk~2UybqJWSFO-Y-Ja9exfvMez#5nPr!LV7T8_)R z`e5~Kr$Oh$Yo)?6WNm;$cZF{qC~nR&vl8yTz52m5N;#au;y*73Xsm#OFFXnny%q*TYUQ1_*SG)SsJ8 ze3&og0P1c$pNEhP+2oG6z}25x%!-EhdW9BztD<3;uWmnXUn0vz_44-46A69}CBSsB zWD2?3FFo{E)c5i6_Lko-(6u;K|cTbE6WzG-q%@}rP-zF>@w2Q z&~c6Z)((Nypl|#{&%?Qq&nFq7gj0}r$wg2^b4e6!a5U<~&Mc(#HZvlj|Z>MdlgDI4l)+8sipB`)=Nu63J=5-*= z(Wh<(tXZ-7f8qW;hpPSaC#kxiw#aS9yrn7MLhS9!5%XWh2>O>Um3EyvYlrRHCq)PI zQoTf%_3Ps9an+T@^5_JY-}AazihQkRD2psmwzz8}IN)~T^saX&HZv8F_5h**ml4ge z^txxZKver=!KK5eJ}JV7hnC`5Ondaa=WS8b_I#nYVCxIFFUA{qxG(P`?~Xwpe~vFc zdHR!co;C+7Z>vTup0+8Z+d?mvuIC7?1iEZf?9{ZMbJyJwhT$X@xISgEf7mJ~MA;w|!T8b@P*hnW^eiJL#AAz0#1u=<~#b zoP{ic7e=0Ltjvn6S+uj!Unl4z_F6MLCrZp9FF&MJXuorD(A;dQq)i5Vd+#V*10UNCE8yNZbLLag)^8H zDX7%TPq@$Uv0i=HW3$$ae9P;4#`i8iXGLKTdqq){T5Vxxyi=d#{0jP^zo<3i`2sc< zOrE&xITeVIqY$fz#&W*Vw+9CbZ@GjG_B)%mb+sb<^z5sT1>Qdh6D-!}TmIPMZQ!tD zW4oUWAlD*Iw!0@ju;rPbH0G$ee-(j=DbKii-;fX9uTViH-yyi!2ZhbwY+w>=16y~3 z|K5fMGz3x2fGSzw5zB$Tt=XQ!mXlmXz^h)$b*?#uWH96n#oVRoJ-;eh>il>Rdv5fA(}y;oiHzq*oi!1GCEm$iHz2(U+9iPHf>K>5fSgow z;^-#S={~(i@APE32iAkmdOC4JumffKU6T+NfBUfHs0lPmAidw&Nf&m;J-d+l#}Q*D z#CDT05fjXN1imoFHUC7fsBV|j{ct!1A2z?w790Z-Ot8%db&mW@4?`i{o@Cmk=Gqxs zl?YJPZf`a=ABi=ym56Q_U|9I4A6kX*524!7>zsbXX62a8T#Ouk+)dUTE6SD6hWH!nzgT5bC~uy!-KeWIKK-`rra1MA|5Gir3O1?msHbgiNwP{o$tgDz#!yVxYgsrM_E*XF zh86bmJkll~l+Lc1@+)J!%}@MvsFy{M)Y=&9Ut<~GHo15kd2fk3IAoomuUO*B-j`IS zIx8v_M=Y}>ZywKJBZil@#IjBAGovPKaUXu5t6p`1{JR6L(wAUHNSd zr=IiisMTffT`J3w>%wo6m`N``b6D=O27K72p*>At<~q;pB+|h+n)@B>4M)lE>p1w> zcaOhc);1NFGMaf@8-L!@+lVK<*B!Wqg9>{Iu+()|OFCts9Sg2yqT++We7&=M$UpJm zQ^0q_cAF#b=WPaq9pwKa>bQ(tz>SMXAjHrC;r0`9^5^ql9T2~sC-nck0e(I^T?b#Xfd8lOx2RLM%)iT!K!}5S0`a_gi=L(?5%yHs z@K7j4rlKGhblwR*2O1>AFJ}igQzm+PptP!XT4&VAERgngL3?B^c#Cb@*c=AOJU|86 znU<+)jpdYGsNGWgRc;jPOaUt!TYb$hvIhuLT?Da0prAoZgWQOlv!iaJeRrOQ z`f0)gLyEJRc?0fsRM&Nzm%c$xln<(wCM3~vIB4wEp6)*a60?f>;Y!83f5R$OG>R1M zp#h)nNo$m7w{>oFpn>*wIiZ+`0aZtJ7x&v8lW#rHH0UA>4*Do?T!C6r0!GP^wB<8< z*JIkTvHt7bVA<+94>9(x<7DOn_NobX z=xZZIbA~Vdp7~c;8`aLOK5{`gs&{BYJlg}(Lfipmylqe+3PPFYD1Rt_C87lymjrafLIlGkYVoNJ{ld1 zO(CCA)t`p)qE;#^xa`R~Fr^5J9xK$m2N@YhZU9#G(*}iDSdq30v2~suWT2mw732SW z=~pB|yp)+DH|l1gx7){V;>1R!PiKDpOz$`CP%dvM28so>1f(Ddod|1J%_bRSogzz` z5u&+G)ba8AUHEN?{{gP@JQ73}wb({2f)Fu~Ru1Hv#$Sl#-;%@;^W!|#YEYVIrb|pY z)HDE;04~1tCp4r!0!3XcNsFJ4W&+u3I`2p}RMGVq$j|!q`yn|f^8!3#2s|59MSyw( zvOzA1Nu|U#BjZ=d@dT-@2se%_s7w!hC(rhS;JYm2yhz4CjGj^g&fG6fypU?!`37m?j6gT7XlxHwFn5ndh0m z?kYCT^ScG1t^n=oLNCN8_I7~m@1w&u&(x1zh)t=R5#n({1hEFPNX>|m;YeLt@TmQV z4sq(40EZB5mF!l(4@jOO`H`*50_;y5p;#f1MU?724u7IV4FFPQ%tX1~hqq@~xa!g<$ix zt15lmpT~ZKMazBb?AOf^*O^C$wT=DR%+V?d(mZs8{xr=g&|N_eL5V(e0SMhz-+rTk zT6qS7ovZ%aqq!7LztS941QK(!I$4fVEW|4R#3{YZ_$_%HZ!2}~GR8F!V2Q=>511rn zp=`3_2gC-sq9za)b#y|Z-sCjAg3?Le9kp73MD9a6(po@4f-<^YhI)WK&shE%Hva)a zr5}k>7p*sT^=CM658&*G^PgBjcjnpBXZ>KFw-X5Q{f)Ke*m7eK60v~jnvDI&FWH_6 z#TeBK;}@rr-c}vVOSG-s8;||Rk7u4WdC}5buMRp0l^z;#RP6mrlV@M^r0MIhfBgM{ zsz=d_+O6rgO?g5wk-ioaO~curT*!(4@QrV1AaDwN1PDHUyEAuWyh$7mKu*aR`bRH$ zyX*_qGKhPYkzB8)QiDog+F+MmlMJUQx%kA#&F{v%$dsYJOdRO(r&_;A1mS+oalgP^ z2@q$+p*+963BK<2_qn|5-dvaK7=RZgI*pE4(#ITAdq2lQ-8xxE$e=3jj*dd)Yt{|E zCW_1LWV3Sk6&L)mSNtoEDo*8_AygiCCOekJ+SpS)I2v|DRfhPoX!X);THkwnC;WOc zut`eCXd+bJw$>Wgy%7}1Au@2CIUVAA&wpmzpzfpp#oV2q+A%z#LZSB!LXrc9pZaBu z9e=u1Hm9-mjoWWa_-tK%MwUw7Ev2C}Ir*EkHr#jtBlTA$NW|{{h0#kY({{DHvZk2J zWIyKkfE4dYpL;ogO*SpX=}&Xb)oCm3O8%8yKw6`Iob_?(+yc)wCpdO zzxCe#(*0G7#7~DUux6|nN!E&M|3zu|hl%9p?Y{t89H>E!9L0Ly2D1Re74lDz{I0zG zw8%9|&Hoek|JQ&95V2w+`dMFqGG<=9ETB2*m77TL01V=PWASU0)wP&~1iDov_P=od zQ*DKKu7&kTc3;j!A~!d;|Doz*w=drha~?1AR~64LMi5wJWo6?Ebloau`ofQgeu+Wu z&9g`VeV0}=TJy&xzH6rcbdnnVtV%SV395Kt8W$2=<=ExPS=AWz88mSjh^(jSWKMn~Cp0&3hy3^gBi=Su-bN&xQg~lrs6D$Laet!R&3H*p zg$Xh|MxhNKtpS{VT$gb~6Yy0R*6Q&GpO?{DOc+}-pS#5fR`F8S!ccY1GIr=u+c%$% z&B(xCtJ1?X2jj{|3!n^nIP+ZoOXMQc@U4If+q}c*sm0SOpv4z|@{N|vptUf{w0;n8 zvqLuzelARKXRK!4Q;RNnas%>o-r3W*JWfz_ROBGo??y6H4NZNtY`;Br54W=GGc(qbvrB*Dg}U0Fm?SBp$;+&BCIP;az%WR?^^De)(}=anr(&M? zosb(4PY1T7+QC}^OD(FoEGuNhotY4`1{y<(DSl@4GeS{4M66A#q)>tIv|akw22G97 zIWd%NewnT3AZKsEbX{rCiXqV;_wpJJRje>M@LDDmLl#NO9K0Dx<8i^}JCNFq`}B|| zQNB47|MWE;6Y_XuyJ3}TK_c1CH)8^^n0sqs08gvcQ~AE(&}M6y_gqavRETXp@=?uS zd6NnKE~S@%^mS{&tXY5&2fX}{?J)%*_7hn+Vz-52rs`&ZFbMvw`Y-=m3&*k>;@L3+WFJAnpeByJA|Q-))}ki{il z!)E)|SbOGb2G9Iutb~iLRR>KGbKbm>BoIaFi_$AZ0CHw=wqXvTx=oopCcwvCh$OU+kxVw#^eYhhd>J7gRJ zpI#p)*<{Ovnn;4x_|<_=Fp;G8DkuV9T^jKezKx-DoeMrv97yoXOM_*gZ zQ+DB|4b1mFa`&%5OcBKDC3o27C(R08Bz+a)xl^H!=hj>y=r&u@+RY;=%BobOD%YEl zAp9y5Ich3ga8lp+x^ByikiY`b29d5|gffVB{VMF9O za_e0vFWDU77S((~r2g@VL zx!F&eUr2E=*fY=iKJ)WL4}fC11ibWG3@(28Klmfes06)NW1NC ziWTS!5h000br2omRaf>SDU+LS4;>4q%wotikl zbboMsEGXgPxH-p{rWM2gs$sHAsz#$mUzL-T>3i^mI_TOP5gbvv9iN9N6h#d-du!c|_2} zm}5gQ_2b)@I41)Qdh07>lu|oa{;Jx>CZrULQAp@nP%VAMe|14Ej6POK8-Ps-M=j7rXneX<=vmS%b6f;+2 zI(kAN5*#XI@KZQ^)UEnaeN~#F0*&3D7fy}N&NS1d%qBC%4ldMJQ{EZJ1HXD@?&D*b zQ+r+k8>y*QN}lKtCl3GQeky|>_2}~8fLGA8 zb$x8}I|+}4N5FZ}1!_SGg&!Ro%G@Zpti9-$M6t>rp7BtnA>_yg3puh?85$_j;K*{? znbVX7Uw7c<@MD&vG|()aG2ZKmDvRwuK_wC_@j0GR)NEb9Q(|oy&D*?>$f>>NuEKuXma|58Fgd zih4wb56*)ook`JzDtI0?y;jd86a>rkC%skA*1E#+_d^YH(&7ofJ;TLC^Z_GGHr1+N zLa~m6H=_vZgMG>QE^U0%P}oT_+NTRjx2YfXzkl>2O%+G*>6$)pk>!*2nu#zx=*gxB z-bc2@?4IxoObkC@RIkXYFpzm+nasxRfjJl>=d%9=bK9PmM1nwbqV??( z<&U(pZN}nGXw`3XnLB+!iD@&(8z0O?2GSp?v;X`-%k${Q5&UF+1Hsx4_!SQS__ZW! zUK#2Z|B6$2)A8oL)Ys!KZu8lLag@=8FEU=Fw`czGn?FJ9KR@B$ul3g*Ul{mW#_j5G zxVOhs#a3g!MQ zXbT2`g7Fx+{T6XK-}eymDt%2<2T!I++hu7pgk0GA=!-Ej_iRs4H&G zS}E_@diTj&kM&6J_$940=lTVC@c#-? z;o7`wLW40BXItwfPy$v4pSr(a_|opt+%^l`d}-HuuB-ItU*{-?A2yqUHxKp3kl7LF z`yq|F!8n8Qwn_3W)Ye6D!q-j9g#khRifQ36V5b9?B>Ul{`>~-{P4fFDpoy20%4S^* z=e`g+C?Mb{D-jurvDOO*1-UZBlA2XGY`+sm8Yy;x>EJpMt&X=h8$ynGpNwlp1zpaN zpFYXbCNP2>D-oPWkapfxE@wWq>?`5}UU)V(ohg6AY%JKxAZPDjvjUb1_0_2#o%zU# zv2|kr>29K4p%~uW#hJ1jC1S=z+aF&U)FD&Ju!C+Je&h}7h17w)5wln5sU-&YVlxIj zb`8-EJM2*mZlN3kQ6V8BG_Q$R0pK3`DzVg+X6{^}v~Z4Tj~$!@e@ z)*K25>dL~m%}keIc*4o~rK(Ym!^o>TH5#eM$aW=dGCQ_z!ymcVeDk3czq(r#U=A(# z)To}swB0;c3H=c)lAGKfFGs*6*8?st<%n7TEc7Idmd-qr8ONzKNVly2M-pxC%|Jv`ap6u;{l4XDD+*s$A1^?T}ojTI% zElNw5ti}P`%l&%uh(ib!=Q_bETrlw_1rfXyRnUGs`>Wqv`zQ#s8mdTL5FG}G7C17J zlL?3>!ib*6d!O^KKl8C(9CNLfVpXXTj`DJ3HNV90W1?xC-R>|2wke+APb$UIUzcm* zFA#XFo1y5IyTEd`3Jq*F`aY9!=wSZTw!|}yukqrH$d0}Kl4p`85Sx}LNXNLT_*gux zryhINt#rk`3{>M4SMT!a@`OclG&iS31}9vxrT@wWKEkh~6143Tq-fzk$7^J5nPewg;9T#D zXQH`sM_$pp-+PfjPlO_ZB$ZirIT|g;I?RAdRJZGat{#j3lgaUWxXl_deK}f1jCbiv zlUvA_uctxVw((wIN@|~Y7X>-UB7QaALTUEKth2c>Rv8R;j;!my%i; zC{QGx5P?ibe|7{5HPQ^9V+t`FWN-a_LKz2*Hp{WnXomSq}7?lN%CZ;<8r(hZf< zSndov&2&NhG*ny`z{Oaw5kXa;ZEZ9zIpVc5uvrb9m&kXed|9VyhAAj;6y>&8H zqaCF}qokI_D;qDwLS5fLG^Z8nR}er}#neYoaij5leb2Ny>?{?E^SZWLE&S=hTe`-F zUmjy?963G!l`4S_X3(6?8wEwVtkKB;orC2f1D%Rodi~9lQCN4ay%YneI9v~d&N}Vmy}+Nlzstz=SA-}P zTOOOODe_nr8T8&+SEsw(7GGu@T*tR}0zE4U z%!R?h+GqdK@^(-pC|}ijHC55~N#xwe=trCU)kUd^mw~ac>8mFwfe*HOWUfUZgwfet zV+U05yt-~MK`hPH;mWBN2a%OB;3=P{j02t%ULsXqI8=CL@@&p5j|rDT zd^sy@fa<#%+C{SmV%Z9qUe0Im(JYIe9tJ? z?wi8N?*@~DNIgDzQCl#_|L}@kLp`EM%L{Y0p03?0>;^obWARBBH|b;5bx*) zmv6fd7C}kgse!CiaMf%@vvB3Vc{HS^edgIt{N?_)%yh8Wk7LXqGRjg9T<66dE$hea4C;OyZzLaFvK=Qax*TpTN zIT3pE9YQ+!C390Lm*vXGIQL&4t#6$)P3PO_)r#JNo_)weo_;##@u{M`i4X#od-ASl3XozC>S3~-uCcLGoIwbchy!}w_V*1+a7ClX~+89E;MsV zL4}Y7&+c2H;;oa{U0X%4+$Cu`w+YqWB)Sn+~ae;1UUuih>hg+ z|9|aWTU3)-mX3>6MNccis#3X=vWO_HK+zOX5-wFLh0z8|5QB{&G!(E9LtwZh2qD#l z1|=vM(0~EbmLMod$mJ)=1m|I<=V6{^=3!Q?bsqP> z&)(nK`}@v1YyJCdu!5*;2{5qP50lhr?e{1$X-wOW~yeFrT z1esvO+#hl4cVNM^-?8`|i+`uV-|ON(B*8F`Doo0o5Y3b30hQ-Hr6nk;@;_71|DI^P zYAfU!~=b>%>%(woB|p(`Wab0zGL+-lD65^)ImQbo^2=#Z&i? zI_@1KmWyJ=9EMX(x9YIX^;~kjTTX^ScW@-Z(4D?exZzocj8kd%CzrLWB!;%W;?nqV=SGuh`B}I z6j(df-4Czr&eR*%4yvPUo;| zq=W_h(==h7$4g*k4$&vcXyfQyu=l87kbI=4@z+7wle`i)5apR}RuK^3Qv0U61y*7H zZgFIowhs=-*Qcq9DL$o)=|pqsO^3<;rdG!a8+Hn$i!Kzq%b&XD0ZX zOE@&6B7l;U(k}8A^T_r1Tr)-vZ6BO9ApwlfJhgVTH7*7hq1S*iJ{LXCPWS`G-~_6v zhY$=9r@9;A(sPrwFG?`Cf=`k+rX^V<`rxm?m7%z5k6~ctk+NX!^5sI+fE*>@)H-Gk;Z z$fvQwZaJGz$R9jO59c9R7iUh!&DOp!s^7lUg>DszM~Ed~u=(qFijB#cWJX_eU5pJ_ zfJ>hBUBz|2|AdYQF7rQ+DR4<=^&+<%cHS%UCPg)ldKh7&kv#ka6-@a4NZ#6{$n73a z*B}G)e#*?ZOu=l5w<>#AN$9y@(WU}dVxBMF0qij-2}Yh{kdMzElUDs^uMykp9@pvJ zdYiR!JH0r<^V)1i19dBLG^+R5kB1S45UeWaU0w#2hhCyd0dVc;BJY zXW9fE+sgmHT@5t%plC;9^5fmc4qT4Pg6kW|(vE+{dc_vHiSQkwtYk=5WTE*NSgpUG zE)HOy8{o*W$k+H@v)9h3%%xRf$$}H_?ts%cb8%MSMmY7GV6;bMSo}@}ggDw08Pu!& zp#`<7!|fJ7%q4FMd>M918zlt7kmh!X!g0NXg1}Hb+sJo^k9lyN$;)0|JMHhvyAm<5 z2S)yGB_tm>^-v$@JH3Aquh$?FzGk*g5dfMCd+=^h#GK8QzCKeXo(!!$)`oIYgU-2b zyik-naM_dQ7y=)`7IPEI1W7-9O^mkI!#fTctpgqHxwOUW(jL*GZ{9kNn(+Pe^t&DD zH)5g>Irl5+o}U&c?jc2)Hp={W9w&E(83L2#eXgu5h&h@m8pGhYr5ukw%Z}W2y#QOb2wfq;e?SpwFM00$#QDGqju3UKA%9 zFmz!%6NN~1cQK+B4fud%LjDbCDnzZhJ=%)+nS1lY^q1-UJ7;`%?ntc52W)t@?E6=V z{Y~06TPr0~Io8vdH*lufxWk1Ic%RT&L%@@zA`WXj^M1YBu43PddzG9jD62>=#B=XOMO_Z&D z^P3z{l(sdgIq#A5FDs#`NJC$9qV^U;TAuOdWLirz(6bM2-w_=lb8I%sXyJJ69`5wa zN?3=dF`~xsx-_qt!8)DIPr&(X>ivhhBhlJ`)zM7i#Z!bw*czCc41L(l!RG7`uIeL@ zF9tNegGCrJ)QJ%dh^j1_6o&$e7pQNJ36g56ZI4{boH*n678c$w44-7k*5>(v4L-(n zioPteRPC??g%3-Wu}=LAwVM7H)V?~h^r<&|tl_+XyI=L)SnHCoP%xjSb*+u3Zr&Sn z+uZq3?~lzB+=`~GZY;Mq<F6t04c=dcSIW|EK;6>JUTT>a z(WRuM+*DdWqb)u3_D`}n3-p1)=bjT$-aQMGue%V{YTCtiDOlTO(P_MyZGJe$?5~BB zQhVtP5n~X&ZdaVpmRkHBDuK?t`{jmtE)tGi<0WC1Fe5zmnjVGd#8IscTEcJDY42k(N46RM)N<@)>Dmc$XPF*2J+$KPX+#e8_~R#bYr%gc*Po28!60gr z5LcfHS~-VvzC(tHEg)0`vaC^JnEoth}jL;3us+*6Ju{xn@H-C4wKBJ2}PnR3ly z6iFaRZP{WgjoRpmoavIwoYwvx0w-T*A(FTuZZeO`Y1e+g)R7)od14><1SiLW=_Nx= z`@VtnqVtDv6L&2Pmy;_FN}zCiRM5G&kIQJ~qalE9AF1Zv6ek97|4cj^8ffLJm@CVSK3jlNDaY^v zl~C*V*Bo5T{-9*4MF|u>JGp!qU>p> z1@VmP!v@;@ym!VNVt