diff --git a/config/namelist.cvmix b/config/namelist.cvmix index 5c73d9403..af600ebe8 100644 --- a/config/namelist.cvmix +++ b/config/namelist.cvmix @@ -71,7 +71,86 @@ idemix_surforc_vname = 'var706' ! variable name in surface forcing file !idemix_botforc_vname = 'wave_dissipation' ! variable name in bottom forcing file idemix_botforc_file = '/albedo/pool/FESOM/fesom2.0/forcing/idemix/forcing_idemix_final_bin/FIN_STORMTIDE2_M2_plus_NYCANDER_CnoM2_bin_0.40deg.nc' ! path to bottom forcing file, idemix_botforc_vname = 'stormt_M2_plus_nycand_CnoM2' ! variable name in bottom forcing file +/ + +! ============================================================================ +! IDEMIX2 (INTERNAL WAVE ENERGY PARAMETERIZATION) +! ============================================================================ +! Based on: F. Pohlmann, C. Eden, D. Olbers and Z. Zhao (draft) Anisotropy of +! internal tide generation and propagation in the consistent internal wave mixing +! closure IDEMIX +! ============================================================================ +¶m_idemix2 +! --- Time Scales --- +idemix2_tau_v = 172800.0 ! vertical symmetrization time scale [s] (2 days) +idemix2_tau_h = 1296000.0 ! horizontal symmetrization time scale [s] (15 days) + +! --- Spectral Parameters --- +idemix2_gamma = 1.570 ! spectral shape constant [dimensionless] (order 1) +idemix2_jstar = 5.0 ! spectral bandwidth in vertical modes [dimensionless] +idemix2_mu0 = 0.33333333 ! dissipation parameter [dimensionless] + +! --- superbee-spectral advection scheme and Adams-Bashfort timestepping --- +idemix2_enable_AB = .true. +idemix2_AB_epsilon = 0.1_WP +! --- Number of used spectral frequency bins +idemix2_nfbin = 52 + +! --- ensures idemix1 functionality --- +idemix2_enable_hor_diff_expl = .false. +idemix2_enable_hor_diff_impl_iter = .true. ! from Pollman et al. (2017) +idemix2_hor_diff_niter = 5 + +! --- shelf definition as distance from coast in meters +idemix2_shelf_dist = 300.e3 + +! --- scal down baroclinic wave speed when not all modes are used --- +idemix2_scal_cn = 1.0 + +! --- maximum cutoff value for interal wave energy --- +idemix2_Eiw_maxthresh= 0.1 + +! --- M2 Forcing (Summed anisotropic M2-tide generation modes 1-2 (W/m2)) --- +idemix2_enable_M2 = .false. +idemix2_M2forc_file = '/albedo/work/user/pscholz/forcing/IDEMIX2/idemix2_IT_forc_M2modes1-2_aniso.nc' +idemix2_M2forc_vname = 'Flux_to2' ! variable name in surface forcing file +idemix2_M2forc_zname = 'phi' ! zdim variable name in surface forcing file +idemix2_tau_M2_shelf = 7.0 +idemix2_tau_M2_oce = 50.0 + +! --- NIW Forcing (Summed anisotropic M2-tide generation modes 1-2 (W/m2)) --- +idemix2_enable_niw = .false. +idemix2_fniw_usage = 0.2 ! fraction of surface forcing used [dimensionless] +idemix2_niwforc_file = '/albedo/work/user/pscholz/forcing/IDEMIX/fourier_smooth_2005_cfsr_inert_rgrid.nc' +idemix2_niwforc_vname = 'var706' +idemix2_tau_niw_shelf = 7.0 +idemix2_tau_niw_oce = 3.0 + +! --- Bottom Forcing (Tidal Internal Waves) --- +idemix2_enable_bot = .true. +idemix2_botforc_file = '/albedo/pool/FESOM/fesom2.0/forcing/idemix/forcing_idemix_final_bin/FIN_STORMTIDE2_M2_plus_NYCANDER_CnoM2_bin_0.40deg.nc' ! path to bottom forcing file, +idemix2_botforc_vname = 'stormt_M2_plus_nycand_CnoM2' ! variable name in bottom forcing file + +! --- Root Mean Square Topographic Height forcing --- +idemix2_hrmsforc_file = '/albedo/work/user/pscholz/forcing/IDEMIX2/idemix2_hrms_Goff2023.nc' +idemix2_hrmsforc_vname= 'HRMS' + +! --- Characteristic horizontal length scale of topographic feature --- +idemix2_hlamforc_file = '/albedo/work/user/pscholz/forcing/IDEMIX2/idemix2_lambda_Goff2010.nc' +idemix2_hlamforc_vname= 'LAMBDA' + +! --- apply one pass of area-weighted node smoothin after wave-wave interaction +! --- the idemix2 only mode (no EM2 or Eniw) needs some additional smoothing otherwise instable +idemix2_smooth_Eiw_diss= .false. +idemix2_smooth_Eiw = .false. ! smooth iwe2_E_iw(:,:,tip1) after wave-wave +idemix2_smooth_alpha_c = .false. ! smooth iwe2_alpha_c after parameter loop +idemix2_smooth_niter = 1 + +! --- diagnostics +idemix2_diag_Ecompart = .false. +idemix2_diag_Eiw = .false. +idemix2_diag_WWI = .false. / ! ============================================================================ diff --git a/src/MOD_MESH.F90 b/src/MOD_MESH.F90 index adbb9ff7b..f6d1438b4 100644 --- a/src/MOD_MESH.F90 +++ b/src/MOD_MESH.F90 @@ -37,6 +37,7 @@ MODULE MOD_MESH real(kind=WP), allocatable, dimension(:) :: elem_area real(kind=WP), allocatable, dimension(:,:) :: edge_dxdy real(kind=WP), allocatable, dimension(:,:) :: edge_cross_dxdy +integer , allocatable, dimension(:,:) :: edge_up_dn_tri real(kind=WP), allocatable, dimension(:) :: elem_cos real(kind=WP), allocatable, dimension(:) :: metric_factor integer, allocatable, dimension(:,:) :: elem_neighbors @@ -198,6 +199,7 @@ subroutine write_t_mesh(mesh, unit, iostat, iomsg) call write_bin_array(mesh%elem_edges, unit, iostat, iomsg) call write_bin_array(mesh%elem_area, unit, iostat, iomsg) call write_bin_array(mesh%edge_dxdy, unit, iostat, iomsg) + call write_bin_array(mesh%edge_up_dn_tri,unit, iostat, iomsg) call write_bin_array(mesh%edge_cross_dxdy, unit, iostat, iomsg) call write_bin_array(mesh%elem_cos, unit, iostat, iomsg) @@ -295,7 +297,7 @@ subroutine read_t_mesh(mesh, unit, iostat, iomsg) call read_bin_array(mesh%elem_edges, unit, iostat, iomsg) call read_bin_array(mesh%elem_area, unit, iostat, iomsg) call read_bin_array(mesh%edge_dxdy, unit, iostat, iomsg) - + call read_bin_array(mesh%edge_up_dn_tri,unit, iostat, iomsg) call read_bin_array(mesh%edge_cross_dxdy, unit, iostat, iomsg) call read_bin_array(mesh%elem_cos, unit, iostat, iomsg) call read_bin_array(mesh%metric_factor, unit, iostat, iomsg) diff --git a/src/MOD_PARTIT.F90 b/src/MOD_PARTIT.F90 index 2e8330a4b..2f26b4b6d 100644 --- a/src/MOD_PARTIT.F90 +++ b/src/MOD_PARTIT.F90 @@ -86,6 +86,17 @@ module MOD_PARTIT integer, allocatable :: s_mpitype_nod2D_i(:), r_mpitype_nod2D_i(:) integer, allocatable :: s_mpitype_nod3D(:,:,:), r_mpitype_nod3D(:,:,:) + ! Spectral bin (fbin) fields for IDEMIX2 halo exchange + ! Full spectral column exchanged at once (like standard nod3D exchanges full depth column). + ! Nodal fields: (peer, nfbin:nfbin, n_val) with n_val=1..3 + ! Element fields: (peer, nfbin:nfbin) for 2D, (peer, nfbin:nfbin, n_val) for 3D with n_val=1..4 + integer :: nfbin_mpi = 0 ! number of spectral bins for MPI types (0 = not initialized) + integer, allocatable :: s_mpitype_nod3D_fbin(:,:,:), r_mpitype_nod3D_fbin(:,:,:) + integer, allocatable :: s_mpitype_elem2D_fbin(:,:), r_mpitype_elem2D_fbin(:,:) + integer, allocatable :: s_mpitype_elem2D_full_fbin(:,:), r_mpitype_elem2D_full_fbin(:,:) + integer, allocatable :: s_mpitype_elem3D_fbin(:,:,:), r_mpitype_elem3D_fbin(:,:,:) + integer, allocatable :: s_mpitype_elem3D_full_fbin(:,:,:), r_mpitype_elem3D_full_fbin(:,:,:) + integer :: MPIERR !!! remPtr_* are constructed during the runtime and shall not be dumped!!! diff --git a/src/associate_part_ass.h b/src/associate_part_ass.h index 615095acc..da4d03e51 100644 --- a/src/associate_part_ass.h +++ b/src/associate_part_ass.h @@ -69,4 +69,18 @@ if (allocated(partit%s_mpitype_nod2D)) then s_mpitype_nod3D(1:com_nod2D%sPEnum, lb:ub, 1:3) => partit%s_mpitype_nod3D(:,:,:) r_mpitype_nod3D(1:com_nod2D%rPEnum, lb:ub, 1:3) => partit%r_mpitype_nod3D(:,:,:) -end if \ No newline at end of file +end if + +nfbin_mpi => partit%nfbin_mpi +if (allocated(partit%s_mpitype_nod3D_fbin)) then + s_mpitype_nod3D_fbin( 1:com_nod2D%sPEnum , nfbin_mpi:nfbin_mpi, 1:3) => partit%s_mpitype_nod3D_fbin( :,:,:) + r_mpitype_nod3D_fbin( 1:com_nod2D%rPEnum , nfbin_mpi:nfbin_mpi, 1:3) => partit%r_mpitype_nod3D_fbin( :,:,:) + s_mpitype_elem2D_fbin( 1:com_elem2D%sPEnum , nfbin_mpi:nfbin_mpi ) => partit%s_mpitype_elem2D_fbin( :,:) + r_mpitype_elem2D_fbin( 1:com_elem2D%rPEnum , nfbin_mpi:nfbin_mpi ) => partit%r_mpitype_elem2D_fbin( :,:) + s_mpitype_elem2D_full_fbin(1:com_elem2D_full%sPEnum, nfbin_mpi:nfbin_mpi ) => partit%s_mpitype_elem2D_full_fbin( :,:) + r_mpitype_elem2D_full_fbin(1:com_elem2D_full%rPEnum, nfbin_mpi:nfbin_mpi ) => partit%r_mpitype_elem2D_full_fbin( :,:) + s_mpitype_elem3D_fbin( 1:com_elem2D%sPEnum , nfbin_mpi:nfbin_mpi, 1:4) => partit%s_mpitype_elem3D_fbin( :,:,:) + r_mpitype_elem3D_fbin( 1:com_elem2D%rPEnum , nfbin_mpi:nfbin_mpi, 1:4) => partit%r_mpitype_elem3D_fbin( :,:,:) + s_mpitype_elem3D_full_fbin(1:com_elem2D_full%sPEnum, nfbin_mpi:nfbin_mpi, 1:4) => partit%s_mpitype_elem3D_full_fbin(:,:,:) + r_mpitype_elem3D_full_fbin(1:com_elem2D_full%rPEnum, nfbin_mpi:nfbin_mpi, 1:4) => partit%r_mpitype_elem3D_full_fbin(:,:,:) +end if \ No newline at end of file diff --git a/src/associate_part_def.h b/src/associate_part_def.h index 262780a4a..0c64ea886 100644 --- a/src/associate_part_def.h +++ b/src/associate_part_def.h @@ -16,6 +16,13 @@ integer, dimension(:), pointer :: s_mpitype_nod2D_i, r_mpitype_nod2D_i integer, dimension(:,:,:), pointer :: s_mpitype_nod3D, r_mpitype_nod3D + integer, dimension(:,:,:), pointer :: s_mpitype_nod3D_fbin , r_mpitype_nod3D_fbin + integer, dimension(:,:), pointer :: s_mpitype_elem2D_fbin , r_mpitype_elem2D_fbin + integer, dimension(:,:), pointer :: s_mpitype_elem2D_full_fbin, r_mpitype_elem2D_full_fbin + integer, dimension(:,:,:), pointer :: s_mpitype_elem3D_fbin , r_mpitype_elem3D_fbin + integer, dimension(:,:,:), pointer :: s_mpitype_elem3D_full_fbin, r_mpitype_elem3D_full_fbin + integer, pointer :: nfbin_mpi + integer, pointer :: MPIERR integer, pointer :: MPIERR_IB ! copy for icebergs LA: 2023-05-22 integer, pointer :: npes diff --git a/src/cvmix_driver/cvmix_idemix2.F90 b/src/cvmix_driver/cvmix_idemix2.F90 new file mode 100644 index 000000000..b24430e39 --- /dev/null +++ b/src/cvmix_driver/cvmix_idemix2.F90 @@ -0,0 +1,1363 @@ +module cvmix_idemix2 +! This module contains the main computations of the IDEMIX 2 parameterization (described in "A Global Model for the Diapycnal +! Diffusivity Induced by Internal Gravity Waves", Olbers&Eden 2013) of Internal wave energy and its dissipation +! +! EdenOlbers2014: +! -------------- +! Eden, C. and Olbers, D. (2014): An Energy Compartment Model for Propagation, +! Nonlinear Interaction, and Dissipation of Internal Gravity Waves , Journal of +! Physical Oceanography, 44 (8), pp. 2093-2106 . doi: 10.1175/JPO-D-13-0224.1 + +use cvmix_kinds_and_types, only : cvmix_r8 , & + CVMIX_OVERWRITE_OLD_VAL , & + CVMIX_SUM_OLD_AND_NEW_VALS , & + CVMIX_MAX_OLD_AND_NEW_VALS , & + cvmix_data_type , & + cvmix_PI , & + cvmix_global_params_type +use cvmix_kinds_and_types_addon, only : cvmix_data_type_addon +use cvmix_utils_addon, only : cvmix_update_tke, solve_tridiag +implicit none + +!_______________________________________________________________________________ +private +save +!public member functions +public :: cvmix_idemix2_init +public :: cvmix_idemix2_compute_param +public :: cvmix_idemix2_compute_compart_groupvel +public :: cvmix_idemix2_compute_compart_interact_tscale +public :: cvmix_idemix2_compute_M2_dissipation +public :: cvmix_idemix2_compute_vert_struct_fct +public :: cvmix_idemix2_compute_vdiff_vdiss_Eiw +public :: cvmix_idemix2_compute_Eiw_waveinteract +public :: cvmix_idemix2_compute_Eiw_diss2KvAv +public :: gofx2, hofx1, hofx2 + + +!_______________________________________________________________________________ +! Interface to call the IDEMIX parameterization +! interface cvmix_coeffs_idemix2 +! module procedure integrate_idemix2 ! calculation ! FIXME: rename in cvmix_coeffs_low.. +! !module procedure idemix_wrap ! necessary to handle old/new values and to hand over user_defined constants +! end interface cvmix_coeffs_idemix2 + +interface cvmix_idemix2_init + module procedure compute_init +end interface cvmix_idemix2_init + +interface cvmix_idemix2_compute_param + module procedure compute_param +end interface cvmix_idemix2_compute_param + +interface cvmix_idemix2_compute_compart_groupvel + module procedure compute_compart_groupvel +end interface cvmix_idemix2_compute_compart_groupvel + +interface cvmix_idemix2_compute_compart_interact_tscale + module procedure compute_compart_interact_tscale +end interface cvmix_idemix2_compute_compart_interact_tscale + +interface cvmix_idemix2_compute_M2_dissipation + module procedure compute_M2_dissipation +end interface cvmix_idemix2_compute_M2_dissipation + +interface cvmix_idemix2_compute_vert_struct_fct + module procedure compute_vert_struct_fct +end interface cvmix_idemix2_compute_vert_struct_fct + +interface cvmix_idemix2_compute_vdiff_vdiss_Eiw + module procedure compute_vdiff_vdiss_Eiw +end interface cvmix_idemix2_compute_vdiff_vdiss_Eiw + +interface cvmix_idemix2_compute_Eiw_waveinteract + module procedure compute_Eiw_waveinteract +end interface cvmix_idemix2_compute_Eiw_waveinteract + +interface cvmix_idemix2_compute_Eiw_diss2KvAv + module procedure compute_Eiw_diss2KvAv +end interface cvmix_idemix2_compute_Eiw_diss2KvAv + +interface idemix2_put + module procedure vmix_tke_put_idemix2_int + module procedure vmix_tke_put_idemix2_real + module procedure vmix_tke_put_idemix2_bool +end interface idemix2_put + +!_______________________________________________________________________________ +! types for Idemix +type, public :: idemix2_type + private + real(cvmix_r8) :: & + tau_v , & ! time scale for vertical symmetrisation (sec) + tau_h , & ! time scale for horizontal symmetrisation, only necessary for lateral diffusion (sec) + gamma , & ! constant of order one derived from the shape of the spectrum in m space (dimensionless) + jstar , & ! spectral bandwidth in modes (dimensionless) + mu0 , & ! dissipation parameter (dimensionless) + shelf_dist , & ! shelf definition in meters from coast + tau_niw_shelf , & ! NIW dissipation timescale on shelf (days) + tau_niw_oce , & ! NIW dissipation timescale floor in open ocean (days) + tau_M2_shelf , & ! M2 dissipation timescale on shelf (days) + tau_M2_oce ! M2 dissipation timescale floor in open ocean (days) + + logical :: & + enable_M2 , & + enable_niw , & + enable_superbee_adv , & + enable_AB_timestep , & + enable_hor_diffusion, & + enable_hor_diff_iter + + integer :: & + handle_old_vals , & + nfbin , & + hor_diff_niter + +end type idemix2_type +type(idemix2_type), target :: idemix2_constants_saved + +!_______________________________________________________________________________ +contains + + + +! +! +!_______________________________________________________________________________ +subroutine compute_init(tau_v , & ! time scale for vertical symmetrisation + tau_h , & ! time scale for horizontal symmetrisation + gamma , & ! const. derived from the shape of the spectrum in m spac + jstar , & ! mode number scale + mu0 , & ! dissipation parameter (dimensionless) + nfbin , & ! number of spectral bins + shelf_dist , & ! shelf definition in meters from coast + tau_niw_shelf , & + tau_niw_oce , & + tau_M2_shelf , & + tau_M2_oce , & + enable_M2 , & + enable_niw , & + enable_superbee_adv , & + enable_AB_timestep , & + enable_hor_diffusion, & + enable_hor_diff_iter, & + hor_diff_niter , & + handle_old_vals, idemix2_userdef_constants) + + ! This subroutine sets user or default values for IDEMIX parameters + real(cvmix_r8), optional, intent(in) :: tau_v, tau_h, gamma, jstar, mu0, shelf_dist, & + tau_niw_shelf, tau_niw_oce, tau_M2_shelf, tau_M2_oce + logical , optional, intent(in) :: enable_M2, enable_niw, & + enable_superbee_adv, enable_AB_timestep, & + enable_hor_diffusion, enable_hor_diff_iter + integer , optional, intent(in) :: nfbin, hor_diff_niter + integer , optional, intent(in) :: handle_old_vals + type(idemix2_type), target, optional, intent(inout) :: idemix2_userdef_constants + + + ! FIXME: not sure about the allowed ranges for idemix parameters, default values confirm with pyOM testcases + !___ tau_v _________________________________________________________________ + if (present(tau_v)) then + if(tau_v.lt.1.d0*86400.0 .or. tau_v .gt. 100.d0*86400.0) then + print*, "ERROR:tau_v can only be allowed_range" + stop 1 + end if + call idemix2_put('tau_v', tau_v, idemix2_userdef_constants) + else + call idemix2_put('tau_v',1._cvmix_r8*86400.0 , idemix2_userdef_constants) + end if + + !___ tau_h _________________________________________________________________ + if (present(tau_h)) then + if(tau_h.lt. 0.01*86400. .or. tau_h .gt. 100.*86400.) then + print*, "ERROR:tau_h can only be allowed_range" + stop 1 + end if + call idemix2_put('tau_h', tau_h, idemix2_userdef_constants) + else + call idemix2_put('tau_h', 15._cvmix_r8*86400.0, idemix2_userdef_constants) + end if + + !___ gamma _________________________________________________________________ + if (present(gamma)) then + if(gamma.lt. 1.d0 .or. gamma .gt. 3.d0) then + print*, "ERROR:gamma can only be allowed_range" + stop 1 + end if + call idemix2_put('gamma', gamma, idemix2_userdef_constants) + else + call idemix2_put('gamma', 1.57_cvmix_r8, idemix2_userdef_constants) + end if + + !___ jstar _________________________________________________________________ + if (present(jstar)) then + if(jstar.lt. 5.d0 .or. jstar .gt. 15.d0) then + print*, "ERROR:jstar can only be allowed_range" + stop 1 + end if + call idemix2_put('jstar', jstar, idemix2_userdef_constants) + else + call idemix2_put('jstar', 10._cvmix_r8 , idemix2_userdef_constants) + end if + + !___ mu0 ___________________________________________________________________ + if (present(mu0)) then + if(mu0.lt. 0.d0 .or. mu0 .gt. 3.d0) then + print*, "ERROR: mu0 can only be allowed_range" + stop 1 + end if + call idemix2_put('mu0', mu0, idemix2_userdef_constants) + else + call idemix2_put('mu0', 4._cvmix_r8/3.0 , idemix2_userdef_constants) + end if + + !___ shelf_dist ____________________________________________________________ + if (present(shelf_dist)) then + call idemix2_put('shelf_dist', shelf_dist, idemix2_userdef_constants) + else + call idemix2_put('shelf_dist', 300000._cvmix_r8, idemix2_userdef_constants) + end if + + !___ tau_niw_shelf _________________________________________________________ + if (present(tau_niw_shelf)) then + call idemix2_put('tau_niw_shelf', tau_niw_shelf, idemix2_userdef_constants) + else + call idemix2_put('tau_niw_shelf', 7._cvmix_r8, idemix2_userdef_constants) + end if + + !___ tau_niw_oce ___________________________________________________________ + if (present(tau_niw_oce)) then + call idemix2_put('tau_niw_oce', tau_niw_oce, idemix2_userdef_constants) + else + call idemix2_put('tau_niw_oce', 3._cvmix_r8, idemix2_userdef_constants) + end if + + !___ tau_M2_shelf __________________________________________________________ + if (present(tau_M2_shelf)) then + call idemix2_put('tau_M2_shelf', tau_M2_shelf, idemix2_userdef_constants) + else + call idemix2_put('tau_M2_shelf', 7._cvmix_r8, idemix2_userdef_constants) + end if + + !___ tau_M2_oce ____________________________________________________________ + if (present(tau_M2_oce)) then + call idemix2_put('tau_M2_oce', tau_M2_oce, idemix2_userdef_constants) + else + call idemix2_put('tau_M2_oce', 50._cvmix_r8, idemix2_userdef_constants) + end if + + !___ superbee_adv __________________________________________________________ + if (present(nfbin)) then + call idemix2_put('nfbin', nfbin, idemix2_userdef_constants) + else + call idemix2_put('nfbin', 52 , idemix2_userdef_constants) + end if + + !___ enable_M2 _____________________________________________________________ + if (present(enable_M2)) then + call idemix2_put('enable_M2', enable_M2, idemix2_userdef_constants) + else + call idemix2_put('enable_M2', .true. , idemix2_userdef_constants) + end if + + !___ enable_niw ____________________________________________________________ + if (present(enable_niw)) then + call idemix2_put('enable_niw', enable_niw, idemix2_userdef_constants) + else + call idemix2_put('enable_niw', .true. , idemix2_userdef_constants) + end if + + !___ superbee_adv __________________________________________________________ + if (present(enable_superbee_adv)) then + call idemix2_put('enable_superbee_adv', enable_superbee_adv, idemix2_userdef_constants) + else + call idemix2_put('enable_superbee_adv', .true. , idemix2_userdef_constants) + end if + + !___ superbee_adv __________________________________________________________ + if (present(enable_AB_timestep)) then + call idemix2_put('enable_AB_timestep', enable_AB_timestep, idemix2_userdef_constants) + else + call idemix2_put('enable_AB_timestep', .true. , idemix2_userdef_constants) + end if + + !___ homogenous diffusion idemix1 functionality ____________________________ + if (present(enable_hor_diffusion)) then + call idemix2_put('enable_hor_diffusion', enable_hor_diffusion, idemix2_userdef_constants) + else + call idemix2_put('enable_hor_diffusion', .false. , idemix2_userdef_constants) + end if + + if (present(enable_hor_diff_iter)) then + call idemix2_put('enable_hor_diff_iter', enable_hor_diff_iter, idemix2_userdef_constants) + else + call idemix2_put('enable_hor_diff_iter', .false. , idemix2_userdef_constants) + end if + + if (present(hor_diff_niter)) then + call idemix2_put('hor_diff_niter', hor_diff_niter, idemix2_userdef_constants) + else + call idemix2_put('hor_diff_niter', 5 , idemix2_userdef_constants) + end if + + !___ handle_old_vals________________________________________________________ + if (present(handle_old_vals)) then + if(handle_old_vals.lt. 1 .or. handle_old_vals.gt. 3 ) then + print*, "ERROR:handle_old_vals can only be 1 to 3" + stop 1 + end if + call idemix2_put('handle_old_vals', handle_old_vals, idemix2_userdef_constants) + else + call idemix2_put('handle_old_vals', 1, idemix2_userdef_constants) + end if +end subroutine compute_init + + +! +! +!_______________________________________________________________________________ +! Compute idemix2 representative vertical (v0) and horizontal (c0) group velocites +! as well as the enery dissipation coefficient alpha_c +subroutine compute_param( & + nlev , & + coriolis , & + Nsqr , & + cn , & + alpha_c , & + c0 , & + v0 , & + idemix2_const_userdef & + ) + !___Input___________________________________________________________________ + type(idemix2_type), intent(in) , optional, target :: idemix2_const_userdef + integer , intent(in) :: nlev + real(cvmix_r8) , intent(in) :: coriolis , & + cn + + real(cvmix_r8) , intent(in) , dimension(nlev+1):: Nsqr + + !___Output__________________________________________________________________ + real(cvmix_r8) , intent(out), dimension(nlev) :: alpha_c , & + c0 , & + v0 + + !___Local___________________________________________________________________ + integer :: di + real(cvmix_r8) :: fxa, cstar !, intNz + type(idemix2_type), pointer :: idemix2_const_in + + ! do pointer into save variable or into user defined input variable + idemix2_const_in => idemix2_constants_saved + if (present(idemix2_const_userdef)) then + idemix2_const_in => idemix2_const_userdef + end if + + !___________________________________________________________________________ + ! calculate cstar from OE13 Eq. (13) --> vertical integrate sqrt(N²) --> which + ! is already in cn + ! --> cstar = max(1d-2,intNz/(cvmix_PI*idemix2_const_in%jstar) ) + cstar = max(1d-2,cn/(idemix2_const_in%jstar) ) + + !___________________________________________________________________________ + ! calculate vertical and horizontal representative group velocities c0 and v0 + ! c0: OE13 Eq. (13) + ! alpha_c iwe**2: dissipation of internal wave energy (OE13 Eq. (15)) + do di=1,nlev + fxa = sqrt(max(0d0,Nsqr(di))) / ( 1d-22 + abs(coriolis) ) + c0(di) = max(0d0, idemix2_const_in%gamma*cstar*gofx2(fxa)) + v0(di) = max(0d0, idemix2_const_in%gamma*cstar*hofx2(fxa)) + alpha_c(di) = max( 1d-4, idemix2_const_in%mu0*acosh(max(1d0,fxa))*abs(coriolis)/cstar**2 ) + + ! set v0 to zero to prevent horizontal iwe propagation in mixed layer + if ( fxa<1d0 ) then + v0(di) = 0d0 + endif + enddo + +end subroutine compute_param + + +! +! +!_______________________________________________________________________________ +! Compute idemix representative vertical (v0) and horizontal (c0) group velocites +! as well as the enery dissipation coefficient alpha_c +subroutine compute_compart_groupvel( & + nfbin , & + coriolis , & + coriol_grady , & + coslat , & + cn , & + cn_gradx , & + cn_grady , & + phit , & + phiu , & + omega_compart , & + u_compart , & + v_compart , & + w_compart , & + idemix2_const_userdef & + ) + + !___Input___________________________________________________________________ + type(idemix2_type), intent(in) , optional, target :: idemix2_const_userdef + integer , intent(in) :: nfbin + real(cvmix_r8) , intent(in) :: coriolis , & + coriol_grady , & + coslat , & + cn , & + cn_gradx , & + cn_grady , & + omega_compart + real(cvmix_r8) , intent(in) , dimension(nfbin) :: phit , & + phiu + !___Output__________________________________________________________________ + real(cvmix_r8) , intent(out), dimension(nfbin) :: u_compart , & + v_compart , & + w_compart + !___Local___________________________________________________________________ + integer :: di, fbin_i + real(cvmix_r8) :: fxa, fxa2, cstar, & + kdot_x, kdot_y, cg_compart + type(idemix2_type), pointer :: idemix2_const_in + + ! do pointer into save variable or into user defined input variable + idemix2_const_in => idemix2_constants_saved + if (present(idemix2_const_userdef)) then + idemix2_const_in => idemix2_const_userdef + end if + + !___________________________________________________________________________ + ! compute group velocity of M2 internal tidal waves + cg_compart=sqrt( max(0d0, omega_compart**2 - coriolis**2 ) ) * cn/omega_compart + + !___________________________________________________________________________ + ! eq4 in EdenOlbers2014: + ! + ! phi_dot = [c_n/omega/sqrt(omega²-f²)) * f * grad_f + ! + sqrt(omega²-f²)/omega * grad_cn ] * (sin(phi), -cos(phi)) + ! + ! phi_dot = (k_dot_x, kdot_y) * (sin(phi), cos(phi)) + ! + + ! compute wave vector component for the M2 internal tides: + ! kdot_M2 = (kdot_x_M2, kdot_y_M2) + + ! compute: sqrt(omega²-f²) + ! 1st term (Coriolis refraction, cn/fxa singular at f=omega): floor prevents 1/fxa divergence + fxa = sqrt(max(1d-10, omega_compart**2 - coriolis**2 )) + ! 2nd term (cn-gradient refraction, sqrt(fxa) non-singular): no floor, goes to zero naturally + fxa2 = sqrt(max(0d0, omega_compart**2 - coriolis**2 )) + + ! 1st part coriolis contribution + ! compute: c_n/omega/sqrt(omega²-f²)) * f * grad_f (uses fxa with floor) + ! 2nd part topographic/buoyancy driven contribution + ! compute: sqrt(omega²-f²)/omega * grad_cn (uses fxa2, physical zero at equator) + kdot_y = -cn/fxa/omega_compart * coriolis*coriol_grady & + -fxa2/omega_compart*cn_grady + ! | + ! +-> this minus sign is from the -cos(phi) + ! + + kdot_x = fxa2/omega_compart*cn_gradx + + !___________________________________________________________________________ + !zonal, meridional and cross-spectral component of M2 internal tide group velocity +! do fbin_i=2,nfbin-1 + do fbin_i=1, nfbin ! --> include ghost cells ofthe periodic boundary + u_compart(fbin_i) = cg_compart*cos( phit(fbin_i) ) + ! pyOM2 has v_M2 = cg*sin(phi)*cosu(j): the V-face zonal width on a lat-lon + ! grid is r*cos(lat_face)*dx, so the FV budget gives cosu/cost*dyt in the + ! denominator — this correctly implements the spherical divergence metric + ! term 1/(r*cos)*d(cos*v*E)/dlat = -v*tan(lat)/r * E (convergence of meridians). + ! In FESOM2 the FV scheme computes EUCLIDEAN divergence on the unstructured + ! mesh; multiplying v_compart by cos(lat) would NOT reproduce pyOM2's + ! correction (different denominator structure). The proper fix would be an + ! explicit source +cg*sin(phi)*tan(lat)/r * E per bin, but FESOM2 standard + ! tracer advection omits this metric term too — omitting it here is consistent. + v_compart(fbin_i) = cg_compart*sin( phit(fbin_i) ) + w_compart(fbin_i) = (kdot_y*cos(phiu(fbin_i)) + kdot_x*sin(phiu(fbin_i)) ) + end do + +end subroutine compute_compart_groupvel + + + +! +! +!_______________________________________________________________________________ +subroutine compute_compart_interact_tscale( & + dtime , & + lat , & + coriolis , & + cn , & + zbottom , & + topo_hrms , & + topo_hlam , & + topo_shelf , & + omega_compart , & + tau_compart , & + compart_name , & + idemix2_const_userdef & + ) + !___Input___________________________________________________________________ + type(idemix2_type), intent(in) , optional, target :: idemix2_const_userdef + real(cvmix_r8) , intent(in) :: dtime , & + lat , & + coriolis , & + omega_compart , & + cn , & + zbottom , & + topo_hrms , & + topo_hlam + logical , intent(in) :: topo_shelf + !___Output__________________________________________________________________ + real(cvmix_r8) , intent(out) :: tau_compart + character(len=*) , intent(in) :: compart_name + !___Local___________________________________________________________________ + real(cvmix_r8) :: fxb, fxc, N0, small=1.0e-12_cvmix_r8 + type(idemix2_type), pointer :: idemix2_const_in + + ! do pointer into save variable or into user defined input variable + idemix2_const_in => idemix2_constants_saved + if (present(idemix2_const_userdef)) then + idemix2_const_in => idemix2_const_userdef + end if + + !___________________________________________________________________________ + ! compute NIW Dissipation Timescale + tau_compart = 0.0_cvmix_r8 + if (zbottom>0) then + N0=cn*cvmix_PI/zbottom + if ( N0 > abs(coriolis) .and. omega_compart > abs(coriolis) ) then + + if (trim(compart_name)=='niw') then + ! fxc = topo_hrms**2.0 * 2.0*cvmix_PI/(small+topo_hlam) ! Goff & Arbic + fxc = topo_hrms**2.0 * 2.0*sqrt(2.6)/(small+topo_hlam) ! Goff for nu=0.8 FP 2020 + fxb = 0.5* N0*( (omega_compart**2.0 + coriolis**2.0)/omega_compart**2.0 )**2.0 & + *(omega_compart**2.0 - coriolis**2.0)**0.5/omega_compart + tau_compart = min(0.5/dtime, fxc*fxb/zbottom) + + elseif (trim(compart_name)=='M2') then + + if (topo_hrms>0.0) then + ! fxc = topo_hrms**2.0 * 2.0*cvmix_PI/(small+topo_hlam) ! Goff & Arbic + fxc = topo_hrms**2.0 * 2.0*sqrt(2.6)/(small+topo_hlam) ! Goff for nu=0.8 FP 2020 + fxb = 0.5* N0*( (omega_compart**2.0 + coriolis**2.0)/omega_compart**2.0 )**2.0 & + *(omega_compart**2.0 - coriolis**2.0)**0.5/omega_compart + tau_compart = min(0.5/dtime, fxc*fxb/zbottom) + else + tau_compart = 1.0/(idemix2_const_in%tau_M2_oce*86400.0_cvmix_r8) + end if + end if + endif + endif + + ! on shelf limitation + if (topo_shelf) then + if (trim(compart_name)=='niw') tau_compart = 1.0/(idemix2_const_in%tau_niw_shelf*86400.0_cvmix_r8) + if (trim(compart_name)=='M2' ) tau_compart = 1.0/(idemix2_const_in%tau_M2_shelf *86400.0_cvmix_r8) + end if + if (trim(compart_name)=='niw') then + tau_compart = max(1.0/(idemix2_const_in%tau_niw_oce*86400.0_cvmix_r8), tau_compart) + else if (trim(compart_name)=='M2') then + tau_compart = max(1.0/(idemix2_const_in%tau_M2_oce *86400.0_cvmix_r8), tau_compart) + end if +end subroutine compute_compart_interact_tscale + + +! +! +!_______________________________________________________________________________ +subroutine compute_M2_dissipation( & + lat , & + cn , & + zbottom , & + alpha_M2_c , & + idemix2_const_userdef & + ) + !___Input___________________________________________________________________ + type(idemix2_type), intent(in) , optional, target :: idemix2_const_userdef + real(cvmix_r8) , intent(in) :: lat , & + cn , & + zbottom + + !___Output__________________________________________________________________ + real(cvmix_r8) , intent(out) :: alpha_M2_c + !___Local___________________________________________________________________ + real(cvmix_r8) :: N0, xalpha1, xalpha2 + real(cvmix_r8) :: mstar=0.01 ,& + M2_f=2*cvmix_PI/(12.42*60*60) + type(idemix2_type), pointer :: idemix2_const_in + + ! do pointer into save variable or into user defined input variable + idemix2_const_in => idemix2_constants_saved + if (present(idemix2_const_userdef)) then + idemix2_const_in => idemix2_const_userdef + end if + + ! compute alpha_M2_c M2 Continuous Dissipation Rate (Background M2 tidal + ! dissipation rate (not topographic)) + alpha_M2_c = 0.0 + if (zbottom > 0.) then + N0 = cn*cvmix_PI/zbottom+1D-20 +! if (abs(lat) < 28.5 ) then +! ! lambda+/M2=15*E*mstar/N * (sin(phi-28.5)/sin(28.5))^1/2 +! alpha_M2_c=alpha_M2_c+ M2_f*15*mstar/N0* (sin( abs(abs(lat) -28.5)/180.*cvmix_PI )/sin(28.5/180.*cvmix_PI) )**0.5 +! endif +! if (abs(lat) < 74.5 ) then +! ! lambda-/M2 = 0.7*E*mstar/N *sin^2(phi) +! alpha_M2_c=alpha_M2_c+ M2_f*0.7*mstar/N0* sin( abs(lat)/180.*cvmix_PI )**2 +! endif + ! sum interaction !FP 2020 + if (abs(lat) < 28.5 ) then + if(lat < 0.) then + xalpha1 = 13.0076 + xalpha2 = 3.1617*1d-6 + else + xalpha1 = 13.1923 + xalpha2 = 3.4391*1d-6 + endif + alpha_M2_c = alpha_M2_c + xalpha2*10.0**(abs(lat)/xalpha1) + endif + + ! difference interaction !FP 2020 + if (abs(lat) < 74.5 ) then + if(lat < 0.) then + xalpha1 = -2.8223 + xalpha2 = 1.4875*1d-4 + else + xalpha1 = -6.6848 + xalpha2 = 1.8207*1d-4 + endif + alpha_M2_c = alpha_M2_c + xalpha2*(sin((2.*lat+xalpha1)*cvmix_PI/180.)/sin(74.5*cvmix_PI/180.))**2. + endif + alpha_M2_c=alpha_M2_c/zbottom + endif + + ! ensure background value + alpha_M2_c = max(0D0, min( 1d-5,alpha_M2_c )) + +end subroutine compute_M2_dissipation + + +! +! +!_______________________________________________________________________________ +! Calculates the vertical structure functions for internal wave modes in the +! IDEMIX model. These functions describe how wave energy is distributed vertically +! in the ocean. +! +! Key Variables: +! phin: Vertical structure function φₙ(z) - the modal function itself +! phinz: Vertical derivative dφₙ/dz - the gradient of the modal function +! E_struct_M2: Energy structure function for M2 tides +! E_struct_niw: Energy structure function for near-inertial waves +subroutine compute_vert_struct_fct( & + nlev , & + dzw , & + coriolis , & + cn , & + Nsqr , & + omega_M2 , & + omega_niw , & + E_struct_M2 , & + E_struct_niw , & + idemix2_const_userdef & + ) + !___Input___________________________________________________________________ + type(idemix2_type), intent(in) , optional, target :: idemix2_const_userdef + integer , intent(in) :: nlev + real(cvmix_r8) , intent(in) :: dzw(:) + real(cvmix_r8) , intent(in) :: coriolis, cn + real(cvmix_r8) , intent(in) :: Nsqr(:) + real(cvmix_r8) , intent(in), optional :: omega_M2, omega_niw + + !___Output__________________________________________________________________ + real(cvmix_r8) , intent(inout), optional :: E_struct_M2(:), E_struct_niw(:) + + !___Local___________________________________________________________________ + integer :: di + real(cvmix_r8) :: fxa, norm, phin_dim1, small=1.0e-12_cvmix_r8, mask + real(cvmix_r8), dimension(:) :: Nzw(nlev), phin(nlev), dphindz(nlev), dzt(nlev) + type(idemix2_type), pointer :: idemix2_const_in + + ! do pointer into save variable or into user defined input variable + idemix2_const_in => idemix2_constants_saved + if (present(idemix2_const_userdef)) then + idemix2_const_in => idemix2_const_userdef + end if + + !___________________________________________________________________________ + ! calculate int_(-h)^z N dz + phin(:) = 0.0_cvmix_r8 + Nzw(1) = max(small, Nsqr(1)) + dzt(1) = dzw(1) * 0.5_cvmix_r8 + phin(1) = sqrt(Nzw(1))*dzt(1) + phin_dim1 = phin(1) + fxa = phin(1)/(small+cn) + dphindz(1) = sin(fxa)/Nzw(1)**0.25_cvmix_r8 + phin(1) = cos(fxa)*Nzw(1)**0.25_cvmix_r8 + + do di = 2, nlev-1 + ! interpolate N² onto tracer levels and cumulative integrate + Nzw(di) = max(small, Nsqr(di)) + dzt(di) = (dzw(di-1)+dzw(di)) * 0.5_cvmix_r8 + + ! calculate int_(-h)^z N dz + phin(di) = phin_dim1 + sqrt(Nzw(di))*dzt(di) + phin_dim1 = phin(di) + + ! calculate phi_n = cos( int_(-h)^z N/c_n dz )*N^0.5 + ! and dphi_n/dz = sin( int_(-h)^z N/c_n dz )/N^0.5 + fxa = phin(di)/(small+cn) + dphindz(di) = sin(fxa)/Nzw(di)**0.25_cvmix_r8 + phin(di) = cos(fxa)*Nzw(di)**0.25_cvmix_r8 + enddo + + di = nlev + ! interpolate N² onto tracer levels and cumulative integrate + Nzw(di) = max(small, Nsqr(di)) + dzt(di) = dzw(di-1) * 0.5_cvmix_r8 + phin(di) = phin_dim1 + sqrt(Nzw(di))*dzt(di) + fxa = phin(di)/(small+cn) + dphindz(di) = sin(fxa)/Nzw(di)**0.25_cvmix_r8 + phin(di) = cos(fxa)*Nzw(di)**0.25_cvmix_r8 + + + ! normalisation with int_(-h)^0 dz (dphi_n/dz )^2 /N^2 = 1 + norm = 0.0_cvmix_r8 + do di = 1,nlev + norm = norm + dphindz(di)**2/Nzw(di)*dzt(di) + enddo + do di = 1,nlev + if (norm>0.0_cvmix_r8) dphindz(di) = dphindz(di)/norm**0.5 + enddo + + ! normalisation with int_(-h)^0 dz phi_n^2 /c_n^2 = 1 + norm=0.0_cvmix_r8 + do di = 1,nlev + norm = norm + phin(di)**2/(small+cn**2)*dzt(di) + enddo + do di = 1,nlev + if (norm>0.0_cvmix_r8) phin(di) = phin(di)/norm**0.5 + enddo + + if (present(E_struct_M2)) then + ! ATTENTION (this is not part of pyOM2): + ! M2 internal waves can only propagate where their frequency + ! (ω_M2 ≈ 1.405×10⁻⁴ s⁻¹) exceeds the local Coriolis parameter (f = 2Ω sin φ). + ! (Poleward of the critical latitude (~74.5°), where |f| > ω_M2, the dispersion + ! (relation becomes invalid and the vertical structure function E_struct_M2 turns + ! (negative—physically meaningless for wave energy. The condition + ! (abs(coriolis_t) < omega_M2 ensures M2 energy is only computed in regions where + ! (these waves can exist as propagating solutions. Without this check, high-latitude + ! (grid points produce unphysical negative energies that contaminate the solution and + ! (violate energy conservation principles + if ( abs(coriolis) < omega_M2 ) then + mask = 1.0_cvmix_r8 + else + mask = 0.0_cvmix_r8 + end if + + ! calculate structure function for energy: + ! E(z) = E_0 0.5( (1+f^2/om^2) phi_n^2/c_n^2 + (1-f^2/om^2) (dphi_n/dz)^2/N^2) + do di = 1,nlev + E_struct_M2(di) = mask * 0.5_cvmix_r8*( (1.0_cvmix_r8+coriolis**2/omega_M2**2)*phin( di)**2 /(small+cn**2) & + +(1.0_cvmix_r8-coriolis**2/omega_M2**2)*dphindz(di)**2 /Nzw(di) ) + +! if (E_struct_M2(di)/=E_struct_M2(di) .or. E_struct_M2(di)<0.0_cvmix_r8) then +! write(*,*) " }-))))°> found negative/NaN E_struct_M2", E_struct_M2(di) +! write(*,*) "di = ", di +! write(*,*) "mask = ", mask +! write(*,*) "coriolis = ", coriolis +! write(*,*) "omega_M2 = ", omega_M2 +! write(*,*) "phin( di) = ", phin( di) +! write(*,*) "dphindz(di) = ", dphindz(di) +! write(*,*) "Nzw(di) = ", Nzw(di) +! write(*,*) "cn = ", cn +! write(*,*) "coriolis**2/omega_M2**2 = ", coriolis**2/omega_M2**2 +! write(*,*) "(1.0_cvmix_r8+coriolis**2/omega_M2**2) = ", (1.0_cvmix_r8+coriolis**2/omega_M2**2) +! write(*,*) "(1.0_cvmix_r8-coriolis**2/omega_M2**2) = ", (1.0_cvmix_r8-coriolis**2/omega_M2**2) +! end if + + enddo + endif + + if (present(E_struct_niw)) then + ! ATTENTION (this is not part of pyOM2): + ! here its a safety switch in theory it should be imposed by definition that + ! abs(coriolis) < omega_niw + if ( abs(coriolis) < omega_niw ) then + mask = 1.0_cvmix_r8 + else + mask = 0.0_cvmix_r8 + end if + + ! calculate structure function for energy: + ! E(z) = E_0 0.5( (1+f^2/om^2) phi_n^2/c_n^2 + (1-f^2/om^2) (dphi_n/dz)^2/N^2) + do di = 1,nlev + E_struct_niw(di) = mask * 0.5_cvmix_r8*( (1.0_cvmix_r8+coriolis**2/(small+omega_niw**2))*phin( di)**2/(small+cn**2) & + +(1.0_cvmix_r8-coriolis**2/(small+omega_niw**2))*dphindz(di)**2/Nzw(di) ) + +! if (E_struct_niw(di)/=E_struct_niw(di) .or. E_struct_niw(di)<0.0_cvmix_r8) then +! write(*,*) " }-))))°> found negative/NaN E_struct_niw", E_struct_niw(di) +! write(*,*) "di = ", di +! write(*,*) "mask = ", mask +! write(*,*) "coriolis = ", coriolis +! write(*,*) "omega_niw = ", omega_niw +! write(*,*) "phin( di) = ", phin( di) +! write(*,*) "dphindz(di) = ", dphindz(di) +! write(*,*) "Nzw(di) = ", Nzw(di) +! write(*,*) "cn = ", cn +! write(*,*) "(1.0_cvmix_r8+coriolis**2/omega_M2**2) = ", (1.0_cvmix_r8+coriolis**2/omega_M2**2) +! write(*,*) "(1.0_cvmix_r8-coriolis**2/omega_M2**2) = ", (1.0_cvmix_r8-coriolis**2/omega_M2**2) +! end if + enddo + endif + +end subroutine compute_vert_struct_fct + + +! +! +!_______________________________________________________________________________ +! Integrate vertical part of internal wave energy idemix equation, solve vertical +! diffusion an dissipation implicitly over the water column. Keep in mind Eiw lives +! on the full depth levels +subroutine compute_vdiff_vdiss_Eiw( & + nlev , & + dzw , & + dt , & + c0 , & + alpha_c , & + fsrf , & + fbot , & + Eiw_maxthresh , & + Eiw_old , & + Eiw_new , & + Eiw_diss , & + Eiw_dt , & + Eiw_vdif , & + Eiw_srf , & + Eiw_bot , & + idemix2_const_userdef & + ) + !___Input___________________________________________________________________ + type(idemix2_type), intent(in) , optional, target :: idemix2_const_userdef + integer , intent(in) :: nlev ! --> number of full depth levels + real(cvmix_r8) , intent(in), dimension(nlev-1) :: dzw ! --> layer thickness + real(cvmix_r8) , intent(in) :: dt + real(cvmix_r8) , intent(in), dimension(nlev) :: c0 + real(cvmix_r8) , intent(in), dimension(nlev) :: alpha_c + real(cvmix_r8) , intent(in) :: fsrf + real(cvmix_r8) , intent(in), dimension(nlev) :: fbot +! real(cvmix_r8) , intent(in), dimension(nlev) :: fadd --> in moment no additional forcings + real(cvmix_r8) , intent(in) :: Eiw_maxthresh + real(cvmix_r8) , intent(in), dimension(nlev) :: Eiw_old + + !___Output__________________________________________________________________ + real(cvmix_r8) , intent(out), dimension(nlev) :: Eiw_new + real(cvmix_r8) , intent(out), dimension(nlev) :: Eiw_diss + + real(cvmix_r8) , intent(out), optional :: Eiw_dt(nlev) + real(cvmix_r8) , intent(out), optional :: Eiw_vdif(nlev) + real(cvmix_r8) , intent(out), optional :: Eiw_bot(nlev) + real(cvmix_r8) , intent(out), optional :: Eiw_srf + !___Local___________________________________________________________________ + integer :: nz + real(cvmix_r8), dimension(nlev) :: Eiw_max + real(cvmix_r8), dimension(nlev) :: fadd + real(cvmix_r8), dimension(nlev-1) :: c0_zmid + real(cvmix_r8), dimension(nlev) :: dzmid + real(cvmix_r8), dimension(nlev) :: a_dif, b_dif, c_dif + real(cvmix_r8), dimension(nlev) :: a_tri, b_tri, c_tri, d_tri + type(idemix2_type), pointer :: idemix2_const_in + + ! do pointer into save variable or into user defined input variable + idemix2_const_in => idemix2_constants_saved + if (present(idemix2_const_userdef)) then + idemix2_const_in => idemix2_const_userdef + end if + !___________________________________________________________________________ + a_dif = 0.0_cvmix_r8 + b_dif = 0.0_cvmix_r8 + c_dif = 0.0_cvmix_r8 + a_tri = 0.0_cvmix_r8 + b_tri = 0.0_cvmix_r8 + c_tri = 0.0_cvmix_r8 + d_tri = 0.0_cvmix_r8 + Eiw_new = 0.0_cvmix_r8 + Eiw_diss = 0.0_cvmix_r8 + + !___________________________________________________________________________ + ! initialise additional forcings with zeros, there can be additional forcing terms + ! from EKE, GM disspation, lateral friction, cabbeling heat, bottom friction + ! This is not yet implemented + fadd(:) = 0.0_cvmix_r8 + + !___________________________________________________________________________ + ! prevent negative dissipation of IW energy, might not be neccessary but + ! safety first + Eiw_max = max(0.0_cvmix_r8, Eiw_old) + + !___________________________________________________________________________ + ! Solve vertical part implicitly, having Eiw on mid-depth levels like tracer + ! for easier advection + ! + ! dEiw/dt = d/dz(c0*tau_v * d/dz(c0*Eiw)) - alpha_c*Eiw + forcing + ! |___________________________| | + ! vertical diffusion of E_iw dissipation + ! + ! ~~~~~~~o zlev=1~~~~~~~ + ! | + ! zmid=1 + --> k-0.5 + ! | + ! o 2 --> k --> Eiw_k, c0_k + ! | + ! 2 + --> k+0.5 + ! | + ! -------o 3----------- + ! ///////////////////// + ! c0_k-0.5 = (c0_k+c0_k-1) / 2 + ! c0_k+0.5 = (c0_k+c0_k+1) / 2 + ! + ! d/dz(c0*Eiw)_k = (c0_k*Eiw_k - c0_k-1*Eiw_k-1)/h(k-1) = dcE_k-0.5--> defined on middepth levels + ! d/dz(c0* dcE_k-0.5) = (c0_k+0.5*dcE_k+0.5 - c0_k-0.5*dcE_k-0.5) * 2 / (h_k+ h_k-1) + ! + ! Discrite Form: + ! -------------- + ! Eiw^(t+1) - Eiw^(t) = dz* [d/dz(c0*tau_v * d/dz(c0*Eiw)) - alpha_c*Eiw]^(t+1) + forcing^(t) + ! Eiw^(t+1)_k = Eiw^(t)_k + ! + dt * forcing^(t)_k + ! - dt * alpha_c * Eiw^(t+1)_k + ! - tau_v * [ c0_k+0.5 * (c0_k+1*Eiw_k+1 - c0_k *Eiw_k ) * 2 / h_k / (h_k+h_k-1)] + ! -c0_k-0.5 * (c0_k *Eiw_k - c0_k-1*Eiw_k-1) * 2 / h_k-1 / (h_k+h_k-1)] + ! Rearange for Tridiagonal: + ! ------------------------- + ! a_k * Eiw^(t+1)_k-1 + b_k * Eiw^(t+1)_k + c_k * Eiw^(t+1) = d_k + ! + ! Estimate coefficents a,b,c: + ! --------------------------- + ! 1) a_k --> (k-1, t+1): + ! - dt * 2 / (h_k-1*(h_k+h_k-1)) * c0_(k-0.5)*c0_k-1*Eiw^(t+1)_k-1 = a_k * Eiw^(t+1)_k-1 + ! + ! 2) b_k --> (k , t+1): + ! Eiw^(t+1)_k + ! + dt*2/(h_k *(h_k+h_k-1))*c0_(k+0.5)*c0_k*Eiw^(t+1)_k + ! + dt*2/(h_k-1*(h_k+h_k-1))*c0_(k-0.5)*c0_k*Eiw^(t+1)_k + ! + dt*alpha_c*Eiw^(t+1)_k + ! = b_k * Eiw^(t+1)_k + ! + ! 3) c_k --> (k+1 , t+1): + ! - dt * 2 / (h_k*(h_k+h_k-1)) * c0_(k+0.5)*c0_k+1*Eiw^(t+1)_k+1 = c_k * Eiw^(t+1)_k+1 + ! + ! 4) d_k --> (k , t ): + ! Eiw^t_k + dt* Forc^t_k = d_k + ! + ! Solve tridiagonal matrix: + ! ------------------------- + ! | b_1 c_1 0 0 0 | (Eiw_1) = (d_1) + ! | a_2 b_2 c_2 0 0 | (Eiw_2) = (d_2) + ! | 0 a_3 b_3 c_3 0 | (Eiw_3) = (d_3) + ! | 0 0 a_4 b_4 c_4 | (Eiw_4) = (d_4) + ! | 0 0 0 a_k b_k | (Eiw_k) = (d_k) + ! + !___________________________________________________________________________ + nz = 1 + dzmid(nz) = dzw(nz)*0.5_cvmix_r8 + + do nz = 2, nlev-1 + c0_zmid(nz-1) = idemix2_const_in%tau_v * (c0(nz)+c0(nz-1))*0.5_cvmix_r8 / dzw(nz-1) + dzmid(nz) = (dzw(nz) + dzw(nz-1))*0.5_cvmix_r8 + end do + + nz=nlev + dzmid(nz) = dzw(nz-1)*0.5_cvmix_r8 + c0_zmid(nz-1) = idemix2_const_in%tau_v * (c0(nz)+c0(nz-1))*0.5_cvmix_r8 / dzw(nz-1) + + !___________________________________________________________________________ + ! -- a -- + a_dif(1) = 0.0_cvmix_r8 ! not part of the diffusion matrix, thus value is arbitrary + do nz=2,nlev + a_dif(nz) = c0_zmid(nz-1)*c0(nz-1) / dzmid(nz) + end do + + ! -- b -- + nz = 1 + b_dif(nz) = c0_zmid(nz )*c0(nz) / dzmid(nz) + do nz=2,nlev-1 + b_dif(nz) = (c0_zmid(nz-1)*c0(nz)+c0_zmid(nz)*c0(nz)) / dzmid(nz) + end do + nz = nlev + b_dif(nz) = c0_zmid(nz-1)*c0(nz) / dzmid(nz) + + ! -- c-- + do nz=1,nlev-1 + c_dif(nz) = c0_zmid(nz)*c0(nz+1) / dzmid(nz) + end do + c_dif(nlev) = 0.0_cvmix_r8 + + !___________________________________________________________________________ + ! prepare tridiagonal matrix elements: a,b,c,d + ! alpha_c dissipation is applied only at interior levels (2:nlev-1). + ! Boundary levels (nz=1 surface, nz=nlev bottom) are excluded, consistent + ! with IDEMIX1 (iwe_Tdis(2:nlev)), to avoid feeding Kv/TKE at W-grid + ! boundary cells where forcing BCs already control tracer fluxes. + nz = 1 + a_tri(nz) = -dt * a_dif(nz) + b_tri(nz) = 1.0_cvmix_r8 & + + dt * b_dif(nz) + c_tri(nz) = -dt * c_dif(nz) + + do nz=2,nlev-1 + a_tri(nz) = -dt * a_dif(nz) + b_tri(nz) = 1.0_cvmix_r8 & + + dt * b_dif(nz) & + + dt * alpha_c(nz)*Eiw_max(nz) + c_tri(nz) = -dt * c_dif(nz) + end do + + nz = nlev + a_tri(nz) = -dt * a_dif(nz) + b_tri(nz) = 1.0_cvmix_r8 & + + dt * b_dif(nz) + c_tri(nz) = -dt * c_dif(nz) + + ! -- d --- + do nz=1,nlev + ! --> fbot(nz) must be here an array overf depth since we want this + ! in FESOM2 to operate on nodes, but our bottom topography is on elements + ! so bottom forcing is injected over the water column where elements + ! that participate to the scalar control volume turn into bottom over the + ! vertical depth + d_tri(nz) = Eiw_old(nz) + dt*fadd(nz) + dt*fbot(nz)/dzmid(nz) + + end do + d_tri(1) = d_tri(1) + dt*fsrf/dzmid(1) + + !___________________________________________________________________________ + ! solve tridiagonal matrix + call solve_tridiag(a_tri, b_tri, c_tri, d_tri, Eiw_new, nlev) + + !___________________________________________________________________________ + ! build in some upper lower Eiw bounds + Eiw_new = max(0.0_cvmix_r8, min(Eiw_maxthresh, Eiw_new)) +! do nz=1,nlev +! ! if (any(Eiw_new<0.0_cvmix_r8)) then +! if (Eiw_new(nz)/=Eiw_new(nz) .or. Eiw_new(nz)<0.0_cvmix_r8) then +! write(*,*) " }-))))°> found negative/NaN Eiw_new in vdiff", Eiw_new(nz) +! write(*,*) " Eiw_old(nz)=", Eiw_old(nz) +! write(*,*) " fsrf =", fsrf +! write(*,*) " fbot(nz) =", fbot(nz) +! write(*,*) " alpha_c(nz)=", alpha_c(nz) +! write(*,*) " Eiw_max(nz)=", Eiw_max(nz) +! end if +! end do + + !___________________________________________________________________________ + ! dissipation of E_iw + Eiw_diss(2:nlev-1) = -alpha_c(2:nlev-1)*Eiw_max(2:nlev-1)*Eiw_new(2:nlev-1) + + !___________________________________________________________________________ + ! debuggin diagnostics: + + ! production of Eiw from vertical diffusion + if (present(Eiw_vdif)) then + nz = 1 + Eiw_vdif(nz) = - b_dif(nz)*Eiw_new(nz) + c_dif(nz)*Eiw_new(nz+1) + do nz=2,nlev-1 + Eiw_vdif(nz) = a_dif(nz)*Eiw_new(nz-1) - b_dif(nz)*Eiw_new(nz) + c_dif(nz)*Eiw_new(nz+1) + enddo + nz = nlev + Eiw_vdif(nz) = a_dif(nz)*Eiw_new(nz-1) - b_dif(nz)*Eiw_new(nz) + end if + + ! total production of Eiw + if (present(Eiw_dt )) Eiw_dt(:) = (Eiw_new(:) - Eiw_old(:))/dt + + ! surface production term + if (present(Eiw_srf)) Eiw_srf = fsrf/dzmid(1) + + ! bottom production term + if (present(Eiw_bot)) Eiw_bot(:)= fbot(:)/dzmid(:) + +end subroutine compute_vdiff_vdiss_Eiw + + +! +! +!_______________________________________________________________________________ +! Integrate vertical part of internal wave energy idemix equation, solve vertical +! diffusion an dissipation implicitly over the water column. Keep in mind Eiw lives +! on the full depth levels +subroutine compute_Eiw_waveinteract( & + nlev & + , nfbin & + , dzw & + , dphi & + , dt & + , flag_posdef & + , E_iw_old & + , E_iw_new & + , E_M2_old & + , E_M2_new & + , E_M2_struct & + , alpha_M2_c & + , tau_M2 & + , E_niw_old & + , E_niw_new & + , E_niw_struct & + , tau_niw & + , idemix2_const_userdef & + , E_iw_dt & + , E_iw_diss_M2 & + , E_iw_diss_niw & + , E_M2_dt & + , E_M2_diss_wwi & + ) + !___Input/Output____________________________________________________________ + type(idemix2_type), intent(in ), optional, target :: idemix2_const_userdef + integer , intent(in ) :: nlev ! --> number of full depth levels + integer , intent(in ) :: nfbin ! --> of spectral bins + real(cvmix_r8) , intent(in ) :: dzw(nlev-1) ! --> layer thickness + real(cvmix_r8) , intent(in ) :: dphi(nfbin) + real(cvmix_r8) , intent(in ) :: dt + logical , intent(in ) :: flag_posdef + real(cvmix_r8) , intent(in ) :: E_iw_old(nlev) + real(cvmix_r8) , intent(inout) :: E_iw_new(nlev) + real(cvmix_r8) , intent(in ), optional :: E_M2_old(nfbin) + real(cvmix_r8) , intent(inout), optional :: E_M2_new(nfbin) + real(cvmix_r8) , intent(in ), optional :: E_M2_struct(nlev) + real(cvmix_r8) , intent(in ), optional :: alpha_M2_c + real(cvmix_r8) , intent(in ), optional :: tau_M2 + real(cvmix_r8) , intent(in ), optional :: E_niw_old(nfbin) + real(cvmix_r8) , intent(inout), optional :: E_niw_new(nfbin) + real(cvmix_r8) , intent(in ), optional :: E_niw_struct(nlev) + real(cvmix_r8) , intent(in ), optional :: tau_niw + + ! optional diagnostics + real(cvmix_r8) , intent(inout), optional :: E_iw_dt(nlev) + real(cvmix_r8) , intent(inout), optional :: E_iw_diss_M2(nlev) + real(cvmix_r8) , intent(inout), optional :: E_iw_diss_niw(nlev) + real(cvmix_r8) , intent(inout), optional :: E_M2_dt(nfbin) + real(cvmix_r8) , intent(inout), optional :: E_M2_diss_wwi(nfbin) + + !___Local___________________________________________________________________ + integer :: nz, fbini + real(cvmix_r8) :: vint, sint, aM2c, fmin, small=1.0e-12_cvmix_r8 + real(cvmix_r8), dimension(:) :: M2_diss(nfbin), IW_diss(nlev) + type(idemix2_type), pointer :: idemix2_const_in + + ! do pointer into save variable or into user defined input variable + idemix2_const_in => idemix2_constants_saved + if (present(idemix2_const_userdef)) then + idemix2_const_in => idemix2_const_userdef + end if + + !___________________________________________________________________________ + ! vertical integrate E_iw --> compute dzt from dzw + vint = 0.0_cvmix_r8 + nz = 1 + vint = vint + E_iw_old(nz)*dzw(nz)*0.5_cvmix_r8 + do nz = 2, nlev-1 + vint = vint + E_iw_old(nz)*(dzw(nz)+dzw(nz-1))*0.5_cvmix_r8 + end do + nz = nlev + vint = vint + E_iw_old(nz)*dzw(nz-1)*0.5_cvmix_r8 + + !___________________________________________________________________________ + if (present(E_M2_old)) then + ! spectrally integrate E_M2 + sint = 0.0_cvmix_r8 + do fbini = 2, nfbin-1 + sint = sint + E_M2_old(fbini)*dphi(fbini) + end do + + ! initialise M2 WWI dissipation + M2_diss = 0.0_cvmix_r8 + + ! update M2 energy: interaction of M2 and continuum + aM2c = alpha_M2_c + aM2c = max(0.0_cvmix_r8,min(aM2c,1./max(small,dt*vint))) ! FP 2020 + aM2c = max(0.0_cvmix_r8,min(aM2c,1./max(small,dt*sint))) + + do fbini = 2, nfbin-1 + M2_diss(fbini) = aM2c*vint*E_M2_old(fbini) + M2_diss(fbini) = min(M2_diss(fbini), E_M2_new(fbini)/max(small,dt)) + E_M2_new(fbini) = E_M2_new(fbini)-dt*M2_diss(fbini) + E_M2_new(fbini) = merge(max(0.0_cvmix_r8, E_M2_new(fbini)), E_M2_new(fbini), flag_posdef) + end do + + ! optional M2 WWI diagnostic + if (present(E_M2_dt)) E_M2_dt(:) = E_M2_dt(:) - M2_diss(:) + if (present(E_M2_diss_wwi)) E_M2_diss_wwi(:) = -M2_diss(:) + + ! update E_iw from E_M2 through wave-wave-interaction + IW_diss(:) = 0.0_cvmix_r8 + do nz = 1, nlev + fmin = min( 0.5_cvmix_r8/dt,aM2c*vint ) ! flux limiter + IW_diss(nz) = dt * tau_M2* sint * E_M2_struct(nz) & + + dt * fmin * sint * E_M2_struct(nz) + E_iw_new(nz) = E_iw_new(nz) + IW_diss(nz) + E_iw_new(nz) = merge(max(0.0_cvmix_r8, E_iw_new(nz)), E_iw_new(nz), flag_posdef) + end do + + ! optional E_iw diagnostic + if (present(E_iw_dt)) E_iw_dt = E_iw_dt + IW_diss/dt + if (present(E_iw_diss_M2)) E_iw_diss_M2 = IW_diss/dt + + end if + + !___________________________________________________________________________ + if (present(E_niw_old)) then + ! spectrally integrate E_niw + sint = 0.0_cvmix_r8 + do fbini = 2, nfbin-1 + sint = sint + E_niw_old(fbini)*dphi(fbini) + end do + + ! update E_iw from E_niw through wave-wave-interaction + IW_diss(:) = 0.0_cvmix_r8 + do nz = 1, nlev + IW_diss(nz) = dt * tau_niw * sint * E_niw_struct(nz) + E_iw_new(nz) = E_iw_new(nz) + IW_diss(nz) + E_iw_new(nz) = merge(max(0.0_cvmix_r8, E_iw_new(nz)), E_iw_new(nz), flag_posdef) + end do + + ! optional E_iw diagnostic + if (present(E_iw_dt)) E_iw_dt = E_iw_dt + IW_diss/dt + if (present(E_iw_diss_niw)) E_iw_diss_niw = IW_diss/dt + + end if +end subroutine compute_Eiw_waveinteract + + + +! +! +!_______________________________________________________________________________ +! IDEMIX2 only shortcut: derive diffusivity and viscosity using Osbourne relation +subroutine compute_Eiw_diss2KvAv(nlev, Eiw_diss, Nsqr, KappaH, KappaM) + !___Input/Output____________________________________________________________ + integer , intent(in ) :: nlev ! --> number of full depth levels + real(cvmix_r8) , intent(in ) :: Eiw_diss(nlev) ! --> layer thickness + real(cvmix_r8) , intent(in ) :: Nsqr( nlev) + real(cvmix_r8) , intent(inout) :: KappaH( nlev) + real(cvmix_r8) , intent(inout) :: KappaM( nlev) + + !___Local___________________________________________________________________ + integer :: nz + + KappaH = 0.0_cvmix_r8 + KappaM = 0.0_cvmix_r8 + do nz = 2, nlev-1 + KappaH(nz) = 0.2_cvmix_r8/(1.0_cvmix_r8+0.2_cvmix_r8) * (-1.0_cvmix_r8 * Eiw_diss(nz)) / max(1.0e-12_cvmix_r8, Nsqr(nz)) + KappaH(nz) = max(1.0e-9_cvmix_r8, KappaH(nz)) + KappaH(nz) = min(1.0_cvmix_r8, KappaH(nz)) + KappaM(nz) = 10.0_cvmix_r8 * KappaH(nz) + end do +end subroutine compute_Eiw_diss2KvAv + + +! +! +!_______________________________________________________________________________ +subroutine vmix_tke_put_idemix2_real(varname, val, idemix2_userdef_constants) + ! This subroutine puts real values to IDEMIX variables + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + type(idemix2_type), intent(inout), target, optional:: idemix2_userdef_constants + type(idemix2_type), pointer :: idemix2_constants_out + ! do pointer into save variable + idemix2_constants_out=>idemix2_constants_saved + ! if input idemix_userdef_constants present do pointer into this + if (present(idemix2_userdef_constants)) idemix2_constants_out=> idemix2_userdef_constants + select case(trim(varname)) + case('tau_v' ) ; idemix2_constants_out%tau_v = val + case('tau_h' ) ; idemix2_constants_out%tau_h = val + case('jstar' ) ; idemix2_constants_out%jstar = val + case('gamma' ) ; idemix2_constants_out%gamma = val + case('mu0' ) ; idemix2_constants_out%mu0 = val + case('shelf_dist' ) ; idemix2_constants_out%shelf_dist = val + case('tau_niw_shelf') ; idemix2_constants_out%tau_niw_shelf = val + case('tau_niw_oce' ) ; idemix2_constants_out%tau_niw_oce = val + case('tau_M2_shelf' ) ; idemix2_constants_out%tau_M2_shelf = val + case('tau_M2_oce' ) ; idemix2_constants_out%tau_M2_oce = val + case DEFAULT + print*, "ERROR:", trim(varname), " not a valid choice" + stop 1 + end select +end subroutine vmix_tke_put_idemix2_real + +subroutine vmix_tke_put_idemix2_int(varname,val,idemix2_userdef_constants) + ! This subroutine puts integer values to IDEMIX variables + character(len=*), intent(in) :: varname + integer, intent(in) :: val + type(idemix2_type), intent(inout), target, optional:: idemix2_userdef_constants + type(idemix2_type), pointer :: idemix2_constants_out + idemix2_constants_out=>idemix2_constants_saved + if (present(idemix2_userdef_constants)) idemix2_constants_out=> idemix2_userdef_constants + select case(trim(varname)) + case('handle_old_vals' ) ; idemix2_constants_out%handle_old_vals = val + case('nfbin' ) ; idemix2_constants_out%nfbin = val + case('hor_diff_niter' ) ; idemix2_constants_out%hor_diff_niter= val + case DEFAULT + print*, "ERROR:", trim(varname), " not a valid choice" + stop 1 + end select +end subroutine vmix_tke_put_idemix2_int + +subroutine vmix_tke_put_idemix2_bool(varname,val,idemix2_userdef_constants) + ! This subroutine puts integer values to IDEMIX variables + character(len=*), intent(in) :: varname + logical, intent(in) :: val + type(idemix2_type), intent(inout), target, optional:: idemix2_userdef_constants + type(idemix2_type), pointer :: idemix2_constants_out + idemix2_constants_out=>idemix2_constants_saved + if (present(idemix2_userdef_constants)) idemix2_constants_out=> idemix2_userdef_constants + select case(trim(varname)) + case('enable_M2' ) ; idemix2_constants_out%enable_M2 = val + case('enable_niw' ) ; idemix2_constants_out%enable_niw = val + case('enable_superbee_adv' ) ; idemix2_constants_out%enable_superbee_adv = val + case('enable_AB_timestep' ) ; idemix2_constants_out%enable_AB_timestep = val + case('enable_hor_diffusion') ; idemix2_constants_out%enable_hor_diffusion= val + case('enable_hor_diff_iter') ; idemix2_constants_out%enable_hor_diff_iter= val + case DEFAULT + print*, "ERROR:", trim(varname), " not a valid choice" + stop 1 + end select +end subroutine vmix_tke_put_idemix2_bool + + +! +! +!_______________________________________________________________________________ +! function g(x) --> adapted from pyOM +function gofx2(x1) + implicit none + real(cvmix_r8) :: gofx2,x1,x2,c + real(cvmix_r8), parameter :: pi = 3.14159265358979323846264338327950588 + x2=max(3d0,x1) + c= 1.-(2./pi)*asin(1./x2) + gofx2 = 2/pi/c*0.9*x2**(-2./3.)*(1-exp(-x2/4.3)) +end function gofx2 + +! function h(x) --> adapted from pyOM +function hofx2(x1) + implicit none + real(cvmix_r8) :: hofx2,x1,x2 + real(cvmix_r8), parameter :: pi = 3.14159265358979323846264338327950588 + x2 = max(1d1, x1) ! by_nils: it has to be x2>1 + hofx2 = (2./pi)/(1.-(2./pi)*asin(1./x2)) * (x2-1.)/(x2+1.) +end function hofx2 + +! function h(x) --> from pyOM +function hofx1(x) + implicit none + real(cvmix_r8) :: hofx1,x + real(cvmix_r8), parameter :: pi = 3.14159265358979323846264338327950588 + hofx1 = (2./pi)/(1.-(2./pi)*asin(1./x)) * (x-1.)/(x+1.) +end function hofx1 + +end module cvmix_idemix2 \ No newline at end of file diff --git a/src/cvmix_driver/gen_modules_cvmix_idemix.F90 b/src/cvmix_driver/gen_modules_cvmix_idemix.F90 index 615d1ae51..2db0ac8db 100644 --- a/src/cvmix_driver/gen_modules_cvmix_idemix.F90 +++ b/src/cvmix_driver/gen_modules_cvmix_idemix.F90 @@ -133,7 +133,7 @@ subroutine init_cvmix_idemix(partit, mesh) !_______________________________________________________________________ if(mype==0) then write(*,*) '____________________________________________________________' - write(*,*) ' --> initialise IDEMIX' + write(*,*) ' --> initialise IDEMIX', mype write(*,*) end if @@ -239,8 +239,18 @@ subroutine init_cvmix_idemix(partit, mesh) ! only 20% of the niw-input are available to penetrate into the deeper ocean ! divide by density_0 --> convert from W/m^2 to m^3/s^3 - iwe_fsrf = iwe_fsrf/density_0 * idemix_sforcusage - + iwe_fsrf = iwe_fsrf/density_0 * idemix_sforcusage + + ! check for total surface energy that is infused, compare with IDEMIX2 Etot_srf + loc_Etot = 0.0_WP + do elem=1, myDim_elem2D + if (elem2D_nodes(1,elem)<=myDim_nod2D) then + loc_Etot = loc_Etot + elem_area(elem)*iwe_fsrf(elem)*density_0 + end if + end do + call MPI_AllREDUCE(loc_Etot, glb_Etot, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + if (mype==0) write(*,*) " --> IDEMIX total srf. energy Etot_srf =", glb_Etot*1.0e-12, ' TW' + else if (mype==0) then write(*,*) '____________________________________________________________________' @@ -249,8 +259,8 @@ subroutine init_cvmix_idemix(partit, mesh) write(*,*) ' --> check your namelist.cvmix, idemix_surforc_file & ' write(*,*) ' idemix_botforc_file' write(*,*) '____________________________________________________________________' + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) end if - call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) end if !_______________________________________________________________________ @@ -301,7 +311,6 @@ subroutine init_cvmix_idemix(partit, mesh) ! divide by density_0 --> convert from W/m^2 to m^3/s^3 iwe_fbot = iwe_fbot/density_0 - else if (mype==0) then write(*,*) '____________________________________________________________________' @@ -310,8 +319,9 @@ subroutine init_cvmix_idemix(partit, mesh) write(*,*) ' --> check your namelist.cvmix, idemix_surforc_file & ' write(*,*) ' idemix_botforc_file' write(*,*) '____________________________________________________________________' + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) end if - call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) + end if !_______________________________________________________________________ @@ -731,11 +741,11 @@ subroutine calc_cvmix_idemix(partit, mesh) end do !___________________________________________________________________ - ! diagnostic: add horizontal propgation to the total production rate - ! of internal wave energy iwe_Tot - do node = 1,node_size - iwe_Thdi(:,node) = ( iwe(:,node) - iwe_Thdi(:,node) )/dt - iwe_Ttot(:,node) = iwe_Ttot(:,node) + iwe_Thdi(:,node) + ! diagnostic: add horizontal propagation to the total production rate + ! of internal wave energy iwe_Ttot + do elem = 1, elem_size + iwe_Thdi(:,elem) = ( iwe(:,elem) - iwe_Thdi(:,elem) )/dt + iwe_Ttot(:,elem) = iwe_Ttot(:,elem) + iwe_Thdi(:,elem) end do end if !-->if (idemix_n_hor_iwe_prop_iter>0) then diff --git a/src/cvmix_driver/gen_modules_cvmix_idemix2.F90 b/src/cvmix_driver/gen_modules_cvmix_idemix2.F90 new file mode 100644 index 000000000..37302c7c9 --- /dev/null +++ b/src/cvmix_driver/gen_modules_cvmix_idemix2.F90 @@ -0,0 +1,3825 @@ +! +! +!=============================================================================== +! module interface to FESOM2.0 for the CVMIX IDEMIX2 extension for the calculation +! of the internal wave energy and its dissipation in Turbulent Kinetic Energy +! vertical mixing scheme --> it is based one its pyOM2 implementation by Carsten Eden +! +! @see Olbers D., Eden C.: +! A Global Model for the Diapycnal Diffusivity Induced Internal Gravity Waves. +! J. Phys. Oceanogr., 43, 1759-1779. doi: 10.1175/JPO-D-12-0207.1, 2013. +! @see Eden C., Czeschel L., Olbers D.: +! Towards Energetically Consistent Ocean Models. +! J. Phys. Oceanogr., 44, 3160-3184, doi: 10.1175/JPO-D-13-0260.1, 2014. +! written by Patrick Scholz, 04.06.2026 +module g_cvmix_idemix2 + + !___________________________________________________________________________ + ! module calls from cvmix library + use cvmix_idemix2, only : cvmix_idemix2_init , & + cvmix_idemix2_compute_param , & + cvmix_idemix2_compute_compart_groupvel , & + cvmix_idemix2_compute_compart_interact_tscale , & + cvmix_idemix2_compute_M2_dissipation , & + cvmix_idemix2_compute_vert_struct_fct , & + cvmix_idemix2_compute_vdiff_vdiss_Eiw , & + cvmix_idemix2_compute_Eiw_waveinteract , & + cvmix_idemix2_compute_Eiw_diss2KvAv + + use cvmix_put_get, only : cvmix_put + use cvmix_kinds_and_types + + !___________________________________________________________________________ + ! module calls from FESOM + use g_config , only: dt, flag_debug, logfile_outfreq + use o_param + use MOD_MESH + USE MOD_PARTIT + USE MOD_PARSUP + use o_arrays + use o_tracers + use g_comm_auto + use g_interp + use g_read_other_NetCDF + use g_dist2coast, only: compute_dist2coast + use find_up_downwind_triangles_interface + use par_support_interfaces, only: init_mpi_types_fbin + use g_support, only: smooth_nod + implicit none + public + + !___________________________________________________________________________ + ! OCECTL/CVMIX_IDEMIX_PARAM namelist parameters + ! time scale for vertical symmetrisation (sec) + ! real(kind=WP) :: idemix_tau_v = 86400.0 ! old + real(kind=WP) :: idemix2_tau_v = 172800.0 ! from Pollman et al. (2017), use 2days, 2*86400sec + + ! time scale for horizontal symmetrisation, only necessary for lateral diffusion (sec), + ! use 15days, 15*86400sec + real(kind=WP) :: idemix2_tau_h = 1296000.0 + + ! constant of order one derived from the shape of the spectrum in m space (dimensionless) + real(kind=WP) :: idemix2_gamma = 1.570 + + ! spectral bandwidth in modes (dimensionless), or mode number scale, it describes over + ! over how many equivalent modes the energy is spread + ! real(kind=WP) :: idemix_jstar = 10.0 ! old + real(kind=WP) :: idemix2_jstar = 5.0 ! from Pollman et al. (2017) + + ! dissipation parameter (dimensionless) + ! real(kind=WP) :: idemix_mu0 = 1.33333333 ! old + real(kind=WP) :: idemix2_mu0 = 0.33333333 ! from Pollman et al. (2017), use 2days + + ! use superbee-spectral advection scheme and Adams-Bashfort timestepping +! logical :: idemix2_enable_superbee_adv = .true. + logical :: idemix2_enable_AB = .true. + real(kind=WP) :: idemix2_AB_epsilon = 0.1_WP + ! number of spectral bins used for the M2 tidal and near-inertial wave (niw) components + ! e.g 50+2 in loop used as do fbin=2,51 ... 1 and 52 serve as spectral boudary condition + ! The first and last bins are used for boundary conditions in the spectral space. + ! They ensure smooth transitions and prevent numerical instabilities at the edges of the spectral domain. + ! Numerical Stability: The advection scheme (e.g., Superbee) requires ghost cells or boundary values. + ! Skipping the first and last bins avoids out-of-bounds errors when calculating gradients. + integer :: idemix2_nfbin=52 + + ! enable adding of idemix full horizontal tendency from + ! div(grad(Eiw*v0)*v0*tauh) diffusion term --> explicit + logical :: idemix2_enable_hor_diff_expl = .false. + + ! enable idemix1 functionality of homogenous diffusion into all directions + logical :: idemix2_enable_hor_diff_impl_iter = .false. + integer :: idemix2_hor_diff_niter = 5 ! from Pollman et al. (2017) + + ! define shelf is defined as distance from coast (default 300km) + real(kind=WP) :: idemix2_shelf_dist = 300.0e3 + + ! NIW/M2 dissipation timescales: shelf value and open-ocean floor (days) + ! defaults match pyOM2_fpohlmann: shelf=7days, NIW floor=3days, M2 floor=50days + ! --> Larger idemix2_tau_niw_oce (e.g. 50 days) → rate `1/τ` small → E_niw dissipates slowly → more reaches open ocean + ! --> Smaller idemix2_tau_niw_oce (e.g. 3 days) → rate `1/τ` large → E_niw dissipates quickly → energy stays near source + ! | Version | tau_niw_oce | Effect | + ! |-------------------|-------------|-------------------------------------| + ! | pyOM2 original | 50 days | slow dissipation, fills open ocean | + ! | pyOM2_fpohlmann | 3 days | fast dissipation, stays near source | + ! | FESOM2 default | 3 days | matches pyOM2_fpohlmann | + real(kind=WP) :: idemix2_tau_niw_shelf = 7.0_WP + real(kind=WP) :: idemix2_tau_niw_oce = 50.0_WP ! pyOM2_fpohlmann default; pyOM2_orig: 50.0 + real(kind=WP) :: idemix2_tau_M2_shelf = 7.0_WP + real(kind=WP) :: idemix2_tau_M2_oce = 50.0_WP + + ! scal down baroclinic wave speed when not all modes are used + real(kind=WP) :: idemix2_scal_cn = 1.0 + + ! minimum cn floor: prevents cg_compart→0 in convective columns near the M2 critical latitude (~74.5°N). + ! Recommended value: 0.1 m/s (symmetric with the cstar=max(1e-2,...) floor already applied for Eiw). + real(kind=WP) :: idemix2_cn_min = 0.0 + + !___________________________________________________________________________ + ! enable M2 tidal component as significant source of internal wave energy in IDEMIX2, + ! lower frequency modes + ! Frequency: Semi-diurnal (twice daily, ~12.42 hour period) + ! Source : Barotropic tidal flow over rough topography + ! Energy : Higher energy, lower frequency + ! Impact : Dominant in regions with strong tidal currents + logical :: idemix2_enable_M2 = .true. + + ! filelocation for idemix2 M2 forcing (Summed anisotropic M2-tide generation modes 1-2 (W/m2)) + character(MAX_PATH):: idemix2_M2forc_file = './idemix2_IT_forc_M2modes1+2_aniso.nc' + character(MAX_PATH):: idemix2_M2forc_vname= 'Flux_to2' + character(MAX_PATH):: idemix2_M2forc_zname= 'phi' + + !___________________________________________________________________________ + ! enable Near-Inertial Wave (NIW) component of the IDEMIX module. NIWs are generated by + ! wind stress and have frequencies close to the local inertial frequency. + ! Frequency: Near the local inertial frequency (f, typically 1-4 cycles per day at mid-latitudes) + ! Source : Wind forcing, especially during storms + ! Energy : Lower energy, higher frequency than M2 + ! Impact : Important in the upper ocean, especially after storms + logical :: idemix2_enable_niw = .false. + + ! amount of surface for2cing that is used + real(kind=WP) :: idemix2_fniw_usage = 0.2 + + ! filelocation for idemix2 NIW forcing (near inertial waves) + character(MAX_PATH):: idemix2_niwforc_file = './dummy.nc' + character(MAX_PATH):: idemix2_niwforc_vname= 'dummy' + + !___________________________________________________________________________ + ! filelocation for idemix2 bottom forcing + logical :: idemix2_enable_bot = .true. + + character(MAX_PATH):: idemix2_botforc_file = './tidal_energy_gx1v6_20090205_rgrid.nc' + character(MAX_PATH):: idemix2_botforc_vname= 'wave_dissipation' + ! total global Energy input that should be conserved if 0.0 no conservation is applied + real(kind=WP) :: idemix2_botforc_Etot = 0.0_WP ! units W + + !___________________________________________________________________________ + ! maximum cutoff value for interal wave energy --> is there for stability + real(kind=WP) :: idemix2_Eiw_maxthresh= 0.1 + ! Option A: smooth IDEMIX2 internal fields to improve long-term stability. + ! All flags default to .false. so Option B (TKE-interface smoothing in + ! gen_modules_cvmix_tke.F90) is tested first. + logical :: idemix2_smooth_Eiw_diss = .false. ! smooth iwe2_E_iw_diss after vertical solve + logical :: idemix2_smooth_Eiw = .false. ! smooth iwe2_E_iw(:,:,tip1) after wave-wave + logical :: idemix2_smooth_alpha_c = .false. ! smooth iwe2_alpha_c after parameter loop + integer :: idemix2_smooth_niter = 1 + + !___________________________________________________________________________ + ! switch on extended diagnostic + logical :: idemix2_diag_Ecompart= .false. + logical :: idemix2_diag_Eiw = .false. + logical :: idemix2_diag_WWI = .false. + +! !___________________________________________________________________________ +! ! enable lee wave source of internal wave energy in IDEMIX2, +! ! Lee Wave Generation: Generated when mean flow encounters topography Energy +! ! transfers from mean flow to internal waves +! logical :: idemix2_enable_leew = .false. +! +! ! filelocation for idemix2 M2 forcing (Summed anisotropic M2-tide generation modes 1-2 (W/m2)) +! character(MAX_PATH):: idemix2_leewforc_file = './idemix2_lee_forc_Eden.nc' +! character(MAX_PATH):: idemix2_leewforc_vname= 'C_lee' + + !___________________________________________________________________________ + ! filelocation for idemix2 Root Mean Square Topographic Height forcing. Measures the roughness or + ! variability of seafloor topography. Units: Meters (m), Role: Represents the standard deviation + ! of seafloor height variations. Used to calculate energy transfer from tides/NIW to internal waves. + character(MAX_PATH):: idemix2_hrmsforc_file = './idemix2_forcing_t-scattering_Goff2023_1deg.nc' + character(MAX_PATH):: idemix2_hrmsforc_vname= 'HRMS' + + ! filelocation for idemix2 Characteristic horizontal length scale of topographic features. + ! Units: Meters (m), Role: Represents the dominant wavelength of seafloor roughness. Used to + ! normalize the topographic forcing. + character(MAX_PATH):: idemix2_hlamforc_file = './idemix2_forcing_t-scattering_1deg.nc' + character(MAX_PATH):: idemix2_hlamforc_vname= 'LAMBDA_G10' + + namelist /param_idemix2/ idemix2_tau_v, idemix2_tau_h, idemix2_gamma, idemix2_jstar, idemix2_mu0, idemix2_scal_cn, idemix2_cn_min, & + idemix2_enable_AB, idemix2_AB_epsilon, idemix2_nfbin, & ! idemix2_enable_superbee_adv + idemix2_enable_hor_diff_expl, idemix2_enable_hor_diff_impl_iter, idemix2_hor_diff_niter, & + idemix2_shelf_dist, & + idemix2_tau_niw_shelf, idemix2_tau_niw_oce, & + idemix2_tau_M2_shelf, idemix2_tau_M2_oce, & + idemix2_botforc_Etot, & + idemix2_enable_M2 , idemix2_M2forc_file , idemix2_M2forc_vname , idemix2_M2forc_zname, & + idemix2_enable_niw , idemix2_niwforc_file , idemix2_niwforc_vname , idemix2_fniw_usage, & +! idemix2_enable_leew, idemix2_leewforc_file, idemix2_leewforc_vname, & + idemix2_enable_bot , idemix2_botforc_file , idemix2_botforc_vname , & + idemix2_hrmsforc_file, idemix2_hrmsforc_vname, & + idemix2_hlamforc_file, idemix2_hlamforc_vname, & + idemix2_Eiw_maxthresh, & + idemix2_smooth_Eiw_diss, idemix2_smooth_Eiw, idemix2_smooth_alpha_c, idemix2_smooth_niter, & + idemix2_diag_Ecompart, idemix2_diag_Eiw, idemix2_diag_WWI + + !___________________________________________________________________________ + ! CVMIX-IDEMIX variables + real(kind=WP), allocatable, dimension(:) :: iwe2_phit, iwe2_phiu, iwe2_dphit, iwe2_dphiu + + ! + ! --- M2 related global variables --- + real(kind=WP) :: iwe2_omega_M2 + real(kind=WP), allocatable, dimension(:,:,:):: iwe2_M2_uv, iwe2_E_M2, iwe2_E_M2_divh, iwe2_E_M2_divs + real(kind=WP), allocatable, dimension(:,:) :: iwe2_M2_w, iwe2_fM2, iwe2_E_M2_struct + real(kind=WP), allocatable, dimension(:) :: w_M2_e, iwe2_alpha_M2_c, iwe2_M2_tau + + ! optional diagnostic + real(kind=WP), allocatable, dimension(:,:) :: iwe2_E_M2_dt , & + iwe2_E_M2_advh, iwe2_E_M2_advs , & + iwe2_E_M2_diss, iwe2_E_M2_diss_wwi, & + iwe2_E_M2_forc + real(kind=WP), allocatable, dimension(:) :: iwe2_E_M2_refl + + + ! --- niw related global variables --- + real(kind=WP), allocatable, dimension(:) :: iwe2_omega_niw + real(kind=WP), allocatable, dimension(:,:,:):: iwe2_niw_uv, iwe2_E_niw, iwe2_E_niw_divh, iwe2_E_niw_divs + real(kind=WP), allocatable, dimension(:,:) :: iwe2_niw_w, iwe2_fniw, iwe2_E_niw_struct + real(kind=WP), allocatable, dimension(:) :: w_niw_e, iwe2_niw_tau + + ! optional diagnostic + real(kind=WP), allocatable, dimension(:,:) :: iwe2_E_niw_dt , & + iwe2_E_niw_advh, iwe2_E_niw_advs , & + iwe2_E_niw_diss, & + iwe2_E_niw_forc + real(kind=WP), allocatable, dimension(:) :: iwe2_E_niw_refl + + ! --- Eiw - internal wave energy related variables --- + real(kind=WP), allocatable, dimension(:,:,:):: iwe2_E_iw + real(kind=WP), allocatable, dimension(:,:) :: iwe2_E_iw_diss + + ! optional diagnostic + real(kind=WP), allocatable, dimension(:,:) :: iwe2_E_iw_dt, iwe2_E_iw_fbot, & + iwe2_E_iw_vdif, iwe2_E_iw_hdif + real(kind=WP), allocatable, dimension(:) :: iwe2_E_iw_fsrf + real(kind=WP), allocatable, dimension(:,:) :: iwe2_E_iw_diss_M2, iwe2_E_iw_diss_niw + + real(kind=WP), allocatable, dimension(:,:) :: iwe2_Av + + ! --- general idemix variable --- + real(kind=WP), allocatable, dimension(:) :: iwe2_cn + real(kind=WP), allocatable, dimension(:,:) :: iwe2_c0, iwe2_v0, iwe2_alpha_c + + ! --- forcing realted variables --- + real(kind=WP), allocatable, dimension(:) :: iwe2_topo_hrms, iwe2_topo_hlam, iwe2_topo_dist + real(kind=WP), allocatable, dimension(:) :: iwe2_fleew, iwe2_fsrf, iwe2_fbot_n + real(kind=WP), allocatable, dimension(:,:) :: iwe2_fbot + + ! --- support variables --- + real(kind=WP), allocatable, dimension(:) :: vol_nodB2T + real(kind=WP), allocatable, dimension(:,:) :: vol_wcelli + real(kind=WP), allocatable, dimension(:) :: iwe2_grady_coriol, aux + real(kind=WP), allocatable, dimension(:,:,:):: iwe2_gradxy_e, iwe2_gradxy_n + real(kind=WP), allocatable, dimension(:,: ):: iwe2_flx_uv, iwe2_flx_w + integer :: iwe2_ti=1, iwe2_tip1=2 + + ! reflective coastal BC: for each edge touching exactly one coast node, + ! iwe2_bc_reflect_bin stores the mirror spectral bin (0 = edge not flagged), + ! iwe2_bc_reflect_sgn = +1 if ednodes(1) is the coast node, -1 if ednodes(2) is. + integer , allocatable, dimension(:) :: iwe2_refl_bin + integer , allocatable, dimension(:) :: iwe2_refl_sgn + ! per-timestep scratch: blocked coast flux accumulated per (mirror bin, interior node), + ! filled by apply_reflect_bc_spctrl, applied to Edivh in hsintegrate_Ecompart + real(kind=WP), allocatable, dimension(:,:) :: iwe2_refl_src + ! mask: .true. for own nodes that are interior to at least one coast edge + logical, allocatable, dimension(:) :: iwe2_refl_node + ! mask: .true. for nodes that sit ON the coast (belong to a boundary edge) + logical, allocatable, dimension(:) :: iwe2_coast_node + ! pre-computed periodic wrap indices for cross-spectral superbee stencil + ! (branch-free inner loop in adv_Ecompart_crss_spctrl_superbee) + integer, allocatable, dimension(:) :: iwe2_idxp1, iwe2_idxp2, iwe2_idxm1 + + ! load variables from CVMix list + type(cvmix_data_type) :: CVMix_vars + + contains + + + + ! + ! + ! + !=========================================================================== + ! allocate and initialize IDEMIX variables --> call initialisation + ! routine from cvmix library + subroutine init_cvmix_idemix2(partit, mesh) + implicit none + type(t_mesh), intent(inout), target :: mesh + type(t_partit), intent(inout), target :: partit + + character(len=cvmix_strlen) :: nmlfile + logical :: file_exist=.False. + integer :: node_size, elem_size, elem, node, nfbin, & + fbin_i, elnodes(3), nzmax, nlu, nln, nz + real(kind=WP) :: loc_Etot=0.0_WP, glb_Etot=0.0_WP + real(kind=WP) :: t0, t1 +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + !_______________________________________________________________________ + if(mype==0) then + write(*,*) '____________________________________________________________' + write(*,*) ' --> initialise CVMIX_IDEMIX2' + write(*,*) + end if + !_______________________________________________________________________ + ! read cvmix namelist file + nmlfile ='namelist.cvmix' ! name of ocean namelist file + ! check if cvmix namelist file exists if not use default values + file_exist=.False. + inquire(file=trim(nmlfile),exist=file_exist) + if (file_exist) then + open(20,file=trim(nmlfile)) + read(20,nml=param_idemix2) + close(20) + else + write(*,*) ' could not find namelist.cvmix, will use default values !' + end if + + !_______________________________________________________________________ + if (mype==0) then + write(*,*) " IDEMIX2:" + write(*,*) " ├> parameter " + write(*,*) " │ ┌──────────────────────────── " + write(*,*) " │ ├> idemix2_tau_v = ", idemix2_tau_v + write(*,*) " │ ├> idemix2_tau_h = ", idemix2_tau_h + write(*,*) " │ ├> idemix2_gamma = ", idemix2_gamma + write(*,*) " │ ├> idemix2_jstar = ", idemix2_jstar + write(*,*) " │ ├> idemix2_mu0 = ", idemix2_mu0 + write(*,*) " │ ├> idemix2_scal_cn = ", idemix2_scal_cn + write(*,*) " │ ├> idemix2_cn_min = ", idemix2_cn_min + write(*,*) " │ ├> idemix2_Eiw_maxthresh = ", idemix2_Eiw_maxthresh + write(*,*) " │ ├> idemix2...hor_diff_expl = ", idemix2_enable_hor_diff_expl + write(*,*) " │ └> idemix2...hor_diff_impl_iter= ", idemix2_enable_hor_diff_impl_iter + write(*,*) " │ └> idemix2_hor_diff_niter= ", idemix2_hor_diff_niter + write(*,*) " │ " + write(*,*) " ├> idemix2_AB_timestep = ", idemix2_enable_AB + write(*,*) " │ └> idemix2_AB_epsilon = ", idemix2_AB_epsilon + write(*,*) " │ " + write(*,*) " ├> idemix2_nfbin = ", idemix2_nfbin + write(*,*) " │ " + write(*,*) " ├> idemix2_enable_M2 = ", idemix2_enable_M2 + write(*,*) " │ ┌──────────────────────────── " + write(*,*) " │ ├> idemix2_M2forc_file = ", trim(idemix2_M2forc_file) + write(*,*) " │ │ ├> idemix2_M2forc_vname = ", trim(idemix2_M2forc_vname) + write(*,*) " │ │ └> idemix2_M2forc_zname = ", trim(idemix2_M2forc_zname) + write(*,*) " │ ├> idemix2_tau_M2_shelf = ", idemix2_tau_M2_shelf, " days" + write(*,*) " │ └> idemix2_tau_M2_oce = ", idemix2_tau_M2_oce, " days" + + write(*,*) " │ " + write(*,*) " ├> idemix2_enable_niw = ", idemix2_enable_niw + write(*,*) " │ ┌──────────────────────────── " + write(*,*) " │ ├> idemix2_fniw_usage = ", idemix2_fniw_usage + write(*,*) " │ ├> idemix2_niwforc_file = ", trim(idemix2_niwforc_file) + write(*,*) " │ │ └> idemix2_niwforc_vname = ", trim(idemix2_niwforc_vname) + write(*,*) " │ ├> idemix2_tau_niw_shelf = ", idemix2_tau_niw_shelf, " days" + write(*,*) " │ └> idemix2_tau_niw_oce = ", idemix2_tau_niw_oce, " days" + write(*,*) " │ " + write(*,*) " ├> idemix2_enable_bot = ", idemix2_enable_bot + write(*,*) " │ ┌──────────────────────────── " + write(*,*) " │ └> idemix2_botforc_file = ", trim(idemix2_botforc_file) + write(*,*) " │ ├> idemix2_botforc_vname = ", trim(idemix2_botforc_vname) + write(*,*) " │ └> idemix2_botforc_Etot = ", idemix2_botforc_Etot + write(*,*) " │ " +! write(*,*) " ├> idemix2_enable_leew = ", idemix2_enable_leew +! write(*,*) " │ └> idemix2_leewforc_file = ", trim(idemix2_leewforc_file) +! write(*,*) " │ └> idemix2_leewforc_vname= ", trim(idemix2_leewforc_vname) +! write(*,*) " │ " + write(*,*) " ├> topographic height forcing " + write(*,*) " │ ┌──────────────────────────── " + write(*,*) " │ ├> idemix2_hrmsforc_file = ", trim(idemix2_hrmsforc_file) + write(*,*) " │ │ └> idemix2_hrmsforc_vname= ", trim(idemix2_hrmsforc_vname) + write(*,*) " │ └> idemix2_hlamforc_file = ", trim(idemix2_hlamforc_file) + write(*,*) " │ └> idemix2_hlamforc_vname= ", trim(idemix2_hlamforc_vname) + write(*,*) " │ " + WRITE(*,*) " ├> idemix2_shelf_dist = ", idemix2_shelf_dist + write(*,*) " │ " + write(*,*) " ├> smoothing switches " + write(*,*) " │ ┌──────────────────────────── " + write(*,*) " │ ├> idemix2_smooth_Eiw_diss = ", idemix2_smooth_Eiw_diss + write(*,*) " │ ├> idemix2_smooth_Eiw = ", idemix2_smooth_Eiw + write(*,*) " │ ├> idemix2_smooth_alpha_c = ", idemix2_smooth_alpha_c + write(*,*) " │ └> idemix2_smooth_niter = ", idemix2_smooth_niter + write(*,*) " │ " + write(*,*) " ├> diagnostic switches " + write(*,*) " │ ┌──────────────────────────── " + write(*,*) " │ ├> idemix2_diag_Ecompart = ", idemix2_diag_Ecompart + write(*,*) " │ ├> idemix2_diag_Eiw = ", idemix2_diag_Eiw + write(*,*) " │ └> idemix2_diag_WWI = ", idemix2_diag_WWI + write(*,*) + write(*,*) " IDEMIX2 inputs:" + end if + + !_______________________________________________________________________ + ! allocate + initialse idemix arrays --> with size myDim_nod2D+eDim_nod2D + node_size=myDim_nod2D+eDim_nod2D + elem_size=myDim_elem2D+eDim_elem2D + nfbin =idemix2_nfbin + + ! Build MPI datatypes for spectral bin halo exchange + call init_mpi_types_fbin(idemix2_nfbin, partit) + + ! 3d vertical group velocities (m/s) for the continuous internal wave spectrum + ! 3d horizontal group velocities (m/s) for the continuous internal wave spectrum + allocate(iwe2_c0(nl,node_size), iwe2_v0(nl,node_size)) + iwe2_c0(:,:) = 0.0_WP + iwe2_v0(:,:) = 0.0_WP + + ! baroclionic gravity wave speed + allocate(iwe2_cn(node_size)) + iwe2_cn(:) = 0.0_WP + + ! Eiw 3d enery dissipation coefficient + allocate(iwe2_alpha_c(nl,node_size)) + iwe2_alpha_c(:,:) = 0.0_WP + + ! initialise Eiw - internal wave energy variables + ! index (..., 1:3) timestep index E^(n-1), E^(n), E^(n+1) + allocate(iwe2_E_iw( nl, node_size, 2)) + iwe2_E_iw( :,:,:)= 0.0_WP + + allocate(iwe2_E_iw_diss(nl, node_size)) + iwe2_E_iw_diss( :,:)= 0.0_WP ! Eiw production from disspation + + ! Diagnostics (sized myDim_nod2D: IO-only, never need halo) + if (idemix2_diag_Eiw) then + allocate( iwe2_E_iw_fbot(nl, myDim_nod2D) & + , iwe2_E_iw_vdif(nl, myDim_nod2D) & + , iwe2_E_iw_hdif(nl, myDim_nod2D) & + , iwe2_E_iw_fsrf( myDim_nod2D) & + ) + iwe2_E_iw_fbot( :,:)= 0.0_WP + iwe2_E_iw_hdif( :,:)= 0.0_WP + iwe2_E_iw_vdif( :,:)= 0.0_WP + iwe2_E_iw_fsrf( :)= 0.0_WP + end if + if (idemix2_diag_Eiw .or. idemix2_diag_WWI) then + allocate( iwe2_E_iw_dt( nl, myDim_nod2D)) + iwe2_E_iw_dt( :,:)= 0.0_WP + end if + + ! initialise M2 variables + if (idemix2_enable_M2) then + ! M2 energy dissipation + allocate(iwe2_alpha_M2_c(node_size)) + iwe2_alpha_M2_c(:) = 0.0_WP + + ! M2 dissipation timescale + allocate(iwe2_M2_tau(node_size)) + iwe2_M2_tau(:) = 0.0_WP + + ! M2 cross spectral propagation at elements + allocate(w_M2_e(nfbin)) + w_M2_e(:) = 0.0_WP + + ! M2 zonal/merid group velocity, and cross spectral propagation + ! at vertices + allocate(iwe2_M2_uv(2, nfbin,elem_size)) + allocate(iwe2_M2_w( nfbin,node_size)) + iwe2_M2_uv(:,:,:) = 0.0_WP + iwe2_M2_w(:,:) = 0.0_WP + + ! M2 forcing + allocate(iwe2_fM2(nfbin, node_size)) + iwe2_fM2(:,:) = 0.0_WP + + ! M2 wave energy, and divergence of M2 wave energy + ! index (..., 1:3) timestep index E^(n-1), E^(n), E^(n+1) + allocate( iwe2_E_M2( nfbin, node_size, 2) & + , iwe2_E_M2_divh(nfbin, node_size, 2) & + , iwe2_E_M2_divs(nfbin, node_size, 2) & + ) + iwe2_E_M2( :,:,:)= 0.0_WP + iwe2_E_M2_divh( :,:,:)= 0.0_WP + iwe2_E_M2_divs( :,:,:)= 0.0_WP + + ! structure function for M2 energy + allocate(iwe2_E_M2_struct(nl, node_size)) + iwe2_E_M2_struct(:,:) = 0.0_WP + + ! Diagnostics + if (idemix2_diag_Ecompart) then + ! diagnostic for M2 spectral energy advection + allocate( iwe2_E_M2_advh(nfbin, myDim_nod2D) & + , iwe2_E_M2_advs(nfbin, myDim_nod2D) & + , iwe2_E_M2_diss(nfbin, myDim_nod2D) & + , iwe2_E_M2_forc(nfbin, myDim_nod2D) ) + allocate( iwe2_E_M2_refl( myDim_nod2D) ) + iwe2_E_M2_advh(:,:) = 0.0_WP + iwe2_E_M2_advs(:,:) = 0.0_WP + iwe2_E_M2_diss(:,:) = 0.0_WP + iwe2_E_M2_forc(:,:) = 0.0_WP + iwe2_E_M2_refl(:) = 0.0_WP + end if + + if (idemix2_diag_Ecompart .or. idemix2_diag_WWI) then + allocate( iwe2_E_M2_dt(nfbin, myDim_nod2D) ) + iwe2_E_M2_dt(:,:) = 0.0_WP + end if + + if (idemix2_diag_WWI) then + ! diagnostic for M2 wave-wave interaction + allocate( iwe2_E_iw_diss_M2(nl, myDim_nod2D) & + , iwe2_E_M2_diss_wwi(nfbin, myDim_nod2D) ) + iwe2_E_iw_diss_M2( :,:) = 0.0_WP + iwe2_E_M2_diss_wwi(:,:) = 0.0_WP + end if + end if + + ! initialise niw variables + if (idemix2_enable_niw) then + ! niw frequency + allocate(iwe2_omega_niw(node_size)) + iwe2_omega_niw(:) = 0.0_WP + + ! niw dissipation timescale + allocate(iwe2_niw_tau(node_size)) + iwe2_niw_tau(:) = 0.0_WP + + ! niw cross spectral propagation at elements + allocate(w_niw_e(nfbin)) + w_niw_e(:) = 0.0_WP + + ! niw zonal/merid group velocity, and cross spectral propagation + ! at vertices + allocate(iwe2_niw_uv(2, nfbin,elem_size)) + allocate(iwe2_niw_w( nfbin,node_size)) + iwe2_niw_uv(:,:,:) = 0.0_WP + iwe2_niw_w(:,:) = 0.0_WP + + ! niw forcing + allocate(iwe2_fniw(nfbin, node_size)) + iwe2_fniw(:,:) = 0.0_WP + + ! niw wave energy, and divergence of niw wave energy + ! index (..., 1:3) timestep index E^(n-1), E^(n), E^(n+1) + allocate( iwe2_E_niw( nfbin, node_size, 2) & + , iwe2_E_niw_divh(nfbin, node_size, 2) & + , iwe2_E_niw_divs(nfbin, node_size, 2) & + ) + iwe2_E_niw( :,:,:)= 0.0_WP + iwe2_E_niw_divh( :,:,:)= 0.0_WP + iwe2_E_niw_divs( :,:,:)= 0.0_WP + + ! structure function for niw energy + allocate(iwe2_E_niw_struct(nl, node_size)) + iwe2_E_niw_struct(:,:) = 0.0_WP + + ! Diagnostics + if (idemix2_diag_Ecompart) then + ! diagnostic for niw spectral energy advection + allocate( iwe2_E_niw_advh(nfbin, myDim_nod2D) & + , iwe2_E_niw_advs(nfbin, myDim_nod2D) & + , iwe2_E_niw_diss(nfbin, myDim_nod2D) & + , iwe2_E_niw_forc(nfbin, myDim_nod2D) ) + allocate( iwe2_E_niw_refl( myDim_nod2D) ) + iwe2_E_niw_advh(:,:) = 0.0_WP + iwe2_E_niw_advs(:,:) = 0.0_WP + iwe2_E_niw_diss(:,:) = 0.0_WP + iwe2_E_niw_forc(:,:) = 0.0_WP + iwe2_E_niw_refl(:) = 0.0_WP + end if + + if (idemix2_diag_Ecompart .or. idemix2_diag_WWI) then + allocate( iwe2_E_niw_dt(nfbin, myDim_nod2D) ) + iwe2_E_niw_dt(:,:) = 0.0_WP + end if + + if (idemix2_diag_WWI) then + ! diagnostic for niw wave-wave interaction + allocate( iwe2_E_iw_diss_niw(nl, myDim_nod2D) ) + iwe2_E_iw_diss_niw(:,:) = 0.0_WP + end if + end if + + ! reflected boundary condition (only needed when M2 or NIW compartments are active) + if (idemix2_enable_M2 .or. idemix2_enable_niw) then + allocate(iwe2_refl_bin(myDim_edge2D)) + allocate(iwe2_refl_sgn(myDim_edge2D)) + allocate(iwe2_refl_src(idemix2_nfbin, myDim_nod2D)) + allocate(iwe2_refl_node(myDim_nod2D+eDim_nod2D)) + allocate(iwe2_coast_node(myDim_nod2D+eDim_nod2D)) + iwe2_refl_bin(:) = 0 + iwe2_refl_sgn(:) = 0 + iwe2_refl_src(:,:)= 0.0_WP + iwe2_refl_node(:) = .false. + iwe2_coast_node(:)= .false. + end if + + ! allocate 1d Spectral space coordinates + allocate( iwe2_phit( nfbin) & + , iwe2_phiu( nfbin) & + , iwe2_dphit(nfbin) & + , iwe2_dphiu(nfbin) & + ) + iwe2_phit(:) = 0.0_WP + iwe2_phiu(:) = 0.0_WP + iwe2_dphit(:) = 0.0_WP + iwe2_dphiu(:) = 0.0_WP + + ! internal wave related vertical viscosity and diffusivity + if(mix_scheme_nmb==7) then + allocate(iwe2_Av(nl,elem_size)) + iwe2_Av(:,:) = 0.0_WP + endif + + ! forcing fields, M2 tidal forcing (spectral) and NIW forcing (spectral) + allocate( iwe2_fbot_n( node_size) & + , iwe2_fbot(nl, node_size) & + , iwe2_fsrf( node_size) & +! , iwe2_fleew( myDim_elem2D) & + ) + iwe2_fbot_n(:) = 0.0_WP + iwe2_fbot(:,:) = 0.0_WP + iwe2_fsrf( :) = 0.0_WP +! iwe2_fleew( :) = 0.0_WP + + ! Topographic height and Topographic wavelength + allocate( iwe2_topo_hrms( node_size) & + , iwe2_topo_hlam( node_size) & + , iwe2_topo_dist( node_size) & + ) + iwe2_topo_hrms(:) = 0.0_WP + iwe2_topo_hlam(:) = 0.0_WP + iwe2_topo_dist(:) = 0.0_WP + + ! support gradient variables + allocate( iwe2_grady_coriol( elem_size) & + , iwe2_gradxy_e(2, nfbin, elem_size) & + , iwe2_gradxy_n(2, nfbin, node_size) & + ) + iwe2_grady_coriol(:) = 0.0_WP + iwe2_gradxy_e(:,:,:) = 0.0_WP + iwe2_gradxy_n(:,:,:) = 0.0_WP + + ! support horizontal edge flux and vertical flux and accumulated divergence variables + allocate( iwe2_flx_uv(nfbin, partit%myDim_edge2D) & + , iwe2_flx_w( nfbin, partit%myDim_nod2D ) & + ) + iwe2_flx_uv(:,:) = 0.0 + iwe2_flx_w( :,:) = 0.0 + + ! support inverse volume of wcell + allocate(vol_wcelli(nl, node_size)) + vol_wcelli(:,:) = 0.0_WP + allocate(vol_nodB2T(node_size)) + vol_nodB2T(:) = 0.0_WP + + !_______________________________________________________________________ + ! width of spectral frequency bins + iwe2_dphit(:) = 2.0_WP*pi/(nfbin-2) + iwe2_dphiu(:) = iwe2_dphit(:) + ! iwe2_phiu(k) represents the center of the k-th spectral bin + ! iwe2_phit(k) represents the edge of the k-th spectral bin + iwe2_phit(1) = -iwe2_dphit(1) + iwe2_phiu(1 )= iwe2_phit(1)+iwe2_dphit(1)/2.0_WP + do fbin_i=2,nfbin + iwe2_phit(fbin_i) = iwe2_phit(fbin_i-1) + iwe2_dphit(fbin_i) + iwe2_phiu(fbin_i) = iwe2_phiu(fbin_i-1) + iwe2_dphiu(fbin_i) + end do + + !_______________________________________________________________________ + ! pre-compute periodic wrap indices for cross-spectral superbee stencil + allocate(iwe2_idxp1(nfbin), iwe2_idxp2(nfbin), iwe2_idxm1(nfbin)) + do fbin_i = 1, nfbin + iwe2_idxp1(fbin_i) = fbin_i+1; if (iwe2_idxp1(fbin_i)>nfbin) iwe2_idxp1(fbin_i)=iwe2_idxp1(fbin_i)-(nfbin-2) + iwe2_idxp2(fbin_i) = fbin_i+2; if (iwe2_idxp2(fbin_i)>nfbin) iwe2_idxp2(fbin_i)=iwe2_idxp2(fbin_i)-(nfbin-2) + iwe2_idxm1(fbin_i) = fbin_i-1; if (iwe2_idxm1(fbin_i)<1 ) iwe2_idxm1(fbin_i)=nfbin-2 + end do + + !_______________________________________________________________________ + ! pre-compute reflective coastal BC lookup tables + if (idemix2_enable_M2 .or. idemix2_enable_niw) then + call init_reflect_bc( iwe2_refl_bin & ! OUT: mirror spectral bin index per coast edge (0=not coast) + , iwe2_refl_sgn & ! OUT: sign per coast edge (+1 if ednodes(1) is coast, -1 otherwise) + , iwe2_refl_src & ! OUT: per-timestep reflect source accumulator (m²/s³) + , iwe2_refl_node & ! OUT: logical mask, .true. for coast-adjacent interior nodes + , iwe2_coast_node & ! OUT: logical mask, .true. for coast nodes themselves + , partit & ! IN + , mesh & ! IN + ) + end if + + !_______________________________________________________________________ + ! read idemix M2 forcing from cfsr data --> file + if (idemix2_enable_M2) then + t0=MPI_Wtime() + ! omega_M2 is fixed, as the M2 tidal forcing is independent of the local inertial frequency. + ! Physical Implication: At high latitudes where |f| > ω_M2, the M2 tide becomes evanescent + ! (cannot propagate as internal waves). This is handled in the code by checking ω_M2 > |f| + ! for M2 tidal forcing when computing iwe_M2_tau, if ω_M2 < |f| --> iwe_M2_tau=0.0 + iwe2_omega_M2 = 2*pi/( 12*60*60 + 25.2 *60 ) ! M2 frequency in 1/s + + file_exist=.False. + inquire(file=trim(idemix2_M2forc_file),exist=file_exist) + if (file_exist) then + if (mype==0) write(*,*) ' ├> read IDEMIX2 M2 wave forcing' + call read_other_NetCDF_3d( & + trim(idemix2_M2forc_file) , & + trim(idemix2_M2forc_vname) , & + trim(idemix2_M2forc_zname) , & + iwe2_fM2 , & + .true. , & !.true. -> on node + partit , & + mesh & + ) + do fbin_i = 1, nfbin + iwe2_fM2(fbin_i,:) = iwe2_fM2(fbin_i,:)/density_0/iwe2_dphit(fbin_i) + end do + else + if (mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: IDEMIX2 M2 forcing file not found! Cant apply IDEMIX2' + write(*,*) ' vertical mixing parameterisation! ' + write(*,*) ' ├> file: ', trim(idemix2_M2forc_file) + write(*,*) ' └> check: namelist.cvmix, idemix2_M2forc_file & ' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) + end if + end if + + t1=MPI_Wtime() + if (mype==0) write(*,*) ' │ └> elapsed time:', t1-t0 + end if ! --> if (idemix2_enable_M2) then + + !_______________________________________________________________________ + ! read idemix niw or srf forcing from cfsr data --> file + t0=MPI_Wtime() + file_exist=.False. + inquire(file=trim(idemix2_niwforc_file),exist=file_exist) + if (file_exist) then + call read_other_NetCDF( & + trim(idemix2_niwforc_file) , & + trim(idemix2_niwforc_vname) , & + 1 , & + iwe2_fsrf , & + .true. , & ! NN for missing values + .true. , & ! interpolate to vertices + partit , & + mesh & + ) + + + ! only 20% (idemix2_fniw_usage) from the surface forcing goes into internal waves + ! iwe2_fsrf becomes surface forcing variable when idemix2_enable_niw=.false. + ! in this case standard idemix1 behaviour + iwe2_fsrf = max(0.0_WP,iwe2_fsrf) + iwe2_fsrf = iwe2_fsrf/density_0*idemix2_fniw_usage + + ! check for total tidal energy that is infused through the surface, see how + ! much is lossed during interpolation and compare with value of the + ! original files + loc_Etot = 0.0_WP + do node=1, myDim_nod2D + loc_Etot = loc_Etot + area(1,node)*iwe2_fsrf(node)*density_0 + end do + call MPI_AllREDUCE(loc_Etot, glb_Etot, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + + if (idemix2_enable_niw) then + if (mype==0) write(*,*) ' ├> read IDEMIX2 niw wave forcing' + do fbin_i =2, nfbin-1 + iwe2_fniw(fbin_i, :) = iwe2_fsrf(:)/(2.0_WP*pi) + end do + iwe2_fsrf(:) = 0.0_WP + else + if (mype==0) write(*,*) ' ├> read IDEMIX2 surface wave forcing' + end if + if (mype==0) write(*,*) ' ├> IDEMIX2 total srf. energy Etot_srf =', glb_Etot*1.0e-12, ' TW' + + else + if (mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: IDEMIX2 NIW/Srf. forcing file not found! ' + write(*,*) ' Required for srf. energy input even when idemix2_enable_niw=.false.!' + write(*,*) ' Cant apply IDEMIX2 vertical mixing parameterisation! ' + write(*,*) ' ├> file: ', trim(idemix2_niwforc_file) + write(*,*) ' └> check: namelist.cvmix, idemix2_niwforc_file & ' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) + end if + end if + + + ! NIWs are super-inertial (ω_niw > |f|), which is essential for their propagation as internal waves. + ! The factor 1.05 ensures the frequency is 5% above the local inertial frequency. + ! Why 1.05? Represents the minimum frequency for NIWs to propagate. Accounts for the Doppler shift + ! from background flows. Physical Context: NIWs are generated by wind events and have frequencies + ! close to f. They can only propagate as internal waves if ω > |f|. + if (idemix2_enable_niw) then + do node = 1, myDim_nod2D+eDim_nod2D + iwe2_omega_niw(node) = max(1.0e-8_WP, abs( 1.05 * mesh%coriolis_node(node) ) ) + end do + end if + t1=MPI_Wtime() + if (mype==0) write(*,*) ' │ └> elapsed time:', t1-t0 + + !_______________________________________________________________________ + ! read idemix bottom near tidal forcing from cesm data set --> file + ! from N. Brüggemann interpoalted to regular grid + if (idemix2_enable_bot) then + t0=MPI_Wtime() + file_exist=.False. + inquire(file=trim(idemix2_botforc_file),exist=file_exist) + if (file_exist) then + if (mype==0) write(*,*) ' ├> read IDEMIX2 near tidal bottom forcing' + call read_other_NetCDF(trim(idemix2_botforc_file), trim(idemix2_botforc_vname), 1, iwe2_fbot_n, .true., .true., partit, mesh) ! | | + ! .true.=NN for missing values ----------------+ | + ! .true.=interpolate to vertices ----------------------+ + + ! make sure forcing is all positive no numerical negative values + iwe2_fbot_n = max(0.0_WP, iwe2_fbot_n) + + ! check for total tidal energy that is infused through the bottom + loc_Etot = 0.0_WP + do node=1, myDim_nod2D + loc_Etot = loc_Etot + area(1,node)*iwe2_fbot_n(node) + end do + call MPI_AllREDUCE(loc_Etot, glb_Etot, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + if (mype==0) write(*,*) " │ └> IDEMIX2 total tidal energy Etot_bot =", glb_Etot*1.0e-12, ' TW' + + ! normalize total tidal energy at bottom with respect to the total + ! tidal energy that is e.g in the original forcing files to accomodate + ! non concerving losses during interpolation. This is only done when + ! in namelist.cvmix: idemix2_botforc_Etot \= 0.0_WP + if (idemix2_botforc_Etot /= 0.0_WP) then + iwe2_fbot_n = iwe2_fbot_n * idemix2_botforc_Etot/glb_Etot + + loc_Etot = 0.0_WP + do node=1, myDim_nod2D + loc_Etot = loc_Etot + area(1,node)*iwe2_fbot_n(node) + end do + call MPI_AllREDUCE(loc_Etot, glb_Etot, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + if (mype==0) write(*,*) " │ └> IDEMIX2 Etot_bot after normalizing =", glb_Etot*1.0e-12, ' TW' + end if + + ! divide by density_0 --> convert from W/m^2 to m^3/s^3 + iwe2_fbot_n = iwe2_fbot_n/density_0 + + else + if (mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: IDEMIX2 bottom forcing file not found! Cant apply IDEMIX' + write(*,*) ' vertical mixing parameterisation! ' + write(*,*) ' ├> file: ', trim(idemix2_botforc_file) + write(*,*) ' └> check: namelist.cvmix, idemix2_botforc_file' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) + end if + end if + t1=MPI_Wtime() + if (mype==0) write(*,*) ' │ └> elapsed time:', t1-t0 + end if !--> if (idemix2_enable_bot) then + +! !_______________________________________________________________________ +! ! read Lee-Wave forcing +! if (idemix2_enable_leew) then +! t0=MPI_Wtime() +! file_exist=.False. +! inquire(file=trim(idemix2_leewforc_file),exist=file_exist) +! if (file_exist) then +! if (mype==0) write(*,*) ' ├> read IDEMIX2 lee wave forcing --> add to bottom forcing' +! call read_other_NetCDF(trim(idemix2_leewforc_file), trim(idemix2_leewforc_vname), 1, iwe2_fleew, .true., .false., partit, mesh) +! +! iwe2_fbot_n = iwe2_fbot_n + iwe2_fleew +! ! | +! ! +-> no division by density_0, Lee wave Forcing +! ! already in units of m^3/s^3 +! else +! if (mype==0) then +! print *, achar(27)//'[33m' +! write(*,*) '____________________________________________________________________' +! write(*,*) ' ERROR: IDEMIX2 Lee-Wave forcing file not found! Cant apply IDEMIX2' +! write(*,*) ' vertical mixing parameterisation! ' +! write(*,*) ' ├> file: ', trim(idemix2_hrmsforc_file) +! write(*,*) ' └> check: namelist.cvmix, idemix2_leewforc_file' +! write(*,*) '____________________________________________________________________' +! print *, achar(27)//'[0m' +! write(*,*) +! call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) +! end if +! end if +! end if ! --> if (idemix2_enable_leew) then + + !_______________________________________________________________________ + ! read idemix HRMS and HLAM forcing --> file + if (idemix2_enable_M2 .or. idemix2_enable_niw ) then + t0=MPI_Wtime() + ! topo_hrms (Root Mean Square Topographic Height), Definition: Measures the roughness or variability of seafloor topography. + ! Units: Meters (m), Role: Represents the standard deviation of seafloor height variations. Used to calculate + ! energy transfer from tides/NIW to internal waves. + file_exist=.False. + inquire(file=trim(idemix2_hrmsforc_file),exist=file_exist) + if (file_exist) then + if (mype==0) write(*,*) ' ├> read IDEMIX2 HRMS forcing' + call read_other_NetCDF(trim(idemix2_hrmsforc_file), trim(idemix2_hrmsforc_vname), 1, iwe2_topo_hrms, .true., .true., partit, mesh) + else + if (mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: IDEMIX2 HRMS forcing file not found! Cant apply IDEMIX2' + write(*,*) ' vertical mixing parameterisation! ' + write(*,*) ' ├> file: ', trim(idemix2_hrmsforc_file) + write(*,*) ' └> check: namelist.cvmix, idemix2_hrmsforc_file' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) + end if + end if + + ! topo_hlam (Topographic Wavelength), Definition: Characteristic horizontal length scale of topographic features. + ! Units: Meters (m), Role: Represents the dominant wavelength of seafloor roughness. Used to normalize the topographic forcing. + file_exist=.False. + inquire(file=trim(idemix2_hlamforc_file),exist=file_exist) + if (file_exist) then + if (mype==0) write(*,*) ' ├> read IDEMIX2 HLAM forcing' + call read_other_NetCDF(trim(idemix2_hlamforc_file), trim(idemix2_hlamforc_vname), 1, iwe2_topo_hlam, .true., .true., partit, mesh) + else + if (mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: IDEMIX2 HLAM forcing file not found! Cant apply IDEMIX2' + write(*,*) ' vertical mixing parameterisation! ' + write(*,*) ' ├> file: ', trim(idemix2_hlamforc_file) + write(*,*) ' └> check: namelist.cvmix, idemix2_hlamforc_file' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) + end if + end if + + ! In the M2 tidal and NIW energy calculations: + ! --> fxc = topo_hrms(i,j)**2 * 2*pi / (1d-12 + topo_lam(i,j)) + ! This term estimates the energy flux from barotropic tides to internal waves. The ratio topo_hrms²/topo_lam represents + ! the topographic "steepness" affecting wave generation. + ! Physical Interpretation: + ! --> High topo_hrms and small topo_lam: Indicates rough, steep topography that efficiently generates internal waves. + ! --> Low topo_hrms and large topo_lam: Indicates smooth, flat topography with minimal wave generation. + ! These parameters are crucial for accurately representing the conversion of barotropic tidal energy to internal + ! waves over rough topography. + + t1=MPI_Wtime() + if (mype==0) write(*,*) ' │ └> elapsed time:', t1-t0 + + end if ! --> if (idemix2_enable_M2 .or. idemix2_enable_niw ) then + + !_______________________________________________________________________ + ! distribute nodal bottom flux across staircase depth levels using cap + ! area fractions: iwe2_fbot(nz,n) = fbot_n * (area(nz-1,n)-area(nz,n)) / area(1,n) + do node = 1, myDim_nod2D+eDim_nod2D + nlu = nlevels_nod2D_min(node) + nln = nlevels_nod2D(node) + do nz = nlu, nln + iwe2_fbot(nz, node) = iwe2_fbot_n(node) * (area(nz-1, node) - area(nz, node)) / area(1, node) + end do + end do + + !_______________________________________________________________________ + ! compute centroid distance from nearset coastal point together with + ! idemix2_shelf_dist defines what is shelf and what not + if (idemix2_enable_M2 .or. idemix2_enable_niw) then + t0=MPI_Wtime() + call compute_dist2coast(iwe2_topo_dist, mesh, partit, 'node') + t1=MPI_Wtime() + if (partit%mype==0) write(*,*) ' └> dist2coast elapsed time:', t1-t0 + end if + !_______________________________________________________________________ + ! compute d/dy of coriolis + do elem = 1, myDim_elem2D + elnodes = elem2d_nodes(:,elem) + iwe2_grady_coriol(elem) = sum(gradient_sca(4:6, elem)*mesh%coriolis_node(elnodes)) + end do + + !_______________________________________________________________________ + ! compute scalar cell volume from top to bottom + call compute_vol_nodB2T_fix(vol_nodB2T, mesh, partit) + + !_______________________________________________________________________ + ! initialise IDEMIX parameters + call cvmix_idemix2_init( & + tau_v = idemix2_tau_v & !IN: vertical dissipation timescale (s) + , tau_h = idemix2_tau_h & !IN: horizontal diffusion timescale (s) + , gamma = idemix2_gamma & !IN: spectral bandwidth parameter + , jstar = idemix2_jstar & !IN: GM76 spectral peak mode number + , mu0 = idemix2_mu0 & !IN: wave-wave interaction coefficient + , nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , shelf_dist = idemix2_shelf_dist & !IN: shelf distance threshold (m) + , tau_niw_shelf = idemix2_tau_niw_shelf & !IN: NIW shelf dissipation timescale (s) + , tau_niw_oce = idemix2_tau_niw_oce & !IN: NIW open-ocean floor timescale (s) + , tau_M2_shelf = idemix2_tau_M2_shelf & !IN: M2 shelf dissipation timescale (s) + , tau_M2_oce = idemix2_tau_M2_oce & !IN: M2 open-ocean floor timescale (s) + , enable_M2 = idemix2_enable_M2 & !IN: activate M2 tidal compartment + , enable_niw = idemix2_enable_niw & !IN: activate NIW compartment + , enable_AB_timestep = idemix2_enable_AB & !IN: use Adams-Bashforth 2nd-order time stepping + , enable_hor_diffusion= idemix2_enable_hor_diff_expl & !IN: enable horizontal Laplacian diffusion + , enable_hor_diff_iter= idemix2_enable_hor_diff_impl_iter & !IN: use iterative horizontal diffusion + , hor_diff_niter = idemix2_hor_diff_niter & !IN: number of horizontal diffusion iterations + ) + + if (partit%mype==0) write(*,*) + end subroutine init_cvmix_idemix2 + + + + ! + ! + ! + !=========================================================================== + ! pre-compute reflective coastal BC lookup tables iwe2_bc_reflect_bin and + ! iwe2_bc_reflect_sgn. Must be called after iwe2_phit is initialised. + ! + ! SETUP (pre-computed once in init_reflect_bc) + ! ───────────────────────────────────────────── + ! LAND │ n_coast ──────edge────── n_int + ! │ sgn=+1 (interior) + ! │ + ! │ iwe2_bc_reflect_bin(edge) = kk (mirror spectral bin) + ! │ iwe2_bc_reflect_sgn(edge) = +1 (coast = ednodes(1)) + subroutine init_reflect_bc( refl_bin & + , refl_sgn & + , refl_src & + , refl_node & + , coast_node & + , partit & + , mesh & + ) + implicit none + type(t_mesh) , intent(in) , target :: mesh + type(t_partit), intent(inout), target :: partit + integer , intent(inout) :: refl_bin(partit%myDim_edge2D) + integer , intent(inout) :: refl_sgn(partit%myDim_edge2D) + real(kind=WP) , intent(inout) :: refl_src(idemix2_nfbin, partit%myDim_nod2D) + logical , intent(inout) :: refl_node(partit%myDim_nod2D+partit%eDim_nod2D) + logical , intent(inout) :: coast_node(partit%myDim_nod2D+partit%eDim_nod2D) + + integer :: edge, n1, n2, n_int, node, kk_bc, fbinj, nfbin + real(kind=WP) :: lon1, lat1, lon2, lat2, lat_mean + real(kind=WP) :: edge_dx, edge_dy, phi_mirror, dist, dist_min + logical, allocatable :: is_coast_node(:) + real(kind=WP), allocatable :: coast_flag(:) + integer :: loc_cnt(3), glb_cnt(3) +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + nfbin = idemix2_nfbin + + ! > refl_bin(edge) stores the MIRROR SPECTRAL BIN for a flagged + ! coast edge. 0 = edge not flagged, BC skipped. + ! + ! > HOW IT IS COMPUTED (init_reflect_bc) + ! For each edge with exactly one coast node: + ! 1. Compute direction FROM coast node BACK INTO the ocean: + ! edge_dx = (lon_interior - lon_coast) * cos(lat_mean) + ! edge_dy = lat_interior - lat_coast + ! 2. phi_mirror = atan2(edge_dy, edge_dx) mapped to [0, 2*pi) + ! 3. kk = interior bin (2..nfbin-1) with angle closest to phi_mirror + ! 4. refl_bin(edge) = kk + ! + ! > HOW IT IS USED (apply_reflect_bc_spctrl): + ! ALL toward-coast bins at this edge (any fbini where sgn*flux > 0) + ! are blocked and their energy reflected into the SAME single bin kk: + ! reflect_src(kk, n_int) += sgn * outflux (for all toward-coast fbini) + ! One kk per edge — an approximation based on the edge-normal geometry. + ! refl_bin(:) = 0 + + ! > refl_sgn(edge) encodes WHICH of the two edge nodes is the coast + ! node, and from that, WHICH flux sign means "toward coast". Each edge has + ! two endpoint nodes: edges(1, edge) and edges(2, edge). The sign convention + ! in the FV scheme is: + ! flux(fbini, edge) > 0 = transport from edges(2) -> edges(1) + ! flux(fbini, edge) < 0 = transport from edges(1) -> edges(2) + ! sgn = +1 --> coast node = edges(1, edge) + ! interior = edges(2, edge) + ! flux toward coast when: flux > 0 + ! sgn = -1 --> coast node = edges(2, edge) + ! interior = edges(1, edge) + ! flux toward coast when: flux < 0 + ! + ! > The single condition: + ! sgn * flux(fbini, edge) > 0 + ! + ! > captures both cases -- it is true whenever the flux is directed toward + ! whichever node is the coast node, regardless of edge orientation. + ! It also determines the interior node n_int: + ! n_int = merge(edges(2, edge), edges(1, edge), sgn == +1) + ! And the reflected energy magnitude is always: + ! sgn * outflux = |outflux| > 0 + ! + ! in both orientations (positive for sgn=+1 with outflux>0, + ! positive for sgn=-1 with outflux<0). + ! refl_sgn(:) = 0 + + ! > refl_src is a 2D scratch array (nfbin, nod2D) used to implement + ! reflective boundary conditions at coastlines for horizontal NIW energy advection. + ! 1. During apply_reflect_bc_spctrl: + ! For every coast-adjacent edge flagged in iwe2_bc_reflect_bin, any flux + ! directed toward the coast node is zeroed out and the blocked energy is + ! accumulated into refl_src(kk, n_int) at the interior node (n_int), + ! with the sign corrected so energy is conserved. + ! 2. After advection in hsintegrate_Ecompart: + ! The accumulated blocked flux is re-injected as a divergence source + ! Edivh += refl_src / vol_s, effectively bouncing the energy back + ! into the interior in bin kk (the mirror/reflected propagation direction). + ! + ! > In short: it is a flux-blocking + re-injection buffer that prevents NIW energy + ! from leaking into land, redirecting it instead into the spectrally mirrored + ! propagation direction at the last ocean node. + ! refl_src(:,:) = 0.0_WP + + ! a node is a coast node if it belongs to at least one boundary edge. + ! exchange_nod propagates coast status to halo nodes whose coast edge + ! lives on a neighbouring MPI task (no logical overload → real proxy). + allocate(is_coast_node(myDim_nod2D+eDim_nod2D)) + allocate(coast_flag(myDim_nod2D+eDim_nod2D)) + coast_flag(:) = 0.0_WP + do edge = 1, myDim_edge2D + if (edge_tri(2, edge) == 0) then + coast_flag(edges(1, edge)) = 1.0_WP + coast_flag(edges(2, edge)) = 1.0_WP + end if + end do + call exchange_nod(coast_flag, partit) + is_coast_node = (coast_flag > 0.5_WP) + deallocate(coast_flag) + + do edge = 1, myDim_edge2D + if (edge_tri(2, edge) == 0) cycle ! skip coast-parallel boundary edges + n1 = edges(1, edge) + n2 = edges(2, edge) + ! only process edges with exactly one coast node + if (is_coast_node(n1) .eqv. is_coast_node(n2)) cycle + + ! rotated model coordinates of the two nodes (lon/lat in radians). + ! Must use coord_nod2D (rotated) NOT geo_coord_nod2D (geographic): + ! the spectral bins phit(k) are in the rotated frame because + ! u_compart = cg*cos(phit) is projected onto edge_cross_dxdy, + ! which is built from coord_nod2D with cos(rotated_lat) metric. + lon1 = coord_nod2D(1, n1); lat1 = coord_nod2D(2, n1) + lon2 = coord_nod2D(1, n2); lat2 = coord_nod2D(2, n2) + lat_mean = 0.5_WP*(lat1 + lat2) + + ! edge direction FROM coast node BACK TO interior node (the reflection direction) + if (is_coast_node(n2)) then + ! coast = n2, interior = n1: reflect direction is n2 -> n1 + edge_dx = (lon1 - lon2) * cos(lat_mean) + edge_dy = lat1 - lat2 + refl_sgn(edge) = -1 ! negative flux = transport n1->n2 = INTO coast + else + ! coast = n1, interior = n2: reflect direction is n1 -> n2 + edge_dx = (lon2 - lon1) * cos(lat_mean) + edge_dy = lat2 - lat1 + refl_sgn(edge) = +1 ! positive flux = transport n2->n1 = INTO coast + end if + + ! mirror angle = direction away from coast, mapped to [0, 2*pi) + phi_mirror = atan2(edge_dy, edge_dx) + if (phi_mirror < 0.0_WP) phi_mirror = phi_mirror + 2.0_WP*pi + + ! find nearest interior spectral bin (skip ghost cells 1 and nfbin) + kk_bc = 2 + dist_min = (iwe2_phit(2) - phi_mirror)**2 + do fbinj = 3, nfbin-1 + dist = (iwe2_phit(fbinj) - phi_mirror)**2 + if (dist < dist_min) then + dist_min = dist + kk_bc = fbinj + end if + end do + refl_bin(edge) = kk_bc + end do + + ! create logical array if node is a reflected boudnary node + refl_node(:) = .false. + do edge = 1, myDim_edge2D + if (refl_bin(edge) == 0) cycle + n_int = merge(edges(2,edge), edges(1,edge), refl_sgn(edge) == +1) + if (n_int <= myDim_nod2D) refl_node(n_int) = .true. + end do + + coast_node = is_coast_node + deallocate(is_coast_node) + + ! global diagnostic: reduce counts across all MPI ranks and print on rank 0 + loc_cnt(1) = count(edge_tri(2, 1:myDim_edge2D) == 0) + loc_cnt(2) = count(refl_bin(1:myDim_edge2D) > 0) + loc_cnt(3) = count(refl_node(1:myDim_nod2D)) + call MPI_AllREDUCE(loc_cnt, glb_cnt, 3, MPI_INTEGER, MPI_SUM, MPI_COMM_FESOM, MPIerr) + if (mype==0) then + write(*,*) ' ├> IDEMIX2 reflective coastal BC lookup table built' + write(*,*) ' │ boundary edges (edge_tri(2)==0) [global] : ', glb_cnt(1) + write(*,*) ' │ coast-adj. interior edges flagged [global] : ', glb_cnt(2) + write(*,*) ' │ coast-adj. interior nodes flagged [global] : ', glb_cnt(3) + end if + end subroutine init_reflect_bc + + + + ! + ! + ! + !=========================================================================== + ! calculate IDEMIX2 internal wave energy and its dissipation + subroutine calc_cvmix_idemix2(istep, partit, mesh) + implicit none + integer, intent(in) :: istep + type(t_mesh), intent(in), target :: mesh + type(t_partit), intent(inout), target :: partit + integer :: node, elem, edge, node_size, elem_size, k, fbini, nfbin + integer :: nz, nln, nl1, nl2, nl12, nu1, nu2, nu12, uln, iter + integer :: elnodes(3), el(2), ednodes(2) + real(kind=WP) :: lat_n_deg, lat_e_deg + real(kind=WP) :: cn, cn_e, cn_gradx_e, cn_grady_e, omega_niw_e + real(kind=WP) :: inv_area, area_third + logical :: topo_shelf=.False. + ! Timing variables + real(kind=WP) :: t_start, t_end, t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10 + real(kind=WP) :: time_params, time_groupvel, time_M2_integ, time_niw_integ + real(kind=WP) :: time_Eiw_vdiff=0.0, time_Eiw_hdiff=0.0, time_waveint=0.0, time_Kv_Av=0.0, time_total=0.0 + +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + node_size = myDim_nod2D + elem_size = myDim_elem2D + nfbin = idemix2_nfbin + + !_______________________________________________________________________ + ! Start total timing + t_start = MPI_Wtime() + + !_______________________________________________________________________ + ! do tau timestepping indices shift (2-slot: ti and tip1 alternate 1<->2) + iwe2_ti = iwe2_tip1 + iwe2_tip1 = 3 - iwe2_ti + + !_______________________________________________________________________ + ! compute scalar cell volume from top to bottom + ! --> if we take not the ALE variying ocean layer into account --> slight + ! numerical drift + ! --> if take the fixed standard levels (zbar) to compute the ocean volume + ! than only normal numerical drift, ocean volume can be computed at + ! initialisation point + ! call compute_vol_nodB2T_hnode(vol_nodB2T, mesh, partit) + + ! compute inverse cell volume for horizontal diffusion; uses Z_3d_n and + ! hnode which change every timestep under ALE, so must be updated here + call compute_vol_wcell(vol_wcelli, mesh, partit) + + !_______________________________________________________________________ + ! 1. Compute IDEMIX2 parameters (cn, alpha_c, v0, c0, tau, struct functions) + t0 = MPI_Wtime() +!$OMP PARALLEL DO PRIVATE(node, lat_n_deg, nln, uln, nz, cn, topo_shelf) + do node=1, myDim_nod2D+eDim_nod2D + !___________________________________________________________________ + uln = ulevels_nod2D(node) + nln = nlevels_nod2D(node) + + !___________________________________________________________________ + ! re-initialse cross spectral velocites, for later accumulation through + ! elemental values + if (idemix2_enable_M2 ) iwe2_M2_w( :,node) = 0.0_WP + if (idemix2_enable_niw) iwe2_niw_w(:,node) = 0.0_WP + + !___________________________________________________________________ + lat_n_deg = geo_coord_nod2D(2,node) / rad + + !___________________________________________________________________ + ! compute baroclinic gravity wave speed + cn=0.0_WP + do nz=uln, nln-1 + cn=cn+hnode(nz,node)*(sqrt(max(bvfreq(nz,node), 0._WP)) + sqrt(max(bvfreq(nz+1,node), 0._WP)))/2._WP + end do + cn = cn/pi * idemix2_scal_cn + cn = max(cn, idemix2_cn_min) + iwe2_cn(node)=cn + + ! + ! + !___________________________________________________________________ + ! 1st. compute idemix2 parameter over the vertical water column and + ! local horizontal parameters on elements !!!: + call cvmix_idemix2_compute_param( & + nlev = nln-uln+1 & !IN: number of active levels + , coriolis = mesh%coriolis_node( node) & !IN: Coriolis parameter (1/s) + , Nsqr = bvfreq( uln:nln, node) & !IN: buoyancy frequency squared (1/s²) + , cn = cn & !IN: first baroclinic mode speed (m/s) + , alpha_c = iwe2_alpha_c(uln:nln, node) & !OUT: wave-wave dissipation rate (1/s) + , c0 = iwe2_c0( uln:nln, node) & !OUT: vertical representative group speed (m/s) + , v0 = iwe2_v0( uln:nln, node) & !OUT: horizontal representative group speed (m/s) + ) + + ! + ! + !___________________________________________________________________ + ! 3rd. compute dissipation time scales and rates + if (idemix2_enable_M2 .or. idemix2_enable_niw) then + if (iwe2_topo_dist(node) <= idemix2_shelf_dist) then + topo_shelf = .True. + else + topo_shelf = .False. + end if + if (idemix2_enable_M2) then + call cvmix_idemix2_compute_compart_interact_tscale(& + dtime = dt & !IN: time step (s) + , lat = lat_n_deg & !IN: latitude (degrees) + , coriolis = mesh%coriolis_node( node) & !IN: Coriolis parameter (1/s) + , cn = cn & !IN: first baroclinic mode speed (m/s) + , zbottom = -zbar_n_bot( node) & !IN: bottom depth, positive (m) + , topo_hrms = iwe2_topo_hrms( node) & !IN: RMS topographic height (m) + , topo_hlam = iwe2_topo_hlam( node) & !IN: characteristic topographic length scale (m) + , topo_shelf = topo_shelf & !IN: .true. if node is on shelf + , omega_compart= iwe2_omega_M2 & !IN: M2 tidal frequency (1/s) + , tau_compart = iwe2_M2_tau( node) & !OUT: M2 bottom scattering timescale (1/s) + , compart_name = 'M2' & !IN: compartment name + ) + call cvmix_idemix2_compute_M2_dissipation( & + lat = lat_n_deg & !IN: latitude (degrees) + , cn = cn & !IN: first baroclinic mode speed (m/s) + , zbottom = -zbar_n_bot( node) & !IN: bottom depth, positive (m) + , alpha_M2_c = iwe2_alpha_M2_c( node) & !OUT: M2 continuous (PSI) dissipation rate (1/s) + ) + end if + if (idemix2_enable_niw) then + call cvmix_idemix2_compute_compart_interact_tscale(& + dtime = dt & !IN: time step (s) + , lat = lat_n_deg & !IN: latitude (degrees) + , coriolis = mesh%coriolis_node( node) & !IN: Coriolis parameter (1/s) + , cn = cn & !IN: first baroclinic mode speed (m/s) + , zbottom = -zbar_n_bot( node) & !IN: bottom depth, positive (m) + , topo_hrms = iwe2_topo_hrms( node) & !IN: RMS topographic height (m) + , topo_hlam = iwe2_topo_hlam( node) & !IN: characteristic topographic length scale (m) + , topo_shelf = topo_shelf & !IN: .true. if node is on shelf + , omega_compart= iwe2_omega_niw( node) & !IN: NIW frequency (lat-dependent, 1/s) + , tau_compart = iwe2_niw_tau( node) & !OUT: NIW bottom scattering timescale (1/s) + , compart_name = 'niw' & !IN: compartment name + ) + end if + end if + + ! + ! + !___________________________________________________________________ + ! 4th. compute structure function for M2 and NIW energy + if ((idemix2_enable_M2) .and. (idemix2_enable_niw)) then + call cvmix_idemix2_compute_vert_struct_fct( & + nlev = nln-uln+1 & !IN: number of active levels + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , coriolis = mesh%coriolis_node( node) & !IN: Coriolis parameter (1/s) + , cn = cn & !IN: first baroclinic mode speed (m/s) + , Nsqr = bvfreq( uln:nln, node) & !IN: buoyancy frequency squared (1/s²) + , omega_M2 = iwe2_omega_M2 & !IN: M2 tidal frequency (1/s) + , omega_niw = iwe2_omega_niw( node) & !IN: NIW frequency, lat-dependent (1/s) + , E_struct_M2 = iwe2_E_M2_struct( uln:nln, node) & !INOUT: M2 energy vertical structure function + , E_struct_niw= iwe2_E_niw_struct(uln:nln, node) & !INOUT: NIW energy vertical structure function + ) + + else if (idemix2_enable_M2) then + call cvmix_idemix2_compute_vert_struct_fct( & + nlev = nln-uln+1 & !IN: number of active levels + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , coriolis = mesh%coriolis_node( node) & !IN: Coriolis parameter (1/s) + , cn = cn & !IN: first baroclinic mode speed (m/s) + , Nsqr = bvfreq( uln:nln, node) & !IN: buoyancy frequency squared (1/s²) + , omega_M2 = iwe2_omega_M2 & !IN: M2 tidal frequency (1/s) + , E_struct_M2 = iwe2_E_M2_struct( uln:nln, node) & !INOUT: M2 energy vertical structure function + ) + + else if (idemix2_enable_niw) then + call cvmix_idemix2_compute_vert_struct_fct( & + nlev = nln-uln+1 & !IN: number of active levels + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , coriolis = mesh%coriolis_node( node) & !IN: Coriolis parameter (1/s) + , cn = cn & !IN: first baroclinic mode speed (m/s) + , Nsqr = bvfreq( uln:nln, node) & !IN: buoyancy frequency squared (1/s²) + , omega_niw = iwe2_omega_niw( node) & !IN: NIW frequency, lat-dependent (1/s) + , E_struct_niw= iwe2_E_niw_struct(uln:nln, node) & !INOUT: NIW energy vertical structure function + ) + + end if + end do ! --> do node=1, myDim_nod2D+eDim_nod2D +!$OMP END PARALLEL DO + t1 = MPI_Wtime() + time_params = t1 - t0 + + !___________________________________________________________________________ + if (idemix2_enable_M2 .or. idemix2_enable_niw) then + !_______________________________________________________________________ + ! 2. Compute idemix2 group velocites for M2 an NIW + t1 = MPI_Wtime() + do elem = 1, myDim_elem2D + nln = nlevels(elem)-1 + uln = ulevels(elem) + elnodes = elem2d_nodes(:,elem) + lat_e_deg = sum(geo_coord_nod2D(2,elnodes)) / (3.0_WP*rad) + area_third = elem_area(elem) / 3.0_WP + if (idemix2_enable_M2) w_M2_e(:) = 0.0_WP + if (idemix2_enable_niw) w_niw_e(:) = 0.0_WP + + !___________________________________________________________________ + ! compute baroclionic gravity wave speed on elements + cn_e = sum(iwe2_cn(elnodes))/3.0 + + ! compute gradient of baroclionic gkdot_x_M2 = sqrt(fxa)/omega_M2*cn_gradxravity wave speed on elements + cn_gradx_e = sum(gradient_sca(1:3,elem)*iwe2_cn(elnodes)) + cn_grady_e = sum(gradient_sca(4:6,elem)*iwe2_cn(elnodes)) + + ! average iwe2_omega_niw to elem + if (idemix2_enable_niw) omega_niw_e = sum(iwe2_omega_niw(elnodes))/3.0 + + !___________________________________________________________________ + if (idemix2_enable_M2) then + call cvmix_idemix2_compute_compart_groupvel( & + nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , coriolis = mesh%coriolis( elem) & !IN: Coriolis parameter at element (1/s) + , coriol_grady = iwe2_grady_coriol( elem) & !IN: meridional gradient of Coriolis (1/(m·s)) + , coslat = mesh%elem_cos( elem) & !IN: cosine of latitude at element + , cn = cn_e & !IN: first baroclinic mode speed at element (m/s) + , cn_gradx = cn_gradx_e & !IN: zonal gradient of cn at element (1/s) + , cn_grady = cn_grady_e & !IN: meridional gradient of cn at element (1/s) + , phit = iwe2_phit & !IN: angular bin edges (rad) + , phiu = iwe2_phiu & !IN: angular bin centres (rad) + , omega_compart= iwe2_omega_M2 & !IN: M2 tidal frequency (1/s) + , u_compart = iwe2_M2_uv(1, :, elem) & !OUT: zonal group velocity per bin (m/s) + , v_compart = iwe2_M2_uv(2, :, elem) & !OUT: meridional group velocity per bin (m/s) + , w_compart = w_M2_e( : ) & !OUT: cross-spectral propagation rate per bin (1/s) + ) + ! --> here w_M2_e and w_niw_e are still on elements but for the proper + ! finite volume advection implementation we need them on nodes ! + do k=1,3 + iwe2_M2_w(:, elnodes(k)) = iwe2_M2_w(:, elnodes(k)) + w_M2_e(:)*area_third + end do + + end if + if (idemix2_enable_niw) then + call cvmix_idemix2_compute_compart_groupvel( & + nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , coriolis = mesh%coriolis( elem) & !IN: Coriolis parameter at element (1/s) + , coriol_grady = iwe2_grady_coriol( elem) & !IN: meridional gradient of Coriolis (1/(m·s)) + , coslat = mesh%elem_cos( elem) & !IN: cosine of latitude at element + , cn = cn_e & !IN: first baroclinic mode speed at element (m/s) + , cn_gradx = cn_gradx_e & !IN: zonal gradient of cn at element (1/s) + , cn_grady = cn_grady_e & !IN: meridional gradient of cn at element (1/s) + , phit = iwe2_phit & !IN: angular bin edges (rad) + , phiu = iwe2_phiu & !IN: angular bin centres (rad) + , omega_compart= omega_niw_e & !IN: NIW frequency, elem-averaged (1/s) + , u_compart = iwe2_niw_uv(1, :, elem) & !OUT: zonal group velocity per bin (m/s) + , v_compart = iwe2_niw_uv(2, :, elem) & !OUT: meridional group velocity per bin (m/s) + , w_compart = w_niw_e( : ) & !OUT: cross-spectral propagation rate per bin (1/s) + ) + + do k=1,3 + iwe2_niw_w(:, elnodes(k)) = iwe2_niw_w(:, elnodes(k)) + w_niw_e(:)*area_third + end do + end if + ! --> at the end we still need to normalize iwe2_M2_w and iwe2_niw_w + ! with the scalararea! + end do ! --> do elem = 1, myDim_elem2D + t2 = MPI_Wtime() + time_groupvel = t2 - t1 + + ! finalize elem2node averaging of iwe2_M2_w and iwe2_niw_w + ! cross spectral exachange has to be related to nodes, since general advection + ! is related to nodes independent of the volume + if (idemix2_enable_M2) then + call exchange_elem_fbin(iwe2_M2_uv, partit) + call exchange_nod_fbin(iwe2_M2_w, partit) + !$OMP PARALLEL DO PRIVATE(node, inv_area) + do node=1, myDim_nod2D+eDim_nod2D + inv_area = 1.0_WP / area(1, node) + iwe2_M2_w(:, node) = iwe2_M2_w(:, node) * inv_area + end do + !$OMP END PARALLEL DO + end if + + if (idemix2_enable_niw) then + call exchange_elem_fbin(iwe2_niw_uv, partit) + call exchange_nod_fbin(iwe2_niw_w, partit) + !$OMP PARALLEL DO PRIVATE(node, inv_area) + do node=1, myDim_nod2D+eDim_nod2D + inv_area = 1.0_WP / area(1, node) + iwe2_niw_w(:, node) = iwe2_niw_w(:, node) * inv_area + end do + !$OMP END PARALLEL DO + end if + + + !_______________________________________________________________________ + ! 3. Horizontal spectral integrate energy compartment E_M2^(n+1) and + ! E_niw^(n+1) equation. + ! dE/dt = -div(vec_u * E) - tau*E + Forc + ! E^(n+1) = E^n + dt*( -div(vec_u^n*E^n) - tau*E^n + Forc^n) + t3 = MPI_Wtime() + if (idemix2_enable_M2) then + if (idemix2_diag_Ecompart) then + call hsintegrate_Ecompart( & + iwe2_ti, iwe2_tip1 & ! IN: current and next time indices + , 'M2' & ! IN: compartment name + , iwe2_E_M2 & ! INOUT: energy array [2,nfbin,node] + , iwe2_E_M2_divh & ! INOUT: horizontal divergence flux accumulator + , iwe2_E_M2_divs & ! INOUT: cross-spectral divergence accumulator + , iwe2_M2_uv & ! IN: horizontal group velocities on elements + , iwe2_M2_w & ! INOUT: cross-spectral propagation speed on nodes + , iwe2_fM2 & ! IN: M2 tidal surface forcing + , iwe2_M2_tau & ! IN: M2 dissipation timescale per node + , iwe2_dphit & ! IN: angular bin widths + , iwe2_gradxy_e & ! INOUT: energy gradient on elements (work array) + , iwe2_gradxy_n & ! INOUT: energy gradient on nodes (work array) + , iwe2_flx_uv & ! INOUT: horizontal edge flux (work array) + , iwe2_flx_w & ! INOUT: cross-spectral flux (work array) + , iwe2_refl_bin & ! IN: mirror bin lookup table + , iwe2_refl_sgn & ! IN: coast edge sign + , iwe2_refl_src & ! INOUT: reflect source accumulator + , iwe2_refl_node & ! IN: coast-adjacent node mask + , vol_nodB2T & ! IN: scalar cell volumes bottom-to-top + , partit & ! INOUT + , mesh & ! IN + , idemix2_enable_AB & ! IN: enable AB2 time stepping + , iwe2_E_M2_dt & ! INOUT: optional diagnostic: total tendency + , iwe2_E_M2_advh & ! INOUT: optional diagnostic: horiz. advection + , iwe2_E_M2_advs & ! INOUT: optional diagnostic: spectral advection + , iwe2_E_M2_diss & ! INOUT: optional diagnostic: dissipation + , iwe2_E_M2_forc & ! INOUT: optional diagnostic: forcing + , iwe2_E_M2_refl & ! INOUT: optional diagnostic: coast reflection + ) + else + call hsintegrate_Ecompart( & + iwe2_ti, iwe2_tip1 & ! IN: current and next time indices + , 'M2' & ! IN: compartment name + , iwe2_E_M2 & ! INOUT: energy array [2,nfbin,node] + , iwe2_E_M2_divh & ! INOUT: horizontal divergence flux accumulator + , iwe2_E_M2_divs & ! INOUT: cross-spectral divergence accumulator + , iwe2_M2_uv & ! IN: horizontal group velocities on elements + , iwe2_M2_w & ! INOUT: cross-spectral propagation speed on nodes + , iwe2_fM2 & ! IN: M2 tidal surface forcing + , iwe2_M2_tau & ! IN: M2 dissipation timescale per node + , iwe2_dphit & ! IN: angular bin widths + , iwe2_gradxy_e & ! INOUT: energy gradient on elements (work array) + , iwe2_gradxy_n & ! INOUT: energy gradient on nodes (work array) + , iwe2_flx_uv & ! INOUT: horizontal edge flux (work array) + , iwe2_flx_w & ! INOUT: cross-spectral flux (work array) + , iwe2_refl_bin & ! IN: mirror bin lookup table + , iwe2_refl_sgn & ! IN: coast edge sign + , iwe2_refl_src & ! INOUT: reflect source accumulator + , iwe2_refl_node & ! IN: coast-adjacent node mask + , vol_nodB2T & ! IN: scalar cell volumes bottom-to-top + , partit & ! INOUT + , mesh & ! IN + , idemix2_enable_AB & ! IN: enable AB2 time stepping + ) + end if + ! Compute global total NIW energy for conservation check + ! call check_global_energy(iwe2_E_M2, iwe2_tip1, iwe2_dphit, vol_nodB2T, iwe2_fM2, iwe2_M2_tau, partit, mesh, 'M2') + ! call check_flux_conservation( iwe2_E_niw_divh, iwe2_E_niw_divs, iwe2_ti, iwe2_dphit, vol_nodB2T, partit, mesh, 'M2') + end if + t4 = MPI_Wtime() + time_M2_integ = t4 - t3 + + t4 = MPI_Wtime() + if (idemix2_enable_niw) then + ! create complete Ecomaprt diagnostic + if (idemix2_diag_Ecompart) then + call hsintegrate_Ecompart( & + iwe2_ti, iwe2_tip1 & ! IN: current and next time indices + , 'NIW' & ! IN: compartment name + , iwe2_E_niw & ! INOUT: energy array [2,nfbin,node] + , iwe2_E_niw_divh & ! INOUT: horizontal divergence flux accumulator + , iwe2_E_niw_divs & ! INOUT: cross-spectral divergence accumulator + , iwe2_niw_uv & ! IN: horizontal group velocities on elements + , iwe2_niw_w & ! INOUT: cross-spectral propagation speed on nodes + , iwe2_fniw & ! IN: NIW surface forcing + , iwe2_niw_tau & ! IN: NIW dissipation timescale per node + , iwe2_dphit & ! IN: angular bin widths + , iwe2_gradxy_e & ! INOUT: energy gradient on elements (work array) + , iwe2_gradxy_n & ! INOUT: energy gradient on nodes (work array) + , iwe2_flx_uv & ! INOUT: horizontal edge flux (work array) + , iwe2_flx_w & ! INOUT: cross-spectral flux (work array) + , iwe2_refl_bin & ! IN: mirror bin lookup table + , iwe2_refl_sgn & ! IN: coast edge sign + , iwe2_refl_src & ! INOUT: reflect source accumulator + , iwe2_refl_node & ! IN: coast-adjacent node mask + , vol_nodB2T & ! IN: scalar cell volumes bottom-to-top + , partit & ! INOUT + , mesh & ! IN + , idemix2_enable_AB & ! IN: enable AB2 time stepping + , iwe2_E_niw_dt & ! INOUT: optional diagnostic: total tendency + , iwe2_E_niw_advh & ! INOUT: optional diagnostic: horiz. advection + , iwe2_E_niw_advs & ! INOUT: optional diagnostic: spectral advection + , iwe2_E_niw_diss & ! INOUT: optional diagnostic: dissipation + , iwe2_E_niw_forc & ! INOUT: optional diagnostic: forcing + , iwe2_E_niw_refl & ! INOUT: optional diagnostic: coast reflection + ) + else + call hsintegrate_Ecompart( & + iwe2_ti, iwe2_tip1 & ! IN: current and next time indices + , 'NIW' & ! IN: compartment name + , iwe2_E_niw & ! INOUT: energy array [2,nfbin,node] + , iwe2_E_niw_divh & ! INOUT: horizontal divergence flux accumulator + , iwe2_E_niw_divs & ! INOUT: cross-spectral divergence accumulator + , iwe2_niw_uv & ! IN: horizontal group velocities on elements + , iwe2_niw_w & ! INOUT: cross-spectral propagation speed on nodes + , iwe2_fniw & ! IN: NIW surface forcing + , iwe2_niw_tau & ! IN: NIW dissipation timescale per node + , iwe2_dphit & ! IN: angular bin widths + , iwe2_gradxy_e & ! INOUT: energy gradient on elements (work array) + , iwe2_gradxy_n & ! INOUT: energy gradient on nodes (work array) + , iwe2_flx_uv & ! INOUT: horizontal edge flux (work array) + , iwe2_flx_w & ! INOUT: cross-spectral flux (work array) + , iwe2_refl_bin & ! IN: mirror bin lookup table + , iwe2_refl_sgn & ! IN: coast edge sign + , iwe2_refl_src & ! INOUT: reflect source accumulator + , iwe2_refl_node & ! IN: coast-adjacent node mask + , vol_nodB2T & ! IN: scalar cell volumes bottom-to-top + , partit & ! INOUT + , mesh & ! IN + , idemix2_enable_AB & ! IN: enable AB2 time stepping + ) + end if + ! Compute global total NIW energy for conservation check + ! call check_global_energy(iwe2_E_niw, iwe2_tip1, iwe2_dphit, vol_nodB2T, iwe2_fniw, iwe2_niw_tau, partit, mesh, 'niw') + ! call check_flux_conservation( iwe2_E_niw_divh, iwe2_E_niw_divs, iwe2_ti, iwe2_dphit, vol_nodB2T, partit, mesh, 'niw') + end if + t5 = MPI_Wtime() + time_niw_integ = t5 - t4 + + end if ! --> if (idemix2_enable_M2 .or. idemix2_enable_niw) then + + + !_______________________________________________________________________ + ! 4. Integrate IDEMIX equation vertical, solve vertical diffusion and + t6 = MPI_Wtime() + ! dissipation part implicitly + ! Eiw^(t+1) = Eiw^(t) + dt*[ d/dz( c_0 * tau_v * d/dz(c_0*E_iw))^(t+1) + ! - alpha_c*Eiw^(t+1) + ! + Forc^(t) ] +!$OMP PARALLEL DO PRIVATE(node, uln, nln) + do node = 1, myDim_nod2D+eDim_nod2D + uln = ulevels_nod2D(node) + nln = nlevels_nod2D(node) + if (idemix2_diag_Eiw .and. node <= myDim_nod2D) then + call cvmix_idemix2_compute_vdiff_vdiss_Eiw( & + nlev = nln-uln+1 & !IN: number of active levels + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dt = dt & !IN: time step (s) + , c0 = iwe2_c0( uln:nln , node) & !IN: first baroclinic mode speed (m/s) + , alpha_c = iwe2_alpha_c( uln:nln , node) & !IN: wave-wave dissipation rate (1/s) + , fsrf = iwe2_fsrf( node) & !IN: surface IW energy flux (m²/s³) + , fbot = iwe2_fbot( uln:nln , node) & !IN: bottom tidal energy flux (m²/s³) + , Eiw_maxthresh = idemix2_Eiw_maxthresh & !IN: + , Eiw_old = iwe2_E_iw(uln:nln , node, iwe2_ti) & !IN: IW energy at current time (m²/s²) + , Eiw_new = iwe2_E_iw(uln:nln , node, iwe2_tip1) & !OUT: IW energy at next time (m²/s²) + , Eiw_diss = iwe2_E_iw_diss( uln:nln , node) & !OUT: IW dissipation rate for TKE coupling (m²/s³) + , Eiw_dt = iwe2_E_iw_dt( uln:nln , node) & !OUT: optional diagnostic: total tendency + , Eiw_vdif = iwe2_E_iw_vdif( uln:nln , node) & !OUT: optional diagnostic: vertical diffusion tendency + , Eiw_srf = iwe2_E_iw_fsrf( node) & !OUT: optional diagnostic: surface forcing + , Eiw_bot = iwe2_E_iw_fbot( uln:nln , node) & !OUT: optional diagnostic: bottom forcing + ) + else + call cvmix_idemix2_compute_vdiff_vdiss_Eiw( & + nlev = nln-uln+1 & !IN: number of active levels + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dt = dt & !IN: time step (s) + , c0 = iwe2_c0( uln:nln , node) & !IN: first baroclinic mode speed (m/s) + , alpha_c = iwe2_alpha_c( uln:nln , node) & !IN: wave-wave dissipation rate (1/s) + , fsrf = iwe2_fsrf( node) & !IN: surface IW energy flux (m²/s³) + , fbot = iwe2_fbot( uln:nln , node) & !IN: bottom tidal energy flux (m²/s³) + , Eiw_maxthresh = idemix2_Eiw_maxthresh & !IN: + , Eiw_old = iwe2_E_iw(uln:nln, node, iwe2_ti) & !IN: IW energy at current time (m²/s²) + , Eiw_new = iwe2_E_iw(uln:nln, node, iwe2_tip1) & !OUT: IW energy at next time (m²/s²) + , Eiw_diss = iwe2_E_iw_diss( uln:nln , node) & !OUT: IW dissipation rate for TKE coupling (m²/s³) + ) + end if + end do ! --> do node = 1, myDim_nod2D +!$OMP END PARALLEL DO + t7 = MPI_Wtime() + time_Eiw_vdiff = t7 - t6 + + !_______________________________________________________________________ + ! Exchange E_iw(..., tp1) after vertical diffusion - needed for horizontal diffusion gradients + if (idemix2_enable_hor_diff_expl .or. idemix2_enable_hor_diff_impl_iter) then + call exchange_nod(iwe2_E_iw(:, :, iwe2_tip1), partit) + end if + + !_______________________________________________________________________ + ! 5+6. Horizontal Eiw diffusion (explicit single-pass or iterative implicit) + ! Eiw^(t+1) += div_h( v_0 * tau_h * grad_h(v_0 * Eiw) ) + t7 = MPI_Wtime() + ! Diagnostic: capture negated pre-diffusion iwe2_tip1 state. + ! The before/after approach is used for both modes because the iterative + ! implicit call aliases Eiw_old and Eiw to the same array, making any + ! in-subroutine Eiw-Eiw_old difference zero (Fortran aliasing bug). + if ((idemix2_enable_hor_diff_expl .or. idemix2_enable_hor_diff_impl_iter) .and. idemix2_diag_Eiw) then + iwe2_E_iw_hdif = -iwe2_E_iw(:, 1:myDim_nod2D, iwe2_tip1) + end if + + if (idemix2_enable_hor_diff_expl) then + ! Exchange E_iw(...,ti) halo - needed for explicit horizontal diffusion gradients + call exchange_nod(iwe2_E_iw(:, :, iwe2_ti), partit) + call compute_hdiff_Eiw( & + iwe2_E_iw(:, :, iwe2_ti) & ! IN: IW energy at current time + , iwe2_E_iw(:, :, iwe2_tip1)& ! INOUT: IW energy updated by horizontal diffusion + , iwe2_v0 & ! IN: first baroclinic mode group speed (m/s) + , 1 & ! IN: number of horizontal diffusion iterations + , partit & ! INOUT + , mesh & ! IN + ) + end if + + if (idemix2_enable_hor_diff_impl_iter) then + do iter=1, idemix2_hor_diff_niter + call compute_hdiff_Eiw( & + iwe2_E_iw(:, :, iwe2_tip1) & ! IN: IW energy from previous iteration + , iwe2_E_iw(:, :, iwe2_tip1) & ! INOUT: IW energy updated in-place (iterative) + , iwe2_v0 & ! IN: first baroclinic mode group speed (m/s) + , idemix2_hor_diff_niter & ! IN: total number of diffusion iterations + , partit & ! INOUT + , mesh & ! IN + ) + call exchange_nod(iwe2_E_iw(:, :, iwe2_tip1), partit) + end do + end if + + ! Diagnostic: iwe2_E_iw_hdif = (Eiw_after - Eiw_before) / dt [m²/s³] + if ((idemix2_enable_hor_diff_expl .or. idemix2_enable_hor_diff_impl_iter) .and. idemix2_diag_Eiw) then + do node = 1, myDim_nod2D + uln = ulevels_nod2D(node) + nln = nlevels_nod2D(node) + iwe2_E_iw_hdif(uln:nln, node) = (iwe2_E_iw_hdif(uln:nln, node) & + + iwe2_E_iw(uln:nln, node, iwe2_tip1)) / dt + iwe2_E_iw_dt(uln:nln, node) = iwe2_E_iw_dt(uln:nln, node) & + + iwe2_E_iw_hdif(uln:nln, node) + end do + end if + t8 = MPI_Wtime() + time_Eiw_hdiff = t8 - t7 + + !_______________________________________________________________________ + ! 7. compute wave-wave interaction + t8 = MPI_Wtime() + if (idemix2_enable_M2 .or. idemix2_enable_niw) then +!$OMP PARALLEL DO PRIVATE(node, uln, nln) + do node = 1, myDim_nod2D+eDim_nod2D + uln = ulevels_nod2D(node) + nln = nlevels_nod2D(node) + !_______________________________________________________________ + if (idemix2_enable_M2 .and. idemix2_enable_niw) then + if (idemix2_diag_WWI .and. node <= myDim_nod2D) then + call cvmix_idemix2_compute_Eiw_waveinteract( & + nlev = nln-uln+1 & !IN: number of active levels + , nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dphi = iwe2_dphit & !IN: angular bin widths + , dt = dt & !IN: time step (s) + , flag_posdef = .True. & !IN: enforce positive-definiteness + , E_iw_old = iwe2_E_iw( uln:nln, node, iwe2_ti) & !IN: IDEMIX1 IW energy at current time (m²/s²) + , E_iw_new = iwe2_E_iw( uln:nln, node, iwe2_tip1) & !INOUT: IDEMIX1 IW energy updated by wave-wave interaction + , E_M2_old = iwe2_E_M2( : , node, iwe2_ti) & !IN: M2 compartment energy at current time (m²/s²) + , E_M2_new = iwe2_E_M2( : , node, iwe2_tip1) & !INOUT: M2 compartment energy updated + , E_M2_struct = iwe2_E_M2_struct( uln:nln, node) & !IN: M2 vertical structure function + , alpha_M2_c = iwe2_alpha_M2_c( node) & !IN: M2 continuous dissipation rate + , tau_M2 = iwe2_M2_tau( node) & !IN: M2 interaction timescale (s) + , E_niw_old = iwe2_E_niw(: , node, iwe2_ti) & !IN: NIW compartment energy at current time (m²/s²) + , E_niw_new = iwe2_E_niw(: , node, iwe2_tip1) & !INOUT: NIW compartment energy updated + , E_niw_struct = iwe2_E_niw_struct( uln:nln, node) & !IN: NIW vertical structure function + , tau_niw = iwe2_niw_tau( node) & !IN: NIW interaction timescale (s) + , E_iw_dt = iwe2_E_iw_dt( : , node) & !INOUT: optional diagnostic: IDEMIX1 tendency from wave-wave + , E_iw_diss_M2 = iwe2_E_iw_diss_M2( : , node) & !INOUT: optional diagnostic: IDEMIX1 dissipation from M2 + , E_iw_diss_niw = iwe2_E_iw_diss_niw( : , node) & !INOUT: optional diagnostic: IDEMIX1 dissipation from NIW + , E_M2_dt = iwe2_E_M2_dt( : , node) & !INOUT: optional diagnostic: M2 tendency from wave-wave + , E_M2_diss_wwi = iwe2_E_M2_diss_wwi( : , node) & !INOUT: optional diagnostic: M2 dissipation from wave-wave + ) + else + call cvmix_idemix2_compute_Eiw_waveinteract( & + nlev = nln-uln+1 & !IN: number of active levels + , nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dphi = iwe2_dphit & !IN: angular bin widths + , dt = dt & !IN: time step (s) + , flag_posdef = .True. & !IN: enforce positive-definiteness + , E_iw_old = iwe2_E_iw( uln:nln, node, iwe2_ti) & !IN: IDEMIX1 IW energy at current time (m²/s²) + , E_iw_new = iwe2_E_iw( uln:nln, node, iwe2_tip1) & !INOUT: IDEMIX1 IW energy updated by wave-wave interaction + , E_M2_old = iwe2_E_M2( : , node, iwe2_ti) & !IN: M2 compartment energy at current time (m²/s²) + , E_M2_new = iwe2_E_M2( : , node, iwe2_tip1) & !INOUT: M2 compartment energy updated + , E_M2_struct = iwe2_E_M2_struct( uln:nln, node) & !IN: M2 vertical structure function + , alpha_M2_c = iwe2_alpha_M2_c( node) & !IN: M2 continuous dissipation rate + , tau_M2 = iwe2_M2_tau( node) & !IN: M2 interaction timescale (s) + , E_niw_old = iwe2_E_niw(: , node, iwe2_ti) & !IN: NIW compartment energy at current time (m²/s²) + , E_niw_new = iwe2_E_niw(: , node, iwe2_tip1) & !INOUT: NIW compartment energy updated + , E_niw_struct = iwe2_E_niw_struct( uln:nln, node) & !IN: NIW vertical structure function + , tau_niw = iwe2_niw_tau( node) & !IN: NIW interaction timescale (s) + ) + end if + + elseif (idemix2_enable_M2) then + if (idemix2_diag_WWI .and. node <= myDim_nod2D) then + call cvmix_idemix2_compute_Eiw_waveinteract( & + nlev = nln-uln+1 & !IN: number of active levels + , nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dphi = iwe2_dphit & !IN: angular bin widths + , dt = dt & !IN: time step (s) + , flag_posdef = .True. & !IN: enforce positive-definiteness + , E_iw_old = iwe2_E_iw( uln:nln, node, iwe2_ti) & !IN: IDEMIX1 IW energy at current time (m²/s²) + , E_iw_new = iwe2_E_iw( uln:nln, node, iwe2_tip1) & !INOUT: IDEMIX1 IW energy updated by wave-wave interaction + , E_M2_old = iwe2_E_M2( : , node, iwe2_ti) & !IN: M2 compartment energy at current time (m²/s²) + , E_M2_new = iwe2_E_M2( : , node, iwe2_tip1) & !INOUT: M2 compartment energy updated + , E_M2_struct = iwe2_E_M2_struct( uln:nln, node) & !IN: M2 vertical structure function + , alpha_M2_c = iwe2_alpha_M2_c( node) & !IN: M2 continuous dissipation rate + , tau_M2 = iwe2_M2_tau( node) & !IN: M2 interaction timescale (s) + , E_iw_dt = iwe2_E_iw_dt( : , node) & !INOUT: optional diagnostic: IDEMIX1 tendency from wave-wave + , E_iw_diss_M2 = iwe2_E_iw_diss_M2( : , node) & !INOUT: optional diagnostic: IDEMIX1 dissipation from M2 + , E_M2_dt = iwe2_E_M2_dt( : , node) & !INOUT: optional diagnostic: M2 tendency from wave-wave + , E_M2_diss_wwi = iwe2_E_M2_diss_wwi( : , node) & !INOUT: optional diagnostic: M2 dissipation from wave-wave + ) + else + call cvmix_idemix2_compute_Eiw_waveinteract( & + nlev = nln-uln+1 & !IN: number of active levels + , nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dphi = iwe2_dphit & !IN: angular bin widths + , dt = dt & !IN: time step (s) + , flag_posdef = .True. & !IN: enforce positive-definiteness + , E_iw_old = iwe2_E_iw( uln:nln, node, iwe2_ti) & !IN: IDEMIX1 IW energy at current time (m²/s²) + , E_iw_new = iwe2_E_iw( uln:nln, node, iwe2_tip1) & !INOUT: IDEMIX1 IW energy updated by wave-wave interaction + , E_M2_old = iwe2_E_M2( : , node, iwe2_ti) & !IN: M2 compartment energy at current time (m²/s²) + , E_M2_new = iwe2_E_M2( : , node, iwe2_tip1) & !INOUT: M2 compartment energy updated + , E_M2_struct = iwe2_E_M2_struct( uln:nln, node) & !IN: M2 vertical structure function + , alpha_M2_c = iwe2_alpha_M2_c( node) & !IN: M2 continuous dissipation rate + , tau_M2 = iwe2_M2_tau( node) & !IN: M2 interaction timescale (s) + ) + end if + elseif (idemix2_enable_niw) then + if (idemix2_diag_WWI .and. node <= myDim_nod2D) then + call cvmix_idemix2_compute_Eiw_waveinteract( & + nlev = nln-uln+1 & !IN: number of active levels + , nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dphi = iwe2_dphit & !IN: angular bin widths + , dt = dt & !IN: time step (s) + , flag_posdef = .True. & !IN: enforce positive-definiteness + , E_iw_old = iwe2_E_iw( uln:nln, node, iwe2_ti) & !IN: IDEMIX1 IW energy at current time (m²/s²) + , E_iw_new = iwe2_E_iw( uln:nln, node, iwe2_tip1) & !INOUT: IDEMIX1 IW energy updated by wave-wave interaction + , E_niw_old = iwe2_E_niw(: , node, iwe2_ti) & !IN: NIW compartment energy at current time (m²/s²) + , E_niw_new = iwe2_E_niw(: , node, iwe2_tip1) & !INOUT: NIW compartment energy updated + , E_niw_struct = iwe2_E_niw_struct( uln:nln, node) & !IN: NIW vertical structure function + , tau_niw = iwe2_niw_tau( node) & !IN: NIW interaction timescale (s) + , E_iw_dt = iwe2_E_iw_dt( : , node) & !INOUT: optional diagnostic: IDEMIX1 tendency from wave-wave + , E_iw_diss_niw = iwe2_E_iw_diss_niw( : , node) & !INOUT: optional diagnostic: IDEMIX1 dissipation from NIW + ) + else + call cvmix_idemix2_compute_Eiw_waveinteract( & + nlev = nln-uln+1 & !IN: number of active levels + , nfbin = idemix2_nfbin & !IN: number of spectral angular bins + , dzw = hnode( uln:nln-1, node) & !IN: layer thickness (m) + , dphi = iwe2_dphit & !IN: angular bin widths + , dt = dt & !IN: time step (s) + , flag_posdef = .True. & !IN: enforce positive-definiteness + , E_iw_old = iwe2_E_iw( uln:nln, node, iwe2_ti) & !IN: IDEMIX1 IW energy at current time (m²/s²) + , E_iw_new = iwe2_E_iw( uln:nln, node, iwe2_tip1) & !INOUT: IDEMIX1 IW energy updated by wave-wave interaction + , E_niw_old = iwe2_E_niw(: , node, iwe2_ti) & !IN: NIW compartment energy at current time (m²/s²) + , E_niw_new = iwe2_E_niw(: , node, iwe2_tip1) & !INOUT: NIW compartment energy updated + , E_niw_struct = iwe2_E_niw_struct( uln:nln, node) & !IN: NIW vertical structure function + , tau_niw = iwe2_niw_tau( node) & !IN: NIW interaction timescale (s) + ) + end if + end if ! --> (idemix2_enable_M2 .and. idemix2_enable_niw) then + end do ! --> for node = 1, myDim_nod2D +!$OMP END PARALLEL DO + end if ! --> if (idemix2_enable_M2 .or . idemix2_enable_niw) then + t9 = MPI_Wtime() + time_waveint = t9 - t8 + + !_______________________________________________________________________ + ! 8. write IDEMIX2 diffusivities and viscositie to FESOM only when IDEMIX2 is + t9 = MPI_Wtime() + ! used alone --> mostly for debuging --> otherwise TKE Av and Kv are use + if(mix_scheme_nmb==7) then + + !___________________________________________________________________ + ! write out diffusivity --> convert from elem to vertices +!$OMP PARALLEL DO PRIVATE(node, uln, nln) + do node=1, myDim_nod2D + uln = ulevels_nod2D(node) + nln = nlevels_nod2D(node) + !_______________________________________________________________ + ! convert Eiw disspation into Kv and Av on vertices + call cvmix_idemix2_compute_Eiw_diss2KvAv( & + nlev = nln-uln+1 & !IN: number of active levels + , Eiw_diss= iwe2_E_iw_diss(uln:nln, node) & !IN: IW dissipation rate (m²/s³) + , Nsqr = bvfreq( uln:nln, node) & !IN: buoyancy frequency squared (1/s²) + , KappaH = Kv( uln:nln, node) & !INOUT: diapycnal diffusivity (m²/s) + , KappaM = iwe2_Av( uln:nln, node) & !INOUT: vertical viscosity (m²/s) + ) + end do +!$OMP END PARALLEL DO + call exchange_nod(iwe2_Av, partit) + call exchange_nod(Kv , partit) + + !___________________________________________________________________ + ! more idemix2 viscosity from vertices to elements + do elem=1,myDim_elem2D+eDim_elem2D + uln = ulevels(elem) + nln = nlevels(elem) + elnodes = elem2d_nodes(:,elem) + do nz=uln, nln + Av(nz, elem) = sum(iwe2_Av(nz, elnodes))/3.0_WP + end do + end do + + end if + t10 = MPI_Wtime() + time_Kv_Av = t10 - t9 + + !_______________________________________________________________________ + ! Timing report + t_end = MPI_Wtime() + time_total = t_end - t_start + + if (mype==0 .and. mod(istep, logfile_outfreq)==0) then + write(*,*) + write(*,'(A)') ' ___IDEMIX2 EXECUTION TIMES_____________________________' + write(*,'(A, ES10.3, A, F6.2, A)') ' Params (cn,tau,struct) : ', time_params, ' s (', 100.0*time_params/time_total, '%)' + write(*,'(A, ES10.3, A, F6.2, A)') ' Group velocities (u,v,w) : ', time_groupvel, ' s (', 100.0*time_groupvel/time_total, '%)' + write(*,'(A, ES10.3, A, F6.2, A)') ' M2 spectral integration : ', time_M2_integ, ' s (', 100.0*time_M2_integ/time_total, '%)' + write(*,'(A, ES10.3, A, F6.2, A)') ' NIW spectral integration : ', time_niw_integ, ' s (', 100.0*time_niw_integ/time_total, '%)' + write(*,'(A, ES10.3, A, F6.2, A)') ' Eiw vertical diffusion : ', time_Eiw_vdiff, ' s (', 100.0*time_Eiw_vdiff/time_total, '%)' + write(*,'(A, ES10.3, A, F6.2, A)') ' Eiw horizontal diffusion : ', time_Eiw_hdiff, ' s (', 100.0*time_Eiw_hdiff/time_total, '%)' + write(*,'(A, ES10.3, A, F6.2, A)') ' Wave-wave interaction : ', time_waveint, ' s (', 100.0*time_waveint/time_total, '%)' + write(*,'(A, ES10.3, A, F6.2, A)') ' Kv/Av output : ', time_Kv_Av, ' s (', 100.0*time_Kv_Av/time_total, '%)' + write(*,'(A)') ' _______________________________________' + write(*,'(A, ES10.3,A)') ' IDEMIX2 TOTAL time : ', time_total, ' s' + write(*,*) + write(*,*) + end if + + end subroutine calc_cvmix_idemix2 + + + + ! + ! + !___________________________________________________________________________ + ! horizontal superbee advection of spectral bins + subroutine adv_Ecompart_hor_spctrl_superbee(& + vel & + , ttf & + , ttf_grad_n & + , flux & + , partit & + , mesh & + , flag_2ndord_time & + , flag_posdef & + ) + + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit) , intent(inout), target :: partit + type(t_mesh) , intent(in) , target :: mesh + real(kind=WP) , intent(in) :: ttf( idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(in) :: ttf_grad_n(2, idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(in) :: vel(2, idemix2_nfbin, partit%myDim_elem2D+partit%eDim_elem2D) + real(kind=WP) , intent(inout) :: flux( idemix2_nfbin, partit%myDim_edge2D) + logical , intent(in) :: flag_2ndord_time + logical , intent(in) :: flag_posdef + + !___LOCAL VARIABLES_____________________________________________________ + real(kind=WP) :: dx1, dy1, dx2, dy2, dxdy12(2), dt_over_edlen, n_x, n_y, n_len + real(kind=WP) :: u1, u2, v1, v2, Ue, CFL, dh1, dh2 + real(kind=WP) :: R, ttfp2, ttfm1, ttf0, ttfp1, dttf0p1, Tmean1, Tmean2, Cr, vflux, vfabs + integer :: el(2), el2, ednodes(2), edge, fbini, nfbin, nln, uln, nz + logical, parameter :: flag_volfix=.True. +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + !_______________________________________________________________________ + nfbin=idemix2_nfbin + + ! this advection does !!! NOT !!! go over the vertical dimension it goes + ! over the domain of the spectral bins +!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(edge, ednodes, el, el2, fbini, nln, & +!$OMP dx1, dy1, dx2, dy2, dxdy12, dh1, dh2, n_x, n_y, n_len, dt_over_edlen, & +!$OMP u1, v1, u2, v2, Ue, CFL, vflux, vfabs, & +!$OMP ttf0, ttfp1, dttf0p1, ttfp2, ttfm1, R, Cr, Tmean1, Tmean2) +!$OMP DO + do edge=1, myDim_edge2D + !___________________________________________________________________ + ! local indice of nodes that span up edge ed + ednodes= edges(:,edge) + + ! local index of element that contribute to edge + el = edge_tri(:,edge) + + ! edge_cross_dxdy(1:2,ed)... dx,dy distance from center of edge to + ! element centroid el(1) --> needed to calc flux perpedicular to edge from elem el(1) + dx1 = edge_cross_dxdy(1,edge) + dy1 = edge_cross_dxdy(2,edge) + + ! length of edge dx dy + dxdy12 = edge_dxdy(:,edge)*r_earth + + ! compute elemental local bottom depth for volume flux computation + if (flag_volfix) then + nln = nlevels(el(1)) + dh1 = abs(zbar(nln)) + else + uln = ulevels(el(1)) + nln = nlevels(el(1))-1 + dh1 = 0.0_WP + do nz=uln,nln + dh1 = dh1 + helem(nz, el(1)) + end do + end if + + !___________________________________________________________________ + ! same parameter but for other element el(2) that contributes to edge ed + ! if el(2)==0 than edge is boundary edge + dx2 = 0.0_WP + dy2 = 0.0_WP + dh2 = 0.0_WP + el2 = el(1) ! --> just a dummy index here is vel(el2) are multiplied with 0.0_WP + if(el(2)>0) then + el2 = el(2) ! --> dummy replaced with valid el(2), dx2 and dy2 + dx2 = edge_cross_dxdy(3,edge) + dy2 = edge_cross_dxdy(4,edge) + + ! compute elemental local bottom depth for volume flux computation + if (flag_volfix) then + nln = nlevels(el2) + dh2 = abs(zbar(nln)) + else + uln = ulevels(el2) + nln = nlevels(el2)-1 + do nz=uln,nln + dh2 = dh2 + helem(nz, el2) + end do + end if + + dxdy12(1)= dxdy12(1) * (elem_cos(el(1)) + elem_cos(el2)) * 0.5_WP + + ! compute mean edge-segment normal vector + ! (dx1,dy1) + ! ^ + ! │ + ! ├──> (dy1,-dx1) + ! │ + ! ●━━━━━━━━━━━━┿━━━━━━━━━━►● + ! │ + ! (dy2,-dx2) <──┼──> (-dy2,dx2) + ! │ + ! v + ! (dx2,dy2) + ! + n_x = ( dy1 + (-dy2))/2 + n_y = ((-dx1) + dx2 )/2 + + else + dxdy12(1)= dxdy12(1) * elem_cos(el(1)) + ! compute edge-segment normal vector + n_x = dy1 + n_y = -dx1 + end if + dt_over_edlen = dt/sqrt(dxdy12(1)**2 + dxdy12(2)**2) + + ! Normalize normal vector to unit length for CFL calculation + n_len = sqrt(n_x**2 + n_y**2) + n_x = n_x / n_len + n_y = n_y / n_len + + !___________________________________________________________________ + !loop over spectral bins + do fbini = 2, nfbin-1 + !_______________________________________________________________ + ! compute volume flux across the segments from el(1) + ! NOTE: NO dphi here - matches pyOM2 (dphi only in cross-spectral divergence) + u1 = vel(1, fbini, el(1)) + v1 = vel(2, fbini, el(1)) + u2 = vel(1, fbini, el2 ) + v2 = vel(2, fbini, el2 ) + + vflux = (-v1*dx1 + u1*dy1) * dh1 & + + ( v2*dx2 - u2*dy2) * dh2 ! NO * dphi(fbini) + + ! compute approximated edge centered and along edge projected + ! mean velocity --> need to add component to make second order + ! in time + Ue = sqrt((0.5_WP*( u1 + u2 )*n_x)**2 + (0.5_WP*( v1 + v2 )*n_y)**2) + CFL = min(1.0_WP, Ue*dt_over_edlen) + + !_______________________________________________________________ + ! compute tracer difference allong edge + ttf0 = ttf(fbini, ednodes(1)) + ttfp1 = ttf(fbini, ednodes(2)) + dttf0p1 = (ttfp1-ttf0) + + !_______________________________________________________________ + ! tracer Slope Ratio Calculation for upwind augmented point + ! + ! o + ! ○._ .´ `. .-○ + ! | `._ .´ ^ dx1,dy1 .-´ | + ! | `._ .´ ├─> `. .-´ | + ! | □ `●━━━━━━┿━━━━━►●´----□---|-->●ttf_p2 + ! | .-´│`. <─┤ .´│`._ | + ! | .-´ dx2,dy2 v .´ │ `._ | + ! ○.-´ │ `. .´ │ `._○ + ! │ o │ + ! ├------------>┤ + ! │ dxdy12 │ + ! │ │ + ! v v + ! ttf_0 ttf_grad_n_p1 + ! + ttfp2 = ttf0 & + + 2.0_WP * dxdy12(1)*ttf_grad_n(1, fbini, ednodes(2)) & + + 2.0_WP * dxdy12(2)*ttf_grad_n(2, fbini, ednodes(2)) + + ! considering here we want to advect energy we can ensure the + ! variable to be positiv definit + ttfp2 = merge(max(0.0_WP,ttfp2), ttfp2, flag_posdef) + + ! compute tracer slope + R = (ttfp1-ttfp2)/(-dttf0p1+small) + + ! apply superbee limiter + Cr = slimiter_superbee(R) ! DEBUG: force pure upwind (no reconstruction) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dx ]_Limited * dx/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dx ]_Limited * (dx/2 - u_ed*n_ed*dt/2) + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dx ]_Limited * dx/2 *(1 - CFL_h) + ! --> becomes second order in space and time (Direct space-time scheme) + ! --> u_ed = (vel(el(1)) + vel(el(2)))/2 + ! --> n_ed = (n_1 + n_2)/2 + ! --> CFL_h = u_ed*n_ed*dt/dx + Tmean2 = ttfp1 + 0.5_WP * Cr * (-dttf0p1) * (1.0_WP-merge(CFL, 0.0_WP, flag_2ndord_time)) + + !_______________________________________________________________ + ! tracer Slope Ratio Calculation for downwind augmented point + ! + ! o + ! ○._ .´ `. .-○ + ! | `._ .´ ^ dx1,dy1 .-´ | + ! | `._ .´ ├─> `. .-´ | + ! ttf_m1●<--|---□----`●━━━━━━┿━━━━━►●´ □ | + ! | .-´│`. <─┤ .´│`._ | + ! | .-´ dx2,dy2 v .´ │ `._ | + ! ○.-´ │ `. .´ │ `._○ + ! │ o │ + ! ├------------>┤ + ! │ dxdy12 │ + ! │ │ + ! v v + ! ttf_grad_n_0 ttf_p1 + ! + ttfm1 = ttfp1 & + - 2.0_WP * dxdy12(1)*ttf_grad_n(1, fbini, ednodes(1)) & + - 2.0_WP * dxdy12(2)*ttf_grad_n(2, fbini, ednodes(1)) + + ! considering here we want to advect energy we can ensure the + ! variable to be positiv definit + ttfm1 = merge(max(0.0_WP,ttfm1), ttfm1, flag_posdef) + + ! compute tracer slope + R = (ttf0-ttfm1)/(dttf0p1+small) + + ! apply superbee limiter + Cr = slimiter_superbee(R) ! DEBUG: force pure upwind (no reconstruction) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dx ]_Limited * dx/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dx ]_Limited * (dx/2 - u_ed*n_ed*dt/2) + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dx ]_Limited * dx/2 *(1 - CFL_h) + ! --> becomes second order in space and time (Direct space-time scheme) + ! --> u_ed = (vel(el(1)) + vel(el(2)))/2 + ! --> n_ed = (n_1 + n_2)/2 + ! --> CFL_h = u_ed*n_ed*dt/dx + Tmean1 = ttf0 + 0.5_WP * Cr * (dttf0p1) * (1.0_WP-merge(CFL, 0.0_WP, flag_2ndord_time)) + + !_______________________________________________________________ + ! Horizontal flux + vfabs = abs(vflux) + flux(fbini, edge) = -0.5_WP*( & + (vflux+vfabs)*Tmean1+ & + (vflux-vfabs)*Tmean2 & + ) + + end do ! --> for fbini = 1, nfbin + end do !--> do edge=1, myDim_edge2D +!$OMP END DO +!$OMP END PARALLEL + end subroutine adv_Ecompart_hor_spctrl_superbee + + + + ! + ! + !___________________________________________________________________________ + ! reflective coastal boundary condition for horizontal spectral energy flux + ! + ! For every interior edge touching exactly one coast node, any flux directed + ! TOWARD that coast node is blocked and re-injected at the same edge into the + ! mirror spectral bin (bin whose propagation angle points back into the ocean). + ! This conserves total energy: the divergence seen by adv_Ecompart_flx2tra_spctrl + ! has zero net flux at coastal edges. + ! + ! Sign convention (matches adv_Ecompart_flx2tra_spctrl): + ! flux > 0 -> transport from ednodes(2) to ednodes(1) + ! flux < 0 -> transport from ednodes(1) to ednodes(2) + ! + ! iwe2_bc_reflect_sgn(edge) = +1 when ednodes(1) is the coast node + ! = -1 when ednodes(2) is the coast node + ! Transport is INTO the coast when sgn * flux > 0. + !___________________________________________________________________________ + ! + ! EACH TIMESTEP — 4 steps + ! ──────────────────────── + ! + ! STEP 1 │ adv_Ecompart_hor_spctrl_superbee + ! │ + ! │ Computes flux(fbini, edge) for all bins. + ! │ In bin fbini, wave energy at n_int propagates toward coast: + ! │ + ! │ n_coast <━━━━━━━━━━━━━━ n_int + ! │ flux(fbini) > 0 + ! │ (positive = toward n_coast) + ! │ + ! │ Superbee enforces positivity on its own fluxes here. + ! + ! STEP 2 │ apply_reflect_bc_spctrl + ! │ + ! │ For each flagged edge where sgn * flux(fbini) > 0: + ! │ + ! │ flux(fbini, edge) = 0 <- coast-directed flux blocked + ! │ reflect_src(kk, n_int) += sgn * outflux <- energy saved for n_int + ! │ + ! │ n_coast ................ n_int + ! │ flux = 0 (blocked) reflect_src(kk) = |outflux| + ! │ + ! │ Coast node is NEVER written to. + ! │ sgn * outflux = |outflux| > 0 regardless of edge orientation. + ! + ! STEP 3 │ adv_Ecompart_flx2tra_spctrl + ! │ + ! │ Accumulates flux divergence into Edivh, divides by vol_s. + ! │ Bin fbini flux was zeroed -> n_int keeps its energy in fbini, + ! │ n_coast gets nothing. + ! │ + ! │ Edivh(fbini, n_int) = 0 (no export toward coast) + ! │ Edivh(fbini, n_coast)= 0 (nothing received) + ! + ! STEP 4 │ inject reflect_src into Edivh (in hsintegrate_Ecompart) + ! │ + ! │ Edivh(kk, n_int) += reflect_src(kk, n_int) / vol_s(n_int) + ! │ + ! │ Energy appears as a SOURCE at n_int in the mirror bin kk -- + ! │ the reflected wave now propagates AWAY from the coast: + ! │ + ! │ n_coast n_int ━━━━━━━━━━━━> + ! │ bin kk (away from coast) + ! + ! ENERGY BALANCE + ! ────────────── + ! n_coast : gained 0 (fbini blocked) + 0 (not in kk path) = 0 (unchanged) + ! n_int : gained 0 in fbini (blocked) + ! gained |outflux|/vol_s in kk (reflect_src) + ! net total = 0 -> spectral redistribution only (conserved) + ! fbini --> energy blocked at coast, stays at n_int + ! kk <-- same energy re-injected at n_int in mirror direction + ! + subroutine apply_reflect_bc_spctrl( flux & + , refl_src & + , refl_flux & + , refl_bin & + , refl_sgn & + , vol_s & + , partit & + , mesh) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit), intent(inout), target :: partit + type(t_mesh) , intent(in ), target :: mesh + real(kind=WP) , intent(inout) :: flux( idemix2_nfbin, partit%myDim_edge2D) + integer , intent(in ) :: refl_bin( partit%myDim_edge2D) + integer , intent(in ) :: refl_sgn( partit%myDim_edge2D) + real(kind=WP) , intent(out ) :: refl_src( idemix2_nfbin, partit%myDim_nod2D) + real(kind=WP) , intent(out ) :: refl_flux( partit%myDim_nod2D) + real(kind=WP) , intent(in ) :: vol_s( partit%myDim_nod2D+partit%eDim_nod2D) + !___LOCAL VARIABLES_____________________________________________________ + integer :: edge, fbini, kk, nfbin, sgn, n_int + real(kind=WP) :: outflux, ivols_int +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + nfbin = idemix2_nfbin + + refl_src( :,:) = 0.0_WP + refl_flux(:) = 0.0_WP + + ! Zero every coast-directed flux so no energy reaches the coast node. + ! For each blocked flux in bin fbini, accumulate two terms into reflect_src: + ! +sgn*outflux in mirror bin kk (energy gained in reflected direction) + ! -sgn*outflux in source bin fbini (energy lost from incident direction) + ! Net: energy is redistributed fbini→kk at n_int with zero total change. + ! Applied to Edivh after adv_Ecompart_flx2tra_spctrl in hsintegrate_Ecompart. +!$OMP PARALLEL DO PRIVATE(edge, fbini, kk, sgn, n_int, outflux, ivols_int) + do edge = 1, myDim_edge2D + kk = refl_bin(edge) + ! edge is not connected to coast + if (kk == 0) cycle + + ! sgn = +1 --> coast node = edges(1, edge) + ! interior = edges(2, edge) + ! sgn = -1 --> coast node = edges(2, edge) + ! interior = edges(1, edge) + sgn = refl_sgn(edge) + + ! which one is interior coastal edge node + n_int = merge(edges(2, edge), edges(1, edge), sgn == +1) + + ! local scaler volume + ivols_int = 1.0_WP/vol_s(n_int) + + do fbini = 2, nfbin-1 + outflux = flux(fbini, edge)*ivols_int + if (sgn * outflux > 0.0_WP) then + ! block flux towards coast by setting to zero + flux(fbini, edge) = 0.0_WP + if (n_int <= myDim_nod2D) then +!$OMP ATOMIC + refl_src(kk, n_int) = refl_src(kk, n_int) + sgn * outflux +!$OMP ATOMIC + refl_src(fbini, n_int) = refl_src(fbini, n_int) - sgn * outflux +!$OMP ATOMIC + refl_flux(n_int) = refl_flux(n_int) + sgn * outflux + end if + end if + + end do ! --> do fbini = 2, nfbin-1 + end do ! --> do edge = 1, myDim_edge2D +!$OMP END PARALLEL DO + + end subroutine apply_reflect_bc_spctrl + + + + ! + ! + !___________________________________________________________________________ + ! cross spectral superbee advection across spectral bins + subroutine adv_Ecompart_crss_spctrl_superbee( & + cs & ! cross-spectral exchange rate + , ttf & ! Energy compartment @ node + , dphi & ! width spectral bin + , flux & ! cross-spectral flux + , partit & + , mesh & + , flag_2ndord_time & + , flag_posdef & + ! flag_wlimitcfl & + ) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit),intent(inout), target :: partit + type(t_mesh), intent(in) , target :: mesh + real(kind=WP), intent(inout) :: cs( idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(in) :: ttf( idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(in) :: dphi(idemix2_nfbin) + real(kind=WP), intent(inout) :: flux(idemix2_nfbin, partit%myDim_nod2D) + logical , intent(in) :: flag_2ndord_time + logical , intent(in) :: flag_posdef + ! logical , intent(in) :: flag_wlimitcfl + + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, fbini, nfbin + real(kind=WP) :: R, ttf0, ttfp1, dttf0p1, Tmean1, Tmean2, Cr, vflux, vfabs + real(kind=WP) :: CFL !, cflmax=0.50_WP +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + !_______________________________________________________________________ + nfbin=idemix2_nfbin + + !_______________________________________________________________________ +#ifndef ENABLE_OPENACC +!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(node, fbini, & +!$OMP ttf0, ttfp1, dttf0p1, R, Cr, Tmean1, Tmean2, & +!$OMP CFL, vflux, vfabs) +!$OMP DO +#else +!$ACC PARALLEL LOOP GANG DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) +#endif + !_______________________________________________________________________ + ! this advection does !!! NOT !!! go over the vertical dimension it goes + ! over the domain of the spectral bins + do node = 1, myDim_nod2D + + !___________________________________________________________________ + !loop over spectral bins +!$ACC LOOP VECTOR + ! Compute flux at all interfaces (1 to nfbin-1) + ! Bins 1 and nfbin are boundary bins (should have zero energy) + do fbini = 1, nfbin + ! wrap indices pre-computed in init (branch-free, module arrays) + + CFL = abs(cs(fbini, node)) * dt / dphi(fbini) + + !_______________________________________________________________ + ! compute tracer difference + ttf0 = ttf(fbini , node) + ttfp1 = ttf(iwe2_idxp1(fbini) , node) + dttf0p1 = ttfp1 - ttf0 + + !_______________________________________________________________ + ! tracer Slope Ratio Calculation for upwind point + ! compute tracer slope + R = (ttfp1-ttf(iwe2_idxp2(fbini),node))/(-dttf0p1+small) + + ! apply superbee limiter + Cr = slimiter_superbee(R) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dz ]_Limited * dz/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dz ]_Limited * (dz/2 -|W|*dt/2) + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dz ]_Limited * dz/2 *(1 - CFL) + ! --> CFL = W*dt/dx + Tmean2 = ttfp1 + 0.5_WP*Cr*(-dttf0p1) * (1.0_WP-merge(CFL, 0.0_WP, flag_2ndord_time)) + Tmean2 = merge(max(0.0_WP, Tmean2), Tmean2, flag_posdef) + + !_______________________________________________________________ + ! tracer Slope Ratio Calculation for downwind point + ! compute tracer slope + R = (ttf0-ttf(iwe2_idxm1(fbini),node))/(dttf0p1+small) + + ! apply superbee limiter + Cr = slimiter_superbee(R) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dz ]_Limited * dz/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dz ]_Limited * (dz/2 -|W|*dt/2) + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dz ]_Limited * dz/2 *(1 - CFL) + ! --> CFL = W*dt/dx + Tmean1 = ttf0 + 0.5_WP*Cr*(dttf0p1) * (1.0_WP-merge(CFL, 0.0_WP, flag_2ndord_time)) + Tmean1 = merge(max(0.0_WP, Tmean1), Tmean1, flag_posdef) + + !_______________________________________________________________ + ! cross spectral flux matching pyOM2 (NO negative sign, NO area) + vflux = cs(fbini, node) + vfabs = abs(vflux) + flux(fbini, node) = -0.5_WP*( & + (vflux+vfabs)*Tmean1+ & + (vflux-vfabs)*Tmean2 & + ) + + end do !--> do fbini = 1, nfbin +!$ACC END LOOP + end do ! --> do node = 1, myDim_nod2D + +#ifndef ENABLE_OPENACC +!$OMP END DO +!$OMP END PARALLEL +#else + !$ACC END PARALLEL LOOP +#endif + end subroutine adv_Ecompart_crss_spctrl_superbee + + + + ! + ! + !___________________________________________________________________________ + ! superbee slope limiter + pure elemental real(kind=WP) function slimiter_superbee(R) result(Cr) + real(kind=WP), intent(in) :: R + Cr = max( 0._WP, min(1.0_WP, 2.0_WP*R), min(2.0_WP, R) ) + end function slimiter_superbee + + + + ! + ! + !___________________________________________________________________________ + ! build tracer divergence from fluxes + ! + ! dE/dt = -div(vec_u * E) + Forc | *int(dV) + ! E^(n+1)*V^(n+1) - E^n*V^n = dt*( -int_circ( vec_u^n*vec_n*E^n*dA) + Forc*V^n) + ! | + ! |--> V^(n+1) = V^(n) + ! v + ! E^(n+1) = E^(n) + dt/V^n * ( - Flx_hv + Forc*V^n) + ! |--> Flx_hv = Flx_h + Flx_v + subroutine adv_Ecompart_flx2tra_spctrl(& + flx_h & + , flx_v & + , refl_src & + , refl_node & + , div_h & + , div_v & + , dphit & + , vol_s & + , partit & + , mesh & + ) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit), intent(inout), target :: partit + type(t_mesh) , intent(in ), target :: mesh + real(kind=WP) , intent(in) :: flx_h( idemix2_nfbin, partit%myDim_edge2D) + real(kind=WP) , intent(in) :: flx_v( idemix2_nfbin, partit%myDim_nod2D) + real(kind=WP) , intent(inout) :: refl_src(idemix2_nfbin, partit%myDim_nod2D ) + logical , intent(in) :: refl_node( partit%myDim_nod2D+partit%eDim_nod2D ) + + real(kind=WP) , intent(inout) :: div_h( idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(inout) :: div_v( idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(in ) :: dphit( idemix2_nfbin) + real(kind=WP) , intent(in ) :: vol_s(partit%myDim_nod2D+partit%eDim_nod2D) + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, edge, fbini, nfbin, ednodes(2) + real(kind=WP) :: inv_dphi(idemix2_nfbin), ivols_lcl + +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + nfbin = idemix2_nfbin + ! + ! + !_______________________________________________________________________ +#ifndef ENABLE_OPENACC + !$OMP PARALLEL DO COLLAPSE(2) +#else + !$ACC PARALLEL LOOP GANG VECTOR COLLAPSE(2) DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) +#endif + do node=1, myDim_nod2D+eDim_nod2D + do fbini=1, nfbin + div_h(fbini, node)=0.0_WP + div_v(fbini, node)=0.0_WP + end do + end do +#ifndef ENABLE_OPENACC + !$OMP END PARALLEL DO +#else + !$ACC END PARALLEL LOOP +#endif + do fbini=1, nfbin + inv_dphi(fbini) = 1 / dphit(fbini) + end do + ! + ! + !_______________________________________________________________________ + ! Vertical part +#ifndef ENABLE_OPENACC + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(node, edge, ednodes, fbini) + !$OMP DO +#else + !$ACC PARALLEL LOOP GANG DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) +#endif + do node=1, myDim_nod2d + !$ACC LOOP VECTOR + do fbini=2,nfbin-1 + ! Cross-spectral divergence: (flux(fbini) - flux(fbini-1))/dphi + ! flux(fbini) is at interface between fbini and fbini+1 + ! flux(fbini-1) is at interface between fbini-1 and fbini + div_v(fbini,node) = div_v(fbini,node) + (flx_v(fbini,node)-flx_v(fbini-1,node)) * inv_dphi(fbini) + end do + !$ACC END LOOP + end do +#ifndef ENABLE_OPENACC + !$OMP END DO +#else + !$ACC END PARALLEL LOOP +#endif + + ! + ! + !_______________________________________________________________________ + ! Horizontal part +#ifndef ENABLE_OPENACC + !$OMP DO +#else +# if !defined(DISABLE_OPENACC_ATOMICS) + !$ACC PARALLEL LOOP GANG PRIVATE(enodes, el) DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) +# else + !$ACC UPDATE SELF(dttf_h, flux_h) +# endif +#endif + do edge=1, myDim_edge2D + ednodes = edges(:,edge) +#ifndef ENABLE_OPENACC +# if defined(_OPENMP) && !defined(__openmp_reproducible) + call omp_set_lock(partit%plock(ednodes(1))) +# else + !$OMP ORDERED +# endif +#else +# if !defined(DISABLE_OPENACC_ATOMICS) + !$ACC LOOP VECTOR +# endif +#endif + ! + !___________________________________________________________________ + ! horizontal flux contribution to ednode_1 + do fbini=2, nfbin-1 +#if !defined(DISABLE_OPENACC_ATOMICS) + !$ACC ATOMIC UPDATE +#endif + ! Horizontal divergence: flux/area (NO inv_dphi - that's only for cross-spectral!) + div_h(fbini, ednodes(1))=div_h(fbini, ednodes(1))+flx_h(fbini, edge) + + +#ifndef ENABLE_OPENACC +# if defined(_OPENMP) && !defined(__openmp_reproducible) + ! if there is now __openmp or __openmp_reproducible assemble horizontal + ! divergence in one loop + end do + + !___________________________________________________________________ + call omp_unset_lock(partit%plock(ednodes(1))) + call omp_set_lock (partit%plock(ednodes(2))) + + ! + !___________________________________________________________________ + ! horizontal flux contribution to ednode_2 + do fbini=2, nfbin-1 +# endif +#else +# if !defined(DISABLE_OPENACC_ATOMICS) + !$ACC ATOMIC UPDATE +# endif +#endif + ! Horizontal divergence: flux/area (NO inv_dphi - that's only for cross-spectral!) + div_h(fbini,ednodes(2))=div_h(fbini,ednodes(2))-flx_h(fbini,edge) + end do + +#ifndef ENABLE_OPENACC +# if defined(_OPENMP) && !defined(__openmp_reproducible) + call omp_unset_lock(partit%plock(ednodes(2))) +# else + !$OMP END ORDERED +# endif +#else +# if !defined(DISABLE_OPENACC_ATOMICS) + !$ACC END LOOP +# endif +#endif + end do + +#ifndef ENABLE_OPENACC + !$OMP END DO + !$OMP END PARALLEL +#else +# if !defined(DISABLE_OPENACC_ATOMICS) + !$ACC END PARALLEL LOOP +# else + !$ACC UPDATE DEVICE(dttf_h) +# endif +#endif + !_______________________________________________________________________ + ! normalize with total volume of scalar cell from top to bottom +#ifndef ENABLE_OPENACC + ! precompute reciprocal outside inner loop: FP division is ~6x more expensive + ! than multiply on CPU, and the outer loop already saturates thread count + !$OMP PARALLEL DO PRIVATE(ivols_lcl) + do node=1, myDim_nod2d! +eDim_nod2D + ivols_lcl = 1/vol_s(node) + do fbini=2,nfbin-1 + div_h(fbini, node) = div_h(fbini,node)*ivols_lcl + end do + end do + !$OMP END PARALLEL DO +#else + ! on GPU, division throughput is far less asymmetric than on CPU and memory + ! bandwidth dominates; inline division to keep loops perfectly nested for + ! COLLAPSE(2), which gives a flat warp-filling iteration space + !$ACC PARALLEL LOOP GANG VECTOR COLLAPSE(2) DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) + do node=1, myDim_nod2d! +eDim_nod2D + do fbini=2,nfbin-1 + div_h(fbini, node) = div_h(fbini,node)/vol_s(node) + end do + end do + !$ACC END PARALLEL LOOP +#endif + + !_______________________________________________________________________ + ! inject blocked coast fluxes as source at interior nodes in mirror bin +#ifndef ENABLE_OPENACC + !$OMP PARALLEL DO + do node = 1, myDim_nod2D + if (.not. refl_node(node)) cycle + do fbini = 2, nfbin-1 + div_h(fbini, node) = div_h(fbini, node) + refl_src(fbini, node) + end do + end do + !$OMP END PARALLEL DO +#else + ! cycle on outer loop is semantically wrong in a COLLAPSE(2) combined iteration + ! space (would cycle fbini, not node); condition moved inside inner loop — + ! a predicated assignment is GPU-friendly and restores perfect nesting + !$ACC PARALLEL LOOP GANG VECTOR COLLAPSE(2) DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) + do node = 1, myDim_nod2D + do fbini = 2, nfbin-1 + if (refl_node(node)) div_h(fbini, node) = div_h(fbini, node) + refl_src(fbini, node) + end do + end do + !$ACC END PARALLEL LOOP +#endif + + end subroutine adv_Ecompart_flx2tra_spctrl + + + + ! + ! + !___________________________________________________________________________ + ! integrate equation for wave energy compartments + subroutine hsintegrate_Ecompart( & + ti, tip1 & + , Ename & + , E & + , Edivh & + , Edivs & + , vel & + , cs & ! cross-spectral exchange rate phi_dot + , forc & + , tauE & + , dphit & + , gradxy_e & + , gradxy_n & + , flx_uv & + , flx_cs & + , refl_bin & + , refl_sgn & + , refl_src & + , refl_node & + , vol_s & + , partit & + , mesh & + , flag_AB2 & ! to 2nd order Adams-Bashfort on top + , Edt & + , Eadvh & + , Eadvs & + , Ediss & + , Eforc & + , Erefl & + ) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit) , intent(inout), target :: partit + type(t_mesh) , intent(in ), target :: mesh + integer , intent(in ) :: ti, tip1 + character(len=*), intent(in ) :: Ename + real(kind=WP) , intent(inout) :: E( idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D, 2) + real(kind=WP) , intent(inout) :: Edivh(idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D, 2) + real(kind=WP) , intent(inout) :: Edivs(idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D, 2) + real(kind=WP) , intent(in ) :: vel( 2, idemix2_nfbin, partit%myDim_elem2D+partit%eDim_elem2D) + real(kind=WP) , intent(inout) :: cs( idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(in ) :: forc( idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(in ) :: tauE( partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(inout) :: gradxy_e(2, idemix2_nfbin, partit%myDim_elem2D+partit%eDim_elem2D) + real(kind=WP) , intent(inout) :: gradxy_n(2, idemix2_nfbin, partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(in ) :: dphit( idemix2_nfbin) + real(kind=WP) , intent(inout) :: flx_uv( idemix2_nfbin, partit%myDim_edge2D) + real(kind=WP) , intent(inout) :: flx_cs( idemix2_nfbin, partit%myDim_nod2D ) + integer , intent(in ) :: refl_bin( partit%myDim_edge2D ) + integer , intent(in ) :: refl_sgn( partit%myDim_edge2D ) + real(kind=WP) , intent(inout) :: refl_src( idemix2_nfbin, partit%myDim_nod2D ) + logical , intent(in ) :: refl_node( partit%myDim_nod2D +partit%eDim_nod2D) + real(kind=WP) , intent(in ) :: vol_s( partit%myDim_nod2D +partit%eDim_nod2D) + logical , intent(in) :: flag_AB2 + + real(kind=WP) , intent(inout), optional:: Edt( idemix2_nfbin, partit%myDim_nod2D) + real(kind=WP) , intent(inout), optional:: Eadvh( idemix2_nfbin, partit%myDim_nod2D) + real(kind=WP) , intent(inout), optional:: Eadvs( idemix2_nfbin, partit%myDim_nod2D) + real(kind=WP) , intent(inout), optional:: Ediss( idemix2_nfbin, partit%myDim_nod2D) + real(kind=WP) , intent(inout), optional:: Eforc( idemix2_nfbin, partit%myDim_nod2D) + real(kind=WP) , intent(inout), optional:: Erefl( partit%myDim_nod2D) + + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, fbini, nfbin + real(kind=WP) :: inv_denom + real(kind=WP) :: refl_flux(partit%myDim_nod2D) +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + !_______________________________________________________________________ + nfbin=idemix2_nfbin + iwe2_flx_uv(:,:) = 0.0 + iwe2_flx_w( :,:) = 0.0 + + !_______________________________________________________________________ + ! Exchange current timelevel (contiguous with timelevel-last layout) + call exchange_nod_fbin(E(:, :, ti), partit) + + !_______________________________________________________________________ + ! compute gradient of iwe2_E on nodes + call tracer_gradient_elements(E(:,:,ti), gradxy_e, partit, mesh, .False.) + call exchange_elem_fbin(gradxy_e, partit) + call interp_e2n(gradxy_e, gradxy_n, mesh, partit, .False.) + call exchange_nod_fbin(gradxy_n, partit) + + !_______________________________________________________________________ + ! compute horizontal superbee advected tracer flux + call adv_Ecompart_hor_spctrl_superbee( & + vel & + , E(:,:,ti) & + , gradxy_n & + , flx_uv & + , partit & + , mesh & + , .True. & ! do 2nd order in space & time + , .True. & ! enforce positive definit + ) + + ! apply reflective coastal BC: redirect coast-directed fluxes into mirror bins + call apply_reflect_bc_spctrl( flx_uv & + , refl_src & + , refl_flux & + , refl_bin & + , refl_sgn & + , vol_s & + , partit & + , mesh & + ) + + !_______________________________________________________________________ + ! compute cross spectral superbee advected tracer flux + call adv_Ecompart_crss_spctrl_superbee( & + cs & + , E(:,:,ti) & + , dphit & + , flx_cs & + , partit & + , mesh & + , .True. & ! do 2nd order in space & time + , .True. & ! enforce positive definit + ) + + !_______________________________________________________________________ + ! compute flux divergence + call adv_Ecompart_flx2tra_spctrl( & + flx_uv & + ,flx_cs & + ,refl_src & + ,refl_node & + ,Edivh(:,:,ti) & + ,Edivs(:,:,ti) & + ,dphit & + ,vol_s & + ,partit & + ,mesh & + ) + + !_______________________________________________________________________ + ! Eden and Olbers 2014, eq. 2 + ! integrate E_M2^(n+1) = E_M2^(n) + dt*[ + ! - div(c_uv*E_M2^n) --> (the minus is hidden in the flux computation) + ! - d/dphi (dphit/dt*E_M2^n) --> (the minus is hidden in the flux computation) + ! + forc + ! + W + T] + ! + ! eq. 7 & 8: Wave-Wave (T) and Topographic interaction + ! T_M2 + W_M2 = alpha_c_M2*E_M2*int(Eiw*dz) - 1/tau_M2 * E_M2 + ! └───────────┬─────────────┘ + ! └> this part added in wave-wave-interaction + ! T_niw + W_niw = -1/tau_niw * E_niw + ! --> here variable tauE is already 1/tau + + !_______________________________________________________________________ + ! Adams-Bashforth 2nd order + implicit dissipation + if (flag_AB2) then + do node= 1, myDim_nod2d + inv_denom = 1.0_WP / (1.0_WP + dt*tauE(node)) + do fbini=2,nfbin-1 + E(fbini, node, tip1) = ( E(fbini, node, ti) & + + dt * ( & + + (1.5_WP+idemix2_AB_epsilon)*Edivh(fbini, node, ti ) & + - (0.5_WP+idemix2_AB_epsilon)*Edivh(fbini, node, tip1) & + + (1.5_WP+idemix2_AB_epsilon)*Edivs(fbini, node, ti ) & + - (0.5_WP+idemix2_AB_epsilon)*Edivs(fbini, node, tip1) & + + forc(fbini, node) & + ) & + ) * inv_denom + end do + E( 1, node, tip1) = E(nfbin-1, node, tip1) + E(nfbin, node, tip1) = E( 2, node, tip1) + end do + !_______________________________________________________________________ + ! Forward Euler + implicit dissipation + else + do node= 1, myDim_nod2d + inv_denom = 1.0_WP / (1.0_WP + dt*tauE(node)) + do fbini=2,nfbin-1 + E(fbini, node, tip1) = ( E(fbini, node, ti) & + + dt * ( & + + Edivh(fbini, node, ti) & ! div(c_uv*E^n) + + Edivs(fbini, node, ti) & ! d/dphi (w*E^n) + + forc( fbini, node) & ! forc + ) & + ) * inv_denom + end do + E( 1, node, tip1) = E(nfbin-1, node, tip1) + E(nfbin, node, tip1) = E( 2, node, tip1) + end do + end if + + !_______________________________________________________________________ + ! additional diagnostics + if (present(Edt)) Edt(:,:) = (E(:, 1:myDim_nod2D, tip1)-E(:, 1:myDim_nod2D, ti)) / dt + + if (present(Eadvh)) then + if (flag_AB2) then + Eadvh(:,:) = ((1.5+idemix2_AB_epsilon)*Edivh(:, 1:myDim_nod2D, ti ) & + - (0.5+idemix2_AB_epsilon)*Edivh(:, 1:myDim_nod2D, tip1)) + else + Eadvh(:,:) = Edivh(:, 1:myDim_nod2D, ti) + end if + end if + + if (present(Eadvs)) then + if (flag_AB2) then + Eadvs(:,:) = ((1.5+idemix2_AB_epsilon)*Edivs(:, 1:myDim_nod2D, ti ) & + - (0.5+idemix2_AB_epsilon)*Edivs(:, 1:myDim_nod2D, tip1)) + else + Eadvs(:,:) = Edivs(:, 1:myDim_nod2D, ti) + end if + end if + + if (present(Ediss)) then + do node= 1, myDim_nod2d + Ediss(:,node) = - tauE(node)*E(:, node, tip1) + end do + end if + + if (present(Eforc)) Eforc(:,:) = forc(:, 1:myDim_nod2D) + + if (present(Erefl)) Erefl(:) = refl_flux(1:myDim_nod2D) + + end subroutine hsintegrate_Ecompart + + + ! + ! + !___________________________________________________________________________ + ! compute inverse volume of w scalar cell + ! ~~~~~~~~~o zbar_1~~~~~~~~~~ + ! | + ! x Z_1 -------->^ + ! | | + ! o zbar_2, w_2 | h_wcell * areasvol = Vol_wcell --> Vol_wcelli = 1/Vol_wcell + ! | | + ! x Z_2 -------->v + ! | + ! o zbar_3 + ! : + ! : + ! : + ! ---------o zbar_n---------- + ! /////////////////////////// + subroutine compute_vol_wcell(vol_wcelli, mesh, partit) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit) , intent(inout), target :: partit + type(t_mesh) , intent(in ), target :: mesh + real(kind=WP) , intent(inout) :: vol_wcelli(:,:) + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, nz, nln, uln + real(kind=WP) :: dz_trr(mesh%nl) +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + do node = 1, myDim_nod2D + eDim_nod2D + ! number of above bottom levels at node + nln = nlevels_nod2D(node)-1 + uln = ulevels_nod2D(node) + + ! thickness of mid-level to mid-level interface at node + dz_trr = 0.0_WP + dz_trr(uln+1:nln) = Z_3d_n(uln:nln-1,node)-Z_3d_n(uln+1:nln,node) + dz_trr(uln) = hnode(uln,node)/2.0_WP + dz_trr(nln+1) = hnode(nln,node)/2.0_WP + + ! surface cell + vol_wcelli(uln,node) = 1/areasvol(uln,node)/dz_trr(uln) + do nz=uln+1,nln + ! inverse volumne centered around full depth levels + vol_wcelli(nz,node)= 1/areasvol(nz-1,node)/dz_trr(nz) + end do + ! bottom cell + vol_wcelli(nln+1,node) = 1/areasvol(nln,node)/dz_trr(nln+1) + + end do !-->do node = 1,node_size + end subroutine compute_vol_wcell + + + + ! + ! + !___________________________________________________________________________ + ! compute volume of scalar cell from bottom to top + ! ~~~~~~~~~o zbar_1~~~~~~~~~~ + ! | + ! x Z_1 + ! | + ! o zbar_2 + ! | + ! x Z_2 + ! | + ! o zbar_3 + ! : + ! : + ! : + ! ---------o zbar_n---------- + ! /////////////////////////// + subroutine compute_vol_nodB2T_fix(vol_nodB2T, mesh, partit) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit) , intent(inout), target :: partit + type(t_mesh) , intent(in ), target :: mesh + real(kind=WP) , intent(inout) :: vol_nodB2T(partit%myDim_nod2D+partit%eDim_nod2D) + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, elem, nz, nln, uln, elnodes(3) +! real(kind=WP) :: lcl_sumvol, glb_sumvol, vol +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + vol_nodB2T = 0.0_WP +! lcl_sumvol = 0.0_WP + do node = 1, myDim_nod2D + nln = nlevels_nod2D(node)-1 + uln = ulevels_nod2D(node) + do nz=uln,nln +! lcl_sumvol = lcl_sumvol + areasvol(nz,node)*abs(zbar(nz)-zbar(nz+1)) + vol_nodB2T(node) = vol_nodB2T(node) + areasvol(nz,node)*abs(zbar(nz)-zbar(nz+1)) + end do + end do !-->do node = 1,node_size + ! call MPI_Allreduce(lcl_sumvol, glb_sumvol, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + ! if (partit%mype == 0) then + ! write(*,*) ' debug: vol_node_fix: ', glb_sumvol + ! end if + call exchange_nod(vol_nodB2T, partit) + + ! lcl_sumvol = 0.0_WP + ! do elem = 1, myDim_elem2D + ! ! Nodes are uniquely partitioned (e.g., via METIS) — each node belongs + ! ! to exactly one rank Elements are then distributed so that each rank + ! ! has all elements touching its owned nodes — but boundary elements + ! ! necessarily appear on multiple ranks (they share vertices across partitions) + ! elnodes=mesh%elem2D_nodes(:,elem) + ! if (elnodes(1) > myDim_nod2D) cycle + ! nln = nlevels(elem)-1 + ! uln = ulevels(elem) + ! do nz=uln,nln + ! lcl_sumvol = lcl_sumvol + elem_area(elem)*abs(zbar(nz)-zbar(nz+1)) + ! end do + ! end do !-->do node = 1,node_size + ! call MPI_Allreduce(lcl_sumvol, glb_sumvol, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + ! if (partit%mype == 0) then + ! write(*,*) ' debug: vol_elem_fix: ', glb_sumvol + ! end if + + end subroutine compute_vol_nodB2T_fix + + + + ! + ! + !___________________________________________________________________________ + ! compute volume of scalar cell from bottom to top + ! ~~~~~~~~~o zbar_1~~~~~~~~~~ + ! | + ! x Z_1 + ! | + ! o zbar_2 -------+ + ! | | + ! x Z_2 |--------> hnode(2, node) + ! | | + ! o zbar_3--------+ + ! : + ! : + ! : + ! ---------o zbar_n---------- + ! /////////////////////////// + subroutine compute_vol_nodB2T_hnode(vol_nodB2T, mesh, partit) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit) , intent(inout), target :: partit + type(t_mesh) , intent(in ), target :: mesh + real(kind=WP) , intent(inout) :: vol_nodB2T(partit%myDim_nod2D+partit%eDim_nod2D) + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, elem, nz, nln, uln +! real(kind=WP) :: lcl_sumvol, glb_sumvol, vol +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + vol_nodB2T = 0.0_WP + ! lcl_sumvol = 0.0_WP + do node = 1, myDim_nod2D + nln = nlevels_nod2D(node)-1 + uln = ulevels_nod2D(node) + do nz=uln,nln + ! lcl_sumvol = lcl_sumvol + areasvol(nz,node)*hnode(nz,node) + vol_nodB2T(node) = vol_nodB2T(node) + areasvol(nz,node)*hnode(nz,node) + end do + end do !-->do node = 1,node_size + ! call MPI_Allreduce(lcl_sumvol, glb_sumvol, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + ! if (partit%mype == 0) then + ! write(*,*) ' debug: vol_node_hnode: ', glb_sumvol + ! end if + call exchange_nod(vol_nodB2T, partit) + + end subroutine compute_vol_nodB2T_hnode + + + + ! + ! + !___________________________________________________________________________ + ! --> add contribution from horizontal wave propagation + ! Since IDEMIX is used in a global model configuration the vertical + ! internal wave mixing (call cvmix_coeffs_idemix) have to be extended by + ! a lateral diffusion term (see. Olbers D., Eden C., 2013, A Global Model + ! for the Diapycnal Diffusivity Induced Internal Gravity Waves...) + ! + ! diffusion term = div_h( v_0 * idemix_tau_h * grad_h(v_0*E_iw) ) + ! + ! use Gaussian integral satz ... int(div vec_A)dV = ringint(A*vec_n)dA + ! div vec_A = 1/V * sum_i=1...nface( A_i*vec_n_i)*A_i + subroutine compute_hdiff_Eiw( & + Eiw_old , & + Eiw , & + v0 , & + n_hor_iter , & + partit , & + mesh & + ) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_partit) , intent(inout), target :: partit + type(t_mesh) , intent(in ), target :: mesh + real(kind=WP) , intent(in ) :: Eiw_old(:,:) + real(kind=WP) , intent(inout) :: Eiw(:,:) + real(kind=WP) , intent(in ) :: v0(:,:) + integer , intent(in ) :: n_hor_iter + !___LOCAL VARIABLES_____________________________________________________ + integer :: edge, ednodes(2), edel(2), & + elnodes1(3), elnodes2(3), & + node, nz, & + nl1, nl2, nl12, & + nu1, nu2, nu12 + real(kind=WP) :: dz_trr1(mesh%nl), dz_trr2(mesh%nl), & + grad_v0Eiw(2) + real(kind=WP) :: dx1, dx2, dy1, dy2, vflux +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + !_______________________________________________________________________ + ! calculate horizontal diffusion term div( grad(Eiw*v0) * tau_h*v0) + do edge=1,myDim_edge2D + !___________________________________________________________________ + ! ednode ... vertices that form the edge + ednodes = edges(:,edge) + + ! deltaX1,deltaY1 ... cross edge dx and dy for the two elements + ! that contribute to the edge + ! o + ! / \ + ! / \ + ... triangle centroids + ! / + \ x ... edge mid points + ! / ^ \ + ! / |----\--------------->edge_cross_dxdy(1:2,edge) + ! ednodes(1)o-----x-----o ednodes(2) + ! \ |----/--------------->edge_cross_dxdy(3:4,edge) + ! \ v / + ! \ + / + ! \ / + ! \ / + ! o + ! + dx1 = edge_cross_dxdy(1,edge) + dy1 = edge_cross_dxdy(2,edge) + ! el ... elements that contribute to edge + edel = edge_tri(:,edge) + ! elnodes1 ... nodes that contribute to element el(1) + elnodes1 = elem2d_nodes(:,edel(1)) + ! nl1 ... number of layers at element el(1) + nl1 = nlevels(edel(1)) + ! nu1 ... upper index of ocean default = 1 but can consider cavity !=1 + nu1 = ulevels(edel(1)) + + ! thickness of mid-level to mid-level interface of element el(1) + dz_trr1 = 0.0_WP + dz_trr1(nu1) = helem(nu1 ,edel(1))/2.0_WP + do nz = nu1+1, nl1-1 + dz_trr1(nz) = helem(nz-1 ,edel(1))/2.0_WP + helem(nz,edel(1))/2.0_WP + end do + dz_trr1(nl1) = helem(nl1-1,edel(1))/2.0_WP + + !___________________________________________________________________ + ! the same as above but for el(2)--> if el(2)==0 than this edge + ! is a boundary edge and el(2) does not exist + nl2=0 + nu2=0 + if (edel(2)>0) then + dx2 = edge_cross_dxdy(3,edge) + dy2 = edge_cross_dxdy(4,edge) + elnodes2 = elem2d_nodes(:,edel(2)) + nl2 = nlevels(edel(2)) + nu2 = ulevels(edel(2)) + + ! thickness of mid-level to mid-level interface of element el(2) + dz_trr2 = 0.0_WP + dz_trr2(nu2) = helem(nu2 ,edel(2))/2.0_WP + do nz = nu2+1, nl2-1 + dz_trr2(nz) = helem(nz-1 ,edel(2))/2.0_WP + helem(nz,edel(2))/2.0_WP + end do + dz_trr2(nl2) = helem(nl2-1,edel(2))/2.0_WP + endif + + !___________________________________________________________________ + ! common depth levels between elements edel(1) and edel(2) + nl12=min(nl1,nl2) + nu12=max(nu1,nu2) + + !___________________________________________________________________ + ! (A) goes only into this loop when the edge has only facing element + ! el(1) --> so the edge is a boundary edge --> this is for ocean + ! surface in case of cavity + do nz=nu1,nu12-1 + !_______________________________________________________________ + ! --> calc: grad_h(v_0*E_iw) + ! calculate flux from el(1) with respect to edge mid + ! point + grad_v0Eiw(1) = sum(gradient_sca(1:3,edel(1))*v0(nz,elnodes1)*Eiw_old(nz,elnodes1)) + grad_v0Eiw(2) = sum(gradient_sca(4:6,edel(1))*v0(nz,elnodes1)*Eiw_old(nz,elnodes1)) + + ! calculate flux --> grad_v0Eiw is now located on elements + vflux = (grad_v0Eiw(1)*dy1-grad_v0Eiw(2)*dx1)*dz_trr1(nz) + + !_______________________________________________________________ + ! --> calc: v_0*idemix_tau_h* grad_h(v_0*E_iw) + ! multiply vflux with iwe_v0 interpolate to the edge- + ! mid point + vflux = vflux * (v0(nz,ednodes(1))+v0(nz,ednodes(2)))*0.5_WP + + !_______________________________________________________________ + ! --> calc: div(v_0*idemix_tau_h* grad_h(v_0*E_iw)) + ! sum fluxes over the surface --> gaussian integral satz + ! --> keep in mind vol_wcelli is the inverse volume !!! + Eiw(nz,ednodes(1)) = Eiw(nz,ednodes(1)) + dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(1))*vflux + Eiw(nz,ednodes(2)) = Eiw(nz,ednodes(2)) - dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(2))*vflux + end do !-->do nz=nu1,nu12-1 + + !___________________________________________________________________ + ! (B) goes only into this loop when the edge has only facing elemenmt + ! el(2) --> so the edge is a boundary edge --> this is for ocean + ! surface in case of cavity + if (nu2 > 0) then + do nz=nu2,nu12-1 + !___________________________________________________________ + ! --> calc: grad_h(v_0*E_iw) + ! first calculate flux from el(1) with respect to edge mid + ! point + grad_v0Eiw(1) = sum(gradient_sca(1:3,edel(2))*v0(nz,elnodes2)*Eiw_old(nz,elnodes2)) + grad_v0Eiw(2) = sum(gradient_sca(4:6,edel(2))*v0(nz,elnodes2)*Eiw_old(nz,elnodes2)) + + ! calculate flux + vflux = -(grad_v0Eiw(1)*dy2-grad_v0Eiw(2)*dx2)*dz_trr2(nz) + ! |--> minus sign comes from the fact that the the + ! normal vectors (dx1,dy1) and (dx2,dy2) face + ! in opposite direction (Right-Hand-Rule) + + !___________________________________________________________ + ! --> calc: v_0*idemix_tau_h* grad_h(v_0*E_iw) + ! multiply vflux with iwe_v0 interpolate to the edge- + ! mid point + vflux = vflux * (v0(nz,ednodes(1))+v0(nz,ednodes(2)))*0.5_WP + + !___________________________________________________________ + ! --> calc: div(v_0*idemix_tau_h* grad_h(v_0*E_iw)) + ! sum fluxes over the surface --> gaussian integral satz + Eiw(nz,ednodes(1)) = Eiw(nz,ednodes(1)) + dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(1))*vflux + Eiw(nz,ednodes(2)) = Eiw(nz,ednodes(2)) - dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(2))*vflux + + end do !-->do nz=nu2,nu12-1 + end if + + !___________________________________________________________________ + ! (C) goes only into this loop when the edge has two facing elements + ! --> so the edge is not a boundary edge + do nz=nu12,nl12 + !_______________________________________________________________ + ! --> calc: grad_h(v_0*E_iw) + ! calculate grad(iwe*iwe_v0) for el(1) + grad_v0Eiw(1) = sum(gradient_sca(1:3,edel(1))*v0(nz,elnodes1)*Eiw_old(nz,elnodes1)) + grad_v0Eiw(2) = sum(gradient_sca(4:6,edel(1))*v0(nz,elnodes1)*Eiw_old(nz,elnodes1)) + + ! calculate flux --> grad_v0Eiw is now located on elements + vflux = (grad_v0Eiw(1)*dy1-grad_v0Eiw(2)*dx1)*dz_trr1(nz) + + ! calculate grad(iwe*iwe_v0) for el(2) and average for el(1) + ! and el(2) + grad_v0Eiw(1) = sum(gradient_sca(1:3,edel(2))*v0(nz,elnodes2)*Eiw_old(nz,elnodes2)) + grad_v0Eiw(2) = sum(gradient_sca(4:6,edel(2))*v0(nz,elnodes2)*Eiw_old(nz,elnodes2)) + + ! calculate flux + vflux = vflux + -(grad_v0Eiw(1)*dy2-grad_v0Eiw(2)*dx2)*dz_trr2(nz) + + !_______________________________________________________________ + ! --> calc: v_0*idemix_tau_h* grad_h(v_0*E_iw) + ! multiply vflux with iwe_v0 interpolate to the edge- + ! mid point + vflux = vflux * (v0(nz,ednodes(1))+v0(nz,ednodes(2)))*0.5_WP + + !_______________________________________________________________ + ! --> calc: div(v_0*idemix_tau_h* grad_h(v_0*E_iw)) + ! sum fluxes over the surface --> gaussian integral satz + Eiw(nz,ednodes(1)) = Eiw(nz,ednodes(1)) + dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(1))*vflux + Eiw(nz,ednodes(2)) = Eiw(nz,ednodes(2)) - dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(2))*vflux + end do !-->do nz=1,n2 + + !___________________________________________________________________ + ! (D) goes only into this loop when the edge has only facing element + ! el(1) --> so the edge is a boundary edge + do nz=nl12+1,nl1 + !_______________________________________________________________ + ! --> calc: grad_h(v_0*E_iw) + ! calculate flux from el(1) with respect to edge mid + ! point + grad_v0Eiw(1) = sum(gradient_sca(1:3,edel(1))*v0(nz,elnodes1)*Eiw_old(nz,elnodes1)) + grad_v0Eiw(2) = sum(gradient_sca(4:6,edel(1))*v0(nz,elnodes1)*Eiw_old(nz,elnodes1)) + + ! calculate flux + vflux = (grad_v0Eiw(1)*dy1-grad_v0Eiw(2)*dx1)*dz_trr1(nz) + + !_______________________________________________________________ + ! --> calc: v_0*idemix_tau_h* grad_h(v_0*E_iw) + ! multiply vflux with iwe_v0 interpolate to the edge- + ! mid point + vflux = vflux * (v0(nz,ednodes(1))+v0(nz,ednodes(2)))*0.5_WP + + !_______________________________________________________________ + ! --> calc: div(v_0*idemix_tau_h* grad_h(v_0*E_iw)) + ! sum fluxes over the surface --> gaussian integral satz + Eiw(nz,ednodes(1)) = Eiw(nz,ednodes(1)) + dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(1))*vflux + Eiw(nz,ednodes(2)) = Eiw(nz,ednodes(2)) - dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(2))*vflux + end do !-->do nz=nl12+1,nl1 + + !___________________________________________________________________ + ! (E) goes only into this loop when the edge has only facing elemenmt + ! el(2) --> so the edge is a boundary edge + do nz=nl12+1,nl2 + !_______________________________________________________________ + ! --> calc: grad_h(v_0*E_iw) + ! first calculate flux from el(1) with respect to edge mid + ! point + grad_v0Eiw(1) = sum(gradient_sca(1:3,edel(2))*v0(nz,elnodes2)*Eiw_old(nz,elnodes2)) + grad_v0Eiw(2) = sum(gradient_sca(4:6,edel(2))*v0(nz,elnodes2)*Eiw_old(nz,elnodes2)) + + ! calculate flux + vflux = -(grad_v0Eiw(1)*dy2-grad_v0Eiw(2)*dx2)*dz_trr2(nz) + + !_______________________________________________________________ + ! --> calc: v_0*idemix_tau_h* grad_h(v_0*E_iw) + ! multiply vflux with iwe_v0 interpolate to the edge- + ! mid point + vflux = vflux * (v0(nz,ednodes(1))+v0(nz,ednodes(2)))*0.5_WP + + !_______________________________________________________________ + ! --> calc: div(v_0*idemix_tau_h* grad_h(v_0*E_iw)) + ! sum fluxes over the surface --> gaussian integral satz + Eiw(nz,ednodes(1)) = Eiw(nz,ednodes(1)) + dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(1))*vflux + Eiw(nz,ednodes(2)) = Eiw(nz,ednodes(2)) - dt*idemix2_tau_h/n_hor_iter*vol_wcelli(nz,ednodes(2))*vflux + + end do !-->do nz=nl12+1,nl1 + end do !-->do edge=1,myDim_edge2D + + end subroutine compute_hdiff_Eiw + + + + ! + ! + !___________________________________________________________________________ + ! Check if velocity field is divergence-free using gradient_vec operator + subroutine check_Ecompart_div_uv(vel_uv, div_uv, partit, mesh, compartment_name) + implicit none + type(t_partit), intent(inout), target :: partit + type(t_mesh), intent(in), target :: mesh + real(kind=WP), intent(in) :: vel_uv(2, idemix2_nfbin, partit%myDim_elem2D+partit%eDim_elem2D) + real(kind=WP), intent(inout) :: div_uv(idemix2_nfbin, partit%myDim_elem2D+partit%eDim_elem2D) + character(len=*), intent(in) :: compartment_name + + integer :: elem, fbini, j, neighbor_elem + real(kind=WP) :: local_div_sum, global_div_sum, global_div_max + real(kind=WP) :: u_neighbor(idemix2_nfbin), v_neighbor(idemix2_nfbin) + +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + ! Compute divergence of velocity field using gradient_vec operator + ! gradient_vec(1:3, elem) are coefficients for ∂/∂x + ! gradient_vec(4:6, elem) are coefficients for ∂/∂y + do elem = 1, myDim_elem2D + + ! Initialize divergence arrays + div_uv(:, elem) = 0.0_WP + + do j = 1, 3 + neighbor_elem = mesh%elem_neighbors(j, elem) + if (neighbor_elem > 0) then + u_neighbor(:) = vel_uv(1, :, neighbor_elem) + v_neighbor(:) = vel_uv(2, :, neighbor_elem) + else + u_neighbor(:) = vel_uv(1, :, elem) + v_neighbor(:) = vel_uv(2, :, elem) + end if + + do fbini = 2, idemix2_nfbin-1 + ! Compute Total divergence + ! Compute gradients using gradient_vec coefficients + ! ∂u/∂x = Σ(gradient_vec(1:3, elem) * u_neighbor) + ! ∂v/∂y = Σ(gradient_vec(4:6, elem) * v_neighbor) + div_uv(fbini, elem) = div_uv(fbini, elem) & + + (mesh%gradient_vec(j , elem)*u_neighbor(fbini)) & + + (mesh%gradient_vec(j+3, elem)*v_neighbor(fbini)) + end do + end do + end do + + end subroutine check_Ecompart_div_uv + + + + ! + ! + !___________________________________________________________________________ + ! Check flux conservation: sum of all divergences weighted by area should be zero + subroutine check_flux_conservation(div_h, div_s, ti, dphit, vol_s, partit, mesh, compartment_name) + implicit none + type(t_partit), intent(inout), target :: partit + type(t_mesh), intent(in), target :: mesh + real(kind=WP), intent(in) :: div_h(idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D, 3) + real(kind=WP), intent(in) :: div_s(idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D, 3) + integer, intent(in) :: ti + real(kind=WP), intent(in) :: dphit(idemix2_nfbin) + real(kind=WP), intent(in) :: vol_s(partit%myDim_nod2D+partit%eDim_nod2D) + character(len=*), intent(in) :: compartment_name + + integer :: node, fbini, lcl_nedge, glb_nedge + real(kind=WP) :: lcl_divh_sum, lcl_divs_sum + real(kind=WP) :: glb_divh_sum, glb_divs_sum + +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + ! Compute local sum: div * area * dphi + ! For a closed domain with no sources/sinks, this should sum to zero + lcl_divh_sum = 0.0_WP + do node = 1, myDim_nod2D + eDim_nod2D ! Full extended domain: telescoping holds locally per rank + do fbini = 2, idemix2_nfbin-1 ! Exclude ghost bins + lcl_divh_sum = lcl_divh_sum + div_h(fbini, node, ti)*vol_s(node) + end do + end do +! write(*,*) lcl_divh_sum, mype + + lcl_divs_sum = 0.0_WP + do node = 1, myDim_nod2D ! Full extended domain: telescoping holds locally per rank + do fbini = 2, idemix2_nfbin-1 ! Exclude ghost bins + lcl_divs_sum = lcl_divs_sum + div_s(fbini, node, ti)*dphit(fbini) + end do + end do + + ! Sum across all MPI ranks + glb_divh_sum = 0.0_WP + glb_divs_sum = 0.0_WP + call MPI_Allreduce(lcl_divh_sum, glb_divh_sum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + call MPI_Allreduce(lcl_divs_sum, glb_divs_sum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + + if (mype == 0) then + write(*,*) ' debug: flux total conservation check (',trim(compartment_name),'):',& + ' Σ(div_h*vols) = ', glb_divh_sum, & + ', Σ(div_s*dphi) = ', glb_divs_sum + end if + + end subroutine check_flux_conservation + + + + ! + ! + !___________________________________________________________________________ + ! Compute and print global total NIW energy for conservation check + subroutine check_global_energy(Ecompart, ti, dphit, vol_s, forc, tauE, partit, mesh, compartment_name) + implicit none + type(t_partit), intent(inout), target :: partit + type(t_mesh), intent(in), target :: mesh + real(kind=WP), intent(in) :: Ecompart(idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D, 3) + real(kind=WP), intent(in) :: vol_s(partit%myDim_nod2D+partit%eDim_nod2D) + integer, intent(in) :: ti + real(kind=WP), intent(in) :: dphit(idemix2_nfbin) + real(kind=WP), intent(in) :: forc(idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(in) :: tauE(partit%myDim_nod2D+partit%eDim_nod2D) + character(len=*), intent(in) :: compartment_name + + integer :: node, fbini + real(kind=WP) :: lcl_energy, lcl_vol, glb_energy, glb_vol + real(kind=WP) :: lcl_forc, glb_forc, lcl_diss, glb_diss + real(kind=WP) :: lcl_maxE, glb_maxE, lcl_minE, glb_minE + +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + lcl_energy = 0.0_WP + lcl_vol = 0.0_WP + lcl_forc = 0.0_WP + lcl_diss = 0.0_WP + lcl_maxE = -1.0e33 + lcl_minE = 1.0e33 + do node = 1, myDim_nod2D ! Only owned nodes + lcl_vol = lcl_vol + vol_s(node) + do fbini = 2, idemix2_nfbin-1 ! Exclude ghost bins + lcl_energy = lcl_energy + Ecompart(fbini, node, ti) * dphit(fbini) * vol_s(node) + lcl_forc = lcl_forc + forc(fbini, node) * dphit(fbini) * vol_s(node) + lcl_diss = lcl_diss + tauE(node) * Ecompart(fbini, node, ti) * dphit(fbini) * vol_s(node) + lcl_maxE = max(lcl_maxE, Ecompart(fbini, node, ti)) + lcl_minE = min(lcl_minE, Ecompart(fbini, node, ti)) + end do + end do + + ! Sum across all MPI ranks + glb_energy = 0.0_WP + glb_vol = 0.0_WP + glb_forc = 0.0_WP + glb_diss = 0.0_WP + call MPI_Allreduce(lcl_energy, glb_energy, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + call MPI_Allreduce(lcl_vol , glb_vol , 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + call MPI_Allreduce(lcl_forc , glb_forc , 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + call MPI_Allreduce(lcl_diss , glb_diss , 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_FESOM, MPIerr) + call MPI_Allreduce(lcl_minE , glb_minE , 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_FESOM, MPIerr) + call MPI_Allreduce(lcl_maxE , glb_maxE , 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_FESOM, MPIerr) + + + ! Print on rank 0 + if (mype == 0) then + write(*,*) ' debug: global Σ(E_',trim(compartment_name),'*dphi*vols) = ', glb_energy, ' J', & + ', global min(E_',trim(compartment_name),') = ', glb_minE, & + ', global max(E_',trim(compartment_name),') = ', glb_maxE + write(*,*) ' debug: global Σ(forc_',trim(compartment_name),'*dphi*vols) = ', glb_forc, ' W', & + ', global Σ(tau*E_',trim(compartment_name),'*dphi*vols) = ', glb_diss, ' W', & + ', global forc_',trim(compartment_name),'/diss_',trim(compartment_name),' = ', glb_forc/glb_diss, ' W' + end if + + end subroutine check_global_energy + + + ! + !___________________________________________________________________________ + ! Compute and print maximum CFL numbers for horizontal and cross-spectral advection + subroutine check_max_cfl(vel, cs, dphit, partit, mesh, compartment_name) + implicit none + type(t_partit), intent(inout), target :: partit + type(t_mesh), intent(in), target :: mesh + real(kind=WP), intent(in) :: vel(2, idemix2_nfbin, partit%myDim_elem2D+partit%eDim_elem2D) + real(kind=WP), intent(in) :: cs(idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(in) :: dphit(idemix2_nfbin) + character(len=*), intent(in) :: compartment_name + + integer :: edge, fbini, nfbin, node, el(2), el2, ednodes(2) + real(kind=WP) :: dx1, dy1, dx2, dy2, dxdy12(2), edlen, n_x, n_y, n_len + real(kind=WP) :: u1, u2, v1, v2, Ue, CFL_h, CFL_cs + real(kind=WP) :: lcl_cfl_h, glb_cfl_h, lcl_cfl_cs, glb_cfl_cs + +#include "../associate_part_def.h" +#include "../associate_mesh_def.h" +#include "../associate_part_ass.h" +#include "../associate_mesh_ass.h" + + nfbin = idemix2_nfbin + lcl_cfl_h = 0.0_WP + lcl_cfl_cs = 0.0_WP + + ! Max horizontal CFL over all edges + do edge = 1, myDim_edge2D + ednodes = edges(:,edge) + el = edge_tri(:,edge) + + dx1 = edge_cross_dxdy(1,edge) + dy1 = edge_cross_dxdy(2,edge) + dxdy12 = edge_dxdy(:,edge)*r_earth + + el2 = el(1) + dx2 = 0.0_WP + dy2 = 0.0_WP + if (el(2) > 0) then + el2 = el(2) + dx2 = edge_cross_dxdy(3,edge) + dy2 = edge_cross_dxdy(4,edge) + dxdy12(1) = dxdy12(1) * (elem_cos(el(1)) + elem_cos(el2)) * 0.5_WP + n_x = ( dy1 + (-dy2))/2 + n_y = ((-dx1) + dx2 )/2 + else + dxdy12(1) = dxdy12(1) * elem_cos(el(1)) + n_x = dy1 + n_y = -dx1 + end if + edlen = sqrt(dxdy12(1)**2 + dxdy12(2)**2) + n_len = sqrt(n_x**2 + n_y**2) + if (n_len > 0.0_WP) then + n_x = n_x / n_len + n_y = n_y / n_len + end if + + do fbini = 2, nfbin-1 + u1 = vel(1, fbini, el(1)) + v1 = vel(2, fbini, el(1)) + u2 = vel(1, fbini, el2) + v2 = vel(2, fbini, el2) + Ue = sqrt((0.5_WP*(u1+u2)*n_x)**2 + (0.5_WP*(v1+v2)*n_y)**2) + CFL_h = Ue * dt / edlen + lcl_cfl_h = max(lcl_cfl_h, CFL_h) + end do + end do + + ! Max cross-spectral CFL over all nodes and bins + do node = 1, myDim_nod2D + do fbini = 2, nfbin-1 + CFL_cs = abs(cs(fbini, node)) * dt / dphit(fbini) + lcl_cfl_cs = max(lcl_cfl_cs, CFL_cs) + end do + end do + + ! Global max across MPI ranks + glb_cfl_h = 0.0_WP + glb_cfl_cs = 0.0_WP + call MPI_Allreduce(lcl_cfl_h , glb_cfl_h , 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_FESOM, MPIerr) + call MPI_Allreduce(lcl_cfl_cs, glb_cfl_cs, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_FESOM, MPIerr) + + if (mype == 0) then + write(*,*) ' debug: CFL_max_horizontal(',trim(compartment_name),') = ', glb_cfl_h, & + ', CFL_max_cross_spectral(',trim(compartment_name),') = ', glb_cfl_cs +! write(*,*) ' debug: dt_max_FE(',trim(compartment_name),') = ', dt/max(glb_cfl_h, glb_cfl_cs), ' s', & +! ', dt_max_AB2(',trim(compartment_name),') = ', 0.5_WP*dt/max(glb_cfl_h, glb_cfl_cs), ' s' + end if + + end subroutine check_max_cfl + + +! !=========================================================================== +! ! Compute velocity flux divergence consistent with the edge-based Superbee +! ! flux scheme. For tracer h=1, the Superbee flux reduces to -vflux (since +! ! gradients are zero for a constant field). This gives the numerical velocity +! ! divergence as seen by the flux operator. +! ! +! ! Used for compatible transport: E(n+1) = [E(n)+dt*Edivh] / [1+dt*div_vel] +! ! which preserves constant fields exactly while maintaining conservation. +! subroutine compute_vel_div_consistent(vel, div_vel, partit, mesh) +! implicit none +! type(t_partit), intent(inout), target :: partit +! type(t_mesh), intent(in), target :: mesh +! real(kind=WP), intent(in) :: vel(2, idemix2_nfbin, partit%myDim_elem2D+partit%eDim_elem2D) +! real(kind=WP), intent(inout) :: div_vel(idemix2_nfbin, partit%myDim_nod2D+partit%eDim_nod2D) +! +! integer :: edge, fbini, nfbin, node, el(2), el2, ednodes(2) +! real(kind=WP) :: dx1, dy1, dx2, dy2, u1, v1, u2, v2, vflux +! +! #include "../associate_part_def.h" +! #include "../associate_mesh_def.h" +! #include "../associate_part_ass.h" +! #include "../associate_mesh_ass.h" +! +! nfbin = idemix2_nfbin +! div_vel = 0.0_WP +! +! ! Edge loop: compute vflux using SAME geometry as Superbee routine +! do edge = 1, myDim_edge2D +! ednodes = edges(:, edge) +! el = edge_tri(:, edge) +! +! dx1 = edge_cross_dxdy(1, edge) +! dy1 = edge_cross_dxdy(2, edge) +! +! dx2 = 0.0_WP +! dy2 = 0.0_WP +! el2 = el(1) +! if (el(2) > 0) then +! el2 = el(2) +! dx2 = edge_cross_dxdy(3, edge) +! dy2 = edge_cross_dxdy(4, edge) +! end if +! +! do fbini = 2, nfbin-1 +! u1 = vel(1, fbini, el(1)) +! v1 = vel(2, fbini, el(1)) +! u2 = vel(1, fbini, el2) +! v2 = vel(2, fbini, el2) +! +! vflux = (-v1*dx1 + u1*dy1) + (v2*dx2 - u2*dy2) +! +! ! For tracer h=1: flux_h1 = -vflux +! ! Assembly matches Superbee: div(node1) += flux, div(node2) -= flux +! div_vel(fbini, ednodes(1)) = div_vel(fbini, ednodes(1)) - vflux +! div_vel(fbini, ednodes(2)) = div_vel(fbini, ednodes(2)) + vflux +! end do +! end do +! +! ! Assemble halo contributions to owner (same as for div_h) +! call assemble_nod2D_fbin(div_vel, partit) +! ! Distribute complete values to halos +! call exchange_nod_fbin(div_vel, partit) +! ! Normalize by area (same as for div_h) +! do node = 1, myDim_nod2D + eDim_nod2D +! do fbini = 2, nfbin-1 +! div_vel(fbini, node) = div_vel(fbini, node) / areasvol(1, node) +! end do +! end do +! +! end subroutine compute_vel_div_consistent + + +!_______________________________________________________________________________ +! Stage current state into slot 1 before writing restart (call before rotation). +! The two cases are mutually exclusive and complementary: +! tip1==2: fresh E is in slot 2 → copy to slot 1; div already in slot 1 (ti=1) +! tip1==1: fresh E already in slot 1; current div is in slot 2 (ti=2) → copy to slot 1 +! +! the output stream is fixed on location iwe2_E_iw(:, :, 1) thats why we need it to +! update when iwe2_tip1==2 and its a restart writing moment +subroutine prepare_idemix2_restart() + if (iwe2_tip1 == 2) then + iwe2_E_iw(:, :, 1) = iwe2_E_iw(:, :, 2) + if (allocated(iwe2_E_M2)) iwe2_E_M2(:, :, 1) = iwe2_E_M2(:, :, 2) + if (allocated(iwe2_E_niw)) iwe2_E_niw(:, :, 1) = iwe2_E_niw(:, :, 2) + else + if (allocated(iwe2_E_M2)) then + iwe2_E_M2_divh(:, :, 1) = iwe2_E_M2_divh(:, :, 2) + iwe2_E_M2_divs(:, :, 1) = iwe2_E_M2_divs(:, :, 2) + end if + if (allocated(iwe2_E_niw)) then + iwe2_E_niw_divh(:, :, 1) = iwe2_E_niw_divh(:, :, 2) + iwe2_E_niw_divs(:, :, 1) = iwe2_E_niw_divs(:, :, 2) + end if + end if +end subroutine prepare_idemix2_restart + + +!_______________________________________________________________________________ +! After loading restart: slot 1 holds saved E and div. +! E: fill slot 2 for AB bootstrap (iwe2_ti=1,iwe2_tip1=2 at restart init). +! Div: saved div goes to slot 2 (=tip1 at init, read as "previous" on first step); +! slot 1 (=ti) zeroed — it will be overwritten fresh in the first step. +subroutine apply_idemix2_restart() + iwe2_E_iw(:, :, 2) = iwe2_E_iw(:, :, 1) + if (allocated(iwe2_E_M2)) then + iwe2_E_M2(:, :, 2) = iwe2_E_M2(:, :, 1) + iwe2_E_M2_divh(:, :, 2) = iwe2_E_M2_divh(:, :, 1) + iwe2_E_M2_divh(:, :, 1) = 0.0_WP + iwe2_E_M2_divs(:, :, 2) = iwe2_E_M2_divs(:, :, 1) + iwe2_E_M2_divs(:, :, 1) = 0.0_WP + end if + if (allocated(iwe2_E_niw)) then + iwe2_E_niw(:, :, 2) = iwe2_E_niw(:, :, 1) + iwe2_E_niw_divh(:, :, 2) = iwe2_E_niw_divh(:, :, 1) + iwe2_E_niw_divh(:, :, 1) = 0.0_WP + iwe2_E_niw_divs(:, :, 2) = iwe2_E_niw_divs(:, :, 1) + iwe2_E_niw_divs(:, :, 1) = 0.0_WP + end if +end subroutine apply_idemix2_restart + + +end module g_cvmix_idemix2 + diff --git a/src/cvmix_driver/gen_modules_cvmix_tke.F90 b/src/cvmix_driver/gen_modules_cvmix_tke.F90 index 44bdf6866..268405508 100644 --- a/src/cvmix_driver/gen_modules_cvmix_tke.F90 +++ b/src/cvmix_driver/gen_modules_cvmix_tke.F90 @@ -20,6 +20,10 @@ module g_cvmix_tke use cvmix_put_get, only: cvmix_put use cvmix_kinds_and_types use g_cvmix_idemix, only: iwe_n, iwe_Tdis_n, iwe_alpha_c_n + use g_cvmix_idemix2, only: iwe2_E_iw, iwe2_E_iw_diss, iwe2_alpha_c, iwe2_tip1, & + idemix2_smooth_Eiw, idemix2_smooth_Eiw_diss, & + idemix2_smooth_alpha_c, idemix2_smooth_niter + use g_support, only: smooth_nod !___________________________________________________________________________ ! module calls from FESOM @@ -223,7 +227,7 @@ subroutine init_cvmix_tke(partit, mesh) end if !_______________________________________________________________________ - if(mix_scheme_nmb==56) tke_only=.False. + if(mix_scheme_nmb==56 .or. mix_scheme_nmb==57) tke_only=.False. if (mype==0) then write(*,*) " tke_only = ", tke_only @@ -302,9 +306,21 @@ subroutine calc_cvmix_tke(dynamics, partit, mesh) ! load things from idemix when selected if (.not. tke_only) then - tke_in3d_iwe = iwe_n - tke_in3d_iwdis = -iwe_Tdis_n - tke_in3d_iwealphac = iwe_alpha_c_n + if (mod(mix_scheme_nmb,10)==6) then + tke_in3d_iwe = iwe_n + tke_in3d_iwdis = -iwe_Tdis_n + tke_in3d_iwealphac = iwe_alpha_c_n + else if (mod(mix_scheme_nmb,10)==7) then + tke_in3d_iwe = iwe2_E_iw(:,:,iwe2_tip1) + tke_in3d_iwdis = -iwe2_E_iw_diss + tke_in3d_iwealphac = iwe2_alpha_c + ! Smooth TKE-interface copies only — never the prognostic Eiw state. + ! All three arrays are recomputed each step so smoothing here has no + ! memory and does not accumulate: Eiw heterogeneity is fully preserved. + if (idemix2_smooth_Eiw) call smooth_nod(tke_in3d_iwe, idemix2_smooth_niter, partit, mesh) + if (idemix2_smooth_Eiw_diss) call smooth_nod(tke_in3d_iwdis, idemix2_smooth_niter, partit, mesh) + if (idemix2_smooth_alpha_c) call smooth_nod(tke_in3d_iwealphac, idemix2_smooth_niter, partit, mesh) + end if endif !_______________________________________________________________________ diff --git a/src/fesom_module.F90 b/src/fesom_module.F90 index 9ea20678a..7e865240b 100755 --- a/src/fesom_module.F90 +++ b/src/fesom_module.F90 @@ -79,14 +79,25 @@ module fesom_main_storage_module integer :: which_readr ! read which restart files (0=netcdf, 1=core dump,2=dtype) integer :: total_nsteps integer, pointer :: mype, npes, MPIerr, MPI_COMM_FESOM, MPI_COMM_WORLD, MPI_COMM_FESOM_IB - real(kind=WP) :: t0, t1, t2, t3, t4, t5, t6, t7, t8, t0_ice, t1_ice, t0_frc, t1_frc - real(kind=WP) :: rtime_fullice, rtime_write_restart, rtime_write_means, rtime_compute_diag, rtime_read_forcing + real(kind=WP) :: t0, t1, t2, t3, t4, t5, t6, t7, t8 + real(kind=WP) :: t_start , t_end + real(kind=WP) :: t_iceb_s , t_iceb_e , rtime_iceb_full, t_iceb_s0, t_iceb_e0, t_iceb_s1, t_iceb_e1 + real(kind=WP) :: t_ice_s , t_ice_e , rtime_ice_full + real(kind=WP) :: t_ice_o2iflx_s , rtime_ice_o2iflx + real(kind=WP) :: t_ice_rfrc_s , rtime_ice_readforc + real(kind=WP) :: t_ice_step_s , rtime_ice_step, rtime_ice_step_evp, rtime_ice_adv, rtime_ice_therm + real(kind=WP) :: t_ice_oflx_s , rtime_ice_oflx + real(kind=WP) :: t_oce_s , t_oce_e , rtime_oce_full + real(kind=WP) :: t_diag_s , t_diag_e , rtime_compute_diag + real(kind=WP) :: t_io_s , t_io_e , rtime_write_means + real(kind=WP) :: t_rstart_s, t_rstart_e, rtime_write_restart + real(kind=real32) :: rtime_setup_mesh, rtime_setup_ocean, rtime_setup_forcing real(kind=real32) :: rtime_setup_ice, rtime_setup_other, rtime_setup_restart real(kind=real32) :: runtime_alltimesteps #if defined (__recom) - real(kind=WP) :: t0_recom, t1_recom - real(kind=real32) :: rtime_setup_recom, rtime_compute_recom + real(kind=WP) :: t_recom_s, t_recom_e, rtime_compute_recom + real(kind=real32) :: rtime_setup_recom #endif type(t_mesh) mesh @@ -343,13 +354,13 @@ subroutine fesom_init(fesom_total_nsteps) tracers_info%data_pointers(n)%tracer_data => f%tracers%data(n)%values end do - f%t0_recom=MPI_Wtime() + f%t_recom_s=MPI_Wtime() call recom_init(f%mesh%nl, f%mesh%ulevels_nod2d, f%mesh%nlevels_nod2D, & f%mesh%geo_coord_nod2D, f%mesh%z_3d_n, f%partit%myDim_nod2d, & f%partit%eDim_nod2D, f%partit%mype, f%partit%MPI_COMM_FESOM, & f%partit%myDim_elem2D, f%partit%eDim_elem2D, tracers_info, & f%tracers%num_tracers, rad) ! adjust values for recom tracers (derived type "t_tracer") - f%t1_recom=MPI_Wtime() + f%t_recom_e=MPI_Wtime() deallocate(tracers_info%ids) deallocate(tracers_info%data_pointers) @@ -465,7 +476,7 @@ subroutine fesom_init(fesom_total_nsteps) f%rtime_setup_other = real((f%t8 - f%t7) + (f%t6 - f%t5) ,real32) #if defined (__recom) - f%rtime_setup_recom = real( f%t1_recom - f%t0_recom ,real32) + f%rtime_setup_recom = real( f%t_recom_s - f%t_recom_e ,real32) #endif write(*,*) '==========================================' @@ -524,11 +535,16 @@ subroutine fesom_init(fesom_total_nsteps) ! if (f%mype==10) write(,) f%mesh1%ssh_stiff%values-f%mesh%ssh_stiff%value ! Initialize timers - f%rtime_fullice = 0._WP + f%rtime_oce_full = 0._WP + f%rtime_ice_full = 0._WP + f%rtime_ice_o2iflx = 0._WP + f%rtime_ice_readforc = 0._WP + f%rtime_ice_step = 0._WP + f%rtime_ice_oflx = 0._WP + f%rtime_write_restart = 0._WP f%rtime_write_means = 0._WP f%rtime_compute_diag = 0._WP - f%rtime_read_forcing = 0._WP #if defined (__recom) f%rtime_compute_recom = 0._WP #endif @@ -620,8 +636,8 @@ subroutine fesom_runloop(current_nsteps) call MPI_Barrier(f%MPI_COMM_FESOM, f%MPIERR) if (f%mype==0) then write(*,*) 'FESOM start iteration after the barrier...' - f%t0 = MPI_Wtime() endif + f%t_start = MPI_Wtime() if(f%mype==0) then write(*,*) print *, achar(27)//'[32m' //'____________________________________________________________'//achar(27)//'[0m' @@ -641,6 +657,7 @@ subroutine fesom_runloop(current_nsteps) call io_xios_update_calendar(n) #endif if (use_icebergs) then + f%t_iceb_s0 = MPI_Wtime() !n_ib = n u_wind_ib = u_wind v_wind_ib = v_wind @@ -692,6 +709,7 @@ subroutine fesom_runloop(current_nsteps) ! ----------------------------------------------------------------------------------- ! LA asyncronous coupling not included in this FESOM version, yet!! ! + f%t_iceb_e0 = MPI_Wtime() end if if (use_global_tides) then @@ -714,21 +732,25 @@ subroutine fesom_runloop(current_nsteps) ! -------------- ! LA icebergs: 2023-05-17 if (use_icebergs .and. mod(n - 1, steps_per_ib_step)==0) then + f%t_iceb_s = MPI_Wtime() if (f%mype==0) write(*,*) '*** step n=',n !t1_icb = MPI_Wtime() call iceberg_calculation(f%ice,f%mesh,f%partit,f%dynamics,n) + f%t_iceb_e = MPI_Wtime() end if ! -------------- + !___model sea-ice step__________________________________________________ - f%t1 = MPI_Wtime() if(use_ice) then + f%t_ice_s = MPI_Wtime() !___compute fluxes from ocean to ice________________________________ if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call ocean2ice(n)'//achar(27)//'[0m' + f%t_ice_o2iflx_s = MPI_Wtime() call ocean2ice(f%ice, f%dynamics, f%tracers, f%partit, f%mesh) !___compute update of atmospheric forcing____________________________ if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call update_atm_forcing(n)'//achar(27)//'[0m' - f%t0_frc = MPI_Wtime() + f%t_ice_rfrc_s = MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_start("update_atm_forcing") #endif @@ -740,7 +762,7 @@ subroutine fesom_runloop(current_nsteps) #if defined (FESOM_PROFILING) call fesom_profiler_end("update_atm_forcing") #endif - f%t1_frc = MPI_Wtime() + f%t_ice_step_s = MPI_Wtime() !___compute ice step________________________________________________ if (f%ice%ice_steps_since_upd>=f%ice%ice_ave_steps-1) then f%ice%ice_update=.true. @@ -759,15 +781,17 @@ subroutine fesom_runloop(current_nsteps) call fesom_profiler_end("ice_timestep") #endif endif - + !___compute fluxes to the ocean: heat, freshwater, momentum_________ if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call oce_fluxes_mom...'//achar(27)//'[0m' + f%t_ice_oflx_s = MPI_Wtime() call oce_fluxes_mom(f%ice, f%dynamics, f%partit, f%mesh) ! momentum only call oce_fluxes(f%ice, f%dynamics, f%tracers, f%partit, f%mesh) + f%t_ice_e = MPI_Wtime() end if + call before_oce_step(f%dynamics, f%tracers, f%partit, f%mesh) ! prepare the things if required - f%t2 = MPI_Wtime() - + !___now recom____________________________________________________ #if defined (__recom) if (f%mype==0 .and. n==1) print *, achar(27)//'[46' //'_____________________________________________________________'//achar(27)//'[0m' @@ -783,7 +807,7 @@ subroutine fesom_runloop(current_nsteps) tracers_info%data_pointers(tracer_index)%tracer_data => f%tracers%data(tracer_index)%values end do - f%t0_recom = MPI_Wtime() + f%t_recom_s = MPI_Wtime() call recom(f%ice%data(1)%values, f%mesh%nl, & f%mesh%ulevels_nod2d, f%mesh%nlevels_nod2D, f%mesh%hnode, & f%mesh%z_3d_n, f%mesh%zbar_3d_n, f%mesh%geo_coord_nod2d, & @@ -798,7 +822,7 @@ subroutine fesom_runloop(current_nsteps) f%partit%com_nod2D%req, f%partit%com_nod2D%nreq, & dt, daynew, month, mstep, ndpyr, yearold, timenew, rad, kappa, & press_air, u_wind, v_wind, shortwave) - f%t1_recom = MPI_Wtime() + f%t_recom_e = MPI_Wtime() deallocate(tracers_info%ids) deallocate(tracers_info%ltra_diag) @@ -808,6 +832,7 @@ subroutine fesom_runloop(current_nsteps) !___model ocean step____________________________________________________ if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call oce_timestep_ale'//achar(27)//'[0m' + f%t_oce_s = MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_start("oce_timestep_ale") #endif @@ -823,10 +848,11 @@ subroutine fesom_runloop(current_nsteps) end if end do end if ! use_transit - - f%t3 = MPI_Wtime() + f%t_oce_e = MPI_Wtime() + !___compute energy diagnostics..._______________________________________ if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call compute_diagnostics(1)'//achar(27)//'[0m' + f%t_diag_s = MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_start("compute_diagnostics") #endif @@ -834,7 +860,12 @@ subroutine fesom_runloop(current_nsteps) #if defined (FESOM_PROFILING) call fesom_profiler_end("compute_diagnostics") #endif + f%t_diag_e = MPI_Wtime() + + !___prepare output______________________________________________________ + if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call output (n)'//achar(27)//'[0m' + f%t_io_s = MPI_Wtime() ! XIOS send for CMOR 0D scalars. xios_send_field is a collective ! over the FESOM client context: ALL ranks must participate or ! XIOS errors with "callers not coherent" (event_server.cpp:29). @@ -878,9 +909,6 @@ subroutine fesom_runloop(current_nsteps) if (do_cmor_0d_reset) call reset_cmor_acc() end if - f%t4 = MPI_Wtime() - !___prepare output______________________________________________________ - if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call output (n)'//achar(27)//'[0m' #if defined (FESOM_PROFILING) call fesom_profiler_start("output") #endif @@ -888,14 +916,19 @@ subroutine fesom_runloop(current_nsteps) #if defined (FESOM_PROFILING) call fesom_profiler_end("output") #endif - + f%t_io_e = MPI_Wtime() + ! LA icebergs: 2023-05-17 if (use_icebergs .and. mod(n, steps_per_ib_step)==0.0) then + f%t_iceb_s1 = MPI_Wtime() call reset_ib_fluxes + f%t_iceb_e1 = MPI_Wtime() end if !-------------------------- - f%t5 = MPI_Wtime() + !___prepare restart_____________________________________________________ + if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call write_initial_conditions(n,...)'//achar(27)//'[0m' + f%t_rstart_s = MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_start("restart") #endif @@ -910,18 +943,10 @@ subroutine fesom_runloop(current_nsteps) #if defined (FESOM_PROFILING) call fesom_profiler_end("restart") #endif - f%t6 = MPI_Wtime() + f%t_rstart_e = MPI_Wtime() - f%rtime_fullice = f%rtime_fullice + f%t2 - f%t1 - f%rtime_compute_diag = f%rtime_compute_diag + f%t4 - f%t3 - f%rtime_write_means = f%rtime_write_means + f%t5 - f%t4 - f%rtime_write_restart = f%rtime_write_restart + f%t6 - f%t5 - f%rtime_read_forcing = f%rtime_read_forcing + f%t1_frc - f%t0_frc -#if defined (__recom) - f%rtime_compute_recom = f%rtime_compute_recom + f%t1_recom - f%t0_recom -#endif - -! Transient tracers: update of input values between restarts + ! ______________________________________________________________________ + ! Transient tracers: update of input values between restarts if(use_transit .and. anthro_transit .and. (daynew == ndpyr) .and. (timenew==86400.)) then ti_transit = ti_transit + 1 if (f%mype==0) then @@ -938,6 +963,30 @@ subroutine fesom_runloop(current_nsteps) end if endif + !_______________________________________________________________________ + ! accumulate for mean wall-clock time of sub components + if (use_ice) then + f%rtime_ice_full = f%rtime_ice_full + f%t_ice_e - f%t_ice_s + f%rtime_ice_o2iflx = f%rtime_ice_o2iflx + f%t_ice_rfrc_s - f%t_ice_o2iflx_s + f%rtime_ice_readforc = f%rtime_ice_readforc + f%t_ice_step_s - f%t_ice_rfrc_s + f%rtime_ice_step = f%rtime_ice_step + f%t_ice_oflx_s - f%t_ice_step_s + f%rtime_ice_oflx = f%rtime_ice_oflx + f%t_ice_e - f%t_ice_oflx_s + end if + + f%rtime_oce_full = f%rtime_oce_full + f%t_oce_e - f%t_oce_s + + if (use_icebergs) then + f%rtime_iceb_full = f%rtime_iceb_full + f%t_iceb_e-f%t_iceb_s + f%t_iceb_e0-f%t_iceb_s0 + f%t_iceb_e1-f%t_iceb_s1 + end if + + f%rtime_compute_diag = f%rtime_compute_diag + f%t_diag_e - f%t_diag_s + f%rtime_write_means = f%rtime_write_means + f%t_io_e - f%t_io_s + f%rtime_write_restart = f%rtime_write_restart + f%t_rstart_e - f%t_rstart_s + +#if defined (__recom) + f%rtime_compute_recom = f%rtime_compute_recom + f%t_recom_s - f%t_recom_e +#endif + end do !call cray_acc_set_debug_global_level(3) f%from_nstep = f%from_nstep+current_nsteps @@ -958,11 +1007,12 @@ subroutine fesom_finalize() use mpp_io #endif ! EO parameters - ! 1..15 are the existing FESOM timers (ocean components, ice, output, etc.) - ! 16..20 are the io_meandata sub-decomposition: update_means, streamloop, + ! 1..19 are the existing FESOM timers (ocean components, ice, output, etc.) + ! 20..24 are the io_meandata sub-decomposition: update_means, streamloop, ! pack, mask, xsend (see rtime_om_* in io_meandata.F90). - real(kind=real32) :: mean_rtime(20), max_rtime(20), min_rtime(20) - integer :: tr_num + integer :: tr_num, n_rtime=27 + real(kind=real32), allocatable :: mean_rtime(:), max_rtime(:), min_rtime(:) + allocate(mean_rtime(n_rtime), max_rtime(n_rtime), min_rtime(n_rtime)) ! Start finalization profiling #if defined (FESOM_PROFILING) @@ -1026,73 +1076,89 @@ subroutine fesom_finalize() !$ACC EXIT DATA DELETE (f%partit%eDim_nod2D, f%partit%myDim_edge2D) !$ACC EXIT DATA DELETE (f%partit%myDim_elem2D, f%partit%myDim_nod2D, f%partit%myList_edge2D) !$ACC EXIT DATA DELETE (f%mesh, f%partit, f) + f%t_end = MPI_Wtime() + f%runtime_alltimesteps = real(f%t_end-f%t_start,real32) if (f%mype==0) then - f%t1 = MPI_Wtime() - f%runtime_alltimesteps = real(f%t1-f%t0,real32) write(*,*) 'FESOM Run is finished, updating clock' endif - mean_rtime(1) = rtime_oce - mean_rtime(2) = rtime_oce_mixpres - mean_rtime(3) = rtime_oce_dyn - mean_rtime(4) = rtime_oce_dynssh - mean_rtime(5) = rtime_oce_solvessh - mean_rtime(6) = rtime_oce_GMRedi - mean_rtime(7) = rtime_oce_solvetra - mean_rtime(8) = rtime_ice - mean_rtime(9) = rtime_tot - mean_rtime(10) = f%rtime_fullice - f%rtime_read_forcing - mean_rtime(11) = f%rtime_compute_diag - mean_rtime(12) = f%rtime_write_means - mean_rtime(13) = f%rtime_write_restart - mean_rtime(14) = f%rtime_read_forcing + + !___________________________________________________________________________ + ! ocean step timeing + mean_rtime(1) = f%rtime_oce_full + mean_rtime(2) = rtime_oce_presdens + mean_rtime(3) = rtime_oce_mixing + mean_rtime(4) = rtime_oce_dyn + mean_rtime(5) = rtime_oce_dynssh + mean_rtime(6) = rtime_oce_solvessh + mean_rtime(7) = rtime_oce_GMRedi + mean_rtime(8) = rtime_oce_solvetra + + ! ice step timeing + mean_rtime(9) = f%rtime_ice_full + mean_rtime(10) = f%rtime_ice_o2iflx + mean_rtime(11) = f%rtime_ice_readforc + mean_rtime(12) = f%rtime_ice_step + mean_rtime(13) = rtime_ice_evp + mean_rtime(14) = rtime_ice_adv + mean_rtime(15) = rtime_ice_therm + mean_rtime(16) = f%rtime_ice_oflx + + ! total ice+ocean step timeing + mean_rtime(17) = f%rtime_oce_full + f%rtime_ice_full + + ! diag, mean I/O, restart timing + mean_rtime(18) = f%rtime_compute_diag + mean_rtime(19) = f%rtime_write_means + ! Sub-decomposition of rtime_write_means (= mean_rtime(12)): + ! (20) update_means accumulator cost (per step, every step) + ! (21) per-stream loop in output() (incl. write_mean dispatch) + ! (22) Fortran tmp2/tmp3 nested-loop pack from local_values_*_copy + ! (23) io_xios_apply_wet_* / apply_ice_mask_* full-array scans + ! (24) pure xios_send_field call wall (post-gate, the actual XIOS pipeline) + mean_rtime(20) = real(rtime_om_update_means, real32) + mean_rtime(21) = real(rtime_om_streamloop, real32) + mean_rtime(22) = real(rtime_om_pack, real32) + mean_rtime(23) = real(rtime_om_mask, real32) + mean_rtime(24) = real(rtime_om_xsend, real32) + mean_rtime(25) = f%rtime_write_restart + + ! total runtime + mean_rtime(26) = f%runtime_alltimesteps + #if defined (__recom) - mean_rtime(15) = f%rtime_compute_recom + ! recom timing + mean_rtime(n_rtime) = f%rtime_compute_recom #endif - ! Sub-decomposition of rtime_write_means (= mean_rtime(12)): - ! (16) update_means accumulator cost (per step, every step) - ! (17) per-stream loop in output() (incl. write_mean dispatch) - ! (18) Fortran tmp2/tmp3 nested-loop pack from local_values_*_copy - ! (19) io_xios_apply_wet_* / apply_ice_mask_* full-array scans - ! (20) pure xios_send_field call wall (post-gate, the actual XIOS pipeline) - mean_rtime(16) = real(rtime_om_update_means, real32) - mean_rtime(17) = real(rtime_om_streamloop, real32) - mean_rtime(18) = real(rtime_om_pack, real32) - mean_rtime(19) = real(rtime_om_mask, real32) - mean_rtime(20) = real(rtime_om_xsend, real32) - max_rtime(1:14) = mean_rtime(1:14) - min_rtime(1:14) = mean_rtime(1:14) - max_rtime(16:20) = mean_rtime(16:20) - min_rtime(16:20) = mean_rtime(16:20) + + ! compute mean, max, min component WCT across processors + max_rtime(1:n_rtime-1) = mean_rtime(1:n_rtime-1) + min_rtime(1:n_rtime-1) = mean_rtime(1:n_rtime-1) + call MPI_AllREDUCE(MPI_IN_PLACE, mean_rtime, n_rtime-1, MPI_REAL, MPI_SUM, f%MPI_COMM_FESOM, f%MPIerr) + mean_rtime(1:n_rtime-1) = mean_rtime(1:n_rtime-1) / real(f%npes,real32) + call MPI_AllREDUCE(MPI_IN_PLACE, max_rtime, n_rtime-1, MPI_REAL, MPI_MAX, f%MPI_COMM_FESOM, f%MPIerr) + call MPI_AllREDUCE(MPI_IN_PLACE, min_rtime, n_rtime-1, MPI_REAL, MPI_MIN, f%MPI_COMM_FESOM, f%MPIerr) + #if defined (__recom) - max_rtime(15) = mean_rtime(15) - min_rtime(15) = mean_rtime(15) - call MPI_AllREDUCE(MPI_IN_PLACE, mean_rtime(15), 1, MPI_REAL, MPI_SUM, f%MPI_COMM_FESOM, f%MPIerr) - mean_rtime(15) = mean_rtime(15) / real(f%npes,real32) - call MPI_AllREDUCE(MPI_IN_PLACE, max_rtime(15), 1, MPI_REAL, MPI_MAX, f%MPI_COMM_FESOM, f%MPIerr) - call MPI_AllREDUCE(MPI_IN_PLACE, min_rtime(15), 1, MPI_REAL, MPI_MIN, f%MPI_COMM_FESOM, f%MPIerr) -#endif - - call MPI_AllREDUCE(MPI_IN_PLACE, mean_rtime, 14, MPI_REAL, MPI_SUM, f%MPI_COMM_FESOM, f%MPIerr) - mean_rtime(1:14) = mean_rtime(1:14) / real(f%npes,real32) - call MPI_AllREDUCE(MPI_IN_PLACE, max_rtime, 14, MPI_REAL, MPI_MAX, f%MPI_COMM_FESOM, f%MPIerr) - call MPI_AllREDUCE(MPI_IN_PLACE, min_rtime, 14, MPI_REAL, MPI_MIN, f%MPI_COMM_FESOM, f%MPIerr) - ! Sub-decomposition of write_means: indices (16)..(20) - call MPI_AllREDUCE(MPI_IN_PLACE, mean_rtime(16), 5, MPI_REAL, MPI_SUM, f%MPI_COMM_FESOM, f%MPIerr) - mean_rtime(16:20) = mean_rtime(16:20) / real(f%npes,real32) - call MPI_AllREDUCE(MPI_IN_PLACE, max_rtime(16), 5, MPI_REAL, MPI_MAX, f%MPI_COMM_FESOM, f%MPIerr) - call MPI_AllREDUCE(MPI_IN_PLACE, min_rtime(16), 5, MPI_REAL, MPI_MIN, f%MPI_COMM_FESOM, f%MPIerr) + ! compute mean, max, min recom WCT across processors + max_rtime(n_rtime) = mean_rtime(n_rtime) + min_rtime(n_rtime) = mean_rtime(n_rtime) + call MPI_AllREDUCE(MPI_IN_PLACE, mean_rtime(n_rtime), 1, MPI_REAL, MPI_SUM, f%MPI_COMM_FESOM, f%MPIerr) + mean_rtime(n_rtime) = mean_rtime(n_rtime) / real(f%npes,real32) + call MPI_AllREDUCE(MPI_IN_PLACE, max_rtime(n_rtime), 1, MPI_REAL, MPI_MAX, f%MPI_COMM_FESOM, f%MPIerr) + call MPI_AllREDUCE(MPI_IN_PLACE, min_rtime(n_rtime), 1, MPI_REAL, MPI_MIN, f%MPI_COMM_FESOM, f%MPIerr) +#endif ! Per-stream cumulative cost — printed sorted at finalize from rank 0. call print_per_stream_costs(f%partit%MPI_COMM_FESOM, f%partit%mype, f%npes) #if defined (__XIOS) - ! Must finalize XIOS BEFORE MPI/OASIS teardown so server2 receives - ! the client-finalize signal on MPI_COMM_WORLD (matches NEMO/OIFS). - call io_xios_close() + ! Must finalize XIOS BEFORE MPI/OASIS teardown so server2 receives + ! the client-finalize signal on MPI_COMM_WORLD (matches NEMO/OIFS). + call io_xios_close() #endif -#if defined (__oifs) +#if defined (__oifs) ! OpenIFS coupled version has to call oasis_terminate through par_ex call par_ex(f%partit%MPI_COMM_FESOM, f%partit%mype) #endif @@ -1109,45 +1175,53 @@ subroutine fesom_finalize() if(f%fesom_did_mpi_init) call par_ex(f%partit%MPI_COMM_FESOM, f%partit%mype) ! finalize MPI before FESOM prints its stats block, otherwise there is sometimes output from other processes from an earlier time in the programm AFTER the starts block (with parastationMPI) if (f%mype==0) then - 41 format (a35,a10,2a15) !Format for table heading - 42 format (a30,3f15.4) !Format for table content - - print 41, '___MODEL RUNTIME per task [seconds]','_____mean_','___________min_', '___________max_' - print 42, ' runtime ocean: ', mean_rtime(1), min_rtime(1), max_rtime(1) - print 42, ' > runtime oce. mix,pres. :', mean_rtime(2), min_rtime(2), max_rtime(2) - print 42, ' > runtime oce. dyn. u,v,w:', mean_rtime(3), min_rtime(3), max_rtime(3) - print 42, ' > runtime oce. dyn. ssh :', mean_rtime(4), min_rtime(4), max_rtime(4) - print 42, ' > runtime oce. solve ssh :', mean_rtime(5), min_rtime(5), max_rtime(5) - print 42, ' > runtime oce. GM/Redi :', mean_rtime(6), min_rtime(6), max_rtime(6) - print 42, ' > runtime oce. tracer :', mean_rtime(7), min_rtime(7), max_rtime(7) - print 42, ' runtime ice : ', mean_rtime(10), min_rtime(10), max_rtime(10) - print 42, ' > runtime ice step : ', mean_rtime(8), min_rtime(8), max_rtime(8) - print 42, ' runtime diag: ', mean_rtime(11), min_rtime(11), max_rtime(11) - print 42, ' runtime output: ', mean_rtime(12), min_rtime(12), max_rtime(12) - print 42, ' > out: update_means ', mean_rtime(16), min_rtime(16), max_rtime(16) - print 42, ' > out: streamloop ', mean_rtime(17), min_rtime(17), max_rtime(17) - print 42, ' > out: pack ', mean_rtime(18), min_rtime(18), max_rtime(18) - print 42, ' > out: mask ', mean_rtime(19), min_rtime(19), max_rtime(19) - print 42, ' > out: xsend ', mean_rtime(20), min_rtime(20), max_rtime(20) - print 42, ' runtime restart: ', mean_rtime(13), min_rtime(13), max_rtime(13) - print 42, ' runtime forcing: ', mean_rtime(14), min_rtime(14), max_rtime(14) - print 42, ' runtime total (ice+oce): ', mean_rtime(9), min_rtime(9), max_rtime(9) + 41 format (a35,a10,2a15,a9,a10) !Format heading + 42 format (a,3f15.4,f8.2,a1,f8.2,a1) !Format oce/ice (two %) + 43 format (a,3f15.4,f8.2,a1) !Format other (one %) + + print 41, '___MODEL RUNTIME per task [seconds]','_____mean_','___________min_','___________max_','____%tot_','_%ice+oce_' + write(*,42) ' > runtime ocean :', mean_rtime(1), min_rtime(1), max_rtime(1), 100.*mean_rtime(1) /mean_rtime(26),'%',100.*mean_rtime(1) /mean_rtime(17),'%' + write(*,42) ' ├> runtime oce. pres.,dens:', mean_rtime(2), min_rtime(2), max_rtime(2), 100.*mean_rtime(2) /mean_rtime(26),'%',100.*mean_rtime(2) /mean_rtime(17),'%' + write(*,42) ' ├> runtime oce. mixing :', mean_rtime(3), min_rtime(3), max_rtime(3), 100.*mean_rtime(3) /mean_rtime(26),'%',100.*mean_rtime(3) /mean_rtime(17),'%' + write(*,42) ' ├> runtime oce. dyn. u,v,w:', mean_rtime(4), min_rtime(4), max_rtime(4), 100.*mean_rtime(4) /mean_rtime(26),'%',100.*mean_rtime(4) /mean_rtime(17),'%' + write(*,42) ' ├> runtime oce. dyn. ssh :', mean_rtime(5), min_rtime(5), max_rtime(5), 100.*mean_rtime(5) /mean_rtime(26),'%',100.*mean_rtime(5) /mean_rtime(17),'%' + write(*,42) ' │ └> runtime oce. slv ssh:', mean_rtime(6), min_rtime(6), max_rtime(6), 100.*mean_rtime(6) /mean_rtime(26),'%',100.*mean_rtime(6) /mean_rtime(17),'%' + write(*,42) ' ├> runtime oce. GM/Redi :', mean_rtime(7), min_rtime(7), max_rtime(7), 100.*mean_rtime(7) /mean_rtime(26),'%',100.*mean_rtime(7) /mean_rtime(17),'%' + write(*,42) ' └> runtime oce. tracer :', mean_rtime(8), min_rtime(8), max_rtime(8), 100.*mean_rtime(8) /mean_rtime(26),'%',100.*mean_rtime(8) /mean_rtime(17),'%' + write(*,42) ' > runtime ice :', mean_rtime(9), min_rtime(9), max_rtime(9), 100.*mean_rtime(9) /mean_rtime(26),'%',100.*mean_rtime(9) /mean_rtime(17),'%' + write(*,42) ' ├> runtime ice o2iflx :', mean_rtime(10), min_rtime(10), max_rtime(10), 100.*mean_rtime(10)/mean_rtime(26),'%',100.*mean_rtime(10)/mean_rtime(17),'%' + write(*,42) ' ├> runtime ice read forc :', mean_rtime(11), min_rtime(11), max_rtime(11), 100.*mean_rtime(11)/mean_rtime(26),'%',100.*mean_rtime(11)/mean_rtime(17),'%' + write(*,42) ' ├> runtime ice step :', mean_rtime(12), min_rtime(12), max_rtime(12), 100.*mean_rtime(12)/mean_rtime(26),'%',100.*mean_rtime(12)/mean_rtime(17),'%' + write(*,42) ' │ ├> runtime ice evp :', mean_rtime(13), min_rtime(13), max_rtime(13), 100.*mean_rtime(13)/mean_rtime(26),'%',100.*mean_rtime(13)/mean_rtime(17),'%' + write(*,42) ' │ ├> runtime ice adv. :', mean_rtime(14), min_rtime(14), max_rtime(14), 100.*mean_rtime(14)/mean_rtime(26),'%',100.*mean_rtime(14)/mean_rtime(17),'%' + write(*,42) ' │ └> runtime ice therm. :', mean_rtime(15), min_rtime(15), max_rtime(15), 100.*mean_rtime(15)/mean_rtime(26),'%',100.*mean_rtime(15)/mean_rtime(17),'%' + write(*,42) ' └> runtime ice o2aflx :', mean_rtime(16), min_rtime(16), max_rtime(16), 100.*mean_rtime(16)/mean_rtime(26),'%',100.*mean_rtime(16)/mean_rtime(17),'%' + write(*,42) ' > runtime total (ice+oce) :', mean_rtime(17), min_rtime(17), max_rtime(17), 100.*mean_rtime(17)/mean_rtime(26),'%',100.*mean_rtime(17)/mean_rtime(17),'%' + write(*,43) ' > runtime diag :', mean_rtime(18), min_rtime(18), max_rtime(18), 100.*mean_rtime(18)/mean_rtime(26),'%' + write(*,43) ' > runtime output :', mean_rtime(19), min_rtime(19), max_rtime(19), 100.*mean_rtime(19)/mean_rtime(26),'%' + write(*,43) ' ├> runtime update_means :', mean_rtime(20), min_rtime(20), max_rtime(20), 100.*mean_rtime(20)/mean_rtime(26),'%' + write(*,43) ' ├> runtime streamloop :', mean_rtime(21), min_rtime(21), max_rtime(21), 100.*mean_rtime(21)/mean_rtime(26),'%' + write(*,43) ' ├> runtime pack :', mean_rtime(22), min_rtime(22), max_rtime(22), 100.*mean_rtime(22)/mean_rtime(26),'%' + write(*,43) ' ├> runtime mask :', mean_rtime(23), min_rtime(23), max_rtime(23), 100.*mean_rtime(23)/mean_rtime(26),'%' + write(*,43) ' └> runtime xsend :', mean_rtime(24), min_rtime(24), max_rtime(24), 100.*mean_rtime(24)/mean_rtime(26),'%' + write(*,43) ' > runtime restart :', mean_rtime(25), min_rtime(25), max_rtime(25), 100.*mean_rtime(25)/mean_rtime(26),'%' + #if defined (__recom) - print 42, ' runtime recom: ', mean_rtime(15), min_rtime(15), max_rtime(15) + print 43, ' runtime recom: ', mean_rtime(n_rtime), min_rtime(n_rtime), max_rtime(n_rtime), 100.*mean_rtime(n_rtime)/mean_rtime(21),'%' #endif - 43 format (a33,i15) !Format Ncores - 44 format (a33,i15) !Format OMP threads - 45 format (a33,f15.4,a4) !Format runtime + 44 format (a33,i15) !Format Ncores + 45 format (a33,i15) !Format OMP threads + 46 format (a33,f15.4,a4) !Format runtime write(*,*) write(*,*) '======================================================' write(*,*) '================ BENCHMARK RUNTIME ===================' - print 43, ' Number of cores : ',f%npes + print 44, ' Number of cores : ',f%npes #if defined(_OPENMP) - print 44, ' Max OpenMP threads : ',OMP_GET_MAX_THREADS() + print 45, ' Max OpenMP threads : ',OMP_GET_MAX_THREADS() #endif - print 45, ' Runtime for all timesteps : ',f%runtime_alltimesteps,' sec' + print 46, ' Runtime for all timesteps : ',f%runtime_alltimesteps,' sec' write(*,*) '======================================================' write(*,*) end if diff --git a/src/gen_halo_exchange.F90 b/src/gen_halo_exchange.F90 index 92b9aba02..33be86d05 100755 --- a/src/gen_halo_exchange.F90 +++ b/src/gen_halo_exchange.F90 @@ -2721,6 +2721,516 @@ subroutine gather_edg2D_i(arr2D, arr2Dglobal, partit) end subroutine gather_edg2D_i !============================================== +! ======================================================================== +! Gather routines for spectral bin (fbin) fields used by IDEMIX2. +! These handle arrays with dimensions (nfbin, horizontal) instead of (nl, horizontal). +! ======================================================================== + +!============================================================================ +! Make nodal spectral bin information available to master PE +! arr3D(nfbin, nod2D) +subroutine gather_nod2D_fbin(arr2D, arr2D_global, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +integer :: nfbin +integer :: n +real(real64) :: arr2D(:,:) +real(real64) :: arr2D_global(:,:) +real(real64), allocatable :: recvbuf(:,:) +integer :: req(partit%npes-1) +integer :: start, n2D +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes> 1) then +CALL MPI_BARRIER(MPI_COMM_FESOM,MPIerr) + +nfbin=ubound(arr2D,1) + +IF ( mype == 0 ) THEN + + if (npes>1) then + allocate(recvbuf(nfbin,ubound(arr2D_global,2))) + + do n = 1, npes-1 + n2D = (remPtr_nod2D(n+1) - remPtr_nod2D(n))*nfbin + start = remPtr_nod2D(n) + call MPI_IRECV(recvbuf(1,start), n2D, MPI_DOUBLE_PRECISION, n, 2, MPI_COMM_FESOM, req(n), MPIerr) + enddo + + arr2D_global(1:nfbin,myList_nod2D(1:myDim_nod2D)) = arr2D(1:nfbin,1:myDim_nod2D) + + call MPI_WAITALL(npes-1, req, MPI_STATUSES_IGNORE, MPIerr) + + arr2D_global(1:nfbin, remList_nod2D(1 : remPtr_nod2D(npes)-1)) & + = recvbuf(1:nfbin, 1 : remPtr_nod2D(npes)-1) + + deallocate(recvbuf) + + else + arr2D_global(:,:) = arr2D(:,:) + endif + +ELSE + + call MPI_SEND( arr2D, myDim_nod2D*nfbin, MPI_DOUBLE_PRECISION, 0, 2, MPI_COMM_FESOM, MPIerr ) + +ENDIF + +end if +end subroutine gather_nod2D_fbin + +!============================================================================ +! Make element spectral bin information available to master PE +! arr2D(nfbin, elem2D) +subroutine gather_elem2D_fbin(arr2D, arr2D_global, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +integer :: nfbin +integer :: n +real(real64) :: arr2D(:,:) +real(real64) :: arr2D_global(:,:) +real(real64), allocatable :: recvbuf(:,:) +integer :: req(partit%npes-1) +integer :: start, n2D +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes> 1) then +CALL MPI_BARRIER(MPI_COMM_FESOM,MPIerr) + +nfbin=ubound(arr2D,1) + +IF ( mype == 0 ) THEN + + if (npes>1) then + allocate(recvbuf(nfbin,ubound(arr2D_global,2))) + + do n = 1, npes-1 + n2D = (remPtr_elem2D(n+1) - remPtr_elem2D(n))*nfbin + start = remPtr_elem2D(n) + call MPI_IRECV(recvbuf(1,start), n2D, MPI_DOUBLE_PRECISION, n, 2, MPI_COMM_FESOM, req(n), MPIerr) + enddo + + arr2D_global(1:nfbin,myList_elem2D(1:myDim_elem2D)) = arr2D(1:nfbin,1:myDim_elem2D) + + call MPI_WAITALL(npes-1, req, MPI_STATUSES_IGNORE, MPIerr) + + arr2D_global(1:nfbin, remList_elem2D(1 : remPtr_elem2D(npes)-1)) & + = recvbuf(1:nfbin, 1 : remPtr_elem2D(npes)-1) + + deallocate(recvbuf) + + else + arr2D_global(:,:) = arr2D(:,:) + endif + +ELSE + + call MPI_SEND( arr2D, myDim_elem2D*nfbin, MPI_DOUBLE_PRECISION, 0, 2, MPI_COMM_FESOM, MPIerr ) + +ENDIF + +end if +end subroutine gather_elem2D_fbin + +!============================================================================ +! Make nodal spectral bin information available to master PE (real4 version) +! arr2D(nfbin, nod2D) +subroutine gather_real4_nod2D_fbin(arr2D, arr2D_global, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +integer :: nfbin +integer :: n +real(real32) :: arr2D(:,:) +real(real32) :: arr2D_global(:,:) +real(real32), allocatable :: recvbuf(:,:) +integer :: req(partit%npes-1) +integer :: start, n2D +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes> 1) then +CALL MPI_BARRIER(MPI_COMM_FESOM,MPIerr) + +nfbin=ubound(arr2D,1) + +IF ( mype == 0 ) THEN + + if (npes>1) then + allocate(recvbuf(nfbin,ubound(arr2D_global,2))) + + do n = 1, npes-1 + n2D = (remPtr_nod2D(n+1) - remPtr_nod2D(n))*nfbin + start = remPtr_nod2D(n) + call MPI_IRECV(recvbuf(1,start), n2D, MPI_REAL, n, 2, MPI_COMM_FESOM, req(n), MPIerr) + enddo + + arr2D_global(1:nfbin,myList_nod2D(1:myDim_nod2D)) = arr2D(1:nfbin,1:myDim_nod2D) + + call MPI_WAITALL(npes-1, req, MPI_STATUSES_IGNORE, MPIerr) + + arr2D_global(1:nfbin, remList_nod2D(1 : remPtr_nod2D(npes)-1)) & + = recvbuf(1:nfbin, 1 : remPtr_nod2D(npes)-1) + + deallocate(recvbuf) + + else + arr2D_global(:,:) = arr2D(:,:) + endif + +ELSE + + call MPI_SEND( arr2D, myDim_nod2D*nfbin, MPI_REAL, 0, 2, MPI_COMM_FESOM, MPIerr ) + +ENDIF + +end if +end subroutine gather_real4_nod2D_fbin + +!============================================================================ +! Make element spectral bin information available to master PE (real4 version) +! arr2D(nfbin, elem2D) +subroutine gather_real4_elem2D_fbin(arr2D, arr2D_global, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +integer :: nfbin +integer :: n +real(real32) :: arr2D(:,:) +real(real32) :: arr2D_global(:,:) +real(real32), allocatable :: recvbuf(:,:) +integer :: req(partit%npes-1) +integer :: start, n2D +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes> 1) then +CALL MPI_BARRIER(MPI_COMM_FESOM,MPIerr) + +nfbin=ubound(arr2D,1) + +IF ( mype == 0 ) THEN + + if (npes>1) then + allocate(recvbuf(nfbin,ubound(arr2D_global,2))) + + do n = 1, npes-1 + n2D = (remPtr_elem2D(n+1) - remPtr_elem2D(n))*nfbin + start = remPtr_elem2D(n) + call MPI_IRECV(recvbuf(1,start), n2D, MPI_REAL, n, 2, MPI_COMM_FESOM, req(n), MPIerr) + enddo + + arr2D_global(1:nfbin,myList_elem2D(1:myDim_elem2D)) = arr2D(1:nfbin,1:myDim_elem2D) + + call MPI_WAITALL(npes-1, req, MPI_STATUSES_IGNORE, MPIerr) + + arr2D_global(1:nfbin, remList_elem2D(1 : remPtr_elem2D(npes)-1)) & + = recvbuf(1:nfbin, 1 : remPtr_elem2D(npes)-1) + + deallocate(recvbuf) + + else + arr2D_global(:,:) = arr2D(:,:) + endif + +ELSE + + call MPI_SEND( arr2D, myDim_elem2D*nfbin, MPI_REAL, 0, 2, MPI_COMM_FESOM, MPIerr ) + +ENDIF + +end if +end subroutine gather_real4_elem2D_fbin + +!============================================== + +! ======================================================================== +! Halo exchange routines for spectral bin (fbin) fields used by IDEMIX2. +! The first array dimension is nfbin (number of spectral frequency bins) +! instead of nl (number of vertical levels). +! Naming convention: +! exchange_nod2D_fbin: nodal 2D spectral field arr(nfbin, nod2D) +! exchange_nod3D_fbin: nodal 3D spectral field arr(n_val, nfbin, nod2D) +! exchange_elem2D_fbin: elem 2D spectral field arr(nfbin, elem2D) +! exchange_elem3D_fbin: elem 3D spectral field arr(n_val, nfbin, elem2D) +! ======================================================================== + +! ======================================================================== +! 2D nodal spectral field: arr(nfbin, myDim_nod2D+eDim_nod2D) +! ======================================================================== +subroutine exchange_nod2D_fbin(nod_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: nod_array(:,:) +if (partit%npes > 1) then + call exchange_nod2D_fbin_begin(nod_array, partit) + call exchange_nod_end(partit) +endif +END SUBROUTINE exchange_nod2D_fbin + +subroutine exchange_nod2D_fbin_begin(nod_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: nod_array(:,:) +integer :: n, sn, rn +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes > 1) then + if (nfbin_mpi == 0) then + if (mype==0) print *,'ERROR: exchange_nod2D_fbin called but init_mpi_types_fbin was not called.' + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 1) + endif + + sn=com_nod2D%sPEnum + rn=com_nod2D%rPEnum + + ! Exchange full spectral column at once (n_val=1 for 2D array) + DO n=1,rn + call MPI_IRECV(nod_array, 1, r_mpitype_nod3D_fbin(n,nfbin_mpi,1), com_nod2D%rPE(n), & + com_nod2D%rPE(n), MPI_COMM_FESOM, com_nod2D%req(n), MPIerr) + END DO + DO n=1, sn + call MPI_ISEND(nod_array, 1, s_mpitype_nod3D_fbin(n,nfbin_mpi,1), com_nod2D%sPE(n), & + mype, MPI_COMM_FESOM, com_nod2D%req(rn+n), MPIerr) + END DO + com_nod2D%nreq = rn+sn + call MPI_WAITALL(com_nod2D%nreq, com_nod2D%req, MPI_STATUSES_IGNORE, MPIerr) +endif +END SUBROUTINE exchange_nod2D_fbin_begin + +! ======================================================================== +! 3D nodal spectral field: arr(n_val, nfbin, myDim_nod2D+eDim_nod2D) +! ======================================================================== +subroutine exchange_nod3D_fbin(nod_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: nod_array(:,:,:) +if (partit%npes > 1) then + call exchange_nod3D_fbin_begin(nod_array, partit) + call exchange_nod_end(partit) +endif +END SUBROUTINE exchange_nod3D_fbin + +subroutine exchange_nod3D_fbin_begin(nod_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: nod_array(:,:,:) +integer :: n, sn, rn, n_val +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes > 1) then + if (nfbin_mpi == 0) then + if (mype==0) print *,'ERROR: exchange_nod3D_fbin called but init_mpi_types_fbin was not called.' + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 1) + endif + + ! nod_array(n_val, nfbin, nod2D) + n_val = ubound(nod_array,1) + if (n_val < 1 .or. n_val > 3) then + if (mype==0) print *,'exchange_nod3D_fbin: n_val must be 1..3, got', n_val + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 1) + endif + + sn=com_nod2D%sPEnum + rn=com_nod2D%rPEnum + + ! Exchange full spectral column at once + DO n=1,rn + call MPI_IRECV(nod_array, 1, r_mpitype_nod3D_fbin(n,nfbin_mpi,n_val), com_nod2D%rPE(n), & + com_nod2D%rPE(n), MPI_COMM_FESOM, com_nod2D%req(n), MPIerr) + END DO + DO n=1, sn + call MPI_ISEND(nod_array, 1, s_mpitype_nod3D_fbin(n,nfbin_mpi,n_val), com_nod2D%sPE(n), & + mype, MPI_COMM_FESOM, com_nod2D%req(rn+n), MPIerr) + END DO + com_nod2D%nreq = rn+sn + call MPI_WAITALL(com_nod2D%nreq, com_nod2D%req, MPI_STATUSES_IGNORE, MPIerr) +endif +END SUBROUTINE exchange_nod3D_fbin_begin + +! ======================================================================== +! 2D elemental spectral field: arr(nfbin, myDim_elem2D+eDim_elem2D) +! ======================================================================== +subroutine exchange_elem2D_fbin(elem_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: elem_array(:,:) +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes > 1) then + call exchange_elem2D_fbin_begin(elem_array, partit) + call exchange_elem_end(partit) +endif +END SUBROUTINE exchange_elem2D_fbin + +subroutine exchange_elem2D_fbin_begin(elem_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: elem_array(:,:) +integer :: n, sn, rn +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes > 1) then + if (nfbin_mpi == 0) then + if (mype==0) print *,'ERROR: exchange_elem2D_fbin called but init_mpi_types_fbin was not called.' + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 1) + endif + + if (ubound(elem_array,2)<=myDim_elem2D+eDim_elem2D) then + ! small halo + elem_full_flag = .false. + sn=com_elem2D%sPEnum + rn=com_elem2D%rPEnum + + ! Exchange full spectral column at once + DO n=1,rn + call MPI_IRECV(elem_array, 1, r_mpitype_elem2D_fbin(n,nfbin_mpi), com_elem2D%rPE(n), & + com_elem2D%rPE(n), MPI_COMM_FESOM, com_elem2D%req(n), MPIerr) + END DO + DO n=1, sn + call MPI_ISEND(elem_array, 1, s_mpitype_elem2D_fbin(n,nfbin_mpi), com_elem2D%sPE(n), & + mype, MPI_COMM_FESOM, com_elem2D%req(rn+n), MPIerr) + END DO + com_elem2D%nreq = rn+sn + call MPI_WAITALL(com_elem2D%nreq, com_elem2D%req, MPI_STATUSES_IGNORE, MPIerr) + else + ! full halo + elem_full_flag = .true. + sn=com_elem2D_full%sPEnum + rn=com_elem2D_full%rPEnum + + ! Exchange full spectral column at once + DO n=1,rn + call MPI_IRECV(elem_array, 1, r_mpitype_elem2D_full_fbin(n,nfbin_mpi), com_elem2D_full%rPE(n), & + com_elem2D_full%rPE(n), MPI_COMM_FESOM, com_elem2D_full%req(n), MPIerr) + END DO + DO n=1, sn + call MPI_ISEND(elem_array, 1, s_mpitype_elem2D_full_fbin(n,nfbin_mpi), com_elem2D_full%sPE(n), & + mype, MPI_COMM_FESOM, com_elem2D_full%req(rn+n), MPIerr) + END DO + com_elem2D_full%nreq = rn+sn + call MPI_WAITALL(com_elem2D_full%nreq, com_elem2D_full%req, MPI_STATUSES_IGNORE, MPIerr) + endif +endif +END SUBROUTINE exchange_elem2D_fbin_begin + +! ======================================================================== +! 3D elemental spectral field: arr(n_val, nfbin, myDim_elem2D+eDim_elem2D) +! ======================================================================== +subroutine exchange_elem3D_fbin(elem_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: elem_array(:,:,:) +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes > 1) then + call exchange_elem3D_fbin_begin(elem_array, partit) + call exchange_elem_end(partit) +endif +END SUBROUTINE exchange_elem3D_fbin + +subroutine exchange_elem3D_fbin_begin(elem_array, partit) +use MOD_MESH +USE MOD_PARTIT +USE MOD_PARSUP +IMPLICIT NONE +type(t_partit), intent(inout), target :: partit +real(real64), intent(inout) :: elem_array(:,:,:) +integer :: n, sn, rn, n_val +#include "associate_part_def.h" +#include "associate_part_ass.h" + +if (npes > 1) then + if (nfbin_mpi == 0) then + if (mype==0) print *,'ERROR: exchange_elem3D_fbin called but init_mpi_types_fbin was not called.' + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 1) + endif + + ! elem_array(n_val, nfbin, elem2D) + n_val = ubound(elem_array,1) + if (n_val < 1 .or. n_val > 4) then + if (mype==0) print *,'exchange_elem3D_fbin: n_val must be 1..4, got', n_val + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 1) + endif + + if (ubound(elem_array,3)<=myDim_elem2D+eDim_elem2D) then + ! small halo + elem_full_flag = .false. + sn=com_elem2D%sPEnum + rn=com_elem2D%rPEnum + + ! Exchange full spectral column at once + DO n=1,rn + call MPI_IRECV(elem_array, 1, r_mpitype_elem3D_fbin(n,nfbin_mpi,n_val), com_elem2D%rPE(n), & + com_elem2D%rPE(n), MPI_COMM_FESOM, com_elem2D%req(n), MPIerr) + END DO + DO n=1, sn + call MPI_ISEND(elem_array, 1, s_mpitype_elem3D_fbin(n,nfbin_mpi,n_val), com_elem2D%sPE(n), & + mype, MPI_COMM_FESOM, com_elem2D%req(rn+n), MPIerr) + END DO + com_elem2D%nreq = rn+sn + call MPI_WAITALL(com_elem2D%nreq, com_elem2D%req, MPI_STATUSES_IGNORE, MPIerr) + else + ! full halo + elem_full_flag = .true. + sn=com_elem2D_full%sPEnum + rn=com_elem2D_full%rPEnum + + ! Exchange full spectral column at once + DO n=1,rn + call MPI_IRECV(elem_array, 1, r_mpitype_elem3D_full_fbin(n,nfbin_mpi,n_val), com_elem2D_full%rPE(n), & + com_elem2D_full%rPE(n), MPI_COMM_FESOM, com_elem2D_full%req(n), MPIerr) + END DO + DO n=1, sn + call MPI_ISEND(elem_array, 1, s_mpitype_elem3D_full_fbin(n,nfbin_mpi,n_val), com_elem2D_full%sPE(n), & + mype, MPI_COMM_FESOM, com_elem2D_full%req(rn+n), MPIerr) + END DO + com_elem2D_full%nreq = rn+sn + call MPI_WAITALL(com_elem2D_full%nreq, com_elem2D_full%req, MPI_STATUSES_IGNORE, MPIerr) + endif +endif +END SUBROUTINE exchange_elem3D_fbin_begin + +! ======================================================================== + end module g_comm @@ -2767,6 +3277,26 @@ module g_comm_auto module procedure exchange_elem2d_i_begin end interface exchange_elem_begin +interface exchange_nod_fbin + module procedure exchange_nod2D_fbin + module procedure exchange_nod3D_fbin +end interface exchange_nod_fbin + +interface exchange_nod_fbin_begin + module procedure exchange_nod2D_fbin_begin + module procedure exchange_nod3D_fbin_begin +end interface exchange_nod_fbin_begin + +interface exchange_elem_fbin + module procedure exchange_elem2D_fbin + module procedure exchange_elem3D_fbin +end interface exchange_elem_fbin + +interface exchange_elem_fbin_begin + module procedure exchange_elem2D_fbin_begin + module procedure exchange_elem3D_fbin_begin +end interface exchange_elem_fbin_begin + interface broadcast_nod module procedure broadcast_nod3D @@ -2790,6 +3320,11 @@ module g_comm_auto module procedure gather_nod2D_i end interface gather_nod +interface gather_nod_fbin + module procedure gather_nod2D_fbin + module procedure gather_real4_nod2D_fbin +end interface gather_nod_fbin + interface gather_elem module procedure gather_elem3D module procedure gather_elem2D @@ -2802,6 +3337,11 @@ module g_comm_auto module procedure gather_elem2D_i end interface gather_elem +interface gather_elem_fbin + module procedure gather_elem2D_fbin + module procedure gather_real4_elem2D_fbin +end interface gather_elem_fbin + interface gather_edge module procedure gather_edg2D module procedure gather_edg2D_i @@ -2811,5 +3351,8 @@ module g_comm_auto private ! hides items not listed on public statement public :: exchange_nod,exchange_elem,broadcast_nod,broadcast_elem, & gather_nod, gather_elem, exchange_nod_begin, exchange_nod_end, exchange_elem_begin, & - exchange_elem_end, gather_edge + exchange_elem_end, gather_edge, & + exchange_nod_fbin, exchange_elem_fbin, & + exchange_nod_fbin_begin, exchange_elem_fbin_begin, & + gather_nod_fbin, gather_elem_fbin end module g_comm_auto diff --git a/src/gen_interpolation.F90 b/src/gen_interpolation.F90 index 0b17e7c46..e3455ff9d 100644 --- a/src/gen_interpolation.F90 +++ b/src/gen_interpolation.F90 @@ -1,3 +1,23 @@ +module g_interp + use MOD_MESH + use MOD_PARTIT + use MOD_PARSUP + use o_PARAM, only: WP + implicit none + + !___________________________________________________________________________ + interface interp_e2n + module procedure interp_e2n_3d + module procedure interp_e2n_2d + module procedure interp_e2n_1d + end interface interp_e2n + + !___________________________________________________________________________ + contains + + + + ! routines doing 3D, 2D and 1D interpolation subroutine interp_2d_field_v2(num_lon_reg, num_lat_reg, lon_reg, lat_reg, data_reg, missvalue, & num_mod, lon_mod, lat_mod, data_mod, partit) @@ -28,9 +48,6 @@ subroutine interp_2d_field_v2(num_lon_reg, num_lat_reg, lon_reg, lat_reg, data_r ! Coded by Qiang Wang ! Reviewed by ?? !------------------------------------------------------------------------------------- - USE MOD_PARTIT - USE MOD_PARSUP - use o_PARAM, only: WP implicit none integer :: n, i, ii, jj, k, nod_find integer :: ind_lat_h, ind_lat_l, ind_lon_h, ind_lon_l @@ -170,9 +187,6 @@ subroutine interp_2d_field(num_lon_reg, num_lat_reg, lon_reg, lat_reg, data_reg, ! Coded by Qiang Wang ! Reviewed by ?? !------------------------------------------------------------------------------------- - USE MOD_PARTIT - USE MOD_PARSUP - use o_PARAM, only: WP implicit none integer :: n, i integer :: ind_lat_h, ind_lat_l, ind_lon_h, ind_lon_l @@ -447,5 +461,191 @@ subroutine interp_3d_field(num_lon_reg, num_lat_reg, num_lay_reg, & end do end subroutine interp_3d_field ! -!--------------------------------------------------------------------------- ! +!_______________________________________________________________________________ +! interpolate from node to elements 3d (2, nz, elem) +subroutine interp_e2n_3d(data_e, data_n, mesh, partit, do_overz_in) + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + real(kind=WP) , intent(in ), dimension(:,:,:) :: data_e + real(kind=WP) , intent(inout), dimension(:,:,:) :: data_n + type(t_mesh) , intent(in ), target :: mesh + type(t_partit) , intent(inout), target :: partit + logical , intent(in) , optional :: do_overz_in + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, elem, nz, nl1, ul1, k + real(kind=WP) :: vx, vy + logical :: do_overz +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + ! + !___________________________________________________________________________ + do_overz = .True. + if (present(do_overz_in)) do_overz = do_overz_in + + ! + !___________________________________________________________________________ + ! Do interpolation over vertical depth dimension consider bottom topography + if (do_overz) then + do node = 1, myDim_nod2D + nl1 = nlevels_nod2D(node)-1 + ul1 = ulevels_nod2D(node) + do nz = ul1, nl1 + vx = 0.0_WP + vy = 0.0_WP + do k = 1, nod_in_elem2D_num(node) + elem = nod_in_elem2D(k, node) + if( nz.LE.(nlevels(elem)-1) .and. nz.GE.(ulevels(elem))) then + vx = vx + data_e(1, nz, elem) * elem_area(elem) + vy = vy + data_e(2, nz, elem) * elem_area(elem) + endif + end do + data_n(1, nz, node)=vx/3.0_WP/areasvol(nz, node) + data_n(2, nz, node)=vy/3.0_WP/areasvol(nz, node) + end do + end do + + ! + !___________________________________________________________________________ + ! Do interpolation along spectral domain no bottom topography to consider + else + ul1=1 + nl1=size(data_e,2) + do node = 1, myDim_nod2D + do nz = ul1+1, nl1-1 + vx = 0.0_WP + vy = 0.0_WP + do k = 1, nod_in_elem2D_num(node) + elem = nod_in_elem2D(k, node) + vx = vx + data_e(1, nz, elem) * elem_area(elem) + vy = vy + data_e(2, nz, elem) * elem_area(elem) + end do + data_n(1, nz, node)=vx/3.0_WP/areasvol(1, node) + data_n(2, nz, node)=vy/3.0_WP/areasvol(1, node) + end do + end do + end if + +end subroutine interp_e2n_3d + + +! +! +!_______________________________________________________________________________ +! interpolate from elem to nodes 2d (2, elem), (nz, elem), (nfbin, elem) --> (.., node) +subroutine interp_e2n_2d(data_e, data_n, mesh, partit, do_overz_in) + use MOD_MESH + USE MOD_PARTIT + USE MOD_PARSUP + use o_param, only: WP + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + real(kind=WP) , intent(in ), dimension(:,:) :: data_e + real(kind=WP) , intent(inout), dimension(:,:) :: data_n + type(t_mesh) , intent(in ), target :: mesh + type(t_partit) , intent(inout), target :: partit + logical , intent(in) , optional :: do_overz_in + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, elem, nz, nl1, ul1, k + real(kind=WP) :: vx, vy + logical :: do_overz +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + ! + !___________________________________________________________________________ + do_overz = .True. + if (present(do_overz_in)) do_overz = do_overz_in + + !___________________________________________________________________________ + ! Do interpolation for 2d vector data e.g 2d gradient (2, elem) + if (size(data_e, 1) == 2) then + do node = 1, myDim_nod2D + vx = 0.0_WP + vy = 0.0_WP + do k = 1, nod_in_elem2D_num(node) + elem = nod_in_elem2D(k, node) + vx = vx + data_e(1, elem) * elem_area(elem) + vy = vy + data_e(2, elem) * elem_area(elem) + end do + data_n(1, node)=vx/3.0_WP/areasvol(1, node) + data_n(2, node)=vy/3.0_WP/areasvol(1, node) + end do + + !___________________________________________________________________________ + ! Do interpolation over vertical depth dimension consider bottom topography (nz,elem) + else if (do_overz) then + do node = 1, myDim_nod2D + nl1 = nlevels_nod2D(node)-1 + ul1 = ulevels_nod2D(node) + do nz = ul1, nl1 + vx = 0.0_WP + do k = 1, nod_in_elem2D_num(node) + elem = nod_in_elem2D(k, node) + if( nz.LE.(nlevels(elem)-1) .and. nz.GE.(ulevels(elem))) then + vx = vx + data_e(nz, elem) * elem_area(elem) + endif + end do + data_n(nz, node)=vx/3.0_WP/areasvol(nz, node) + end do + end do + + !___________________________________________________________________________ + ! Do interpolation along spectral domain no bottom topography to consider (nfbin, elem) + else + ul1=1 + nl1=size(data_e,1) + do node = 1, myDim_nod2D + do nz = ul1+1, nl1-1 + vx = 0.0_WP + do k = 1, nod_in_elem2D_num(node) + elem = nod_in_elem2D(k, node) + vx = vx + data_e(nz, elem) * elem_area(elem) + end do + data_n(nz, node)=vx/3.0_WP/areasvol(1, node) + end do + end do + end if + +end subroutine interp_e2n_2d + + +! +! +!_______________________________________________________________________________ +! interpolate from elem to nodes 1d (elem) --> (node) +subroutine interp_e2n_1d(data_e, data_n, mesh, partit) + use MOD_MESH + USE MOD_PARTIT + USE MOD_PARSUP + use o_param, only: WP + implicit none + !___INPUT/OUTPUT VARIABLES______________________________________________ + real(kind=WP) , intent(in ), dimension(:) :: data_e + real(kind=WP) , intent(inout), dimension(:) :: data_n + type(t_mesh) , intent(in ), target :: mesh + type(t_partit) , intent(inout), target :: partit + !___LOCAL VARIABLES_____________________________________________________ + integer :: node, elem, nz, nl1, ul1, k + real(kind=WP) :: vx +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + ! + !___________________________________________________________________________ + ! Do interpolation for 1d vector data (elem) --> (node) + do node = 1, myDim_nod2D + vx = 0.0_WP + do k = 1, nod_in_elem2D_num(node) + elem = nod_in_elem2D(k, node) + vx = vx + data_e(elem) * elem_area(elem) + data_n(node)=vx/3.0_WP/areasvol(1, node) + end do + end do +end subroutine interp_e2n_1d + +end module g_interp \ No newline at end of file diff --git a/src/gen_modules_config.F90 b/src/gen_modules_config.F90 index ecc17effa..670e500a2 100755 --- a/src/gen_modules_config.F90 +++ b/src/gen_modules_config.F90 @@ -168,9 +168,9 @@ module g_config real(kind=WP) :: dt integer :: save_count_mean, save_count_restart logical :: r_restart - real(kind=WP) :: rtime_ice=0.0, rtime_tot=0.0 + real(kind=WP) :: rtime_ice=0.0, rtime_tot=0.0, rtime_ice_evp=0.0, rtime_ice_adv=0.0, rtime_ice_therm=0.0 real(kind=WP) :: rtime_oce=0.0, rtime_oce_dyn=0.0, rtime_oce_dynssh=0.0, rtime_oce_solvessh=0.0 - real(kind=WP) :: rtime_oce_solvetra=0.0, rtime_oce_GMRedi=0.0, rtime_oce_mixpres=0.0 + real(kind=WP) :: rtime_oce_solvetra=0.0, rtime_oce_GMRedi=0.0, rtime_oce_presdens=0.0, rtime_oce_mixing=0.0 real(kind=WP) :: dummy=1.e10 diff --git a/src/gen_modules_diag.F90 b/src/gen_modules_diag.F90 index 516e9f388..0e8989602 100644 --- a/src/gen_modules_diag.F90 +++ b/src/gen_modules_diag.F90 @@ -1274,9 +1274,9 @@ subroutine compute_dvd(mode, dynamics, tracers, partit, mesh) !_______________________________________________________________________ ! need to recompute tracer gradients - call tracer_gradient_elements(trold, partit, mesh) + call tracer_gradient_elements(trold, tr_xy, partit, mesh) call exchange_elem(tr_xy, partit) - call tracer_gradient_z(trold, partit, mesh) + call tracer_gradient_z(trold, tr_z, partit, mesh) call exchange_nod(tr_z, partit) !=== DVD Knut Klingbeil et al. 2014 ==================================== diff --git a/src/gen_modules_dist2coast.F90 b/src/gen_modules_dist2coast.F90 new file mode 100644 index 000000000..3e95c425e --- /dev/null +++ b/src/gen_modules_dist2coast.F90 @@ -0,0 +1,525 @@ +module g_dist2coast + !___________________________________________________________________________ + use MOD_MESH + use MOD_PARTIT + use MOD_PARSUP + use g_config, only: flag_debug, cyclic_length + use o_param + use o_arrays + use g_comm_auto + use, intrinsic :: iso_fortran_env, only: real32, real64 + implicit none + private + public :: find_coast_pnts, build_coast_bins, nearest_coast_dist, compute_dist2coast + + interface allgatherv_coast + module procedure allgatherv_coast_real4 + module procedure allgatherv_coast_real8 + end interface + + !___________________________________________________________________________ + contains + + ! + ! + !___________________________________________________________________________ + ! compute distance in [m] for each elemental surface points to the closest + ! coastal point across partition domains + subroutine compute_dist2coast(dist, mesh, partit, modein) + !___INPUT/OUTPUT VARIABLES______________________________________________ + real(kind=WP) , intent(inout) :: dist(:) + type(t_mesh) , intent(in) , target :: mesh + type(t_partit) , intent(inout), target :: partit + character(len=*), intent(in), optional :: modein + !___LOCAL VARIABLES_____________________________________________________ + real(kind=WP) , allocatable :: coast_lon(:), coast_lat(:) + integer :: n_coast + real(kind=WP) :: bin_dlon=10.0*rad, bin_dlat=10.0*rad + integer , allocatable :: bin_head(:,:), bin_next(:) + integer :: bin_nlon, bin_nlat + integer :: elem, node, elnodes(3), node_size, elem_size + real(kind=WP) :: lon_e, lat_e, lonr(3), xmin + character(len=10) :: mode + real(kind=WP) :: t0, t1, t2, t3 + + !_______________________________________________________________________ + mode = 'elem' + if (present(modein)) mode=trim(modein) + if (partit%mype==0 .and. (trim(mode) .eq. 'elem')) then + write(*,*) ' └> compute dist2coast for elements' + elseif (partit%mype==0 .and. (trim(mode) .eq. 'node')) then + write(*,*) ' └> compute dist2coast for vertices' + end if + + !_______________________________________________________________________ + ! find all coastal points across all partitions and combine them in + ! lon/lat array that is known to all partitions + if (flag_debug .and. partit%mype==0) print *, achar(27)//'[37m'//' --> call find_coast_pnts'//achar(27)//'[0m' + t0=MPI_Wtime() + call find_coast_pnts(coast_lon, coast_lat, n_coast, mesh, partit) + + !_______________________________________________________________________ + ! build coastal binning array with a linked list of all coastal points + ! within a list so that we do not need to loop everytime over all coastal + ! points to compute the distance + if (flag_debug .and. partit%mype==0) print *, achar(27)//'[37m'//' --> call build_coast_bins'//achar(27)//'[0m' + t1=MPI_Wtime() + call build_coast_bins(coast_lon, coast_lat , & + bin_dlon , bin_dlat , & + bin_nlon , bin_nlat , & + bin_head , bin_next) + + !_______________________________________________________________________ + ! compute distance for each local elem point to the coastline + ! allocate(dist(partit%myDim_elem2D)) --> dist should be allocated and + ! initialised outside + t2=MPI_Wtime() + if (trim(mode) .eq. 'elem') then + !___________________________________________________________________ + if ( .not. (size(dist) == partit%myDim_elem2D+partit%eDim_elem2D .or. & + size(dist) == partit%myDim_elem2D)) then + if (partit%mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: size(dist)=', size(dist), ' does not agree to element computation' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + end if + else + elem_size = size(dist) + end if + + !___________________________________________________________________ + if (flag_debug .and. partit%mype==0) print *, achar(27)//'[37m'//' --> call nearest_coast_dist'//achar(27)//'[0m' + do elem = 1, elem_size + elnodes = mesh%elem2d_nodes(:,elem) + lat_e = sum(mesh%geo_coord_nod2D(2,elnodes))/3.0_WP + + ! do properly computing of elem centroid lon position across + ! periodic boundary + lonr = mesh%geo_coord_nod2D(1, elnodes) + xmin = minval(lonr) + do node=1,3 + if(lonr(node)-xmin>=cyclic_length/2.0_WP) lonr(node)=lonr(node)-cyclic_length + if(lonr(node)-xmin<-cyclic_length/2.0_WP) lonr(node)=lonr(node)+cyclic_length + end do + lon_e = sum(lonr)/3.0_WP + + ! compute elem centoid distance to nearest coast line point + call nearest_coast_dist(lon_e , lat_e , & + coast_lon, coast_lat , & + bin_dlon , bin_dlat , & + bin_head , bin_next , & + dist(elem)) + end do ! --> do elem = 1, partit%myDim_elem2D + + elseif (trim(mode) .eq. 'node') then + !___________________________________________________________________ + if ( .not. (size(dist) == partit%myDim_nod2D+partit%eDim_nod2D .or. & + size(dist) == partit%myDim_nod2D)) then + if (partit%mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: size(dist)=', size(dist), ' does not agree to vertice computation' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + end if + else + node_size = size(dist) + end if + + !___________________________________________________________________ + if (flag_debug .and. partit%mype==0) print *, achar(27)//'[37m'//' --> call nearest_coast_dist'//achar(27)//'[0m' + do node = 1, node_size + lat_e = mesh%geo_coord_nod2D(2,node) ! convert in degree + + ! do properly computing of elem centroid lon position across + ! periodic boundary + lon_e = mesh%geo_coord_nod2D(1,node) ! convert in degree + + ! compute elem centoid distance to nearest coast line point + call nearest_coast_dist(lon_e , lat_e , & + coast_lon, coast_lat , & + bin_dlon , bin_dlat , & + bin_head , bin_next , & + dist(node)) + end do ! --> do node = 1, partit%myDim_nod2D + + else + if (partit%mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: This mode=', trim(mode), ' is not supported when computing distance ' + write(*,*) ' to coast line.' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + end if + end if ! --> if (trim(mode) .eq. 'elem') then + t3=MPI_Wtime() + + !_______________________________________________________________________ + if (partit%mype==0) then + write(*,*) ' └> time find coast pnts:', t1-t0 + write(*,*) ' └> time build bins :', t2-t1 + write(*,*) ' └> time comp. dist :', t3-t2 + end if + + !_______________________________________________________________________ + deallocate(bin_head, bin_next) + deallocate(coast_lon, coast_lat) + + end subroutine compute_dist2coast + + + + ! + ! + !___________________________________________________________________________ + ! create array with all coastal lon/lat coordinate points. This array has to be + ! visible to all partitions is need to compute smallest distance of every vertice + ! with respect to the coast + ! coast_lon/lat only needed for distance computation will be deallocated + ! immediately after + subroutine find_coast_pnts(coast_lon, coast_lat, n_coast, mesh, partit) + !___INPUT/OUTPUT VARIABLES______________________________________________ + type(t_mesh) , intent(in) , target :: mesh + type(t_partit), intent(inout), target :: partit + real(kind=WP) , intent(out) , allocatable :: coast_lon(:), coast_lat(:) + integer , intent(out) :: n_coast + !___LOCAL VARIABLES_____________________________________________________ + integer :: p, edge, ednodes(2), lcl_n_coast, cnt + real(kind=WP), allocatable :: lcl_coast_lon(:), lcl_coast_lat(:) + logical, allocatable :: lcl_coast_isT(:) + integer, allocatable :: all_counts(:), all_displs(:) + + ! Identify local coastal vertices + allocate(lcl_coast_isT(partit%myDim_nod2D)) + lcl_coast_isT = .false. + do edge = 1, partit%myDim_edge2D + if (partit%myList_edge2D(edge) <= mesh%edge2D_in) cycle ! boundary edge + ednodes = mesh%edges(:, edge) + ! Check if this is a boundary edge + if (ednodes(1) >= 1 .and. ednodes(1)<=partit%myDim_nod2D) lcl_coast_isT(ednodes(1)) = .true. + if (ednodes(2) >= 1 .and. ednodes(2)<=partit%myDim_nod2D) lcl_coast_isT(ednodes(2)) = .true. + end do + + ! How many coastal boundary point are in this partition + lcl_n_coast = 0 + do p = 1, partit%myDim_nod2D + if (lcl_coast_isT(p)) lcl_n_coast = lcl_n_coast+1 + end do + + ! Determine coordiantes of local coastal points + if (lcl_n_coast > 0) THEN + allocate(lcl_coast_lon(lcl_n_coast), lcl_coast_lat(lcl_n_coast)) + cnt=1 + do p=1,partit%myDim_nod2D + if (lcl_coast_isT(p)) then + lcl_coast_lon(cnt)=mesh%geo_coord_nod2D(1,p) ! is in radian + lcl_coast_lat(cnt)=mesh%geo_coord_nod2D(2,p) ! is in radian + cnt=cnt+1 + end if + end do + else + allocate(lcl_coast_lon(0), lcl_coast_lat(0)) + end if + + ! Gather all counts from all processors into array + allocate(all_counts(partit%npes)) + all_counts = 0 + call MPI_ALLGATHER(lcl_n_coast, 1, MPI_INTEGER, all_counts, 1, MPI_INTEGER, & + partit%MPI_COMM_FESOM, partit%MPIERR) + + ! Calculate displacements across processors + allocate(all_displs(partit%npes)) + all_displs=0 + do p = 2, partit%npes + all_displs(p) = all_displs(p-1) + all_counts(p -1) + end do + + ! Total number of all coastal points + n_coast = sum(all_counts) + + ! Gather all coastal coordinates from all partitions + allocate(coast_lon(n_coast), coast_lat(n_coast)) + call allgatherv_coast(lcl_coast_lon, lcl_n_coast , & + coast_lon, all_counts, all_displs , & + partit) + call allgatherv_coast(lcl_coast_lat, lcl_n_coast , & + coast_lat, all_counts, all_displs , & + partit) + + !_______________________________________________________________________ + deallocate(lcl_coast_isT, lcl_coast_lon, lcl_coast_lat) + deallocate(all_counts, all_displs) + + end subroutine find_coast_pnts + + + + ! + ! + !___________________________________________________________________________ + ! make sure MPI_ALLGATHERV for all coastal points is precision selectiv by + ! its self through interface for the case WP is changed + subroutine allgatherv_coast_real8(send, sendcount, recv, counts, displs, partit) + real(real64) , intent(in) :: send(:) + real(real64) , intent(out) :: recv(:) + integer , intent(in) :: sendcount, counts(:), displs(:) + type(t_partit), intent(inout), target :: partit + call MPI_ALLGATHERV(send, sendcount, MPI_DOUBLE_PRECISION , & + recv, counts, displs, MPI_DOUBLE_PRECISION , & + partit%MPI_COMM_FESOM, partit%MPIERR) + end subroutine allgatherv_coast_real8 + + subroutine allgatherv_coast_real4(send, sendcount, recv, counts, displs, partit) + real(real32) , intent(in) :: send(:) + real(real32) , intent(out) :: recv(:) + integer , intent(in) :: sendcount, counts(:), displs(:) + type(t_partit), intent(inout), target :: partit + call MPI_ALLGATHERV(send, sendcount, MPI_REAL , & + recv, counts, displs, MPI_REAL , & + partit%MPI_COMM_FESOM, partit%MPIERR) + end subroutine allgatherv_coast_real4 + + + + ! + ! + !___________________________________________________________________________ + ! Build bin linked-lists for coastal points + ! Inputs: coast_lon/coast_lat (degrees), dlon/dlat (degrees) + ! Outputs: + ! nlon,nlat, head(nlon,nlat), next(ncoast) + subroutine build_coast_bins(coast_lon, coast_lat, dlon, dlat, nlon, nlat, head, next) + !___INPUT/OUTPUT VARIABLES______________________________________________ + real(WP), intent(in) :: coast_lon(:), coast_lat(:) + real(WP), intent(in) :: dlon, dlat + integer, intent(out) :: nlon, nlat + integer, intent(out), allocatable :: head(:,:), next(:) + !___LOCAL VARIABLES_____________________________________________________ + integer :: ci, loni, lati, ncoast + + ! number of coastal points + ncoast = size(coast_lon) + + ! number of lon/lat points depending on binning resolution + nlon = int(2.0_WP*pi/dlon) + nlat = int( pi/dlat) + if (nlon < 1) nlon = 1 + if (nlat < 1) nlat = 1 + + ! allocate fields for linked list + allocate(head(nlon, nlat)) + allocate(next(ncoast)) + head = 0 + next = 0 + + ! fill linked list head and next array with indices, How does it work: + ! next array has length number of coastal point, a next array indices position + ! next(i) contains the index of the next point in coast_lon/coast_lat + ! head(ib,jb) contains only the starting index from the list from which you + ! then proceed to next --> to next --> to next index until you reach next(i)=0 + ! which is the end of the list at this bin location + do ci = 1, ncoast + loni = lon_bin(coast_lon(ci), dlon, nlon) + lati = lat_bin(coast_lat(ci), dlat, nlat) + next(ci) = head(loni, lati) + head(loni, lati) = ci + end do + end subroutine build_coast_bins + + + + ! + ! + !___________________________________________________________________________ + ! pure declares a Fortran procedure as side-effect free: it cannot modify global + ! data or perform I/O and depends only on its arguments. It guarantees that + ! the same inputs always produce the same output (its rekursive). This makes + ! the procedure thread-safe and safe for use in DO CONCURRENT and parallel regions. + ! While it doesn’t make the function itself faster, it enables safer optimization + ! and vectorization. + pure integer function lon_bin(lon, dlon, nlon) result(ib) + real(WP), intent(in) :: lon, dlon + integer, intent(in) :: nlon + real(WP) :: l + l = wrap_lon(lon) + ib = int((l + pi) / dlon) + 1 + if (ib < 1) ib = 1 + if (ib > nlon) ib = nlon + end function lon_bin + + + + ! + ! + !___________________________________________________________________________ + pure integer function lat_bin(lat, dlat, nlat) result(jb) + real(WP), intent(in) :: lat, dlat + integer, intent(in) :: nlat + real(WP) :: a + a = max(-0.5_WP*pi, min(0.5_WP*pi, lat)) + jb = int((a + 0.5_WP*pi) / dlat) + 1 + if (jb < 1) jb = 1 + if (jb > nlat) jb = nlat + end function lat_bin + + + + ! + ! + !___________________________________________________________________________ + pure real(WP) function wrap_lon(lon) result(lw) + real(WP), intent(in) :: lon ! degrees, any range + lw = modulo(lon + pi, 2.0_WP*pi) - pi + end function wrap_lon + + + + ! + ! + !___________________________________________________________________________ + ! Find nearest coastal distance for one vertex by expanding bin rings + ! If your bins are too fine, remote ocean expands r a bit until it finds coast. + subroutine nearest_coast_dist(vlon, vlat, coast_lon, coast_lat, dlon, dlat, & + head, next, dist) + !___INPUT/OUTPUT VARIABLES______________________________________________ + real(WP), intent(in) :: vlon, vlat + real(WP), intent(in) :: coast_lon(:), coast_lat(:) + real(WP), intent(in) :: dlon, dlat + integer, intent(in) :: head(:,:), next(:) + real(WP), intent(out) :: dist + !___LOCAL VARIABLES_____________________________________________________ + integer :: nlon, nlat, lati0, loni0, r + real(WP) :: dist_best, minstep, cos_lat + + ! number of lon/lat bins + nlon = size(head, 1) + nlat = size(head, 2) + + ! vlon, vlat are the coordinates of the reference points for which we want + ! to compute the smallest distance to the coast line + loni0 = lon_bin(vlon, dlon, nlon) + lati0 = lat_bin(vlat, dlat, nlat) + cos_lat = max(0.0_WP, cos(vlat)) + minstep = min(dlat, dlon*cos_lat) + + ! returning huge number dist_best=1.7977E+308 + dist_best = huge(1.0_WP) + + ! Expand rings r = 0,1,2,... until we have a candidate and further rings + ! cannot beat current dist_best (simple conservative stop rule). + ! scan through concentric index rings around index location of reverence + ! point + ! r=0 r=1 r=2 + ! .-------. + ! .---. | | + ! # | # | | # | ... + ! `---´ | | + ! `-------´ + ! + ! do not rescan bins that already have been scanned scan only new outer + ! shell + do r = 0, max(nlon, nlat) + + ! top row + call scan_row(lati0+r, -r, r) + + if (r > 0) then + ! bottom row (avoid double count when r=0) + call scan_row(lati0-r, -r , r ) + + ! left/right columns excluding corners (already done by rows) + call scan_col(-r , lati0-r+1, lati0+r-1) + call scan_col( r , lati0-r+1, lati0+r-1) + end if + + ! Conservative early stop (safe globally): lon/lat spacing + ! do not accept center value r=0 as automatically being the best + if (dist_best < huge(1.0_WP) .and. r>0) then + if ( real(r,WP) * minstep * r_earth > dist_best ) exit + end if + + end do + dist = dist_best + + !_______________________________________________________________________ + contains + ! + !___________________________________________________________________ + ! make sure lon indices properly wrap across the periodic boiundary + pure integer function wrap_loni(i) result(iw) + integer, intent(in) :: i + iw = i + if (iw < 1) iw = iw + nlon + if (iw > nlon) iw = iw - nlon + end function wrap_loni + ! + !___________________________________________________________________ + ! scan outer row of binning shell with radius r + subroutine scan_row(lati, ii1, ii2) + integer, intent(in) :: lati, ii1, ii2 + integer :: ii, loni, idx + real(WP) :: d + if (lati < 1 .or. lati > nlat) return + + do ii = ii1, ii2 + loni = wrap_loni(loni0 + ii) + idx = head(loni, lati) + do while (idx /= 0) + d = haversine_m(vlon, vlat, coast_lon(idx), coast_lat(idx)) + if (d < dist_best) dist_best = d + idx = next(idx) + end do + end do + end subroutine scan_row + ! + !___________________________________________________________________ + ! scan outer column of binning shell with radius r + subroutine scan_col(ii, lat1, lat2) + integer, intent(in) :: ii, lat1, lat2 + integer :: lati, loni, idx + real(WP) :: d + loni = wrap_loni(loni0 + ii) + + do lati = max(1, lat1), min(nlat, lat2) + idx = head(loni, lati) + do while (idx /= 0) + d = haversine_m(vlon, vlat, coast_lon(idx), coast_lat(idx)) + if (d < dist_best) dist_best = d + idx = next(idx) + end do + end do + end subroutine scan_col + + end subroutine nearest_coast_dist + + + + ! + ! + !___________________________________________________________________________ + ! computes the great-circle distance between two lon/lat points on a sphere (Earth), + ! using the haversine formula, and returns the distance in meters. + pure real(WP) function haversine_m(lon1, lat1, lon2, lat2) result(d) + real(WP), intent(in) :: lon1, lat1, lon2, lat2 ! degrees + real(WP) :: dlam, dphi, a + dphi = (lat2 - lat1) + dlam = (wrap_lon(lon2 - lon1)) + + ! The standard haversine expression: + ! a=sin⁡2(dphi/2)+cos⁡(phi1)cos⁡(phi2)sin⁡2(dlam/2) + ! where phi is latitude, lam is longitude. + a = sin(dphi*0.5_WP)**2 + cos(lat1)*cos(lat2)*sin(dlam*0.5_WP)**2 + + ! central angle is: c=2arcsin⁡(a) + ! then distance on a sphere is: d=R⋅c + d = 2.0_WP*r_earth*asin(min(1.0_WP, sqrt(a))) + + end function haversine_m + +end module g_dist2coast \ No newline at end of file diff --git a/src/gen_modules_partitioning.F90 b/src/gen_modules_partitioning.F90 index cac1ba210..1ab4776ca 100644 --- a/src/gen_modules_partitioning.F90 +++ b/src/gen_modules_partitioning.F90 @@ -35,6 +35,14 @@ subroutine init_gatherLists(partit) implicit none type(t_partit), intent(inout), target :: partit end subroutine init_gatherLists + + subroutine init_mpi_types_fbin(nfbin, partit) + USE MOD_PARTIT + USE MOD_PARSUP + implicit none + integer, intent(in) :: nfbin + type(t_partit), intent(inout), target :: partit + end subroutine init_mpi_types_fbin end interface end module par_support_interfaces @@ -517,6 +525,260 @@ subroutine init_mpi_types(partit, mesh) deallocate(blocklen_tmp, displace_tmp) endif end subroutine init_mpi_types + + + +!=================================================================== +! Build MPI Data types for halo exchange of spectral bin (fbin) fields. +! These are used by IDEMIX2 where the first array dimension is nfbin +! (number of spectral frequency bins) instead of nl (number of vertical levels). +! Must be called after init_mpi_types and before first spectral bin exchange. +subroutine init_mpi_types_fbin(nfbin, partit) + USE MOD_PARTIT + USE MOD_PARSUP + implicit none + + integer, intent(in) :: nfbin + type(t_partit), intent(inout), target :: partit + integer :: n, n_val + integer :: i, max_nb, nb, nini, nend + integer, allocatable :: blocklen(:), displace(:) + integer, allocatable :: blocklen_tmp(:), displace_tmp(:) + +#include "associate_part_def.h" +#include "associate_part_ass.h" + + if (npes <= 1) return + + ! Store nfbin for runtime checks in exchange routines + partit%nfbin_mpi = nfbin + + !================================================================ + ! Allocate MPI datatype arrays for spectral bin exchange + ! Full spectral column exchanged at once (mirroring standard nod3D/elem3D pattern) + !================================================================ + allocate(partit%r_mpitype_nod3D_fbin( com_nod2D%rPEnum , nfbin:nfbin, 3)) ! nodes, nfbin bins, 1-3 values + allocate(partit%s_mpitype_nod3D_fbin( com_nod2D%sPEnum , nfbin:nfbin, 3)) + allocate(partit%r_mpitype_elem2D_fbin( com_elem2D%rPEnum , nfbin:nfbin )) ! elems 2D small halo + allocate(partit%s_mpitype_elem2D_fbin( com_elem2D%sPEnum , nfbin:nfbin )) + allocate(partit%r_mpitype_elem2D_full_fbin(com_elem2D_full%rPEnum, nfbin:nfbin )) ! elems 2D full halo + allocate(partit%s_mpitype_elem2D_full_fbin(com_elem2D_full%sPEnum, nfbin:nfbin )) + allocate(partit%r_mpitype_elem3D_fbin( com_elem2D%rPEnum , nfbin:nfbin, 4)) ! elems 3D small halo, 1-4 values + allocate(partit%s_mpitype_elem3D_fbin( com_elem2D%sPEnum , nfbin:nfbin, 4)) + allocate(partit%r_mpitype_elem3D_full_fbin(com_elem2D_full%rPEnum, nfbin:nfbin, 4)) ! elems 3D full halo + allocate(partit%s_mpitype_elem3D_full_fbin(com_elem2D_full%sPEnum, nfbin:nfbin, 4)) + + !================================================================ + ! Build MPI Data types for element fields (small halo) + !================================================================ + max_nb = max( & + maxval(com_elem2D%rptr( 2:com_elem2D%rPEnum+1 ) - com_elem2D%rptr( 1:com_elem2D%rPEnum )), & + maxval(com_elem2D%sptr( 2:com_elem2D%sPEnum+1 ) - com_elem2D%sptr( 1:com_elem2D%sPEnum )), & + maxval(com_elem2D_full%rptr(2:com_elem2D_full%rPEnum+1) - com_elem2D_full%rptr(1:com_elem2D_full%rPEnum)), & + maxval(com_elem2D_full%sptr(2:com_elem2D_full%sPEnum+1) - com_elem2D_full%sptr(1:com_elem2D_full%sPEnum))) + + allocate(displace(max_nb), blocklen(max_nb)) + allocate(displace_tmp(max_nb), blocklen_tmp(max_nb)) + + ! --- Receive types for elements (small halo) --- + do n=1,com_elem2D%rPEnum + nb = 1 + nini = com_elem2D%rptr(n) + nend = com_elem2D%rptr(n+1) - 1 + displace(:) = 0 + displace(1) = com_elem2D%rlist(nini) -1 + blocklen(:) = 1 + do i=nini+1, nend + if (com_elem2D%rlist(i) /= com_elem2D%rlist(i-1) + 1) then + nb = nb+1 + displace(nb) = com_elem2D%rlist(i) -1 + else + blocklen(nb) = blocklen(nb)+1 + endif + enddo + ! 2D fbin type: full spectral column at once (nfbin per element) + blocklen_tmp(1:nb) = blocklen(1:nb)*nfbin + displace_tmp(1:nb) = displace(1:nb)*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%r_mpitype_elem2D_fbin(n,nfbin), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%r_mpitype_elem2D_fbin(n,nfbin), partit%MPIerr) + ! 3D fbin types: full spectral column, n_val values per bin + DO n_val=1,4 + blocklen_tmp(1:nb) = blocklen(1:nb)*n_val*nfbin + displace_tmp(1:nb) = displace(1:nb)*n_val*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%r_mpitype_elem3D_fbin(n,nfbin,n_val), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%r_mpitype_elem3D_fbin(n,nfbin,n_val), partit%MPIerr) + ENDDO + enddo + + ! --- Send types for elements (small halo) --- + do n=1,com_elem2D%sPEnum + nb = 1 + nini = com_elem2D%sptr(n) + nend = com_elem2D%sptr(n+1) - 1 + displace(:) = 0 + displace(1) = com_elem2D%slist(nini) -1 + blocklen(:) = 1 + do i=nini+1, nend + if (com_elem2D%slist(i) /= com_elem2D%slist(i-1) + 1) then + nb = nb+1 + displace(nb) = com_elem2D%slist(i) -1 + else + blocklen(nb) = blocklen(nb)+1 + endif + enddo + ! 2D fbin type: full spectral column at once + blocklen_tmp(1:nb) = blocklen(1:nb)*nfbin + displace_tmp(1:nb) = displace(1:nb)*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%s_mpitype_elem2D_fbin(n,nfbin), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%s_mpitype_elem2D_fbin(n,nfbin), partit%MPIerr) + ! 3D fbin types: full spectral column, n_val values per bin + DO n_val=1,4 + blocklen_tmp(1:nb) = blocklen(1:nb)*n_val*nfbin + displace_tmp(1:nb) = displace(1:nb)*n_val*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%s_mpitype_elem3D_fbin(n,nfbin,n_val), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%s_mpitype_elem3D_fbin(n,nfbin,n_val), partit%MPIerr) + ENDDO + enddo + + !================================================================ + ! Build MPI Data types for element fields (full halo) + !================================================================ + ! --- Receive types for elements (full halo) --- + do n=1,com_elem2D_full%rPEnum + nb = 1 + nini = com_elem2D_full%rptr(n) + nend = com_elem2D_full%rptr(n+1) - 1 + displace(:) = 0 + displace(1) = com_elem2D_full%rlist(nini) -1 + blocklen(:) = 1 + do i=nini+1, nend + if (com_elem2D_full%rlist(i) /= com_elem2D_full%rlist(i-1) + 1) then + nb = nb+1 + displace(nb) = com_elem2D_full%rlist(i) -1 + else + blocklen(nb) = blocklen(nb)+1 + endif + enddo + ! 2D fbin type: full spectral column at once + blocklen_tmp(1:nb) = blocklen(1:nb)*nfbin + displace_tmp(1:nb) = displace(1:nb)*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%r_mpitype_elem2D_full_fbin(n,nfbin), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%r_mpitype_elem2D_full_fbin(n,nfbin), partit%MPIerr) + ! 3D fbin types: full spectral column, n_val values per bin + DO n_val=1,4 + blocklen_tmp(1:nb) = blocklen(1:nb)*n_val*nfbin + displace_tmp(1:nb) = displace(1:nb)*n_val*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%r_mpitype_elem3D_full_fbin(n,nfbin,n_val), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%r_mpitype_elem3D_full_fbin(n,nfbin,n_val), partit%MPIerr) + ENDDO + enddo + + ! --- Send types for elements (full halo) --- + do n=1,com_elem2D_full%sPEnum + nb = 1 + nini = com_elem2D_full%sptr(n) + nend = com_elem2D_full%sptr(n+1) - 1 + displace(:) = 0 + displace(1) = com_elem2D_full%slist(nini) -1 + blocklen(:) = 1 + do i=nini+1, nend + if (com_elem2D_full%slist(i) /= com_elem2D_full%slist(i-1) + 1) then + nb = nb+1 + displace(nb) = com_elem2D_full%slist(i) -1 + else + blocklen(nb) = blocklen(nb)+1 + endif + enddo + ! 2D fbin type: full spectral column at once + blocklen_tmp(1:nb) = blocklen(1:nb)*nfbin + displace_tmp(1:nb) = displace(1:nb)*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%s_mpitype_elem2D_full_fbin(n,nfbin), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%s_mpitype_elem2D_full_fbin(n,nfbin), partit%MPIerr) + ! 3D fbin types: full spectral column, n_val values per bin + DO n_val=1,4 + blocklen_tmp(1:nb) = blocklen(1:nb)*n_val*nfbin + displace_tmp(1:nb) = displace(1:nb)*n_val*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%s_mpitype_elem3D_full_fbin(n,nfbin,n_val), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%s_mpitype_elem3D_full_fbin(n,nfbin,n_val), partit%MPIerr) + ENDDO + enddo + + deallocate(displace, blocklen) + deallocate(displace_tmp, blocklen_tmp) + + !================================================================ + ! Build MPI Data types for nodal fields + !================================================================ + max_nb = max(maxval(com_nod2D%rptr(2:com_nod2D%rPEnum+1) - com_nod2D%rptr(1:com_nod2D%rPEnum)), & + maxval(com_nod2D%sptr(2:com_nod2D%sPEnum+1) - com_nod2D%sptr(1:com_nod2D%sPEnum))) + + allocate(displace(max_nb), blocklen(max_nb)) + allocate(displace_tmp(max_nb), blocklen_tmp(max_nb)) + + ! --- Receive types for nodes --- + do n=1,com_nod2D%rPEnum + nb = 1 + nini = com_nod2D%rptr(n) + nend = com_nod2D%rptr(n+1) - 1 + displace(:) = 0 + displace(1) = com_nod2D%rlist(nini) -1 + blocklen(:) = 1 + do i=nini+1, nend + if (com_nod2D%rlist(i) /= com_nod2D%rlist(i-1) + 1) then + nb = nb+1 + displace(nb) = com_nod2D%rlist(i) -1 + else + blocklen(nb) = blocklen(nb)+1 + endif + enddo + ! Full spectral column: n_val*nfbin contiguous elements per node + DO n_val=1,3 + blocklen_tmp(1:nb) = blocklen(1:nb)*n_val*nfbin + displace_tmp(1:nb) = displace(1:nb)*n_val*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%r_mpitype_nod3D_fbin(n,nfbin,n_val), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%r_mpitype_nod3D_fbin(n,nfbin,n_val), partit%MPIerr) + ENDDO + enddo + + ! --- Send types for nodes --- + do n=1,com_nod2D%sPEnum + nb = 1 + nini = com_nod2D%sptr(n) + nend = com_nod2D%sptr(n+1) - 1 + displace(:) = 0 + displace(1) = com_nod2D%slist(nini) -1 + blocklen(:) = 1 + do i=nini+1, nend + if (com_nod2D%slist(i) /= com_nod2D%slist(i-1) + 1) then + nb = nb+1 + displace(nb) = com_nod2D%slist(i) -1 + else + blocklen(nb) = blocklen(nb)+1 + endif + enddo + ! Full spectral column: n_val*nfbin contiguous elements per node + DO n_val=1,3 + blocklen_tmp(1:nb) = blocklen(1:nb)*n_val*nfbin + displace_tmp(1:nb) = displace(1:nb)*n_val*nfbin + call MPI_TYPE_INDEXED(nb, blocklen_tmp, displace_tmp, MPI_DOUBLE_PRECISION, & + partit%s_mpitype_nod3D_fbin(n,nfbin,n_val), partit%MPIerr) + call MPI_TYPE_COMMIT(partit%s_mpitype_nod3D_fbin(n,nfbin,n_val), partit%MPIerr) + ENDDO + enddo + + deallocate(blocklen, displace) + deallocate(blocklen_tmp, displace_tmp) + +end subroutine init_mpi_types_fbin !=================================================================== subroutine init_gatherLists(partit) USE MOD_PARTIT diff --git a/src/gen_modules_read_NetCDF.F90 b/src/gen_modules_read_NetCDF.F90 index 8ab8b94fd..fdfbd0e18 100755 --- a/src/gen_modules_read_NetCDF.F90 +++ b/src/gen_modules_read_NetCDF.F90 @@ -4,146 +4,265 @@ module g_read_other_NetCDF contains subroutine read_other_NetCDF(file, vari, itime, model_2Darray, check_dummy, do_onvert, partit, mesh) - ! Read 2D data and interpolate to the model grid. - ! Currently used to read runoff and SSS. - ! First, missing values are filled in on the raw regular grid; - ! Second, interp_2d_field does the interpolation. - ! The check_dummy part should be modified in new applications! - ! if check_dummy=.true., missing value is replaced with a meaningful value nearby - ! if check_dummy=.false., missing value is replaced with 0.0 + ! Read 2D data and interpolate to the model grid. + ! Currently used to read runoff and SSS. + ! First, missing values are filled in on the raw regular grid; + ! Second, interp_2d_field does the interpolation. + ! The check_dummy part should be modified in new applications! + ! if check_dummy=.true., missing value is replaced with a meaningful value nearby + ! if check_dummy=.false., missing value is replaced with 0.0 - use, intrinsic :: ISO_FORTRAN_ENV, only: real64 - use g_config - use o_param - USE MOD_MESH - USE MOD_PARTIT - USE MOD_PARSUP - use netcdf - implicit none + use, intrinsic :: ISO_FORTRAN_ENV, only: real64 + use g_config + use o_param + USE MOD_MESH + USE MOD_PARTIT + USE MOD_PARSUP + use g_interp + use netcdf + implicit none - type(t_mesh), intent(in), target :: mesh - type(t_partit), intent(inout), target :: partit - integer :: i, j, ii, jj, k, n, num, flag, cnt - integer :: itime, latlen, lonlen - integer :: status, ncid, varid - integer :: lonid, latid - integer :: istart(3), icount(3), elnodes(3) - real(real64) :: x, y, miss, aux, xmin, elnodes_x(3) - real(real64), allocatable :: lon(:), lat(:) - real(real64), allocatable :: ncdata(:,:), ncdata_temp(:,:) - real(real64), allocatable :: temp_x(:), temp_y(:) - real(real64) :: model_2Darray(partit%myDim_nod2d+partit%eDim_nod2D) - character(*) :: vari - character(*) :: file - logical :: check_dummy, do_onvert - integer :: ierror ! return error code + !___Input/Output____________________________________________________________ + character(*) , intent(in) :: file + character(*) , intent(in) :: vari + integer , intent(in) :: itime + real(kind=WP) , intent(inout) :: model_2Darray(:) + logical , intent(in) :: check_dummy + logical , intent(in) :: do_onvert + type(t_mesh) , intent(in) , target :: mesh + type(t_partit), intent(inout), target :: partit + !___Local___________________________________________________________________ + integer :: i, j, ii, jj, k, n, num, flag, cnt + integer :: latlen, lonlen + integer :: status, ncid, varid + integer :: lonid, latid + integer :: istart(3), icount(3), elnodes(3) + real(kind=WP) :: x, y, miss, aux, xmin, elnodes_x(3) + real(kind=WP), allocatable :: lon(:), lat(:) + real(kind=WP), allocatable :: ncdata(:,:), ncdata_temp(:,:) + real(kind=WP), allocatable :: temp_x(:), temp_y(:) + logical :: found_error=.False. + integer :: ierror ! return error code #include "associate_part_def.h" #include "associate_mesh_def.h" #include "associate_part_ass.h" #include "associate_mesh_ass.h" + !___________________________________________________________________________ + ! open netcdf file, check existence + if (mype==0) then + ! open file + status=nf90_open(file, nf90_nowrite, ncid) + if (status /= nf90_noerr) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: File not found: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ', nf90_strerror(status) + write(*,*) ' └> check: namelist.*' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + end if + + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) - if (mype==0) then - ! open file - status=nf90_open(file, nf90_nowrite, ncid) - end if - - call MPI_BCast(status, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) - if (status.ne.nf90_noerr)then - print*,'ERROR: CANNOT READ 2D netCDF FILE CORRECTLY !!!!!' - print*,'Error in opening netcdf file '//file - call par_ex(partit%MPI_COMM_FESOM, partit%mype) - stop - endif - - if (mype==0) then - ! lat - status=nf90_inq_dimid(ncid, 'lat', latid) - status=nf90_inquire_dimension(ncid, latid, len=latlen) - ! lon - status=nf90_inq_dimid(ncid, 'lon', lonid) - status=nf90_inquire_dimension(ncid, lonid, len=lonlen) - end if - call MPI_BCast(latlen, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) - call MPI_BCast(lonlen, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) - - ! lat - allocate(lat(latlen)) - if (mype==0) then - status=nf90_inq_varid(ncid, 'lat', varid) - status=nf90_get_var(ncid, varid, lat, start=(/1/), count=(/latlen/)) - end if - call MPI_BCast(lat, latlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + !___________________________________________________________________________ + ! read dimensions from netcdf file, checkfor the naming of dimensions + if (mype==0) then + ! lat + status=nf90_inq_dimid(ncid, 'lat', latid) + if (status == NF90_EBADDIM) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Dimension lat not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lat' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_inquire_dimension(ncid, latid, len=latlen) + + ! lon + status=nf90_inq_dimid(ncid, 'lon', lonid) + if (status == NF90_EBADDIM) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Dimension lon not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lon' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_inquire_dimension(ncid, lonid, len=lonlen) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast len of lon/lat to all processes + call MPI_BCast(latlen, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) + call MPI_BCast(lonlen, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) - ! lon - allocate(lon(lonlen)) - if (mype==0) then - status=nf90_inq_varid(ncid, 'lon', varid) - status=nf90_get_var(ncid, varid, lon, start=(/1/), count=(/lonlen/)) - end if - call MPI_BCast(lon, lonlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + !___________________________________________________________________________ + ! read latitude regular coordinates from netcdf file --> lat + allocate(lat(latlen)) + if (mype==0) then + status=nf90_inq_varid(ncid, 'lat', varid) + if (status == NF90_ENOTVAR) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Variable lat not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lat' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_get_var(ncid, varid, lat, start=(/1/), count=(/latlen/)) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast latitude array to all processes + call MPI_BCast(lat, latlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) - ! make sure range 0. - 360. - do n=1,lonlen - if (lon(n)<0.0_WP) then - lon(n)=lon(n)+360._WP - end if - end do + !___________________________________________________________________________ + ! read longitude regular coordinates from netcdf file --> lat + allocate(lon(lonlen)) + if (mype==0) then + status=nf90_inq_varid(ncid, 'lon', varid) + if (status == NF90_ENOTVAR) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Variable lon not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lon' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_get_var(ncid, varid, lon, start=(/1/), count=(/lonlen/)) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast longitude array to all processes + call MPI_BCast(lon, lonlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) - allocate(ncdata(lonlen,latlen), ncdata_temp(lonlen,latlen)) - ncdata = 0.0_WP - - if (mype==0) then - ! data - status=nf90_inq_varid(ncid, vari, varid) - istart = (/1,1,itime/) - icount= (/lonlen,latlen,1/) - status=nf90_get_var(ncid, varid, ncdata, start=istart, count=icount) + ! make sure range 0. - 360. + do n=1,lonlen + if (lon(n)<0.0_WP) then + lon(n)=lon(n)+360._WP + end if + end do - ! missing value - status= nf90_get_att(ncid, varid, 'missing_value', miss) - ! close file - status=nf90_close(ncid) - end if - call MPI_BCast(ncdata, lonlen*latlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) - call MPI_BCast(miss, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) - !write(*,*)'miss', miss - !write(*,*)'raw',minval(ncdata),maxval(ncdata) - ncdata_temp=ncdata - do i=1,lonlen - do j=1,latlen - if (ncdata(i,j)==miss .or. ncdata(i,j)==-99.0_WP) then !! - if (check_dummy) then - aux=0.0_WP - cnt=0 - do k=1,30 - do ii=max(1,i-k),min(lonlen,i+k) - do jj=max(1,j-k),min(latlen,j+k) - if (ncdata_temp(ii,jj)/=miss .and. ncdata_temp(ii,jj)/=-99.0_WP) then !! - aux=aux+ncdata_temp(ii,jj) - cnt=cnt+1 - end if - end do !ii - end do !jj - if (cnt>0) then - ncdata(i,j)=aux/cnt - exit - end if - end do !k - else - ncdata(i,j)=0.0_WP - end if + !___________________________________________________________________________ + ! read the 2d data --> check if variable name does exist + allocate(ncdata(lonlen,latlen), ncdata_temp(lonlen,latlen)) + ncdata = 0.0_WP + if (mype==0) then + ! data + status=nf90_inq_varid(ncid, vari, varid) + if (status == NF90_ENOTVAR) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Variable ',vari,' not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: namelist.* ' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + call par_ex(partit%MPI_COMM_FESOM, partit%mype, 0) end if - end do - end do + istart= (/1,1,itime/) + icount= (/lonlen,latlen,1/) + status=nf90_get_var(ncid, varid, ncdata, start=istart, count=icount) + + ! missing value + status= nf90_get_att(ncid, varid, 'missing_value', miss) + + ! close file + status=nf90_close(ncid) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast 2d data array to all processes + call MPI_BCast(ncdata, lonlen*latlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + call MPI_BCast(miss , 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + + ncdata_temp=ncdata + do i=1,lonlen + do j=1,latlen + ! check for missing value + if (ncdata(i,j)==miss .or. ncdata(i,j)==-99.0_WP) then + ! check_dummy=.true., missing value is replaced with a + ! meaningful value nearby make sure that near coastal + ! interpoaltion is valid + if (check_dummy) then + aux=0.0_WP + cnt=0 + ! look for up to 30 grid boxes nearby + do k=1,30 + do ii=max(1,i-k),min(lonlen,i+k) + do jj=max(1,j-k),min(latlen,j+k) + if (ncdata_temp(ii,jj)/=miss .and. ncdata_temp(ii,jj)/=-99.0_WP) then !! + aux=aux+ncdata_temp(ii,jj) + cnt=cnt+1 + end if + end do !ii + end do !jj + if (cnt>0) then + ncdata(i,j)=aux/cnt + exit + end if + end do ! --> do k=1,30 + else + ncdata(i,j)=0.0_WP + end if ! --> if (check_dummy) then + end if ! --> if (ncdata(i,j)==miss .or. ncdata(i,j)==-99.0_WP) then + end do ! --> do j=1,latlen + end do ! --> do i=1,lonlen !write(*,*) 'post',minval(ncdata), maxval(ncdata) !___________________________________________________________________________ ! create interpolation coordinates ! do data interpolation on vertices if (do_onvert) then - num=myDim_nod2d+eDim_nod2d + !PSnum=myDim_nod2d+eDim_nod2d + num=size(model_2Darray,1) allocate(temp_x(num), temp_y(num)) do n=1, num temp_x(n)=geo_coord_nod2d(1,n)/rad @@ -176,12 +295,352 @@ subroutine read_other_NetCDF(file, vari, itime, model_2Darray, check_dummy, do_o !___________________________________________________________________________ ! do interpolation - flag=0 + flag=0 call interp_2d_field(lonlen, latlen, lon, lat, ncdata, num, temp_x, temp_y, & - model_2Darray, flag, partit) + model_2Darray(1:num), flag, partit) deallocate(temp_y, temp_x, ncdata_temp, ncdata, lon, lat) end subroutine read_other_NetCDF +! +! +!_______________________________________________________________________________ +subroutine read_other_NetCDF_3d(file, vname, zvname, model_3Darray, do_onvert, partit, mesh) + ! Read data over three dimensions e2g. time or phit (mist be dimension without + ! topography or lsmask information) and interpolate to the model grid. + ! First, missing values are filled in on the raw regular grid; + ! Second, interp_2d_field does the interpolation. + ! The check_dummy part should be modified in new applications! + ! if check_dummy=.true., missing value is replaced with a meaningful value nearby + ! if check_dummy=.false., missing value is replaced with 0.0 + + use, intrinsic :: ISO_FORTRAN_ENV, only: real64 + use g_config + use o_param + USE MOD_MESH + USE MOD_PARTIT + USE MOD_PARSUP + use g_interp + use netcdf + implicit none + + !___Input/Output____________________________________________________________ + character(*) , intent(in) :: file + character(*) , intent(in) :: vname + character(*) , intent(in) :: zvname + real(kind=WP) , intent(inout) :: model_3Darray(:,:) + logical , intent(in) :: do_onvert + type(t_mesh) , intent(in) , target :: mesh + type(t_partit), intent(inout), target :: partit + !___Local___________________________________________________________________ + integer :: i, j, ii, jj, k, n, num, flag, cnt + integer :: latlen, lonlen, zlen, nz + integer :: status, ncid, varid + integer :: lonid, latid, zid + integer :: istart(3), icount(3), elnodes(3) + real(kind=WP) :: x, y, missvalue, aux, xmin, elnodes_x(3) + real(kind=WP), allocatable :: lon(:), lat(:) !, z(:) + real(kind=WP), allocatable :: ncdata(:,:,:) + real(kind=WP), allocatable :: temp_x(:), temp_y(:) + logical :: found_error=.False. + integer :: ierror ! return error code + +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !___________________________________________________________________________ + ! open netcdf file, check existence + if (mype==0) then + ! open file + status=nf90_open(file, nf90_nowrite, ncid) + if (status /= nf90_noerr) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: File not found: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ', nf90_strerror(status) + write(*,*) ' └> check: namelist.*' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + end if + + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + !___________________________________________________________________________ + ! read dimensions from netcdf file, checkfor the naming of dimensions + if (mype==0) then + ! lat + status=nf90_inq_dimid(ncid, 'lat', latid) + if (status == NF90_EBADDIM) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Dimension lat not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lat' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_inquire_dimension(ncid, latid, len=latlen) + + ! lon + status=nf90_inq_dimid(ncid, 'lon', lonid) + if (status == NF90_EBADDIM) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Dimension lon not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lon' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_inquire_dimension(ncid, lonid, len=lonlen) + + ! read 3rd z dimension in file, could be time, or phit (idemix2) ... + status=nf90_inq_dimid(ncid, zvname, zid) + if (status == NF90_EBADDIM) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Dimension ',zvname, ' not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lon' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_inquire_dimension(ncid, zid, len=zlen) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast len of lon/lat to all processes + call MPI_BCast(latlen, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) + call MPI_BCast(lonlen, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) + call MPI_BCast(zlen , 1, MPI_INTEGER, 0, MPI_COMM_FESOM, ierror) + + !___________________________________________________________________________ + ! read latitude regular coordinates from netcdf file --> lat + allocate(lat(latlen)) + if (mype==0) then + status=nf90_inq_varid(ncid, 'lat', varid) + if (status == NF90_ENOTVAR) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Variable lat not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lat' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_get_var(ncid, varid, lat, start=(/1/), count=(/latlen/)) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast latitude array to all processes + call MPI_BCast(lat, latlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + + !___________________________________________________________________________ + ! read longitude regular coordinates from netcdf file --> lat + allocate(lon(lonlen)) + if (mype==0) then + status=nf90_inq_varid(ncid, 'lon', varid) + if (status == NF90_ENOTVAR) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Variable lon not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: Dim and CoordVariable name must be lon' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + status=nf90_get_var(ncid, varid, lon, start=(/1/), count=(/lonlen/)) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast longitude array to all processes + call MPI_BCast(lon, lonlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + + ! make sure range 0. - 360. + do n=1,lonlen + if (lon(n)<0.0_WP) then + lon(n)=lon(n)+360._WP + end if + end do + +! !___________________________________________________________________________ +! ! read z coordiantes +! allocate(z(zlen)) +! if (mype==0) then +! status=nf90_inq_varid(ncid, zvname, varid) +! if (status == NF90_ENOTVAR) then +! print *, achar(27)//'[33m' +! write(*,*) '____________________________________________________________________' +! write(*,*) ' ERROR: Variable ', zvname ,' not found in file: ' +! write(*,*) ' ├> file:', file +! write(*,*) ' ├> status:', status +! write(*,*) ' ├> ',nf90_strerror(status) +! write(*,*) ' └> check: Dim and CoordVariable name must' +! write(*,*) '____________________________________________________________________' +! print *, achar(27)//'[0m' +! write(*,*) +! found_error = .True. +! end if +! status=nf90_get_var(ncid, varid, z, start=(/1/), count=(/zlen/)) +! end if +! ! broadcast found_error variable to all other processes --> create kill signal +! ! for all processes +! call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) +! if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) +! +! ! broadcast longitude array to all processes +! call MPI_BCast(z, zlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + + !___________________________________________________________________________ + ! read the 3d data --> check if variable name does exist + allocate(ncdata(lonlen, latlen, zlen)) + ncdata = 0.0_WP + if (mype==0) then + ! data + status=nf90_inq_varid(ncid, vname, varid) + if (status == NF90_ENOTVAR) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: Variable ', vname, ' not found in file: ' + write(*,*) ' ├> file:', file + write(*,*) ' ├> status:', status + write(*,*) ' ├> ',nf90_strerror(status) + write(*,*) ' └> check: namelist.* ' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + istart= (/ 1, 1, 1/) + icount= (/lonlen, latlen, zlen/) + status=nf90_get_var(ncid, varid, ncdata, start=istart, count=icount) + + ! missing value + status= nf90_get_att(ncid, varid, 'missing_value', missvalue) + + ! close file + status=nf90_close(ncid) + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! broadcast 2d data array to all processes + call MPI_BCast(ncdata , lonlen*latlen*zlen, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + call MPI_BCast(missvalue, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, ierror) + + !___________________________________________________________________________ + ! size of input array should be 3d (nz, myDim_elem2D) or (nz, myDim_nod2D) + found_error = .False. + nz = size(model_3Darray,1) + if (nz /= zlen) then + if (mype==0) then + print *, achar(27)//'[33m' + write(*,*) '____________________________________________________________________' + write(*,*) ' ERROR: length of zdimension in file does not agree with len of zdim in model' + write(*,*) '____________________________________________________________________' + print *, achar(27)//'[0m' + write(*,*) + found_error = .True. + end if + end if + ! broadcast found_error variable to all other processes --> create kill signal + ! for all processes + call MPI_BCast(found_error, 1, MPI_LOGICAL, 0, MPI_COMM_FESOM, ierror) + if (found_error) call par_ex(partit%MPI_COMM_FESOM, partit%mype) + + ! create interpolation coordinates + ! do data interpolation on vertices + if (do_onvert) then + num=myDim_nod2d+eDim_nod2d + allocate(temp_x(num), temp_y(num)) + do n=1, num + temp_x(n)=geo_coord_nod2d(1,n)/rad + temp_y(n)=geo_coord_nod2d(2,n)/rad + ! change lon range to [0 360] + if(temp_x(n)<0._WP) temp_x(n)=temp_x(n) + 360.0_WP + end do + + ! do data interpolation on element centroids + else + num = myDim_elem2D + allocate(temp_x(num), temp_y(num)) + do n=1, num + ! compute points of element centroids in geo frame use them here for interpolation + elnodes = elem2D_nodes(:,n) + elnodes_x= geo_coord_nod2D(1, elnodes) + xmin = minval(elnodes_x) + do k=1,3 + if(elnodes_x(k)-xmin>=cyclic_length/2.0_WP) elnodes_x(k)=elnodes_x(k)-cyclic_length + if(elnodes_x(k)-xmin<-cyclic_length/2.0_WP) elnodes_x(k)=elnodes_x(k)+cyclic_length + end do + ! compute in units [deg], in geo frame + temp_x(n)=sum(elnodes_x)/3.0_WP/rad + temp_y(n)=sum(geo_coord_nod2D(2,elnodes))/3.0_WP/rad + + ! change lon range to [0 360] + if(temp_x(n)<0._WP) temp_x(n)=temp_x(n) + 360.0_WP + end do + end if + + !___________________________________________________________________________ + ! do interpolation + do k=1,zlen + call interp_2d_field_v2(lonlen, latlen, & + lon, lat, ncdata(:,:,k), missvalue, & + num, temp_x, temp_y, model_3Darray(k,1:num), & + partit) + end do + deallocate(temp_y, temp_x, ncdata, lon, lat) + +end subroutine read_other_NetCDF_3d + + + + + + + + ! !------------------------------------------------------------------------------------ ! @@ -199,6 +658,7 @@ subroutine read_surf_hydrography_NetCDF(file, vari, itime, model_2Darray, partit USE MOD_PARSUP use g_rotate_grid use, intrinsic :: ISO_FORTRAN_ENV, only: real64 + use g_interp use netcdf implicit none @@ -322,6 +782,7 @@ subroutine read_2ddata_on_grid_NetCDF(file, vari, itime, model_2Darray, partit, USE MOD_PARTIT USE MOD_PARSUP use g_rotate_grid + use g_interp use netcdf implicit none diff --git a/src/ice_setup_step.F90 b/src/ice_setup_step.F90 index fd6684d17..1c6180089 100755 --- a/src/ice_setup_step.F90 +++ b/src/ice_setup_step.F90 @@ -333,21 +333,24 @@ subroutine ice_timestep(step, ice, partit, mesh) #if defined (FESOM_PROFILING) call fesom_profiler_end("ice_thermodynamics") #endif - rtime_ice = rtime_ice + (t3-t0) + rtime_ice = rtime_ice + (t3-t0) + rtime_ice_evp = rtime_ice_evp + t1-t0 + rtime_ice_adv = rtime_ice_adv + t2-t1 + rtime_ice_therm = rtime_ice_therm + t3-t2 rtime_tot = rtime_tot + (t3-t0) if(mod(step,logfile_outfreq)==0 .and. mype==0) then write(*,*) '___ICE STEP EXECUTION TIMES____________________________' #if defined (__icepack) - write(*,"(A, ES10.3)") ' Ice Dyn. :', time_evp - write(*,"(A, ES10.3)") ' Ice Advect. :', time_advec - write(*,"(A, ES10.3)") ' Ice Thermodyn. :', time_therm + write(*,"(A, ES10.3, A, F6.2, A)") ' Ice Dyn. :', time_evp, ' (', 100.0*time_evp/(t3-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Ice Advect. :', time_advec,' (', 100.0*time_advec/(t3-t0),'%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Ice Thermodyn. :', time_therm,' (', 100.0*time_therm/(t3-t0),'%)' #else - write(*,"(A, ES10.3)") ' Ice Dyn. :', t1-t0 - write(*,"(A, ES10.3)") ' Ice Advect. :', t2-t1 - write(*,"(A, ES10.3)") ' Ice Thermodyn. :', t3-t2 + write(*,"(A, ES10.3, A, F6.2, A)") ' Ice Dyn. :', t1-t0, ' (', 100.0*(t1-t0)/(t3-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Ice Advect. :', t2-t1, ' (', 100.0*(t2-t1)/(t3-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Ice Thermodyn. :', t3-t2, ' (', 100.0*(t3-t2)/(t3-t0), '%)' #endif /* (__icepack) */ write(*,*) ' _______________________________' - write(*,"(A, ES10.3)") ' Ice TOTAL :', t3-t0 + write(*,"(A, ES10.3)") ' Ice TOTAL :', t3-t0 write(*,*) endif end subroutine ice_timestep diff --git a/src/io_fesom_file.F90 b/src/io_fesom_file.F90 index 1706f0cec..9b1bd6053 100644 --- a/src/io_fesom_file.F90 +++ b/src/io_fesom_file.F90 @@ -56,7 +56,8 @@ module io_fesom_file_module integer, save :: m_nod2d integer, save :: m_elem2d integer, save :: m_nl - integer, save :: m_ncat + integer, save :: m_ncat + integer, save :: m_nfbin = 0 type fesom_file_type_ptr @@ -106,7 +107,7 @@ function time_dimindex(this) result(x) end function time_dimindex - subroutine init(this, mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat) ! todo: would like to call it initialize but Fortran is rather cluncky with overwriting base type procedures + subroutine init(this, mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat, mesh_nfbin) ! todo: would like to call it initialize but Fortran is rather cluncky with overwriting base type procedures use io_netcdf_workaround_module use io_gather_module use MOD_PARTIT @@ -115,6 +116,7 @@ subroutine init(this, mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat) ! tod integer mesh_elem2d integer mesh_nl integer, optional :: mesh_ncat + integer, optional :: mesh_nfbin type(t_partit), target :: partit ! EO parameters type(fesom_file_type_ptr), allocatable :: tmparr(:) @@ -129,11 +131,16 @@ subroutine init(this, mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat) ! tod m_elem2d = mesh_elem2d m_nl = mesh_nl !PS mesh_ncat ... icepack number of ice thickness classes, - if (present(mesh_ncat)) then + if (present(mesh_ncat)) then m_ncat = mesh_ncat - else + else m_ncat = 0 - end if + end if + if (present(mesh_nfbin)) then + m_nfbin = mesh_nfbin + else + m_nfbin = 0 + end if call this%netcdf_file_type%initialize() @@ -593,7 +600,9 @@ function obtain_diminfo(this, len) result(info) else if(len == m_nl ) then info = dim_info( idx=this%add_dim('nz' , len), len=len) else if(len == m_ncat ) then - info = dim_info( idx=this%add_dim('ncat', len), len=len) + info = dim_info( idx=this%add_dim('ncat', len), len=len) + else if(len == m_nfbin .and. m_nfbin > 0) then + info = dim_info( idx=this%add_dim('nfbin', len), len=len) else print *, "error in line ",__LINE__, __FILE__," can not find dimension with size",len stop 1 diff --git a/src/io_meandata.F90 b/src/io_meandata.F90 index 007cf2490..6aaf6521b 100644 --- a/src/io_meandata.F90 +++ b/src/io_meandata.F90 @@ -76,6 +76,7 @@ module io_MEANDATA real(kind=WP) :: rtime_per_stream=0._WP !< cumulative wall in this stream's write_mean dispatch over the run; printed sorted at finalize logical :: is_in_use=.false. logical :: is_elem_based = .false. + logical :: is_fbin_based = .false. logical :: flip class(data_strategy_type), allocatable :: data_strategy integer :: comm @@ -209,6 +210,7 @@ subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) #if defined (__cvmix) use g_cvmix_tke use g_cvmix_idemix + use g_cvmix_idemix2 use g_cvmix_kpp use g_cvmix_tidal #endif @@ -1687,7 +1689,7 @@ subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) !_______________________________________________________________________________ ! TKE mixing diagnostic CASE ('TKE ') - if (mix_scheme_nmb==5 .or. mix_scheme_nmb==56) then + if (mix_scheme_nmb==5 .or. mix_scheme_nmb==56 .or. mix_scheme_nmb==57) then call def_stream((/nl,nod2D/), (/nl,myDim_nod2D/), 'tke' , 'turbulent kinetic energy' , 'm^2/s^2', tke(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream((/nl,nod2D/), (/nl,myDim_nod2D/), 'tke_Ttot', 'total production of turbulent kinetic energy', 'm^2/s^3', tke_Ttot(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream((/nl,nod2D/), (/nl,myDim_nod2D/), 'tke_Tbpr', 'TKE production by buoyancy' , 'm^2/s^3', tke_Tbpr(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) @@ -1709,22 +1711,102 @@ subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) CASE ('IDEMIX ') if (mod(mix_scheme_nmb,10)==6) then call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe' , 'internal wave energy' , 'm^2/s^2', iwe(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) - call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Ttot', 'total production of internal wave energy' , 'm^2/s^2', iwe_Ttot(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Ttot', 'total production of internal wave energy' , 'm^2/s^3', iwe_Ttot(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Tdif', 'IWE production by vertical diffusion' , 'm^2/s^3', iwe_Tdif(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Tdis', 'IWE production by dissipation' , 'm^2/s^3', iwe_Tdis(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) - call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Tsur', 'IWE production from surface forcing' , 'm^2/s^2', iwe_Tsur(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) - call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Tbot', 'IWE production from bottom forcing' , 'm^2/s^2', iwe_Tbot(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) - call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Thdi', 'IWE production from hori. diffusion' , 'm^2/s^2', iwe_Thdi(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Tsur', 'IWE production from surface forcing' , 'm^2/s^3', iwe_Tsur(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Tbot', 'IWE production from bottom forcing' , 'm^2/s^3', iwe_Tbot(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_Thdi', 'IWE production from hori. diffusion' , 'm^2/s^3', iwe_Thdi(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_c0' , 'IWE vertical group velocity' , 'm/s' , iwe_c0(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) - call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_v0' , 'IWE horizontal group velocity' , 'm/s' , iwe_c0(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'iwe_v0' , 'IWE horizontal group velocity' , 'm/s' , iwe_v0(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream(elem2D , myDim_elem2D , 'iwe_fbot', 'IDEMIX bottom forcing' , 'm^3/s^3', iwe_fbot(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream(elem2D , myDim_elem2D , 'iwe_fsrf', 'IDEMIX surface forcing' , 'm^3/s^3', iwe_fsrf(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) end if +!_______________________________________________________________________________ +! IDEMIX2 mixing Internal-Wave-Energy diagnostics +CASE ('IDEMIX2 ') + if (mod(mix_scheme_nmb,10)==7) then + call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_Eiw' , 'internal wave energy ' , 'm^2/s^2', iwe2_E_iw(:,:,iwe2_tip1) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_Eiw_diss', 'Eiw production from dissipation', 'm^2/s^3', iwe2_E_iw_diss( :,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_c0' , 'Eiw vertical group velocity' , 'm/s' , iwe2_c0(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_v0' , 'Eiw horizontal group velocity' , 'm/s' , iwe2_v0(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_alpha_c' , 'Eiw dissipation coefficien' , 's/m^2' , iwe2_alpha_c(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream( nod2d , myDim_nod2D , 'iwe2_fbot' , 'bottom forcing' , 'm^3/s^3', iwe2_fbot_n(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream( nod2d , myDim_nod2D , 'iwe2_fsrf' , 'surface forcing' , 'm^3/s^3', iwe2_fsrf(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream( nod2d , myDim_nod2D , 'iwe2_cn' , 'baroclinic velocity' , 'm/s' , iwe2_cn(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + ! optional diagnostic + if (idemix2_diag_Eiw) then + if (allocated(iwe2_E_iw_dt )) call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_Eiw_dt' , 'Eiw total production ' , 'm^2/s^3', iwe2_E_iw_dt( :,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_iw_hdif)) call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_Eiw_hdif', 'Eiw production from hor. diff.' , 'm^2/s^3', iwe2_E_iw_hdif( :,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_iw_vdif)) call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_Eiw_vdif', 'Eiw production from ver. diff.' , 'm^2/s^3', iwe2_E_iw_vdif( :,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_iw_fsrf)) call def_stream( nod2d , myDim_nod2D , 'iwe2_Eiw_fsrf', 'Eiw production from srf. forc.' , 'm^2/s^3', iwe2_E_iw_fsrf( :) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_iw_fbot)) call def_stream((/nl,nod2d/), (/nl,myDim_nod2D/), 'iwe2_Eiw_fbot', 'Eiw production from bot. forc.' , 'm^2/s^3', iwe2_E_iw_fbot( :,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if + + if (idemix2_enable_M2) then + + call def_stream( nod2d , myDim_nod2D , 'iwe2_m2_alphac' , 'M2 energy dissipation' , 's/m^2' , iwe2_alpha_M2_c(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream( nod2d , myDim_nod2D , 'iwe2_m2_tau' , 'M2 dissipation timescale' , 's' , iwe2_M2_tau(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_m2_forc' , 'M2 forcing' , 'm^3/s^3/rad', iwe2_fM2(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_m2_w' , 'M2 cross. spectr. propag.' , 'rad/s' , iwe2_M2_w(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin,elem2D/),(/idemix2_nfbin,myDim_elem2D/), 'iwe2_m2_u' , 'M2 zonal propag.' , 'm/s' , iwe2_M2_uv(1,:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin,elem2D/),(/idemix2_nfbin,myDim_elem2D/), 'iwe2_m2_v' , 'M2 merid. propag.' , 'm/s' , iwe2_M2_uv(2,:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2' , 'M2 wave energy' , 'm^2/s^2' , iwe2_E_M2( :,:,iwe2_tip1), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_divh' , 'EM2 horiz wave energy diverg.' , 'm^2/s^2' , iwe2_E_M2_divh(:,:,iwe2_ti ), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_divs' , 'EM2 crss spctr wave energy diverg.' , 'm^2/s^2' , iwe2_E_M2_divs(:,:,iwe2_ti ), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl , nod2d/),(/nl ,myDim_nod2D /), 'iwe2_Em2_strct' , 'EM2 structure function energy' , 'm^2/s^2' , iwe2_E_M2_struct(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + ! optional diagnostic + if (idemix2_diag_Ecompart) then + if (allocated(iwe2_E_M2_refl )) call def_stream(nod2d, myDim_nod2D, 'iwe2_Em2_refl' , 'EM2 coast-intercept. accumulated flux', 'm^2/s^3', iwe2_E_M2_refl(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_M2_dt )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_dt' , 'EM2 total tendency' , 'm^2/s^3' , iwe2_E_M2_dt( :,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_M2_advh )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_advh' , 'EM2 horizontal advection' , 'm^2/s^3' , iwe2_E_M2_advh(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_M2_advs )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_advs' , 'EM2 spectral advection' , 'm^2/s^3' , iwe2_E_M2_advs(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_M2_diss )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_diss' , 'EM2 dissipation' , 'm^2/s^3' , iwe2_E_M2_diss(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_M2_forc )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_forc' , 'EM2 forcing tendency' , 'm^2/s^3' , iwe2_E_M2_forc(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if + if (idemix2_diag_WWI) then + if (allocated(iwe2_E_iw_diss_M2)) call def_stream((/nl ,nod2d/),(/nl ,myDim_nod2D /), 'iwe2_Eiw_dissM2' , 'Eiw dissipation through M2 WWI' , 'm^2/s^3' , iwe2_E_iw_diss_M2(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_M2_diss_wwi))call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Em2_dissWWI', 'EM2 dissipation through Eiw' , 'm^2/s^3' , iwe2_E_M2_diss_wwi(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if + end if + + if (idemix2_enable_niw) then + call def_stream( nod2d , myDim_nod2D , 'iwe2_niw_omega' , 'niw frequency' , '1/s' , iwe2_omega_niw(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream( nod2d , myDim_nod2D , 'iwe2_niw_tau' , 'niw dissipation timescale' , 's' , iwe2_niw_tau(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_niw_forc' , 'niw forcing' , 'm^3/s^3/rad', iwe2_fniw(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_niw_w' , 'niw cross. spectr. propag.' , 'rad/s' , iwe2_niw_w(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin,elem2D/),(/idemix2_nfbin,myDim_elem2D/), 'iwe2_niw_u' , 'niw zonal propag.' , 'm/s' , iwe2_niw_uv(1,:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin,elem2D/),(/idemix2_nfbin,myDim_elem2D/), 'iwe2_niw_v' , 'niw merid. propag.' , 'm/s' , iwe2_niw_uv(2,:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw' , 'niw wave energy' , 'm^2/s^2' , iwe2_E_niw( :,:,iwe2_tip1), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw_divh' , 'Eniw horz wave energy diverg.' , 'm^2/s^2' , iwe2_E_niw_divh(:,:,iwe2_ti ), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw_divs' , 'Eniw crss spctr wave energy diverg.', 'm^2/s^2' , iwe2_E_niw_divs(:,:,iwe2_ti ), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream((/nl , nod2d/),(/nl ,myDim_nod2D /), 'iwe2_Eniw_strct' , 'Eniw structure function energy' , 'm^2/s^2' , iwe2_E_niw_struct(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + ! optional diagnostic + if (idemix2_diag_Ecompart) then + if (allocated(iwe2_E_niw_refl )) call def_stream(nod2d, myDim_nod2D, 'iwe2_Eniw_refl' , 'Eniw coast-intercept. accumulated flux', 'm^2/s^3', iwe2_E_niw_refl(:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_niw_dt )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw_dt' , 'Eniw total tendency' , 'm^2/s^3' , iwe2_E_niw_dt( :,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_niw_advh )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw_advh' , 'Eniw horizontal advection' , 'm^2/s^3' , iwe2_E_niw_advh(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_niw_advs )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw_advs' , 'Eniw spectral advection' , 'm^2/s^3' , iwe2_E_niw_advs(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_niw_diss )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw_diss' , 'Eniw dissipation' , 'm^2/s^3' , iwe2_E_niw_diss(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + if (allocated(iwe2_E_niw_forc )) call def_stream((/idemix2_nfbin, nod2d/),(/idemix2_nfbin,myDim_nod2D /), 'iwe2_Eniw_forc' , 'Eniw forcing tendency' , 'm^2/s^3' , iwe2_E_niw_forc(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if + if (idemix2_diag_WWI) then + if (allocated(iwe2_E_iw_diss_niw)) call def_stream((/nl ,nod2d/),(/nl ,myDim_nod2D /), 'iwe2_Eiw_dissniw', 'Eiw dissipation through niw WWI' , 'm^2/s^3' , iwe2_E_iw_diss_niw(:,:) , io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if + end if + + if (idemix2_enable_M2 .or. idemix2_enable_niw) then + call def_stream(nod2d, myDim_nod2D, 'topo_dist2c', 'distance from coast' , 'm', iwe2_topo_dist, io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream(nod2d, myDim_nod2D, 'topo_hrms' , 'Root Mean Square Topographic Heigh', 'm', iwe2_topo_hrms, io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + call def_stream(nod2d, myDim_nod2D, 'topo_hlam' , 'Topographic Wavelength' , 'm', iwe2_topo_hlam, io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if + end if + !_______________________________________________________________________________ ! TIDAL mixing diagnostics CASE ('TIDAL ') - if (mod(mix_scheme_nmb,10)==7) then + if (mod(mix_scheme_nmb,10)==8) then ! cvmix_TIDAL diagnostics call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'tidal_Kv' , 'tidal diffusivity' , 'm^2/s' , tidal_Kv(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) call def_stream((/nl,elem2D/), (/nl,myDim_elem2D/), 'tidal_Av' , 'tidal viscosity' , 'm^2/s' , tidal_Av(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) @@ -2209,6 +2291,7 @@ function mesh_dimname_from_dimsize(size, partit, mesh) result(name) #if defined (__icepack) use icedrv_main, only: ncat ! number of ice thickness cathegories #endif + use g_cvmix_idemix2, only: idemix2_nfbin implicit none integer :: size type(t_mesh) , intent(in) :: mesh @@ -2229,6 +2312,8 @@ function mesh_dimname_from_dimsize(size, partit, mesh) result(name) elseif (size==ncat) then name='ncat' #endif + elseif (size==idemix2_nfbin) then + name='nfbin' else name='unknown' if (partit%mype==0) write(*,*) 'WARNING: unknown dimension in mean I/O with size of ', size @@ -2247,6 +2332,7 @@ subroutine create_new_file(entry, ice, dynamics, partit, mesh) use fesom_version_info_module use g_config use o_PARAM + use g_cvmix_idemix2, only: idemix2_nfbin, iwe2_phit use diagnostics, only: std_dens implicit none @@ -2295,6 +2381,10 @@ subroutine create_new_file(entry, ice, dynamics, partit, mesh) call assert_nf( nf90_def_var(entry%ncid, entry%dimname(1), nf90_int, (/entry%dimID(1)/), entry%dimvarID(1)), __LINE__) call assert_nf( nf90_put_att(entry%ncid, entry%dimvarID(1), 'long_name', 'sigma2 density class'), __LINE__) + elseif (entry%dimname(1)=='nfbin') then + call assert_nf( nf90_def_var(entry%ncid, entry%dimname(1), nf90_int, (/entry%dimID(1)/), entry%dimvarID(1)), __LINE__) + call assert_nf( nf90_put_att(entry%ncid, entry%dimvarID(1), 'long_name', 'spectral bins'), __LINE__) + else if (partit%mype==0) write(*,*) 'WARNING: unknown first dimension in 2d mean I/O data' @@ -2384,6 +2474,10 @@ subroutine create_new_file(entry, ice, dynamics, partit, mesh) #endif elseif (entry%dimname(1)=='ndens') then call assert_nf( nf90_put_var(entry%ncid, entry%dimvarID(1), std_dens), __LINE__) + + elseif (entry%dimname(1)=='nfbin') then + call assert_nf( nf90_put_var(entry%ncid, entry%dimvarID(1), iwe2_phit), __LINE__) + else if (partit%mype==0) write(*,*) 'WARNING: unknown first dimension in 2d mean I/O data' end if @@ -2617,16 +2711,25 @@ subroutine write_mean(entry, entry_index) end if !_______________________________________________________________________ - ! loop over vertical layers --> do gather 3d variables layerwise in 2d - ! slices + ! loop over vertical layers or spectral bins --> do gather 3d variables layerwise in 2d slices do lev=1, size1 !___________________________________________________________________ - ! local output variables are gahtered in 2d shaped entry%aux_r8 + ! local output variables are gathered in 2d shaped entry%aux_r8 ! either for vertices or elements - if(.not. entry%is_elem_based) then - call gather_nod2D (entry%local_values_r8_copy(lev,1:size(entry%local_values_r8_copy,dim=2)), entry%aux_r8, entry%root_rank, tag, entry%comm, entry%p_partit) + if (entry%is_fbin_based) then + ! Spectral bin arrays: gather bin by bin (same pattern as vertical levels) + if(.not. entry%is_elem_based) then + call gather_nod2D (entry%local_values_r8_copy(lev,1:size(entry%local_values_r8_copy,dim=2)), entry%aux_r8, entry%root_rank, tag, entry%comm, entry%p_partit) + else + call gather_elem2D(entry%local_values_r8_copy(lev,1:size(entry%local_values_r8_copy,dim=2)), entry%aux_r8, entry%root_rank, tag, entry%comm, entry%p_partit) + end if else - call gather_elem2D(entry%local_values_r8_copy(lev,1:size(entry%local_values_r8_copy,dim=2)), entry%aux_r8, entry%root_rank, tag, entry%comm, entry%p_partit) + ! Regular vertical-level arrays: gather layer by layer + if(.not. entry%is_elem_based) then + call gather_nod2D (entry%local_values_r8_copy(lev,1:size(entry%local_values_r8_copy,dim=2)), entry%aux_r8, entry%root_rank, tag, entry%comm, entry%p_partit) + else + call gather_elem2D(entry%local_values_r8_copy(lev,1:size(entry%local_values_r8_copy,dim=2)), entry%aux_r8, entry%root_rank, tag, entry%comm, entry%p_partit) + end if end if !___________________________________________________________________ @@ -2653,17 +2756,26 @@ subroutine write_mean(entry, entry_index) end if !_______________________________________________________________________ - ! loop over vertical layers --> do gather 3d variables layerwise in 2d - ! slices + ! loop over vertical layers or spectral bins --> do gather 3d variables layerwise in 2d slices do lev=1, size1 !PS if (entry%p_partit%mype==entry%root_rank) t0=MPI_Wtime() !___________________________________________________________________ - ! local output variables are gahtered in 2d shaped entry%aux_r8 + ! local output variables are gathered in 2d shaped entry%aux_r4 ! either for vertices or elements - if(.not. entry%is_elem_based) then - call gather_real4_nod2D (entry%local_values_r4_copy(lev,1:size(entry%local_values_r4_copy,dim=2)), entry%aux_r4, entry%root_rank, tag, entry%comm, entry%p_partit) + if (entry%is_fbin_based) then + ! Spectral bin arrays: gather bin by bin (same pattern as vertical levels) + if(.not. entry%is_elem_based) then + call gather_real4_nod2D (entry%local_values_r4_copy(lev,1:size(entry%local_values_r4_copy,dim=2)), entry%aux_r4, entry%root_rank, tag, entry%comm, entry%p_partit) + else + call gather_real4_elem2D(entry%local_values_r4_copy(lev,1:size(entry%local_values_r4_copy,dim=2)), entry%aux_r4, entry%root_rank, tag, entry%comm, entry%p_partit) + end if else - call gather_real4_elem2D(entry%local_values_r4_copy(lev,1:size(entry%local_values_r4_copy,dim=2)), entry%aux_r4, entry%root_rank, tag, entry%comm, entry%p_partit) + ! Regular vertical-level arrays: gather layer by layer + if(.not. entry%is_elem_based) then + call gather_real4_nod2D (entry%local_values_r4_copy(lev,1:size(entry%local_values_r4_copy,dim=2)), entry%aux_r4, entry%root_rank, tag, entry%comm, entry%p_partit) + else + call gather_real4_elem2D(entry%local_values_r4_copy(lev,1:size(entry%local_values_r4_copy,dim=2)), entry%aux_r4, entry%root_rank, tag, entry%comm, entry%p_partit) + end if end if !___________________________________________________________________ @@ -3301,6 +3413,7 @@ subroutine def_stream3D(glsize, lcsize, name, description, units, data, freq, fr use mod_mesh USE MOD_PARTIT USE MOD_PARSUP + use g_cvmix_idemix2, only: idemix2_nfbin implicit none type(t_partit), intent(inout), target :: partit integer, intent(in) :: glsize(2), lcsize(2) @@ -3372,6 +3485,14 @@ subroutine def_stream3D(glsize, lcsize, name, description, units, data, freq, fr entry%dimname(1)=mesh_dimname_from_dimsize(glsize(1), partit, mesh) !2D! mesh_dimname_from_dimsize(glsize, mesh) entry%dimname(2)=mesh_dimname_from_dimsize(glsize(2), partit, mesh) !2D! entry%dimname(2)='unknown' + + ! Check if this is a spectral bin array based on dimension size + if (glsize(1) == idemix2_nfbin) then + entry%is_fbin_based = .true. + else + entry%is_fbin_based = .false. + end if + ! non dimension specific call def_stream_after_dimension_specific(entry, name, description, units, freq, freq_unit, accuracy, partit, mesh, long_description) diff --git a/src/io_mesh_info.F90 b/src/io_mesh_info.F90 index 79288c307..1a3725fc5 100644 --- a/src/io_mesh_info.F90 +++ b/src/io_mesh_info.F90 @@ -5,6 +5,8 @@ module io_mesh_info use g_config use g_comm_auto use o_PARAM +use g_cvmix_idemix2, only: iwe2_refl_bin, iwe2_refl_sgn, iwe2_refl_node, iwe2_coast_node, & + idemix2_enable_M2, idemix2_enable_niw use netcdf implicit none @@ -46,6 +48,7 @@ subroutine write_mesh_info(partit, mesh) integer :: lon_id, lat_id ! UGRID NAMES START HERE integer :: face_node_id, edge_nodes_id, face_edges_id, face_links_id, edge_face_links_id + integer :: iwe2_refl_bin_id, iwe2_refl_sgn_id, iwe2_refl_node_id, iwe2_coast_node_id character(100) :: longname character(2000) :: filename real(kind=WP), allocatable :: rbuffer(:), lrbuffer(:) @@ -327,6 +330,12 @@ subroutine write_mesh_info(partit, mesh) call my_def_var(ncid, 'gradient_sca_y', NF90_DOUBLE, 2, (/elem_n_id, id_3/), gradient_sca_y_id, 'y component of a gradient at nodes of an element', partit) call my_def_var(ncid, 'gradient_vec_x', NF90_DOUBLE, 2, (/elem_n_id, id_3/), gradient_vec_x_id, 'x component of a gradient at elements of an element', partit) call my_def_var(ncid, 'gradient_vec_y', NF90_DOUBLE, 2, (/elem_n_id, id_3/), gradient_vec_y_id, 'y component of a gradient at elements of an element', partit) + if (mod(mix_scheme_nmb,10)==7 .and. (idemix2_enable_M2 .or. idemix2_enable_niw)) then + call my_def_var(ncid, 'iwe2_refl_bin', NF90_INT, 1, (/edge_n_id/), iwe2_refl_bin_id, 'IDEMIX2 reflect BC: mirror spectral bin per coast edge (0=interior)', partit) + call my_def_var(ncid, 'iwe2_refl_sgn', NF90_INT, 1, (/edge_n_id/), iwe2_refl_sgn_id, 'IDEMIX2 reflect BC: coast-node sign per edge (+1 node1 coast, -1 node2 coast)', partit) + call my_def_var(ncid, 'iwe2_refl_node', NF90_INT, 1, (/nod_n_id/), iwe2_refl_node_id, 'IDEMIX2 reflect BC: coast-adjacent interior node mask (0/1)', partit) + call my_def_var(ncid, 'iwe2_coast_node', NF90_INT, 1, (/nod_n_id/), iwe2_coast_node_id, 'IDEMIX2 reflect BC: coast node mask after MPI halo exchange (0/1)', partit) + end if call my_nf90_enddef(ncid, partit) ! NOTE(PG): Same order as definition! @@ -591,6 +600,25 @@ subroutine write_mesh_info(partit, mesh) deallocate(rbuffer) endif + if (mod(mix_scheme_nmb,10)==7 .and. (idemix2_enable_M2 .or. idemix2_enable_niw)) then + allocate(ibuffer(edge2D)) + call gather_edge(iwe2_refl_bin(1:myDim_edge2D), ibuffer, partit) + call my_put_vara(ncid, iwe2_refl_bin_id, 1, edge2D, ibuffer, partit) + call gather_edge(iwe2_refl_sgn(1:myDim_edge2D), ibuffer, partit) + call my_put_vara(ncid, iwe2_refl_sgn_id, 1, edge2D, ibuffer, partit) + deallocate(ibuffer) + + allocate(ibuffer(nod2D)) + allocate(lbuffer(myDim_nod2D)) + lbuffer = merge(1, 0, iwe2_refl_node(1:myDim_nod2D)) + call gather_nod(lbuffer, ibuffer, partit) + call my_put_vara(ncid, iwe2_refl_node_id, 1, nod2D, ibuffer, partit) + lbuffer = merge(1, 0, iwe2_coast_node(1:myDim_nod2D)) + call gather_nod(lbuffer, ibuffer, partit) + call my_put_vara(ncid, iwe2_coast_node_id, 1, nod2D, ibuffer, partit) + deallocate(lbuffer, ibuffer) + end if + call my_close(ncid, partit) end subroutine write_mesh_info diff --git a/src/io_restart.F90 b/src/io_restart.F90 index 4e7464fee..bd7caa296 100644 --- a/src/io_restart.F90 +++ b/src/io_restart.F90 @@ -19,6 +19,7 @@ MODULE io_RESTART #if defined (__cvmix) use g_cvmix_tke use g_cvmix_idemix + use g_cvmix_idemix2 #endif #if defined(__recom) use recom_glovar @@ -155,7 +156,20 @@ subroutine ini_ocean_io(dynamics, tracers, partit, mesh) endif if (mix_scheme_nmb==6 .or. mix_scheme_nmb==56) then call oce_files%def_elem_var_optional('iwe', 'Internal Wave Energy' , 'm2/s2', iwe(:,:), mesh, partit) - endif + endif + if (mod(mix_scheme_nmb,10)==7) then + call oce_files%def_node_var_optional('iwe2_Eiw' , 'IDEMIX2 low-mode IW energy' , 'm2/s2', iwe2_E_iw(:,:,1), mesh, partit) + if (idemix2_enable_M2) then + call oce_files%def_node_var_optional('iwe2_EM2' , 'IDEMIX2 M2 spectral energy' , 'm2/s2', iwe2_E_M2(:,:,1), mesh, partit, nfbin=idemix2_nfbin) + call oce_files%def_node_var_optional('iwe2_EM2divh' , 'IDEMIX2 M2 horiz div (AB2 prev)' , 'm2/s3', iwe2_E_M2_divh(:,:,1), mesh, partit, nfbin=idemix2_nfbin) + call oce_files%def_node_var_optional('iwe2_EM2divs' , 'IDEMIX2 M2 spec div (AB2 prev)' , 'm2/s3', iwe2_E_M2_divs(:,:,1), mesh, partit, nfbin=idemix2_nfbin) + end if + if (idemix2_enable_niw) then + call oce_files%def_node_var_optional('iwe2_Eniw' , 'IDEMIX2 NIW spectral energy' , 'm2/s2', iwe2_E_niw(:,:,1), mesh, partit, nfbin=idemix2_nfbin) + call oce_files%def_node_var_optional('iwe2_Eniwdivh', 'IDEMIX2 NIW horiz div (AB2 prev)', 'm2/s3', iwe2_E_niw_divh(:,:,1), mesh, partit, nfbin=idemix2_nfbin) + call oce_files%def_node_var_optional('iwe2_Eniwdivs', 'IDEMIX2 NIW spec div (AB2 prev)', 'm2/s3', iwe2_E_niw_divs(:,:,1), mesh, partit, nfbin=idemix2_nfbin) + end if + endif #endif if (dynamics%opt_visc==8) then call oce_files%def_elem_var_optional('uke', 'unresolved kinetic energy', 'm2/s2', uke(:,:), mesh, partit) @@ -426,8 +440,12 @@ subroutine read_initial_conditions(which_readr, ice, dynamics, tracers, partit, end if #endif +#if defined (__cvmix) + if (mod(mix_scheme_nmb,10)==7) call apply_idemix2_restart() +#endif + end if - + end subroutine read_initial_conditions !-------------------------------------------------------------------------------------------- @@ -544,6 +562,9 @@ subroutine write_initial_conditions(istep, nstart, ntotal, which_readr, ice, dyn ! Write restart files if(is_portable_restart_write) then +#if defined (__cvmix) + if (mod(mix_scheme_nmb,10)==7) call prepare_idemix2_restart() +#endif ! Write OCEAN restart if (partit%mype==RAW_RESTART_METADATA_RANK) print *, achar(27)//'[1;33m'//' --> write restarts to netcdf file: ocean'//achar(27)//'[0m' call write_netcdf_restarts(write_oce_path, oce_files, istep) diff --git a/src/io_restart_file_group.F90 b/src/io_restart_file_group.F90 index 27e34a5f7..663877b06 100644 --- a/src/io_restart_file_group.F90 +++ b/src/io_restart_file_group.F90 @@ -103,38 +103,41 @@ subroutine def_elem_var_3d(this, name, longname, units, local_data, mesh, partit end subroutine def_elem_var_3d - subroutine add_file(g, name, must_exist_on_read, mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat) + subroutine add_file(g, name, must_exist_on_read, mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat, mesh_nfbin) class(restart_file_group), target, intent(inout) :: g character(len=*), intent(in) :: name logical must_exist_on_read integer mesh_nod2d, mesh_elem2d, mesh_nl type(t_partit), intent(in) :: partit - !PS mesh_ncat ... icepack number of ice thickness classes, do it here as optional - !PS parameter, i assume is the less intrusive option. Therefore it must be + !PS mesh_ncat ... icepack number of ice thickness classes, do it here as optional + !PS parameter, i assume is the less intrusive option. Therefore it must be !PS at the end of the argumnent input list - integer, optional :: mesh_ncat + integer, optional :: mesh_ncat + integer, optional :: mesh_nfbin ! EO parameters type(restart_file_type), pointer :: f call assert(g%nfiles < size(g%files), __LINE__) g%nfiles = g%nfiles+1 f => g%files(g%nfiles) - + f%path = "" allocate(f%varname,source=name) f%must_exist_on_read = must_exist_on_read - - if (present(mesh_ncat)) then - call f%fesom_file_type%init(mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat) - ! make sure we can identify a 2d icepackvariable, problem here is, We have a new - ! dimension ncat number of ice thickness categories and icepack 2d vars have + + if (present(mesh_ncat)) then + call f%fesom_file_type%init(mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_ncat=mesh_ncat) + ! make sure we can identify a 2d icepackvariable, problem here is, We have a new + ! dimension ncat number of ice thickness categories and icepack 2d vars have ! dimensions (nod2, ncat) but fesom IO expects (ncat, nod2) --> means we ! need to sneek in a matrix transpose somehow!!! + else if (present(mesh_nfbin)) then + call f%fesom_file_type%init(mesh_nod2d, mesh_elem2d, mesh_nl, partit, mesh_nfbin=mesh_nfbin) else call f%fesom_file_type%init(mesh_nod2d, mesh_elem2d, mesh_nl, partit) end if ! this is specific for a restart file - f%iter_varindex = f%add_var_int('iter', [f%time_dimindex()]) + f%iter_varindex = f%add_var_int('iter', [f%time_dimindex()]) end subroutine add_file @@ -152,7 +155,7 @@ subroutine def_node_var_2d_optional(this, name, longname, units, local_data, mes call this%files(this%nfiles)%specify_node_var(name, longname, units, local_data) end subroutine def_node_var_2d_optional - subroutine def_node_var_3d_optional(this, name, longname, units, local_data, mesh, partit, ncat) + subroutine def_node_var_3d_optional(this, name, longname, units, local_data, mesh, partit, ncat, nfbin) use mod_mesh class(restart_file_group), intent(inout) :: this character(len=*) , intent(in) :: name @@ -161,18 +164,22 @@ subroutine def_node_var_3d_optional(this, name, longname, units, local_data, mes type(t_mesh) , intent(in) :: mesh type(t_partit) , intent(in) :: partit integer , intent(in) , optional :: ncat + integer , intent(in) , optional :: nfbin ! EO parameters - if (present(ncat)) then + if (present(ncat)) then !PS add a seprate case for icepack since here i need to write a 2d vertice file - !PS over the dimension of number of ice thickness classes. Additional input + !PS over the dimension of number of ice thickness classes. Additional input !PS parameter ncat - call add_file(this, name, .false., mesh%nod2d, mesh%elem2d, mesh%nl, partit, ncat) + call add_file(this, name, .false., mesh%nod2d, mesh%elem2d, mesh%nl, partit, mesh_ncat=ncat) call this%files(this%nfiles)%specify_node_var(name, longname, units, local_data, ncat) + else if (present(nfbin)) then + call add_file(this, name, .false., mesh%nod2d, mesh%elem2d, mesh%nl, partit, mesh_nfbin=nfbin) + call this%files(this%nfiles)%specify_node_var(name, longname, units, local_data) else call add_file(this, name, .false., mesh%nod2d, mesh%elem2d, mesh%nl, partit) call this%files(this%nfiles)%specify_node_var(name, longname, units, local_data) - end if - + end if + end subroutine def_node_var_3d_optional diff --git a/src/oce_adv_tra_driver.F90 b/src/oce_adv_tra_driver.F90 index fa0cd7c65..d3e2c9d71 100644 --- a/src/oce_adv_tra_driver.F90 +++ b/src/oce_adv_tra_driver.F90 @@ -365,7 +365,7 @@ subroutine do_oce_adv_tra(dt, vel, w, wi, we, tr_num, dynamics, tracers, partit, CASE('CDIFF') call adv_tra_ver_cdiff( pwvel, ttfAB, partit, mesh, adv_flux_ver, o_init_zero=do_zero_flux) CASE('PPM') - call adv_tra_vert_ppm(dt, pwvel, ttfAB, partit, mesh, adv_flux_ver, o_init_zero=do_zero_flux) + call adv_tra_ver_ppm(dt, pwvel, ttfAB, partit, mesh, adv_flux_ver, o_init_zero=do_zero_flux) CASE('UPW1') call adv_tra_ver_upw1 ( pwvel, ttfAB, partit, mesh, adv_flux_ver, o_init_zero=do_zero_flux) CASE DEFAULT !unknown diff --git a/src/oce_adv_tra_hor.F90 b/src/oce_adv_tra_hor.F90 index 3586f683c..2c72fac68 100644 --- a/src/oce_adv_tra_hor.F90 +++ b/src/oce_adv_tra_hor.F90 @@ -56,6 +56,23 @@ subroutine adv_tra_hor_mfct(vel, ttf, partit, mesh, num_ord, flux, edge_up_dn_gr real(kind=WP), intent(in) :: edge_up_dn_grad(4, mesh%nl-1, partit%myDim_edge2D) logical, optional :: o_init_zero end subroutine adv_tra_hor_mfct + + ! superbee advection num_ord=0: 2nd order in space num_ord=1: 2nd order in space + ! and time through Direct space-time scheme + subroutine adv_tra_hor_spbee(vel, ttf, partit, mesh, num_ord, flux, edge_up_dn_grad, flag_posdef, o_init_zero) + use MOD_MESH + USE MOD_PARTIT + USE MOD_PARSUP + type(t_partit), intent(inout), target :: partit + type(t_mesh) , intent(in) , target :: mesh + real(kind=WP) , intent(in) :: num_ord ! num_ord is the fraction of fourth-order contribution in the solution + real(kind=WP) , intent(in) :: ttf( mesh%nl-1, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP) , intent(in) :: vel(2, mesh%nl-1, partit%myDim_elem2D+partit%eDim_elem2D) + real(kind=WP) , intent(inout) :: flux( mesh%nl-1, partit%myDim_edge2D) + real(kind=WP) , intent(in) :: edge_up_dn_grad(4, mesh%nl-1, partit%myDim_edge2D) + logical , intent(in) :: flag_posdef + logical , optional :: o_init_zero + end subroutine adv_tra_hor_spbee end interface end module oce_adv_tra_hor_interfaces ! @@ -832,3 +849,407 @@ subroutine adv_tra_hor_mfct(vel, ttf, partit, mesh, num_ord, flux, edge_up_dn_gr !$ACC END PARALLEL LOOP #endif end subroutine adv_tra_hor_mfct + + + +! +! +!_______________________________________________________________________________ +! horizontal advection second order in space (2nd oprder in time) using superbee +! slope limiter +! !!! ATTENTION !!! +! This part is sofar untested it is left here for later pickup +subroutine adv_tra_hor_spbee( & + vel , & + ttf , & + partit , & + mesh , & + num_ord , & + flux , & + edge_up_dn_grad , & + flag_posdef , & + o_init_zero & + ) + use MOD_MESH + use MOD_TRACER + use MOD_PARTIT + use MOD_PARSUP + use g_config, only: dt + use g_comm_auto + implicit none + !___INPUT/OUTPUT VARIABLES__________________________________________________ + type(t_partit) , intent(inout), target :: partit + type(t_mesh) , intent(in) , target :: mesh + real(kind=WP) , intent(in) :: ttf( mesh%nl-1, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP) , intent(in) :: vel(2, mesh%nl-1, partit%myDim_elem2D+partit%eDim_elem2D) + real(kind=WP) , intent(inout) :: flux( mesh%nl-1, partit%myDim_edge2D) + real(kind=WP) , intent(in) :: edge_up_dn_grad(4, mesh%nl-1, partit%myDim_edge2D) + real(kind=WP) , intent(in) :: num_ord + logical , intent(in) :: flag_posdef + logical , optional :: o_init_zero + !___LOCAL VARIABLES_________________________________________________________ + logical :: l_init_zero, flag_2ndord_time + real(kind=WP) :: dx1, dy1, dx2, dy2, dx0, dy0, dxdy12(2), dt_over_edlen + real(kind=WP) :: n_x, n_y, nlen, inv_nlen + real(kind=WP) :: u1, u2, v1, v2, Ue + real(kind=WP) :: vflux, cfl, T12vflux + integer :: edel(2), ednodes(2), edge, edel0 + integer :: nz, nl1, nl2, nl12, nu1, nu2, nu12, nzs, nze +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !___________________________________________________________________________ + if (num_ord == 1.0_WP) then + flag_2ndord_time = .False. + else + flag_2ndord_time = .True. + end if + + !___________________________________________________________________________ + l_init_zero=.true. + if (present(o_init_zero)) then + l_init_zero=o_init_zero + end if + if (l_init_zero) then +#ifndef ENABLE_OPENACC + !$OMP PARALLEL DO +#else + !$ACC PARALLEL LOOP GANG VECTOR COLLAPSE(2) DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) +#endif + do edge=1, myDim_edge2D + do nz=1, mesh%nl-1 + flux(nz,edge)=0.0_WP + end do + end do +#ifndef ENABLE_OPENACC + !$OMP END PARALLEL DO +#else + !$ACC END PARALLEL LOOP +#endif + end if + + !___________________________________________________________________________ +!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(edge, ednodes, edel, edel0, & +!$OMP nz, nl1, nl2, nl12, nu1, nu2, nu12, nzs, nze, & +!$OMP dx1, dy1, dx2, dy2, dxdy12, dx0, dy0, & +!$OMP vflux, cfl, dt_over_edlen, T12vflux, & +!$OMP u1, u2, v1, v2, n_x, n_y, Ue) +!$OMP DO + do edge=1, myDim_edge2D + !_______________________________________________________________________ + ! local indice of nodes that span up edge ed + ednodes= edges(:,edge) + + ! local index of element that contribute to edge + edel = edge_tri(:,edge) + + nl1 = nlevels(edel(1))-1 + ! nu1 ... upper index of ocean default = 1 but can consider cavity !=1 + nu1 = ulevels(edel(1)) + + ! edge_cross_dxdy(1:2,ed)... dx,dy distance from center of edge to + ! element centroid el(1) --> needed to calc flux perpedicular to edge from elem el(1) + dx1 = edge_cross_dxdy(1,edge) + dy1 = edge_cross_dxdy(2,edge) + + ! length of edge dx dy + dxdy12 = edge_dxdy(:,edge)*r_earth + + !_______________________________________________________________________ + ! same parameter but for other element el(2) that contributes to edge ed + ! if el(2)==0 than edge is boundary edge + nl2 = 0 + nu2 = 0 + dx2 = 0.0_WP + dy2 = 0.0_WP + if(edel(2)>0) then + nl2 = nlevels(edel(2))-1 + nu2 = ulevels(edel(2)) + dx2 = edge_cross_dxdy(3,edge) + dy2 = edge_cross_dxdy(4,edge) + dxdy12(1)= dxdy12(1) * (elem_cos(edel(1)) + elem_cos(edel(2))) * 0.5_WP + + ! compute mean edge-segment normal vector + ! (dx1,dy1) + ! ^ + ! │ + ! ├──> (dy1,-dx1) + ! │ + ! ●━━━━━━━━━━━┿━━━━━━━━━━►● + ! │ + ! (dy2,-dx2) <──┼──> (-dy2,dx2) + ! │ + ! v + ! (dx2,dy2) + ! + n_x = ( dy1 + (-dy2))/2 + n_y = ((-dx1) + dx2 )/2 + + else + dxdy12(1)= dxdy12(1) * elem_cos(edel(1)) + ! compute edge-segment normal vector + n_x = dy1 + n_y = -dx1 + end if + + ! normalize n_vec=(n_x, n_y) + nlen = sqrt(n_x**2 + n_y**2) + inv_nlen = 1/max(nlen, tiny(1.0_WP)) + n_x = n_x * inv_nlen + n_y = n_y * inv_nlen + + dt_over_edlen = dt/sqrt(dxdy12(1)**2 + dxdy12(2)**2) + + !_______________________________________________________________________ + ! compute volume fluxes + nu12=max(nu1,nu2) + nl12=min(nl1,nl2) + + !_______________________________________________________________________ + ! loop over upper uncommon edge levels between edel(1) and edel(2) + ! --> edge is boundary edge, edel(2) does not exist + ! In this case the entire advection of this edge is only handled by the first + ! loop the other two loop will be skiped + if (edel(2) <= 0) then + nzs = nu1 + nze = nl1 + edel0 = edel(1) + dx0 = -dx1 + dy0 = dy1 + ! --> edge is interior edge + elseif (nu1 < nu2) then + nzs = nu1 + nze = nu12-1 + edel0 = edel(1) + dx0 = -dx1 + dy0 = dy1 + ! --> edge is interior edge + else ! (nu1 > nu2) + nzs = nu2 + nze = nu12-1 + edel0 = edel(2) + dx0 = dx2 + dy0 = -dy2 + end if + do nz=nzs, nze + ! compute volume flux across the segments from el(1) + u1 = vel(1, nz, edel0) + v1 = vel(2, nz, edel0) + vflux = (v1*dx0 + u1*dy0)*helem(nz,edel0) + + ! compute approximated edge centered and along edge projected + ! mean velocity --> need to add component to make second order + ! in time + Ue = abs( (u1 * n_x) + (v1 * n_y) ) + cfl = Ue*dt_over_edlen + + ! compute upwind, downwind edge centered tracers volume flux, based on + ! gradient projected ttfm1 and ttfp2 values and applied superbee limiter + T12vflux = spbee_compute_T12vflux(ttf(nz, ednodes(1)), ttf(nz, ednodes(2)), & + edge_up_dn_grad(:, nz, edge), & + vflux, cfl, dxdy12, flag_2ndord_time, flag_posdef) + + flux(nz, edge)= -T12vflux - flux(nz, edge) + end do ! --> do nz=nu0, nu12-1 + + !_______________________________________________________________________ + ! if edge is boundary edge skip this code block everything is handled by the + ! first loop + if (edel(2)>0) then + !_______________________________________________________________________ + ! loop over common edge depth levels between edel(1) and edel(2) + do nz = nu12, nl12 + ! compute volume flux across the segments from el(1) + u1 = vel(1, nz, edel(1)) + v1 = vel(2, nz, edel(1)) + u2 = vel(1, nz, edel(2)) + v2 = vel(2, nz, edel(2)) + vflux = (-v1*dx1 + u1*dy1)*helem(nz,edel(1)) + ( v2*dx2 - u2*dy2)*helem(nz,edel(2)) + + ! compute approximated edge centered and along edge projected + ! mean velocity --> need to add component to make second order + ! in time + Ue = abs( 0.5_WP*( u1 + u2 )*n_x + 0.5_WP*( v1 + v2 )*n_y ) + cfl = Ue*dt_over_edlen + + ! compute upwind, downwind edge centered tracers volume flux, based on + ! gradient projected ttfm1 and ttfp2 values and applied superbee limiter + T12vflux = spbee_compute_T12vflux(ttf(nz, ednodes(1)), ttf(nz, ednodes(2)), & + edge_up_dn_grad(:, nz, edge), & + vflux, cfl, dxdy12, flag_2ndord_time, flag_posdef) + + flux(nz, edge)= -T12vflux - flux(nz, edge) + end do !--> do nz=nu12, nl12 + + !_______________________________________________________________________ + ! loop over lower uncommon edge levels between edel(1) and edel(2) + if (nl1 > nl2) then + nzs = nl12+1 + nze = nl1 + edel0 = edel(1) + dx0 = -dx1 + dy0 = dy1 + else ! (nl1 < nl2) + nzs = nl12+1 + nze = nl2 + edel0 = edel(2) + dx0 = dx2 + dy0 = -dy2 + end if + do nz = nzs, nze + ! compute volume flux across the segments from el(1) + u1 = vel(1, nz, edel0) + v1 = vel(2, nz, edel0) + vflux = (v1*dx0 + u1*dy0)*helem(nz,edel0) + + ! compute approximated edge centered and along edge projected + ! mean velocity --> need to add component to make second order + ! in time + Ue = abs( u1 * n_x + v1 * n_y) + cfl = Ue*dt_over_edlen + + ! compute upwind, downwind edge centered tracers volume flux, based on + ! gradient projected ttfm1 and ttfp2 values and applied superbee limiter + T12vflux = spbee_compute_T12vflux(ttf(nz, ednodes(1)), ttf(nz, ednodes(2)), & + edge_up_dn_grad(:, nz, edge), & + vflux, cfl, dxdy12, flag_2ndord_time, flag_posdef) + + flux(nz, edge)= -T12vflux - flux(nz, edge) + end do ! --> do nz=nl12+1,nl1 + end if ! --> if (edel(2)>0) then + end do !--> do edge=1, myDim_edge2D +!$OMP END DO +!$OMP END PARALLEL + + contains + + ! + ! + !___________________________________________________________________________ + ! superbee slope limiter + pure elemental real(kind=WP) function spbee_limiter(R) result(Cr) + real(kind=WP), intent(in) :: R + Cr = max(0._WP, max( min(2._WP*R, 1._WP), min(R, 2._WP) )) + end function spbee_limiter + + ! + ! + !___________________________________________________________________________ + ! compute edge centered superbee limited tracer volume flux + pure real(kind=WP) function spbee_compute_T12vflux(& + ttf0 , & + ttfp1 , & + ttf_grad_ed , & + vflux , & + cfl , & + dxdy12 , & + flag_2ndord_time , & + flag_posdef & + ) result(T12vflux) + real(kind=WP), intent(in) :: ttf0, ttfp1, ttf_grad_ed(4), & + vflux, cfl, dxdy12(2) + logical , intent(in) :: flag_2ndord_time, flag_posdef + real(kind=WP) :: dttf0p1, ttfp2, ttfm1, R, Cr, vfabs, Tmean1, Tmean2 + + !_______________________________________________________________________ + ! compute tracer difference allong edge + dttf0p1 = ttfp1-ttf0 + + !_______________________________________________________________________ + ! tracer Slope Ratio Calculation for upwind augmented point + ! + ! o + ! ○._ .´ `. .-○ + ! | `._ .´ ^ dx1,dy1 .-´ | + ! | `._ .´ ├─> `. .-´ | + ! | □ `●━━━━━━┿━━━━━►●´----□---|-->●ttf_p2 + ! | .-´│`. <─┤ .´│`._ | + ! | .-´ dx2,dy2 v .´ │ `._ | + ! ○.-´ │ `. .´ │ `._○ + ! │ o │ + ! ├------------>┤ + ! │ dxdy12 │ + ! │ dttf0p1 │ + ! v v + ! ttf_0 ttf_grad_ed(3:4) + ! ttf_p1 + ttfp2 = ttf0 & + + 2.0_WP * dxdy12(1)*ttf_grad_ed(3) & + + 2.0_WP * dxdy12(2)*ttf_grad_ed(4) + + ! considering here we want to advect energy we can ensure the + ! variable to be positiv definit + ttfp2 = merge(max(0.0_WP,ttfp2), ttfp2, flag_posdef) + + ! compute tracer slope + R = (ttfp1-ttfp2)/(-dttf0p1+small) + + ! apply superbee limiter + Cr = spbee_limiter(R) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dx ]_Limited * dx/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dx ]_Limited * (dx/2 - u_ed*n_ed*dt/2) + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dx ]_Limited * dx/2 *(1 - CFL_h) + ! --> becomes second order in space and time (Direct space-time scheme) + ! --> u_ed = (vel(el(1)) + vel(el(2)))/2 + ! --> n_ed = (n_1 + n_2)/2 + ! --> CFL_h = u_ed*n_ed*dt/dx + Tmean2 = ttfp1 + 0.5_WP * Cr * (-dttf0p1) * (1.0_WP-merge(cfl, 0.0_WP, flag_2ndord_time)) + + !_______________________________________________________________________ + ! tracer Slope Ratio Calculation for downwind augmented point + ! + ! o + ! ○._ .´ `. .-○ + ! | `._ .´ ^ dx1,dy1 .-´ | + ! | `._ .´ ├─> `. .-´ | + ! ttf_m1●<--|---□----`●━━━━━━┿━━━━━►●´ □ | + ! | .-´│`. <─┤ .´│`._ | + ! | .-´ dx2,dy2 v .´ │ `._ | + ! ○.-´ │ `. .´ │ `._○ + ! │ o │ + ! ├------------>┤ + ! │ dxdy12 │ + ! │ dttf0p1 │ + ! v v + ! ttf_grad_ed(1:2) ttf_p1 + ! ttf0 + ttfm1 = ttfp1 & + - 2.0_WP * dxdy12(1)*ttf_grad_ed(1) & + - 2.0_WP * dxdy12(2)*ttf_grad_ed(2) + + ! considering here we want to advect energy we can ensure the + ! variable to be positiv definit + ttfm1 = merge(max(0.0_WP,ttfm1), ttfm1, flag_posdef) + + ! compute tracer slope + R = (ttf0-ttfm1)/(dttf0p1+small) + + ! apply superbee limiter + Cr = spbee_limiter(R) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dx ]_Limited * dx/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dx ]_Limited * (dx/2 - u_ed*n_ed*dt/2) + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dx ]_Limited * dx/2 *(1 - CFL_h) + ! --> becomes second order in space and time (Direct space-time scheme) + ! --> u_ed = (vel(el(1)) + vel(el(2)))/2 + ! --> n_ed = (n_1 + n_2)/2 + ! --> CFL_h = u_ed*n_ed*dt/dx + Tmean1 = ttf0 + 0.5_WP * Cr * (dttf0p1) * (1.0_WP-merge(cfl, 0.0_WP, flag_2ndord_time)) + + ! compute upwind/downwind related tracer volume flux + vfabs = abs(vflux) + T12vflux= 0.5_WP*( (vflux+vfabs)*Tmean1+ (vflux-vfabs)*Tmean2) + end function spbee_compute_T12vflux + +end subroutine adv_tra_hor_spbee + + diff --git a/src/oce_adv_tra_ver.F90 b/src/oce_adv_tra_ver.F90 index 1cebcf089..30be62a03 100644 --- a/src/oce_adv_tra_ver.F90 +++ b/src/oce_adv_tra_ver.F90 @@ -2,7 +2,7 @@ module oce_adv_tra_ver_interfaces interface ! implicit 1st order upwind vertical advection with to solve for fct_LO ! updates the input tracer ttf - subroutine adv_tra_vert_impl(dt, w, ttf, partit, mesh) + subroutine adv_tra_ver_impl(dt, w, ttf, partit, mesh) use mod_mesh USE MOD_PARTIT USE MOD_PARSUP @@ -11,7 +11,7 @@ subroutine adv_tra_vert_impl(dt, w, ttf, partit, mesh) type(t_mesh), intent(in), target :: mesh real(kind=WP), intent(inout) :: ttf(mesh%nl-1, partit%myDim_nod2D+partit%eDim_nod2D) real(kind=WP), intent(in) :: W (mesh%nl, partit%myDim_nod2D+partit%eDim_nod2D) - end subroutine adv_tra_vert_impl + end subroutine adv_tra_ver_impl !=============================================================================== ! 1st order upwind (explicit) ! returns flux given at vertical interfaces of scalar volumes @@ -53,7 +53,7 @@ end subroutine adv_tra_ver_qr4c ! IF o_init_zero=.TRUE. : flux will be set to zero before computation ! IF o_init_zero=.FALSE. : flux=flux-input flux ! flux is not multiplied with dt - subroutine adv_tra_vert_ppm(dt, w, ttf, partit, mesh, flux, o_init_zero) + subroutine adv_tra_ver_ppm(dt, w, ttf, partit, mesh, flux, o_init_zero) use MOD_MESH USE MOD_PARTIT USE MOD_PARSUP @@ -65,7 +65,7 @@ subroutine adv_tra_vert_ppm(dt, w, ttf, partit, mesh, flux, o_init_zero) real(kind=WP), intent(in) :: W (mesh%nl, partit%myDim_nod2D+partit%eDim_nod2D) real(kind=WP), intent(inout) :: flux(mesh%nl, partit%myDim_nod2D) logical, optional :: o_init_zero - end subroutine adv_tra_vert_ppm + end subroutine adv_tra_ver_ppm ! central difference reconstruction (2nd order, use only with FCT) ! returns flux given at vertical interfaces of scalar volumes ! IF o_init_zero=.TRUE. : flux will be set to zero before computation @@ -84,6 +84,25 @@ subroutine adv_tra_ver_cdiff(w, ttf, partit, mesh, flux, o_init_zero) real(kind=WP), intent(inout) :: flux(mesh%nl, partit%myDim_nod2D) logical, optional :: o_init_zero end subroutine adv_tra_ver_cdiff +! superbee, slope limited reconstruction (2nd order in space and time ) +! returns flux given at vertical interfaces of scalar volumes +! IF o_init_zero=.TRUE. : flux will be set to zero before computation +! IF o_init_zero=.FALSE. : flux=flux-input flux +! flux is not multiplied with dt + subroutine adv_tra_ver_spbee(w, ttf, partit, mesh, flux, flag_2ndord_time, flag_posdef, o_init_zero) + use MOD_MESH + USE MOD_PARTIT + USE MOD_PARSUP + type(t_partit),intent(in), target :: partit + type(t_mesh), intent(in), target :: mesh + real(kind=WP) :: tvert(mesh%nl), tv + real(kind=WP), intent(in) :: ttf(mesh%nl-1, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(in) :: W (mesh%nl, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(inout) :: flux(mesh%nl, partit%myDim_nod2D) + logical , intent(in) :: flag_2ndord_time + logical , intent(in) :: flag_posdef + logical, optional :: o_init_zero + end subroutine adv_tra_ver_spbee end interface end module oce_adv_tra_ver_interfaces !=============================================================================== @@ -435,7 +454,7 @@ end subroutine adv_tra_ver_qr4c ! ! !=============================================================================== -subroutine adv_tra_vert_ppm(dt, w, ttf, partit, mesh, flux, o_init_zero) +subroutine adv_tra_ver_ppm(dt, w, ttf, partit, mesh, flux, o_init_zero) use MOD_MESH use MOD_TRACER USE MOD_PARTIT @@ -628,7 +647,7 @@ subroutine adv_tra_vert_ppm(dt, w, ttf, partit, mesh, flux, o_init_zero) ! if (mype==0) write(*,*) 'PPM overshoot statistics:', real(overshoot_counter)/real(counter) !$OMP END DO !$OMP END PARALLEL -end subroutine adv_tra_vert_ppm +end subroutine adv_tra_ver_ppm ! ! !=============================================================================== @@ -693,3 +712,175 @@ subroutine adv_tra_ver_cdiff(w, ttf, partit, mesh, flux, o_init_zero) !$OMP END DO !$OMP END PARALLEL end subroutine adv_tra_ver_cdiff + + +! +! +!_______________________________________________________________________________ +! vertical advection 2nd order in space (and time) using superbee slope limiter +! !!! ATTENTION !!! +! This part is sofar untested it is left here for later pickup +subroutine adv_tra_ver_spbee( & + W , & + ttf , & + partit , & + mesh , & + flux , & + flag_2ndord_time , & + flag_posdef , & + o_init_zero & + ) + use MOD_MESH + use MOD_TRACER + use MOD_PARTIT + use MOD_PARSUP + use g_config, only: dt + use g_comm_auto + implicit none + !___INPUT/OUTPUT VARIABLES__________________________________________________ + type(t_partit),intent(inout), target :: partit + type(t_mesh), intent(in) , target :: mesh + real(kind=WP), intent(in) :: W ( mesh%nl , partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(in) :: ttf( mesh%nl-1, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(inout) :: flux(mesh%nl , partit%myDim_nod2D) + logical , intent(in) :: flag_2ndord_time + logical , intent(in) :: flag_posdef + logical , optional :: o_init_zero + !___LOCAL VARIABLES_________________________________________________________ + logical :: l_init_zero + integer :: node, nz, nzmin, nzmax + real(kind=WP) :: R, ttf0, ttfp1, dttf0p1, Tmean1, Tmean2, Cr, vflux, vfabs + real(kind=WP) :: cfl +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !___________________________________________________________________________ + l_init_zero=.true. + if (present(o_init_zero)) then + l_init_zero=o_init_zero + end if + if (l_init_zero) then +!$OMP PARALLEL DO + do node=1, myDim_nod2D + flux(:, node)=0.0_WP + end do +!$OMP END PARALLEL DO + end if + + !___________________________________________________________________________ +#ifndef ENABLE_OPENACC +!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(node, nz, nzmin, nzmax, ttf0, ttfp1, dttf0p1, & +!$OMP R, Cr, Tmean2, Tmean1, cfl, vflux, vfabs) +!$OMP DO +#else +!$ACC PARALLEL LOOP GANG DEFAULT(PRESENT) VECTOR_LENGTH(acc_vl) +#endif + !___________________________________________________________________________ + ! this advection does !!! NOT !!! go over the vertical dimension it goes + ! over the domain of the spectral bins + do node = 1, myDim_nod2D + nzmax=nlevels_nod2D(node) + nzmin=ulevels_nod2D(node) + + !_______________________________________________________________________ + ! vert. flux at surface layer + nz=nzmin + flux(nz,node)=-W(nz,node)*ttf(nz,node)*area(nz,node)-flux(nz,node) + + !_______________________________________________________________________ + ! vert. flux at bottom - 1 layer --> centered differences + nz=nzmax-1 + flux(nz,node)=-0.5_WP*(ttf(nz-1,node)+ttf(nz,node))*W(nz,node)*area(nz,node)-flux(nz,node) + + !_______________________________________________________________________ + ! vert. flux at bottom layer --> zero bottom flux + nz=nzmax + flux(nz,node)= 0.0_WP-flux(nz,node) + + !_______________________________________________________________________ + !loop over spectral bins +!$ACC LOOP VECTOR + do nz = nzmin+1, nzmax-2 + !___________________________________________________________________ + cfl = abs(W(nz, node)) * dt * 2.0_WP / (hnode(nz-1,node)+hnode(nz,node)) + + !___________________________________________________________________ + ! compute tracer difference + ttf0 = ttf(nz , node) + ttfp1 = ttf(nz+1, node) + dttf0p1 = ttfp1 - ttf0 + + !___________________________________________________________________ + ! tracer Slope Ratio Calculation for upwind point + ! compute tracer slope + R = (ttfp1-ttf(nz+2,node))/(-dttf0p1+small) + + ! apply superbee limiter + Cr = spbee_limiter(R) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dz ]_Limited * dz/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dz ]_Limited * (dz/2 -|W|*dt/2) + ! T_(i+0.5) = T_i+1 - [ (T_i+1 - T_i)/dz ]_Limited * dz/2 *(1 - CFL) + ! --> CFL = W*dt/dx + Tmean2 = ttfp1 + 0.5_WP*Cr*(-dttf0p1) * (1.0_WP-merge(cfl, 0.0_WP, flag_2ndord_time)) + + ! make sure tracer are enforced to be positive definite e.g for + ! internal wave energy + Tmean2 = merge(max(0.0_WP, Tmean2), Tmean2, flag_posdef) + + !___________________________________________________________________ + ! tracer Slope Ratio Calculation for downwind point + ! compute tracer slope + R = (ttf0-ttf(nz-1,node))/(dttf0p1+small) + + ! apply superbee limiter + Cr = spbee_limiter(R) + + ! construct edge centered tracer value + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dz ]_Limited * dz/2 + ! --> this is seconds order in space, but first order in time + ! + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dz ]_Limited * (dz/2 -|W|*dt/2) + ! T_(i+0.5) = T_i + [ (T_i+1 - T_i)/dz ]_Limited * dz/2 *(1 - CFL) + ! --> CFL = W*dt/dx + Tmean1 = ttf0 + 0.5_WP*Cr*(dttf0p1) * (1.0_WP-merge(cfl, 0.0_WP, flag_2ndord_time)) + + ! make sure tracer are enforced to be positive definite e.g for + ! internal wave energy + Tmean1 = merge(max(0.0_WP, Tmean1), Tmean1, flag_posdef) + !___________________________________________________________________ + ! cross spectral exchange rate is related to spectral width dphi + vflux = W(nz, node) + vfabs = abs(vflux) + flux(nz, node)=-0.5_WP*((vflux+vfabs)*Tmean1 + (vflux-vfabs)*Tmean2 & + )*area(nz,node) - flux(nz, node) + + end do !--> do nz = nzmin+1, nzmax-2 +!$ACC END LOOP + end do ! --> do node = 1, myDim_nod2D +#ifndef ENABLE_OPENACC +!$OMP END DO +!$OMP END PARALLEL +#else + !$ACC END PARALLEL LOOP +#endif + + contains + + ! + ! + !___________________________________________________________________________ + ! superbee slope limiter + pure elemental real(kind=WP) function spbee_limiter(R) result(Cr) + real(kind=WP), intent(in) :: R + Cr = max(0._WP, min( min(2._WP*R, 0.5_WP+R/2._WP), 2._WP )) + end function spbee_limiter + +end subroutine adv_tra_ver_spbee + + diff --git a/src/oce_ale.F90 b/src/oce_ale.F90 index 0f8e93b57..39deb2f97 100644 --- a/src/oce_ale.F90 +++ b/src/oce_ale.F90 @@ -3327,6 +3327,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) #if defined (__cvmix) use g_cvmix_tke use g_cvmix_idemix + use g_cvmix_idemix2 use g_cvmix_pp use g_cvmix_kpp use g_cvmix_tidal @@ -3357,7 +3358,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) type(t_mesh) , intent(inout), target :: mesh type(t_ice) , intent(inout), target :: ice !___________________________________________________________________________ - real(kind=8) :: t0,t1, t2, t30, t3, t4, t5, t6, t7, t8, t9, t10, loc, glo + real(kind=8) :: t0, t1, t2, t30, t3, t4, t5, t6, t7, t8, t9, t10, t11, loc, glo integer :: node integer :: nz, elem, nzmin, nzmax !for KE diagnostic !___________________________________________________________________________ @@ -3368,17 +3369,16 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) #include "associate_part_ass.h" #include "associate_mesh_ass.h" eta_n => dynamics%eta_n(:) - - !___________________________________________________________________________ - t0=MPI_Wtime() !PS water_flux = 0.0_WP !PS heat_flux = 0.0_WP !PS stress_surf= 0.0_WP !PS stress_node_surf= 0.0_WP - + !___________________________________________________________________________ + t0=MPI_Wtime() #if defined (FESOM_PROFILING) - call fesom_profiler_start("oce_mix_pres") + call fesom_profiler_start("oce_pressure_density") #endif + !___________________________________________________________________________ ! calculate equation of state, density, pressure and mixed layer depths if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call pressure_bv'//achar(27)//'[0m' @@ -3413,6 +3413,13 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) !___________________________________________________________________________ call status_check(partit) + + t1 = MPI_Wtime() +#if defined (FESOM_PROFILING) + call fesom_profiler_end("oce_pressure_density") + call fesom_profiler_start("oce_mixing_scheme") +#endif + !___________________________________________________________________________ ! >>>>>> <<<<<< ! >>>>>> calculate vertical mixing coefficients for tracer (Kv) <<<<<< @@ -3432,15 +3439,18 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! to be called prior to tke ! for debugging #if defined (__cvmix) - if (mod(mix_scheme_nmb,10)==6) then + if (mod(mix_scheme_nmb,10)==6) then if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call calc_cvmix_idemix'//achar(27)//'[0m' call calc_cvmix_idemix(partit, mesh) + elseif (mod(mix_scheme_nmb,10)==7) then + if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call calc_cvmix_idemix2'//achar(27)//'[0m' + call calc_cvmix_idemix2(n, partit, mesh) end if #endif !___MAIN MIXING SCHEMES_____________________________________________________ ! use FESOM2.0 tuned k-profile parameterization for vertical mixing - if (mix_scheme_nmb==1 .or. mix_scheme_nmb==17) then + if (mix_scheme_nmb==1 .or. mix_scheme_nmb==18 ) then if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call oce_mixing_KPP'//achar(27)//'[0m' call oce_mixing_KPP(Av, Kv_double, dynamics, tracers, partit, mesh) !$OMP PARALLEL DO @@ -3453,13 +3463,13 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! use FESOM2.0 tuned pacanowski & philander parameterization for vertical ! mixing - else if(mix_scheme_nmb==2 .or. mix_scheme_nmb==27) then + else if(mix_scheme_nmb==2 .or. mix_scheme_nmb==28) then if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call oce_mixing_PP'//achar(27)//'[0m' call oce_mixing_PP(dynamics, partit, mesh) call mo_convect(ice, partit, mesh) #if defined (__cvmix) ! use CVMIX KPP (Large at al. 1994) - else if(mix_scheme_nmb==3 .or. mix_scheme_nmb==37) then + else if(mix_scheme_nmb==3 .or. mix_scheme_nmb==38) then if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call calc_cvmix_kpp'//achar(27)//'[0m' call calc_cvmix_kpp(ice, dynamics, tracers, partit, mesh) call mo_convect(ice, partit, mesh) @@ -3467,7 +3477,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! use CVMIX PP (Pacanowski and Philander 1981) parameterisation for mixing ! based on Richardson number Ri = N^2/(du/dz)^2, using Brunt Väisälä frequency ! N^2 and vertical horizontal velocity shear dui/dz - else if(mix_scheme_nmb==4 .or. mix_scheme_nmb==47) then + else if(mix_scheme_nmb==4 .or. mix_scheme_nmb==48) then if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call calc_cvmix_pp'//achar(27)//'[0m' call calc_cvmix_pp(dynamics, partit, mesh) call mo_convect(ice, partit, mesh) @@ -3476,7 +3486,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! vertical mixing with or without the IDEMIX (dissipation of energy by ! internal gravity waves) extension from Olbers and Eden, 2013, "A global ! Model for the diapycnal diffusivity induced by internal gravity waves" - else if(mix_scheme_nmb==5 .or. mix_scheme_nmb==56) then + else if(mix_scheme_nmb==5 .or. mix_scheme_nmb==56 .or. mix_scheme_nmb==57) then if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call calc_cvmix_tke'//achar(27)//'[0m' call calc_cvmix_tke(dynamics, partit, mesh) call mo_convect(ice, partit, mesh) @@ -3493,17 +3503,18 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! the already computed viscosities/diffusivities of KPP, PP, cvmix_KPP or ! cvmix_PP --> use standalone for debugging --> needs to be called after main ! mixing schemes - if ( mod(mix_scheme_nmb,10)==7) then + if ( mod(mix_scheme_nmb,10)==8) then if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call calc_cvmix_tidal'//achar(27)//'[0m' call calc_cvmix_tidal(partit, mesh) end if #endif - t1=MPI_Wtime() + + t2=MPI_Wtime() #if defined (FESOM_PROFILING) - call fesom_profiler_end("oce_mix_pres") + call fesom_profiler_end("oce_mixing_scheme") call fesom_profiler_start("oce_dyn_momentum") -#endif +#endif !___________________________________________________________________________ ! add contribution from momentum advection, coriolis and pressure gradient | @@ -3631,7 +3642,8 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) end do end if end if - t2=MPI_Wtime() + + t3=MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_end("oce_dyn_momentum") call fesom_profiler_start("oce_ssh_solve") @@ -3659,10 +3671,10 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call relax_zonal_vel'//achar(27)//'[0m' call relax_zonal_vel(dynamics, partit, mesh) end if - t3=MPI_Wtime() + t4=MPI_Wtime() #if defined (FESOM_PROFILING) - call fesom_profiler_end("oce_ssh_solve") - call fesom_profiler_start("oce_vel_update") + call fesom_profiler_end("oce_ssh_solve") + call fesom_profiler_start("oce_vel_update") #endif ! estimate new horizontal velocity u^(n+1) @@ -3672,10 +3684,10 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) call update_vel(dynamics, partit, mesh) ! --> eta_(n) --> eta_(n+1) = eta_(n) + deta = eta_(n) + (eta_(n+1) + eta_(n)) - t4=MPI_Wtime() + t5=MPI_Wtime() #if defined (FESOM_PROFILING) - call fesom_profiler_end("oce_vel_update") - call fesom_profiler_start("oce_hbar_calc") + call fesom_profiler_end("oce_vel_update") + call fesom_profiler_start("oce_hbar_calc") #endif ! Update to hbar(n+3/2) and compute dhe to be used on the next step @@ -3700,10 +3712,10 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) !$OMP END PARALLEL DO ! --> eta_(n) ! call zero_dynamics !DS, zeros several dynamical variables; to be used for testing new implementations! - t5=MPI_Wtime() + t6=MPI_Wtime() #if defined (FESOM_PROFILING) - call fesom_profiler_end("oce_hbar_calc") - call fesom_profiler_start("oce_gm_redi") + call fesom_profiler_end("oce_hbar_calc") + call fesom_profiler_start("oce_gm_redi") #endif !___________________________________________________________________________ @@ -3716,20 +3728,21 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! Do barotropic step, get eta_{n+1} and BT transport call compute_BT_step_SE_ale(dynamics, partit, mesh) - t3=MPI_Wtime() + t4=MPI_Wtime() #if defined (FESOM_PROFILING) - call fesom_profiler_end("oce_ssh_solve") - call fesom_profiler_start("oce_vel_update") -#endif + call fesom_profiler_end("oce_ssh_solve") + call fesom_profiler_start("oce_vel_update") +#endif + ! Trim U to be consistent with BT transport call update_trim_vel_ale_vtransp(1, dynamics, partit, mesh) - t4=MPI_Wtime() - t5=t4 + t5=MPI_Wtime() + t6=t5 #if defined (FESOM_PROFILING) - call fesom_profiler_end("oce_vel_update") - call fesom_profiler_start("oce_hbar_calc") - call fesom_profiler_end("oce_hbar_calc") - call fesom_profiler_start("oce_gm_redi") + call fesom_profiler_end("oce_vel_update") + call fesom_profiler_start("oce_hbar_calc") + call fesom_profiler_end("oce_hbar_calc") + call fesom_profiler_start("oce_gm_redi") #endif end if ! --> if (.not. dynamics%use_ssh_se_subcycl) then @@ -3746,7 +3759,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) call fer_solve_Gamma(partit, mesh) call fer_gamma2vel(dynamics, partit, mesh) end if - t6=MPI_Wtime() + t7=MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_end("oce_gm_redi") call fesom_profiler_start("oce_vert_vel") @@ -3776,7 +3789,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) end if call compute_vert_vel_transpv(dynamics, partit, mesh) end if - t7=MPI_Wtime() + t8=MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_end("oce_vert_vel") call fesom_profiler_start("oce_tracer_solve") @@ -3794,7 +3807,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! solve tracer equation if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call solve_tracers_ale'//achar(27)//'[0m' call solve_tracers_ale(ice, dynamics, tracers, partit, mesh) - t8=MPI_Wtime() + t9=MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_end("oce_tracer_solve") call fesom_profiler_start("oce_thickness_update") @@ -3804,7 +3817,7 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! Update hnode=hnode_new, helem if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call update_thickness_ale'//achar(27)//'[0m' call update_thickness_ale(partit, mesh) - t9=MPI_Wtime() + t10=MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_end("oce_thickness_update") call fesom_profiler_start("oce_blowup_check") @@ -3832,37 +3845,40 @@ subroutine oce_timestep_ale(n, ice, dynamics, tracers, partit, mesh) ! togeather around 2.5% of model runtime if (flag_debug .and. mype==0) print *, achar(27)//'[36m'//' --> call check_blowup'//achar(27)//'[0m' call check_blowup(n, ice, dynamics, tracers, partit, mesh) - t10=MPI_Wtime() + t11=MPI_Wtime() #if defined (FESOM_PROFILING) call fesom_profiler_end("oce_blowup_check") #endif !___________________________________________________________________________ ! write out execution times for ocean step parts - rtime_oce = rtime_oce + (t10-t0)-(t10-t9) - rtime_oce_mixpres = rtime_oce_mixpres + (t1-t0) - rtime_oce_dyn = rtime_oce_dyn + (t2-t1)+(t7-t6)+(t4-t3) - rtime_oce_dynssh = rtime_oce_dynssh + (t3-t2)+(t5-t4) - rtime_oce_solvessh = rtime_oce_solvessh + (t3-t30) - rtime_oce_GMRedi = rtime_oce_GMRedi + (t6-t5) - rtime_oce_solvetra = rtime_oce_solvetra + (t8-t7) - rtime_tot = rtime_tot + (t10-t0)-(t10-t9) + rtime_oce = rtime_oce + (t11-t0)-(t11-t10) + rtime_oce_presdens = rtime_oce_presdens + (t1-t0) + rtime_oce_mixing = rtime_oce_mixing + (t2-t1) + rtime_oce_dyn = rtime_oce_dyn + (t3-t2)+(t8-t7)+(t5-t4) + rtime_oce_dynssh = rtime_oce_dynssh + (t4-t3)+(t6-t5) + rtime_oce_solvessh = rtime_oce_solvessh + (t4-t30) + rtime_oce_GMRedi = rtime_oce_GMRedi + (t7-t6) + rtime_oce_solvetra = rtime_oce_solvetra + (t9-t8) + rtime_tot = rtime_tot + (t11-t0)-(t11-t10) if(mod(n,logfile_outfreq)==0 .and. mype==0) then + write(*,*) write(*,*) '___ALE OCEAN STEP EXECUTION TIMES______________________' - write(*,"(A, ES10.3)") ' Oce. Mix,Press.. :', t1-t0 - write(*,"(A, ES10.3)") ' Oce. Dynamics :', t2-t1 - write(*,"(A, ES10.3)") ' Oce. Update Vel. :', t4-t3 - write(*,"(A, ES10.3)") ' Oce. Fer-GM. :', t6-t5 + write(*,"(A, ES10.3, A, F6.2, A)") ' Oce. Press, Dens.:', t1-t0, ' (', 100.0*(t1-t0)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Oce. Mixing :', t2-t1, ' (', 100.0*(t2-t1)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Oce. Dynamics :', t3-t2, ' (', 100.0*(t3-t2)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Oce. Update Vel. :', t5-t4, ' (', 100.0*(t5-t4)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' Oce. Fer-GM. :', t7-t6, ' (', 100.0*(t7-t6)/(t11-t0), '%)' write(*,*) ' _______________________________' - write(*,"(A, ES10.3)") ' ALE-Solve SSH :', t3-t2 - write(*,"(A, ES10.3)") ' ALE-Calc. hbar :', t5-t4 - write(*,"(A, ES10.3)") ' ALE-Update+W :', t7-t6 - write(*,"(A, ES10.3)") ' ALE-Solve Tracer :', t8-t7 - write(*,"(A, ES10.3)") ' ALE-Update hnode :', t9-t8 + write(*,"(A, ES10.3, A, F6.2, A)") ' ALE-Solve SSH :', t4-t3, ' (', 100.0*(t4-t3)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' ALE-Calc. hbar :', t6-t5, ' (', 100.0*(t6-t5)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' ALE-Update+W :', t8-t7, ' (', 100.0*(t8-t7)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' ALE-Solve Tracer :', t9-t8, ' (', 100.0*(t9-t8)/(t11-t0), '%)' + write(*,"(A, ES10.3, A, F6.2, A)") ' ALE-Update hnode :', t10-t9, ' (', 100.0*(t10-t9)/(t11-t0), '%)' write(*,*) ' _______________________________' - write(*,"(A, ES10.3)") ' check for blowup :', t10-t9 + write(*,"(A, ES10.3, A, F6.2, A)") ' check for blowup :', t11-t10, ' (', 100.0*(t11-t10)/(t11-t0), '%)' write(*,*) ' _______________________________' - write(*,"(A, ES10.3)") ' Oce. TOTAL :', t10-t0 + write(*,"(A, ES10.3)") ' Oce. TOTAL :', t11-t0 write(*,*) write(*,*) end if diff --git a/src/oce_muscl_adv.F90 b/src/oce_muscl_adv.F90 index cb3c0638a..052f08828 100755 --- a/src/oce_muscl_adv.F90 +++ b/src/oce_muscl_adv.F90 @@ -1,13 +1,15 @@ module find_up_downwind_triangles_interface interface - subroutine find_up_downwind_triangles(twork, partit, mesh) + subroutine find_up_downwind_triangles(partit, mesh, edge_up_dn_tri, edge_up_dn_grad ) use MOD_MESH USE MOD_PARTIT USE MOD_PARSUP use MOD_TRACER - type(t_mesh), intent(in) , target :: mesh + type(t_mesh), intent(inout) , target :: mesh type(t_partit), intent(inout), target :: partit - type(t_tracer_work), intent(inout), target :: twork +! type(t_tracer_work), intent(inout), target :: twork + integer , intent(inout), allocatable,dimension(:,:) :: edge_up_dn_tri + real(kind=WP), intent(inout), allocatable,dimension(:,:,:), optional :: edge_up_dn_grad end subroutine find_up_downwind_triangles end interface end module find_up_downwind_triangles_interface @@ -53,7 +55,7 @@ subroutine muscl_adv_init(twork, partit, mesh) !___________________________________________________________________________ ! find upwind and downwind triangle for each local edge - call find_up_downwind_triangles(twork, partit, mesh) + call find_up_downwind_triangles(partit, mesh, twork%edge_up_dn_tri, twork%edge_up_dn_grad) !___________________________________________________________________________ nn_size=0 @@ -159,7 +161,7 @@ end SUBROUTINE muscl_adv_init ! ! !_______________________________________________________________________________ -SUBROUTINE find_up_downwind_triangles(twork, partit, mesh) +SUBROUTINE find_up_downwind_triangles(partit, mesh, edge_up_dn_tri, edge_up_dn_grad) USE MOD_MESH USE MOD_PARTIT USE MOD_PARSUP @@ -174,17 +176,19 @@ SUBROUTINE find_up_downwind_triangles(twork, partit, mesh) real(kind=WP), allocatable :: coord_elem(:, :,:), temp(:) integer, allocatable :: temp_i(:), e_nodes(:,:) -type(t_mesh), intent(in) , target :: mesh +type(t_mesh), intent(inout), target :: mesh type(t_partit), intent(inout), target :: partit -type(t_tracer_work), intent(inout), target :: twork +! type(t_tracer_work), intent(inout), target :: twork +integer , intent(inout), allocatable, dimension(:,:) :: edge_up_dn_tri +real(kind=WP), intent(inout), allocatable, dimension(:,:,:), optional :: edge_up_dn_grad #include "associate_part_def.h" #include "associate_mesh_def.h" #include "associate_part_ass.h" #include "associate_mesh_ass.h" -allocate(twork%edge_up_dn_tri(2,myDim_edge2D)) -allocate(twork%edge_up_dn_grad(4,nl-1,myDim_edge2D)) -twork%edge_up_dn_tri=0 +allocate(edge_up_dn_tri(2,myDim_edge2D)) +edge_up_dn_tri=0 + ! ===== ! In order that this procedure works, we need to know nodes and their coordinates ! on the extended set of elements (not only my, but myDim+eDim+eXDim) @@ -275,15 +279,15 @@ SUBROUTINE find_up_downwind_triangles(twork, partit, mesh) ! Since b and c are the sides of triangle, |ab|0.0_WP).and.(ax>0.0_WP).and.(axab)) then - twork%edge_up_dn_tri(1,n)=elem + edge_up_dn_tri(1,n)=elem cycle endif if((ab==ax).or.(ax==0.0_WP)) then - twork%edge_up_dn_tri(1,n)=elem + edge_up_dn_tri(1,n)=elem cycle endif END DO @@ -318,15 +322,15 @@ SUBROUTINE find_up_downwind_triangles(twork, partit, mesh) ! Since b and c are the sides of triangle, |ab|0.0_WP).and.(ax>0.0_WP).and.(axab)) then - twork%edge_up_dn_tri(2,n)=elem + edge_up_dn_tri(2,n)=elem cycle endif if((ab==ax).or.(ax==0.0)) then - twork%edge_up_dn_tri(2,n)=elem + edge_up_dn_tri(2,n)=elem cycle endif END DO @@ -340,14 +344,19 @@ SUBROUTINE find_up_downwind_triangles(twork, partit, mesh) ! Count the number of 'good' edges: !k=0 !DO n=1, myDim_edge2D -! if((twork%edge_up_dn_tri(1,n).ne.0).and.(twork%edge_up_dn_tri(2,n).ne.0)) k=k+1 +! if((edge_up_dn_tri(1,n).ne.0).and.(edge_up_dn_tri(2,n).ne.0)) k=k+1 !END DO + +if (present(edge_up_dn_grad)) then + allocate(edge_up_dn_grad(4,nl-1,myDim_edge2D)) !$OMP PARALLEL DO -DO n=1, myDim_edge2D - twork%edge_up_dn_grad(:, :, n)=0.0_WP -END DO + DO n=1, myDim_edge2D + edge_up_dn_grad(:, :, n)=0.0_WP + END DO !$OMP END PARALLEL DO +end if + deallocate(e_nodes, coord_elem) end SUBROUTINE find_up_downwind_triangles ! diff --git a/src/oce_setup_step.F90 b/src/oce_setup_step.F90 index 48a5c84a1..cd918741c 100755 --- a/src/oce_setup_step.F90 +++ b/src/oce_setup_step.F90 @@ -88,6 +88,7 @@ subroutine ocean_setup(dynamics, tracers, partit, mesh) #if defined (__cvmix) use g_cvmix_tke use g_cvmix_idemix + use g_cvmix_idemix2 use g_cvmix_pp use g_cvmix_kpp use g_cvmix_tidal @@ -143,19 +144,21 @@ subroutine ocean_setup(dynamics, tracers, partit, mesh) ! here translate mix_scheme string into integer --> for later usage only ! integer comparison is required select case (trim(mix_scheme)) - case ('KPP' ) ; mix_scheme_nmb = 1 - case ('PP' ) ; mix_scheme_nmb = 2 + case ('KPP' ) ; mix_scheme_nmb = 1 + case ('PP' ) ; mix_scheme_nmb = 2 #if defined (__cvmix) - case ('cvmix_KPP' ) ; mix_scheme_nmb = 3 - case ('cvmix_PP' ) ; mix_scheme_nmb = 4 - case ('cvmix_TKE' ) ; mix_scheme_nmb = 5 - case ('cvmix_IDEMIX' ) ; mix_scheme_nmb = 6 - case ('cvmix_TIDAL' ) ; mix_scheme_nmb = 7 - case ('KPP+cvmix_TIDAL' ) ; mix_scheme_nmb = 17 - case ('PP+cvmix_TIDAL' ) ; mix_scheme_nmb = 27 - case ('cvmix_KPP+cvmix_TIDAL' ) ; mix_scheme_nmb = 37 - case ('cvmix_PP+cvmix_TIDAL' ) ; mix_scheme_nmb = 47 - case ('cvmix_TKE+cvmix_IDEMIX') ; mix_scheme_nmb = 56 + case ('cvmix_KPP' ) ; mix_scheme_nmb = 3 + case ('cvmix_PP' ) ; mix_scheme_nmb = 4 + case ('cvmix_TKE' ) ; mix_scheme_nmb = 5 + case ('cvmix_IDEMIX' ) ; mix_scheme_nmb = 6 + case ('cvmix_IDEMIX2' ) ; mix_scheme_nmb = 7 + case ('cvmix_TIDAL' ) ; mix_scheme_nmb = 8 + case ('KPP+cvmix_TIDAL' ) ; mix_scheme_nmb = 17 + case ('PP+cvmix_TIDAL' ) ; mix_scheme_nmb = 27 + case ('cvmix_KPP+cvmix_TIDAL' ) ; mix_scheme_nmb = 37 + case ('cvmix_PP+cvmix_TIDAL' ) ; mix_scheme_nmb = 48 + case ('cvmix_TKE+cvmix_IDEMIX' ) ; mix_scheme_nmb = 56 + case ('cvmix_TKE+cvmix_IDEMIX2') ; mix_scheme_nmb = 57 #endif case ('TOY' ) ; mix_scheme_nmb = 8 case default @@ -177,12 +180,12 @@ subroutine ocean_setup(dynamics, tracers, partit, mesh) call init_cvmix_kpp(partit, mesh) ! initialise cvmix_PP - elseif (mix_scheme_nmb==4 .or. mix_scheme_nmb==47) then + elseif (mix_scheme_nmb==4 .or. mix_scheme_nmb==48) then if (flag_debug .and. partit%mype==0) print *, achar(27)//'[36m'//' --> call init_cvmix_pp'//achar(27)//'[0m' call init_cvmix_pp(partit, mesh) ! initialise cvmix_TKE - elseif (mix_scheme_nmb==5 .or. mix_scheme_nmb==56) then + elseif (mix_scheme_nmb==5 .or. mix_scheme_nmb==56 .or. mix_scheme_nmb==57) then if (flag_debug .and. partit%mype==0) print *, achar(27)//'[36m'//' --> call init_cvmix_tke'//achar(27)//'[0m' call init_cvmix_tke(partit, mesh) #endif @@ -194,11 +197,17 @@ subroutine ocean_setup(dynamics, tracers, partit, mesh) if (mod(mix_scheme_nmb,10)==6) then if (flag_debug .and. partit%mype==0) print *, achar(27)//'[36m'//' --> call init_cvmix_idemix'//achar(27)//'[0m' call init_cvmix_idemix(partit, mesh) + + ! initialise additional mixing cvmix_IDEMIX2 --> only in combination with + ! cvmix_TKE+cvmix_IDEMIX2 or stand alone for debbuging as cvmix_TKE + elseif (mod(mix_scheme_nmb,10)==7) then + if (flag_debug .and. partit%mype==0) print *, achar(27)//'[36m'//' --> call init_cvmix_idemix2'//achar(27)//'[0m' + call init_cvmix_idemix2(partit, mesh) ! initialise additional mixing cvmix_TIDAL --> only in combination with ! KPP+cvmix_TIDAL, PP+cvmix_TIDAL, cvmix_KPP+cvmix_TIDAL, cvmix_PP+cvmix_TIDAL ! or stand alone for debbuging as cvmix_TIDAL - elseif (mod(mix_scheme_nmb,10)==7) then + elseif (mod(mix_scheme_nmb,10)==8) then if (flag_debug .and. partit%mype==0) print *, achar(27)//'[36m'//' --> call init_cvmix_tidal'//achar(27)//'[0m' call init_cvmix_tidal(partit, mesh) end if diff --git a/src/oce_tracer_mod.F90 b/src/oce_tracer_mod.F90 index 2fb963fe0..bb04dda44 100755 --- a/src/oce_tracer_mod.F90 +++ b/src/oce_tracer_mod.F90 @@ -124,11 +124,11 @@ SUBROUTINE init_tracers_AB(tr_num, tracers, partit, mesh) if (flag_debug .and. partit%mype==0) print *, achar(27)//'[38m'//' --> call tracer_gradient_elements'//achar(27)//'[0m' !PS call tracer_gradient_elements(tracers%data(tr_num)%valuesAB, partit, mesh) - call tracer_gradient_elements(tracers%data(tr_num)%values, partit, mesh) + call tracer_gradient_elements(tracers%data(tr_num)%values, tr_xy, partit, mesh) call exchange_elem_begin(tr_xy, partit) if (flag_debug .and. partit%mype==0) print *, achar(27)//'[38m'//' --> call tracer_gradient_z'//achar(27)//'[0m' - call tracer_gradient_z(tracers%data(tr_num)%values, partit, mesh) !WHY NOT AB HERE? DSIDOREN! + call tracer_gradient_z(tracers%data(tr_num)%values, tr_z, partit, mesh) !WHY NOT AB HERE? DSIDOREN! call exchange_elem_end(partit) ! tr_xy used in fill_up_dn_grad !$OMP BARRIER @@ -139,14 +139,14 @@ SUBROUTINE init_tracers_AB(tr_num, tracers, partit, mesh) call exchange_nod_end(partit) ! tr_z halos should have arrived by now. if (flag_debug .and. partit%mype==0) print *, achar(27)//'[38m'//' --> call tracer_gradient_elements'//achar(27)//'[0m' - call tracer_gradient_elements(tracers%data(tr_num)%values, partit, mesh) !redefine tr_arr to the current timestep + call tracer_gradient_elements(tracers%data(tr_num)%values, tr_xy, partit, mesh) !redefine tr_arr to the current timestep call exchange_elem(tr_xy, partit) END SUBROUTINE init_tracers_AB ! ! !======================================================================= -SUBROUTINE tracer_gradient_elements(ttf, partit, mesh) +SUBROUTINE tracer_gradient_elements(ttf, ttf_grad, partit, mesh, do_overz_in) !computes elemental gradient of tracer USE MOD_MESH USE MOD_PARTIT @@ -156,42 +156,76 @@ SUBROUTINE tracer_gradient_elements(ttf, partit, mesh) USE o_ARRAYS IMPLICIT NONE - type(t_mesh), intent(in), target :: mesh - type(t_partit), intent(inout), target :: partit - real(kind=WP) :: ttf(mesh%nl-1, partit%myDim_nod2D+partit%eDim_nod2D) - integer :: elem, elnodes(3) - integer :: nz, nzmin, nzmax + real(kind=WP) , intent(in) , dimension(:,:) :: ttf !(mesh%nl-1, partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP) , intent(inout), dimension(:,:,:) :: ttf_grad + type(t_mesh) , intent(in) , target :: mesh + type(t_partit), intent(inout), target :: partit + logical , intent(in) , optional :: do_overz_in + integer :: elem, elnodes(3) + integer :: nz, nzmin, nzmax + logical :: do_overz #include "associate_part_def.h" #include "associate_mesh_def.h" #include "associate_part_ass.h" #include "associate_mesh_ass.h" + + ! + !___________________________________________________________________________ + do_overz = .True. + if (present(do_overz_in)) do_overz = do_overz_in + ! + !___________________________________________________________________________ + if (do_overz) then #ifndef ENABLE_OPENACC !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(elem, elnodes, nz, nzmin, nzmax) #else !ACC PARALLEL LOOP DEFAULT(PRESENT) PRIVATE(elnodes) #endif - DO elem=1, myDim_elem2D - elnodes=elem2D_nodes(:,elem) - nzmin = ulevels(elem) - nzmax = nlevels(elem) - !!PS DO nz=1, nlevels(elem)-1 - DO nz=nzmin, nzmax-1 - tr_xy(1,nz, elem)=sum(gradient_sca(1:3,elem)*ttf(nz,elnodes)) - tr_xy(2,nz, elem)=sum(gradient_sca(4:6,elem)*ttf(nz,elnodes)) - END DO - END DO + do elem=1, myDim_elem2D + elnodes=elem2D_nodes(:,elem) + nzmin = ulevels(elem) + nzmax = nlevels(elem) + do nz=nzmin, nzmax-1 + ttf_grad(1,nz, elem)=sum(gradient_sca(1:3,elem)*ttf(nz,elnodes)) + ttf_grad(2,nz, elem)=sum(gradient_sca(4:6,elem)*ttf(nz,elnodes)) + end do + end do #ifndef ENABLE_OPENACC !$OMP END PARALLEL DO #else !ACC END PARALLEL LOOP #endif + + ! + !___________________________________________________________________________ + else ! (do_overz==.False.) + nzmin = 1 + nzmax = size(ttf, 1) +#ifndef ENABLE_OPENACC +!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(elem, elnodes, nz) +#else +!ACC PARALLEL LOOP DEFAULT(PRESENT) PRIVATE(elnodes) +#endif + do elem=1, myDim_elem2D + elnodes=elem2D_nodes(:,elem) + do nz=nzmin+1, nzmax-1 + ttf_grad(1,nz, elem)=sum(gradient_sca(1:3,elem)*ttf(nz,elnodes)) + ttf_grad(2,nz, elem)=sum(gradient_sca(4:6,elem)*ttf(nz,elnodes)) + end do + end do +#ifndef ENABLE_OPENACC +!$OMP END PARALLEL DO +#else +!ACC END PARALLEL LOOP +#endif + end if END SUBROUTINE tracer_gradient_elements ! ! !======================================================================================== -SUBROUTINE tracer_gradient_z(ttf, partit, mesh) +SUBROUTINE tracer_gradient_z(ttf, ttf_grad, partit, mesh) !computes vertical gradient of tracer USE MOD_MESH USE MOD_PARTIT @@ -201,9 +235,12 @@ SUBROUTINE tracer_gradient_z(ttf, partit, mesh) USE o_ARRAYS USE g_CONFIG IMPLICIT NONE - type(t_mesh), intent(in), target :: mesh - type(t_partit), intent(inout), target :: partit - real(kind=WP) :: ttf(mesh%nl-1,partit%myDim_nod2D+partit%eDim_nod2D) + + real(kind=WP), intent(in ), dimension(:,:) :: ttf !(mesh%nl-1,partit%myDim_nod2D+partit%eDim_nod2D) + real(kind=WP), intent(inout), dimension(:,:) :: ttf_grad !(mesh%nl-1,partit%myDim_nod2D+partit%eDim_nod2D) + type(t_partit), intent(inout), target :: partit + type(t_mesh), intent(in), target :: mesh + real(kind=WP) :: dz integer :: n, nz, nzmin, nzmax @@ -221,10 +258,10 @@ SUBROUTINE tracer_gradient_z(ttf, partit, mesh) nzmin=ulevels_nod2D(n) DO nz=nzmin+1, nzmax-1 dz=0.5_WP*(hnode(nz-1,n)+hnode(nz,n)) - tr_z(nz, n)=(ttf(nz-1,n)-ttf(nz,n))/dz + ttf_grad(nz, n)=(ttf(nz-1,n)-ttf(nz,n))/dz END DO - tr_z(nzmin, n)=0.0_WP - tr_z(nzmax, n)=0.0_WP + ttf_grad(nzmin, n)=0.0_WP + ttf_grad(nzmax, n)=0.0_WP END DO #ifndef ENABLE_OPENACC !$OMP END PARALLEL DO diff --git a/src/write_step_info.F90 b/src/write_step_info.F90 index 0ad26ee50..3aee46c49 100644 --- a/src/write_step_info.F90 +++ b/src/write_step_info.F90 @@ -175,9 +175,9 @@ subroutine write_step_info(istep, outfreq, ice, dynamics, tracers, partit, mesh) loc=omp_min_max_sum1(hbar-hbar_old, 1, myDim_nod2D, 'min', partit) end if call MPI_AllREDUCE(loc , min_deta , 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_FESOM, MPIerr) - loc=omp_min_max_sum1(hnode(1,:), 1, myDim_nod2D, 'min', partit) + loc=omp_min_max_sum1(hnode(1,1:myDim_nod2d), 1, myDim_nod2D, 'min', partit) call MPI_AllREDUCE(loc , min_hnode , 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_FESOM, MPIerr) - loc=omp_min_max_sum1(hnode(2,:), 1, myDim_nod2D, 'min', partit) + loc=omp_min_max_sum1(hnode(2,1:myDim_nod2d), 1, myDim_nod2D, 'min', partit) call MPI_AllREDUCE(loc , min_hnode2 , 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_FESOM, MPIerr) !_______________________________________________________________________ @@ -248,28 +248,28 @@ subroutine write_step_info(istep, outfreq, ice, dynamics, tracers, partit, mesh) write(*,*) ' int(dhbar)-int(wflux)*dt =', int_dhbar-int_wflux*dt*(-1.0) write(*,*) write(*,*) ' ___global min/max/mean --> mstep=',mstep,'____________' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' eta= ', min_eta ,' | ',max_eta ,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' deta= ', min_deta ,' | ',max_deta ,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' hbar= ', min_hbar ,' | ',max_hbar ,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, ES10.3)") ' wflux= ', min_wflux,' | ',max_wflux,' | ',int_wflux - write(*,"(A, ES10.3, A, ES10.3, A, ES10.3)") ' hflux= ', min_hflux,' | ',max_hflux,' | ',int_hflux - write(*,"(A, ES10.3, A, ES10.3, A, ES10.3)") ' temp= ', min_temp ,' | ',max_temp ,' | ',int_temp - write(*,"(A, ES10.3, A, ES10.3, A, ES10.3)") ' salt= ', min_salt ,' | ',max_salt ,' | ',int_salt - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' wvel(1,:)= ', min_wvel ,' | ',max_wvel ,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' wvel(2,:)= ', min_wvel2,' | ',max_wvel2,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' uvel(1,:)= ', min_uvel ,' | ',max_uvel ,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' uvel(2,:)= ', min_uvel2,' | ',max_uvel2,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' vvel(1,:)= ', min_vvel ,' | ',max_vvel ,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' vvel(2,:)= ', min_vvel2,' | ',max_vvel2,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' hnode(1,:)= ', min_hnode,' | ',max_hnode,' | ','N.A.' - write(*,"(A, ES10.3, A, ES10.3, A, A )") ' hnode(2,:)= ', min_hnode2,' | ',max_hnode2,' | ','N.A.' - write(*,"(A, A , A, ES10.3, A, A )") ' cfl_z= ',' N.A. ',' | ',max_cfl_z ,' | ','N.A.' - write(*,"(A, A , A, ES10.3, A, A )") ' pgf_x= ',' N.A. ',' | ',max_pgfx ,' | ','N.A.' - write(*,"(A, A , A, ES10.3, A, A )") ' pgf_y= ',' N.A. ',' | ',max_pgfy ,' | ','N.A.' - write(*,"(A, A , A, ES10.3, A, A )") ' Av= ',' N.A. ',' | ',max_av ,' | ','N.A.' - write(*,"(A, A , A, ES10.3, A, A )") ' Kv= ',' N.A. ',' | ',max_kv ,' | ','N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' eta= ', min_eta , ' | ', max_eta , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' deta= ', min_deta , ' | ', max_deta , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' hbar= ', min_hbar , ' | ', max_hbar , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, ES10.3)") ' wflux= ', min_wflux , ' | ', max_wflux , ' | ', int_wflux + write(*,"(A15, ES10.3, A3, ES10.3, A3, ES10.3)") ' hflux= ', min_hflux , ' | ', max_hflux , ' | ', int_hflux + write(*,"(A15, ES10.3, A3, ES10.3, A3, ES10.3)") ' temp= ', min_temp , ' | ', max_temp , ' | ', int_temp + write(*,"(A15, ES10.3, A3, ES10.3, A3, ES10.3)") ' salt= ', min_salt , ' | ', max_salt , ' | ', int_salt + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' wvel(1,:)= ', min_wvel , ' | ', max_wvel , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' wvel(2,:)= ', min_wvel2 , ' | ', max_wvel2 , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' uvel(1,:)= ', min_uvel , ' | ', max_uvel , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' uvel(2,:)= ', min_uvel2 , ' | ', max_uvel2 , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' vvel(1,:)= ', min_vvel , ' | ', max_vvel , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") ' vvel(2,:)= ', min_vvel2 , ' | ', max_vvel2 , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") 'hnode(1,:)= ', min_hnode , ' | ', max_hnode , ' | ', 'N.A.' + write(*,"(A15, ES10.3, A3, ES10.3, A3, A10 )") 'hnode(2,:)= ', min_hnode2, ' | ', max_hnode2, ' | ', 'N.A.' + write(*,"(A15, A10 , A3, ES10.3, A3, A10 )") ' cfl_z= ', ' N.A.' , ' | ', max_cfl_z , ' | ', 'N.A.' + write(*,"(A15, A10 , A3, ES10.3, A3, A10 )") ' pgf_x= ', ' N.A.' , ' | ', max_pgfx , ' | ', 'N.A.' + write(*,"(A15, A10 , A3, ES10.3, A3, A10 )") ' pgf_y= ', ' N.A.' , ' | ', max_pgfy , ' | ', 'N.A.' + write(*,"(A15, A10 , A3, ES10.3, A3, A10 )") ' Av= ', ' N.A.' , ' | ', max_av , ' | ', 'N.A.' + write(*,"(A15, A10 , A3, ES10.3, A3, A10 )") ' Kv= ', ' N.A.' , ' | ', max_kv , ' | ', 'N.A.' if (use_ice) then - write(*,"(A, A , A, ES10.3, A, A)") ' m_ice= ',' N.A. ',' | ',max_m_ice ,' | ','N.A.' + write(*,"(A15, A10 , A3, ES10.3, A3, A10)") ' m_ice= ', ' N.A.' , ' | ', max_m_ice , ' | ', 'N.A.' end if end if endif ! --> if (mod(istep,logfile_outfreq)==0) then