diff --git a/cime_config/cam_autogen.py b/cime_config/cam_autogen.py index 997e793ef..eaecc6d1a 100644 --- a/cime_config/cam_autogen.py +++ b/cime_config/cam_autogen.py @@ -292,8 +292,9 @@ def _find_metadata_files(source_dirs, scheme_finder): bad_xml_sources.append(xml_file) # end if for scheme in schemes: - meta_files[scheme] = (path, source_file, - xml_file) + if scheme not in meta_files: + meta_files[scheme] = (path, source_file, + xml_file) # End for else: # Add meta file to list of files diff --git a/cime_config/namelist_definition_cam.xml b/cime_config/namelist_definition_cam.xml index c07fe112d..0f1f365ce 100644 --- a/cime_config/namelist_definition_cam.xml +++ b/cime_config/namelist_definition_cam.xml @@ -65,6 +65,8 @@ ${DIN_LOC_ROOT}/atm/waccm/ic/wa3_ne5np4_1950_spinup.cam2.i.1960-01-01-00000_c150810.nc ${DIN_LOC_ROOT}/atm/waccm/ic/waccm5_1850_ne30np4_L70_0001-01-11-00000_c151217.nc ${DIN_LOC_ROOT}/atm/waccm/ic/fw2000_ne30np4_L70_c181221.nc + ${DIN_LOC_ROOT}/atm/cam/inic/se/FHISTC_LTso_ne16pg3_ne16pg3_mg17.i.c260220.nc + ${DIN_LOC_ROOT}/atm/cam/inic/se/FHISTC_MTso_ne16pg3_ne16pg3_mg17.i.c260220.nc ${DIN_LOC_ROOT}/atm/cam/inic/mpas/mpasa120_L26_notopo_coords_c251105.nc @@ -116,7 +118,28 @@ UNSET_PATH - + + real + initial_conditions + cam_initfiles_nl + + Specify whether and how to perform + dry surface pressure scaling. If less than or equal to 0.0, + do not perform scaling. If greater than 0.0, perform scaling to scale_dry_air_mass + value (in Pa) as the average dry surface pressure target. + Default: 0.0 + + + 0.0D0 + + 98288.0D0 + 98288.0D0 + 98288.0D0 + 98288.0D0 + + 101080.0D0 + + diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 4681270a8..4972854e2 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -243,6 +243,7 @@ + @@ -253,4 +254,27 @@ + + + + + + + + + + + + + + + + + + + + + + + diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq_analy_ic_cam4/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq_analy_ic_cam4/user_nl_cam index 6df48b413..21528a89c 100644 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq_analy_ic_cam4/user_nl_cam +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq_analy_ic_cam4/user_nl_cam @@ -1,10 +1,16 @@ -hist_add_inst_fields;h1: T, Q, U, V, PS + +! set analytic ICs +analytic_ic_type=held_suarez_1994 + +! setup history output hist_output_frequency;h1: 1*nsteps hist_write_nstep0;h1: .true. -analytic_ic_type=held_suarez_1994 hist_precision;h1: REAL64 hist_max_frames;h1: 1 +! general atmospheric state variables +hist_add_inst_fields;h1: T, Q, U, V, PS + ! history fields for CAM4 Hack shallow convection hist_add_inst_fields;h1:CMFDT,CMFDQ,CMFDLIQ,CMFDICE,CMFDQR,DQP,ICWMRSH,CMFSL,CMFLQ,FREQSH,EVAPTCM,FZSNTCM,EVSNTCM,HKNTPRPD,HKNTSNPD,HKFLXPRC,HKFLXSNW,HKEIHEAT,EVAPQCM,PRECSH,CMFMCSH diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq_se_cam4/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq_se_cam4/shell_commands new file mode 100644 index 000000000..bff4ca286 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq_se_cam4/shell_commands @@ -0,0 +1 @@ +./xmlchange CAM_LINKED_LIBS=" " diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq_se_cam4/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq_se_cam4/user_nl_cam new file mode 100644 index 000000000..6c2d8de62 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq_se_cam4/user_nl_cam @@ -0,0 +1,32 @@ + +! setup history output +hist_output_frequency;h1: 1*nsteps +hist_write_nstep0;h1: .true. +hist_precision;h1: REAL64 +hist_max_frames;h1: 1 + +! general atmospheric state variables (to match 'history_amwg' from CAM) +hist_add_inst_fields;h1: T, U, V, ZM, OMEGA, PS, PHIS, PMID + +! constituent diagnostics +hist_add_inst_fields;h1: Q, CLDLIQ, CLDICE + +! SE dycore variables (to test 'GLL_hist' grid outputs) +hist_add_inst_fields;h1: FU, FV, FT + +! history fields for CAM4 gravity waves (to match 'history_amwg' from CAM): +hist_add_inst_fields;h1: TAUGWX, TAUGWY + +! history fields for CAM4 RK microphysics (to match 'history_amwg' from CAM): +hist_add_inst_fields;h1: IWC, ICIMR, ICWMR, FICE + +! cloud fraction history fields (to match 'history_amwg' from CAM): +hist_add_inst_fields;h1: CONCLD + +! history fields for CAM4 boundary layer scheme (to match 'history_amwg' from CAM): +hist_add_inst_fields;h1: DTV, PBLH + +! history fields for RRTMGP radiation scheme (to match 'history_amwg' from CAM):! shortwave fields +hist_add_inst_fields;h1: SOLIN, QRS, FSNT, FSNTC, FSNTOA, FSNTOAC, SWCF, FSNS, FSNSC, FSUTOA, FSDS, FSDSC +hist_add_inst_fields;h1: QRL, FLNT, FLNTC, FLUT, FLUTC, LWCF, FLNS, FLNSC, FLDS + diff --git a/src/control/cam_initfiles.F90 b/src/control/cam_initfiles.F90 index 4d7903469..1fbfc788d 100644 --- a/src/control/cam_initfiles.F90 +++ b/src/control/cam_initfiles.F90 @@ -44,6 +44,8 @@ module cam_initfiles ! cam_branch_file: Filepath of primary restart file for a branch run character(len=cl) :: cam_branch_file = ' ' + real(r8), public, protected :: scale_dry_air_mass = 0.0_r8 ! Toggle and target avg air mass + ! rest_pfile: The restart pointer file contains name of most recently ! written primary restart file. ! The contents of this file are updated by cam_write_restart @@ -89,7 +91,7 @@ subroutine cam_initfiles_readnl(nlfile) character(len=*), parameter :: subname = 'cam_initfiles_readnl' namelist /cam_initfiles_nl/ ncdata, bnd_topo, pertlim, cam_branch_file, & - unset_path_str + unset_path_str, scale_dry_air_mass !------------------------------------------------------------------------ if (masterproc) then @@ -122,6 +124,10 @@ subroutine cam_initfiles_readnl(nlfile) if (ierr /= 0) then call endrun(subname//": ERROR: mpi_bcast: cam_branch_file") end if + call mpi_bcast(scale_dry_air_mass, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) then + call endrun(subname//": ERROR: mpi_bcast: scale_dry_air_mass") + endif call mpi_bcast(unset_path_str, len(unset_path_str), mpi_character, & mstrid, mpicom, ierr) if (ierr /= 0) then @@ -198,7 +204,13 @@ subroutine cam_initfiles_readnl(nlfile) write(iulog,*) ' Maximum abs value of scale factor used to ', & 'perturb initial conditions, pertlim= ', pertlim - + if (scale_dry_air_mass > 0) then + write(iulog,*) & + ' Initial condition dry mass will be scaled to: ',scale_dry_air_mass,' Pa' + else + write(iulog,*) & + ' Initial condition dry mass will not be scaled.' + end if end if end subroutine cam_initfiles_readnl diff --git a/src/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index 43323f7ed..deb4522f1 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -25,7 +25,6 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) use cam_abortutils, only: endrun use cam_logfile, only: cam_logfile_readnl, iulog use cam_initfiles, only: cam_initfiles_readnl - use cam_constituents, only: cam_constituents_readnl use cam_ccpp_scheme_namelists, only: cam_read_ccpp_scheme_namelists use runtime_obj, only: cam_set_runtime_opts, unset_str use cam_ccpp_cap, only: ccpp_physics_suite_schemes @@ -81,7 +80,6 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) call cam_logfile_readnl(nlfilename) !The log settings must always be read first call physconst_readnl(nlfilename) call cam_initfiles_readnl(nlfilename) - call cam_constituents_readnl(nlfilename) call history_readnl(nlfilename) call phys_readnl(nlfilename) ! Should set phys_suite_name call vert_coord_readnl(nlfilename) diff --git a/src/data/air_composition.F90 b/src/data/air_composition.F90 index e18da95ea..e78269825 100644 --- a/src/data/air_composition.F90 +++ b/src/data/air_composition.F90 @@ -138,7 +138,8 @@ subroutine air_composition_init() use physics_grid, only: pcols => columns_on_task use vert_coord, only: pver use runtime_obj, only: wv_stdname - use cam_constituents, only: const_name, num_advected + use cam_constituents, only: num_constituents, num_advected + use cam_constituents, only: const_name, const_is_advected use cam_constituents, only: const_set_thermo_active use cam_constituents, only: const_set_water_species @@ -237,7 +238,8 @@ subroutine air_composition_init() icnst = 1 water_species_num = 0 dry_species_num = 0 - do idx = 1, num_advected + do idx = 1, num_constituents + if (.not. const_is_advected(idx)) cycle ! Skip all non-advected constituents cnst_stdname = const_name(idx) has_liq = .false. has_ice = .false. diff --git a/src/data/registry.xml b/src/data/registry.xml index fd9a8aa0c..1e6e30d36 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -424,7 +424,7 @@ standard_name="dycore_calculates_geopotential_using_logarithms" units="flag" type="logical" access="protected"> .false. - .true. + .true. air_temperature diff --git a/src/data/registry_v1_0.xsd b/src/data/registry_v1_0.xsd index a4772445d..c357105fc 100644 --- a/src/data/registry_v1_0.xsd +++ b/src/data/registry_v1_0.xsd @@ -29,7 +29,7 @@ - + diff --git a/src/dynamics/mpas/dyn_comp_impl.F90 b/src/dynamics/mpas/dyn_comp_impl.F90 index a11829832..57b022a6d 100644 --- a/src/dynamics/mpas/dyn_comp_impl.F90 +++ b/src/dynamics/mpas/dyn_comp_impl.F90 @@ -129,8 +129,7 @@ module subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) ! Module(s) from CAM-SIMA. use cam_abortutils, only: check_allocate use cam_constituents, only: const_name, const_is_water_species, & - num_advected, & - readtrace + num_advected use cam_control_mod, only: initial_run use cam_initfiles, only: initial_file_get_id, topo_file_get_id use cam_logfile, only: debugout_debug, debugout_info @@ -219,14 +218,8 @@ module subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) ! the actual availability (checked and handled by MPAS). call dyn_exchange_constituent_states(direction='e', exchange=.true., conversion=.false.) - ! Namelist option that controls if constituents are to be read from a file. - if (readtrace) then - ! Read variables that belong to the "input" stream in MPAS. - call mpas_dynamical_core % read_write_stream(pio_init_file, 'r', 'input') - else - ! Read variables that belong to the "input" stream in MPAS, excluding constituents. - call mpas_dynamical_core % read_write_stream(pio_init_file, 'r', 'input-scalars') - end if + ! Read variables that belong to the "input" stream in MPAS. + call mpas_dynamical_core % read_write_stream(pio_init_file, 'r', 'input') end if else ! Run type is branch or restart run. diff --git a/src/dynamics/se/advect_tend.F90 b/src/dynamics/se/advect_tend.F90 index 62d5b65c9..21c1d6886 100644 --- a/src/dynamics/se/advect_tend.F90 +++ b/src/dynamics/se/advect_tend.F90 @@ -6,7 +6,6 @@ module advect_tend use shr_kind_mod, only : r8 => shr_kind_r8 - save private public :: compute_adv_tends_xyz @@ -22,14 +21,16 @@ module advect_tend ! - second call computes and outputs the tendencies !---------------------------------------------------------------------- subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) -! use cam_history, only: outfld, hist_fld_active - use time_manager, only: get_step_size + + use shr_kind_mod, only: cl=>shr_kind_cl + use cam_history, only: history_out_field + use time_manager, only: get_step_size ! use cam_constituents, only: tottnam,num_advected - use cam_constituents, only: num_advected - use cam_abortutils, only: check_allocate + use cam_constituents, only: num_advected + use cam_abortutils, only: check_allocate ! SE dycore: - use dimensions_mod, only: nc,np,nlev,ntrac + use dimensions_mod, only: nc,np,nlev,ntrac,use_cslam use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct @@ -43,29 +44,31 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) logical :: init real(r8), allocatable, dimension(:,:) :: ftmp + character(len=cl) :: errmsg + character(len=*), parameter :: subname = 'compute_adv_tends_xyz' - if (ntrac>0) then + if (use_cslam) then nx=nc else nx=np - endif + end if - allocate( ftmp(nx*nx,nlev), stat=iret ) + allocate( ftmp(nx*nx,nlev), stat=iret, errmsg=errmsg ) call check_allocate(iret, subname, 'ftmp(nx*nx,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) init = .false. if ( .not. allocated( adv_tendxyz ) ) then init = .true. - allocate( adv_tendxyz(nx,nx,nlev,num_advected,nets:nete), stat=iret ) + allocate( adv_tendxyz(nx,nx,nlev,num_advected,nets:nete), stat=iret, errmsg=errmsg ) call check_allocate(iret, subname, 'adv_tendxyz(nx,nx,nlev,num_advected,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) adv_tendxyz(:,:,:,:,:) = 0._r8 - endif + end if - if (ntrac>0) then + if (use_cslam) then do ie=nets,nete do ic = 1, num_advected adv_tendxyz(:,:,:,ic,ie) = fvm(ie)%c(1:nc,1:nc,:,ic) - adv_tendxyz(:,:,:,ic,ie) @@ -75,12 +78,11 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) do ie=nets,nete do ic = 1, num_advected adv_tendxyz(:,:,:,ic,ie) = elem(ie)%state%Qdp(:,:,:,ic,qn0)/elem(ie)%state%dp3d(:,:,:,n0) - adv_tendxyz(:,:,:,ic,ie) - enddo + end do end do end if -!Remove once history outputs are enabled: -#if 0 +#ifdef cam_thermo_history if ( .not. init ) then dt = get_step_size() idt = 1._r8/dt @@ -92,11 +94,11 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) ftmp(i+(j-1)*nx,:) = adv_tendxyz(i,j,:,ic,ie) end do end do - call outfld(tottnam(ic), ftmp,nx*nx, ie) + call history_out_field(tottnam(ic), ftmp) end do end do deallocate(adv_tendxyz) - endif + end if deallocate(ftmp) #else if (.not. init) then @@ -105,5 +107,174 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) deallocate(ftmp) #endif end subroutine compute_adv_tends_xyz +#ifdef SCAM + !---------------------------------------------------------------------- + ! computes camiop specific tendencies + ! and writes these to the camiop file + ! called twice each time step: + ! - first call sets the initial mixing ratios/state + ! - second call computes and outputs the tendencies + !---------------------------------------------------------------------- + subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) + use cam_abortutils, only: endrun + use cam_history, only: outfld, hist_fld_active + use time_manager, only: get_step_size + use constituents, only: pcnst,cnst_name + use dimensions_mod, only: nc,np,nlev,use_cslam,npsq + use element_mod, only: element_t + use fvm_control_volume_mod, only: fvm_struct + implicit none + + type (element_t), intent(inout) :: elem(:) + type(fvm_struct), intent(inout) :: fvm(:) + integer, intent(in) :: nets,nete,qn0,n0 + real(r8) :: dt + real(r8), allocatable :: q_new(:,:,:) + real(r8), allocatable :: q_adv(:,:,:) + real(r8), allocatable :: t_adv(:,:) + real(r8), allocatable :: out_q(:,:) + real(r8), allocatable :: out_t(:,:) + real(r8), allocatable :: out_u(:,:) + real(r8), allocatable :: out_v(:,:) + real(r8), allocatable :: out_ps(:) + + integer :: i,j,ic,nx,ie,nxsq,p + integer :: ierr + logical :: init + character(len=*), parameter :: sub = 'compute_write_iop_fields:' + !---------------------------------------------------------------------------- + + if (use_cslam) then + nx=nc + else + nx=np + end if + nxsq=nx*nx + + init = .false. + dt = get_step_size() + + if ( .not. allocated( iop_qtendxyz ) ) then + init = .true. + + allocate( iop_qtendxyz(nx,nx,nlev,pcnst,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_qtendxyz' ) + iop_qtendxyz = 0._r8 + allocate( derivedfq(nx,nx,nlev,pcnst,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate derivedfq' ) + derivedfq = 0._r8 + allocate( iop_qtendxyz_init(nx,nx,nlev,pcnst,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_qtendxyz' ) + iop_qtendxyz_init = 0._r8 + allocate( iop_ttendxyz(nx,nx,nlev,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_ttendxyz' ) + iop_ttendxyz = 0._r8 + allocate( iop_ttendxyz_init(nx,nx,nlev,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_ttendxyz_init' ) + iop_ttendxyz_init = 0._r8 + end if + + ! save initial/calc tendencies on second call to this routine. + if (use_cslam) then + do ie=nets,nete + do ic=1,pcnst + iop_qtendxyz(:,:,:,ic,ie) = fvm(ie)%c(1:nc,1:nc,:,ic) - iop_qtendxyz(:,:,:,ic,ie) + end do + end do + else + do ie=nets,nete + do ic=1,pcnst + iop_qtendxyz(:,:,:,ic,ie) = elem(ie)%state%Qdp(:,:,:,ic,qn0)/elem(ie)%state%dp3d(:,:,:,n0) - iop_qtendxyz(:,:,:,ic,ie) + end do + end do + end if + do ie=nets,nete + iop_ttendxyz(:,:,:,ie) = elem(ie)%state%T(:,:,:,n0) - iop_ttendxyz(:,:,:,ie) + end do + if (init) then + do ie=nets,nete + iop_ttendxyz_init(:,:,:,ie) = iop_ttendxyz(:,:,:,ie) + iop_qtendxyz_init(:,:,:,:,ie) = iop_qtendxyz(:,:,:,:,ie) + derivedfq(:,:,:,:,ie)=elem(ie)%derived%FQ(:,:,:,:)/dt + end do + end if + + if ( .not. init ) then + allocate( q_adv(nxsq,nlev,pcnst),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate q_adv' ) + q_adv = 0._r8 + allocate( t_adv(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate t_adv' ) + t_adv = 0._r8 + allocate( q_new(nx,nx,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate q_new' ) + q_new = 0._r8 + allocate( out_q(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_q' ) + out_q = 0._r8 + allocate( out_t(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_t' ) + out_t = 0._r8 + allocate( out_u(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_u' ) + out_u = 0._r8 + allocate( out_v(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_v' ) + out_v = 0._r8 + allocate( out_ps(npsq),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_ps' ) + out_ps = 0._r8 + do ie=nets,nete + do j=1,nx + do i=1,nx + t_adv(i+(j-1)*np,:) = iop_ttendxyz(i,j,:,ie)/dt - elem(ie)%derived%FT(i,j,:) + out_u(i+(j-1)*np,:) = elem(ie)%state%v(i,j,1,:,n0) + out_v(i+(j-1)*np,:) = elem(ie)%state%v(i,j,2,:,n0) + out_ps(i+(j-1)*np) = elem(ie)%state%psdry(i,j) + + ! to retain bfb, replace state q and t with roundoff version calculated using the ordering and tendencies of the + ! scam prognostic equation + elem(ie)%state%T(i,j,:,n0) = iop_ttendxyz_init(i,j,:,ie) + dt*(elem(ie)%derived%FT(i,j,:) + t_adv(i+(j-1)*np,:)) + out_t(i+(j-1)*np,:) = elem(ie)%state%T(i,j,:,n0) + do p=1,pcnst + q_adv(i+(j-1)*nx,:,p) = iop_qtendxyz(i,j,:,p,ie)/dt - derivedfq(i,j,:,p,ie) + q_new(i,j,:) = iop_qtendxyz_init(i,j,:,p,ie) + dt*(derivedfq(i,j,:,p,ie) + q_adv(i+(j-1)*nx,:,p)) + if (use_cslam) then + fvm(ie)%c(i,j,:,p)=q_new(i,j,:) + else + elem(ie)%state%Qdp(i,j,:,p,qn0)=q_new(i,j,:)*elem(ie)%state%dp3d(i,j,:,n0) + end if + end do + out_q(i+(j-1)*nx,:) = elem(ie)%state%Qdp(i,j,:,1,qn0)/elem(ie)%state%dp3d(i,j,:,n0) + end do + end do + call outfld('Ps',out_ps,npsq,ie) + call outfld('t',out_t,npsq,ie) + call outfld('q',out_q,nxsq,ie) + call outfld('u',out_u,npsq,ie) + call outfld('v',out_v,npsq,ie) + call outfld('divT3d',t_adv,npsq,ie) + do p=1,pcnst + call outfld(trim(cnst_name(p))//'_dten',q_adv(:,:,p),nxsq,ie) + end do + end do + + deallocate(iop_ttendxyz) + deallocate(iop_ttendxyz_init) + deallocate(iop_qtendxyz) + deallocate(iop_qtendxyz_init) + deallocate(derivedfq) + deallocate(out_t) + deallocate(out_q) + deallocate(out_u) + deallocate(out_v) + deallocate(out_ps) + deallocate(t_adv) + deallocate(q_adv) + deallocate(q_new) + + end if + end subroutine compute_write_iop_fields +#endif end module advect_tend diff --git a/src/dynamics/se/dp_coupling.F90 b/src/dynamics/se/dp_coupling.F90 index ae351a660..41f031926 100644 --- a/src/dynamics/se/dp_coupling.F90 +++ b/src/dynamics/se/dp_coupling.F90 @@ -4,37 +4,12 @@ module dp_coupling ! dynamics - physics coupling module !------------------------------------------------------------------------------- -use shr_kind_mod, only: r8=>shr_kind_r8 -use ccpp_kinds, only: kind_phys -use cam_constituents, only: const_is_wet, num_advected - -use spmd_dyn, only: local_dp_map -use spmd_utils, only: iam -use dyn_grid, only: TimeLevel, edgebuf -use dyn_comp, only: dyn_export_t, dyn_import_t - -use runtime_obj, only: runtime_options -use physics_types, only: physics_state, physics_tend -use physics_grid, only: pcols => columns_on_task, get_dyn_col_p -use vert_coord, only: pver, pverp - -use dp_mapping, only: nphys_pts - -use perf_mod, only: t_startf, t_stopf, t_barrierf -use cam_abortutils, only: endrun, check_allocate - -!SE dycore: -use parallel_mod, only: par -use thread_mod, only: horz_num_threads, max_num_threads -use hybrid_mod, only: config_thread_region, get_loop_ranges, hybrid_t -use dimensions_mod, only: np, npsq, nelemd, nlev, nc, qsize, ntrac, fv_nphys - -use dof_mod, only: UniquePoints, PutUniquePoints -use element_mod, only: element_t +use shr_kind_mod, only: r8=>shr_kind_r8 +use ccpp_kinds, only: kind_phys implicit none private -save + public :: d_p_coupling, p_d_coupling @@ -52,20 +27,34 @@ subroutine d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) ! Note that all pressures and tracer mixing ratios coming from the dycore are based on ! dry air mass. - use gravity_waves_sources, only: gws_src_fnct - use gravity_waves_sources, only: gws_src_vort + use gravity_waves_sources, only: gws_src_fnct, gws_src_vort use hycoef, only: hyai, ps0 - use test_fvm_mapping, only: test_mapping_overwrite_dyn_state, test_mapping_output_phys_state use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t use cam_ccpp_cap, only: cam_constituents_array - use cam_constituents, only: const_name + use cam_constituents, only: const_name, num_advected + use spmd_dyn, only: local_dp_map + use spmd_utils, only: iam + use dyn_grid, only: TimeLevel + use dyn_comp, only: dyn_export_t, advected_constituent_index + use runtime_obj, only: runtime_options + use physics_types, only: physics_state, physics_tend + use physics_grid, only: pcols => columns_on_task, get_dyn_col_p + use vert_coord, only: pver + use dp_mapping, only: nphys_pts + use perf_mod, only: t_startf, t_stopf + use cam_abortutils, only: endrun, check_allocate + use parallel_mod, only: par + use thread_mod, only: max_num_threads + use shr_kind_mod, only: shr_kind_cl !SE dycore: - use fvm_mapping, only: dyn2phys_vector, dyn2phys_all_vars - use time_mod, only: timelevel_qdp - use control_mod, only: qsplit - - use shr_kind_mod, only: shr_kind_cl + use fvm_mapping, only: dyn2phys_vector, dyn2phys_all_vars + use se_dyn_time_mod, only: timelevel_qdp + use control_mod, only: qsplit + use dimensions_mod, only: np, nelemd, nlev, qsize + use dimensions_mod, only: fv_nphys, use_cslam + use dof_mod, only: UniquePoints + use element_mod, only: element_t ! arguments type(runtime_options), intent(in) :: cam_runtime_opts ! Runtime settings object @@ -120,7 +109,7 @@ subroutine d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) tl_f = TimeLevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_qdp_np0,tl_qdp_np1) - if (fv_nphys > 0) then + if (use_cslam) then nphys = fv_nphys else allocate(qgll(np,np,nlev,num_advected), stat=ierr, errmsg=errmsg) @@ -187,8 +176,7 @@ subroutine d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) ! Calculate vorticity for moving mountain gravity wave parameterization. call gws_src_vort(elem, tl_f, tl_qdp_np0, vort4gw, nphys) - if (fv_nphys > 0) then - call test_mapping_overwrite_dyn_state(elem,dyn_out%fvm) + if (use_cslam) then !****************************************************************** ! physics runs on an FVM grid: map GLL vars to physics grid !****************************************************************** @@ -236,7 +224,7 @@ subroutine d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) end do call t_stopf('UniquePoints') - end if ! if fv_nphys>0 + end if ! if use_cslam else @@ -250,17 +238,17 @@ subroutine d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) frontga(:,:,:) = 0._r8 vort4gw(:,:,:) = 0._r8 - endif ! iam < par%nprocs + end if ! iam < par%nprocs - if (fv_nphys < 1) then + if (.not.use_cslam) then deallocate(qgll) end if ! q_prev is for saving the tracer fields for calculating tendencies if (.not. allocated(q_prev)) then - allocate(q_prev(pcols,pver,num_advected), stat=ierr) + allocate(q_prev(pcols,pver,num_advected), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'q_prev(pcols,pver,num_advected)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) end if q_prev = 0.0_r8 @@ -283,7 +271,7 @@ subroutine d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) do m = 1, num_advected do ilyr = 1, pver - const_data_ptr(icol, ilyr,m) = real(q_tmp(blk_ind(1), ilyr,m, ie), kind_phys) + const_data_ptr(icol, ilyr, advected_constituent_index(m)) = real(q_tmp(blk_ind(1), ilyr, m, ie), kind_phys) end do end do end do @@ -292,9 +280,9 @@ subroutine d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) ! Save the tracer fields input to physics package for calculating tendencies ! The mixing ratios are all dry at this point. - q_prev(1:pcols,1:pver,:) = real(const_data_ptr(1:pcols,1:pver,1:num_advected), r8) - - call test_mapping_output_phys_state(phys_state,dyn_out%fvm) + do m = 1, num_advected + q_prev(1:pcols,1:pver,m) = real(const_data_ptr(1:pcols,1:pver,advected_constituent_index(m)), r8) + end do ! Deallocate the temporary arrays deallocate(ps_tmp) @@ -318,16 +306,32 @@ end subroutine d_p_coupling subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, tl_qdp) ! Convert the physics output state into the dynamics input state. - use test_fvm_mapping, only: test_mapping_overwrite_tendencies - use test_fvm_mapping, only: test_mapping_output_mapped_tendencies + use shr_kind_mod, only: shr_kind_cl use cam_ccpp_cap, only: cam_constituents_array use cam_constituents, only: num_advected - use cam_constituents, only: const_is_water_species + use cam_constituents, only: const_is_wet + use spmd_dyn, only: local_dp_map + use spmd_utils, only: iam + use dyn_grid, only: edgebuf + use dyn_comp, only: dyn_import_t, advected_constituent_index + use runtime_obj, only: runtime_options + use physics_types, only: physics_state, physics_tend + use physics_grid, only: pcols => columns_on_task, get_dyn_col_p + use vert_coord, only: pver + use dp_mapping, only: nphys_pts + use perf_mod, only: t_startf, t_stopf + use cam_abortutils, only: endrun, check_allocate + use parallel_mod, only: par + use thread_mod, only: max_num_threads ! SE dycore: use bndry_mod, only: bndry_exchange use edge_mod, only: edgeVpack, edgeVunpack use fvm_mapping, only: phys2dyn_forcings_fvm + use hybrid_mod, only: config_thread_region, get_loop_ranges, hybrid_t + use dimensions_mod, only: use_cslam, nelemd, nlev, qsize, ntrac, fv_nphys + use dof_mod, only: PutUniquePoints + use element_mod, only: element_t ! arguments type(runtime_options), intent(in) :: cam_runtime_opts ! Runtime settings object @@ -349,7 +353,7 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t real(r8), allocatable :: T_tmp(:,:,:) ! temp array to hold T real(r8), allocatable :: dq_tmp(:,:,:,:) ! temp array to hold q real(r8), allocatable :: uv_tmp(:,:,:,:) ! temp array to hold uv - integer :: m, i, j, k + integer :: m, m_cnst, i, j, k real(kind_phys) :: factor integer :: num_trac @@ -357,6 +361,8 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t integer :: kptr, ii integer :: ierr + character(len=shr_kind_cl) :: errmsg + character(len=*), parameter :: subname='p_d_coupling' !---------------------------------------------------------------------------- @@ -370,21 +376,21 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t nullify(elem) end if - allocate(T_tmp(nphys_pts,pver,nelemd), stat=ierr) + allocate(T_tmp(nphys_pts,pver,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'T_tmp(nphys_pts,pver,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(uv_tmp(nphys_pts,2,pver,nelemd), stat=ierr) + allocate(uv_tmp(nphys_pts,2,pver,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'uv_tmp(nphys_pts,2,pver,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dq_tmp(nphys_pts,pver,num_advected,nelemd), stat=ierr) + allocate(dq_tmp(nphys_pts,pver,num_advected,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dq_tmp(nphys_pts,pver,num_advected,nelemd)', & file=__FILE__, line=__LINE__) - allocate(dp_phys(nphys_pts,pver,nelemd), stat=ierr) + allocate(dp_phys(nphys_pts,pver,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dp_phys(nphys_pts,pver,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) T_tmp = 0.0_r8 uv_tmp = 0.0_r8 @@ -398,18 +404,17 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t !$omp parallel do num_threads(max_num_threads) private (k, i, m) do ilyr = 1, nlev do icol=1, pcols + !Determine wet to dry adjustment factor: factor = phys_state%pdel(icol,ilyr)/phys_state%pdeldry(icol,ilyr) - !This should ideally check if a constituent is a wet - !mixing ratio or not, but until that is working properly - !in the CCPP framework just check for the water species status - !instead, which is all that CAM configurations require: do m=1, num_advected - if (const_is_water_species(m)) then - const_data_ptr(icol,ilyr,m) = factor*const_data_ptr(icol,ilyr,m) + m_cnst = advected_constituent_index(m) + if (const_is_wet(m_cnst)) then + const_data_ptr(icol,ilyr,m_cnst) = factor*const_data_ptr(icol,ilyr,m_cnst) end if end do + end do end do @@ -421,11 +426,6 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t do icol = 1, pcols call get_dyn_col_p(icol, ie, blk_ind) - ! test code -- does nothing unless cpp macro debug_coupling is defined. - call test_mapping_overwrite_tendencies(phys_state, & - phys_tend, pcols, q_prev(1:pcols,:,:), & - dyn_in%fvm) - do ilyr = 1, pver dp_phys(blk_ind(1),ilyr,ie) = real(phys_state%pdeldry(icol,ilyr), r8) T_tmp(blk_ind(1),ilyr,ie) = real(phys_tend%dTdt_total(icol,ilyr), r8) @@ -433,7 +433,7 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t uv_tmp(blk_ind(1),2,ilyr,ie) = real(phys_tend%dvdt_total(icol,ilyr), r8) do m = 1, num_advected dq_tmp(blk_ind(1),ilyr,m,ie) = & - (real(const_data_ptr(icol,ilyr,m), r8) - q_prev(icol,ilyr,m)) + (real(const_data_ptr(icol,ilyr,advected_constituent_index(m)), r8) - q_prev(icol,ilyr,m)) end do end do end do @@ -520,9 +520,15 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FM(:,:,:,:), 2*nlev, kptr, ie) kptr = kptr + 2*nlev call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FT(:,:,:), nlev, kptr, ie) - kptr = kptr + nlev - call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) - end do + if (.not. use_cslam) then + ! + ! if using CSLAM qdp is being overwritten with CSLAM values in the dynamics + ! so no need to do boundary exchange of tracer tendency on GLL grid here + ! + kptr = kptr + nlev + call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) + end if + end do if (iam < par%nprocs) then call bndry_exchange(par, edgebuf, location='p_d_coupling') @@ -533,8 +539,10 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t call edgeVunpack(edgebuf, dyn_in%elem(ie)%derived%FM(:,:,:,:), 2*nlev, kptr, ie) kptr = kptr + 2*nlev call edgeVunpack(edgebuf, dyn_in%elem(ie)%derived%FT(:,:,:), nlev, kptr, ie) - kptr = kptr + nlev - call edgeVunpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) + if (.not. use_cslam) then + kptr = kptr + nlev + call edgeVunpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) + end if if (fv_nphys > 0) then do k = 1, nlev dyn_in%elem(ie)%derived%FM(:,:,1,k) = & @@ -555,11 +563,6 @@ subroutine p_d_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_in, tl_f, t end if end do call t_stopf('p_d_coupling:bndry_exchange') - - if (iam < par%nprocs .and. fv_nphys > 0) then - call test_mapping_output_mapped_tendencies(dyn_in%fvm(1:nelemd), elem(1:nelemd), & - 1, nelemd, tl_f, tl_qdp) - end if end subroutine p_d_coupling !========================================================================================= @@ -575,12 +578,12 @@ subroutine derived_phys_dry(cam_runtime_opts, phys_state, phys_tend) use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t use cam_ccpp_cap, only: cam_constituents_array use cam_ccpp_cap, only: cam_model_const_properties - use cam_constituents, only: num_advected - use cam_constituents, only: const_is_water_species + use cam_constituents, only: num_advected, num_constituents + use cam_constituents, only: const_is_wet use cam_constituents, only: const_get_index use cam_constituents, only: const_qmin - use runtime_obj, only: wv_stdname - use physics_types, only: lagrangian_vertical + use runtime_obj, only: wv_stdname, runtime_options + use physics_types, only: physics_state, physics_tend, lagrangian_vertical use physconst, only: cpair, gravit, zvir use cam_thermo, only: cam_thermo_dry_air_update, cam_thermo_water_update use air_composition, only: thermodynamic_active_species_num @@ -589,14 +592,18 @@ subroutine derived_phys_dry(cam_runtime_opts, phys_state, phys_tend) use physics_types, only: cpairv, rairv, zvirv, cappav use physics_types, only: cp_or_cv_dycore use physics_types, only: cp_or_cv_dycore_at_start_of_physics_timestep - use physics_grid, only: columns_on_task + use physics_grid, only: pcols => columns_on_task use geopotential_temp, only: geopotential_temp_run use static_energy, only: update_dry_static_energy_run use qneg, only: qneg_run use hycoef, only: hyai, ps0 use shr_vmath_mod, only: shr_vmath_log use shr_kind_mod, only: shr_kind_cx - use dyn_comp, only: ixo, ixo2, ixh, ixh2 + use vert_coord, only: pver, pverp + use cam_abortutils, only: check_allocate + use thread_mod, only: horz_num_threads + use dimensions_mod, only: nlev + use dyn_comp, only: ixo, ixo2, ixh, ixh2, advected_constituent_index use cam_thermo_formula,only: ENERGY_FORMULA_DYCORE_SE ! arguments @@ -762,20 +769,20 @@ subroutine derived_phys_dry(cam_runtime_opts, phys_state, phys_tend) const_data_ptr(i,k,ixh) = const_data_ptr(i,k,ixh) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H - endif + end if if(const_data_ptr(i,k,ixh2) > H2lim) then const_data_ptr(i,k,ixh2) = H2lim - endif + end if end do end do - endif + end if ! Ensure tracers are all greater than or equal to their ! minimum-allowed value: - call qneg_run('D_P_COUPLING', columns_on_task, pver, & - qmin_vals, const_data_ptr, errflg, errmsg) + call qneg_run('D_P_COUPLING', pcols, pver, qmin_vals, & + const_data_ptr, errflg, errmsg) !----------------------------------------------------------------------------- ! Call cam_thermo_update. If cam_runtime_opts%update_thermodynamic_variables() @@ -829,12 +836,9 @@ subroutine derived_phys_dry(cam_runtime_opts, phys_state, phys_tend) do m = 1, num_advected do k = 1, nlev do i = 1, pcols - ! This should ideally check if a constituent is a wet - ! mixing ratio or not, but until that is working properly - ! in the CCPP framework just check for the water species status - ! instead, which is all that CAM physics requires: - if (const_is_water_species(m)) then - const_data_ptr(i,k,m) = factor_array(i,k)*const_data_ptr(i,k,m) + if (const_is_wet(advected_constituent_index(m))) then + const_data_ptr(i,k,advected_constituent_index(m)) = factor_array(i,k)*& + const_data_ptr(i,k,advected_constituent_index(m)) end if end do end do @@ -842,12 +846,11 @@ subroutine derived_phys_dry(cam_runtime_opts, phys_state, phys_tend) ! Call geopotential_temp CCPP scheme: call geopotential_temp_run(pver, lagrangian_vertical, pver, 1, & - pverp, 1, num_advected, phys_state%lnpint, & + pverp, 1, num_constituents, phys_state%lnpint, & phys_state%pint, phys_state%pmid, phys_state%pdel, & phys_state%rpdel, phys_state%t, const_data_ptr(:,:,ix_q), & const_data_ptr, const_prop_ptr, rairv, gravit, zvirv, & - phys_state%zi, phys_state%zm, columns_on_task, errflg, & - errmsg) + phys_state%zi, phys_state%zm, pcols, errflg, errmsg) ! Compute initial dry static energy, include surface geopotential call update_dry_static_energy_run(pver, gravit, phys_state%t, phys_state%zm, & @@ -855,44 +858,4 @@ subroutine derived_phys_dry(cam_runtime_opts, phys_state, phys_tend) errflg, errmsg) end subroutine derived_phys_dry - -!========================================================================================= - -subroutine thermodynamic_consistency(phys_state, const_data_ptr, phys_tend, ncols, pver) - ! - ! Adjust the physics temperature tendency for thermal energy consistency with the - ! dynamics. - ! Note: mixing ratios are assumed to be dry. - ! - use physconst, only: cpair - use air_composition, only: get_cp - - ! SE dycore: - use dimensions_mod, only: lcp_moist - use control_mod, only: phys_dyn_cp - - type(physics_state), intent(in) :: phys_state - real(kind_phys), pointer :: const_data_ptr(:,:,:) - type(physics_tend ), intent(inout) :: phys_tend - integer, intent(in) :: ncols, pver - - real(kind_phys) :: inv_cp(ncols,pver) - !---------------------------------------------------------------------------- - - if (lcp_moist.and.phys_dyn_cp==1) then - ! - ! scale temperature tendency so that thermal energy increment from physics - ! matches SE (not taking into account dme adjust) - ! - ! note that if lcp_moist=.false. then there is thermal energy increment - ! consistency (not taking into account dme adjust) - ! - call get_cp(const_data_ptr(1:ncols,1:pver,1:num_advected),.true.,inv_cp) - - phys_tend%dTdt_total(1:ncols,1:pver) = phys_tend%dTdt_total(1:ncols,1:pver)*cpair*inv_cp - end if -end subroutine thermodynamic_consistency - -!========================================================================================= - end module dp_coupling diff --git a/src/dynamics/se/dp_mapping.F90 b/src/dynamics/se/dp_mapping.F90 index 32de46fc5..1c573848d 100644 --- a/src/dynamics/se/dp_mapping.F90 +++ b/src/dynamics/se/dp_mapping.F90 @@ -1,18 +1,10 @@ ! Separate dynamics and physics grids module dp_mapping - use shr_const_mod, only: pi => shr_const_pi - use cam_abortutils, only: endrun, check_allocate - - !SE dycore: - use dimensions_mod, only: np, fv_nphys - use shr_kind_mod, only: r8=>shr_kind_r8, shr_kind_cl - use coordinate_systems_mod, only: spherical_polar_t - use fvm_control_volume_mod, only: fvm_struct + use shr_kind_mod, only: r8=>shr_kind_r8 implicit none private - save public :: dp_init public :: dp_reorder @@ -49,19 +41,23 @@ module dp_mapping contains subroutine dp_init(elem,fvm) - use spmd_utils, only: masterproc - use cam_logfile, only: iulog + use shr_kind_mod, only: cl=>shr_kind_cl + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use cam_abortutils, only: check_allocate !SE dycore: - use dimensions_mod, only: nelemd, nc, irecons_tracer, npsq - use element_mod, only: element_t + use dimensions_mod, only: nelemd, nc, irecons_tracer, npsq, fv_nphys + use element_mod, only: element_t + use fvm_control_volume_mod, only: fvm_struct ! Dummy variables: type(element_t) , dimension(nelemd), intent(in) :: elem type (fvm_struct), dimension(nelemd), intent(in) :: fvm ! Local variables: - integer :: iret + integer :: iret + character(len=cl) :: errmsg character(len=*), parameter :: subname = 'dp_init' num_weights_phys2fvm = 0 @@ -70,45 +66,51 @@ subroutine dp_init(elem,fvm) num_weights_phys2fvm = (nc+fv_nphys)**2 num_weights_fvm2phys = (nc+fv_nphys)**2 - allocate(weights_all_fvm2phys(num_weights_fvm2phys,irecons_tracer,nelemd), stat=iret) + allocate(weights_all_fvm2phys(num_weights_fvm2phys,irecons_tracer,nelemd), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'weights_all_fvm2phys(num_weights_fvm2phys,irecons_tracer,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(weights_eul_index_all_fvm2phys(num_weights_fvm2phys,2,nelemd), stat=iret) + allocate(weights_eul_index_all_fvm2phys(num_weights_fvm2phys,2,nelemd), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'weights_eul_index_all_fvm2phys(num_weights_fvm2phys,2,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(weights_lgr_index_all_fvm2phys(num_weights_fvm2phys,2,nelemd), stat=iret) + allocate(weights_lgr_index_all_fvm2phys(num_weights_fvm2phys,2,nelemd), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'weights_lgr_index_all_fvm2phys(num_weights_fvm2phys,2,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(weights_all_phys2fvm(num_weights_phys2fvm,irecons_tracer,nelemd), stat=iret) + allocate(weights_all_phys2fvm(num_weights_phys2fvm,irecons_tracer,nelemd), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'weights_all_phys2fvm(num_weights_phys2fvm,irecons_tracer,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(weights_eul_index_all_phys2fvm(num_weights_phys2fvm,2,nelemd), stat=iret) + allocate(weights_eul_index_all_phys2fvm(num_weights_phys2fvm,2,nelemd), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'weights_eul_index_all_phys2fvm(num_weights_phys2fvm,2,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(weights_lgr_index_all_phys2fvm(num_weights_phys2fvm,2,nelemd), stat=iret) + allocate(weights_lgr_index_all_phys2fvm(num_weights_phys2fvm,2,nelemd), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'weights_lgr_index_all_phys2fvm(num_weights_phys2fvm,2,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(jall_fvm2phys(nelemd), stat=iret) + allocate(jall_fvm2phys(nelemd), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'jall_fvm2phys(nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(jall_phys2fvm(nelemd), stat=iret) + allocate(jall_phys2fvm(nelemd), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'jall_phys2fvm(nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) call fvm2phys_init(elem,fvm,nc,fv_nphys,irecons_tracer,& weights_all_fvm2phys,weights_eul_index_all_fvm2phys,weights_lgr_index_all_fvm2phys,& @@ -123,12 +125,14 @@ subroutine dp_init(elem,fvm) end subroutine dp_init subroutine dp_reorder(before, after) + use cam_logfile, only: iulog use spmd_utils, only: masterproc use shr_sys_mod, only: shr_sys_flush + use cam_abortutils, only: endrun !SE dycore: - use dimensions_mod, only: nelem + use dimensions_mod, only: nelem, fv_nphys implicit none real(r8), dimension(fv_nphys*fv_nphys,*), intent(in) :: before @@ -151,9 +155,12 @@ end subroutine dp_reorder !!! subroutine dp_allocate(elem) + + use shr_kind_mod, only: cl=>shr_kind_cl use spmd_utils, only: masterproc, masterprocid, npes use spmd_utils, only: mpicom use mpi, only: mpi_integer + use cam_abortutils, only: check_allocate !SE dycore: use dimensions_mod, only: nelem, nelemd @@ -165,22 +172,23 @@ subroutine dp_allocate(elem) integer :: i,j,ierror integer,dimension(nelemd) :: lgid integer,dimension(:),allocatable :: displs,recvcount + character(len=cl) :: errmsg character(len=*), parameter :: subname = 'dp_allocate' ! begin - allocate(displs(npes), stat=ierror) + allocate(displs(npes), stat=ierror, errmsg=errmsg) call check_allocate(ierror, subname, 'displs(npes)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dp_gid(nelem), stat=ierror) + allocate(dp_gid(nelem), stat=ierror, errmsg=errmsg) call check_allocate(ierror, subname, 'dp_gid(nelem)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(recvcount(npes), stat=ierror) + allocate(recvcount(npes), stat=ierror, errmsg=errmsg) call check_allocate(ierror, subname, 'recvcount(npes)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) call mpi_gather(nelemd, 1, mpi_integer, recvcount, 1, mpi_integer, & masterprocid, mpicom, ierror) @@ -194,9 +202,9 @@ subroutine dp_allocate(elem) call mpi_gatherv(lgid, nelemd, mpi_integer, dp_gid, recvcount, displs, & mpi_integer, masterprocid, mpicom, ierror) if (masterproc) then - allocate(dp_owner(nelem), stat=ierror) + allocate(dp_owner(nelem), stat=ierror, errmsg=errmsg) call check_allocate(ierror, subname, 'dp_owner(nelem)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) dp_owner(:) = -1 do i = 1,npes @@ -210,7 +218,7 @@ subroutine dp_allocate(elem) ! minimize global memory use call mpi_barrier(mpicom,ierror) if (.not.masterproc) then - allocate(dp_owner(nelem), stat=ierror) + allocate(dp_owner(nelem), stat=ierror, errmsg=errmsg) call check_allocate(ierror, subname, 'dp_owner(nelem)', & file=__FILE__, line=__LINE__) end if @@ -236,12 +244,16 @@ subroutine dp_write(elem, fvm, grid_format, filename_in) use spmd_utils, only: masterproc, masterprocid, mpicom, npes use cam_logfile, only: iulog use shr_sys_mod, only: shr_sys_flush + use shr_const_mod, only: pi => shr_const_pi + use shr_kind_mod, only: shr_kind_cl + use cam_abortutils, only: endrun, check_allocate !SE dycore: use dimensions_mod, only: nelem, nelemd use element_mod, only: element_t - use dimensions_mod, only: ne - use coordinate_systems_mod, only: cart2spherical + use dimensions_mod, only: ne, np, fv_nphys + use coordinate_systems_mod, only: cart2spherical, spherical_polar_t + use fvm_control_volume_mod, only: fvm_struct ! Inputs type(element_t), intent(in) :: elem(:) @@ -308,22 +320,22 @@ subroutine dp_write(elem, fvm, grid_format, filename_in) ! Allocate workspace and calculate PE displacement information if (IOroot) then - allocate(displs(npes), stat=ierror) + allocate(displs(npes), stat=ierror, errmsg=errormsg) call check_allocate(ierror, subname, 'displs(npes)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) - allocate(recvcount(npes), stat=ierror) + allocate(recvcount(npes), stat=ierror, errmsg=errormsg) call check_allocate(ierror, subname, 'recvcount(npes)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) else - allocate(displs(0), stat=ierror) + allocate(displs(0), stat=ierror, errmsg=errormsg) call check_allocate(ierror, subname, 'displs(0)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) - allocate(recvcount(0), stat=ierror) + allocate(recvcount(0), stat=ierror, errmsg=errormsg) call check_allocate(ierror, subname, 'recvcount(0)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) end if gridsize = nelem * fv_nphys*fv_nphys if(masterproc) then @@ -339,19 +351,19 @@ subroutine dp_write(elem, fvm, grid_format, filename_in) do i = 2, npes displs(i) = displs(i-1)+recvcount(i-1) end do - allocate(recvbuf(gridsize), stat=ierror) + allocate(recvbuf(gridsize), stat=ierror, errmsg=errormsg) call check_allocate(ierror, subname, 'recvbuf(gridsize)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) else - allocate(recvbuf(0), stat=ierror) + allocate(recvbuf(0), stat=ierror, errmsg=errormsg) call check_allocate(ierror, subname, 'recvbuf(0)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) end if - allocate(gwork(4, gridsize), stat=ierror) + allocate(gwork(4, gridsize), stat=ierror, errmsg=errormsg) call check_allocate(ierror, subname, 'gwork(4, gridsize)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) if (IOroot) then ! Define the horizontal grid dimensions for SCRIP output @@ -618,9 +630,10 @@ subroutine fvm2phys_init(elem,fvm,fvm_nc,phys_nc,irecons,& jall_fvm2phys,jall_phys2fvm) !SE dycore: - use dimensions_mod , only: ngpc,nelemd - use fvm_overlap_mod , only: compute_weights_cell - use element_mod , only: element_t + use dimensions_mod , only: ngpc,nelemd + use fvm_overlap_mod , only: compute_weights_cell + use element_mod , only: element_t + use fvm_control_volume_mod, only: fvm_struct type(element_t) , dimension(nelemd), intent(in) :: elem type (fvm_struct), dimension(nelemd), intent(in) :: fvm diff --git a/src/dynamics/se/dycore/comp_ctr_vol_around_gll_pts.F90 b/src/dynamics/se/dycore/comp_ctr_vol_around_gll_pts.F90 index aa0913324..1c54b1f5f 100644 --- a/src/dynamics/se/dycore/comp_ctr_vol_around_gll_pts.F90 +++ b/src/dynamics/se/dycore/comp_ctr_vol_around_gll_pts.F90 @@ -1378,7 +1378,7 @@ subroutine InitControlVolumes_gll(elem, hybrid,nets,nete) do ie=nets,nete call convert_gbl_index(elem(ie)%vertex%number,ie1,je1,face_no) - start%x=r-pi/4._r8 + ie1*dx + start%x=-pi/4._r8 + ie1*dx start%y=-1._r8*pi/4._r8 + je1*dy endd%x =start%x + dx endd%y =start%y + dy diff --git a/src/dynamics/se/dycore/control_mod.F90 b/src/dynamics/se/dycore/control_mod.F90 index fb7046d99..d20b33407 100644 --- a/src/dynamics/se/dycore/control_mod.F90 +++ b/src/dynamics/se/dycore/control_mod.F90 @@ -16,6 +16,7 @@ module control_mod integer, public :: rk_stage_user = 0 ! number of RK stages to use integer, public :: ftype = 2 ! Forcing Type integer, public :: ftype_conserve = 1 !conserve momentum (dp*u) + integer, public :: dribble_in_rsplit_loop = 0 integer, public :: statediag_numtrac = 3 integer, public :: qsplit = 1 ! ratio of dynamics tsteps to tracer tsteps @@ -23,9 +24,6 @@ module control_mod ! every rsplit tracer timesteps logical, public :: variable_nsplit=.false. - integer, public :: phys_dyn_cp = 0 !=0; no thermal energy scaling of T increment - !=1; scale increment for cp consistency between dynamics and physics - logical, public :: refined_mesh integer, public :: vert_remap_q_alg = 10 @@ -63,10 +61,25 @@ module control_mod ! (only used for variable viscosity, recommend 1.9 in namelist) real (kind=r8), public :: nu = 7.0D5 ! viscosity (momentum equ) real (kind=r8), public :: nu_div = -1 ! viscsoity (momentum equ, div component) - real (kind=r8), public :: nu_s = -1 ! default = nu T equ. viscosity + real (kind=r8), public :: nu_t = -1 ! default = nu T equ. viscosity real (kind=r8), public :: nu_q = -1 ! default = nu tracer viscosity real (kind=r8), public :: nu_p = 0.0D5 ! default = 0 ps equ. viscosity real (kind=r8), public :: nu_top = 0.0D5 ! top-of-the-model viscosity + + ! + ! Del4 sponge layer diffusion + ! + ! Divergence damping hyperviscosity coefficient nu_div [m^4/s] for u,v is increased to + ! nu_div*sponge_del4_nu_div_fac following a hyperbolic tangent function + ! centered around pressure at vertical index sponge_del4_lev + ! + ! Similar for sponge_del4_nu_fac + ! + real(r8), public :: sponge_del4_nu_fac + real(r8), public :: sponge_del4_nu_div_fac + integer , public :: sponge_del4_lev + + integer, public :: hypervis_subcycle=1 ! number of subcycles for hyper viscsosity timestep integer, public :: hypervis_subcycle_sponge=1 ! number of subcycles for hyper viscsosity timestep in sponge integer, public :: hypervis_subcycle_q=1 ! number of subcycles for hyper viscsosity timestep on TRACERS @@ -105,18 +118,13 @@ module control_mod integer, public, parameter :: seast = 6 integer, public, parameter :: nwest = 7 integer, public, parameter :: neast = 8 - - ! - ! parameters for sponge layer Rayleigh damping - ! - real(r8), public :: raytau0 - real(r8), public :: raykrange - integer, public :: rayk0 ! ! molecular diffusion ! real(r8), public :: molecular_diff = -1.0_r8 integer, public :: vert_remap_uvTq_alg, vert_remap_tracer_alg - + + + integer, public :: pgf_formulation = -1 !PGF formulation - see prim_advance_mod.F90 end module control_mod diff --git a/src/dynamics/se/dycore/dimensions_mod.F90 b/src/dynamics/se/dycore/dimensions_mod.F90 index 14856a4be..743ecf419 100644 --- a/src/dynamics/se/dycore/dimensions_mod.F90 +++ b/src/dynamics/se/dycore/dimensions_mod.F90 @@ -1,5 +1,6 @@ module dimensions_mod use shr_kind_mod, only: r8=>shr_kind_r8 + use air_composition, only: thermodynamic_active_species_num implicit none private @@ -19,26 +20,16 @@ module dimensions_mod ! character(len=16), allocatable, public :: cnst_name_gll(:) ! constituent names for SE tracers character(len=128), allocatable, public :: cnst_longname_gll(:) ! long name of SE tracers - ! - !moist cp in energy conversion term - ! - ! .false.: force dycore to use cpd (cp dry) instead of moist cp - ! .true. : use moist cp in dycore - ! - logical , public :: lcp_moist = .true. integer, parameter, public :: np = NP integer, parameter, public :: nc = 3 !cslam resolution integer , public :: fv_nphys !physics-grid resolution - the "MAX" is so that the code compiles with NC=0 integer, public, protected :: qsize_d !SE tracer dimension size + logical, public :: use_cslam = .false. !logical for CSLAM integer, public, protected :: ntrac = 0 !FVM tracer dimension size integer, public :: qsize = 0 !qsize is set in dyn_comp ! - ! hyperviscosity is applied on approximate pressure levels - ! Similar to CAM-EUL; see CAM5 scietific documentation (Note TN-486), equation (3.09), page 58. - ! - logical, public :: hypervis_dynamic_ref_state = .false. ! fvm dimensions: logical, public :: lprint!for debugging integer, parameter, public :: ngpc=3 !number of Gausspoints for the fvm integral approximation !phl change from 4 @@ -61,20 +52,21 @@ module dimensions_mod integer, allocatable, public :: kord_tr(:), kord_tr_cslam(:) - real(r8), allocatable, public :: nu_scale_top(:) ! scaling of del2 viscosity in sponge layer (initialized in dyn_comp) - real(r8), allocatable, public :: nu_lev(:) - real(r8), allocatable, public :: otau(:) + ! Minimum mixing ratio of each CSLAM tracer, in CSLAM tracer index space + ! (1:ntrac, advected constituents only). + ! The mapping is done in dyn_comp from the host constituent index space. + real(r8), allocatable, public :: qmin_cslam(:) - integer, public :: ksponge_end ! sponge is active k=1,ksponge_end - real (r8), allocatable, public :: nu_div_lev(:) ! scaling of viscosity in sponge layer + real(r8), allocatable, public :: nu_scale_top(:) ! scaling of del2 viscosity in sponge layer (initialized in dyn_comp) + real(r8), allocatable, public :: nu_lev(:) ! level dependent del4 (u,v) damping + real(r8), allocatable, public :: nu_t_lev(:) ! level dependent del4 T damping + integer, public :: ksponge_end ! sponge is active k=1,ksponge_end + real(r8), allocatable, public :: nu_div_lev(:) ! scaling of viscosity in sponge layer real(r8), allocatable, public :: kmvis_ref(:) !reference profiles for molecular diffusion real(r8), allocatable, public :: kmcnd_ref(:) !reference profiles for molecular diffusion real(r8), allocatable, public :: rho_ref(:) !reference profiles for rho real(r8), allocatable, public :: km_sponge_factor(:) !scaling for molecular diffusion (when used as sponge) - real(r8), allocatable, public :: kmvisi_ref(:) !reference profiles for molecular diffusion - real(r8), allocatable, public :: kmcndi_ref(:) !reference profiles for molecular diffusion - real(r8), allocatable, public :: rhoi_ref(:) !reference profiles for rho integer, public :: nhc_phys integer, public :: nhe_phys @@ -121,21 +113,27 @@ subroutine dimensions_mod_init() use cam_constituents, only: num_advected use cam_abortutils, only: check_allocate + ! Module(s) from CESM Share. + use shr_kind_mod, only: len_cx => shr_kind_cx + ! Local variables: - integer :: iret + integer :: iret + character(len=len_cx) :: errmsg character(len=*), parameter :: subname = 'dimensions_mod_init' ! Set tracer dimension variables: if (fv_nphys > 0) then - ! Use CSLAM for tracer advection - qsize_d = 10 ! SE tracers (currently SE supports 10 condensate loading tracers) + ! Use CSLAM for tracer advection + qsize_d = thermodynamic_active_species_num ntrac = num_advected + use_cslam = .true. else ! Use GLL for tracer advection qsize_d = num_advected ntrac = 0 ! No fvm tracers if CSLAM is off + use_cslam = .false. end if ! Set grid dimension variables: @@ -145,53 +143,41 @@ subroutine dimensions_mod_init() ! Allocate vertically-dimensioned variables: - allocate(irecons_tracer_lev(nlev), stat=iret) + allocate(irecons_tracer_lev(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'irecons_tracer_lev(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(nu_scale_top(nlev), stat=iret) + allocate(nu_scale_top(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'nu_scale_top(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(nu_lev(nlev), stat=iret) + allocate(nu_lev(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'nu_lev(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(otau(nlev), stat=iret) - call check_allocate(iret, subname, 'otau(nlev)', & - file=__FILE__, line=__LINE__) + allocate(nu_t_lev(nlev), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'nu_t_lev(nlev)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(nu_div_lev(nlev), stat=iret) + allocate(nu_div_lev(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'nu_div_lev(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(kmvis_ref(nlev), stat=iret) + allocate(kmvis_ref(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'kmvis_ref(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(kmcnd_ref(nlev), stat=iret) + allocate(kmcnd_ref(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'kmcnd_ref(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(rho_ref(nlev), stat=iret) + allocate(rho_ref(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'rho_ref(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(km_sponge_factor(nlev), stat=iret) + allocate(km_sponge_factor(nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'km_sponge_factor(nlev)', & - file=__FILE__, line=__LINE__) - - allocate(kmvisi_ref(nlevp), stat=iret) - call check_allocate(iret, subname, 'kmvisi_ref(nlevp)', & - file=__FILE__, line=__LINE__) - - allocate(kmcndi_ref(nlevp), stat=iret) - call check_allocate(iret, subname, 'kmcndi_ref(nlevp)', & - file=__FILE__, line=__LINE__) - - allocate(rhoi_ref(nlevp), stat=iret) - call check_allocate(iret, subname, 'rhoi_ref(nlevp)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) end subroutine dimensions_mod_init diff --git a/src/dynamics/se/dycore/edge_mod.F90 b/src/dynamics/se/dycore/edge_mod.F90 index 42ab912fa..5362b7d30 100644 --- a/src/dynamics/se/dycore/edge_mod.F90 +++ b/src/dynamics/se/dycore/edge_mod.F90 @@ -19,7 +19,6 @@ module edge_mod implicit none private - save ! 8-byte Integer routines public :: LongEdgeVpack, LongEdgeVunpackMIN @@ -116,7 +115,7 @@ module edge_mod ! routines which including element edge data ! (used for FVM arrays where edge data is not shared by neighboring elements) ! these routines pack/unpack element data with user specified halo size - + ! Wrap pointer so we can make an array of them. type :: wrap_ptr real (kind=r8), dimension(:,:), pointer :: ptr => null() @@ -152,13 +151,13 @@ subroutine initGhostBuffer(par,edge,elem,nlyr,ndepth, npoints,bndry_type,nthread call initEdgeBuffer(par,edge,elem,nlyr,bndry_type=bndry_type, & nthreads=nthreads,CardinalLength=ndepth*npoints,OrdinalLength=ndepth*ndepth) ! set some parameters need to support deep halos - edge%ndepth = ndepth + edge%ndepth = ndepth edge%npoints = npoints edge%lb = 1 - edge%ndepth edge%ub = edge%npoints + edge%ndepth end subroutine initGhostBuffer - + subroutine zeroEdgeBuffer(edge) @@ -1837,7 +1836,7 @@ end subroutine LongEdgeVunpackMIN subroutine ghostpack(edge,v,vlyr,kptr,ielem) - + use dimensions_mod, only : max_corner_elem use control_mod, only : north, south, east, west, neast, nwest, seast, swest use edgetype_mod, only : EdgeDescriptor_t @@ -2072,8 +2071,8 @@ subroutine ghostunpack(edge,v,vlyr,kptr,ielem) do l=swest,swest+max_corner_elem-1 isw = edge%getmap(l,ielem) if(isw /= -1) then - ! note the following is the the correct meaning of reverse in this code. - ! It is best described as a transponse operation + ! note the following is the the correct meaning of reverse in this code. + ! It is best described as a transponse operation if (edge%reverse(l,ielem)) then do k=1,vlyr ktmp = nhc*(kptr+k-1) @@ -2109,7 +2108,7 @@ subroutine ghostunpack(edge,v,vlyr,kptr,ielem) ! SEAST do l=swest+max_corner_elem,swest+2*max_corner_elem-1 ise = edge%getmap(l,ielem) - if(ise /= -1) then + if(ise /= -1) then if (edge%reverse(l,ielem)) then do k=1,vlyr ktmp = nhc*(kptr+k-1) @@ -2145,7 +2144,7 @@ subroutine ghostunpack(edge,v,vlyr,kptr,ielem) ! NEAST do l=swest+3*max_corner_elem,swest+4*max_corner_elem-1 ine = edge%getmap(l,ielem) - if(ine /= -1) then + if(ine /= -1) then if (edge%reverse(l,ielem)) then do k=1,vlyr ktmp = nhc*(kptr+k-1) @@ -2181,7 +2180,7 @@ subroutine ghostunpack(edge,v,vlyr,kptr,ielem) ! NWEST do l=swest+2*max_corner_elem,swest+3*max_corner_elem-1 inw = edge%getmap(l,ielem) - if(inw /= -1) then + if(inw /= -1) then if (edge%reverse(l,ielem)) then do k=1,vlyr ktmp = nhc*(kptr+k-1) diff --git a/src/dynamics/se/dycore/element_mod.F90 b/src/dynamics/se/dycore/element_mod.F90 index 2fa3b91ad..e6c0d64d7 100644 --- a/src/dynamics/se/dycore/element_mod.F90 +++ b/src/dynamics/se/dycore/element_mod.F90 @@ -1,6 +1,6 @@ module element_mod - use shr_kind_mod, only: r8=>shr_kind_r8, i8=>shr_kind_i8 + use shr_kind_mod, only: r8=>shr_kind_r8, i8=>shr_kind_i8, len_cx => shr_kind_cx use coordinate_systems_mod, only: spherical_polar_t, cartesian2D_t, cartesian3D_t, distance use edgetype_mod, only: edgedescriptor_t use gridgraph_mod, only: gridvertex_t @@ -45,10 +45,6 @@ module element_mod real(kind=r8), allocatable :: phi(:,:,:) ! geopotential real(kind=r8), allocatable :: omega(:,:,:) ! vertical velocity - ! semi-implicit diagnostics: computed in explict-component, reused in Helmholtz-component. - real(kind=r8), allocatable :: zeta(:,:,:) ! relative vorticity - real(kind=r8), allocatable :: div(:,:,:,:) ! divergence - ! tracer advection fields used for consistency and limiters real(kind=r8), allocatable :: dp(:,:,:) ! for dp_tracers at physics timestep real(kind=r8), allocatable :: divdp(:,:,:) ! divergence of dp @@ -60,24 +56,10 @@ module element_mod real(kind=r8), allocatable :: FM(:,:,:,:) ! momentum forcing real(kind=r8), allocatable :: FDP(:,:,:) ! save full updated dp right after physics real(kind=r8), allocatable :: FT(:,:,:) ! temperature forcing - real(kind=r8), allocatable :: etadot_prescribed(:,:,:) ! prescribed vertical tendency - real(kind=r8), allocatable :: u_met(:,:,:) ! zonal component of prescribed meteorology winds - real(kind=r8), allocatable :: dudt_met(:,:,:) ! rate of change of zonal component of prescribed meteorology winds - real(kind=r8), allocatable :: v_met(:,:,:) ! meridional component of prescribed meteorology winds - real(kind=r8), allocatable :: dvdt_met(:,:,:) ! rate of change of meridional component of prescribed meteorology winds - real(kind=r8), allocatable :: T_met(:,:,:) ! prescribed meteorology temperature - real(kind=r8), allocatable :: dTdt_met(:,:,:) ! rate of change of prescribed meteorology temperature - real(kind=r8), allocatable :: nudge_factor(:,:,:) ! nudging factor (prescribed) - real(kind=r8), allocatable :: Utnd(:,:) ! accumulated U tendency due to nudging towards prescribed met - real(kind=r8), allocatable :: Vtnd(:,:) ! accumulated V tendency due to nudging towards prescribed met - real(kind=r8), allocatable :: Ttnd(:,:) ! accumulated T tendency due to nudging towards prescribed met - - real(kind=r8), allocatable :: pecnd(:,:,:) ! pressure perturbation from condensate - - real(kind=r8) :: ps_met(np,np) ! surface pressure of prescribed meteorology - real(kind=r8) :: dpsdt_met(np,np) ! rate of change of surface pressure of prescribed meteorology - + ! reference profiles + real(kind=r8), allocatable :: T_ref(:,:,:) ! reference temperature + real(kind=r8), allocatable :: dp_ref(:,:,:) ! reference pressure level thickness end type derived_state_t !___________________________________________________________________ @@ -363,46 +345,48 @@ subroutine allocate_element_desc(elem) type (element_t), intent(inout) :: elem(:) integer :: num, j, i, iret + character(len=len_cx) :: errmsg + character(len=*), parameter :: subname = 'allocate_element_desc (SE)' num = SIZE(elem) do j=1,num - allocate(elem(j)%desc%putmapP(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%putmapP(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%putmapP(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%getmapP(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%getmapP(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%getmapP(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%putmapP_ghost(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%putmapP_ghost(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%putmapP_ghost(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%getmapP_ghost(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%getmapP_ghost(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%getmapP_ghost(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%putmapS(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%putmapS(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%putmapS(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%getmapS(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%getmapS(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%getmapS(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%reverse(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%reverse(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%reverse(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%globalID(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%globalID(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%globalID(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(elem(j)%desc%loc2buf(max_neigh_edges), stat=iret) + allocate(elem(j)%desc%loc2buf(max_neigh_edges), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%desc%loc2buf(max_neigh_edges)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do i=1,max_neigh_edges elem(j)%desc%loc2buf(i)=i @@ -417,7 +401,7 @@ subroutine allocate_element_dims(elem) ! Allocate the SE element arrays using the pre-calculated SE dimensions - use dimensions_mod, only: nc, nlev, nlevp, qsize_d, ntrac + use dimensions_mod, only: nc, nlev, nlevp, qsize_d, ntrac, use_cslam !Dummy arguments: type(element_t), intent(inout) :: elem(:) @@ -425,6 +409,8 @@ subroutine allocate_element_dims(elem) !Local arguments: integer :: num, i, iret + character(len=len_cx) :: errmsg + character(len=*), parameter :: subname = 'allocate_element_dims (SE)' !--------------- @@ -437,24 +423,34 @@ subroutine allocate_element_dims(elem) !-------------------------- ! velocity - allocate(elem(i)%state%v(np,np,2,nlev,timelevels), stat=iret) + allocate(elem(i)%state%v(np,np,2,nlev,timelevels), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%state%v(np,np,2,nlev,timelevels)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! temperature - allocate(elem(i)%state%T(np,np,nlev,timelevels), stat=iret) + allocate(elem(i)%state%T(np,np,nlev,timelevels), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%state%T(np,np,nlev,timelevels)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! dry delta p on levels - allocate(elem(i)%state%dp3d(np,np,nlev,timelevels), stat=iret) + allocate(elem(i)%state%dp3d(np,np,nlev,timelevels), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%state%dp3d(np,np,nlev,timelevels)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! Tracer mass - allocate(elem(i)%state%Qdp(np,np,nlev,qsize_d,2), stat=iret) - call check_allocate(iret, subname, 'elem%state%Qdp(np,np,nlev,qsize_d,2)', & - file=__FILE__, line=__LINE__) + ! With CSLAM the tracers are advected on the fvm grid and the GLL Qdp is + ! only refreshed from it, so Qdp does not time-rotate and a single + ! timelevel is allocated. + ! TimeLevel_Qdp pins n0/np1 to 1 when use_cslam = .true.: + if (use_cslam) then + allocate(elem(i)%state%Qdp(np,np,nlev,qsize_d,1), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'elem%state%Qdp(np,np,nlev,qsize_d,1)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + else + allocate(elem(i)%state%Qdp(np,np,nlev,qsize_d,2), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'elem%state%Qdp(np,np,nlev,qsize_d,2)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + end if !-------------------------- @@ -462,146 +458,86 @@ subroutine allocate_element_dims(elem) !---------------------------- ! velocity for SE tracer advection - allocate(elem(i)%derived%vn0(np,np,2,nlev), stat=iret) + allocate(elem(i)%derived%vn0(np,np,2,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%vn0(np,np,2,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! mean dp dissipation tendency, if nu_p>0 - allocate(elem(i)%derived%dpdiss_biharmonic(np,np,nlev), stat=iret) + allocate(elem(i)%derived%dpdiss_biharmonic(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%dpdiss_biharmonic(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! mean dp used to compute psdiss_tens - allocate(elem(i)%derived%dpdiss_ave(np,np,nlev), stat=iret) + allocate(elem(i)%derived%dpdiss_ave(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%dpdiss_ave(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! geopotential - allocate(elem(i)%derived%phi(np,np,nlev), stat=iret) + allocate(elem(i)%derived%phi(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%phi(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! vertical velocity - allocate(elem(i)%derived%omega(np,np,nlev), stat=iret) + allocate(elem(i)%derived%omega(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%omega(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! relative vorticity - allocate(elem(i)%derived%zeta(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%zeta(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! divergence - allocate(elem(i)%derived%div(np,np,nlev,timelevels), stat=iret) - call check_allocate(iret, subname, 'elem%derived%div(np,np,nlev,timelevels)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! for dp_tracers at physics timestep - allocate(elem(i)%derived%dp(np,np,nlev), stat=iret) + allocate(elem(i)%derived%dp(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%dp(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! divergence of dp - allocate(elem(i)%derived%divdp(np,np,nlev), stat=iret) + allocate(elem(i)%derived%divdp(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%divdp(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! DSSed divdp - allocate(elem(i)%derived%divdp_proj(np,np,nlev), stat=iret) + allocate(elem(i)%derived%divdp_proj(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%divdp_proj(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! total tracer mass for diagnostics - allocate(elem(i)%derived%mass(max(qsize_d,ntrac)+9), stat=iret) + allocate(elem(i)%derived%mass(max(qsize_d,ntrac)+9), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%mass(max(qsize_d,ntrac)+9)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! tracer forcing - allocate(elem(i)%derived%FQ(np,np,nlev,qsize_d), stat=iret) + allocate(elem(i)%derived%FQ(np,np,nlev,qsize_d), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%FQ(np,np,nlev,qsize_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! momentum forcing - allocate(elem(i)%derived%FM(np,np,2,nlev), stat=iret) + allocate(elem(i)%derived%FM(np,np,2,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%FM(np,np,2,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! save full updated dp right after physics - allocate(elem(i)%derived%FDP(np,np,nlev), stat=iret) + allocate(elem(i)%derived%FDP(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%FDP(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! temperature forcing - allocate(elem(i)%derived%FT(np,np,nlev), stat=iret) + allocate(elem(i)%derived%FT(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%derived%FT(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! prescribed vertical tendency - allocate(elem(i)%derived%etadot_prescribed(np,np,nlevp), stat=iret) - call check_allocate(iret, subname, 'elem%derived%etadot_prescribed(np,np,nlevp)', & - file=__FILE__, line=__LINE__) - - ! zonal component of prescribed meteorology winds - allocate(elem(i)%derived%u_met(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%u_met(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! rate of change of zonal component of prescribed meteorology winds - allocate(elem(i)%derived%dudt_met(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%dudt_met(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! meridional component of prescribed meteorology winds - allocate(elem(i)%derived%v_met(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%v_met(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! rate of change of meridional component of prescribed meteorology winds - allocate(elem(i)%derived%dvdt_met(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%dvdt_met(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! prescribed meteorology temperature - allocate(elem(i)%derived%T_met(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%T_met(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! rate of change of prescribed meteorology temperature - allocate(elem(i)%derived%dTdt_met(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%dTdt_met(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! nudging factor (prescribed) - allocate(elem(i)%derived%nudge_factor(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%nudge_factor(np,np,nlev)', & - file=__FILE__, line=__LINE__) - - ! accumulated U tendency due to nudging towards prescribed met - allocate(elem(i)%derived%Utnd(npsq,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%Utnd(npsq,nlev)', & - file=__FILE__, line=__LINE__) - - ! accumulated V tendency due to nudging towards prescribed met - allocate(elem(i)%derived%Vtnd(npsq,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%Vtnd(npsq,nlev)', & - file=__FILE__, line=__LINE__) - - ! accumulated T tendency due to nudging towards prescribed met - allocate(elem(i)%derived%Ttnd(npsq,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%Ttnd(npsq,nlev)', & - file=__FILE__, line=__LINE__) - - ! pressure perturbation from condensate - allocate(elem(i)%derived%pecnd(np,np,nlev), stat=iret) - call check_allocate(iret, subname, 'elem%derived%pecnd(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) + + ! reference temperature profile for hyperviscosity + allocate(elem(i)%derived%T_ref(np,np,nlev), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'elem%derived%T_ref(np,np,nlev)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + + ! reference pressure level thickness profile for hyperviscosity + allocate(elem(i)%derived%dp_ref(np,np,nlev), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'elem%derived%dp_ref(np,np,nlev)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) !---------------------------- !First Coordinate: - allocate(elem(i)%sub_elem_mass_flux(nc,nc,4,nlev), stat=iret) + allocate(elem(i)%sub_elem_mass_flux(nc,nc,4,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'elem%sub_elem_mass_flux(nc,nc,4,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) end do diff --git a/src/dynamics/se/dycore/fvm_consistent_se_cslam.F90 b/src/dynamics/se/dycore/fvm_consistent_se_cslam.F90 index 203917101..8ad55884b 100644 --- a/src/dynamics/se/dycore/fvm_consistent_se_cslam.F90 +++ b/src/dynamics/se/dycore/fvm_consistent_se_cslam.F90 @@ -6,16 +6,19 @@ module fvm_consistent_se_cslam use cam_abortutils, only: endrun use cam_logfile, only: iulog - use time_mod, only: timelevel_t + use se_dyn_time_mod, only: timelevel_t use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct use hybrid_mod, only: hybrid_t, config_thread_region, get_loop_ranges, threadOwnsVertLevel use perf_mod, only: t_startf, t_stopf implicit none private - save - real (kind=r8),parameter , private :: eps=1.0e-14_r8 + real (kind=r8), parameter, private :: eps=1.0e-14_r8 + + !Logical to turn on/off timers in this module. Set to .true. to enable timing of CSLAM FVM routines. + logical, parameter, private :: FVM_TIMERS = .false. + public :: run_consistent_se_cslam contains ! @@ -39,13 +42,11 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& use edgetype_mod , only: edgebuffer_t use bndry_mod , only: ghost_exchange use hybvcoord_mod , only: hvcoord_t -!Un-comment once constituents are enabled -JN: -! use constituents , only: qmin - use dimensions_mod , only: large_Courant_incr,irecons_tracer_lev + use dimensions_mod , only: large_Courant_incr,irecons_tracer_lev,qmin_cslam use thread_mod , only: vert_num_threads, omp_set_nested implicit none type (element_t) , intent(inout) :: elem(:) - type (fvm_struct) , intent(inout) :: fvm(:) + type (fvm_struct), target , intent(inout) :: fvm(:) type (hybrid_t) , intent(in) :: hybrid ! distributed parallel structure (shared) type (TimeLevel_t) , intent(in) :: tl ! time level struct type (hvcoord_t) , intent(in) :: hvcoord @@ -68,17 +69,19 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& integer :: kmin,kmax integer :: ir integer :: kblk ! total number of vertical levels per thread - integer :: klev ! total number of vertical levels in the JET region + integer :: klev ! total number of vertical levels in the JET region integer :: region_num_threads logical :: inJetCall logical :: ActiveJetThread - + + real(r8), pointer :: fcube(:,:,:,:) + real(r8), pointer :: spherecentroid(:,:,:) llimiter = .true. inJetCall = .false. - if(((kminp .ne. 1) .or. (kmaxp .ne. nlev)) .and. vert_num_threads>1) then - write(iulog,*)'WARNING: deactivating vertical threading for JET region call' + if(((kminp .ne. 1) .or. (kmaxp .ne. nlev)) .and. vert_num_threads>1) then + write(iulog,*)'WARNING: deactivating vertical threading for JET region call' inJetCall = .true. region_num_threads = 1 else @@ -86,15 +89,15 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& endif call omp_set_nested(.true.) - !$OMP PARALLEL NUM_THREADS(region_num_threads), DEFAULT(SHARED), & + !$OMP PARALLEL NUM_THREADS(region_num_threads), DEFAULT(SHARED), & !$OMP PRIVATE(hybridnew,kblk,ie,k,kmin,gspts,inv_dp_area,itr), & !$OMP PRIVATE(kmin_jet_local,kmax,kmax_jet_local,kptr,q,ctracer,ActiveJetThread) call gauss_points(ngpc,gsweights,gspts) !set gauss points/weights gspts = 0.5_r8*(gspts+1.0_r8) !shift location so in [0:1] instead of [-1:1] - if(inJetCall) then + if(inJetCall) then ! =============================================================================== - ! if this is the reduced Jet region call then do not thread over the vertical.... + ! if this is the reduced Jet region call then do not thread over the vertical.... ! Just use the number of vertical levels that were passed into subroutine ! =============================================================================== hybridnew = config_thread_region(hybrid,'serial') @@ -106,7 +109,7 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& endif kblk = kmax-kmin+1 - !call t_startf('fvm:before_Qnhc') + if(FVM_TIMERS) call t_startf('fvm:before_Qnhc') do ie=nets,nete do k=kmin,kmax elem(ie)%sub_elem_mass_flux(:,:,:,k) = dt_fvm*elem(ie)%sub_elem_mass_flux(:,:,:,k)*fvm(ie)%dp_ref_inverse(k) @@ -119,11 +122,11 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& call ghostpack(ghostbufQnhc,fvm(ie)%c(1-nhc:nc+nhc,1-nhc:nc+nhc,kmin:kmax,q),kblk,kptr,ie) enddo end do - !call t_stopf('fvm:before_Qnhc') - !call t_startf('fvm:ghost_exchange:Qnhc') + if(FVM_TIMERS) call t_stopf('fvm:before_Qnhc') + if(FVM_TIMERS) call t_startf('fvm:ghost_exchange:Qnhc') call ghost_exchange(hybridnew,ghostbufQnhc,location='ghostbufQnhc') - !call t_stopf('fvm:ghost_exchange:Qnhc') - !call t_startf('fvm:orthogonal_swept_areas') + if(FVM_TIMERS) call t_stopf('fvm:ghost_exchange:Qnhc') + if(FVM_TIMERS) call t_startf('fvm:orthogonal_swept_areas') do ie=nets,nete do k=kmin,kmax fvm(ie)%se_flux (1:nc,1:nc,:,k) = elem(ie)%sub_elem_mass_flux(:,:,:,k) @@ -151,24 +154,28 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& end do enddo - !call t_stopf('fvm:orthogonal_swept_areas') + if(FVM_TIMERS) call t_stopf('fvm:orthogonal_swept_areas') do ie=nets,nete + ! Intel compiler version 2023.0.0 on derecho had significant slowdown on subroutine interface without + ! these pointers. + fcube => fvm(ie)%c(:,:,:,:) + spherecentroid => fvm(ie)%spherecentroid(:,1-nhe:nc+nhe,1-nhe:nc+nhe) do k=kmin,kmax - !call t_startf('fvm:tracers_reconstruct') - call reconstruction(fvm(ie)%c(:,:,:,:),nlev,k,& + if(FVM_TIMERS) call t_startf('FVM:tracers_reconstruct') + call reconstruction(fcube,nlev,k,& ctracer(:,:,:,:),irecons_tracer,llimiter,ntrac,& nc,nhe,nhr,nhc,nht,ns,nhr+(nhe-1),& fvm(ie)%jx_min,fvm(ie)%jx_max,fvm(ie)%jy_min,fvm(ie)%jy_max,& fvm(ie)%cubeboundary,fvm(ie)%halo_interp_weight,fvm(ie)%ibase,& - fvm(ie)%spherecentroid(:,1-nhe:nc+nhe,1-nhe:nc+nhe),& + spherecentroid,& fvm(ie)%recons_metrics,fvm(ie)%recons_metrics_integral,& fvm(ie)%rot_matrix,fvm(ie)%centroid_stretch,& fvm(ie)%vertex_recons_weights,fvm(ie)%vtx_cart,& irecons_tracer_lev(k)) - !call t_stopf('fvm:tracers_reconstruct') - !call t_startf('fvm:swept_flux') - call swept_flux(elem(ie),fvm(ie),k,ctracer,irecons_tracer_lev(k),gsweights,gspts) - !call t_stopf('fvm:swept_flux') + if(FVM_TIMERS) call t_stopf('FVM:tracers_reconstruct') + if(FVM_TIMERS) call t_startf('fvm:swept_flux') + call swept_flux(elem(ie),fvm(ie),k,ctracer,irecons_tracer_lev(k),gsweights,gspts) + if(FVM_TIMERS) call t_stopf('fvm:swept_flux') end do end do ! @@ -188,18 +195,18 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& ! ! if (large_Courant_incr) then - !call t_startf('fvm:fill_halo_fvm:large_Courant') + if(FVM_TIMERS) call t_startf('fvm:fill_halo_fvm:large_Courant') !if (kmin_jetkmax) then ! call endrun('ERROR: kmax_jet must be .le. kmax passed to run_consistent_se_cslam') - !end if + !end if ! Determine the extent of the JET that is owned by this thread ActiveJetThread = threadOwnsVertLevel(hybridnew,kmin_jet) .or. threadOwnsVertLevel(hybridnew,kmax_jet) kmin_jet_local = max(kmin_jet,kmin) kmax_jet_local = min(kmax_jet,kmax) klev = kmax_jet-kmin_jet+1 call fill_halo_fvm(ghostbufQ1,elem,fvm,hybridnew,nets,nete,1,kmin_jet_local,kmax_jet_local,klev,active=ActiveJetThread) - !call t_stopf('fvm:fill_halo_fvm:large_Courant') - !call t_startf('fvm:large_Courant_number_increment') + if(FVM_TIMERS) call t_stopf('fvm:fill_halo_fvm:large_Courant') + if(FVM_TIMERS) call t_startf('fvm:large_Courant_number_increment') if(ActiveJetThread) then do k=kmin_jet_local,kmax_jet_local !1,nlev do ie=nets,nete @@ -207,10 +214,10 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& end do end do endif - !call t_stopf('fvm:large_Courant_number_increment') + if(FVM_TIMERS) call t_stopf('fvm:large_Courant_number_increment') end if - !call t_startf('fvm:end_of_reconstruct_subroutine') + if(FVM_TIMERS) call t_startf('fvm:end_of_reconstruct_subroutine') do k=kmin,kmax ! ! convert to mixing ratio @@ -228,9 +235,7 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& ! convert to mixing ratio fvm(ie)%c(i,j,k,itr) = fvm(ie)%c(i,j,k,itr)*inv_dp_area(i,j) ! remove round-off undershoots - !fvm(ie)%c(i,j,k,itr) = MAX(fvm(ie)%c(i,j,k,itr),qmin(itr)) -!Remove once constituents are enabled and ucomment above line -JN: - fvm(ie)%c(i,j,k,itr) = MAX(fvm(ie)%c(i,j,k,itr), 0._r8) + fvm(ie)%c(i,j,k,itr) = MAX(fvm(ie)%c(i,j,k,itr),qmin_cslam(itr)) end do end do end do @@ -248,7 +253,7 @@ subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,& elem(ie)%sub_elem_mass_flux(:,:,:,k)=0 end do end do - !call t_stopf('fvm:end_of_reconstruct_subroutine') + if(FVM_TIMERS) call t_stopf('fvm:end_of_reconstruct_subroutine') !$OMP END PARALLEL call omp_set_nested(.false.) end subroutine run_consistent_se_cslam @@ -278,7 +283,7 @@ subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspt REAL(KIND=r8), dimension(2,8) :: x_start, dgam_vec REAL(KIND=r8) :: gamma_max, displ_first_guess - REAL(KIND=r8) :: flux,flux_tracer(ntrac) + REAL(KIND=r8) :: flux,flux_tracer(ntrac),w REAL(KIND=r8), dimension(num_area) :: dp_area @@ -303,7 +308,6 @@ subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspt ! ! prepare for air/tracer update ! -! dp = fvm%dp_fvm(1-nhe:nc+nhe,1-nhe:nc+nhe,ilev) dp = fvm%dp_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,ilev) fvm%dp_fvm(1:nc,1:nc,ilev) = fvm%dp_fvm(1:nc,1:nc,ilev)*fvm%area_sphere do itr=1,ntrac @@ -317,9 +321,9 @@ subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspt do iside=1,4 do j=jmin_side(iside),jmax_side(iside) do i=imin_side(iside),imax_side(iside) - !DO NOT USE MASS_FLUX_SE AS THRESHOLD - THRESHOLD CONDITION MUST BE CONSISTENT WITH + !DO NOT USE MASS_FLUX_SE AS THRESHOLD - THRESHOLD CONDITION MUST BE CONSISTENT WITH !THE ONE USED IN DEFINE_SWEPT_AREAS -! if (mass_flux_se(i,j,iside)>eps) then +! if (mass_flux_se(i,j,iside)>eps) then if (fvm%se_flux(i,j,iside,ilev)>eps) then ! ! || || @@ -535,14 +539,14 @@ subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspt ! ! iterate to get flux area ! - !call t_startf('fvm:swept_area:get_gamma') + if(FVM_TIMERS) call t_startf('fvm:swept_area:get_gamma') do iarea=1,num_area dp_area(iarea) = dp(idx(1,iarea,i,j,iside),idx(2,iarea,i,j,iside)) end do call get_flux_segments_area_iterate(x,x_static,dx_static,dx,x_start,dgam_vec,num_seg,num_seg_static,& num_seg_max,num_area,dp_area,flowcase,gamma,mass_flux_se(i,j,iside),0.0_r8,gamma_max, & gsweights,gspts,ilev) - !call t_stopf('fvm:swept_area:get_gamma') + if(FVM_TIMERS) call t_stopf('fvm:swept_area:get_gamma') ! ! pack segments for high-order weights computation ! @@ -557,10 +561,10 @@ subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspt ! ! compute higher-order weights ! - !call t_startf('fvm:swept_area:get_high_order_w') + if(FVM_TIMERS) call t_startf('fvm:swept_area:get_high_order_w') call get_high_order_weights_over_areas(x,dx,num_seg,num_seg_max,num_area,weights,ngpc,& gsweights, gspts,irecons_tracer) - !call t_stopf('fvm:swept_area:get_high_order_w') + if(FVM_TIMERS) call t_stopf('fvm:swept_area:get_high_order_w') ! !************************************************** ! @@ -568,16 +572,17 @@ subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspt ! !************************************************** ! - !call t_startf('fvm:swept_area:remap') + if(FVM_TIMERS) call t_startf('fvm:swept_area:remap') flux=0.0_r8; flux_tracer=0.0_r8 do iarea=1,num_area if (num_seg(iarea)>0) then ii=idx(1,iarea,i,j,iside); jj=idx(2,iarea,i,j,iside) flux=flux+weights(1,iarea)*dp(ii,jj) - do itr=1,ntrac - do iw=1,irecons_tracer_actual - flux_tracer(itr) = flux_tracer(itr)+weights(iw,iarea)*ctracer(iw,ii,jj,itr) - end do + do iw=1,irecons_tracer_actual + w = weights(iw,iarea) + do itr=1,ntrac + flux_tracer(itr) = flux_tracer(itr)+w*ctracer(iw,ii,jj,itr) + end do end do end if end do @@ -611,11 +616,11 @@ subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspt fvm%dp_fvm(i-1,j,ilev ) = fvm%dp_fvm(i-1,j,ilev )+flux fvm% c(i-1,j,ilev,1:ntrac) = fvm% c(i-1,j,ilev,1:ntrac)+flux_tracer(1:ntrac) end if - !call t_stopf('fvm:swept_area:remap') + if(FVM_TIMERS) call t_stopf('fvm:swept_area:remap') end if end do end do - end do + end do end subroutine swept_flux @@ -649,7 +654,6 @@ subroutine large_courant_number_increment(fvm,ilev) fvm%se_flux(i,j,iside,ilev)*inv_dp_area(i,j) end if #endif - do itr=1,ntrac flux_tracer(itr) = fvm%se_flux(i,j,iside,ilev)*c_tmp(i,j,itr)*inv_dp_area(i,j) end do @@ -843,19 +847,19 @@ subroutine compute_displacements_for_swept_areas(fvm,cair,k,gsweights,gspts) fvm%se_flux(i,j,iside,k) = ABS(SUM(gamma(iside)*dgam_vec(:,1,iside,i,j))) #ifdef waccm_debug fvm%CSLAM_gamma(i,j,k,iside) = gamma(iside) -#endif +#endif if (gamma(iside)>1_r8) then if (.not.large_Courant_incr) then write(iulog,*) 'ERROR in CSLAM: local Courant number is >1: gamma=',gamma(iside),' k=',k call endrun('ERROR in CSLAM: local Courant number is > 1; set namelist se_large_Courant_incr=.true. ') endif gamma(iside)=1.0_r8-eps - end if + end if else fvm%se_flux(i,j,iside,k) = 0.0_r8 #ifdef waccm_debug fvm%CSLAM_gamma(i,j,k,iside) = 0.0_r8 -#endif +#endif end if enddo end do @@ -951,7 +955,7 @@ subroutine get_flux_segments_area_iterate(x,x_static,dx_static,dx,x_start,dgam_v ! return end if - + dgamma=(gamma2-gamma1)*f2/(f2-f1); gamma3 = gamma2-dgamma; ! Newton "guess" for gamma @@ -976,7 +980,7 @@ subroutine get_flux_segments_area_iterate(x,x_static,dx_static,dx,x_start,dgam_v ! ! to compute first-guess perpendicular displacements for iside=1 ! - iarea=1 + iarea=1 x (:,1,iarea) = x_start(:,1)+gamma3*dgam_vec(:,1) dx (:,1,iarea) = -dx_static(:,1,iarea) x (:,2,iarea) = x_start(:,2)+gamma3*dgam_vec(:,1) diff --git a/src/dynamics/se/dycore/fvm_mapping.F90 b/src/dynamics/se/dycore/fvm_mapping.F90 index 7a4fb2bbf..daf12422a 100644 --- a/src/dynamics/se/dycore/fvm_mapping.F90 +++ b/src/dynamics/se/dycore/fvm_mapping.F90 @@ -14,7 +14,7 @@ !#define skip_high_order_fq_map !do mass and correlation preserving phys2fvm mapping but no high-order pre-mapping of fq #define mass_fix module fvm_mapping - use shr_kind_mod, only: r8=>shr_kind_r8 + use shr_kind_mod, only: r8=>shr_kind_r8, len_cx=>shr_kind_cx use dimensions_mod, only: irecons_tracer use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct @@ -25,8 +25,8 @@ module fvm_mapping private public :: phys2dyn_forcings_fvm, dyn2phys, dyn2phys_vector, dyn2phys_all_vars,dyn2fvm_mass_vars - public :: phys2dyn,fvm2dyn,dyn2fvm - save + public :: phys2dyn,fvm2dyn,dyn2fvm,cslam2gll + integer :: save_max_overlap real(kind=r8), allocatable, dimension(:,:,:,:,:) :: save_air_mass_overlap real(kind=r8), allocatable, dimension(:,:,:,:,:,:) :: save_q_overlap @@ -35,6 +35,12 @@ module fvm_mapping real(kind=r8), allocatable, dimension(:,:,:,:) :: save_overlap_area integer , allocatable, dimension(:,:,:,:,:) :: save_overlap_idx integer , allocatable, dimension(:,:,:,:) :: save_num_overlap + + interface fvm2dyn + module procedure fvm2dynt1 + module procedure fvm2dyntn + end interface fvm2dyn + contains ! ! map all mass variables from gll to fvm @@ -53,8 +59,7 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ integer :: ie,i,j,k,m_cnst,nq integer :: iret - real (kind=r8), dimension(:,:,:,:,:) , allocatable :: fld_phys, fld_gll, fld_fvm - real (kind=r8), allocatable, dimension(:,:,:,:,:) :: qgll + real (kind=r8), dimension(:,:,:,:,:) , allocatable :: fld_phys, fld_gll real (kind=r8) :: element_ave ! ! for tensor product Lagrange interpolation @@ -62,19 +67,9 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ integer :: nflds logical, allocatable :: llimiter(:) + character(len=len_cx) :: errmsg character(len=*), parameter :: subname = 'phys2dyn_forcings_fvm (SE)' - allocate(qgll(np,np,nlev,thermodynamic_active_species_num,nets:nete), stat=iret) - call check_allocate(iret, subname, & - 'qgll(np,np,nlev,thermodynamic_active_species_num,nets:nete)', & - file=__FILE__, line=__LINE__) - - do ie=nets,nete - do nq=1,thermodynamic_active_species_num - qgll(:,:,:,nq,ie) = elem(ie)%state%Qdp(:,:,:,nq,tl_qdp)/elem(ie)%state%dp3d(:,:,:,tl_f) - end do - end do - if (no_cslam) then call endrun("phys2dyn_forcings_fvm: no cslam case: NOT SUPPORTED") else if (nc.ne.fv_nphys) then @@ -87,18 +82,19 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ ! call t_startf('p2d-pg2:copying') nflds = 4+ntrac - allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete), stat=iret) + allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(fld_gll(np,np,nlev,3,nets:nete), stat=iret) + allocate(fld_gll(np,np,nlev,3,nets:nete), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'fld_gll(np,np,nlev,3,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(llimiter(nflds), stat=iret) + allocate(llimiter(3), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'llimiter(nflds)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) fld_phys = -9.99E99_r8!xxx necessary? @@ -123,7 +119,9 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ ! ! do mapping of fu,fv,ft ! - call phys2dyn(hybrid,elem,fld_phys(:,:,:,1:3,:),fld_gll(:,:,:,1:3,:),nets,nete,nlev,3,fvm,llimiter(1:3),2,.true.) + call phys2dyn(hybrid,elem,fld_phys(:,:,:,1:3,:),fld_gll,nets,nete,nlev,3,fvm,llimiter, & + istart_vector=2,halo_filled=.true.) + do ie=nets,nete elem(ie)%derived%fT(:,:,:) = fld_gll(:,:,:,1,ie) elem(ie)%derived%fM(:,:,1,:) = fld_gll(:,:,:,2,ie) @@ -144,44 +142,7 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ end do end do call t_stopf('p2d-pg2:phys2fvm') - - ! - ! overwrite SE Q with cslam Q - ! - nflds = thermodynamic_active_species_num - allocate(fld_gll(np,np,nlev,nflds,nets:nete), stat=iret) - call check_allocate(iret, subname, 'fld_gll(np,np,nlev,nflds,nets:nete)', & - file=__FILE__, line=__LINE__) - - allocate(fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,nflds,nets:nete), stat=iret) - call check_allocate(iret, subname, 'fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,nflds,nets:nete)', & - file=__FILE__, line=__LINE__) - - do ie=nets,nete - ! - ! compute cslam updated Q value - do m_cnst=1,thermodynamic_active_species_num - fld_fvm(1:nc,1:nc,:,m_cnst,ie) = fvm(ie)%c(1:nc,1:nc,:,thermodynamic_active_species_idx(m_cnst))+& - fvm(ie)%fc(1:nc,1:nc,:,thermodynamic_active_species_idx(m_cnst))/fvm(ie)%dp_fvm(1:nc,1:nc,:) - enddo - end do - call t_startf('p2d-pg2:fvm2dyn') - llimiter(1:nflds) = .false. - call fvm2dyn(fld_fvm,fld_gll(:,:,:,1:nflds,:),hybrid,nets,nete,nlev,nflds,fvm,llimiter(1:nflds)) - call t_stopf('p2d-pg2:fvm2dyn') - ! - ! fld_gll now holds q cslam value on gll grid - ! - ! convert fld_gll to increment (q_new-q_old) - ! - do ie=nets,nete - do m_cnst=1,thermodynamic_active_species_num - elem(ie)%derived%fq(:,:,:,m_cnst) =& - fld_gll(:,:,:,m_cnst,ie)-qgll(:,:,:,m_cnst,ie) - end do - end do - deallocate(fld_fvm) - !deallocate arrays allocated in dyn2phys_all_vars + !deallocate arrays allocated in dyn2phys_all_vars deallocate(save_air_mass_overlap,save_q_phys,save_q_overlap,& save_overlap_area,save_num_overlap,save_overlap_idx,save_dp_phys) else @@ -194,20 +155,21 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ !***************************************************************************************** ! ! nflds is ft, fu, fv, + thermo species - nflds = 3+thermodynamic_active_species_num - allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete), stat=iret) + nflds = 3 + allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(fld_gll(np,np,nlev,nflds,nets:nete), stat=iret) + allocate(fld_gll(np,np,nlev,nflds,nets:nete), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'fld_gll(np,np,nlev,nflds,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(llimiter(nflds), stat=iret) + allocate(llimiter(nflds), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, ' llimiter(nflds)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) llimiter(1:nflds) = .false. do ie=nets,nete @@ -217,18 +179,8 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ fld_phys(1:fv_nphys,1:fv_nphys,:,1,ie) = fvm(ie)%ft(1:fv_nphys,1:fv_nphys,:) fld_phys(1:fv_nphys,1:fv_nphys,:,2,ie) = fvm(ie)%fm(1:fv_nphys,1:fv_nphys,1,:) fld_phys(1:fv_nphys,1:fv_nphys,:,3,ie) = fvm(ie)%fm(1:fv_nphys,1:fv_nphys,2,:) - ! - ! compute cslam mixing ratio with physics update - ! - do m_cnst=1,thermodynamic_active_species_num - do k=1,nlev - fld_phys(1:fv_nphys,1:fv_nphys,k,m_cnst+3,ie) = & - fvm(ie)%c(1:fv_nphys,1:fv_nphys,k,thermodynamic_active_species_idx(m_cnst))+& - fvm(ie)%fc_phys(1:fv_nphys,1:fv_nphys,k,thermodynamic_active_species_idx(m_cnst)) - end do - end do - end do - ! + end do + ! ! do mapping ! call phys2dyn(hybrid,elem,fld_phys,fld_gll,nets,nete,nlev,nflds,fvm,llimiter,2) @@ -238,22 +190,16 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ elem(ie)%derived%fM(:,:,2,:) = fld_gll(:,:,:,3,ie) end do do ie=nets,nete - do m_cnst=1,thermodynamic_active_species_num - ! - ! convert fq so that it will effectively overwrite SE q with CSLAM q - ! - elem(ie)%derived%fq(:,:,:,m_cnst) = fld_gll(:,:,:,m_cnst+3,ie)-& - qgll(:,:,:,m_cnst,ie) - end do do m_cnst = 1,ntrac fvm(ie)%fc(1:nc,1:nc,:,m_cnst) = fvm(ie)%fc_phys(1:nc,1:nc,:,m_cnst)*fvm(ie)%dp_fvm(1:nc,1:nc,:) end do end do end if - deallocate(fld_phys,llimiter,fld_gll,qgll) + deallocate(fld_phys,llimiter) end subroutine phys2dyn_forcings_fvm - subroutine fvm2dyn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimiter) + ! for multiple fields + subroutine fvm2dyntn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimiter,halo_filled) use dimensions_mod, only: np, nhc, nc use hybrid_mod , only: hybrid_t use bndry_mod , only: ghost_exchange @@ -266,7 +212,10 @@ subroutine fvm2dyn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimiter type (hybrid_t) , intent(in) :: hybrid type(fvm_struct) , intent(in) :: fvm(nets:nete) logical , intent(in) :: llimiter(num_flds) + logical, optional , intent(in) :: halo_filled !optional if boundary exchange for fld_fvm has already been called + integer :: ie, iwidth + logical :: fill_halo ! !********************************************* ! @@ -274,13 +223,20 @@ subroutine fvm2dyn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimiter ! !********************************************* ! - do ie=nets,nete - call ghostpack(ghostBufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) - end do - call ghost_exchange(hybrid,ghostbufQnhc_s,location='fvm2dyn') - do ie=nets,nete - call ghostunpack(ghostbufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) - end do + fill_halo = .true. + if (present(halo_filled)) then + fill_halo = .not. halo_filled + end if + + if (fill_halo) then + do ie=nets,nete + call ghostpack(ghostBufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) + end do + call ghost_exchange(hybrid,ghostbufQnhc_s,location='fvm2dyntn') + do ie=nets,nete + call ghostunpack(ghostbufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) + end do + end if ! ! mapping ! @@ -290,8 +246,56 @@ subroutine fvm2dyn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimiter call tensor_lagrange_interp(fvm(ie)%cubeboundary,np,nc,nhc,numlev,num_flds,fld_fvm(:,:,:,:,ie),& fld_gll(:,:,:,:,ie),llimiter,iwidth,fvm(ie)%norm_elem_coord) end do - end subroutine fvm2dyn + end subroutine fvm2dyntn + ! for single field + subroutine fvm2dynt1(fld_fvm,fld_gll,hybrid,nets,nete,numlev,fvm,llimiter,halo_filled) + use dimensions_mod, only: np, nhc, nc + use hybrid_mod , only: hybrid_t + use bndry_mod , only: ghost_exchange + use edge_mod , only: ghostpack,ghostunpack + use fvm_mod , only: ghostBufQnhc_t1 + ! + integer , intent(in) :: nets,nete,numlev + real (kind=r8), intent(inout) :: fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,numlev,1,nets:nete) + real (kind=r8), intent(out) :: fld_gll(np,np,numlev,1,nets:nete) + type (hybrid_t) , intent(in) :: hybrid + type(fvm_struct) , intent(in) :: fvm(nets:nete) + logical , intent(in) :: llimiter(1) + logical, optional , intent(in) :: halo_filled!optional if boundary exchange for fld_fvm has already been called + + integer :: ie, iwidth + logical :: fill_halo + ! + !********************************************* + ! + ! halo exchange + ! + !********************************************* + ! + fill_halo = .true. + if (present(halo_filled)) then + fill_halo = .not. halo_filled + end if + + if (fill_halo) then + do ie=nets,nete + call ghostpack(ghostBufQnhc_t1, fld_fvm(:,:,:,1,ie),numlev,0,ie) + end do + call ghost_exchange(hybrid,ghostbufQnhc_t1,location='fvm2dynt1') + do ie=nets,nete + call ghostunpack(ghostbufQnhc_t1, fld_fvm(:,:,:,1,ie),numlev,0,ie) + end do + end if + ! + ! mapping + ! + iwidth=2 + do ie=nets,nete + call tensor_lagrange_interp(fvm(ie)%cubeboundary,np,nc,nhc,numlev,1,fld_fvm(:,:,:,:,ie),& + fld_gll(:,:,:,:,ie),llimiter,iwidth,fvm(ie)%norm_elem_coord) + end do + end subroutine fvm2dynt1 subroutine fill_halo_phys(fld_phys,hybrid,nets,nete,num_lev,num_flds) use dimensions_mod, only: nhc_phys, fv_nphys @@ -330,7 +334,7 @@ end subroutine fill_halo_phys ! must call fill_halo_phys before calling this subroutine ! subroutine phys2dyn(hybrid,elem,fld_phys,fld_gll,nets,nete,num_lev,num_flds,fvm,llimiter,istart_vector,halo_filled) - use dimensions_mod, only: np, nhc_phys, fv_nphys + use dimensions_mod, only: np, nhc_phys, fv_nphys use hybrid_mod, only : hybrid_t type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) integer , intent(in) :: nets,nete,num_flds,num_lev @@ -466,53 +470,59 @@ subroutine dyn2phys_all_vars(nets,nete,elem,fvm,& integer :: k,m_cnst,ie integer :: iret + character(len=len_cx) :: errmsg character(len=*), parameter :: subname = 'dyn2phys_all_vars' !OMP BARRIER OMP MASTER needed if (nc.ne.fv_nphys) then save_max_overlap = 4 !max number of mass overlap areas between phys and fvm grids - allocate(save_air_mass_overlap(save_max_overlap,fv_nphys,fv_nphys,nlev,nets:nete), stat=iret) + allocate(save_air_mass_overlap(save_max_overlap,fv_nphys,fv_nphys,nlev,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'save_air_mass_overlap(save_max_overlap,fv_nphys,fv_nphys,nlev,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(save_q_overlap(save_max_overlap,fv_nphys,fv_nphys,nlev,num_trac,nets:nete), stat=iret) + allocate(save_q_overlap(save_max_overlap,fv_nphys,fv_nphys,nlev,num_trac,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'save_q_overlap(save_max_overlap,fv_nphys,fv_nphys,nlev,num_trac,nets:nete)', & file=__FILE__, line=__LINE__) - allocate(save_q_phys(fv_nphys,fv_nphys,nlev,num_trac,nets:nete), stat=iret) + allocate(save_q_phys(fv_nphys,fv_nphys,nlev,num_trac,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'save_q_phys(fv_nphys,fv_nphys,nlev,num_trac,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(save_dp_phys(fv_nphys,fv_nphys,nlev,nets:nete), stat=iret) + allocate(save_dp_phys(fv_nphys,fv_nphys,nlev,nets:nete), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'save_dp_phys(fv_nphys,fv_nphys,nlev,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(save_overlap_area(save_max_overlap,fv_nphys,fv_nphys,nets:nete), stat=iret) + allocate(save_overlap_area(save_max_overlap,fv_nphys,fv_nphys,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'save_overlap_area(save_max_overlap,fv_nphys,fv_nphys,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(save_num_overlap(fv_nphys,fv_nphys,nlev,nets:nete), stat=iret) + allocate(save_num_overlap(fv_nphys,fv_nphys,nlev,nets:nete), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'save_num_overlap(fv_nphys,fv_nphys,nlev,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) save_num_overlap = 0 - allocate(save_overlap_idx(2,save_max_overlap,fv_nphys,fv_nphys,nets:nete), stat=iret) + allocate(save_overlap_idx(2,save_max_overlap,fv_nphys,fv_nphys,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'save_overlap_idx(2,save_max_overlap,fv_nphys,fv_nphys,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) end if do ie=nets,nete tmp = 1.0_r8 inv_area = 1.0_r8/dyn2phys(tmp,elem(ie)%metdet(:,:)) - phis_phys(:,ie) = RESHAPE(fvm(ie)%phis_physgrid,SHAPE(phis_phys(:,ie))) + phis_phys(:,ie) = RESHAPE(dyn2phys(elem(ie)%state%phis(:,:),elem(ie)%metdet(:,:),inv_area),SHAPE(phis_phys(:,ie))) ps_phys(:,ie) = ptop if (nc.ne.fv_nphys) then tmp = 1.0_r8 @@ -542,7 +552,7 @@ subroutine dyn2phys_all_vars(nets,nete,elem,fvm,& ! no mapping needed - just copy fields into physics structure ! dp3d_phys(:,k,ie) = RESHAPE(fvm(ie)%dp_fvm(1:nc,1:nc,k),SHAPE(dp3d_phys(:,k,ie))) - ps_phys(:,ie) = ps_phys(:,ie)+RESHAPE(fvm(ie)%dp_fvm(1:nc,1:nc,k),SHAPE(ps_phys(:,ie))) + ps_phys(:,ie) = ps_phys(:,ie)+RESHAPE(fvm(ie)%dp_fvm(1:nc,1:nc,k),SHAPE(ps_phys(:,ie))) do m_cnst=1,num_trac q_phys(:,k,m_cnst,ie) = RESHAPE(fvm(ie)%c(1:nc,1:nc,k,m_cnst),SHAPE(q_phys(:,k,m_cnst,ie))) end do @@ -575,7 +585,7 @@ function dyn2fvm(qdp_gll,metdet,inv_dp_darea_phys,q_gll) result(qdp_phys) real (kind=r8), intent(in), optional :: q_gll(np,np) real (kind=r8) :: qdp_phys(nc,nc), min_val, max_val integer :: i,j - + call subcell_integration(qdp_gll(:,:), np, nc, metdet,qdp_phys) if (present(inv_dp_darea_phys)) then ! @@ -655,6 +665,12 @@ function dyn2phys_vector(v_gll,elem) result(v_phys) v_phys(i,2,k)=D(2,1,i)*v1 + D(2,2,i)*v2 end do end do + + ! Cleanup pointer components of interp_p and interpdata + ! to avoid memory leaks every element: + deallocate(interp_p%Imat, interp_p%rk, interp_p%vtemp, interp_p%glp) + deallocate(interpdata%interp_xy, interpdata%ilat, interpdata%ilon) + end function dyn2phys_vector subroutine setup_interpdata_for_gll_to_phys_vec_mapping(interpdata,interp_p) @@ -676,6 +692,7 @@ subroutine setup_interpdata_for_gll_to_phys_vec_mapping(interpdata,interp_p) integer :: iret + character(len=len_cx) :: errmsg character(len=*), parameter :: subname = 'setup_interpdata_for_gll_to_phys_vec_mapping (SE)' ngrid = fv_nphys*fv_nphys @@ -685,17 +702,17 @@ subroutine setup_interpdata_for_gll_to_phys_vec_mapping(interpdata,interp_p) ! gp_quadrature = gausslobatto(np) call interpolate_create(gp_quadrature,interp_p) - allocate(interpdata%interp_xy(ngrid), stat=iret) + allocate(interpdata%interp_xy(ngrid), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'interpdata%interp_xy(ngrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(interpdata%ilat(ngrid), stat=iret) + allocate(interpdata%ilat(ngrid), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'interpdata%ilat(ngrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(interpdata%ilon(ngrid), stat=iret) + allocate(interpdata%ilon(ngrid), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'interpdata%ilon(ngrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! !WARNING: THIS CODE INTERFERES WITH LAT-LON OUTPUT @@ -712,6 +729,10 @@ subroutine setup_interpdata_for_gll_to_phys_vec_mapping(interpdata,interp_p) ioff=ioff+1 enddo enddo + + ! Cleanup pointers allocated by gausslobatto: + deallocate(gp_quadrature%points, gp_quadrature%weights) + end subroutine setup_interpdata_for_gll_to_phys_vec_mapping @@ -1022,27 +1043,32 @@ subroutine phys2fvm(ie,k,fvm,fq_phys,fqdp_fvm,num_trac) real(kind=r8), allocatable, dimension(:,:,:) :: dq_overlap real(kind=r8), allocatable, dimension(:,:,:) :: fq_phys_overlap + character(len=len_cx) :: errmsg character(len=*), parameter :: subname = 'phys2fvm (SE)' - allocate(dq_min_overlap (save_max_overlap,fv_nphys,fv_nphys), stat=iret) + allocate(dq_min_overlap (save_max_overlap,fv_nphys,fv_nphys), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'dq_min_overlap(save_max_overlap,fv_nphys,fv_nphys)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dq_max_overlap (save_max_overlap,fv_nphys,fv_nphys), stat=iret) + allocate(dq_max_overlap (save_max_overlap,fv_nphys,fv_nphys), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'dq_max_overlap(save_max_overlap,fv_nphys,fv_nphys)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dq_overlap (save_max_overlap,fv_nphys,fv_nphys), stat=iret) + allocate(dq_overlap (save_max_overlap,fv_nphys,fv_nphys), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'dq_overlap(save_max_overlap,fv_nphys,fv_nphys)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(fq_phys_overlap (save_max_overlap,fv_nphys,fv_nphys), stat=iret) + allocate(fq_phys_overlap (save_max_overlap,fv_nphys,fv_nphys), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'fq_phys_overlap(save_max_overlap,fv_nphys,fv_nphys)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do m_cnst=1,num_trac fqdp_fvm(:,:,m_cnst) = 0.0_r8 @@ -1057,35 +1083,27 @@ subroutine phys2fvm(ie,k,fvm,fq_phys,fqdp_fvm,num_trac) do jy=1,fv_nphys do jx=1,fv_nphys num = save_num_overlap(jx,jy,k,ie) -#ifdef debug_coupling - save_q_overlap(:,jx,jy,k,m_cnst,ie) = 0.0_r8 - save_q_phys(jx,jy,k,m_cnst,ie) = 0.0_r8 - tmp = save_q_phys(jx,jy,k,m_cnst,ie)+fq_phys(jx,jy,m_cnst) !updated physics grid mixing ratio - phys_cdp_max(jx,jy)= MAX(max_patch,tmp) - phys_cdp_min(jx,jy)= MIN(min_patch,tmp) -#else tmp = save_q_phys(jx,jy,k,m_cnst,ie)+fq_phys(jx,jy,m_cnst) !updated physics grid mixing ratio phys_cdp_max(jx,jy)= MAX(MAX(MAXVAL(save_q_overlap(1:num,jx,jy,k,m_cnst,ie)),max_patch),tmp) phys_cdp_min(jx,jy)= MIN(MIN(MINVAL(save_q_overlap(1:num,jx,jy,k,m_cnst,ie)),min_patch),tmp) -#endif ! ! add high-order fq change when it does not violate monotonicity ! mass_forcing_phys = 0.0_r8 do h=1,num jdx = save_overlap_idx(1,h,jx,jy,ie); jdy = save_overlap_idx(2,h,jx,jy,ie) - q_prev = save_q_overlap(h,jx,jy,k,m_cnst,ie) + q_prev = save_q_overlap(h,jx,jy,k,m_cnst,ie) #ifndef skip_high_order_fq_map save_q_overlap(h,jx,jy,k,m_cnst,ie) = save_q_overlap(h,jx,jy,k,m_cnst,ie)+fq_phys_overlap(h,jx,jy) save_q_overlap(h,jx,jy,k,m_cnst,ie) = MIN(save_q_overlap(h,jx,jy,k,m_cnst,ie),phys_cdp_max(jx,jy)) - save_q_overlap(h,jx,jy,k,m_cnst,ie) = MAX(save_q_overlap(h,jx,jy,k,m_cnst,ie),phys_cdp_min(jx,jy)) + save_q_overlap(h,jx,jy,k,m_cnst,ie) = MAX(save_q_overlap(h,jx,jy,k,m_cnst,ie),phys_cdp_min(jx,jy)) mass_forcing = (save_q_overlap(h,jx,jy,k,m_cnst,ie)-q_prev)*save_air_mass_overlap(h,jx,jy,k,ie) mass_forcing_phys = mass_forcing_phys + mass_forcing fqdp_fvm(jdx,jdy,m_cnst) = fqdp_fvm(jdx,jdy,m_cnst)+mass_forcing #endif ! ! prepare for mass fixing algorithm - ! + ! dq_min_overlap(h,jx,jy) = save_q_overlap(h,jx,jy,k,m_cnst,ie)-phys_cdp_min(jx,jy) dq_max_overlap (h,jx,jy) = save_q_overlap(h,jx,jy,k,m_cnst,ie)-phys_cdp_max(jx,jy) end do @@ -1183,7 +1201,7 @@ subroutine get_fq_overlap(ie,k,fvm,fq_phys,max_overlap,fq_phys_overlap,num_trac) use dp_mapping, only: weights_eul_index_all_fvm2phys use dp_mapping, only: weights_lgr_index_all_phys2fvm, weights_eul_index_all_phys2fvm,jall_phys2fvm use dp_mapping, only: weights_all_phys2fvm - + integer , intent(in) :: ie,k type(fvm_struct) , intent(in) :: fvm integer , intent(in) :: num_trac, max_overlap @@ -1216,7 +1234,7 @@ subroutine get_fq_overlap(ie,k,fvm,fq_phys,max_overlap,fq_phys_overlap,num_trac) end if end do end do - + llimiter_q=.false. call get_physgrid_recons(fvm,fq_phys,recons_q,num_trac,llimiter_q) ! @@ -1236,11 +1254,11 @@ subroutine get_fq_overlap(ie,k,fvm,fq_phys,max_overlap,fq_phys_overlap,num_trac) do m_cnst=1,num_trac fq_phys_overlap(idx,jx,jy,m_cnst) = & (fvm%dp_fvm(jdx,jdy,k)*SUM(weights_all_phys2fvm_local(h,:)*recons_q(:,jx,jy,m_cnst))+& - fq_phys(jx,jy,m_cnst)*dp_tmp)/save_air_mass_overlap(idx,jx,jy,k,ie) + fq_phys(jx,jy,m_cnst)*dp_tmp)/save_air_mass_overlap(idx,jx,jy,k,ie) end do end do end subroutine get_fq_overlap - + subroutine get_physgrid_recons(fvm,field_phys,recons_phys,num_trac,llimiter) use dimensions_mod, only: fv_nphys,nhr_phys,nhc_phys,ns_phys use fvm_reconstruction_mod, only: reconstruction @@ -1335,13 +1353,13 @@ subroutine get_q_overlap_save(ie,k,fvm,q_fvm,num_trac,q_phys) num_overlap(:,:) = 0 q_phys = 0.0_r8 do h=1,jall_fvm2phys(ie) - jx = weights_lgr_index_all_fvm2phys(h,1,ie); jy = weights_lgr_index_all_fvm2phys(h,2,ie) + jx = weights_lgr_index_all_fvm2phys(h,1,ie); jy = weights_lgr_index_all_fvm2phys(h,2,ie) jdx = weights_eul_index_all_fvm2phys(h,1,ie); jdy = weights_eul_index_all_fvm2phys(h,2,ie) num_overlap(jx,jy) = num_overlap(jx,jy)+1 idx = num_overlap(jx,jy) - dp_fvm_tmp = fvm%dp_fvm(jdx,jdy,k) + dp_fvm_tmp = fvm%dp_fvm(jdx,jdy,k) dp_tmp = save_air_mass_overlap(idx,jx,jy,k,ie)-dp_fvm_tmp*weights_all_fvm2phys(h,1,ie) #ifdef PCoM dp_tmp = save_air_mass_overlap(idx,jx,jy,k,ie) @@ -1364,6 +1382,83 @@ subroutine get_q_overlap_save(ie,k,fvm,q_fvm,num_trac,q_phys) save_q_phys(:,:,k,m_cnst,ie) = q_phys(:,:,m_cnst) end do end subroutine get_q_overlap_save - + ! + ! Routine to overwrite thermodynamic active tracers on the GLL grid with CSLAM values + ! by Lagrange interpolation from 3x3 CSLAM grid to GLL grid. + ! + subroutine cslam2gll(elem, fvm, hybrid,nets,nete, tl_f, tl_qdp) + use dimensions_mod, only: nc,nlev,np,nhc + use hybrid_mod, only: hybrid_t + use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx + use fvm_mod, only: ghostBuf_cslam2gll + use bndry_mod, only: ghost_exchange + use edge_mod, only: ghostpack,ghostunpack + use cam_logfile, only: iulog + type (element_t), intent(inout):: elem(:) + type(fvm_struct), intent(inout):: fvm(:) + + type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) + integer, intent(in) :: nets, nete, tl_f, tl_qdp + + integer :: ie,i,j,k,m_cnst,nq,iret + real (kind=r8), dimension(:,:,:,:,:) , allocatable :: fld_fvm, fld_gll + character(len=len_cx) :: errmsg + character(len=*), parameter :: subname = 'cslam2gll' + ! + ! for tensor product Lagrange interpolation + ! + integer :: nflds + logical, allocatable :: llimiter(:) + call t_startf('cslam2gll') + nflds = thermodynamic_active_species_num + + !Allocate variables + !------------------ + allocate(fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,nflds,nets:nete), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,nflds,nets:nete)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + + allocate(fld_gll(np,np,nlev,thermodynamic_active_species_num,nets:nete),stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'fld_gll(np,np,nlev,thermodynamic_active_species_num,nets:nete)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + + allocate(llimiter(nflds), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'llimiter(nflds)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + !------------------ + + llimiter(1:nflds) = .false. + do ie=nets,nete + do m_cnst=1,thermodynamic_active_species_num + do k=1,nlev + fld_fvm(1:nc,1:nc,k,m_cnst,ie) = & + fvm(ie)%c(1:nc,1:nc,k,thermodynamic_active_species_idx(m_cnst)) + end do + end do + end do + call t_startf('fvm:fill_halo_cslam2gll') + do ie=nets,nete + call ghostpack(ghostBuf_cslam2gll, fld_fvm(:,:,:,:,ie),nlev*nflds,0,ie) + end do + call ghost_exchange(hybrid,ghostBuf_cslam2gll,location='cslam2gll') + + do ie=nets,nete + call ghostunpack(ghostBuf_cslam2gll, fld_fvm(:,:,:,:,ie),nlev*nflds,0,ie) + end do + call t_stopf('fvm:fill_halo_cslam2gll') + ! + ! do mapping + ! + call fvm2dyn(fld_fvm,fld_gll,hybrid,nets,nete,nlev,nflds,fvm,llimiter,halo_filled=.true.) + + do ie=nets,nete + do m_cnst=1,thermodynamic_active_species_num + elem(ie)%state%qdp(:,:,:,m_cnst,tl_qdp) = fld_gll(:,:,:,m_cnst,ie)*& + elem(ie)%state%dp3d(:,:,:,tl_f) + end do + end do + deallocate(fld_fvm, fld_gll, llimiter) + call t_stopf('cslam2gll') + end subroutine cslam2gll end module fvm_mapping diff --git a/src/dynamics/se/dycore/fvm_mod.F90 b/src/dynamics/se/dycore/fvm_mod.F90 index 925e5e89e..58a7d3aa7 100644 --- a/src/dynamics/se/dycore/fvm_mod.F90 +++ b/src/dynamics/se/dycore/fvm_mod.F90 @@ -26,6 +26,7 @@ module fvm_mod type (EdgeBuffer_t) :: edgeveloc type (EdgeBuffer_t), public :: ghostBufQnhc_s + type (EdgeBuffer_t), public :: ghostBufQnhc_t1 type (EdgeBuffer_t), public :: ghostBufQnhc_vh type (EdgeBuffer_t), public :: ghostBufQnhc_h type (EdgeBuffer_t), public :: ghostBufQ1_h @@ -35,6 +36,7 @@ module fvm_mod type (EdgeBuffer_t), public :: ghostBufQnhcJet_h type (EdgeBuffer_t), public :: ghostBufFluxJet_h type (EdgeBuffer_t), public :: ghostBufPG_s + type (EdgeBuffer_t), public :: ghostBuf_cslam2gll interface fill_halo_fvm module procedure fill_halo_fvm_noprealloc @@ -58,14 +60,14 @@ subroutine fill_halo_fvm_noprealloc(elem,fvm,hybrid,nets,nete,ndepth,kmin,kmax,k integer,intent(in) :: nets,nete integer,intent(in) :: ndepth ! depth of halo - integer,intent(in) :: kmin,kmax ! min and max vertical level - integer,intent(in) :: ksize ! the total number of vertical + integer,intent(in) :: kmin,kmax ! min and max vertical level + integer,intent(in) :: ksize ! the total number of vertical integer :: ie,i1,i2,kblk,kptr,q ! ! - - if(kmin .ne. 1 .or. kmax .ne. nlev) then + + if(kmin .ne. 1 .or. kmax .ne. nlev) then print *,'WARNING: fill_halo_fvm_noprealloc does not support the passing of non-contigous arrays' print *,'WARNING: incorrect answers are likely' endif @@ -88,7 +90,7 @@ subroutine fill_halo_fvm_noprealloc(elem,fvm,hybrid,nets,nete,ndepth,kmin,kmax,k if(FVM_TIMERS) call t_startf('FVM:Communication') call ghost_exchange(hybrid,cellghostbuf,location='fill_halo_fvm_noprealloc') if(FVM_TIMERS) call t_stopf('FVM:Communication') - !-----------------------------------------------------------------------------------! + !-----------------------------------------------------------------------------------! if(FVM_TIMERS) call t_startf('FVM:Unpack') do ie=nets,nete kptr = kmin-1 @@ -116,15 +118,15 @@ subroutine fill_halo_fvm_prealloc(cellghostbuf,elem,fvm,hybrid,nets,nete,ndepth, integer,intent(in) :: nets,nete integer,intent(in) :: ndepth ! depth of halo - integer,intent(in) :: kmin,kmax ! min and max vertical level - integer,intent(in) :: ksize ! the total number of vertical - logical, optional :: active ! indicates if te current thread is active + integer,intent(in) :: kmin,kmax ! min and max vertical level + integer,intent(in) :: ksize ! the total number of vertical + logical, optional :: active ! indicates if te current thread is active integer :: ie,i1,i2,kblk,q,kptr ! ! logical :: lactive - if(present(active)) then + if(present(active)) then lactive = active else lactive = .true. @@ -134,7 +136,7 @@ subroutine fill_halo_fvm_prealloc(cellghostbuf,elem,fvm,hybrid,nets,nete,ndepth, i2=nc+ndepth kblk = kmax-kmin+1 if(FVM_TIMERS) call t_startf('FVM:pack') - if(lactive) then + if(lactive) then do ie=nets,nete kptr = kmin-1 call ghostpack(cellghostbuf, fvm(ie)%dp_fvm(i1:i2,i1:i2,kmin:kmax),kblk, kptr,ie) @@ -148,9 +150,9 @@ subroutine fill_halo_fvm_prealloc(cellghostbuf,elem,fvm,hybrid,nets,nete,ndepth, if(FVM_TIMERS) call t_startf('FVM:Communication') call ghost_exchange(hybrid,cellghostbuf,location='fill_halo_fvm_prealloc') if(FVM_TIMERS) call t_stopf('FVM:Communication') - !-----------------------------------------------------------------------------------! + !-----------------------------------------------------------------------------------! if(FVM_TIMERS) call t_startf('FVM:Unpack') - if(lactive) then + if(lactive) then do ie=nets,nete kptr = kmin-1 call ghostunpack(cellghostbuf, fvm(ie)%dp_fvm(i1:i2,i1:i2,kmin:kmax),kblk, kptr,ie) @@ -293,7 +295,7 @@ subroutine fill_halo_and_extend_panel(elem,fvm,fld,hybrid,nets,nete,nphys,nhcc, end if end subroutine fill_halo_and_extend_panel - + ! initialize global buffers shared by all threads subroutine fvm_init1(par,elem) use parallel_mod, only: parallel_t @@ -302,28 +304,24 @@ subroutine fvm_init1(par,elem) use control_mod, only: rsplit use dimensions_mod, only: qsize, qsize_d use dimensions_mod, only: fvm_supercycling, fvm_supercycling_jet - use dimensions_mod, only: nc,nhe, nhc, nlev,ntrac, ntrac,ns, nhr + use dimensions_mod, only: nc,nhe, nhc, nlev,ntrac, ntrac,ns, nhr, use_cslam use dimensions_mod, only: large_Courant_incr use dimensions_mod, only: kmin_jet,kmax_jet - + type (parallel_t) :: par type (element_t),intent(inout) :: elem(:) ! - if (ntrac>0) then - if (par%masterproc) then + if (use_cslam) then + if (par%masterproc) then write(iulog,*) " " write(iulog,*) "|-----------------------------------------|" write(iulog,*) "| FVM tracer transport scheme information |" write(iulog,*) "|-----------------------------------------|" write(iulog,*) " " - end if - if (ntrac>0) then - if (par%masterproc) then - write(iulog,*) "Running consistent SE-CSLAM, Lauritzen et al. (2017, MWR)." - write(iulog,*) "CSLAM = Conservative Semi-LAgrangian Multi-tracer scheme" - write(iulog,*) "Lauritzen et al., (2010), J. Comput. Phys." - write(iulog,*) " " - end if + write(iulog,*) "Running consistent SE-CSLAM, Lauritzen et al. (2017, MWR)." + write(iulog,*) "CSLAM = Conservative Semi-LAgrangian Multi-tracer scheme" + write(iulog,*) "Lauritzen et al., (2010), J. Comput. Phys." + write(iulog,*) " " end if ! ! PARAMETER ERROR CHECKING @@ -337,7 +335,7 @@ subroutine fvm_init1(par,elem) write(iulog,*)'with this choice of rsplit =',rsplit write(iulog,*)'rsplit must be a multiple of fvm_supercycling=',fvm_supercycling end if - call endrun("PARAMETER ERROR for fvm: mod(rsplit,fvm_supercycling)<>0") + call endrun("PARAMETER ERROR for fvm: mod(rsplit,fvm_supercycling)<>0") endif if (qsize>0.and.mod(rsplit,fvm_supercycling_jet).ne.0) then @@ -346,15 +344,15 @@ subroutine fvm_init1(par,elem) write(iulog,*)'with this choice of rsplit =',rsplit write(iulog,*)'rsplit must be a multiple of fvm_supercycling_jet=',fvm_supercycling_jet end if - call endrun("PARAMETER ERROR for fvm: mod(rsplit,fvm_supercycling_jet)<>0") + call endrun("PARAMETER ERROR for fvm: mod(rsplit,fvm_supercycling_jet)<>0") endif - + if (large_Courant_incr.and.(fvm_supercycling.ne.fvm_supercycling_jet)) then if (par%masterproc) then write(iulog,*)'Large Courant number increment requires no level dependent supercycling' write(iulog,*)'i.e. fvm_supercycling must be equal to fvm_supercycling_jet' end if - call endrun("PARAMETER ERROR for fvm: large_courant_incr requires fvm_supercycling=fvm_supercycling_jet") + call endrun("PARAMETER ERROR for fvm: large_courant_incr requires fvm_supercycling=fvm_supercycling_jet") endif if (par%masterproc) then @@ -371,7 +369,7 @@ subroutine fvm_init1(par,elem) if (nc.ne.3) then if (par%masterproc) then write(iulog,*) "Only nc==3 is supported for CSLAM" - endif + end if call endrun("PARAMETER ERRROR for fvm: only nc=3 supported for CSLAM") end if @@ -384,7 +382,7 @@ subroutine fvm_init1(par,elem) write(iulog,*) "ns==2: using linear interpolation for mapping cell averages values across edges" write(iulog,*) "Note that ns=4 is default CSLAM setting used in Lauritzen et al. (2010)" write(iulog,*) "so this option is slightly less accurate (but the stencil is smaller near panel edges!)" - + else if (ns==3) then write(iulog,*) "ns==3: using quadratic interpolation for mapping cell averages values across edges" write(iulog,*) "Note that ns=4 is default CSLAM setting used in Lauritzen et al. (2010)" @@ -392,17 +390,17 @@ subroutine fvm_init1(par,elem) else if (ns==4) then write(iulog,*) "ns==4: using cubic interpolation for mapping cell averages values across edges" write(iulog,*) "This is default CSLAM setting used in Lauritzen et al. (2010)" - else + else write(iulog,*) "Not a tested value for ns but it should work! You choose ns = ",ns end if - + ! if (ns.NE.3) then ! write(*,*) "In fvm_reconstruction_mod function matmul_w has been hard-coded for ns=3 for performance" ! write(*,*) "Revert to general code - outcommented above" ! call endrun("stopping") ! end if end if - + if (MOD(ns,2)==0.and.nhr+(nhe-1)+ns/2>nc+nc) then write(iulog,*) "to run this combination of ns and nhr you need to increase nc to ",nhr+ns/2+nhe-1 write(iulog,*) "You choose (ns,nhr,nc,nhe)=",ns,nhr,nc,nhe @@ -413,18 +411,18 @@ subroutine fvm_init1(par,elem) write(iulog,*) "You choose (ns,nhr,nc,nhe)=",ns,nhr,nc,nhe call endrun("stopping") end if - + if (nc==3.and.ns.ne.3) then if (par%masterproc) then write(iulog,*) "Recommended setting for nc=3 is ns=3 (linear interpolation in halo)" write(iulog,*) "You choose ns=",ns write(iulog,*) "Goto dimensions_mod to change value of ns" write(iulog,*) "or outcomment call haltmop below (i.e. you know what you are doing!)" - endif + end if call endrun("stopping") end if end if - + if (nc==4.and.ns.ne.4) then if (par%masterproc) then write(iulog,*) "Recommended setting for nc=4 is ns=4 (cubic interpolation in halo)" @@ -497,6 +495,7 @@ subroutine fvm_init2(elem,fvm,hybrid,nets,nete) ! changes the values for reverse call initghostbuffer(hybrid%par,ghostBufQnhc_s,elem,nlev*(ntrac+1),nhc,nc,nthreads=1) + call initghostbuffer(hybrid%par,ghostBufQnhc_t1,elem,nlev, nhc,nc,nthreads=1) call initghostbuffer(hybrid%par,ghostBufQnhc_h,elem,nlev*(ntrac+1),nhc,nc,nthreads=horz_num_threads) call initghostbuffer(hybrid%par,ghostBufQnhc_vh,elem,nlev*(ntrac+1),nhc,nc,nthreads=vert_num_threads*horz_num_threads) klev = kmax_jet-kmin_jet+1 @@ -504,13 +503,14 @@ subroutine fvm_init2(elem,fvm,hybrid,nets,nete) call initghostbuffer(hybrid%par,ghostBufQ1_vh,elem,klev*(ntrac+1),1,nc,nthreads=vert_num_threads*horz_num_threads) ! call initghostbuffer(hybrid%par,ghostBufFlux_h,elem,4*nlev,nhe,nc,nthreads=horz_num_threads) call initghostbuffer(hybrid%par,ghostBufFlux_vh,elem,4*nlev,nhe,nc,nthreads=vert_num_threads*horz_num_threads) + call initghostbuffer(hybrid%par,ghostBuf_cslam2gll,elem,nlev*thermodynamic_active_species_num,nhc,nc,nthreads=1) ! ! preallocate buffers for physics-dynamics coupling ! if (fv_nphys.ne.nc) then call initghostbuffer(hybrid%par,ghostBufPG_s,elem,nlev*(4+ntrac),nhc_phys,fv_nphys,nthreads=1) else - call initghostbuffer(hybrid%par,ghostBufPG_s,elem,nlev*(3+thermodynamic_active_species_num),nhc_phys,fv_nphys,nthreads=1) + call initghostbuffer(hybrid%par,ghostBufPG_s,elem,nlev*3,nhc_phys,fv_nphys,nthreads=1) end if if (fvm_supercycling.ne.fvm_supercycling_jet) then @@ -527,14 +527,14 @@ end subroutine fvm_init2 subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) use control_mod , only: neast, nwest, seast, swest use fvm_analytic_mod, only: compute_reconstruct_matrix - use dimensions_mod , only: fv_nphys + use dimensions_mod , only: fv_nphys, use_cslam use dimensions_mod, only: nlev, nc, nhe, nlev, ntrac, nhc use coordinate_systems_mod, only: cartesian2D_t,cartesian3D_t use coordinate_systems_mod, only: cubedsphere2cart, cart2cubedsphere implicit none type (element_t) ,intent(inout) :: elem(:) - type (fvm_struct),intent(inout) :: fvm(:) - type (hybrid_t) ,intent(in) :: hybrid + type (fvm_struct),intent(inout) :: fvm(:) + type (hybrid_t) ,intent(in) :: hybrid integer ,intent(in) :: nets,nete,irecons ! type (edgeBuffer_t) :: cellghostbuf @@ -546,7 +546,7 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) type (cartesian2D_t) :: gnom type(cartesian3D_t) :: tmpcart3d - if (ntrac>0.and.nc.ne.fv_nphys) then + if (use_cslam.and.nc.ne.fv_nphys) then ! ! fill the fvm halo for mapping in d_p_coupling if ! physics grid resolution is different than fvm resolution @@ -567,7 +567,7 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) call ghostpack(cellghostbuf, fvm(ie)%norm_elem_coord(1,:,:),1,istart,ie) istart = istart+1 call ghostpack(cellghostbuf, fvm(ie)%norm_elem_coord(2,:,:),1,istart,ie) - istart = istart+1 + istart = istart+1 do ixy=1,2 do ivertex=1,4 call ghostpack(cellghostbuf, fvm(ie)%vtx_cart(ivertex,ixy,:,:) ,1,istart,ie) @@ -586,7 +586,7 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) call ghostunpack(cellghostbuf, fvm(ie)%norm_elem_coord(1,:,:),1,istart,ie) istart = istart+1 call ghostunpack(cellghostbuf, fvm(ie)%norm_elem_coord(2,:,:),1,istart,ie) - istart = istart+1 + istart = istart+1 do ixy=1,2 do ivertex=1,4 call ghostunpack(cellghostbuf, fvm(ie)%vtx_cart(ivertex,ixy,:,:) ,1,istart,ie) @@ -599,9 +599,9 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) call ghostunpack(cellghostbuf, fvm(ie)%spherecentroid(ixy,:,:) ,1,istart,ie) end do enddo - call freeghostbuffer(cellghostbuf) + call freeghostbuffer(cellghostbuf) ! - ! indicator for non-existing cells + ! indicator for non-existing cells ! set vtx_cart to corner value in non-existent cells ! do ie=nets,nete @@ -627,26 +627,26 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) fvm(ie)%vtx_cart(:,2,nc+1 :nc+nhc,1-nhc:0 ) = fvm(ie)%vtx_cart(2,2,nc,1) end if end do - + ! ! set vectors for perpendicular flux vector ! rot90_matrix(1,1) = 0; rot90_matrix(2,1) = 1 !counter-clockwise rotation matrix - rot90_matrix(1,2) =-1; rot90_matrix(2,2) = 0 !counter-clockwise rotation matrix - + rot90_matrix(1,2) =-1; rot90_matrix(2,2) = 0 !counter-clockwise rotation matrix + iside = 1 unit_vec(1,iside) = 0 !x-component of displacement vector for side 1 unit_vec(2,iside) = 1 !y-component of displacement vector for side 1 - + do iside=2,4 unit_vec(:,iside) = MATMUL(rot90_matrix(:,:),unit_vec(:,iside-1)) end do - + ! ! fill halo done ! !------------------------------- - + do ie=nets,nete fvm(ie)%displ_max = 0.0_r8 do j=imin,imax @@ -655,7 +655,7 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) ! rotate gnomonic coordinate vector ! ! fvm(ie)%norm_elem_coord(:,i,j) = MATMUL(fvm(ie)%rot_matrix(:,:,i,j),fvm(ie)%norm_elem_coord(:,i,j)) - ! + ! ishft = NINT(fvm(ie)%flux_orient(2,i,j)) do ixy=1,2 ! @@ -664,10 +664,10 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) fvm(ie)%vtx_cart(1:4,ixy,i,j) = cshift(fvm(ie)%vtx_cart(1:4,ixy,i,j),shift=ishft) fvm(ie)%flux_vec (ixy,i,j,1:4) = cshift(unit_vec (ixy,1:4 ),shift=ishft) ! - ! set flux vector to zero in non-existent cells (corner halo) + ! set flux vector to zero in non-existent cells (corner halo) ! fvm(ie)%flux_vec (ixy,i,j,1:4) = fvm(ie)%ifct(i,j)*fvm(ie)%flux_vec(ixy,i,j,1:4) - + iside=1 fvm(ie)%displ_max(i,j,iside) = fvm(ie)%displ_max(i,j,iside)+& ABS(fvm(ie)%vtx_cart(4,ixy,i,j)-fvm(ie)%vtx_cart(1,ixy,i,j)) @@ -687,7 +687,7 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) ! ! pre-compute derived metric terms used for integration, polynomial ! evaluation at fvm cell vertices, etc. - ! + ! do ie=nets,nete call compute_reconstruct_matrix(nc,nhe,nhc,irecons,fvm(ie)%dalpha,fvm(ie)%dbeta,& fvm(ie)%spherecentroid,fvm(ie)%vtx_cart,fvm(ie)%centroid_stretch,& @@ -695,7 +695,7 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) end do ! ! create a normalized element coordinate system with a halo - ! + ! do ie=nets,nete do j=1-nhc,nc+nhc do i=1-nhc,nc+nhc @@ -731,7 +731,7 @@ subroutine fvm_init3(elem,fvm,hybrid,nets,nete,irecons) end do end subroutine fvm_init3 - + subroutine fvm_pg_init(elem, fvm, hybrid, nets, nete,irecons) use coordinate_systems_mod, only : cartesian2D_t,cartesian3D_t @@ -816,9 +816,9 @@ subroutine fvm_pg_init(elem, fvm, hybrid, nets, nete,irecons) call ghostunpack(cellghostbuf, fvm(ie)%spherecentroid_physgrid(ixy,:,:) ,1,istart,ie) end do enddo - call freeghostbuffer(cellghostbuf) + call freeghostbuffer(cellghostbuf) ! - ! indicator for non-existing cells + ! indicator for non-existing cells ! set vtx_cart to corner value in non-existent cells ! do ie=nets,nete @@ -852,32 +852,32 @@ subroutine fvm_pg_init(elem, fvm, hybrid, nets, nete,irecons) fvm(ie)%vtx_cart_physgrid(2,2,fv_nphys,1) end if end do - + ! ! set vectors for perpendicular flux vector ! rot90_matrix(1,1) = 0; rot90_matrix(2,1) = 1 !counter-clockwise rotation matrix - rot90_matrix(1,2) =-1; rot90_matrix(2,2) = 0 !counter-clockwise rotation matrix - + rot90_matrix(1,2) =-1; rot90_matrix(2,2) = 0 !counter-clockwise rotation matrix + iside = 1 unit_vec(1,iside) = 0 !x-component of displacement vector for side 1 unit_vec(2,iside) = 1 !y-component of displacement vector for side 1 - + do iside=2,4 unit_vec(:,iside) = MATMUL(rot90_matrix(:,:),unit_vec(:,iside-1)) end do - + ! ! fill halo done ! !------------------------------- - + do ie=nets,nete do j=imin,imax do i=imin,imax ! ! rotate gnomonic coordinate vector - ! + ! ishft = NINT(fvm(ie)%flux_orient_physgrid(2,i,j)) do ixy=1,2 ! @@ -891,18 +891,18 @@ subroutine fvm_pg_init(elem, fvm, hybrid, nets, nete,irecons) ! ! pre-compute derived metric terms used for integration, polynomial ! evaluation at fvm cell vertices, etc. - ! + ! do ie=nets,nete call compute_reconstruct_matrix(fv_nphys,nhe_phys,nhc_phys,irecons,fvm(ie)%dalpha_physgrid,fvm(ie)%dbeta_physgrid,& fvm(ie)%spherecentroid_physgrid,fvm(ie)%vtx_cart_physgrid,fvm(ie)%centroid_stretch_physgrid,& fvm(ie)%vertex_recons_weights_physgrid,fvm(ie)%recons_metrics_physgrid,fvm(ie)%recons_metrics_integral_physgrid) - end do + end do ! ! code specific for physgrid ! ! ! create a normalized element coordinate system with a halo - ! + ! do ie=nets,nete do j=1-nhc_phys,fv_nphys+nhc_phys do i=1-nhc_phys,fv_nphys+nhc_phys diff --git a/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 b/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 index b7310ad47..1651423e2 100644 --- a/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 +++ b/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 @@ -79,7 +79,7 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& real (kind=r8), dimension(1-nht:nc+nht,1-nht:nc+nht,3) :: f - integer :: i,j,in,h,itr + integer :: i,j,in,h,itr,k integer, dimension(2,3) :: jx,jy if (present(irecons_actual_in)) then @@ -87,7 +87,6 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& else irecons_actual = irecons end if - jx(1,1)=jx_min(1); jx(2,1)=jx_max(1)-1 jx(1,2)=jx_min(2); jx(2,2)=jx_max(2)-1 @@ -105,7 +104,6 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& if(FVM_TIMERS) call t_startf('FVM:reconstruction:part#1') if (nhe>0) then do itr=1,ntrac_in - ! f=-9e9_r8 call extend_panel_interpolate(nc,nhc,nhr,nht,ns,nh,& fcube(:,:,k_in,itr),cubeboundary,halo_interp_weight,ibase,f(:,:,1),f(:,:,2:3)) call get_gradients(f(:,:,:),jx,jy,irecons,recons(:,:,:,itr),& @@ -113,8 +111,6 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& end do else do itr=1,ntrac_in - ! f=-9e9_r8!to avoid floating point exception for uninitialized variables - ! !in non-existent cells (corners of cube) call extend_panel_interpolate(nc,nhc,nhr,nht,ns,nh,& fcube(:,:,k_in,itr),cubeboundary,halo_interp_weight,ibase,f(:,:,1)) call get_gradients(f(:,:,:),jx,jy,irecons,recons(:,:,:,itr),& @@ -122,42 +118,12 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& end do end if if(FVM_TIMERS) call t_stopf('FVM:reconstruction:part#1') - if(FVM_TIMERS) call t_startf('FVM:reconstruction:part#2') - ! - ! fill in non-existent (in physical space) corner values to simplify - ! logic in limiter code (min/max operation) - ! - do itr=1,ntrac_in - if (llimiter(itr)) then - if (cubeboundary>4) then - select case(cubeboundary) - case (nwest) - do h=1,nhe+1 - fcube(0,nc+h ,k_in,itr) = fcube(1-h,nc ,k_in,itr) - fcube(1-h,nc+1,k_in,itr) = fcube(1 ,nc+h,k_in,itr) - end do - case (swest) - do h=1,nhe+1 - fcube(1-h,0,k_in,itr) = fcube(1,1-h,k_in,itr) - fcube(0,1-h,k_in,itr) = fcube(1-h,1,k_in,itr) - end do - case (seast) - do h=1,nhe+1 - fcube(nc+h,0 ,k_in,itr) = fcube(nc,1-h,k_in,itr) - fcube(nc+1,1-h,k_in,itr) = fcube(nc+h,1,k_in,itr) - end do - case (neast) - do h=1,nhe+1 - fcube(nc+h,nc+1,k_in,itr) = fcube(nc,nc+h,k_in,itr) - fcube(nc+1,nc+h,k_in,itr) = fcube(nc+h,nc,k_in,itr) - end do - end select - end if - call slope_limiter(nhe,nc,nhc,fcube(:,:,k_in,itr),jx,jy,irecons,recons(:,:,:,itr),& - spherecentroid(:,1-nhe:nc+nhe,1-nhe:nc+nhe),& - recons_metrics,vertex_recons_weights,vtx_cart,irecons_actual) - end if - end do + if(FVM_TIMERS) call t_startf('FVM:reconstruction:part#2') + + call slope_limiter(nhe,nc,nhc,fcube,jx,jy,k_in,nlev_in,ntrac_in,irecons,recons,& + spherecentroid(:,1-nhe:nc+nhe,1-nhe:nc+nhe),& + recons_metrics,vertex_recons_weights,vtx_cart,irecons_actual,llimiter,& + cubeboundary) if(FVM_TIMERS) call t_stopf('FVM:reconstruction:part#2') end if if(FVM_TIMERS) call t_startf('FVM:reconstruction:part#3') @@ -188,8 +154,6 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& end do case(6) do itr=1,ntrac_in -! do j=1-nhe,nc+nhe -! do i=1-nhe,nc+nhe do in=1,3 do j=jy(1,in),jy(2,in) do i=jx(1,in),jx(2,in) @@ -334,31 +298,69 @@ subroutine get_gradients(f,jx,jy,irecons,gradient,rot_matrix,centroid_stretch,nc end subroutine get_gradients - subroutine slope_limiter(nhe,nc,nhc,fcube,jx,jy,irecons,recons,spherecentroid,recons_metrics,& - vertex_recons_weights,vtx_cart,irecons_actual) + subroutine slope_limiter(nhe,nc,nhc,fcube,jx,jy,k,nlev,ntrac,irecons,recons,spherecentroid,recons_metrics,& + vertex_recons_weights,vtx_cart,irecons_actual,llimiter,cubeboundary) implicit none - integer , intent(in) :: irecons,nhe,nc,nhc,irecons_actual - real (kind=r8), dimension(1-nhc:, 1-nhc:) , intent(in) :: fcube - real (kind=r8), dimension(irecons,1-nhe:nc+nhe,1-nhe:nc+nhe) , intent(inout):: recons + integer , intent(in) :: irecons_actual,k,nlev,ntrac + integer , intent(in) :: irecons,nhe,nc,nhc + real (kind=r8), dimension(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,ntrac) , intent(inout) :: fcube + real (kind=r8), dimension(irecons,1-nhe:nc+nhe,1-nhe:nc+nhe,ntrac), intent(inout):: recons integer, dimension(2,3) , intent(in) :: jx,jy real (kind=r8), dimension(irecons-1,1-nhe:nc+nhe,1-nhe:nc+nhe) , intent(in) :: spherecentroid real (kind=r8), dimension(3,1-nhe:nc+nhe,1-nhe:nc+nhe) , intent(in) :: recons_metrics real (kind=r8), dimension(4,1:irecons-1,1-nhe:nc+nhe,1-nhe:nc+nhe), intent(in) :: vertex_recons_weights real (kind=r8), dimension(4,2,1-nhc:nc+nhc,1-nhc:nc+nhc) , intent(in) :: vtx_cart + logical, dimension(ntrac) , intent(in) :: llimiter + integer , intent(in) :: cubeboundary real (kind=r8):: minval_patch,maxval_patch real (kind=r8):: phi, min_val, max_val,disc + real (kind=r8):: v1,v2,v3,v4,vx1,vx2,vx3,vx4,vy1,vy2,vy3,vy4,r2,r3,r4,r5,r6,scx,scy,dx,dy,ex1,ex2,f0,val + real (kind=r8):: m1,m2,m3 real (kind=r8):: min_phi real (kind=r8):: extrema(2), xminmax(2),yminmax(2),extrema_value(13) real(kind=r8) :: invtmp ! temporary to pre-compute inverses - integer :: itmp1,itmp2,i,j,in,vertex,n + integer :: itmp1,itmp2,i,j,in,vertex,n,itr,h -! real (kind=r8), dimension(-1:5) :: diff_value real (kind=r8), dimension(-1:1) :: minval_array, maxval_array real (kind=r8), parameter :: threshold = 1.0E-40_r8 - character(len=128) :: errormsg + character(len=128) :: errormsg + integer :: im1,jm1,ip1,jp1 + + ! + ! fill in non-existent (in physical space) corner values to simplify + ! logic in limiter code (min/max operation) + ! + do itr=1,ntrac + if (.not. llimiter(itr)) cycle + if (cubeboundary>4) then + select case(cubeboundary) + case (nwest) + do h=1,nhe+1 + fcube(0,nc+h ,k,itr) = fcube(1-h,nc ,k,itr) + fcube(1-h,nc+1,k,itr) = fcube(1 ,nc+h,k,itr) + end do + case (swest) + do h=1,nhe+1 + fcube(1-h,0,k,itr) = fcube(1,1-h,k,itr) + fcube(0,1-h,k,itr) = fcube(1-h,1,k,itr) + end do + case (seast) + do h=1,nhe+1 + fcube(nc+h,0 ,k,itr) = fcube(nc,1-h,k,itr) + fcube(nc+1,1-h,k,itr) = fcube(nc+h,1,k,itr) + end do + case (neast) + do h=1,nhe+1 + fcube(nc+h,nc+1,k,itr) = fcube(nc,nc+h,k,itr) + fcube(nc+1,nc+h,k,itr) = fcube(nc+h,nc,k,itr) + end do + end select + end if + end do + select case (irecons_actual) ! ! PLM limiter @@ -367,52 +369,51 @@ subroutine slope_limiter(nhe,nc,nhc,fcube,jx,jy,irecons,recons,spherecentroid,re do in=1,3 do j=jy(1,in),jy(2,in) do i=jx(1,in),jx(2,in) - !rck combined min/max and unrolled inner loop - !minval_patch = MINVAL(fcube(i-1:i+1,j-1:j+1)) - !maxval_patch = MAXVAL(fcube(i-1:i+1,j-1:j+1)) - !DIR$ SIMD - do itmp2=-1,+1 - itmp1 = j+itmp2 - minval_array(itmp2) = min(fcube(i-1,itmp1),fcube(i,itmp1),fcube(i+1,itmp1)) - maxval_array(itmp2) = max(fcube(i-1,itmp1),fcube(i,itmp1),fcube(i+1,itmp1)) - enddo - minval_patch = min(minval_array(-1),minval_array(0),minval_array(1)) - maxval_patch = max(maxval_array(-1),maxval_array(0),maxval_array(1)) - - min_phi=1.0_r8 - - ! - ! coordinate bounds (could be pre-computed!) - ! - xminmax(1) = min(vtx_cart(1,1,i,j),vtx_cart(2,1,i,j),vtx_cart(3,1,i,j),vtx_cart(4,1,i,j)) - xminmax(2) = max(vtx_cart(1,1,i,j),vtx_cart(2,1,i,j),vtx_cart(3,1,i,j),vtx_cart(4,1,i,j)) - yminmax(1) = min(vtx_cart(1,2,i,j),vtx_cart(2,2,i,j),vtx_cart(3,2,i,j),vtx_cart(4,2,i,j)) - yminmax(2) = max(vtx_cart(1,2,i,j),vtx_cart(2,2,i,j),vtx_cart(3,2,i,j),vtx_cart(4,2,i,j)) - - !rck restructured loop - !DIR$ SIMD - do vertex=1,4 - call recons_val_cart_plm(fcube(i,j), vtx_cart(vertex,1,i,j), vtx_cart(vertex,2,i,j), spherecentroid(:,i,j), & - recons(1:3,i,j), extrema_value(vertex)) + do itr = 1, ntrac + if (.not. llimiter(itr)) cycle + !rck combined min/max and unrolled inner loop + !minval_patch = MINVAL(fcube(i-1:i+1,j-1:j+1)) + !maxval_patch = MAXVAL(fcube(i-1:i+1,j-1:j+1)) + !DIR$ SIMD + do itmp2=-1,+1 + itmp1 = j+itmp2 + minval_array(itmp2) = min(fcube(i-1,itmp1,k,itr),fcube(i,itmp1,k,itr),fcube(i+1,itmp1,k,itr)) + maxval_array(itmp2) = max(fcube(i-1,itmp1,k,itr),fcube(i,itmp1,k,itr),fcube(i+1,itmp1,k,itr)) + enddo + minval_patch = min(minval_array(-1),minval_array(0),minval_array(1)) + maxval_patch = max(maxval_array(-1),maxval_array(0),maxval_array(1)) + min_phi=1.0_r8 + ! + ! coordinate bounds (could be pre-computed!) + ! + xminmax(1) = min(vtx_cart(1,1,i,j),vtx_cart(2,1,i,j),vtx_cart(3,1,i,j),vtx_cart(4,1,i,j)) + xminmax(2) = max(vtx_cart(1,1,i,j),vtx_cart(2,1,i,j),vtx_cart(3,1,i,j),vtx_cart(4,1,i,j)) + yminmax(1) = min(vtx_cart(1,2,i,j),vtx_cart(2,2,i,j),vtx_cart(3,2,i,j),vtx_cart(4,2,i,j)) + yminmax(2) = max(vtx_cart(1,2,i,j),vtx_cart(2,2,i,j),vtx_cart(3,2,i,j),vtx_cart(4,2,i,j)) + !rck restructured loop + !DIR$ SIMD + do vertex=1,4 + call recons_val_cart_plm(fcube(i,j,k,itr), vtx_cart(vertex,1,i,j), vtx_cart(vertex,2,i,j), spherecentroid(:,i,j), & + recons(1:3,i,j,itr), extrema_value(vertex)) + end do + max_val = MAXVAL(extrema_value(1:4)) + min_val = MINVAL(extrema_value(1:4)) + if (max_val>maxval_patch.and.abs(max_val-fcube(i,j,k,itr))>threshold) then + phi = (maxval_patch-fcube(i,j,k,itr))/(max_val-fcube(i,j,k,itr)) + if (phithreshold) then + phi = (minval_patch-fcube(i,j,k,itr))/(min_val-fcube(i,j,k,itr)) + if (phimaxval_patch.and.abs(max_val-fcube(i,j))>threshold) then - phi = (maxval_patch-fcube(i,j))/(max_val-fcube(i,j)) - if (phithreshold) then - phi = (minval_patch-fcube(i,j))/(min_val-fcube(i,j)) - if (phi threshold) then - extrema(1) = recons(6,i,j) * recons(3,i,j) - 2.0_r8 * recons(5,i,j) * recons(2,i,j) - extrema(2) = recons(6,i,j) * recons(2,i,j) - 2.0_r8 * recons(4,i,j) * recons(3,i,j) - - disc=1.0_r8/disc - extrema(1) = extrema(1) * disc + spherecentroid(1,i,j) - extrema(2) = extrema(2) * disc + spherecentroid(2,i,j) - if ( (extrema(1) - xminmax(1) > -threshold) .and. & !xmin - (extrema(1) - xminmax(2) < threshold) .and. & !xmax - (extrema(2) - yminmax(1) > -threshold) .and. & !ymin - (extrema(2) - yminmax(2) < threshold)) then !ymax - call recons_val_cart(fcube(i,j), extrema(1), extrema(2), spherecentroid(:,i,j), & - recons_metrics(:,i,j), recons(:,i,j), extrema_value(5)) - endif - endif - ! - ! Check all potential minimizer points along element boundaries - ! - if (abs(recons(6,i,j)) > threshold) then - invtmp = 1.0_r8 / (recons(6,i,j) + spherecentroid(2,i,j)) - do n=1,2 - ! Left edge, intercept with du/dx = 0 - extrema(2) = invtmp * (-recons(2,i,j) - 2.0_r8 * recons(4,i,j) * (xminmax(n) - spherecentroid(1,i,j))) - if ((extrema(2) > yminmax(1)-threshold) .and. (extrema(2) < yminmax(2)+threshold)) then - call recons_val_cart(fcube(i,j), xminmax(n), extrema(2), spherecentroid(:,i,j), & - recons_metrics(:,i,j), recons(:,i,j), extrema_value(5+n)) - endif - enddo - ! Top/bottom edge, intercept with du/dy = 0 - invtmp = 1.0_r8 / recons(6,i,j) + spherecentroid(1,i,j) - do n = 1,2 - extrema(1) = invtmp * (-recons(3,i,j) - 2.0_r8 * recons(5,i,j) * (yminmax(n) - spherecentroid(2,i,j))) - if ((extrema(1) > xminmax(1)-threshold) .and. (extrema(1) < xminmax(2)+threshold)) then - call recons_val_cart(fcube(i,j), extrema(1), yminmax(n),spherecentroid(:,i,j), & - recons_metrics(:,i,j), recons(:,i,j), extrema_value(7+n)) - endif - enddo - endif + vx1 = vtx_cart(1,1,i,j); vy1 = vtx_cart(1,2,i,j) + vx2 = vtx_cart(2,1,i,j); vy2 = vtx_cart(2,2,i,j) + vx3 = vtx_cart(3,1,i,j); vy3 = vtx_cart(3,2,i,j) + vx4 = vtx_cart(4,1,i,j); vy4 = vtx_cart(4,2,i,j) + xminmax(1) = min(vx1,vx2,vx3,vx4) + xminmax(2) = max(vx1,vx2,vx3,vx4) + yminmax(1) = min(vy1,vy2,vy3,vy4) + yminmax(2) = max(vy1,vy2,vy3,vy4) + scx = spherecentroid(1,i,j) + scy = spherecentroid(2,i,j) + m1 = recons_metrics(1,i,j) + m2 = recons_metrics(2,i,j) + m3 = recons_metrics(3,i,j) + im1 = i-1; ip1 = i+1 + jm1 = j-1; jp1 = j+1 + do itr = 1, ntrac + if (.not. llimiter(itr)) cycle + !rck combined min/max and unrolled inner loop + !minval_patch = MINVAL(fcube(i-1:i+1,j-1:j+1)) + !maxval_patch = MAXVAL(fcube(i-1:i+1,j-1:j+1)) + minval_patch = min( min( fcube(im1,jm1,k,itr), fcube(i ,jm1,k,itr), fcube(ip1,jm1,k,itr) ), & + min( fcube(im1,j ,k,itr), fcube(i ,j ,k,itr), fcube(ip1,j ,k,itr) ), & + min( fcube(im1,jp1,k,itr), fcube(i ,jp1,k,itr), fcube(ip1,jp1,k,itr) ) ) + maxval_patch = max( max( fcube(im1,jm1,k,itr), fcube(i ,jm1,k,itr), fcube(ip1,jm1,k,itr) ), & + max( fcube(im1,j ,k,itr), fcube(i ,j ,k,itr), fcube(ip1,j ,k,itr) ), & + max( fcube(im1,jp1,k,itr), fcube(i ,jp1,k,itr), fcube(ip1,jp1,k,itr) ) ) + min_phi=1.0_r8 - ! Top/bottom edge, y=const., du/dx=0 - if (abs(recons(4,i,j)) > threshold) then - invtmp = 1.0_r8 / (2.0_r8 * recons(4,i,j))! + spherecentroid(1,i,j) - do n = 1,2 - extrema(1) = spherecentroid(1,i,j)+& - invtmp * (-recons(2,i,j) - recons(6,i,j) * (yminmax(n) - spherecentroid(2,i,j))) - - if ((extrema(1) > xminmax(1)-threshold) .and. (extrema(1) < xminmax(2)+threshold)) then - call recons_val_cart(fcube(i,j), extrema(1), yminmax(n), spherecentroid(:,i,j),& - recons_metrics(:,i,j),recons(:,i,j), extrema_value(9+n)) - endif + f0 = fcube(i,j,k,itr) + min_val = f0; max_val = f0!initialize min/max + ! + ! compute min/max value at cell corners + !DIR$ SIMD + do vertex=1,4 + val = f0 + do itmp1=1,irecons-1 + val = val + recons(itmp1+1,i,j,itr)*vertex_recons_weights(vertex,itmp1,i,j) + enddo + min_val = min(min_val,val) + max_val = max(max_val,val) enddo - endif - ! Left/right edge, x=const., du/dy=0 - if (abs(recons(5,i,j)) > threshold) then - invtmp = 1.0_r8 / (2.0_r8 * recons(5,i,j)) - do n = 1,2 - extrema(2) = spherecentroid(2,i,j)+& - invtmp * (-recons(3,i,j) - recons(6,i,j) * (xminmax(n) - spherecentroid(1,i,j))) - - if ((extrema(2)>yminmax(1)-threshold) .and. (extrema(2) < yminmax(2)+threshold)) then - call recons_val_cart(fcube(i,j), xminmax(n), extrema(2), spherecentroid(:,i,j), & - recons_metrics(:,i,j), recons(:,i,j), extrema_value(11+n)) - endif - enddo - endif - !rck - combined min/max calculation and unrolled - ! max_val = MAXVAL(extrema_value) - ! min_val = MINVAL(extrema_value) - max_val = extrema_value(13) - min_val = extrema_value(13) - do itmp1 = 1,12,4 - max_val = max(max_val, extrema_value(itmp1),extrema_value(itmp1+1),extrema_value(itmp1+2),extrema_value(itmp1+3)) - min_val = min(min_val, extrema_value(itmp1),extrema_value(itmp1+1),extrema_value(itmp1+2),extrema_value(itmp1+3)) - enddo - !rck + r2 = recons(2,i,j,itr); r3 = recons(3,i,j,itr) + r4 = recons(4,i,j,itr); r5 = recons(5,i,j,itr); r6 = recons(6,i,j,itr) + ! Check if the quadratic is minimized within the element + ! Extrema in the interior of the element (there might be just one candidate) + ! DO NOT NEED ABS here, if disc<0 we have a saddle point (no maximum or minimum) + disc = 4.0_r8 * r4 *r5 - r6*r6 + if (abs(disc) > threshold) then + ex1 = (r6*r3 - 2.0_r8*r5*r2) + ex2 = (r6*r2 - 2.0_r8*r4*r3) + disc = 1 /disc + ex1 = ex1*disc+scx + ex2 = ex2*disc+scy + if ( ex1 > xminmax(1)-threshold .and. ex1 < xminmax(2)+threshold .and. & + ex2 > yminmax(1)-threshold .and. ex2 < yminmax(2)+threshold ) then + dx = ex1 - scx; dy = ex2 - scy + v1 = f0 + r2*dx + r3*dy + r4*(m1+dx*dx) + r5*(m2+dy*dy) + r6*(m3+dx*dy) + max_val = max(max_val, v1) + min_val = min(min_val, v1) + end if + endif + ! + ! Check all potential minimizer points along element boundaries + ! - if (max_val>maxval_patch.and.abs(max_val-fcube(i,j))>threshold) then - phi = (maxval_patch-fcube(i,j))/(max_val-fcube(i,j)) - if (phithreshold) then - phi = (minval_patch-fcube(i,j))/(min_val-fcube(i,j)) - if (phi threshold) then + invtmp = 1.0_r8 / (2.0_r8 * r4) + do n = 1,2 + ex1 = scx+invtmp * (-r2 - r6 * (yminmax(n) - scy)) + if ((ex1 > xminmax(1)-threshold) .and. (ex1 < xminmax(2)+threshold)) then + dx = ex1 - scx; dy = yminmax(n) - scy + v1 = f0 + r2*dx + r3*dy + r4*(m1+dx*dx) + r5*(m2+dy*dy) + r6*(m3+dx*dy) + max_val = max(max_val, v1) + min_val = min(min_val, v1) + endif + enddo + endif + ! + ! Left/right edge, x=const., du/dy=0 + ! + if (abs(r5) > threshold) then + invtmp = 1.0_r8 / (2.0_r8 * r5) + do n = 1,2 + ex1 = scy+invtmp * (-r3 - r6 * (xminmax(n) - scx)) + if ((ex1 > yminmax(1)-threshold) .and. (ex1 < yminmax(2)+threshold)) then + dx = xminmax(n) - scx; dy = ex1 - scy + v1 = f0 + r2*dx + r3*dy + r4*(m1+dx*dx) + r5*(m2+dy*dy) + r6*(m3+dx*dy) + max_val = max(max_val, v1) + min_val = min(min_val, v1) + endif + enddo + endif + ! + if (max_val>maxval_patch.and.abs(max_val-fcube(i,j,k,itr))>threshold) then + phi = (maxval_patch-fcube(i,j,k,itr))/(max_val-fcube(i,j,k,itr)) + if (phithreshold) then + phi = (minval_patch-fcube(i,j,k,itr))/(min_val-fcube(i,j,k,itr)) + if (phi100.0_r8) then ! - call automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min_dx,nu_div,2.5_r8 ,'_div') - nu_div_lev(:) = nu_div - nu_lev(:) = nu + ! CAM6 top (~225 Pa) or CAM7 low top + ! + top_032_042km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_032_042km" + else if (ptop>1e-1_r8) then + ! + ! CAM7 top (~4.35e-1 Pa) + ! + top_042_090km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_042_090km" + else if (ptop>1E-4_r8) then + ! + ! WACCM top (~4.5e-4 Pa) + ! + top_090_140km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_090_140km" else ! - ! WACCM setting + ! WACCM-X - geospace (~4e-7 Pa) ! - call automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min_dx,nu_div,2.5_r8 ,'_div') - if (hybrid%masterthread) write(iulog,*) ": sponge layer viscosity scaling factor" + top_140_600km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_140_600km" + end if + ! + ! Logging text for sponge layer configuration + ! + if (hybrid%masterthread .and. (nu_set .or. div_set .or. lev_set)) then + write(iulog,* )"" + write(iulog,* )"Sponge layer del4 coefficient defaults based on model top location:" + end if + ! + ! if user or namelist is not specifying sponge del4 settings here are best guesses (empirically determined) + ! + if (top_042_090km) then + if (sponge_del4_lev <0) sponge_del4_lev = 4 + if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 3.375_r8 !max value without having to increase subcycling of div4 + if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 3.375_r8 !max value without having to increase subcycling of div4 + else if (top_090_140km.or.top_140_600km) then ! defaults for waccm(x) + if (sponge_del4_lev <0) sponge_del4_lev = 20 + if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 5.0_r8 + if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 10.0_r8 + else + if (sponge_del4_lev <0) sponge_del4_lev = 1 + if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 1.0_r8 + if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 1.0_r8 + end if + + ! set max wind speed for diagnostics + umax = 120.0_r8 + if (top_042_090km) then + umax = 240._r8 + else if (top_090_140km) then + umax = 300._r8 + else if (top_140_600km) then + umax = 800._r8 + end if + ! + ! Log sponge layer configuration + ! + if (hybrid%masterthread) then + if (nu_set) then + write(iulog, '(a,e9.2)') ' sponge_del4_nu_fac = ',sponge_del4_nu_fac + end if + + if (div_set) then + write(iulog, '(a,e9.2)') ' sponge_del4_nu_div_fac = ',sponge_del4_nu_div_fac + end if + + if (lev_set) then + write(iulog, '(a,i0)') ' sponge_del4_lev = ',sponge_del4_lev + end if + write(iulog,* )"" + end if + + nu_max = sponge_del4_nu_fac*nu_p + nu_div_max = sponge_del4_nu_div_fac*nu_p + do k=1,nlev + ! Vertical profile from FV dycore (see Lauritzen et al. 2012 DOI:10.1177/1094342011410088) + scale1 = 0.5_r8*(1.0_r8+tanh(2.0_r8*log(pmid(sponge_del4_lev)/pmid(k)))) + if (sponge_del4_nu_div_fac /= 1.0_r8) then + nu_div_lev(k) = (1.0_r8-scale1)*nu_div+scale1*nu_div_max + end if + if (sponge_del4_nu_fac /= 1.0_r8) then + nu_lev(k) = (1.0_r8-scale1)*nu +scale1*nu_max + nu_t_lev(k) = (1.0_r8-scale1)*nu_p +scale1*nu_max + end if + end do + + if (hybrid%masterthread)then + write(iulog,*) "z computed from barometric formula (using US std atmosphere)" + call std_atm_height(pmid(:),z(:)) + write(iulog,*) "k,pmid_ref,z,nu_lev,nu_t_lev,nu_div_lev" do k=1,nlev - press = pmid(k) - - scale1 = 0.5_r8*(1.0_r8+tanh(2.0_r8*log(100.0_r8/press))) - nu_div_lev(k) = (1.0_r8-scale1)*nu_div+scale1*2.0_r8*nu_div - nu_div_lev(k) = nu_div - nu_lev(k) = (1.0_r8-scale1)*nu +scale1*nu_p - nu_lev(k) = nu - if (hybrid%masterthread) write(iulog,*) "nu_lev=",k,nu_lev(k) - if (hybrid%masterthread) write(iulog,*) "nu_div_lev=",k,nu_div_lev(k) + write(iulog,'(i3,5e11.4)') k,pmid(k),z(k),nu_lev(k),nu_t_lev(k),nu_div_lev(k) end do - end if + if (nu_top>0) then + write(iulog,*) ": ksponge_end = ",ksponge_end + write(iulog,*) ": sponge layer Laplacian damping" + write(iulog,*) "k, p, z, nu_scale_top, nu (actual Laplacian damping coefficient)" - if (nu_q<0) nu_q = nu_p ! necessary for consistency - if (nu_s<0) nu_s = nu_p ! temperature damping is always equal to nu_p + do k=1,ksponge_end + write(iulog,'(i3,4e11.4)') k,pmid(k),z(k),nu_scale_top(k),nu_scale_top(k)*nu_top + end do + end if + end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -600,40 +710,31 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& write(iulog,'(a,f12.8,a)') 'Model top is ',ptop,'Pa' write(iulog,'(a)') ' ' write(iulog,'(a)') 'Timestepping methods used in dynamical core:' - write(iulog,'(a)') + write(iulog,'(a)') write(iulog,*) rk_str write(iulog,'(a)') ' * Spectral-element advection uses SSP preservation RK3' write(iulog,'(a)') ' * Viscosity operators use forward Euler' - if (ntrac>0) then - write(iulog,'(a)') ' * CSLAM uses two time-levels backward trajectory method' - end if end if S_laplacian = 2.0_r8 !using forward Euler for sponge diffusion S_hypervis = 2.0_r8 !using forward Euler for hyperviscosity S_rk_tracer = 2.0_r8 - ! - ! estimate max winds - ! - if (ptop>100.0_r8) then - umax = 120.0_r8 - else - umax = 400.0_r8 - end if + ugw = 342.0_r8 !max gravity wave speed dt_max_adv = S_rk/(umax*max_normDinv*lambda_max*ra) dt_max_gw = S_rk/(ugw*max_normDinv*lambda_max*ra) dt_max_tracer_se = S_rk_tracer*min_gw/(umax*max_normDinv*ra) - if (ntrac>0) then + if (use_cslam) then if (large_Courant_incr) then - dt_max_tracer_fvm = real(nhe, r8)*(4.0_r8*pi*real(Rearth, r8)/real(4.0_r8*ne*nc, r8))/umax + dt_max_tracer_fvm = real(nhe, r8)*(4.0_r8*pi*Rearth/real(4.0_r8*ne*nc, r8))/umax else - dt_max_tracer_fvm = real(nhe, r8)*(2.0_r8*pi*real(Rearth, r8)/real(4.0_r8*ne*nc, r8))/umax + dt_max_tracer_fvm = real(nhe, r8)*(2.0_r8*pi*Rearth/real(4.0_r8*ne*nc, r8))/umax end if else dt_max_tracer_fvm = -1.0_r8 end if - dt_max_hypervis = s_hypervis/(MAX(MAXVAL(nu_div_lev(:)),MAXVAL(nu_lev(:)))*normDinv_hypervis) + nu_max = MAX(MAXVAL(nu_div_lev(:)),MAXVAL(nu_lev(:)),MAXVAL(nu_t_lev(:))) + dt_max_hypervis = s_hypervis/(nu_max*normDinv_hypervis) dt_max_hypervis_tracer = s_hypervis/(nu_q*normDinv_hypervis) max_laplace = MAX(MAXVAL(nu_scale_top(:))*nu_top,MAXVAL(kmvis_ref(:)/rho_ref(:))) @@ -653,14 +754,15 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_dyn_vis (hyperviscosity) ; u,v,T,dM) < ',dt_max_hypervis,& 's ',dt_dyn_visco_actual,'s' if (dt_dyn_visco_actual>dt_max_hypervis) write(iulog,*) 'WARNING: dt_dyn_vis theoretically unstable' - write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_se (time-stepping tracers ; q ) < ',dt_max_tracer_se,'s ',& + if (.not.use_cslam) then + write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_se (time-stepping tracers ; q ) < ',dt_max_tracer_se,'s ',& dt_tracer_se_actual,'s' - if (dt_tracer_se_actual>dt_max_tracer_se) write(iulog,*) 'WARNING: dt_tracer_se theoretically unstable' - write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_vis (hyperviscosity tracers; q ) < ',dt_max_hypervis_tracer,'s',& - dt_tracer_visco_actual,'s' - if (dt_tracer_visco_actual>dt_max_hypervis_tracer) write(iulog,*) 'WARNING: dt_tracer_hypervis theoretically unstable' - - if (ntrac>0) then + if (dt_tracer_se_actual>dt_max_tracer_se) write(iulog,*) 'WARNING: dt_tracer_se theoretically unstable' + write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_vis (hyperviscosity tracers; q ) < ',dt_max_hypervis_tracer,'s',& + dt_tracer_visco_actual,'s' + if (dt_tracer_visco_actual>dt_max_hypervis_tracer) write(iulog,*) 'WARNING: dt_tracer_hypervis theoretically unstable' + end if + if (use_cslam) then write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_fvm (time-stepping tracers ; q ) < ',dt_max_tracer_fvm,& 's ',dt_tracer_fvm_actual if (dt_tracer_fvm_actual>dt_max_tracer_fvm) write(iulog,*) 'WARNING: dt_tracer_fvm theortically unstable' @@ -673,8 +775,14 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& write(iulog,'(a,f10.2,a,f10.2,a)') '* dt (del2 sponge ; u,v,T,dM) < ',& dt_max_laplacian_top,'s',dt_dyn_del2_actual,'s' - if (dt_dyn_del2_actual>dt_max_laplacian_top) & - write(iulog,*) 'WARNING: theoretically unstable in sponge; increase se_hypervis_subcycle_sponge' + if (dt_dyn_del2_actual>dt_max_laplacian_top) then + if (k==1) then + write(iulog,*) 'WARNING: theoretically unstable in sponge; increase se_hypervis_subcycle_sponge',& + ' (this WARNING can sometimes be ignored in level 1)' + else + write(iulog,*) 'WARNING: theoretically unstable in sponge; increase se_hypervis_subcycle_sponge' + end if + end if end do write(iulog,*) ' ' if (hypervis_power /= 0) then @@ -1050,7 +1158,7 @@ subroutine wrap_repro_sum (nvars, comm, nsize) nsize_use = nsize else nsize_use = nelemd - endif + end if if (nvars .gt. nrepro_vars) call endrun('ERROR: repro_sum_buffer_size exceeded') ! Repro_sum contains its own OpenMP, so only one thread should call it (AAM) @@ -1104,7 +1212,9 @@ subroutine automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min if (nu < 0) then if (ne <= 0) then - if (hypervis_scaling/=0) then + if (hypervis_power/=0) then + call endrun('ERROR: Automatic scaling of scalar viscosity not implemented') + else if (hypervis_scaling/=0) then nu_min = factor*nu_fac*(max_min_dx*1000.0_r8)**uniform_res_hypervis_scaling nu_max = factor*nu_fac*(min_min_dx*1000.0_r8)**uniform_res_hypervis_scaling nu = factor*nu_min @@ -1113,11 +1223,9 @@ subroutine automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min write(iulog,'(a,2e9.2,a,2f9.2)') "Value at min/max grid spacing: ",nu_min,nu_max,& " Max/min grid spacing (km) = ",max_min_dx,min_min_dx end if - nu = nu_min*(2.0_r8*rearth/(3.0_r8*max_min_dx*1000.0_r8))**hypervis_scaling/(rearth**4._r8) + nu = nu_min*(2.0_r8*rearth/(3.0_r8*max_min_dx*1000.0_r8))**hypervis_scaling/(rearth**4) if (hybrid%masterthread) & write(iulog,'(a,a,a,e9.3)') "Nu_tensor",TRIM(str)," = ",nu - else if (hypervis_power/=0) then - call endrun('ERROR: Automatic scaling of scalar viscosity not implemented') end if else nu = factor*nu_fac*((30.0_r8/ne)*110000.0_r8)**uniform_res_hypervis_scaling diff --git a/src/dynamics/se/dycore/hybrid_mod.F90 b/src/dynamics/se/dycore/hybrid_mod.F90 index f167435aa..46c5a76fe 100644 --- a/src/dynamics/se/dycore/hybrid_mod.F90 +++ b/src/dynamics/se/dycore/hybrid_mod.F90 @@ -7,7 +7,7 @@ module hybrid_mod use parallel_mod , only : parallel_t, copy_par use thread_mod , only : omp_set_num_threads, omp_get_thread_num use thread_mod , only : horz_num_threads, vert_num_threads, tracer_num_threads -use dimensions_mod, only : nlev, qsize, ntrac +use dimensions_mod, only : nlev, qsize, ntrac, use_cslam implicit none private @@ -268,7 +268,7 @@ subroutine init_loop_ranges(nelemd) work_pool_trac(ith+1,2) = end_index end do - if(ntrac>0 .and. ntrac0) then + if ((cubed_sphere_map /= 0) .AND. use_cslam) then if (par%masterproc) then write(iulog, *) subname, 'fvm transport and require equi-angle gnomonic cube sphere mapping.' write(iulog, *) ' Set cubed_sphere_map = 0 or comment it out all together. ' diff --git a/src/dynamics/se/dycore/prim_advance_mod.F90 b/src/dynamics/se/dycore/prim_advance_mod.F90 index cf88d7f96..4602d8d31 100644 --- a/src/dynamics/se/dycore/prim_advance_mod.F90 +++ b/src/dynamics/se/dycore/prim_advance_mod.F90 @@ -8,9 +8,8 @@ module prim_advance_mod implicit none private - save - public :: prim_advance_exp, prim_advance_init, applyCAMforcing, calc_tot_energy_dynamics, compute_omega + public :: prim_advance_exp, prim_advance_init, applyCAMforcing, tot_energy_dyn, compute_omega type (EdgeBuffer_t) :: edge3,edgeOmega,edgeSponge real (kind=r8), allocatable :: ur_weights(:) @@ -31,7 +30,9 @@ subroutine prim_advance_init(par, elem) character(len=*), parameter :: subname = 'prim_advance_init (SE)' call initEdgeBuffer(par,edge3 ,elem,4*nlev ,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) - call initEdgeBuffer(par,edgeSponge,elem,4*ksponge_end,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) + if (ksponge_end>0) then + call initEdgeBuffer(par,edgeSponge,elem,4*ksponge_end,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) + end if call initEdgeBuffer(par,edgeOmega ,elem,nlev ,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) if(.not. allocated(ur_weights)) then @@ -45,12 +46,12 @@ subroutine prim_advance_init(par, elem) ur_weights(1)=1.0_r8/qsplit do i=3,qsplit,2 ur_weights(i)=2.0_r8/qsplit - enddo + end do else do i=2,qsplit,2 ur_weights(i)=2.0_r8/qsplit - enddo - endif + end do + end if end subroutine prim_advance_init subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, nete) @@ -67,15 +68,13 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net use element_mod, only: element_t use hybvcoord_mod, only: hvcoord_t use hybrid_mod, only: hybrid_t - use time_mod, only: TimeLevel_t, timelevel_qdp, tevolve - use dimensions_mod, only: lcp_moist + use se_dyn_time_mod, only: TimeLevel_t, timelevel_qdp, tevolve use fvm_control_volume_mod, only: fvm_struct - use control_mod, only: raytau0 implicit none type (element_t), intent(inout), target :: elem(:) - type(fvm_struct) , intent(in) :: fvm(:) + type(fvm_struct) , intent(inout) :: fvm(:) type (derivative_t) , intent(in) :: deriv type (hvcoord_t) :: hvcoord type (hybrid_t) , intent(in) :: hybrid @@ -86,14 +85,12 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net ! Local real (kind=r8) :: dt_vis, eta_ave_w - real (kind=r8) :: dp(np,np) integer :: ie,nm1,n0,np1,k,qn0,m_cnst, nq + real (kind=r8) :: inv_cp_full(np,np,nlev,nets:nete) real (kind=r8) :: qwater(np,np,nlev,thermodynamic_active_species_num,nets:nete) integer :: qidx(thermodynamic_active_species_num) real (kind=r8) :: kappa(np,np,nlev,nets:nete) - real (kind=r8) :: inv_cp_full(np,np,nlev,nets:nete) - call t_startf('prim_advance_exp') nm1 = tl%nm1 n0 = tl%n0 @@ -120,9 +117,6 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net ! (K&G 2nd order method has CFL=4. tiny CFL improvement not worth 2nd order) ! - if (dry_air_species_num > 0) & - call endrun('ERROR: SE dycore not ready for species dependent thermodynamics - ABORT') - call omp_set_nested(.true.) ! default weights for computing mean dynamics fluxes @@ -140,30 +134,23 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net ! ! make sure Q is updated ! - qwater(:,:,:,nq,ie) = elem(ie)%state%Qdp(:,:,:,m_cnst,qn0)/elem(ie)%state%dp3d(:,:,:,n0) + qwater(:,:,:,nq,ie) = elem(ie)%state%Qdp(:,:,:,m_cnst,qn0)/elem(ie)%state%dp3d(:,:,:,n0) end do end do ! ! compute Cp and kappa=Rdry/cpdry here and not in RK-stages since Q stays constant => Cp and kappa also stays constant ! - if (lcp_moist) then - do ie=nets,nete - call get_cp(qwater(:,:,:,:,ie), & - .true.,inv_cp_full(:,:,:,ie),active_species_idx_dycore=qidx) - end do - else - do ie=nets,nete - inv_cp_full(:,:,:,ie) = 1.0_r8/cpair - end do - end if do ie=nets,nete - call get_kappa_dry(qwater(:,:,:,:,ie),qidx,kappa(:,:,:,ie)) + call get_cp(qwater(:,:,:,:,ie),.true.,& + inv_cp_full(:,:,:,ie), active_species_idx_dycore=qidx) + end do + do ie=nets,nete + call get_kappa_dry(qwater(:,:,:,:,ie), qidx, kappa(:,:,:,ie)) end do dt_vis = dt - if (raytau0>0) call rayleigh_friction(elem,n0,nets,nete,dt) if (tstep_type==1) then ! RK2-SSP 3 stage. matches tracer scheme. optimal SSP CFL, but ! not optimal for regular CFL @@ -191,7 +178,7 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net + 2*elem(ie)%state%T(:,:,:,np1)/3 elem(ie)%state%dp3d(:,:,:,np1)= elem(ie)%state%dp3d(:,:,:,n0)/3 & + 2*elem(ie)%state%dp3d(:,:,:,np1)/3 - enddo + end do else if (tstep_type==2) then ! classic RK3 CFL=sqrt(3) ! u1 = u0 + dt/3 RHS(u0) @@ -270,7 +257,7 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net - elem(ie)%state%T(:,:,:,n0) )/4 elem(ie)%state%dp3d(:,:,:,nm1)= (5*elem(ie)%state%dp3d(:,:,:,nm1) & - elem(ie)%state%dp3d(:,:,:,n0) )/4 - enddo + end do ! u5 = (5*u1/4 - u0/4) + 3dt/4 RHS(u4) ! ! phl: rhs: t=t+2*dt/5+dt/3+3*dt/4 -wrong RK times ... @@ -283,7 +270,7 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net ! u5 = u0 + dt/4 RHS(u0)) + 3dt/4 RHS(u4) else call endrun('ERROR: bad choice of tstep_type') - endif + end if ! ============================================== ! Time-split Horizontal diffusion: nu.del^2 or nu.del^4 @@ -318,7 +305,7 @@ end subroutine prim_advance_exp subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsubstep) - use dimensions_mod, only: np, nc, nlev, qsize, ntrac + use dimensions_mod, only: np, nc, nlev, qsize, ntrac, use_cslam use element_mod, only: element_t use control_mod, only: ftype, ftype_conserve use fvm_control_volume_mod, only: fvm_struct @@ -341,7 +328,8 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu character(len=*), parameter :: subname = 'applyCAMforcing (SE)' - if (ntrac>0) then + call t_startf('applyCAMforc') + if (use_cslam) then allocate(ftmp_fvm(nc,nc,nlev,ntrac,nets:nete), stat=iret) call check_allocate(iret, subname, 'ftmp_fvm(nc,nc,nlev,ntrac,nets:nete)', & file=__FILE__, line=__LINE__) @@ -377,7 +365,7 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu ! do state-update for tracers and "dribbling" forcing for u,v,T ! dt_local = dt_dribble - if (ntrac>0) then + if (use_cslam) then dt_local_tracer = dt_dribble dt_local_tracer_fvm = dt_phys if (nsubstep.ne.1) then @@ -397,7 +385,7 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu ! ! tracers ! - if (qsize>0.and.dt_local_tracer>0) then + if (.not.use_cslam.and.dt_local_tracer>0) then #if (defined COLUMN_OPENMP) !$omp parallel do num_threads(tracer_num_threads) private(q,k,i,j,v1) #endif @@ -414,19 +402,19 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu v1=0 ! Q already negative, dont make it more so else v1 = -elem(ie)%state%Qdp(i,j,k,q,np1_qdp) - endif - endif + end if + end if elem(ie)%state%Qdp(i,j,k,q,np1_qdp) = elem(ie)%state%Qdp(i,j,k,q,np1_qdp)+v1 ftmp(i,j,k,q,ie) = dt_local_tracer*& elem(ie)%derived%FQ(i,j,k,q)-v1 !Only used for diagnostics! - enddo - enddo - enddo - enddo + end do + end do + end do + end do else ftmp(:,:,:,:,ie) = 0.0_r8 end if - if (ntrac>0.and.dt_local_tracer_fvm>0) then + if (use_cslam.and.dt_local_tracer_fvm>0) then ! ! Repeat for the fvm tracers: fc holds tendency (fc_new-fc_old)/dt_physics ! @@ -450,13 +438,12 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu end do end do else - if (ntrac>0) ftmp_fvm(:,:,:,:,ie) = 0.0_r8 + if (use_cslam) ftmp_fvm(:,:,:,:,ie) = 0.0_r8 end if - - if (ftype_conserve==1) then - call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,np1_qdp),MASS_MIXING_RATIO, & - thermodynamic_active_species_idx_dycore,elem(ie)%state%dp3d(:,:,:,np1),pdel) + if (ftype_conserve==1.and..not.use_cslam) then + call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,np1_qdp), MASS_MIXING_RATIO, & + thermodynamic_active_species_idx_dycore, elem(ie)%state%dp3d(:,:,:,np1), pdel) do k=1,nlev do j=1,np do i = 1,np @@ -481,34 +468,33 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu dt_local*elem(ie)%derived%FM(:,:,:,:) end if end do - if (ntrac>0) then + if (use_cslam) then call output_qdp_var_dynamics(ftmp_fvm(:,:,:,:,:),nc,ntrac,nets,nete,'PDC') else call output_qdp_var_dynamics(ftmp(:,:,:,:,:),np,qsize,nets,nete,'PDC') end if - if (ftype==1.and.nsubstep==1) call calc_tot_energy_dynamics(elem,fvm,nets,nete,np1,np1_qdp,'p2d') - if (ntrac>0) deallocate(ftmp_fvm) + if (ftype==1.and.nsubstep==1) call tot_energy_dyn(elem,fvm,nets,nete,np1,np1_qdp,'p2d') + if (use_cslam) deallocate(ftmp_fvm) + call t_stopf('applyCAMforc') end subroutine applyCAMforcing - subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2,eta_ave_w,inv_cp_full,hvcoord) ! ! take one timestep of: ! u(:,:,:,np) = u(:,:,:,np) + dt2*nu*laplacian**order ( u ) - ! T(:,:,:,np) = T(:,:,:,np) + dt2*nu_s*laplacian**order ( T ) + ! T(:,:,:,np) = T(:,:,:,np) + dt2*nu_t*laplacian**order ( T ) ! ! ! For correct scaling, dt2 should be the same 'dt2' used in the leapfrog advace ! ! - use dynconst, only: gravit, cappa, cpair, tref, lapse_rate - use dyn_thermo, only: get_dp_ref - use dimensions_mod, only: np, nlev, nc, ntrac, npsq, qsize - use dimensions_mod, only: hypervis_dynamic_ref_state,ksponge_end + use physconst, only: cappa, cpair + use cam_thermo, only: get_molecular_diff_coef, get_rho_dry + use dimensions_mod, only: np, nlev, nc, use_cslam, npsq, qsize, ksponge_end use dimensions_mod, only: nu_scale_top,nu_lev,kmvis_ref,kmcnd_ref,rho_ref,km_sponge_factor - use dimensions_mod, only: kmvisi_ref,kmcndi_ref,rhoi_ref - use control_mod, only: nu, nu_s, hypervis_subcycle,hypervis_subcycle_sponge, nu_p, nu_top - use control_mod, only: molecular_diff + use dimensions_mod, only: nu_t_lev + use control_mod, only: nu, nu_t, hypervis_subcycle,hypervis_subcycle_sponge, nu_p, nu_top + use control_mod, only: molecular_diff,sponge_del4_lev use hybrid_mod, only: hybrid_t!, get_loop_ranges use element_mod, only: element_t use derivative_mod, only: derivative_t, laplace_sphere_wk, vlaplace_sphere_wk, vlaplace_sphere_wk_mol @@ -519,14 +505,12 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, use viscosity_mod, only: biharmonic_wk_dp3d use hybvcoord_mod, only: hvcoord_t use fvm_control_volume_mod, only: fvm_struct - use air_composition, only: thermodynamic_active_species_idx_dycore - use dyn_thermo, only: get_molecular_diff_coef,get_rho_dry -!Un-comment once history output has been resolved in CAMDEN -JN: -! use cam_history, only: outfld, hist_fld_active + use air_composition, only: thermodynamic_active_species_idx_dycore + use cam_history, only: history_out_field, is_history_field_active type (hybrid_t) , intent(in) :: hybrid type (element_t) , intent(inout), target :: elem(:) - type(fvm_struct) , intent(in) :: fvm(:) + type(fvm_struct) , intent(inout) :: fvm(:) type (EdgeBuffer_t), intent(inout):: edge3 type (derivative_t), intent(in ) :: deriv integer , intent(in) :: nets,nete, nt, qn0 @@ -539,8 +523,6 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, integer :: kbeg, kend, kblk real (kind=r8), dimension(np,np,2,nlev,nets:nete) :: vtens real (kind=r8), dimension(np,np,nlev,nets:nete) :: ttens, dptens - real (kind=r8), dimension(np,np,nlev,nets:nete) :: dp3d_ref, T_ref - real (kind=r8), dimension(np,np,nets:nete) :: ps_ref real (kind=r8), dimension(0:np+1,0:np+1,nlev) :: corners real (kind=r8), dimension(2,2,2) :: cflux real (kind=r8) :: temp (np,np,nlev) @@ -549,60 +531,19 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, type (EdgeDescriptor_t) :: desc real (kind=r8), dimension(np,np) :: lap_t,lap_dp - real (kind=r8), dimension(np,np) :: tmp, tmp2 real (kind=r8), dimension(np,np,ksponge_end,nets:nete):: kmvis,kmcnd,rho_dry - real (kind=r8), dimension(np,np,ksponge_end+1):: kmvisi,kmcndi - real (kind=r8), dimension(np,np,ksponge_end+1):: pint,rhoi_dry - real (kind=r8), dimension(np,np,ksponge_end ):: pmid real (kind=r8), dimension(np,np,nlev) :: tmp_kmvis,tmp_kmcnd real (kind=r8), dimension(np,np,2) :: lap_v - real (kind=r8) :: v1,v2,v1new,v2new,dt,heating,T0,T1 + real (kind=r8) :: v1,v2,v1new,v2new,dt,heating real (kind=r8) :: laplace_fluxes(nc,nc,4) real (kind=r8) :: rhypervis_subcycle real (kind=r8) :: nu_ratio1, ptop, inv_rho - real (kind=r8), dimension(ksponge_end) :: dtemp,du,dv real (kind=r8) :: nu_temp, nu_dp, nu_velo - if (nu_s == 0 .and. nu == 0 .and. nu_p==0 ) return; + if (nu_t == 0 .and. nu == 0 .and. nu_p==0 ) return; ptop = hvcoord%hyai(1)*hvcoord%ps0 - if (hypervis_dynamic_ref_state) then - ! - ! use dynamic reference pressure (P. Callaghan) - ! - call calc_dp3d_reference(elem,edge3,hybrid,nets,nete,nt,hvcoord,dp3d_ref) - do ie=nets,nete - ps_ref(:,:,ie) = ptop + sum(elem(ie)%state%dp3d(:,:,:,nt),3) - end do - else - ! - ! use static reference pressure (hydrostatic balance incl. effect of topography) - ! - do ie=nets,nete - call get_dp_ref(hvcoord%hyai, hvcoord%hybi, hvcoord%ps0,& - elem(ie)%state%phis(:,:),dp3d_ref(:,:,:,ie),ps_ref(:,:,ie)) - end do - endif - ! - ! reference temperature profile (Simmons and Jiabin, 1991, QJRMS, Section 2a) - ! - ! Tref = T0+T1*Exner - ! T1 = .0065*Tref*Cp/g ! = ~191 - ! T0 = Tref-T1 ! = ~97 - ! - T1 = lapse_rate*Tref*cpair/gravit - T0 = Tref-T1 - do ie=nets,nete - do k=1,nlev - dp3d_ref(:,:,k,ie) = ((hvcoord%hyai(k+1)-hvcoord%hyai(k))*hvcoord%ps0 + & - (hvcoord%hybi(k+1)-hvcoord%hybi(k))*ps_ref(:,:,ie)) - tmp = hvcoord%hyam(k)*hvcoord%ps0+hvcoord%hybm(k)*ps_ref(:,:,ie) - tmp2 = (tmp/hvcoord%ps0)**cappa - T_ref(:,:,k,ie) = (T0+T1*tmp2) - end do - end do - kbeg=1; kend=nlev kblk = kend - kbeg + 1 @@ -614,11 +555,10 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do ic=1,hypervis_subcycle - call calc_tot_energy_dynamics(elem,fvm,nets,nete,nt,qn0,'dBH') + call tot_energy_dyn(elem,fvm,nets,nete,nt,qn0,'dBH') rhypervis_subcycle=1.0_r8/real(hypervis_subcycle,kind=r8) - call biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend,& - dp3d_ref,T_ref) + call biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend) do ie=nets,nete ! compute mean flux @@ -629,13 +569,13 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, do j=1,np do i=1,np elem(ie)%derived%dpdiss_ave(i,j,k)=elem(ie)%derived%dpdiss_ave(i,j,k)+& - rhypervis_subcycle*eta_ave_w*elem(ie)%state%dp3d(i,j,k,nt) + rhypervis_subcycle*eta_ave_w*(elem(ie)%state%dp3d(i,j,k,nt)-elem(ie)%derived%dp_ref(i,j,k)) elem(ie)%derived%dpdiss_biharmonic(i,j,k)=elem(ie)%derived%dpdiss_biharmonic(i,j,k)+& rhypervis_subcycle*eta_ave_w*dptens(i,j,k,ie) - enddo - enddo - enddo - endif + end do + end do + end do + end if !$omp parallel do num_threads(vert_num_threads) private(lap_t,lap_dp,lap_v,laplace_fluxes,nu_ratio1,i,j,k) do k=kbeg,kend ! advace in time. @@ -646,14 +586,14 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, !DIR_VECTOR_ALIGNED do j=1,np do i=1,np - ttens(i,j,k,ie) = -nu_s*ttens(i,j,k,ie) + ttens(i,j,k,ie) = -nu_t_lev(k)*ttens(i,j,k,ie) dptens(i,j,k,ie) = -nu_p*dptens(i,j,k,ie) vtens(i,j,1,k,ie) = -nu_lev(k)*vtens(i,j,1,k,ie) vtens(i,j,2,k,ie) = -nu_lev(k)*vtens(i,j,2,k,ie) - enddo - enddo + end do + end do - if (ntrac>0) then + if (use_cslam) then !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,nc @@ -663,9 +603,9 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, ! elem(ie)%sub_elem_mass_flux(i,j,:,k) = elem(ie)%sub_elem_mass_flux(i,j,:,k) - & rhypervis_subcycle*eta_ave_w*nu_p*dpflux(i,j,:,k,ie) - enddo - enddo - endif + end do + end do + end if ! NOTE: we will DSS all tendicies, EXCEPT for dp3d, where we DSS the new state !OMP_COLLAPSE_SIMD @@ -674,10 +614,10 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, do i=1,np elem(ie)%state%dp3d(i,j,k,nt) = elem(ie)%state%dp3d(i,j,k,nt)*elem(ie)%spheremp(i,j)& + dt*dptens(i,j,k,ie) - enddo - enddo + end do + end do - enddo + end do kptr = kbeg - 1 call edgeVpack(edge3,ttens(:,:,kbeg:kend,ie),kblk,kptr,ie) @@ -690,7 +630,7 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, kptr = kbeg - 1 + 3*nlev call edgeVpack(edge3,elem(ie)%state%dp3d(:,:,kbeg:kend,nt),kblk,kptr,ie) - enddo + end do call bndry_exchange(hybrid,edge3,location='advance_hypervis_dp2') @@ -705,17 +645,17 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, kptr = kbeg - 1 + 2*nlev call edgeVunpack(edge3,vtens(:,:,2,kbeg:kend,ie),kblk,kptr,ie) - if (ntrac>0) then + if (use_cslam) then do k=kbeg,kend temp(:,:,k) = elem(ie)%state%dp3d(:,:,k,nt) / elem(ie)%spheremp ! STATE before DSS corners(0:np+1,0:np+1,k) = 0.0_r8 corners(1:np ,1:np ,k) = elem(ie)%state%dp3d(1:np,1:np,k,nt) ! fill in interior data of STATE*mass - enddo - endif + end do + end if kptr = kbeg - 1 + 3*nlev call edgeVunpack(edge3,elem(ie)%state%dp3d(:,:,kbeg:kend,nt),kblk,kptr,ie) - if (ntrac>0) then + if (use_cslam) then desc = elem(ie)%desc kptr = kbeg - 1 + 3*nlev @@ -728,8 +668,8 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, do i=1,np temp(i,j,k) = elem(ie)%rspheremp(i,j)*elem(ie)%state%dp3d(i,j,k,nt) - temp(i,j,k) temp(i,j,k) = temp(i,j,k)/dt - enddo - enddo + end do + end do call distribute_flux_at_corners(cflux, corners(:,:,k), desc%getmapP) @@ -742,7 +682,7 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, elem(ie)%sub_elem_mass_flux(:,:,:,k) = elem(ie)%sub_elem_mass_flux(:,:,:,k) + & rhypervis_subcycle*eta_ave_w*tempflux end do - endif + end if ! apply inverse mass matrix, accumulate tendencies !$omp parallel do num_threads(vert_num_threads) private(k,i,j) @@ -755,9 +695,9 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, vtens(i,j,2,k,ie)=dt*vtens(i,j,2,k,ie)*elem(ie)%rspheremp(i,j) ttens(i,j,k,ie)=dt*ttens(i,j,k,ie)*elem(ie)%rspheremp(i,j) elem(ie)%state%dp3d(i,j,k,nt)=elem(ie)%state%dp3d(i,j,k,nt)*elem(ie)%rspheremp(i,j) - enddo - enddo - enddo + end do + end do + end do !$omp parallel do num_threads(vert_num_threads) private(k,i,j) do k=kbeg,kend @@ -770,15 +710,18 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, vtens(i,j,:,k,ie) elem(ie)%state%T(i,j,k,nt)=elem(ie)%state%T(i,j,k,nt) & +ttens(i,j,k,ie) - enddo - enddo - enddo + end do + end do + end do end do - call calc_tot_energy_dynamics(elem,fvm,nets,nete,nt,qn0,'dCH') + call tot_energy_dyn(elem,fvm,nets,nete,nt,qn0,'dCH') do ie=nets,nete !$omp parallel do num_threads(vert_num_threads), private(k,i,j,v1,v2,heating) - do k=kbeg,kend + do k=sponge_del4_lev+2,nlev + ! + ! only do "frictional heating" away from sponge + ! !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np @@ -791,11 +734,11 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, elem(ie)%state%T(i,j,k,nt)=elem(ie)%state%T(i,j,k,nt) & -heating*inv_cp_full(i,j,k,ie) - enddo - enddo - enddo - enddo - call calc_tot_energy_dynamics(elem,fvm,nets,nete,nt,qn0,'dAH') + end do + end do + end do + end do + call tot_energy_dyn(elem,fvm,nets,nete,nt,qn0,'dAH') end do ! @@ -805,116 +748,57 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, ! !*************************************************************** ! - ! - ! vertical diffusion - ! - call t_startf('vertical_molec_diff') - if (molecular_diff>1) then - do ie=nets,nete - call get_rho_dry(elem(ie)%state%Qdp(:,:,:,1:qsize,qn0), & - elem(ie)%state%T(:,:,:,nt),ptop,elem(ie)%state%dp3d(:,:,:,nt),& - .true.,rhoi_dry=rhoi_dry(:,:,:), & - active_species_idx_dycore=thermodynamic_active_species_idx_dycore) - ! - ! constant coefficients - ! - do k=1,ksponge_end+1 - kmvisi(:,:,k) = kmvisi_ref(k)*rhoi_dry(:,:,k) - kmcndi(:,:,k) = kmcndi_ref(k)*rhoi_dry(:,:,k) - end do - ! - ! do vertical diffusion - ! - do j=1,np - do i=1,np - call solve_diffusion(dt2,np,nlev,i,j,ksponge_end,pmid,pint,kmcndi(:,:,:)/cpair,elem(ie)%state%T(:,:,:,nt),& - 0,dtemp) - call solve_diffusion(dt2,np,nlev,i,j,ksponge_end,pmid,pint,kmvisi(:,:,:),elem(ie)%state%v(:,:,1,:,nt),1,du) - call solve_diffusion(dt2,np,nlev,i,j,ksponge_end,pmid,pint,kmvisi(:,:,:),elem(ie)%state%v(:,:,2,:,nt),1,dv) - do k=1,ksponge_end - v1 = elem(ie)%state%v(i,j,1,k,nt) - v2 = elem(ie)%state%v(i,j,2,k,nt) - v1new = v1 + du(k) - v2new = v2 + dv(k) - ! - ! frictional heating - ! - heating = 0.5_r8*((v1new*v1new+v2new*v2new) - (v1*v1+v2*v2)) - elem(ie)%state%T(i,j,k,nt)=elem(ie)%state%T(i,j,k,nt) & - -heating*inv_cp_full(i,j,k,ie)+dtemp(k) - elem(ie)%state%v(i,j,1,k,nt)=v1new - elem(ie)%state%v(i,j,2,k,nt)=v2new - end do - end do - end do - end do - end if - call t_stopf('vertical_molec_diff') call t_startf('sponge_diff') ! ! compute coefficients for horizontal diffusion ! - if (molecular_diff>0) then + if (molecular_diff==1) then do ie=nets,nete call get_rho_dry(elem(ie)%state%Qdp(:,:,:,1:qsize,qn0), & - elem(ie)%state%T(:,:,:,nt),ptop,elem(ie)%state%dp3d(:,:,:,nt),& - .true.,rho_dry=rho_dry(:,:,:,ie), & + elem(ie)%state%T(:,:,:,nt), ptop, elem(ie)%state%dp3d(:,:,:,nt),& + .true., rho_dry=rho_dry(:,:,:,ie), & active_species_idx_dycore=thermodynamic_active_species_idx_dycore) end do - if (molecular_diff==1) then - do ie=nets,nete - ! - ! compute molecular diffusion and thermal conductivity coefficients at mid-levels - ! - call get_molecular_diff_coef(elem(ie)%state%T(:,:,:,nt),.false.,km_sponge_factor(1:ksponge_end),kmvis(:,:,:,ie),kmcnd(:,:,:,ie),qsize,& - elem(ie)%state%Qdp(:,:,:,1:qsize,qn0),fact=1.0_r8/elem(ie)%state%dp3d(:,:,1:ksponge_end,nt),& - active_species_idx_dycore=thermodynamic_active_species_idx_dycore) - end do - else + do ie=nets,nete ! - ! constant coefficients + ! compute molecular diffusion and thermal conductivity coefficients at mid-levels ! - do ie=nets,nete - do k=1,ksponge_end - kmvis (:,:,k,ie) = kmvis_ref(k) - kmcnd (:,:,k,ie) = kmcnd_ref(k) - end do - end do - end if + call get_molecular_diff_coef(elem(ie)%state%T(:,:,:,nt), .false., km_sponge_factor(1:ksponge_end), kmvis(:,:,:,ie),& + kmcnd(:,:,:,ie), elem(ie)%state%Qdp(:,:,:,1:qsize,qn0), fact=1.0_r8/elem(ie)%state%dp3d(:,:,1:ksponge_end,nt),& + active_species_idx_dycore=thermodynamic_active_species_idx_dycore) + end do ! ! diagnostics ! -!Un-comment once history outputs are enabled -JN: -#if 0 - if (hist_fld_active('nu_kmvis')) then + if (is_history_field_active('nu_kmvis')) then do ie=nets,nete tmp_kmvis = 0.0_r8 do k=1,ksponge_end tmp_kmvis(:,:,k) = kmvis(:,:,k,ie)/rho_dry(:,:,k,ie) end do - call outfld('nu_kmvis',RESHAPE(tmp_kmvis(:,:,:), (/npsq,nlev/)), npsq, ie) + call history_out_field('nu_kmvis',RESHAPE(tmp_kmvis(:,:,:), (/npsq,nlev/))) end do end if - if (hist_fld_active('nu_kmcnd')) then + if (is_history_field_active('nu_kmcnd')) then do ie=nets,nete tmp_kmcnd = 0.0_r8 do k=1,ksponge_end tmp_kmcnd(:,:,k) = kmcnd(:,:,k,ie)*inv_cp_full(:,:,k,ie)/rho_dry(:,:,k,ie) end do - call outfld('nu_kmcnd',RESHAPE(tmp_kmcnd(:,:,:), (/npsq,nlev/)), npsq, ie) + call history_out_field('nu_kmcnd',RESHAPE(tmp_kmcnd(:,:,:), (/npsq,nlev/))) end do end if - if (hist_fld_active('nu_kmcnd_dp')) then + if (is_history_field_active('nu_kmcnd_dp')) then do ie=nets,nete tmp_kmcnd = 0.0_r8 do k=1,ksponge_end tmp_kmcnd(:,:,k) = kmcnd(:,:,k,ie)/(cpair*rho_ref(k)) end do - call outfld('nu_kmcnd_dp',RESHAPE(tmp_kmcnd(:,:,:), (/npsq,nlev/)), npsq, ie) + call history_out_field('nu_kmcnd_dp',RESHAPE(tmp_kmcnd(:,:,:), (/npsq,nlev/))) end do end if -#endif + ! ! scale by reference value ! @@ -929,7 +813,7 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, ! Horizontal Laplacian diffusion ! dt=dt2/hypervis_subcycle_sponge - call calc_tot_energy_dynamics(elem,fvm,nets,nete,nt,qn0,'dBS') + call tot_energy_dyn(elem,fvm,nets,nete,nt,qn0,'dBS') kblk = ksponge_end do ic=1,hypervis_subcycle_sponge rhypervis_subcycle=1.0_r8/real(hypervis_subcycle_sponge,kind=r8) @@ -962,8 +846,8 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, dptens(i,j,k,ie) = nu_dp *lap_dp(i,j) vtens(i,j,1,k,ie) = nu_velo*lap_v(i,j,1) vtens(i,j,2,k,ie) = nu_velo*lap_v(i,j,2) - enddo - enddo + end do + end do end if if (molecular_diff>0) then !************************************************************************ @@ -986,14 +870,14 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, end do end if - if (ntrac>0.and.nu_dp>0) then + if (use_cslam.and.nu_dp>0) then ! ! mass flux for CSLAM due to sponge layer diffusion on dp ! call subcell_Laplace_fluxes(elem(ie)%state%dp3d(:,:,k,nt),deriv,elem(ie),np,nc,laplace_fluxes) elem(ie)%sub_elem_mass_flux(:,:,:,k) = elem(ie)%sub_elem_mass_flux(:,:,:,k) + & rhypervis_subcycle*eta_ave_w*nu_dp*laplace_fluxes - endif + end if ! NOTE: we will DSS all tendencies, EXCEPT for dp3d, where we DSS the new state !OMP_COLLAPSE_SIMD @@ -1002,10 +886,10 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, do i=1,np elem(ie)%state%dp3d(i,j,k,nt) = elem(ie)%state%dp3d(i,j,k,nt)*elem(ie)%spheremp(i,j)& + dt*dptens(i,j,k,ie) - enddo - enddo + end do + end do - enddo + end do kptr = 0 @@ -1019,7 +903,7 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, kptr = 3*ksponge_end call edgeVpack(edgeSponge,elem(ie)%state%dp3d(:,:,1:ksponge_end,nt),kblk,kptr,ie) - enddo + end do call bndry_exchange(hybrid,edgeSponge,location='advance_hypervis_sponge') @@ -1034,17 +918,17 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, kptr = 2*ksponge_end call edgeVunpack(edgeSponge,vtens(:,:,2,1:ksponge_end,ie),kblk,kptr,ie) - if (ntrac>0.and.nu_dp>0.0_r8) then + if (use_cslam.and.nu_dp>0.0_r8) then do k=1,ksponge_end temp(:,:,k) = elem(ie)%state%dp3d(:,:,k,nt) / elem(ie)%spheremp ! STATE before DSS corners(0:np+1,0:np+1,k) = 0.0_r8 corners(1:np ,1:np ,k) = elem(ie)%state%dp3d(1:np,1:np,k,nt) ! fill in interior data of STATE*mass - enddo - endif + end do + end if kptr = 3*ksponge_end call edgeVunpack(edgeSponge,elem(ie)%state%dp3d(:,:,1:ksponge_end,nt),kblk,kptr,ie) - if (ntrac>0.and.nu_dp>0.0_r8) then + if (use_cslam.and.nu_dp>0.0_r8) then desc = elem(ie)%desc kptr = 3*ksponge_end @@ -1057,8 +941,8 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, do i=1,np temp(i,j,k) = elem(ie)%rspheremp(i,j)*elem(ie)%state%dp3d(i,j,k,nt) - temp(i,j,k) temp(i,j,k) = temp(i,j,k)/dt - enddo - enddo + end do + end do call distribute_flux_at_corners(cflux, corners(:,:,k), desc%getmapP) @@ -1071,7 +955,7 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, elem(ie)%sub_elem_mass_flux(:,:,:,k) = elem(ie)%sub_elem_mass_flux(:,:,:,k) + & rhypervis_subcycle*eta_ave_w*tempflux end do - endif + end if ! apply inverse mass matrix, accumulate tendencies !$omp parallel do num_threads(vert_num_threads) private(k,i,j) @@ -1084,42 +968,42 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, vtens(i,j,2,k,ie)=dt*vtens(i,j,2,k,ie)*elem(ie)%rspheremp(i,j) ttens(i,j,k,ie)=dt*ttens(i,j,k,ie)*elem(ie)%rspheremp(i,j) elem(ie)%state%dp3d(i,j,k,nt)=elem(ie)%state%dp3d(i,j,k,nt)*elem(ie)%rspheremp(i,j) - enddo - enddo - enddo - !$omp parallel do num_threads(vert_num_threads) private(k,i,j,v1,v2,v1new,v2new) - do k=1,ksponge_end - !OMP_COLLAPSE_SIMD - !DIR_VECTOR_ALIGNED - do j=1,np - do i=1,np ! update v first (gives better results than updating v after heating) - elem(ie)%state%v(i,j,:,k,nt)=elem(ie)%state%v(i,j,:,k,nt) + & - vtens(i,j,:,k,ie) - elem(ie)%state%T(i,j,k,nt)=elem(ie)%state%T(i,j,k,nt) & - +ttens(i,j,k,ie) - - v1new=elem(ie)%state%v(i,j,1,k,nt) - v2new=elem(ie)%state%v(i,j,2,k,nt) - v1 =elem(ie)%state%v(i,j,1,k,nt)- vtens(i,j,1,k,ie) - v2 =elem(ie)%state%v(i,j,2,k,nt)- vtens(i,j,2,k,ie) - ! - ! frictional heating - ! - heating = 0.5_r8*(v1new*v1new+v2new*v2new-(v1*v1+v2*v2)) - elem(ie)%state%T(i,j,k,nt)=elem(ie)%state%T(i,j,k,nt) & - -heating*inv_cp_full(i,j,k,ie) - enddo - enddo - enddo + elem(ie)%state%v(i,j,:,k,nt)=elem(ie)%state%v(i,j,:,k,nt) + vtens(i,j,:,k,ie) + elem(ie)%state%T(i,j, k,nt)=elem(ie)%state%T(i,j, k,nt) + ttens(i,j, k,ie) + end do + end do + end do + if (molecular_diff>0) then + ! + ! no frictional heating for artificial sponge + ! + !$omp parallel do num_threads(vert_num_threads) private(k,i,j,v1,v2,v1new,v2new) + do k=1,ksponge_end + !OMP_COLLAPSE_SIMD + !DIR_VECTOR_ALIGNED + do j=1,np + do i=1,np + v1new=elem(ie)%state%v(i,j,1,k,nt) + v2new=elem(ie)%state%v(i,j,2,k,nt) + v1 =elem(ie)%state%v(i,j,1,k,nt)- vtens(i,j,1,k,ie) + v2 =elem(ie)%state%v(i,j,2,k,nt)- vtens(i,j,2,k,ie) + ! + ! frictional heating + ! + heating = 0.5_r8*(v1new*v1new+v2new*v2new-(v1*v1+v2*v2)) + elem(ie)%state%T(i,j,k,nt)=elem(ie)%state%T(i,j,k,nt) & + -heating*inv_cp_full(i,j,k,ie) + end do + end do + end do + end if end do end do call t_stopf('sponge_diff') - call calc_tot_energy_dynamics(elem,fvm,nets,nete,nt,qn0,'dAS') + call tot_energy_dyn(elem,fvm,nets,nete,nt,qn0,'dAS') end subroutine advance_hypervis_dp - - subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& deriv,nets,nete,eta_ave_w,inv_cp_full,qwater,qidx,kappa) ! =================================== @@ -1141,15 +1025,8 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& ! allows us to fuse these two loops for more cache reuse ! ! =================================== - use air_composition, only: thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx_dycore - use air_composition, only: dry_air_species_num - use dyn_thermo, only: get_gz_given_dp_Tv_Rdry - use dyn_thermo, only: get_virtual_temp, get_cp_dry - use dyn_thermo, only: get_R_dry - - !SE dycore: - use dimensions_mod, only: np, nc, nlev, ntrac, ksponge_end + use dimensions_mod, only: np, nc, nlev, use_cslam + use control_mod, only: pgf_formulation use hybrid_mod, only: hybrid_t use element_mod, only: element_t use derivative_mod, only: derivative_t, divergence_sphere, gradient_sphere, vorticity_sphere @@ -1158,7 +1035,10 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& use edgetype_mod, only: edgedescriptor_t use bndry_mod, only: bndry_exchange use hybvcoord_mod, only: hvcoord_t - use time_mod, only: tevolve + use cam_thermo, only: get_gz, get_virtual_temp + use air_composition, only: thermodynamic_active_species_num, dry_air_species_num + use air_composition, only: get_cp_dry, get_R_dry + use physconst, only: tref,cpair,rga,lapse_rate implicit none integer, intent(in) :: np1,nm1,n0,nets,nete @@ -1189,11 +1069,9 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& real (kind=r8), dimension(np,np) :: vgrad_T ! v.grad(T) real (kind=r8), dimension(np,np) :: Ephi ! kinetic energy + PHI term real (kind=r8), dimension(np,np,2,nlev) :: grad_p_full - real (kind=r8), dimension(np,np,2,nlev) :: grad_p_m_pmet! gradient(p - p_met) real (kind=r8), dimension(np,np,nlev) :: vort ! vorticity - real (kind=r8), dimension(np,np,nlev) :: p_dry ! pressure dry real (kind=r8), dimension(np,np,nlev) :: dp_dry ! delta pressure dry - real (kind=r8), dimension(np,np,nlev) :: R_dry + real (kind=r8), dimension(np,np,nlev) :: R_dry, cp_dry! real (kind=r8), dimension(np,np,nlev) :: p_full ! pressure real (kind=r8), dimension(np,np,nlev) :: dp_full real (kind=r8), dimension(np,np) :: exner @@ -1203,17 +1081,17 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& real (kind=r8) :: vtens1(np,np,nlev),vtens2(np,np,nlev),ttens(np,np,nlev) real (kind=r8) :: stashdp3d (np,np,nlev),tempdp3d(np,np), tempflux(nc,nc,4) real (kind=r8) :: ckk, term, T_v(np,np,nlev) - real (kind=r8), dimension(np,np,2) :: grad_exner + real (kind=r8), dimension(np,np,2) :: pgf_term + real (kind=r8), dimension(np,np,2) :: grad_exner,grad_logexner + real (kind=r8) :: T0,T1 real (kind=r8), dimension(np,np) :: theta_v - real (kind=r8), dimension(np,np,nlev) :: cp_dry - type (EdgeDescriptor_t):: desc real (kind=r8) :: sum_water(np,np,nlev), density_inv(np,np) real (kind=r8) :: E,v1,v2,glnps1,glnps2 integer :: i,j,k,kptr,ie - real (kind=r8) :: u_m_umet, v_m_vmet, t_m_tmet, ptop + real (kind=r8) :: ptop !JMD call t_barrierf('sync_compute_and_apply_rhs', hybrid%par%comm) call t_adj_detailf(+1) @@ -1223,17 +1101,16 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& ! ! compute virtual temperature and sum_water ! - call get_virtual_temp(qwater(:,:,:,:,ie),& - t_v(:,:,:),temp=elem(ie)%state%T(:,:,:,n0),sum_q =sum_water(:,:,:),& - active_species_idx_dycore=qidx) - call get_R_dry(qwater(:,:,:,:,ie),qidx,R_dry) - call get_cp_dry(qwater(:,:,:,:,ie),qidx,cp_dry) + call get_virtual_temp(qwater(:,:,:,:,ie), t_v(:,:,:),temp=elem(ie)%state%T(:,:,:,n0),& + sum_q =sum_water(:,:,:), active_species_idx_dycore=qidx) + call get_R_dry(qwater(:,:,:,:,ie), qidx, R_dry) + call get_cp_dry(qwater(:,:,:,:,ie), qidx, cp_dry) do k=1,nlev dp_dry(:,:,k) = elem(ie)%state%dp3d(:,:,k,n0) dp_full(:,:,k) = sum_water(:,:,k)*dp_dry(:,:,k) end do - call get_gz_given_dp_Tv_Rdry(dp_full,T_v,R_dry,elem(ie)%state%phis,ptop,phi,pmid=p_full) + call get_gz(dp_full, T_v, R_dry, elem(ie)%state%phis, ptop, phi, pmid=p_full) do k=1,nlev ! vertically lagrangian code: we advect dp3d instead of ps ! we also need grad(p) at all levels (not just grad(ps)) @@ -1270,8 +1147,8 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& do i=1,np elem(ie)%derived%vn0(i,j,1,k)=elem(ie)%derived%vn0(i,j,1,k)+eta_ave_w*vdp_dry(i,j,1,k) elem(ie)%derived%vn0(i,j,2,k)=elem(ie)%derived%vn0(i,j,2,k)+eta_ave_w*vdp_dry(i,j,2,k) - enddo - enddo + end do + end do !divdp_dry(:,:,k) ! ========================================= ! @@ -1281,7 +1158,7 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& call divergence_sphere(vdp_dry(:,:,:,k),deriv,elem(ie),divdp_dry(:,:,k)) call divergence_sphere(vdp_full(:,:,:,k),deriv,elem(ie),divdp_full(:,:,k)) call vorticity_sphere(elem(ie)%state%v(:,:,:,k,n0),deriv,elem(ie),vort(:,:,k)) - enddo + end do ! ==================================================== ! Compute omega_full @@ -1312,7 +1189,7 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& do k=1,nlev ! Loop index added (AAM) elem(ie)%derived%omega(:,:,k) = & elem(ie)%derived%omega(:,:,k) + eta_ave_w*omega_full(:,:,k) - enddo + end do ! ============================================== ! Compute phi + kinetic energy term: 10*nv*nv Flops ! ============================================== @@ -1349,32 +1226,52 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& ! vtemp = gradient_sphere(Ephi(:,:),deriv,elem(ie)%Dinv) call gradient_sphere(Ephi(:,:),deriv,elem(ie)%Dinv,vtemp) density_inv(:,:) = R_dry(:,:,k)*T_v(:,:,k)/p_full(:,:,k) - - if (dry_air_species_num==0) then - exner(:,:)=(p_full(:,:,k)/hvcoord%ps0)**kappa(:,:,k,ie) - theta_v(:,:)=T_v(:,:,k)/exner(:,:) - call gradient_sphere(exner(:,:),deriv,elem(ie)%Dinv,grad_exner) - - grad_exner(:,:,1) = real(cp_dry(:,:,k), r8)*theta_v(:,:)*grad_exner(:,:,1) - grad_exner(:,:,2) = real(cp_dry(:,:,k), r8)*theta_v(:,:)*grad_exner(:,:,2) + if (pgf_formulation==1.or.(pgf_formulation==3.and.hvcoord%hybm(k)>0._r8)) then + if (dry_air_species_num==0) then + exner(:,:)=(p_full(:,:,k)/hvcoord%ps0)**kappa(:,:,k,ie) + theta_v(:,:)=T_v(:,:,k)/exner(:,:) + call gradient_sphere(exner(:,:),deriv,elem(ie)%Dinv,grad_exner) + pgf_term(:,:,1) = cp_dry(:,:,k)*theta_v(:,:)*grad_exner(:,:,1) + pgf_term(:,:,2) = cp_dry(:,:,k)*theta_v(:,:)*grad_exner(:,:,2) + else + exner(:,:)=(p_full(:,:,k)/hvcoord%ps0)**kappa(:,:,k,ie) + theta_v(:,:)=T_v(:,:,k)/exner(:,:) + call gradient_sphere(exner(:,:),deriv,elem(ie)%Dinv,grad_exner) + call gradient_sphere(kappa(:,:,k,ie),deriv,elem(ie)%Dinv,grad_kappa_term) + suml = exner(:,:)*LOG(p_full(:,:,k)/hvcoord%ps0) + grad_kappa_term(:,:,1)=-suml*grad_kappa_term(:,:,1) + grad_kappa_term(:,:,2)=-suml*grad_kappa_term(:,:,2) + pgf_term(:,:,1) = cp_dry(:,:,k)*theta_v(:,:)*(grad_exner(:,:,1)+grad_kappa_term(:,:,1)) + pgf_term(:,:,2) = cp_dry(:,:,k)*theta_v(:,:)*(grad_exner(:,:,2)+grad_kappa_term(:,:,2)) + end if + ! balanced ref profile correction: + ! reference temperature profile (Simmons and Jiabin, 1991, QJRMS, Section 2a) + ! + ! Tref = T0+T1*Exner + ! T1 = .0065*Tref*Cp/g ! = ~191 + ! T0 = Tref-T1 ! = ~97 + ! + T1 = lapse_rate*Tref*cpair*rga + T0 = Tref-T1 + if (hvcoord%hybm(k)>0) then + !only apply away from constant pressure levels + call gradient_sphere(log(exner(:,:)),deriv,elem(ie)%Dinv,grad_logexner) + pgf_term(:,:,1)=pgf_term(:,:,1) + & + cpair*T0*(grad_logexner(:,:,1)-grad_exner(:,:,1)/exner(:,:)) + pgf_term(:,:,2)=pgf_term(:,:,2) + & + cpair*T0*(grad_logexner(:,:,2)-grad_exner(:,:,2)/exner(:,:)) + end if + elseif (pgf_formulation==2.or.pgf_formulation==3) then + pgf_term(:,:,1) = density_inv(:,:)*grad_p_full(:,:,1,k) + pgf_term(:,:,2) = density_inv(:,:)*grad_p_full(:,:,2,k) else - exner(:,:)=(p_full(:,:,k)/hvcoord%ps0)**kappa(:,:,k,ie) - theta_v(:,:)=T_v(:,:,k)/exner(:,:) - call gradient_sphere(exner(:,:),deriv,elem(ie)%Dinv,grad_exner) - - call gradient_sphere(kappa(:,:,k,ie),deriv,elem(ie)%Dinv,grad_kappa_term) - suml = exner(:,:)*LOG(p_full(:,:,k)/hvcoord%ps0) - grad_kappa_term(:,:,1)=-suml*grad_kappa_term(:,:,1) - grad_kappa_term(:,:,2)=-suml*grad_kappa_term(:,:,2) - - grad_exner(:,:,1) = real(cp_dry(:,:,k), r8)*theta_v(:,:)*(grad_exner(:,:,1)+grad_kappa_term(:,:,1)) - grad_exner(:,:,2) = real(cp_dry(:,:,k), r8)*theta_v(:,:)*(grad_exner(:,:,2)+grad_kappa_term(:,:,2)) + call endrun('ERROR: bad choice of pgf_formulation (must be 1, 2, or 3)') end if do j=1,np do i=1,np - glnps1 = grad_exner(i,j,1) - glnps2 = grad_exner(i,j,2) + glnps1 = pgf_term(i,j,1) + glnps2 = pgf_term(i,j,2) v1 = elem(ie)%state%v(i,j,1,k,n0) v2 = elem(ie)%state%v(i,j,2,k,n0) @@ -1411,23 +1308,23 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& elem(ie)%state%dp3d(i,j,k,np1) = & elem(ie)%spheremp(i,j) * (elem(ie)%state%dp3d(i,j,k,nm1) - & dt2 * (divdp_dry(i,j,k))) - enddo - enddo + end do + end do - if (ntrac>0.and.eta_ave_w.ne.0._r8) then + if (use_cslam.and.eta_ave_w.ne.0._r8) then !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np v(i,j,1) = elem(ie)%Dinv(i,j,1,1)*vdp_dry(i,j,1,k) + elem(ie)%Dinv(i,j,1,2)*vdp_dry(i,j,2,k) v(i,j,2) = elem(ie)%Dinv(i,j,2,1)*vdp_dry(i,j,1,k) + elem(ie)%Dinv(i,j,2,2)*vdp_dry(i,j,2,k) - enddo - enddo + end do + end do call subcell_div_fluxes(v, np, nc, elem(ie)%metdet,tempflux) elem(ie)%sub_elem_mass_flux(:,:,:,k) = elem(ie)%sub_elem_mass_flux(:,:,:,k) - eta_ave_w*tempflux end if - enddo + end do ! ========================================================= ! ! Pack @@ -1458,18 +1355,18 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& kptr=nlev call edgeVunpack(edge3, elem(ie)%state%v(:,:,:,:,np1), 2*nlev, kptr, ie) - if (ntrac>0.and.eta_ave_w.ne.0._r8) then + if (use_cslam.and.eta_ave_w.ne.0._r8) then do k=1,nlev stashdp3d(:,:,k) = elem(ie)%state%dp3d(:,:,k,np1)/elem(ie)%spheremp(:,:) end do - endif + end if corners = 0.0_r8 corners(1:np,1:np,:) = elem(ie)%state%dp3d(:,:,:,np1) kptr=kptr+2*nlev call edgeVunpack(edge3, elem(ie)%state%dp3d(:,:,:,np1),nlev,kptr,ie) - if (ntrac>0.and.eta_ave_w.ne.0._r8) then + if (use_cslam.and.eta_ave_w.ne.0._r8) then desc = elem(ie)%desc call edgeDGVunpack(edge3, corners, nlev, kptr, ie) @@ -1508,21 +1405,20 @@ subroutine compute_and_apply_rhs(np1,nm1,n0,dt2,elem,hvcoord,hybrid,& elem(ie)%state%T(i,j,k,np1) = elem(ie)%rspheremp(i,j)*elem(ie)%state%T(i,j,k,np1) elem(ie)%state%v(i,j,1,k,np1) = elem(ie)%rspheremp(i,j)*elem(ie)%state%v(i,j,1,k,np1) elem(ie)%state%v(i,j,2,k,np1) = elem(ie)%rspheremp(i,j)*elem(ie)%state%v(i,j,2,k,np1) - enddo - enddo + end do + end do end do ! vertically lagrangian: complete dp3d timestep: do k=1,nlev elem(ie)%state%dp3d(:,:,k,np1)= elem(ie)%rspheremp(:,:)*elem(ie)%state%dp3d(:,:,k,np1) - enddo + end do end do call t_stopf('compute_and_apply_rhs') call t_adj_detailf(-1) end subroutine compute_and_apply_rhs - ! ! corner fluxes for CSLAM ! @@ -1546,7 +1442,7 @@ subroutine distribute_flux_at_corners(cflux, corners, getmapP) else cflux(1,1,1) = (corners(0,1) - corners(1,1)) cflux(1,1,2) = (corners(1,0) - corners(1,1)) - endif + end if if (getmapP(swest+1*max_corner_elem) /= -1) then cflux(2,1,1) = (corners(np+1,1) - corners(np,1)) @@ -1559,7 +1455,7 @@ subroutine distribute_flux_at_corners(cflux, corners, getmapP) else cflux(2,1,1) = (corners(np+1,1) - corners(np,1)) cflux(2,1,2) = (corners(np ,0) - corners(np,1)) - endif + end if if (getmapP(swest+2*max_corner_elem) /= -1) then cflux(1,2,1) = (corners(0,np ) - corners(1,np )) @@ -1572,7 +1468,7 @@ subroutine distribute_flux_at_corners(cflux, corners, getmapP) else cflux(1,2,1) = (corners(0,np ) - corners(1,np )) cflux(1,2,2) = (corners(1,np+1) - corners(1,np )) - endif + end if if (getmapP(swest+3*max_corner_elem) /= -1) then cflux(2,2,1) = (corners(np+1,np ) - corners(np,np )) @@ -1585,42 +1481,54 @@ subroutine distribute_flux_at_corners(cflux, corners, getmapP) else cflux(2,2,1) = (corners(np+1,np ) - corners(np,np )) cflux(2,2,2) = (corners(np ,np+1) - corners(np,np )) - endif + end if end subroutine distribute_flux_at_corners - subroutine calc_tot_energy_dynamics(elem,fvm,nets,nete,tl,tl_qdp,outfld_name_suffix) - use dynconst, only: gravit, cpair, rearth, omega - use dyn_thermo, only: get_dp, get_cp - use cam_thermo, only: MASS_MIXING_RATIO - use air_composition, only: thermodynamic_active_species_idx_dycore - use hycoef, only: hyai, ps0 - use string_utils, only: strlist_get_ind -!Un-comment once constituents and history outputs are enabled -JN: -! use cam_history, only: outfld, hist_fld_active -! use constituents, only: cnst_get_ind - - !SE dycore: + subroutine tot_energy_dyn(elem,fvm,nets,nete,tl,tl_qdp,outfld_name_suffix) + use dimensions_mod, only: npsq,nlev,np,nc,use_cslam,qsize + use physconst, only: rga, rearth, omega use element_mod, only: element_t - use dimensions_mod, only: npsq,nlev,np,lcp_moist,nc,ntrac,qsize +! use cam_history, only: history_out_field +! use cam_history_support, only: max_fieldname_len +! use cam_constituents, only: const_get_index + use string_utils, only: strlist_get_ind + use hycoef, only: hyai, ps0 use fvm_control_volume_mod, only: fvm_struct + use cam_thermo, only: get_dp, MASS_MIXING_RATIO +! ,wvidx,wlidx,wiidx,seidx,keidx,moidx,mridx,ttidx,teidx, & +! poidx,thermo_budget_num_vars,thermo_budget_vars + use cam_thermo, only: get_hydrostatic_energy + use air_composition, only: thermodynamic_active_species_idx_dycore, get_cp + use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx_dycore + use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx use dimensions_mod, only: cnst_name_gll + use dyn_tests_utils, only: vcoord=>vc_dry_pressure +! use cam_budget, only: thermo_budget_history !------------------------------Arguments-------------------------------- - type (element_t) , intent(in) :: elem(:) - type(fvm_struct) , intent(in) :: fvm(:) + type (element_t) , intent(inout) :: elem(:) + type(fvm_struct) , intent(inout) :: fvm(:) integer , intent(in) :: tl, tl_qdp,nets,nete character*(*) , intent(in) :: outfld_name_suffix ! suffix for "outfld" names !---------------------------Local storage------------------------------- - real(kind=r8) :: se(npsq) ! Dry Static energy (J/m2) - real(kind=r8) :: ke(npsq) ! kinetic energy (J/m2) + real(kind=r8) :: se(np,np) ! Enthalpy energy (J/m2) + real(kind=r8) :: ke(np,np) ! kinetic energy (J/m2) + real(kind=r8) :: po(np,np) ! PHIS term in energy equation (J/m2) + real(kind=r8) :: wv(np,np) ! water vapor + real(kind=r8) :: liq(np,np) ! liquid + real(kind=r8) :: ice(np,np) ! ice + real(kind=r8) :: q(np,nlev,qsize) + integer :: qidx(thermodynamic_active_species_num) real(kind=r8) :: cdp_fvm(nc,nc,nlev) - real(kind=r8) :: se_tmp - real(kind=r8) :: ke_tmp - real(kind=r8) :: ps(np,np) + real(kind=r8) :: cdp(np,np,nlev) + real(kind=r8) :: ptop(np,np) real(kind=r8) :: pdel(np,np,nlev) + real(kind=r8) :: cp(np,np,nlev) + ! ! global axial angular momentum (AAM) can be separated into one part (mr) associatedwith the relative motion ! of the atmosphere with respect to the planets surface (also known as wind AAM) and another part (mo) @@ -1631,31 +1539,23 @@ subroutine calc_tot_energy_dynamics(elem,fvm,nets,nete,tl,tl_qdp,outfld_name_suf real(kind=r8) :: mo(npsq) ! mass AAM real(kind=r8) :: mr_cnst, mo_cnst, cos_lat, mr_tmp, mo_tmp - real(kind=r8) :: cp(np,np,nlev) - - integer :: ie,i,j,k + integer :: ie,i,j,k,m_cnst,nq,idx integer :: ixwv,ixcldice, ixcldliq, ixtt ! CLDICE, CLDLIQ and test tracer indices - character(len=16) :: name_out1,name_out2,name_out3,name_out4,name_out5,name_out6 - - !----------------------------------------------------------------------- -!Un-comment once history outputs are enabled -JN: -#if 0 - name_out1 = 'SE_' //trim(outfld_name_suffix) - name_out2 = 'KE_' //trim(outfld_name_suffix) - name_out3 = 'WV_' //trim(outfld_name_suffix) - name_out4 = 'WL_' //trim(outfld_name_suffix) - name_out5 = 'WI_' //trim(outfld_name_suffix) - name_out6 = 'TT_' //trim(outfld_name_suffix) +#ifdef cam_thermo_history + character(len=max_fieldname_len) :: name_out(thermo_budget_num_vars) - if ( hist_fld_active(name_out1).or.hist_fld_active(name_out2).or.hist_fld_active(name_out3).or.& - hist_fld_active(name_out4).or.hist_fld_active(name_out5).or.hist_fld_active(name_out6)) then + !----------------------------------------------------------------------- + if (thermo_budget_history) then + do i=1,thermo_budget_num_vars + name_out(i)=trim(thermo_budget_vars(i))//'_'//trim(outfld_name_suffix) + end do - if (ntrac>0) then + if (use_cslam) then ixwv = 1 - call cnst_get_ind('CLDLIQ' , ixcldliq, abort=.false.) - call cnst_get_ind('CLDICE' , ixcldice, abort=.false.) + call const_get_index('CLDLIQ' , ixcldliq, abort=.false.) + call const_get_index('CLDICE' , ixcldice, abort=.false.) else ! ! when using CSLAM the condensates on the GLL grid may be located in a different index than in physics @@ -1664,87 +1564,109 @@ subroutine calc_tot_energy_dynamics(elem,fvm,nets,nete,tl,tl_qdp,outfld_name_suf call strlist_get_ind(cnst_name_gll, 'CLDLIQ' , ixcldliq, abort=.false.) call strlist_get_ind(cnst_name_gll, 'CLDICE' , ixcldice, abort=.false.) end if - call cnst_get_ind('TT_LW' , ixtt , abort=.false.) + call const_get_index('TT_LW' , ixtt , abort=.false.) ! ! Compute frozen static energy in 3 parts: KE, SE, and energy associated with vapor and liquid ! + do nq=1,thermodynamic_active_species_num + qidx(nq) = nq + end do do ie=nets,nete - se = 0.0_r8 - ke = 0.0_r8 - call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,tl_qdp),MASS_MIXING_RATIO,thermodynamic_active_species_idx_dycore,& - elem(ie)%state%dp3d(:,:,:,tl),pdel,ps=ps,ptop=hyai(1)*ps0) call get_cp(elem(ie)%state%Qdp(:,:,:,1:qsize,tl_qdp),& - .false.,cp,factor=1.0_r8/elem(ie)%state%dp3d(:,:,:,tl),& + .false., cp, factor=1.0_r8/elem(ie)%state%dp3d(:,:,:,tl),& active_species_idx_dycore=thermodynamic_active_species_idx_dycore) - - ! TODO: need to port cam6_3_109 changes to total energy using get_hydrostatic_energy - ! https://github.com/ESCOMP/CAM/pull/761/files#diff-946bde17289e2f42e43e64413610aa11d102deda8b5199ddaa5b71e67e5d517a - - do k = 1, nlev - do j=1,np - do i = 1, np - ! - ! kinetic energy - ! - ke_tmp = 0.5_r8*(elem(ie)%state%v(i,j,1,k,tl)**2+ elem(ie)%state%v(i,j,2,k,tl)**2)*pdel(i,j,k)/gravit - if (lcp_moist) then - se_tmp = cp(i,j,k)*elem(ie)%state%T(i,j,k,tl)*pdel(i,j,k)/gravit - else - ! - ! using CAM physics definition of internal energy - ! - se_tmp = cpair*elem(ie)%state%T(i,j,k,tl)*pdel(i,j,k)/gravit - end if - se (i+(j-1)*np) = se (i+(j-1)*np) + se_tmp - ke (i+(j-1)*np) = ke (i+(j-1)*np) + ke_tmp - end do - end do - end do + ptop = hyai(1)*ps0 do j=1,np - do i = 1, np - se(i+(j-1)*np) = se(i+(j-1)*np) + elem(ie)%state%phis(i,j)*ps(i,j)/gravit + !get mixing ratio of thermodynamic active species only + !(other tracers not used in get_hydrostatic_energy) + do nq=1,thermodynamic_active_species_num + m_cnst = thermodynamic_active_species_idx_dycore(nq) + q(:,:,m_cnst) = elem(ie)%state%Qdp(:,j,:,m_cnst,tl_qdp)/& + elem(ie)%state%dp3d(:,j,:,tl) end do + call get_hydrostatic_energy(q, & + .false., elem(ie)%state%dp3d(:,j,:,tl), cp(:,j,:), elem(ie)%state%v(:,j,1,:,tl), & + elem(ie)%state%v(:,j,2,:,tl), elem(ie)%state%T(:,j,:,tl), vcoord, ptop=ptop(:,j),& + phis=elem(ie)%state%phis(:,j), dycore_idx=.true., & + se=se(:,j), po=po(:,j), ke=ke(:,j), wv=wv(:,j), liq=liq(:,j), ice=ice(:,j)) end do ! ! Output energy diagnostics on GLL grid ! - call outfld(name_out1 ,se ,npsq,ie) - call outfld(name_out2 ,ke ,npsq,ie) + call history_out_field(name_out(poidx) ,po) + call history_out_field(name_out(seidx) ,se) + call history_out_field(name_out(keidx) ,ke) + call history_out_field(name_out(teidx) ,ke+se+po) ! ! mass variables are output on CSLAM grid if using CSLAM else GLL grid ! - if (ntrac>0) then - if (ixwv>0) then - cdp_fvm = fvm(ie)%c(1:nc,1:nc,:,ixwv)*fvm(ie)%dp_fvm(1:nc,1:nc,:) - call util_function(cdp_fvm,nc,nlev,name_out3,ie) - end if - if (ixcldliq>0) then - cdp_fvm = fvm(ie)%c(1:nc,1:nc,:,ixcldliq)*fvm(ie)%dp_fvm(1:nc,1:nc,:) - call util_function(cdp_fvm,nc,nlev,name_out4,ie) - end if - if (ixcldice>0) then - cdp_fvm = fvm(ie)%c(1:nc,1:nc,:,ixcldice)*fvm(ie)%dp_fvm(1:nc,1:nc,:) - call util_function(cdp_fvm,nc,nlev,name_out5,ie) - end if - if (ixtt>0) then - cdp_fvm = fvm(ie)%c(1:nc,1:nc,:,ixtt)*fvm(ie)%dp_fvm(1:nc,1:nc,:) - call util_function(cdp_fvm,nc,nlev,name_out6,ie) - end if + if (use_cslam) then + if (ixwv>0) then + cdp_fvm = fvm(ie)%c(1:nc,1:nc,:,ixwv)*fvm(ie)%dp_fvm(1:nc,1:nc,:) + call util_function(cdp_fvm,nc,nlev,name_out(wvidx),ie) + end if + ! + ! sum over liquid water + ! + if (thermodynamic_active_species_liq_num>0) then + cdp_fvm = 0.0_r8 + do nq = 1,thermodynamic_active_species_liq_num + cdp_fvm = cdp_fvm + fvm(ie)%c(1:nc,1:nc,:,thermodynamic_active_species_liq_idx(nq))& + *fvm(ie)%dp_fvm(1:nc,1:nc,:) + end do + call util_function(cdp_fvm,nc,nlev,name_out(wlidx),ie) + end if + ! + ! sum over ice water + ! + if (thermodynamic_active_species_ice_num>0) then + cdp_fvm = 0.0_r8 + do nq = 1,thermodynamic_active_species_ice_num + cdp_fvm = cdp_fvm + fvm(ie)%c(1:nc,1:nc,:,thermodynamic_active_species_ice_idx(nq))& + *fvm(ie)%dp_fvm(1:nc,1:nc,:) + end do + call util_function(cdp_fvm,nc,nlev,name_out(wiidx),ie) + end if + if (ixtt>0) then + cdp_fvm = fvm(ie)%c(1:nc,1:nc,:,ixtt)*fvm(ie)%dp_fvm(1:nc,1:nc,:) + call util_function(cdp_fvm,nc,nlev,name_out(ttidx),ie) + end if else - call util_function(elem(ie)%state%qdp(:,:,:,1 ,tl_qdp),np,nlev,name_out3,ie) - if (ixcldliq>0) call util_function(elem(ie)%state%qdp(:,:,:,ixcldliq,tl_qdp),np,nlev,name_out4,ie) - if (ixcldice>0) call util_function(elem(ie)%state%qdp(:,:,:,ixcldice,tl_qdp),np,nlev,name_out5,ie) - if (ixtt>0 ) call util_function(elem(ie)%state%qdp(:,:,:,ixtt ,tl_qdp),np,nlev,name_out6,ie) + cdp = elem(ie)%state%qdp(:,:,:,1,tl_qdp) + call util_function(cdp,np,nlev,name_out(wvidx),ie) + ! + ! sum over liquid water + ! + if (thermodynamic_active_species_liq_num>0) then + cdp = 0.0_r8 + do idx = 1,thermodynamic_active_species_liq_num + cdp = cdp + elem(ie)%state%qdp(:,:,:,thermodynamic_active_species_liq_idx(idx),tl_qdp) + end do + call util_function(cdp,np,nlev,name_out(wlidx),ie) + end if + ! + ! sum over ice water + ! + if (thermodynamic_active_species_ice_num>0) then + cdp = 0.0_r8 + do idx = 1,thermodynamic_active_species_ice_num + cdp = cdp + elem(ie)%state%qdp(:,:,:,thermodynamic_active_species_ice_idx(idx),tl_qdp) + end do + call util_function(cdp,np,nlev,name_out(wiidx),ie) + end if + if (ixtt>0) then + cdp = elem(ie)%state%qdp(:,:,:,ixtt ,tl_qdp) + call util_function(cdp,np,nlev,name_out(ttidx),ie) + end if end if - end do - end if - ! - ! Axial angular momentum diagnostics - ! - ! Code follows - ! - ! Lauritzen et al., (2014): Held-Suarez simulations with the Community Atmosphere Model + end do + ! + ! Axial angular momentum diagnostics + ! + ! Code follows + ! + ! Lauritzen et al., (2014): Held-Suarez simulations with the Community Atmosphere Model ! Spectral Element (CAM-SE) dynamical core: A global axial angularmomentum analysis using Eulerian ! and floating Lagrangian vertical coordinates. J. Adv. Model. Earth Syst. 6,129-140, ! doi:10.1002/2013MS000268 @@ -1752,19 +1674,16 @@ subroutine calc_tot_energy_dynamics(elem,fvm,nets,nete,tl,tl_qdp,outfld_name_suf ! MR is equation (6) without \Delta A and sum over areas (areas are in units of radians**2) ! MO is equation (7) without \Delta A and sum over areas (areas are in units of radians**2) ! - name_out1 = 'MR_' //trim(outfld_name_suffix) - name_out2 = 'MO_' //trim(outfld_name_suffix) - if ( hist_fld_active(name_out1).or.hist_fld_active(name_out2)) then call strlist_get_ind(cnst_name_gll, 'CLDLIQ', ixcldliq, abort=.false.) call strlist_get_ind(cnst_name_gll, 'CLDICE', ixcldice, abort=.false.) - mr_cnst = rearth**3/gravit - mo_cnst = omega*rearth**4/gravit + mr_cnst = rga*rearth**3 + mo_cnst = rga*omega*rearth**4 do ie=nets,nete mr = 0.0_r8 mo = 0.0_r8 - call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,tl_qdp),MASS_MIXING_RATIO,thermodynamic_active_species_idx_dycore,& - elem(ie)%state%dp3d(:,:,:,tl),pdel,ps=ps,ptop=hyai(1)*ps0) + call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,tl_qdp), MASS_MIXING_RATIO, thermodynamic_active_species_idx_dycore,& + elem(ie)%state%dp3d(:,:,:,tl), pdel) do k = 1, nlev do j=1,np do i = 1, np @@ -1777,20 +1696,17 @@ subroutine calc_tot_energy_dynamics(elem,fvm,nets,nete,tl,tl_qdp,outfld_name_suf end do end do end do - call outfld(name_out1 ,mr ,npsq,ie) - call outfld(name_out2 ,mo ,npsq,ie) + call history_out_field(name_out(mridx), mr) + call history_out_field(name_out(moidx), mo) end do - end if - + end if ! if thermo budget history #endif - - end subroutine calc_tot_energy_dynamics + end subroutine tot_energy_dyn subroutine output_qdp_var_dynamics(qdp,nx,num_trac,nets,nete,outfld_name) - use dimensions_mod, only: nlev,ntrac -!Un-comment once constituents and history outputs are enabled -JN: -! use cam_history , only: outfld, hist_fld_active -! use constituents , only: cnst_get_ind + use dimensions_mod, only: nlev,ntrac + use cam_history , only: is_history_field_active + use cam_constituents, only: const_get_index !------------------------------Arguments-------------------------------- integer ,intent(in) :: nx,num_trac,nets,nete @@ -1804,20 +1720,19 @@ subroutine output_qdp_var_dynamics(qdp,nx,num_trac,nets,nete,outfld_name) character(len=16) :: name_out1,name_out2,name_out3,name_out4 !----------------------------------------------------------------------- -!Un-comment once history outputs are enabled -JN: -#if 0 - name_out1 = 'WV_' //trim(outfld_name) name_out2 = 'WI_' //trim(outfld_name) name_out3 = 'WL_' //trim(outfld_name) name_out4 = 'TT_' //trim(outfld_name) - if ( hist_fld_active(name_out1).or.hist_fld_active(name_out2).or.hist_fld_active(name_out3).or.& - hist_fld_active(name_out4)) then + if ( is_history_field_active(name_out1).or.& + is_history_field_active(name_out2).or.& + is_history_field_active(name_out3).or.& + is_history_field_active(name_out4)) then - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - call cnst_get_ind('TT_LW' , ixtt , abort=.false.) + call const_get_index('cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water', ixcldliq, abort=.false.) + call const_get_index('cloud_ice_mixing_ratio_wrt_moist_air_and_condensed_water', ixcldice, abort=.false.) + call const_get_index('TT_LW' , ixtt , abort=.false.) do ie=nets,nete call util_function(qdp(:,:,:,1,ie),nx,nlev,name_out1,ie) @@ -1826,27 +1741,23 @@ subroutine output_qdp_var_dynamics(qdp,nx,num_trac,nets,nete,outfld_name) if (ixtt>0 ) call util_function(qdp(:,:,:,ixtt ,ie),nx,nlev,name_out4,ie) end do end if -#endif end subroutine output_qdp_var_dynamics ! ! column integrate mass-variable and outfld ! subroutine util_function(f_in,nx,nz,name_out,ie) - use dynconst, only: gravit -!Un-comment once history outputs are enabled -JN: -! use cam_history, only: outfld, hist_fld_active + use physconst, only: rga + use cam_history, only: history_out_field, is_history_field_active + integer, intent(in) :: nx,nz,ie real(kind=r8), intent(in) :: f_in(nx,nx,nz) character(len=16), intent(in) :: name_out real(kind=r8) :: f_out(nx*nx) integer :: i,j,k - real(kind=r8) :: inv_g -!Un-comment once history outputs are enabled -JN: -#if 0 - if (hist_fld_active(name_out)) then + + if (is_history_field_active(name_out)) then f_out = 0.0_r8 - inv_g = 1.0_r8/gravit do k = 1, nz do j = 1, nx do i = 1, nx @@ -1854,21 +1765,21 @@ subroutine util_function(f_in,nx,nz,name_out,ie) end do end do end do - f_out = f_out*inv_g - call outfld(name_out,f_out,nx*nx,ie) + f_out = f_out*rga + call history_out_field(name_out,f_out) end if -#endif + end subroutine util_function subroutine compute_omega(hybrid,n0,qn0,elem,deriv,nets,nete,dt,hvcoord) - use control_mod, only : nu_p, hypervis_subcycle - use dimensions_mod, only : np, nlev, qsize - use hybrid_mod, only : hybrid_t - use element_mod, only : element_t - use derivative_mod, only : divergence_sphere, derivative_t,gradient_sphere - use hybvcoord_mod, only : hvcoord_t - use edge_mod, only : edgevpack, edgevunpack - use bndry_mod, only : bndry_exchange + use control_mod, only: nu_p, hypervis_subcycle + use dimensions_mod, only: np, nlev, qsize + use hybrid_mod, only: hybrid_t + use element_mod, only: element_t + use derivative_mod, only: divergence_sphere, derivative_t,gradient_sphere + use hybvcoord_mod, only: hvcoord_t + use edge_mod, only: edgevpack, edgevunpack + use bndry_mod, only: bndry_exchange use viscosity_mod, only: biharmonic_wk_omega use air_composition,only: thermodynamic_active_species_num use air_composition,only: thermodynamic_active_species_idx_dycore @@ -1887,19 +1798,19 @@ subroutine compute_omega(hybrid,n0,qn0,elem,deriv,nets,nete,dt,hvcoord) real (kind=r8) :: dp_full(np,np,nlev) real (kind=r8) :: p_full(np,np,nlev),grad_p_full(np,np,2),vgrad_p_full(np,np,nlev) real (kind=r8) :: divdp_full(np,np,nlev),vdp_full(np,np,2) - real(kind=r8) :: Otens(np,np ,nlev,nets:nete), dt_hyper, sum_water(np,np,nlev) + real(kind=r8) :: Otens(np,np ,nlev,nets:nete), dt_hyper logical, parameter :: del4omega = .true. do ie=nets,nete - call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,qn0),MASS_MIXING_RATIO,& - thermodynamic_active_species_idx_dycore,elem(ie)%state%dp3d(:,:,:,n0),dp_full) + call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,qn0), MASS_MIXING_RATIO,& + thermodynamic_active_species_idx_dycore, elem(ie)%state%dp3d(:,:,:,n0), dp_full) do k=1,nlev if (k==1) then p_full(:,:,k) = hvcoord%hyai(k)*hvcoord%ps0 + dp_full(:,:,k)/2 else p_full(:,:,k)=p_full(:,:,k-1) + dp_full(:,:,k-1)/2 + dp_full(:,:,k)/2 - endif + end if call gradient_sphere(p_full(:,:,k),deriv,elem(ie)%Dinv,grad_p_full (:,:,:)) do j=1,np do i=1,np @@ -1975,366 +1886,4 @@ subroutine compute_omega(hybrid,n0,qn0,elem,deriv,nets,nete,dt,hvcoord) !call FreeEdgeBuffer(edgeOmega) end subroutine compute_omega - - subroutine calc_dp3d_reference(elem,edge3,hybrid,nets,nete,nt,hvcoord,dp3d_ref) - ! - ! calc_dp3d_reference: When the del^4 horizontal damping is applied to dp3d - ! the values are implicitly affected by natural variations - ! due to surface topography. - ! - ! To account for these physicaly correct variations, use - ! the current state values to compute appropriate - ! reference values for the current (lagrangian) ETA-surfaces. - ! Damping should then be applied to values relative to - ! this reference. - !======================================================================= - use hybvcoord_mod , only: hvcoord_t - use dynconst, only: rair, cappa - use element_mod, only: element_t - use dimensions_mod, only: np,nlev - use hybrid_mod, only: hybrid_t - use edge_mod, only: edgevpack, edgevunpack - use bndry_mod, only: bndry_exchange - ! - ! Passed variables - !------------------- - type(element_t ),target,intent(inout):: elem(:) - type(EdgeBuffer_t) ,intent(inout):: edge3 - type(hybrid_t ) ,intent(in ):: hybrid - integer ,intent(in ):: nets,nete - integer ,intent(in ):: nt - type(hvcoord_t ) ,intent(in ):: hvcoord - real(kind=r8) ,intent(out ):: dp3d_ref(np,np,nlev,nets:nete) - ! - ! Local Values - !-------------- - real(kind=r8):: Phis_avg(np,np, nets:nete) - real(kind=r8):: Phi_avg (np,np,nlev,nets:nete) - real(kind=r8):: RT_avg (np,np,nlev,nets:nete) - real(kind=r8):: P_val (np,np,nlev) - real(kind=r8):: Ps_val (np,np) - real(kind=r8):: Phi_val (np,np,nlev) - real(kind=r8):: Phi_ival(np,np) - real(kind=r8):: I_Phi (np,np,nlev+1) - real(kind=r8):: Alpha (np,np,nlev ) - real(kind=r8):: I_P (np,np,nlev+1) - real(kind=r8):: DP_avg (np,np,nlev) - real(kind=r8):: P_avg (np,np,nlev) - real(kind=r8):: Ps_avg (np,np) - real(kind=r8):: Ps_ref (np,np) - real(kind=r8):: RT_lapse(np,np) - real(kind=r8):: dlt_Ps (np,np) - real(kind=r8):: dPhi (np,np,nlev) - real(kind=r8):: dPhis (np,np) - real(kind=r8):: E_Awgt,E_phis,E_phi(nlev),E_T(nlev),Lapse0,Expon0 - integer :: ie,ii,jj,kk,kptr - - ! Loop over elements - !-------------------- - do ie=nets,nete - - ! Calculate Pressure values from dp3dp - !-------------------------------------- - P_val(:,:,1) = hvcoord%hyai(1)*hvcoord%ps0 + elem(ie)%state%dp3d(:,:,1,nt)*0.5_r8 - do kk=2,nlev - P_val(:,:,kk) = P_val(:,:,kk-1) & - + elem(ie)%state%dp3d(:,:,kk-1,nt)*0.5_r8 & - + elem(ie)%state%dp3d(:,:,kk ,nt)*0.5_r8 - end do - Ps_val(:,:) = P_val(:,:,nlev) + elem(ie)%state%dp3d(:,:,nlev,nt)*0.5_r8 - - ! Calculate (dry) geopotential values - !-------------------------------------- - dPhi (:,:,:) = 0.5_r8*(rair*elem(ie)%state%T (:,:,:,nt) & - *elem(ie)%state%dp3d(:,:,:,nt) & - /P_val(:,:,:) ) - Phi_val (:,:,nlev) = elem(ie)%state%phis(:,:) + dPhi(:,:,nlev) - Phi_ival(:,:) = elem(ie)%state%phis(:,:) + dPhi(:,:,nlev)*2._r8 - do kk=(nlev-1),1,-1 - Phi_val (:,:,kk) = Phi_ival(:,:) + dPhi(:,:,kk) - Phi_ival(:,:) = Phi_val (:,:,kk) + dPhi(:,:,kk) - end do - - ! Calculate Element averages - !---------------------------- - E_Awgt = 0.0_r8 - E_phis = 0.0_r8 - E_phi(:) = 0._r8 - E_T (:) = 0._r8 - do jj=1,np - do ii=1,np - E_Awgt = E_Awgt + elem(ie)%spheremp(ii,jj) - E_phis = E_phis + elem(ie)%spheremp(ii,jj)*elem(ie)%state%phis(ii,jj) - E_phi (:) = E_phi (:) + elem(ie)%spheremp(ii,jj)*Phi_val(ii,jj,:) - E_T (:) = E_T (:) + elem(ie)%spheremp(ii,jj)*elem(ie)%state%T(ii,jj,:,nt) - end do - end do - - Phis_avg(:,:,ie) = E_phis/E_Awgt - do kk=1,nlev - Phi_avg(:,:,kk,ie) = E_phi(kk) /E_Awgt - RT_avg (:,:,kk,ie) = E_T (kk)*rair/E_Awgt - end do - end do ! ie=nets,nete - - ! Boundary Exchange of average values - !------------------------------------- - do ie=nets,nete - Phis_avg(:,:,ie) = elem(ie)%spheremp(:,:)*Phis_avg(:,:,ie) - do kk=1,nlev - Phi_avg(:,:,kk,ie) = elem(ie)%spheremp(:,:)*Phi_avg(:,:,kk,ie) - RT_avg (:,:,kk,ie) = elem(ie)%spheremp(:,:)*RT_avg (:,:,kk,ie) - end do - kptr = 0 - call edgeVpack(edge3,Phi_avg(:,:,:,ie),nlev,kptr,ie) - kptr = nlev - call edgeVpack(edge3,RT_avg (:,:,:,ie),nlev,kptr,ie) - kptr = 2*nlev - call edgeVpack(edge3,Phis_avg (:,:,ie),1 ,kptr,ie) - end do ! ie=nets,nete - - call bndry_exchange(hybrid,edge3,location='calc_dp3d_reference') - - do ie=nets,nete - kptr = 0 - call edgeVunpack(edge3,Phi_avg(:,:,:,ie),nlev,kptr,ie) - kptr = nlev - call edgeVunpack(edge3,RT_avg (:,:,:,ie),nlev,kptr,ie) - kptr = 2*nlev - call edgeVunpack(edge3,Phis_avg (:,:,ie),1 ,kptr,ie) - Phis_avg(:,:,ie) = elem(ie)%rspheremp(:,:)*Phis_avg(:,:,ie) - do kk=1,nlev - Phi_avg(:,:,kk,ie) = elem(ie)%rspheremp(:,:)*Phi_avg(:,:,kk,ie) - RT_avg (:,:,kk,ie) = elem(ie)%rspheremp(:,:)*RT_avg (:,:,kk,ie) - end do - end do ! ie=nets,nete - - ! Loop over elements - !-------------------- - do ie=nets,nete - - ! Fill elements with uniformly varying average values - !----------------------------------------------------- - call fill_element(Phis_avg(1,1,ie)) - do kk=1,nlev - call fill_element(Phi_avg(1,1,kk,ie)) - call fill_element(RT_avg (1,1,kk,ie)) - end do - - ! Integrate upward to compute Alpha == (dp3d/P) - !---------------------------------------------- - I_Phi(:,:,nlev+1) = Phis_avg(:,:,ie) - do kk=nlev,1,-1 - I_Phi(:,:,kk) = 2._r8* Phi_avg(:,:,kk,ie) - I_Phi(:,:,kk+1) - Alpha(:,:,kk) = 2._r8*(Phi_avg(:,:,kk,ie) - I_Phi(:,:,kk+1))/RT_avg(:,:,kk,ie) - end do - - ! Integrate downward to compute corresponding average pressure values - !--------------------------------------------------------------------- - I_P(:,:,1) = hvcoord%hyai(1)*hvcoord%ps0 - do kk=1,nlev - DP_avg(:,:,kk ) = I_P(:,:,kk)*(2._r8 * Alpha(:,:,kk))/(2._r8 - Alpha(:,:,kk)) - P_avg (:,:,kk ) = I_P(:,:,kk)*(2._r8 )/(2._r8 - Alpha(:,:,kk)) - I_P (:,:,kk+1) = I_P(:,:,kk)*(2._r8 + Alpha(:,:,kk))/(2._r8 - Alpha(:,:,kk)) - end do - Ps_avg(:,:) = I_P(:,:,nlev+1) - - ! Determine an appropriate d/d lapse rate near the surface - ! OPTIONALLY: Use dry adiabatic lapse rate or environmental lapse rate. - !----------------------------------------------------------------------- - if(.FALSE.) then - ! DRY ADIABATIC laspe rate - !------------------------------ - RT_lapse(:,:) = -1._r8*cappa - else - ! ENVIRONMENTAL (empirical) laspe rate - !-------------------------------------- - RT_lapse(:,:) = (RT_avg (:,:,nlev-1,ie)-RT_avg (:,:,nlev,ie)) & - /(Phi_avg(:,:,nlev-1,ie)-Phi_avg(:,:,nlev,ie)) - endif - - ! Calcualte reference surface pressure - !-------------------------------------- - dPhis(:,:) = elem(ie)%state%phis(:,:)-Phis_avg(:,:,ie) - do jj=1,np - do ii=1,np - if (abs(RT_lapse(ii,jj)) .gt. 1.e-3_r8) then - Lapse0 = RT_lapse(ii,jj)/RT_avg(ii,jj,nlev,ie) - Expon0 = (-1._r8/RT_lapse(ii,jj)) - Ps_ref(ii,jj) = Ps_avg(ii,jj)*((1._r8 + Lapse0*dPhis(ii,jj))**Expon0) - else - Ps_ref(ii,jj) = Ps_avg(ii,jj)*exp(-dPhis(ii,jj)/RT_avg(ii,jj,nlev,ie)) - endif - end do - end do - - ! Calculate reference dp3d values - !--------------------------------- - dlt_Ps(:,:) = Ps_ref(:,:) - Ps_avg(:,:) - do kk=1,nlev - dp3d_ref(:,:,kk,ie) = DP_avg(:,:,kk) + (hvcoord%hybi(kk+1) & - -hvcoord%hybi(kk ))*dlt_Ps(:,:) - end do - - end do ! ie=nets,nete - - ! End Routine - !------------ - return - end subroutine calc_dp3d_reference - !============================================================================= - - - !============================================================================= - subroutine fill_element(Eval) - ! - ! fill_element_bilin: Fill in element gridpoints using local bi-linear - ! interpolation of nearby average values. - ! - ! NOTE: This routine is hard coded for NP=4, if a - ! different value of NP is used... bad things - ! will happen. - !======================================================================= - use dimensions_mod,only: np - ! - ! Passed variables - !------------------- - real(kind=r8),intent(inout):: Eval(np,np) - ! - ! Local Values - !-------------- - real(kind=r8):: X0 - real(kind=r8):: S1,S2,S3,S4 - real(kind=r8):: C1,C2,C3,C4 - real(kind=r8):: E1,E2,E3,E4,E0 - - X0 = sqrt(1._r8/5._r8) - - ! Set the "known" values Eval - !---------------------------- - S1 = (Eval(1 ,2 )+Eval(1 ,3 ))/2._r8 - S2 = (Eval(2 ,np)+Eval(3 ,np))/2._r8 - S3 = (Eval(np,2 )+Eval(np,3 ))/2._r8 - S4 = (Eval(2 ,1 )+Eval(3 ,1 ))/2._r8 - C1 = Eval(1 ,1 ) - C2 = Eval(1 ,np) - C3 = Eval(np,np) - C4 = Eval(np,1 ) - - ! E0 OPTION: Element Center value: - !--------------------------------- - IF(.FALSE.) THEN - ! Use ELEMENT AVERAGE value contained in (2,2) - !---------------------------------------------- - E0 = Eval(2,2) - ELSE - ! Use AVG OF SIDE VALUES after boundary exchange of E0 (smooting option) - !----------------------------------------------------------------------- - E0 = (S1 + S2 + S3 + S4)/4._r8 - ENDIF - - ! Calc interior values along center axes - !---------------------------------------- - E1 = E0 + X0*(S1-E0) - E2 = E0 + X0*(S2-E0) - E3 = E0 + X0*(S3-E0) - E4 = E0 + X0*(S4-E0) - - ! Calculate Side Gridpoint Values for Eval - !------------------------------------------ - Eval(1 ,2 ) = S1 + X0*(C1-S1) - Eval(1 ,3 ) = S1 + X0*(C2-S1) - Eval(2 ,np) = S2 + X0*(C2-S2) - Eval(3 ,np) = S2 + X0*(C3-S2) - Eval(np,2 ) = S3 + X0*(C4-S3) - Eval(np,3 ) = S3 + X0*(C3-S3) - Eval(2 ,1 ) = S4 + X0*(C1-S4) - Eval(3 ,1 ) = S4 + X0*(C4-S4) - - ! Calculate interior values - !--------------------------- - Eval(2 ,2 ) = E1 + X0*(Eval(2 ,1 )-E1) - Eval(2 ,3 ) = E1 + X0*(Eval(2 ,np)-E1) - Eval(3 ,2 ) = E3 + X0*(Eval(3 ,1 )-E3) - Eval(3 ,3 ) = E3 + X0*(Eval(3 ,np)-E3) - - ! End Routine - !------------ - return - end subroutine fill_element - - subroutine rayleigh_friction(elem,nt,nets,nete,dt) - use dimensions_mod, only: nlev, otau - use hybrid_mod, only: hybrid_t!, get_loop_ranges - use element_mod, only: element_t - - type (element_t) , intent(inout), target :: elem(:) - integer , intent(in) :: nets,nete, nt - real(r8) :: dt - - real(r8) :: c1, c2 - integer :: k,ie - - do ie=nets,nete - do k=1,nlev - c2 = 1._r8 / (1._r8 + otau(k)*dt) - c1 = -otau(k) * c2 * dt - elem(ie)%state%v(:,:,:,k,nt) = elem(ie)%state%v(:,:,:,k,nt)+c1 * elem(ie)%state%v(:,:,:,k,nt) -! ptend%s(:ncol,k) = c3 * (state%u(:ncol,k)**2 + state%v(:ncol,k)**2) - enddo - end do - end subroutine rayleigh_friction - - - - subroutine solve_diffusion(dt,nx,nlev,i,j,nlay,pmid,pint,km,fld,boundary_condition,dfld) - use dynconst, only: gravit - real(kind=r8), intent(in) :: dt - integer , intent(in) :: nlay, nlev,nx, i, j - real(kind=r8), intent(in) :: pmid(nx,nx,nlay),pint(nx,nx,nlay+1),km(nx,nx,nlay+1) - real(kind=r8), intent(in) :: fld(nx,nx,nlev) - real(kind=r8), intent(out) :: dfld(nlay) - integer :: boundary_condition - ! - real(kind=r8), dimension(nlay) :: current_guess,next_iterate - real(kind=r8) :: alp, alm, value_level0 - integer :: k,iter, niterations=4 - - ! Make the guess for the next time step equal to the initial value - current_guess(:)= fld(i,j,1:nlay) - do iter = 1, niterations - ! two formulations of the upper boundary condition - !next_iterate(1) = (initial_value(1) + alp * current_guess(i+1) + alm * current_guess(1)) /(1. + alp + alm) ! top BC, u'=0 - if (boundary_condition==0) then - next_iterate(1) = fld(i,j,1) ! u doesn't get prognosed by diffusion at top - else if (boundary_condition==1) then - value_level0 = 0.75_r8*fld(i,j,1) ! value above sponge - k=1 - alp = dt*(km(i,j,k+1)*gravit*gravit/(pmid(i,j,k)-pmid(i,j,k+1)))/(pint(i,j,k)-pint(i,j,k+1)) - alm = dt*(km(i,j,k )*gravit*gravit/(0.5_r8*(pmid(i,j,1)-pmid(i,j,2))))/(pint(i,j,k)-pint(i,j,k+1)) - next_iterate(k) = (fld(i,j,k) + alp * current_guess(k+1) + alm * value_level0)/(1._r8 + alp + alm) - else - ! - ! set fld'=0 at model top - ! - k=1 - alp = dt*(km(i,j,k+1)*gravit*gravit/(pmid(i,j,k)-pmid(i,j,k+1)))/(pint(i,j,k)-pint(i,j,k+1)) - alm = dt*(km(i,j,k )*gravit*gravit/(0.5_r8*(pmid(i,j,1)-pmid(i,j,2))))/(pint(i,j,k)-pint(i,j,k+1)) - next_iterate(k) = (fld(i,j,1) + alp * current_guess(2) + alm * current_guess(1))/(1._r8 + alp + alm) - end if - do k = 2, nlay-1 - alp = dt*(km(i,j,k+1)*gravit*gravit/(pmid(i,j,k )-pmid(i,j,k+1)))/(pint(i,j,k)-pint(i,j,k+1)) - alm = dt*(km(i,j,k )*gravit*gravit/(pmid(i,j,k-1)-pmid(i,j,k )))/(pint(i,j,k)-pint(i,j,k+1)) - next_iterate(k) = (fld(i,j,k) + alp * current_guess(k+1) + alm * current_guess(k-1))/(1._r8 + alp + alm) - end do - next_iterate(nlay) = (fld(i,j,nlay) + alp * fld(i,j,nlay) + alm * current_guess(nlay-1))/(1._r8 + alp + alm) ! bottom BC - - ! before the next iterate, make the current guess equal to the values of the last iteration - current_guess(:) = next_iterate(:) - end do - dfld(:) = next_iterate(:) - fld(i,j,1:nlay) - - end subroutine solve_diffusion - - end module prim_advance_mod diff --git a/src/dynamics/se/dycore/prim_advection_mod.F90 b/src/dynamics/se/dycore/prim_advection_mod.F90 index f1ea126ea..94b6c088d 100644 --- a/src/dynamics/se/dycore/prim_advection_mod.F90 +++ b/src/dynamics/se/dycore/prim_advection_mod.F90 @@ -22,7 +22,7 @@ module prim_advection_mod use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct use hybvcoord_mod, only: hvcoord_t - use time_mod, only: TimeLevel_t, TimeLevel_Qdp + use se_dyn_time_mod, only: TimeLevel_t, TimeLevel_Qdp use control_mod, only: nu_q, nu_p, limiter_option, hypervis_subcycle_q, rsplit use edge_mod, only: edgevpack, edgevunpack, initedgebuffer, initedgesbuffer @@ -44,7 +44,7 @@ module prim_advection_mod public :: prim_advec_tracers_fvm public :: vertical_remap - type (EdgeBuffer_t) :: edgeAdv, edgeAdvp1, edgeAdvQminmax, edgeAdv1, edgeveloc + type (EdgeBuffer_t) :: edgeAdv, edgeAdvp1, edgeAdvQminmax, edgeveloc integer,parameter :: DSSeta = 1 integer,parameter :: DSSomega = 2 @@ -62,7 +62,7 @@ module prim_advection_mod subroutine Prim_Advec_Init1(par, elem) - use dimensions_mod, only: nlev, qsize, nelemd,ntrac + use dimensions_mod, only: nlev, qsize, nelemd,ntrac,use_cslam use parallel_mod, only: parallel_t, boundaryCommMethod use cam_abortutils, only: check_allocate type(parallel_t) :: par @@ -82,7 +82,7 @@ subroutine Prim_Advec_Init1(par, elem) ! ! Set the number of threads used in the subroutine Prim_Advec_tracers_remap() ! - if (ntrac>0) then + if (use_cslam) then advec_remap_num_threads = 1 else advec_remap_num_threads = tracer_num_threads @@ -91,17 +91,17 @@ subroutine Prim_Advec_Init1(par, elem) ! allocate largest one first ! Currently this is never freed. If it was, only this first one should ! be freed, as only it knows the true size of the buffer. - call initEdgeBuffer(par,edgeAdvp1,elem,qsize*nlev + nlev,bndry_type=boundaryCommMethod,& - nthreads=horz_num_threads*advec_remap_num_threads) - call initEdgeBuffer(par,edgeAdv,elem,qsize*nlev,bndry_type=boundaryCommMethod, & - nthreads=horz_num_threads*advec_remap_num_threads) - ! This is a different type of buffer pointer allocation - ! used for determine the minimum and maximum value from - ! neighboring elements - call initEdgeSBuffer(par,edgeAdvQminmax,elem,qsize*nlev*2,bndry_type=boundaryCommMethod, & - nthreads=horz_num_threads*advec_remap_num_threads) - - call initEdgeBuffer(par,edgeAdv1,elem,nlev,bndry_type=boundaryCommMethod) + if (.not.use_cslam) then + call initEdgeBuffer(par,edgeAdvp1,elem,qsize*nlev + nlev,bndry_type=boundaryCommMethod,& + nthreads=horz_num_threads*advec_remap_num_threads) + call initEdgeBuffer(par,edgeAdv,elem,qsize*nlev,bndry_type=boundaryCommMethod, & + nthreads=horz_num_threads*advec_remap_num_threads) + ! This is a different type of buffer pointer allocation + ! used for determine the minimum and maximum value from + ! neighboring elements + call initEdgeSBuffer(par,edgeAdvQminmax,elem,qsize*nlev*2,bndry_type=boundaryCommMethod, & + nthreads=horz_num_threads*advec_remap_num_threads) + end if call initEdgeBuffer(par,edgeveloc,elem,2*nlev,bndry_type=boundaryCommMethod) @@ -181,8 +181,6 @@ subroutine Prim_Advec_Tracers_remap( elem , deriv , hvcoord , hybrid , dt , tl , integer , intent(in ) :: nets integer , intent(in ) :: nete - - !print *,'prim_Advec_Tracers_remap: qsize: ',qsize call Prim_Advec_Tracers_remap_rk2( elem , deriv , hvcoord , hybrid , dt , tl , nets , nete ) end subroutine Prim_Advec_Tracers_remap @@ -231,10 +229,9 @@ end subroutine euler_step_driver !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- subroutine Prim_Advec_Tracers_remap_rk2( elem , deriv , hvcoord , hybrid , dt , tl , nets , nete ) - use derivative_mod, only : divergence_sphere - use control_mod , only : qsplit - use hybrid_mod , only : get_loop_ranges!, PrintHybrid -! use thread_mod , only : omp_set_num_threads, omp_get_thread_num + use derivative_mod, only: divergence_sphere + use control_mod , only: qsplit + use hybrid_mod , only: get_loop_ranges type (element_t) , intent(inout) :: elem(:) type (derivative_t) , intent(in ) :: deriv @@ -321,7 +318,7 @@ subroutine qdp_time_avg( elem , rkstage , n0_qdp , np1_qdp , hybrid , nets , net use hybrid_mod, only : hybrid_t, get_loop_ranges implicit none type(element_t) , intent(inout) :: elem(:) - integer , intent(in ) :: rkstage , n0_qdp , np1_qdp , nets , nete + integer , intent(in ) :: rkstage , n0_qdp , np1_qdp , nets , nete type(hybrid_t) :: hybrid integer :: i,j,ie,q,k integer :: kbeg,kend,qbeg,qend @@ -333,7 +330,7 @@ subroutine qdp_time_avg( elem , rkstage , n0_qdp , np1_qdp , hybrid , nets , net do ie=nets,nete do q=qbeg,qend do k=kbeg,kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -363,7 +360,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , ! ! =================================== use dimensions_mod , only : np, nlev - use hybrid_mod , only : hybrid_t!, PrintHybrid + use hybrid_mod , only : hybrid_t use hybrid_mod , only : get_loop_ranges, threadOwnsTracer use element_mod , only : element_t use derivative_mod , only : derivative_t, divergence_sphere, limiter_optim_iter_full @@ -446,7 +443,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , do ie = nets, nete ! add hyperviscosity to RHS. apply to Q at timelevel n0, Qdp(n0)/dp do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -486,7 +483,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , if ( nu_p > 0 ) then do ie = nets, nete do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -497,7 +494,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , do q = qbeg,qend do k = kbeg, kend ! NOTE: divide by dp0 since we multiply by dp0 below - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -521,7 +518,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , do ie = nets, nete do q = qbeg, qend do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -543,7 +540,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , do ie = nets, nete do q = qbeg, qend do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -572,7 +569,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , do k = kbeg, kend ! derived variable divdp_proj() (DSS'd version of divdp) will only be correct on 2nd and 3rd stage ! but that's ok because rhs_multiplier=0 on the first stage: - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -586,7 +583,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , ! Note that the term dpdissk is independent of Q do k = kbeg, kend ! UN-DSS'ed dp at timelevel n0+1: - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -597,7 +594,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , ! add contribution from UN-DSS'ed PS dissipation ! dpdiss(:,:) = ( hvcoord%hybi(k+1) - hvcoord%hybi(k) ) * ! elem(ie)%derived%psdiss_biharmonic(:,:) - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -619,7 +616,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , do q = qbeg, qend do k = kbeg, kend ! div( U dp Q), - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -640,8 +637,8 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , enddo ! optionally add in hyperviscosity computed above: - if ( rhs_viss /= 0 ) then - !OMP_COLLAPSE_SIMD + if ( rhs_viss /= 0 ) then + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -662,7 +659,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , ! dont do this earlier, since we allow np1_qdp == n0_qdp ! and we dont want to overwrite n0_qdp until we are done using it do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -693,7 +690,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , if ( DSSopt == DSSdiv_vdp_ave ) DSSvar => elem(ie)%derived%divdp_proj(:,:,:) ! also DSS extra field do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -718,7 +715,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , kptr = qsize*nlev + kbeg -1 call edgeVunpack( edgeAdvp1 , DSSvar(:,:,kbeg:kend) , kblk , kptr , ie ) do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -732,7 +729,7 @@ subroutine euler_step( np1_qdp , n0_qdp , dt , elem , hvcoord , hybrid , deriv , kptr = nlev*(q-1) + kbeg - 1 call edgeVunpack( edgeAdvp1 , elem(ie)%state%Qdp(:,:,kbeg:kend,q,np1_qdp) , kblk , kptr , ie ) do k = kbeg, kend - !OMP_COLLAPSE_SIMD + !OMP_COLLAPSE_SIMD !DIR_VECTOR_ALIGNED do j=1,np do i=1,np @@ -806,7 +803,7 @@ subroutine advance_hypervis_scalar( edgeAdv , elem , hvcoord , hybrid , deriv , ! ! For correct scaling, dt2 should be the same 'dt2' used in the leapfrog advace use dimensions_mod , only : np, nlev - use hybrid_mod , only : hybrid_t!, PrintHybrid + use hybrid_mod , only : hybrid_t use hybrid_mod , only : get_loop_ranges use element_mod , only : element_t use derivative_mod , only : derivative_t @@ -948,22 +945,23 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) ! ! map tracers ! map velocity components - ! map temperature (either by mapping thermal energy or virtual temperature over log(p) + ! map temperature (either by mapping enthalpy or virtual temperature + ! over log(p) ! (controlled by vert_remap_uvTq_alg > -20 or <= -20) ! - use hybvcoord_mod , only: hvcoord_t - use vertremap_mod , only: remap1 - use hybrid_mod , only: hybrid_t, config_thread_region,get_loop_ranges, PrintHybrid + use hybvcoord_mod, only: hvcoord_t + use vertremap_mod, only: remap1 + use hybrid_mod, only: hybrid_t, config_thread_region,get_loop_ranges use fvm_control_volume_mod, only: fvm_struct - use dimensions_mod , only: ntrac - use dimensions_mod , only: lcp_moist, kord_tr,kord_tr_cslam - use cam_logfile , only: iulog - use dynconst , only: pi - use dyn_thermo , only: get_enthalpy, get_dp, get_virtual_temp - use cam_thermo , only: MASS_MIXING_RATIO - use air_composition , only: thermodynamic_active_species_idx_dycore - use thread_mod , only: omp_set_nested - use control_mod , only: vert_remap_uvTq_alg + use dimensions_mod, only: use_cslam, ntrac + use dimensions_mod, only: kord_tr,kord_tr_cslam + use cam_logfile, only: iulog + use dynconst, only: pi + use air_composition, only: thermodynamic_active_species_idx_dycore + use dyn_thermo, only: get_enthalpy, get_virtual_temp, get_dp + use cam_thermo, only: MASS_MIXING_RATIO + use thread_mod, only: omp_set_nested + use control_mod, only: vert_remap_uvTq_alg type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) type(fvm_struct), intent(inout) :: fvm(:) @@ -974,7 +972,7 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) type (hvcoord_t) :: hvcoord integer :: ie,i,j,k,np1,nets,nete,np1_qdp,q, m_cnst real (kind=r8), dimension(np,np,nlev) :: dp_moist,dp_star_moist, dp_dry,dp_star_dry - real (kind=r8), dimension(np,np,nlev) :: internal_energy_star + real (kind=r8), dimension(np,np,nlev) :: enthalpy_star real (kind=r8), dimension(np,np,nlev,2):: ttmp real(r8), parameter :: rad2deg = 180.0_r8/pi integer :: region_num_threads,qbeg,qend,kord_uvT(1) @@ -989,23 +987,20 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) ! prepare for mapping of temperature ! if (vert_remap_uvTq_alg>-20) then - if (lcp_moist) then - ! - ! compute internal energy on Lagrangian levels - ! (do it here since qdp is overwritten by remap1) - ! - call get_enthalpy(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), & - elem(ie)%state%t(:,:,:,np1),elem(ie)%state%dp3d(:,:,:,np1),internal_energy_star, & - active_species_idx_dycore=thermodynamic_active_species_idx_dycore) - end if + ! + ! compute enthalpy on Lagrangian levels + ! (do it here since qdp is overwritten by remap1) + ! + call get_enthalpy(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), & + elem(ie)%state%t(:,:,:,np1), elem(ie)%state%dp3d(:,:,:,np1), enthalpy_star, & + active_species_idx_dycore=thermodynamic_active_species_idx_dycore) else ! ! map Tv over log(p) following FV and FV3 ! - call get_virtual_temp(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), & - internal_energy_star,dp_dry=elem(ie)%state%dp3d(:,:,:,np1), & - active_species_idx_dycore=thermodynamic_active_species_idx_dycore) - internal_energy_star = internal_energy_star*elem(ie)%state%t(:,:,:,np1) + call get_virtual_temp(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), enthalpy_star, & + dp_dry=elem(ie)%state%dp3d(:,:,:,np1), active_species_idx_dycore=thermodynamic_active_species_idx_dycore) + enthalpy_star = enthalpy_star*elem(ie)%state%t(:,:,:,np1) end if ! ! update final psdry @@ -1013,17 +1008,18 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) elem(ie)%state%psdry(:,:) = ptop + & sum(elem(ie)%state%dp3d(:,:,:,np1),3) ! - ! compute dry vertical coordinate (Lagrangian and reference levels) + ! compute dry vertical coordinate (Lagrangian and reference + ! levels) ! do k=1,nlev dp_star_dry(:,:,k) = elem(ie)%state%dp3d(:,:,k,np1) - dp_dry(:,:,k) = ( hvcoord%hyai(k+1) - hvcoord%hyai(k) )*hvcoord%ps0 + & - ( hvcoord%hybi(k+1) - hvcoord%hybi(k) )*elem(ie)%state%psdry(:,:) + dp_dry(:,:,k) = ( hvcoord%hyai(k+1) - hvcoord%hyai(k))*hvcoord%ps0 + & + ( hvcoord%hybi(k+1) - hvcoord%hybi(k))*elem(ie)%state%psdry(:,:) elem(ie)%state%dp3d(:,:,k,np1) = dp_dry(:,:,k) enddo ! call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,np1_qdp),MASS_MIXING_RATIO,& - thermodynamic_active_species_idx_dycore,dp_star_dry,dp_star_moist(:,:,:)) + thermodynamic_active_species_idx_dycore, dp_star_dry,dp_star_moist(:,:,:)) ! ! Check if Lagrangian leves have crossed ! @@ -1037,7 +1033,7 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) elem(ie)%spherep(i,j)%lon*rad2deg,elem(ie)%spherep(i,j)%lat*rad2deg write(iulog,*) " " do k=1,nlev - write(iulog,'(A21,I5,A1,f12.8,3f8.2)') "k,dp_star_moist,u,v,T: ",k," ",dp_star_moist(i,j,k)/100.0_r8,& + write(iulog,'(A21,I5,A1,f16.12,3f10.2)')"k,dp_star_moist,u,v,T: ",k," ",dp_star_moist(i,j,k)/100.0_r8,& elem(ie)%state%v(i,j,1,k,np1),elem(ie)%state%v(i,j,2,k,np1),elem(ie)%state%T(i,j,k,np1) end do end if @@ -1051,42 +1047,35 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) ! compute moist reference pressure level thickness ! call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,np1_qdp),MASS_MIXING_RATIO,& - thermodynamic_active_species_idx_dycore,dp_dry,dp_moist(:,:,:)) + thermodynamic_active_species_idx_dycore, dp_dry,dp_moist(:,:,:)) ! ! Remapping of temperature ! if (vert_remap_uvTq_alg>-20) then ! - ! remap internal energy and back out temperature + ! remap enthalpy energy and back out temperature ! - if (lcp_moist) then - call remap1(internal_energy_star,np,1,1,1,dp_star_dry,dp_dry,ptop,1,.true.,kord_uvT) - ! - ! compute sum c^(l)_p*m^(l)*dp on arrival (Eulerian) grid - ! - ttmp(:,:,:,1) = 1.0_r8 - call get_enthalpy(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), & - ttmp(:,:,:,1),dp_dry,ttmp(:,:,:,2), & - active_species_idx_dycore=thermodynamic_active_species_idx_dycore) - elem(ie)%state%t(:,:,:,np1)=internal_energy_star/ttmp(:,:,:,2) - else - internal_energy_star(:,:,:)=elem(ie)%state%t(:,:,:,np1)*dp_star_moist - call remap1(internal_energy_star,np,1,1,1,dp_star_moist,dp_moist,ptop,1,.true.,kord_uvT) - elem(ie)%state%t(:,:,:,np1)=internal_energy_star/dp_moist - end if + call remap1(enthalpy_star,np,1,1,1,dp_star_dry,dp_dry,ptop,1,.true.,kord_uvT) + ! + ! compute sum c^(l)_p*m^(l)*dp on arrival (Eulerian) grid + ! + ttmp(:,:,:,1) = 1.0_r8 + call get_enthalpy(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), & + ttmp(:,:,:,1), dp_dry,ttmp(:,:,:,2), & + active_species_idx_dycore=thermodynamic_active_species_idx_dycore) + elem(ie)%state%t(:,:,:,np1)=enthalpy_star/ttmp(:,:,:,2) else ! ! map Tv over log(p); following FV and FV3 ! - call remap1(internal_energy_star,np,1,1,1,dp_star_moist,dp_moist,ptop,1,.false.,kord_uvT) - call get_virtual_temp(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), & - ttmp(:,:,:,1),dp_dry=dp_dry, & - active_species_idx_dycore=thermodynamic_active_species_idx_dycore) + call remap1(enthalpy_star,np,1,1,1,dp_star_moist,dp_moist,ptop,1,.false.,kord_uvT) + call get_virtual_temp(elem(ie)%state%qdp(:,:,:,1:qsize,np1_qdp), ttmp(:,:,:,1), & + dp_dry=dp_dry,active_species_idx_dycore=thermodynamic_active_species_idx_dycore) ! ! convert new Tv to T ! - elem(ie)%state%t(:,:,:,np1)=internal_energy_star/ttmp(:,:,:,1) + elem(ie)%state%t(:,:,:,np1)=enthalpy_star/ttmp(:,:,:,1) end if ! ! remap velocity components @@ -1095,7 +1084,7 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) call remap1(elem(ie)%state%v(:,:,2,:,np1),np,1,1,1,dp_star_moist,dp_moist,ptop,-1,.false.,kord_uvT) enddo - if (ntrac>0) then + if (use_cslam) then ! ! vertical remapping of CSLAM tracers ! @@ -1112,14 +1101,15 @@ subroutine vertical_remap(hybrid,elem,fvm,hvcoord,np1,np1_qdp,nets,nete) end do end do end do - if(ntrac>tracer_num_threads) then + if(ntrac>tracer_num_threads) then call omp_set_nested(.true.) - !$OMP PARALLEL NUM_THREADS(tracer_num_threads), DEFAULT(SHARED), PRIVATE(hybridnew2,qbeg,qend) + !$OMP PARALLEL NUM_THREADS(tracer_num_threads), + !DEFAULT(SHARED), PRIVATE(hybridnew2,qbeg,qend) hybridnew2 = config_thread_region(hybrid,'ctracer') call get_loop_ranges(hybridnew2, qbeg=qbeg, qend=qend) call remap1(fvm(ie)%c(1:nc,1:nc,:,1:ntrac),nc,qbeg,qend,ntrac,dpc_star, & fvm(ie)%dp_fvm(1:nc,1:nc,:),ptop,0,.false.,kord_tr_cslam) - !$OMP END PARALLEL + !$OMP END PARALLEL call omp_set_nested(.false.) else call remap1(fvm(ie)%c(1:nc,1:nc,:,1:ntrac),nc,1,ntrac,ntrac,dpc_star, & diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index fdee231f8..242744392 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -26,10 +26,10 @@ module prim_driver_mod subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) use dimensions_mod, only: irecons_tracer, fvm_supercycling - use dimensions_mod, only: fv_nphys, ntrac, nc + use dimensions_mod, only: fv_nphys, nc use parallel_mod, only: syncmp - use time_mod, only: timelevel_t, tstep, phys_tscale, nsplit, TimeLevel_Qdp - use time_mod, only: nsplit_baseline,rsplit_baseline + use se_dyn_time_mod, only: timelevel_t, tstep, phys_tscale, nsplit, TimeLevel_Qdp + use se_dyn_time_mod, only: nsplit_baseline,rsplit_baseline use prim_state_mod, only: prim_printstate use control_mod, only: runtype, topology, rsplit, qsplit, rk_stage_user, & nu, nu_q, nu_div, hypervis_subcycle, hypervis_subcycle_q, & @@ -40,6 +40,9 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) use hybvcoord_mod, only: hvcoord_t use prim_advection_mod, only: prim_advec_init2,deriv use prim_advance_mod, only: compute_omega + use physconst, only: rga, cappa, cpair, tref, lapse_rate + use dyn_thermo, only: get_dp_ref + use physconst, only: pstd type (element_t), intent(inout) :: elem(:) type (fvm_struct), intent(inout) :: fvm(:) @@ -56,13 +59,16 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) ! Local variables ! ================================== + ! variables used to calculate CFL ! variables used to calculate CFL real (kind=r8) :: dtnu ! timestep*viscosity parameter - real (kind=r8) :: dt_dyn_vis ! viscosity timestep used in dynamics - real (kind=r8) :: dt_dyn_del2_sponge, dt_remap + real (kind=r8) :: dt_dyn_del2_sponge real (kind=r8) :: dt_tracer_vis ! viscosity timestep used in tracers + real (kind=r8) :: dt_dyn_vis ! viscosity timestep + real (kind=r8) :: dt_remap ! remapping timestep - real (kind=r8) :: dp + real (kind=r8) :: dp,dp0,T1,T0,pmid_ref(np,np) + real (kind=r8) :: ps_ref(np,np,nets:nete) integer :: i,j,k,ie,t,q integer :: n0,n0_qdp @@ -114,13 +120,13 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) if (topology /= "cube") then call endrun('Error: only cube topology supported for primaitve equations') - endif + end if ! CAM has set tstep based on dtime before calling prim_init2(), ! so only now does HOMME learn the timstep. print them out: call print_cfl(elem,hybrid,nets,nete,dtnu,& !p top and p mid levels - hvcoord%hyai(1)*hvcoord%ps0,(hvcoord%hyam(:)+hvcoord%hybm(:))*hvcoord%ps0,& + hvcoord%hyai(1)*hvcoord%ps0,hvcoord%hyam(:)*hvcoord%ps0+hvcoord%hybm(:)*pstd,& !dt_remap,dt_tracer_fvm,dt_tracer_se tstep*qsplit*rsplit,tstep*qsplit*fvm_supercycling,tstep*qsplit,& !dt_dyn,dt_dyn_visco,dt_tracer_visco, dt_phys @@ -129,7 +135,7 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) if (hybrid%masterthread) then if (phys_tscale/=0) then write(iulog,'(a,2f9.2)') "CAM physics timescale: ",phys_tscale - endif + end if write(iulog,'(a,2f9.2)') "CAM dtime (dt_phys): ",tstep*nsplit*qsplit*rsplit write(iulog,*) "CAM-SE uses dry-mass vertical coordinates" @@ -138,6 +144,39 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) n0=tl%n0 call TimeLevel_Qdp( tl, qsplit, n0_qdp) call compute_omega(hybrid,n0,n0_qdp,elem,deriv,nets,nete,dt_remap,hvcoord) + ! + ! pre-compute pressure-level thickness reference profile + ! + do ie=nets,nete + call get_dp_ref(hvcoord%hyai, hvcoord%hybi, hvcoord%ps0, elem(ie)%state%phis(:,:), & + elem(ie)%derived%dp_ref(:,:,:), ps_ref(:,:,ie)) + end do + ! + ! pre-compute reference temperature profile (Simmons and Jiabin, 1991, QJRMS, Section 2a + ! doi: https://doi.org/10.1002/qj.49711749703c) + ! + ! Tref = T0+T1*Exner + ! T1 = .0065*Tref*Cp/g ! = ~191 + ! T0 = Tref-T1 ! = ~97 + ! + T1 = lapse_rate*Tref*cpair*rga + T0 = Tref-T1 + do ie=nets,nete + do k=1,nlev + pmid_ref =hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*ps_ref(:,:,ie) + dp0 = ( hvcoord%hyai(k+1) - hvcoord%hyai(k) )*hvcoord%ps0 + & + ( hvcoord%hybi(k+1) - hvcoord%hybi(k) )*hvcoord%ps0 + if (hvcoord%hybm(k)>0) then + elem(ie)%derived%T_ref(:,:,k) = T0+T1*(pmid_ref/hvcoord%ps0)**cappa + ! + ! pel@ucar.edu: resolved noise issue over Antartica + ! + elem(ie)%derived%dp_ref(:,:,k) = elem(ie)%derived%dp_ref(:,:,k)-dp0 + else + elem(ie)%derived%T_ref(:,:,k) = 0.0_r8 + end if + end do + end do if (hybrid%masterthread) write(iulog,*) "initial state:" call prim_printstate(elem, tl, hybrid,nets,nete, fvm) @@ -146,8 +185,7 @@ end subroutine prim_init2 !=======================================================================================================! - - subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubstep, omega_cn) + subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubstep, single_column, omega_cn) ! ! advance all variables (u,v,T,ps,Q,C) from time t to t + dt_q ! @@ -181,17 +219,17 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst ! ! use hybvcoord_mod, only : hvcoord_t - use time_mod, only: TimeLevel_t, timelevel_update, timelevel_qdp, nsplit - use control_mod, only: statefreq,qsplit, rsplit, variable_nsplit + use se_dyn_time_mod, only: TimeLevel_t, timelevel_update, timelevel_qdp, nsplit + use control_mod, only: statefreq,qsplit, rsplit, variable_nsplit, dribble_in_rsplit_loop use prim_advance_mod, only: applycamforcing - use prim_advance_mod, only: calc_tot_energy_dynamics,compute_omega + use prim_advance_mod, only: tot_energy_dyn,compute_omega use prim_state_mod, only: prim_printstate, adjust_nsplit use prim_advection_mod, only: vertical_remap, deriv use thread_mod, only: omp_get_thread_num use perf_mod , only: t_startf, t_stopf use fvm_mod , only: fill_halo_fvm, ghostBufQnhc_h - use dimensions_mod, only: ntrac,fv_nphys, ksponge_end - + use dimensions_mod, only: use_cslam,fv_nphys + use fvm_mapping, only: cslam2gll type (element_t) , intent(inout) :: elem(:) type(fvm_struct), intent(inout) :: fvm(:) type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) @@ -201,6 +239,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst real(kind=r8), intent(in) :: dt ! "timestep dependent" timestep type (TimeLevel_t), intent(inout):: tl integer, intent(in) :: nsubstep ! nsubstep = 1 .. nsplit + logical, intent(in) :: single_column real (kind=r8) , intent(inout):: omega_cn(2,nets:nete) !min and max of vertical Courant number real(kind=r8) :: dt_q, dt_remap, dt_phys @@ -208,7 +247,6 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst real (kind=r8) :: dp_np1(np,np) real (kind=r8) :: dp_start(np,np,nlev+1,nets:nete),dp_end(np,np,nlev,nets:nete) logical :: compute_diagnostics - ! =================================== ! Main timestepping loop ! =================================== @@ -224,7 +262,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst if (statefreq>0) then if (MODULO(nstep_end,statefreq)==0 .or. nstep_end==tl%nstep0) then compute_diagnostics=.true. - endif + end if end if ! ! initialize variables for computing vertical Courant number @@ -240,18 +278,45 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst dp_start(:,:,1:nlev,ie) = elem(ie)%state%dp3d(:,:,:,tl%n0) dp_start(:,:,nlev+1,ie) = elem(ie)%state%dp3d(:,:,nlev,tl%n0) end do - endif + end if call TimeLevel_Qdp( tl, qsplit, n0_qdp) - call calc_tot_energy_dynamics(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') - call ApplyCAMForcing(elem,fvm,tl%n0,n0_qdp,dt_remap,dt_phys,nets,nete,nsubstep) - call calc_tot_energy_dynamics(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + if (dribble_in_rsplit_loop==0) then + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') + call ApplyCAMForcing(elem,fvm,tl%n0,n0_qdp,dt_remap,dt_phys,nets,nete,nsubstep) + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + end if do r=1,rsplit if (r.ne.1) call TimeLevel_update(tl,"leapfrog") - call prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) - enddo + ! + ! if nsplit==1 and physics time-step is long then there will be noise in the + ! pressure field; hence "dripple" in tendencies + ! + if (dribble_in_rsplit_loop==1) then + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') + call ApplyCAMForcing(elem,fvm,tl%n0,n0_qdp,dt,dt_phys,nets,nete,MAX(nsubstep,r)) + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + end if + ! + ! right after physics overwrite Qdp with CSLAM values + ! + if (use_cslam.and.nsubstep==1.and.r==1) then + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') + call cslam2gll(elem, fvm, hybrid,nets,nete, tl%n0, n0_qdp) + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + end if + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBL') + if (single_column) then + ! Single Column Case + ! Loop over rsplit vertically lagrangian timesteps + call prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) + else + call prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r,nsubstep==nsplit,dt_remap) + end if + call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,n0_qdp,'dAL') + end do ! defer final timelevel update until after remap and diagnostics @@ -263,7 +328,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst ! always for tracers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call calc_tot_energy_dynamics(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAD') + call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAD') if (variable_nsplit.or.compute_diagnostics) then ! @@ -280,9 +345,9 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! time step is complete. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call calc_tot_energy_dynamics(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAR') + call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAR') - if (nsubstep==nsplit) then + if (nsubstep==nsplit .and. .not. single_column) then call compute_omega(hybrid,tl%np1,np1_qdp,elem,deriv,nets,nete,dt_remap,hvcoord) end if @@ -326,7 +391,6 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst end do end do end do - if (nsubstep==nsplit.and.variable_nsplit) then call t_startf('adjust_nsplit') call adjust_nsplit(elem, tl, hybrid,nets,nete, fvm, omega_cn) @@ -341,7 +405,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst call prim_printstate(elem, tl, hybrid,nets,nete, fvm, omega_cn) end if - if (ntrac>0.and.nsubstep==nsplit.and.nc.ne.fv_nphys) then + if (use_cslam.and.nsubstep==nsplit.and.nc.ne.fv_nphys) then ! ! fill the fvm halo for mapping in d_p_coupling if ! physics grid resolution is different than fvm resolution @@ -351,8 +415,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst end subroutine prim_run_subcycle - - subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) + subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep, last_step,dt_remap) ! ! Take qsplit dynamics steps and one tracer step ! for vertically lagrangian option, this subroutine does only the horizontal step @@ -370,18 +433,19 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! tl%n0 time t + dt_q ! use hybvcoord_mod, only: hvcoord_t - use time_mod, only: TimeLevel_t, timelevel_update + use se_dyn_time_mod, only: TimeLevel_t, timelevel_update use control_mod, only: statefreq, qsplit, nu_p use thread_mod, only: omp_get_thread_num use prim_advance_mod, only: prim_advance_exp use prim_advection_mod, only: prim_advec_tracers_remap, prim_advec_tracers_fvm, deriv use derivative_mod, only: subcell_integration use hybrid_mod, only: set_region_num_threads, config_thread_region, get_loop_ranges - use dimensions_mod, only: ntrac,fvm_supercycling,fvm_supercycling_jet + use dimensions_mod, only: use_cslam,fvm_supercycling,fvm_supercycling_jet use dimensions_mod, only: kmin_jet, kmax_jet use fvm_mod, only: ghostBufQnhc_vh,ghostBufQ1_vh, ghostBufFlux_vh use fvm_mod, only: ghostBufQ1_h,ghostBufQnhcJet_h, ghostBufFluxJet_h - + use se_dyn_time_mod, only: timelevel_qdp + use fvm_mapping, only: cslam2gll #ifdef waccm_debug use cam_history, only: outfld #endif @@ -389,13 +453,15 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) type (element_t) , intent(inout) :: elem(:) type(fvm_struct), intent(inout) :: fvm(:) - type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) - type (hvcoord_t), intent(in) :: hvcoord ! hybrid vertical coordinate struct - integer, intent(in) :: nets ! starting thread element number (private) - integer, intent(in) :: nete ! ending thread element number (private) - real(kind=r8), intent(in) :: dt ! "timestep dependent" timestep + type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) + type (hvcoord_t), intent(in) :: hvcoord ! hybrid vertical coordinate struct + integer, intent(in) :: nets ! starting thread element number (private) + integer, intent(in) :: nete ! ending thread element number (private) + real(kind=r8), intent(in) :: dt ! "timestep dependent" timestep type (TimeLevel_t), intent(inout) :: tl - integer, intent(in) :: rstep ! vertical remap subcycling step + integer, intent(in) :: rstep ! vertical remap subcycling step + logical, intent(in) :: last_step ! last step before d_p_coupling + real(kind=r8), intent(in) :: dt_remap type (hybrid_t):: hybridnew,hybridnew2 real(kind=r8) :: st, st1, dp, dt_q @@ -403,6 +469,7 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) integer :: ithr integer :: region_num_threads integer :: kbeg,kend + integer :: n0_qdp, np1_qdp real (kind=r8) :: tempdp3d(np,np), x real (kind=r8) :: tempmass(nc,nc) @@ -422,11 +489,11 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) if (nu_p>0) then elem(ie)%derived%dpdiss_ave=0 elem(ie)%derived%dpdiss_biharmonic=0 - endif + end if ! dp at time t: use floating lagrangian levels: elem(ie)%derived%dp(:,:,:)=elem(ie)%state%dp3d(:,:,:,tl%n0) - enddo + end do ! =============== ! Dynamical Step @@ -454,9 +521,9 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) call t_stopf('prim_advance_exp') ! defer final timelevel update until after Q update. - enddo + end do #ifdef HOMME_TEST_SUB_ELEMENT_MASS_FLUX - if (ntrac>0.and.rstep==1) then + if (use_cslam.and.rstep==1) then do ie=nets,nete do k=1,nlev tempdp3d = elem(ie)%state%dp3d(:,:,k,tl%np1) - & @@ -473,14 +540,13 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) write(iulog,*) __FILE__,__LINE__,"**CSLAM mass-flux ERROR**",ie,k,i,j,tempmass(i,j),x,& ABS((tempmass(i,j)-x)/tempmass(i,j)) call endrun('**CSLAM mass-flux ERROR**') - endif + end if end do end do end do end do end if #endif - ! current dynamics state variables: ! derived%dp = dp at start of timestep ! derived%vn0 = mean horiz. flux: U*dp @@ -500,32 +566,19 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! special case in CAM: if CSLAM tracers are turned on , qsize=1 but this tracer should ! not be advected. This will be cleaned up when the physgrid is merged into CAM trunk ! Currently advecting all species - if (qsize > 0) then - + if (.not.use_cslam) then call t_startf('prim_advec_tracers_remap') - if(ntrac>0) then - ! Deactivate threading in the tracer dimension if this is a CSLAM run - region_num_threads = 1 - else - region_num_threads=tracer_num_threads - endif + region_num_threads=tracer_num_threads call omp_set_nested(.true.) !$OMP PARALLEL NUM_THREADS(region_num_threads), DEFAULT(SHARED), PRIVATE(hybridnew) - if(ntrac>0) then - ! Deactivate threading in the tracer dimension if this is a CSLAM run - hybridnew = config_thread_region(hybrid,'serial') - else - hybridnew = config_thread_region(hybrid,'tracer') - endif + hybridnew = config_thread_region(hybrid,'tracer') call Prim_Advec_Tracers_remap(elem, deriv,hvcoord,hybridnew,dt_q,tl,nets,nete) !$OMP END PARALLEL call omp_set_nested(.false.) call t_stopf('prim_advec_tracers_remap') - end if - ! - ! only run fvm transport every fvm_supercycling rstep - ! - if (ntrac>0) then + else + ! + ! only run fvm transport every fvm_supercycling rstep ! ! FVM transport ! @@ -557,7 +610,9 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) fvm(ie)%psc(i,j) = sum(fvm(ie)%dp_fvm(i,j,:)) + hvcoord%hyai(1)*hvcoord%ps0 end do end do - end do + end do + call TimeLevel_Qdp( tl, qsplit, n0_qdp, np1_qdp) + if (.not.last_step) call cslam2gll(elem, fvm, hybrid,nets,nete, tl%np1, np1_qdp) else if ((mod(rstep,fvm_supercycling_jet) == 0)) then ! ! shorter fvm time-step in jet region @@ -572,11 +627,84 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) (/nc*nc,nlev/)), nc*nc, ie) end do #endif - endif + end if end subroutine prim_step + subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) + ! + ! prim_step version for single column model (SCM) + ! Here we simply want to compute the floating level tendency + ! based on the prescribed large scale vertical velocity + ! Take qsplit dynamics steps and one tracer step + ! for vertically lagrangian option, this subroutine does only + ! the horizontal step + ! + ! input: + ! tl%nm1 not used + ! tl%n0 data at time t + ! tl%np1 new values at t+dt_q + ! + ! then we update timelevel pointers: + ! tl%nm1 = tl%n0 + ! tl%n0 = tl%np1 + ! so that: + ! tl%nm1 tracers: t dynamics: t+(qsplit-1)*dt + ! tl%n0 time t + dt_q + ! + use hybvcoord_mod, only: hvcoord_t + use se_dyn_time_mod, only: TimeLevel_t, timelevel_update + use control_mod, only: statefreq, qsplit, nu_p + use prim_advection_mod, only: deriv + use hybrid_mod, only: config_thread_region, get_loop_ranges + + type (element_t) , intent(inout) :: elem(:) + type(fvm_struct), intent(inout) :: fvm(:) + type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) + type (hvcoord_t), intent(in) :: hvcoord ! hybrid vertical coordinate struct + integer, intent(in) :: nets ! starting thread element number (private) + integer, intent(in) :: nete ! ending thread element number (private) + real(kind=r8), intent(in) :: dt ! "timestep dependent" timestep + type (TimeLevel_t), intent(inout) :: tl + integer, intent(in) :: rstep ! vertical remap subcycling step + integer :: ie,n + ! =============== + ! initialize mean flux accumulation variables and save some variables at n0 + ! for use by advection + ! =============== + do ie=nets,nete + elem(ie)%derived%vn0=0 ! mean horizontal mass flux + if (nu_p>0) then + elem(ie)%derived%dpdiss_ave=0 + elem(ie)%derived%dpdiss_biharmonic=0 + end if + elem(ie)%derived%dp(:,:,:)=elem(ie)%state%dp3d(:,:,:,tl%n0) + end do + + ! =============== + ! Dynamical Step + ! =============== +#ifdef scam + call t_startf('set_prescribed_scm') + + call set_prescribed_scm(elem, fvm, deriv, hvcoord, & + hybrid, dt, tl, nets, nete) + + call t_stopf('set_prescribed_scm') + + do n=2,qsplit + call TimeLevel_update(tl,"leapfrog") + + call t_startf('set_prescribed_scm') + + call set_prescribed_scm(elem, fvm, deriv, hvcoord, & + hybrid, dt, tl, nets, nete) + + call t_stopf('set_prescribed_scm') + end do +#endif + end subroutine prim_step_scm !=======================================================================================================! @@ -655,7 +783,7 @@ subroutine prim_set_dry_mass(elem, hvcoord,initial_global_ave_dry_ps,q) write (iulog,*) "Mixing ratios that are wet have been scaled so that total mass of tracer is conserved" write (iulog,*) "Mixing ratios that are dry have not been changed (mass not conserved in scaling process)" write (iulog,*) "------ end info from prim_set_dry_mass -------------------------------------------------------" - endif + end if end subroutine prim_set_dry_mass subroutine get_global_ave_surface_pressure(elem, global_ave_ps_inic) @@ -687,7 +815,7 @@ subroutine get_global_ave_surface_pressure(elem, global_ave_ps_inic) do ie=nets,nete tmp(:,:,ie)=elem(ie)%state%psdry(:,:) - enddo + end do global_ave_ps_inic = global_integral(elem, tmp(:,:,nets:nete),hybrid,np,nets,nete) deallocate(tmp) end subroutine get_global_ave_surface_pressure diff --git a/src/dynamics/se/dycore/prim_init.F90 b/src/dynamics/se/dycore/prim_init.F90 index b0e8e4256..b884ca806 100644 --- a/src/dynamics/se/dycore/prim_init.F90 +++ b/src/dynamics/se/dycore/prim_init.F90 @@ -30,7 +30,7 @@ subroutine prim_init1(elem, fvm, par, Tl) use element_mod, only: element_t, allocate_element_dims, allocate_element_desc use fvm_mod, only: fvm_init1 use mesh_mod, only: MeshUseMeshFile - use time_mod, only: timelevel_init, timelevel_t + use se_dyn_time_mod, only: timelevel_init, timelevel_t use mass_matrix_mod, only: mass_matrix use derivative_mod, only: allocate_subcell_integration_matrix_cslam use derivative_mod, only: allocate_subcell_integration_matrix_physgrid @@ -332,25 +332,9 @@ subroutine prim_init1(elem, fvm, par, Tl) elem(ie)%derived%FQ=0.0_r8 elem(ie)%derived%FT=0.0_r8 elem(ie)%derived%FDP=0.0_r8 - elem(ie)%derived%pecnd=0.0_r8 elem(ie)%derived%Omega=0 elem(ie)%state%dp3d=0 - - elem(ie)%derived%etadot_prescribed = nan - elem(ie)%derived%u_met = nan - elem(ie)%derived%v_met = nan - elem(ie)%derived%dudt_met = nan - elem(ie)%derived%dvdt_met = nan - elem(ie)%derived%T_met = nan - elem(ie)%derived%dTdt_met = nan - elem(ie)%derived%ps_met = nan - elem(ie)%derived%dpsdt_met = nan - elem(ie)%derived%nudge_factor = nan - - elem(ie)%derived%Utnd=0._r8 - elem(ie)%derived%Vtnd=0._r8 - elem(ie)%derived%Ttnd=0._r8 end do ! ========================================================== diff --git a/src/dynamics/se/dycore/prim_state_mod.F90 b/src/dynamics/se/dycore/prim_state_mod.F90 index 6395c169e..b204a3c8d 100644 --- a/src/dynamics/se/dycore/prim_state_mod.F90 +++ b/src/dynamics/se/dycore/prim_state_mod.F90 @@ -4,7 +4,7 @@ module prim_state_mod use dimensions_mod, only: nlev, np, nc, qsize_d, ntrac use parallel_mod, only: ordered use hybrid_mod, only: hybrid_t - use time_mod, only: timelevel_t, TimeLevel_Qdp, time_at + use se_dyn_time_mod, only: timelevel_t, TimeLevel_Qdp, time_at use control_mod, only: qsplit, statediag_numtrac use global_norms_mod, only: global_integrals_general use element_mod, only: element_t @@ -19,18 +19,18 @@ module prim_state_mod CONTAINS subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) - use dimensions_mod, only: ntrac + use dimensions_mod, only: use_cslam !Un-comment once constitutents are enabled -JN: ! use constituents, only: cnst_name use string_utils, only: to_str !Remove once constituents are enabled -JN use air_composition, only: thermodynamic_active_species_idx_dycore, dry_air_species_num use air_composition, only: thermodynamic_active_species_num,thermodynamic_active_species_idx use cam_control_mod, only: initial_run - use time_mod, only: tstep + use se_dyn_time_mod, only: tstep use control_mod, only: rsplit, qsplit use perf_mod, only: t_startf, t_stopf use cam_abortutils, only: check_allocate - use string_utils, only: to_str + use hycoef, only: hyai, ps0 type (element_t), intent(inout) :: elem(:) type (TimeLevel_t), target, intent(in) :: tl type (hybrid_t), intent(in) :: hybrid @@ -115,9 +115,9 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) n0=tl%n0 call TimeLevel_Qdp( tl, qsplit, n0_qdp) ! moist surface pressure - if (ntrac>0) then + if (use_cslam) then do ie=nets,nete - moist_ps_fvm(:,:,ie)=SUM(fvm(ie)%dp_fvm(1:nc,1:nc,:),DIM=3) + moist_ps_fvm(:,:,ie)=SUM(fvm(ie)%dp_fvm(1:nc,1:nc,:),DIM=3)+hyai(1)*ps0 do q=dry_air_species_num+1,thermodynamic_active_species_num m_cnst = thermodynamic_active_species_idx(q) do k=1,nlev @@ -141,7 +141,7 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) do ie=nets,nete da_gll(:,:,ie) = elem(ie)%mp(:,:)*elem(ie)%metdet(:,:) enddo - if (ntrac>0) then + if (use_cslam) then do ie=nets,nete da_fvm(:,:,ie) = fvm(ie)%area_sphere(:,:) enddo @@ -158,7 +158,7 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) varname(3) = 'T ' varname(4) = 'OMEGA ' varname(5) = 'OMEGA CN ' - if (ntrac>0) then + if (use_cslam) then varname(6) = 'PSDRY(fvm)' varname(7) = 'PS(fvm) ' varname(8) = 'PSDRY(gll)' @@ -188,15 +188,15 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) min_local(ie,5) = 0.0_r8 max_local(ie,5) = 0.0_r8 end if - if (ntrac>0) then - min_local(ie,6) = MINVAL(SUM(fvm(ie)%dp_fvm(1:nc,1:nc,:),DIM=3)) - max_local(ie,6) = MAXVAL(SUM(fvm(ie)%dp_fvm(1:nc,1:nc,:),DIM=3)) + if (use_cslam) then + min_local(ie,6) = MINVAL(SUM(fvm(ie)%dp_fvm(1:nc,1:nc,:),DIM=3))+hyai(1)*ps0 + max_local(ie,6) = MAXVAL(SUM(fvm(ie)%dp_fvm(1:nc,1:nc,:),DIM=3))+hyai(1)*ps0 min_local(ie,7) = MINVAL(moist_ps_fvm(:,:,ie)) - max_local(ie,7) = MINVAL(moist_ps_fvm(:,:,ie)) - min_local(ie,8) = MINVAL(elem(ie)%state%psdry(:,:)) - max_local(ie,8) = MAXVAL(elem(ie)%state%psdry(:,:)) - min_local(ie,9) = MINVAL(moist_ps(:,:,ie)) - max_local(ie,9) = MAXVAL(moist_ps(:,:,ie)) + max_local(ie,7) = MAXVAL(moist_ps_fvm(:,:,ie)) + min_local(ie,8) = MINVAL(elem(ie)%state%psdry(:,:)) + max_local(ie,8) = MAXVAL(elem(ie)%state%psdry(:,:)) + min_local(ie,9) = MINVAL(moist_ps(:,:,ie)) + max_local(ie,9) = MAXVAL(moist_ps(:,:,ie)) do q=1,statediag_numtrac !Un-comment once constitutents are enabled -JN: !varname(nm+q) = TRIM(cnst_name(q)) @@ -227,7 +227,7 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) max_local(ie,nm2+1) = MAXVAL(elem(ie)%derived%FT(:,:,:)) min_local(ie,nm2+2) = MINVAL(elem(ie)%derived%FM(:,:,:,:)) max_local(ie,nm2+2) = MAXVAL(elem(ie)%derived%FM(:,:,:,:)) - if (ntrac>0) then + if (use_cslam) then do q=1,statediag_numtrac !Un-comment once constitutents are enabled -JN: !varname(nm2+2+q) = TRIM('F'//TRIM(cnst_name(q))) @@ -265,7 +265,7 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) ! tracers ! mass = -1.0_r8 - if (ntrac>0) then + if (use_cslam) then do ie=nets,nete do q=1,statediag_numtrac tmp_fvm(:,:,q,ie) = SUM(fvm(ie)%c(1:nc,1:nc,:,q)*fvm(ie)%dp_fvm(1:nc,1:nc,:),DIM=3) @@ -307,7 +307,7 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) if (tl%nstep==0.or..not. initial_run) then mass_chg(:) = 0.0_R8 elem(nets)%derived%mass(nm+1:nm+statediag_numtrac) = mass(nm+1:nm+statediag_numtrac) - if (ntrac>0) then + if (use_cslam) then elem(nets)%derived%mass(6:9) = mass(6:9) else elem(nets)%derived%mass(6:7) = mass(6:7) @@ -355,7 +355,9 @@ subroutine prim_printstate(elem, tl,hybrid,nets,nete, fvm, omega_cn) 101 format (A12,A23,A23,A23,A23) #ifdef waccm_debug - call prim_printstate_cslam_gamma(elem, tl,hybrid,nets,nete, fvm) + if (use_cslam) then + call prim_printstate_cslam_gamma(elem, tl,hybrid,nets,nete, fvm) + end if #endif call prim_printstate_U(elem, tl,hybrid,nets,nete, fvm) end subroutine prim_printstate @@ -409,10 +411,10 @@ end subroutine prim_printstate_cslam_gamma subroutine adjust_nsplit(elem, tl,hybrid,nets,nete, fvm, omega_cn) use dimensions_mod, only: ksponge_end use dimensions_mod, only: fvm_supercycling, fvm_supercycling_jet - use time_mod, only: tstep + use se_dyn_time_mod, only: tstep use control_mod, only: rsplit, qsplit use perf_mod, only: t_startf, t_stopf - use time_mod, only: nsplit, nsplit_baseline,rsplit_baseline + use se_dyn_time_mod, only: nsplit, nsplit_baseline,rsplit_baseline use control_mod, only: qsplit, rsplit use time_manager, only: get_step_size use cam_abortutils, only: endrun diff --git a/src/dynamics/se/dycore/quadrature_mod.F90 b/src/dynamics/se/dycore/quadrature_mod.F90 index e9ad38c7f..d14fbdd22 100644 --- a/src/dynamics/se/dycore/quadrature_mod.F90 +++ b/src/dynamics/se/dycore/quadrature_mod.F90 @@ -19,9 +19,6 @@ module quadrature_mod public :: jacobi public :: quad_norm - public :: trapezoid - private :: trapN - public :: simpsons public :: gaussian_int private :: gausslobatto_pts @@ -230,7 +227,7 @@ function gauss_wts(np1, gpts) result(wts) beta = c0 n = np1-1 - djac=jacobi_derivatives(np1,alpha,beta,np1,gpts) + djac=jacobi_derivatives(np1,alpha,beta,np1,gpts) do i=1,np1 wts(i)=c2/((c1-gpts(i)**2)*djac(i)*djac(i)) @@ -518,11 +515,11 @@ end subroutine test_gausslobatto ! subroutine jacobi: ! ! Computes the Jacobi Polynomials (jac) and their - ! first derivatives up to and including degree n + ! first derivatives up to and including degree n ! at point x on the interval (-1,1). ! - ! See for example the recurrence relations - ! in equation 2.5.4 (page 70) in + ! See for example the recurrence relations + ! in equation 2.5.4 (page 70) in ! ! "Spectral Methods in Fluid Dynamics", ! by C. Canuto, M.Y. Hussaini, A. Quarteroni, T.A.Zang @@ -565,19 +562,19 @@ subroutine jacobi(n, x, alpha, beta, jac, djac) a2k = ( c2*k + alpha + beta + c1 )*( alpha*alpha - beta*beta ) + x*da2kdx a3k = c2*(k + alpha)*( k + beta )*( c2*k + alpha + beta + c2 ) jac(k+1) = ( a2k*jac(k)-a3k*jac(k-1) )/a1k - djac(k+1)= ( a2k*djac(k) + da2kdx*jac(k) - a3k*djac(k-1) )/a1k + djac(k+1)= ( a2k*djac(k) + da2kdx*jac(k) - a3k*djac(k-1) )/a1k end do end subroutine jacobi ! ========================================================== - ! This routine computes the Nth order Jacobi Polynomials + ! This routine computes the Nth order Jacobi Polynomials ! (jac) for a vector of positions x on the interval (-1,1), ! of length npoints. ! - ! See for example the recurrence relations - ! in equation 2.5.4 (page 70) in + ! See for example the recurrence relations + ! in equation 2.5.4 (page 70) in ! ! "Spectral Methods in Fluid Dynamics", ! by C. Canuto, M.Y. Hussaini, A. Quarteroni, T.A.Zang @@ -588,7 +585,7 @@ end subroutine jacobi function jacobi_polynomials(n, alpha, beta, npoints, x) result(jac) integer, intent(in) :: n ! order of the Jacobi Polynomial - real (kind=r8) :: alpha + real (kind=r8) :: alpha real (kind=r8) :: beta integer, intent(in) :: npoints real (kind=r8) :: x(npoints) @@ -638,11 +635,11 @@ end function jacobi_polynomials ! ================================================ ! This routine computes the first derivatives of Nth - ! order Jacobi Polynomials (djac) for a vector of + ! order Jacobi Polynomials (djac) for a vector of ! positions x on the interval (-1,1), of length npoints. ! - ! See for example the recurrence relations - ! in equation 2.5.4 (page 70) in + ! See for example the recurrence relations + ! in equation 2.5.4 (page 70) in ! ! "Spectral Methods in Fluid Dynamics", ! by C. Canuto, M.Y. Hussaini, A. Quarteroni, T.A.Zang @@ -653,7 +650,7 @@ end function jacobi_polynomials function jacobi_derivatives(n, alpha, beta, npoints, x) result(djac) integer , intent(in) :: n ! order of the Jacobi Polynomial - real (kind=r8), intent(in) :: alpha + real (kind=r8), intent(in) :: alpha real (kind=r8), intent(in) :: beta integer , intent(in) :: npoints real (kind=r8), intent(in) :: x(npoints) @@ -761,7 +758,7 @@ end function legendre ! =========================================== ! quad_norm: ! - ! compute normalization constants + ! compute normalization constants ! for k=1,N order Legendre polynomials ! ! e.g. gamma(k) in Canuto, page 58. @@ -789,151 +786,12 @@ function quad_norm(gquad,N) result(gamma) end function quad_norm - ! ======================= - ! TrapN: - ! Numerical recipes - ! ======================= - - subroutine trapN(f,a,b,N,it,s) - INTERFACE - FUNCTION f(x) RESULT(f_x) ! Function to be integrated - use shr_kind_mod, only: r8=>shr_kind_r8 - real(kind=r8), INTENT(IN) :: x - real(kind=r8) :: f_x - END FUNCTION f - END INTERFACE - - real(kind=r8),intent(in) :: a,b - integer, intent(in) :: N - integer, intent(inout) :: it - real(kind=r8), intent(inout) :: s - - real(kind=r8) :: ssum - real(kind=r8) :: del - real(kind=r8) :: rtnm - real(kind=r8) :: x - - integer :: j - - if (N==1) then - s = 0.5_r8*(b-a)*(f(a) + f(b)) - it =1 - else - ssum = 0.0_r8 - rtnm =1.0_r8/it - del = (b-a)*rtnm - x=a+0.5_r8*del - do j=1,it - ssum = ssum + f(x) - x=x+del - end do - s=0.5_r8*(s + del*ssum) - it=2*it - end if - - end subroutine trapN - - ! ========================================== - ! Trapezoid Rule for integrating functions - ! from a to b with residual error eps - ! ========================================== - - function trapezoid(f,a,b,eps) result(Integral) - - integer, parameter :: Nmax = 25 ! At most 2^Nmax + 1 points in integral - - INTERFACE - FUNCTION f(x) RESULT(f_x) ! Function to be integrated - use shr_kind_mod, only: r8=>shr_kind_r8 - real(kind=r8), INTENT(IN) :: x - real(kind=r8) :: f_x - END FUNCTION f - END INTERFACE - - real(kind=r8), intent(in) :: a,b ! The integral bounds - real(kind=r8), intent(in) :: eps ! relative error bound for integral - real(kind=r8) :: Integral ! the integral result (within eps) - real(kind=r8) :: s ! Integral approximation - real(kind=r8) :: sold ! previous integral approx - - integer :: N - integer :: it - - ! ============================================================== - ! Calculate I here using trapezoid rule using f and a DO loop... - ! ============================================================== - - s = 1.0e30_r8 - sold = 0.0_r8 - N=1 - it=0 - do while(N<=Nmax .and. ABS(s-sold)>eps*ABS(sold)) - sold=s - call trapN(f,a,b,N,it,s) - N=N+1 - end do - - Integral = s - - end function trapezoid - - ! ========================================== - ! Simpsons Rule for integrating functions - ! from a to b with residual error eps - ! ========================================== - - function simpsons(f,a,b,eps) result(Integral) - - integer, parameter :: Nmax = 25 ! At most 2^Nmax + 1 points in integral - - INTERFACE - FUNCTION f(x) RESULT(f_x) ! Function to be integrated - use shr_kind_mod, only: r8=>shr_kind_r8 - real(kind=r8), INTENT(IN) :: x - real(kind=r8) :: f_x - END FUNCTION f - END INTERFACE - - real(kind=r8), intent(in) :: a,b ! The integral bounds - real(kind=r8), intent(in) :: eps ! relative error bound for integral - real(kind=r8) :: Integral ! the integral result (within eps) - real(kind=r8) :: s ! Integral approximation - real(kind=r8) :: os ! previous integral approx - real(kind=r8) :: st ! Integral approximation - real(kind=r8) :: ost ! previous integral approx - - integer :: N - integer :: it - - ! ============================================================== - ! Calculate I here using trapezoid rule using f and a DO loop... - ! ============================================================== - - ost= 0.0_r8 - s = 1.0e30_r8 - os = 0.0_r8 - - N=1 - it=0 - do while ((N<=Nmax .and. ABS(s-os)>eps*ABS(os) ) .or. N<=2) - os = s - call trapN(f,a,b,N,it,st) - s=(4.0_r8*st-ost)/3.0_r8 - ost=st - N=N+1 - end do - - Integral = s - - end function simpsons - - ! ========================================== ! gaussian_int: ! - ! Gaussian Quadrature Rule for integrating - ! function f from a to b with gs weights and - ! points with precomputed gaussian quadrature + ! Gaussian Quadrature Rule for integrating + ! function f from a to b with gs weights and + ! points with precomputed gaussian quadrature ! and weights. ! ========================================== @@ -969,8 +827,3 @@ END FUNCTION f end function gaussian_int end module quadrature_mod - - - - - diff --git a/src/dynamics/se/dycore/time_mod.F90 b/src/dynamics/se/dycore/se_dyn_time_mod.F90 similarity index 89% rename from src/dynamics/se/dycore/time_mod.F90 rename to src/dynamics/se/dycore/se_dyn_time_mod.F90 index fdd68af06..7cda275b1 100644 --- a/src/dynamics/se/dycore/time_mod.F90 +++ b/src/dynamics/se/dycore/se_dyn_time_mod.F90 @@ -1,4 +1,4 @@ -module time_mod +module se_dyn_time_mod !------------------ use shr_kind_mod, only: r8=>shr_kind_r8 !------------------ @@ -80,6 +80,7 @@ end subroutine TimeLevel_init_specific !locations for nm1 and n0 for Qdp - because !it only has 2 levels for storage subroutine TimeLevel_Qdp(tl, qsplit, n0, np1) + use dimensions_mod, only: use_cslam type (TimeLevel_t) :: tl integer, intent(in) :: qsplit integer, intent(inout) :: n0 @@ -87,22 +88,26 @@ subroutine TimeLevel_Qdp(tl, qsplit, n0, np1) integer :: i_temp - i_temp = tl%nstep/qsplit - - if (mod(i_temp,2) ==0) then + if (use_cslam) then n0 = 1 - if (present(np1)) then - np1 = 2 - endif + if (present(np1)) np1 = 1 else - n0 = 2 - if (present(np1)) then - np1 = 1 - end if - endif + i_temp = tl%nstep/qsplit + + if (mod(i_temp,2) ==0) then + n0 = 1 + if (present(np1)) then + np1 = 2 + endif + else + n0 = 2 + if (present(np1)) then + np1 = 1 + end if + endif !print * ,'nstep = ', tl%nstep, 'qsplit= ', qsplit, 'i_temp = ', i_temp, 'n0 = ', n0 - + endif end subroutine TimeLevel_Qdp subroutine TimeLevel_update(tl,uptype) @@ -123,13 +128,13 @@ subroutine TimeLevel_update(tl,uptype) ntmp = tl%np1 tl%np1 = tl%n0 tl%n0 = ntmp - else + else print *,'WARNING: TimeLevel_update called wint invalid uptype=',uptype end if - + tl%nstep = tl%nstep+1 !$OMP END MASTER -!$OMP BARRIER +!$OMP BARRIER end subroutine TimeLevel_update -end module time_mod +end module se_dyn_time_mod diff --git a/src/dynamics/se/dycore/viscosity_mod.F90 b/src/dynamics/se/dycore/viscosity_mod.F90 index b29e48a1f..ecb125309 100644 --- a/src/dynamics/se/dycore/viscosity_mod.F90 +++ b/src/dynamics/se/dycore/viscosity_mod.F90 @@ -1,15 +1,15 @@ module viscosity_mod ! ! This module should be renamed "global_deriv_mod.F90" -! -! It is a collection of derivative operators that must be applied to the field -! over the sphere (as opposed to derivative operators that can be applied element +! +! It is a collection of derivative operators that must be applied to the field +! over the sphere (as opposed to derivative operators that can be applied element ! by element) ! ! use shr_kind_mod, only: r8=>shr_kind_r8 use thread_mod, only: max_num_threads, omp_get_num_threads - use dimensions_mod, only: np, nc, nlev,qsize,nelemd + use dimensions_mod, only: np, nc, nlev,nlevp, qsize,nelemd use hybrid_mod, only: hybrid_t, get_loop_ranges, config_thread_region use parallel_mod, only: parallel_t use element_mod, only: element_t @@ -50,11 +50,9 @@ module viscosity_mod CONTAINS -subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend,& - dp3d_ref,T_ref) +subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend) use derivative_mod, only : subcell_Laplace_fluxes - use dimensions_mod, only : ntrac, nu_div_lev,nu_lev - + use dimensions_mod, only : use_cslam, nu_div_lev,nu_lev !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! compute weak biharmonic operator ! input: h,v (stored in elem()%, in lat-lon coordinates @@ -68,101 +66,95 @@ subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid, real (kind=r8), intent(out), dimension(nc,nc,4,nlev,nets:nete) :: dpflux real (kind=r8), dimension(np,np,2,nlev,nets:nete) :: vtens real (kind=r8), dimension(np,np,nlev,nets:nete) :: ttens,dptens - real (kind=r8), dimension(np,np,nlev,nets:nete), optional :: dp3d_ref,T_ref type (EdgeBuffer_t) , intent(inout) :: edge3 type (derivative_t) , intent(in) :: deriv - ! local integer :: i,j,k,kptr,ie,kblk ! real (kind=r8), dimension(:,:), pointer :: rspheremv real (kind=r8), dimension(np,np) :: tmp real (kind=r8), dimension(np,np) :: tmp2 real (kind=r8), dimension(np,np,2) :: v + + real (kind=r8), dimension(np,np,nlev) :: lap_p_wk + real (kind=r8), dimension(np,np,nlevp) :: T_i + + real (kind=r8) :: nu_ratio1, nu_ratio2 logical var_coef1 - + kblk = kend - kbeg + 1 - - if (ntrac>0) dpflux = 0 - !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) + + if (use_cslam) dpflux = 0 + !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) !so tensor is only used on second call to laplace_sphere_wk var_coef1 = .true. if(hypervis_scaling > 0) var_coef1 = .false. - - - do ie=nets,nete + do ie=nets,nete !$omp parallel do num_threads(vert_num_threads) private(k,tmp) do k=kbeg,kend - nu_ratio1=1 - nu_ratio2=1 - if (nu_div_lev(k)/=nu_lev(k)) then - if(hypervis_scaling /= 0) then - ! we have a problem with the tensor in that we cant seperate - ! div and curl components. So we do, with tensor V: - ! nu * (del V del ) * ( nu_ratio * grad(div) - curl(curl)) - nu_ratio1=nu_div_lev(k)/nu_lev(k) - nu_ratio2=1 - else - nu_ratio1=sqrt(nu_div_lev(k)/nu_lev(k)) - nu_ratio2=sqrt(nu_div_lev(k)/nu_lev(k)) - endif - endif - - if (present(T_ref)) then - tmp=elem(ie)%state%T(:,:,k,nt)-T_ref(:,:,k,ie) - else - tmp=elem(ie)%state%T(:,:,k,nt) + nu_ratio1=1 + nu_ratio2=1 + if (nu_div_lev(k)/=nu_lev(k)) then + if(hypervis_scaling /= 0) then + ! we have a problem with the tensor in that we cant seperate + ! div and curl components. So we do, with tensor V: + ! nu * (del V del ) * ( nu_ratio * grad(div) - curl(curl)) + nu_ratio1=nu_div_lev(k)/nu_lev(k) + nu_ratio2=1 + else + nu_ratio1=sqrt(nu_div_lev(k)/nu_lev(k)) + nu_ratio2=sqrt(nu_div_lev(k)/nu_lev(k)) + end if end if + + tmp=elem(ie)%state%T(:,:,k,nt)-elem(ie)%derived%T_ref(:,:,k) call laplace_sphere_wk(tmp,deriv,elem(ie),ttens(:,:,k,ie),var_coef=var_coef1) - if (present(dp3d_ref)) then - tmp=elem(ie)%state%dp3d(:,:,k,nt)-dp3d_ref(:,:,k,ie) - else - tmp=elem(ie)%state%dp3d(:,:,k,nt) - end if + + tmp=elem(ie)%state%dp3d(:,:,k,nt)-elem(ie)%derived%dp_ref(:,:,k) call laplace_sphere_wk(tmp,deriv,elem(ie),dptens(:,:,k,ie),var_coef=var_coef1) call vlaplace_sphere_wk(elem(ie)%state%v(:,:,:,k,nt),deriv,elem(ie),.true.,vtens(:,:,:,k,ie), & var_coef=var_coef1,nu_ratio=nu_ratio1) - enddo - + end do + kptr = kbeg - 1 call edgeVpack(edge3,ttens(:,:,kbeg:kend,ie),kblk,kptr,ie) - - kptr = kbeg - 1 + nlev + + kptr = kbeg - 1 + nlev call edgeVpack(edge3,vtens(:,:,1,kbeg:kend,ie),kblk,kptr,ie) - - kptr = kbeg - 1 + 2*nlev + + kptr = kbeg - 1 + 2*nlev call edgeVpack(edge3,vtens(:,:,2,kbeg:kend,ie),kblk,kptr,ie) - - kptr = kbeg - 1 + 3*nlev + + kptr = kbeg - 1 + 3*nlev call edgeVpack(edge3,dptens(:,:,kbeg:kend,ie),kblk,kptr,ie) - enddo - + end do + call bndry_exchange(hybrid,edge3,location='biharmonic_wk_dp3d') - + do ie=nets,nete !CLEAN rspheremv => elem(ie)%rspheremp(:,:) - + kptr = kbeg - 1 call edgeVunpack(edge3,ttens(:,:,kbeg:kend,ie),kblk,kptr,ie) - - kptr = kbeg - 1 + nlev + + kptr = kbeg - 1 + nlev call edgeVunpack(edge3,vtens(:,:,1,kbeg:kend,ie),kblk,kptr,ie) - - kptr = kbeg - 1 + 2*nlev + + kptr = kbeg - 1 + 2*nlev call edgeVunpack(edge3,vtens(:,:,2,kbeg:kend,ie),kblk,kptr,ie) - - kptr = kbeg - 1 + 3*nlev + + kptr = kbeg - 1 + 3*nlev call edgeVunpack(edge3,dptens(:,:,kbeg:kend,ie),kblk,kptr,ie) - - if (ntrac>0) then + + if (use_cslam) then do k=1,nlev -!CLEAN tmp(:,:)= rspheremv(:,:)*dptens(:,:,k,ie) - tmp(:,:)= elem(ie)%rspheremp(:,:)*dptens(:,:,k,ie) - call subcell_Laplace_fluxes(tmp, deriv, elem(ie), np, nc,dpflux(:,:,:,k,ie)) - enddo - endif - +!CLEAN tmp(:,:)= rspheremv(:,:)*dptens(:,:,k,ie) + tmp(:,:)= elem(ie)%rspheremp(:,:)*dptens(:,:,k,ie) + call subcell_Laplace_fluxes(tmp, deriv, elem(ie), np, nc,dpflux(:,:,:,k,ie)) + end do + end if + ! apply inverse mass matrix, then apply laplace again !$omp parallel do num_threads(vert_num_threads) private(k,v,tmp,tmp2) do k=kbeg,kend @@ -179,9 +171,9 @@ subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid, v(:,:,2)=elem(ie)%rspheremp(:,:)*vtens(:,:,2,k,ie) call vlaplace_sphere_wk(v(:,:,:),deriv,elem(ie),.true.,vtens(:,:,:,k,ie), & var_coef=.true.,nu_ratio=nu_ratio2) - - enddo - enddo + + end do + end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end subroutine biharmonic_wk_dp3d @@ -194,7 +186,7 @@ subroutine biharmonic_wk_omega(elem,ptens,deriv,edge3,hybrid,nets,nete,kbeg,kend real (kind=r8), dimension(np,np,nlev,nets:nete) :: ptens type (EdgeBuffer_t) , intent(inout) :: edge3 type (derivative_t) , intent(in) :: deriv - + ! local integer :: i,j,k,kptr,ie,kblk real (kind=r8), dimension(:,:), pointer :: rspheremv @@ -203,44 +195,44 @@ subroutine biharmonic_wk_omega(elem,ptens,deriv,edge3,hybrid,nets,nete,kbeg,kend real (kind=r8), dimension(np,np,2) :: v real (kind=r8) :: nu_ratio1, nu_ratio2 logical var_coef1 - + kblk = kend - kbeg + 1 - - !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) + + !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) !so tensor is only used on second call to laplace_sphere_wk var_coef1 = .true. if(hypervis_scaling > 0) var_coef1 = .false. - + nu_ratio1=1 nu_ratio2=1 - + do ie=nets,nete - + !$omp parallel do num_threads(vert_num_threads) private(k,tmp) do k=kbeg,kend - tmp=elem(ie)%derived%omega(:,:,k) + tmp=elem(ie)%derived%omega(:,:,k) call laplace_sphere_wk(tmp,deriv,elem(ie),ptens(:,:,k,ie),var_coef=var_coef1) - enddo - + end do + kptr = kbeg - 1 call edgeVpack(edge3,ptens(:,:,kbeg:kend,ie),kblk,kptr,ie) - enddo - + end do + call bndry_exchange(hybrid,edge3,location='biharmonic_wk_omega') - + do ie=nets,nete rspheremv => elem(ie)%rspheremp(:,:) - + kptr = kbeg - 1 call edgeVunpack(edge3,ptens(:,:,kbeg:kend,ie),kblk,kptr,ie) - + ! apply inverse mass matrix, then apply laplace again !$omp parallel do num_threads(vert_num_threads) private(k,tmp) do k=kbeg,kend tmp(:,:)=rspheremv(:,:)*ptens(:,:,k,ie) call laplace_sphere_wk(tmp,deriv,elem(ie),ptens(:,:,k,ie),var_coef=.true.) - enddo - enddo + end do + end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end subroutine biharmonic_wk_omega @@ -261,14 +253,14 @@ subroutine biharmonic_wk_scalar(elem,qtens,deriv,edgeq,hybrid,nets,nete) ! local integer :: k,kptr,i,j,ie,ic,q -integer :: kbeg,kend,qbeg,qend +integer :: kbeg,kend,qbeg,qend real (kind=r8), dimension(np,np) :: lap_p logical var_coef1 integer :: kblk,qblk ! The per thead size of the vertical and tracers call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend) - !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) + !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) !so tensor is only used on second call to laplace_sphere_wk var_coef1 = .true. if(hypervis_scaling > 0) var_coef1 = .false. @@ -278,31 +270,31 @@ subroutine biharmonic_wk_scalar(elem,qtens,deriv,edgeq,hybrid,nets,nete) qblk = qend - qbeg + 1 ! calculate size of the block of tracers do ie=nets,nete - do q=qbeg,qend + do q=qbeg,qend do k=kbeg,kend lap_p(:,:)=qtens(:,:,k,q,ie) call laplace_sphere_wk(lap_p,deriv,elem(ie),qtens(:,:,k,q,ie),var_coef=var_coef1) - enddo + end do kptr = nlev*(q-1) + kbeg - 1 call edgeVpack(edgeq, qtens(:,:,kbeg:kend,q,ie),kblk,kptr,ie) - enddo - enddo + end do + end do call bndry_exchange(hybrid,edgeq,location='biharmonic_wk_scalar') - + do ie=nets,nete ! apply inverse mass matrix, then apply laplace again - do q=qbeg,qend + do q=qbeg,qend kptr = nlev*(q-1) + kbeg - 1 call edgeVunpack(edgeq, qtens(:,:,kbeg:kend,q,ie),kblk,kptr,ie) do k=kbeg,kend lap_p(:,:)=elem(ie)%rspheremp(:,:)*qtens(:,:,k,q,ie) call laplace_sphere_wk(lap_p,deriv,elem(ie),qtens(:,:,k,q,ie),var_coef=.true.) - enddo - enddo - enddo + end do + end do + end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end subroutine biharmonic_wk_scalar @@ -310,7 +302,7 @@ end subroutine biharmonic_wk_scalar subroutine make_C0(zeta,elem,hybrid,nets,nete) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! apply DSS (aka assembly procedure) to zeta. +! apply DSS (aka assembly procedure) to zeta. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! type (hybrid_t) , intent(in) :: hybrid @@ -322,7 +314,7 @@ subroutine make_C0(zeta,elem,hybrid,nets,nete) integer :: k,i,j,ie,ic,kptr,nthread_save - call initEdgeBuffer(hybrid%par,edge1,elem,nlev) +call initEdgeBuffer(hybrid%par,edge1,elem,nlev) do ie=nets,nete #if (defined COLUMN_OPENMP) @@ -330,10 +322,10 @@ subroutine make_C0(zeta,elem,hybrid,nets,nete) #endif do k=1,nlev zeta(:,:,k,ie)=zeta(:,:,k,ie)*elem(ie)%spheremp(:,:) - enddo + end do kptr=0 call edgeVpack(edge1, zeta(1,1,1,ie),nlev,kptr,ie) -enddo +end do call bndry_exchange(hybrid,edge1,location='make_C0') do ie=nets,nete kptr=0 @@ -343,10 +335,10 @@ subroutine make_C0(zeta,elem,hybrid,nets,nete) #endif do k=1,nlev zeta(:,:,k,ie)=zeta(:,:,k,ie)*elem(ie)%rspheremp(:,:) - enddo -enddo + end do +end do -call FreeEdgeBuffer(edge1) +call FreeEdgeBuffer(edge1) end subroutine @@ -397,10 +389,10 @@ subroutine make_C0_vector(v,elem,hybrid,nets,nete) do k=1,nlev v(:,:,1,k,ie)=v(:,:,1,k,ie)*elem(ie)%spheremp(:,:) v(:,:,2,k,ie)=v(:,:,2,k,ie)*elem(ie)%spheremp(:,:) - enddo + end do kptr=0 call edgeVpack(edge2, v(1,1,1,1,ie),2*nlev,kptr,ie) -enddo +end do call bndry_exchange(hybrid,edge2,location='make_C0_vector') do ie=nets,nete kptr=0 @@ -411,10 +403,10 @@ subroutine make_C0_vector(v,elem,hybrid,nets,nete) do k=1,nlev v(:,:,1,k,ie)=v(:,:,1,k,ie)*elem(ie)%rspheremp(:,:) v(:,:,2,k,ie)=v(:,:,2,k,ie)*elem(ie)%rspheremp(:,:) - enddo -enddo + end do +end do -call FreeEdgeBuffer(edge2) +call FreeEdgeBuffer(edge2) #endif end subroutine @@ -425,11 +417,11 @@ subroutine make_C0_vector(v,elem,hybrid,nets,nete) subroutine compute_zeta_C0_contra(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 vorticity. That is, solve: +! compute C0 vorticity. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in contra-variant coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -453,8 +445,8 @@ subroutine compute_zeta_C0_contra(zeta,elem,hybrid,nets,nete,nt) ulatlon(:,:,1) = elem(ie)%D(:,:,1,1)*v1 + elem(ie)%D(:,:,1,2)*v2 ulatlon(:,:,2) = elem(ie)%D(:,:,2,1)*v1 + elem(ie)%D(:,:,2,2)*v2 call vorticity_sphere(ulatlon,deriv,elem(ie),zeta(:,:,k,ie)) -enddo -enddo +end do +end do call make_C0(zeta,elem,hybrid,nets,nete) @@ -464,11 +456,11 @@ subroutine compute_zeta_C0_contra(zeta,elem,hybrid,nets,nete,nt) subroutine compute_div_C0_contra(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 divergence. That is, solve: +! compute C0 divergence. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in contra-variant coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -492,8 +484,8 @@ subroutine compute_div_C0_contra(zeta,elem,hybrid,nets,nete,nt) ulatlon(:,:,1) = elem(ie)%D(:,:,1,1)*v1 + elem(ie)%D(:,:,1,2)*v2 ulatlon(:,:,2) = elem(ie)%D(:,:,2,1)*v1 + elem(ie)%D(:,:,2,2)*v2 call divergence_sphere(ulatlon,deriv,elem(ie),zeta(:,:,k,ie)) -enddo -enddo +end do +end do call make_C0(zeta,elem,hybrid,nets,nete) @@ -501,11 +493,11 @@ subroutine compute_div_C0_contra(zeta,elem,hybrid,nets,nete,nt) subroutine compute_zeta_C0_par(zeta,elem,par,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 vorticity. That is, solve: +! compute C0 vorticity. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! type (parallel_t) :: par @@ -528,11 +520,11 @@ subroutine compute_zeta_C0_par(zeta,elem,par,nt) subroutine compute_div_C0_par(zeta,elem,par,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 divergence. That is, solve: +! compute C0 divergence. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -557,11 +549,11 @@ subroutine compute_div_C0_par(zeta,elem,par,nt) subroutine compute_zeta_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 vorticity. That is, solve: +! compute C0 vorticity. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -582,8 +574,8 @@ subroutine compute_zeta_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) #endif do k=1,nlev call vorticity_sphere(elem(ie)%state%v(:,:,:,k,nt),deriv,elem(ie),zeta(:,:,k,ie)) -enddo -enddo +end do +end do call make_C0(zeta,elem,hybrid,nets,nete) @@ -592,11 +584,11 @@ subroutine compute_zeta_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) subroutine compute_div_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 divergence. That is, solve: +! compute C0 divergence. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -617,8 +609,8 @@ subroutine compute_div_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) #endif do k=1,nlev call divergence_sphere(elem(ie)%state%v(:,:,:,k,nt),deriv,elem(ie),zeta(:,:,k,ie)) -enddo -enddo +end do +end do call make_C0(zeta,elem,hybrid,nets,nete) @@ -632,31 +624,31 @@ subroutine compute_div_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) subroutine neighbor_minmax(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh) - + type (hybrid_t) , intent(in) :: hybrid type (EdgeBuffer_t) , intent(inout) :: edgeMinMax integer :: nets,nete real (kind=r8) :: min_neigh(nlev,qsize,nets:nete) real (kind=r8) :: max_neigh(nlev,qsize,nets:nete) integer :: kblk, qblk - ! local + ! local integer:: ie, q, k, kptr integer:: kbeg, kend, qbeg, qend call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend) - + kblk = kend - kbeg + 1 ! calculate size of the block of vertical levels qblk = qend - qbeg + 1 ! calculate size of the block of tracers - + do ie=nets,nete do q = qbeg, qend kptr = nlev*(q - 1) + kbeg - 1 call edgeSpack(edgeMinMax,min_neigh(kbeg:kend,q,ie),kblk,kptr,ie) kptr = qsize*nlev + nlev*(q - 1) + kbeg - 1 call edgeSpack(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie) - enddo - enddo - + end do + end do + call bndry_exchange(hybrid,edgeMinMax,location='neighbor_minmax') do ie=nets,nete @@ -667,12 +659,12 @@ subroutine neighbor_minmax(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh) call edgeSunpackMAX(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie) do k=kbeg,kend min_neigh(k,q,ie) = max(min_neigh(k,q,ie),0.0_r8) - enddo - enddo - enddo + end do + end do + end do end subroutine neighbor_minmax - + subroutine neighbor_minmax_start(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh) @@ -684,7 +676,7 @@ subroutine neighbor_minmax_start(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh integer :: kblk, qblk integer :: kbeg, kend, qbeg, qend - ! local + ! local integer :: ie,q, k,kptr call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend) @@ -698,8 +690,8 @@ subroutine neighbor_minmax_start(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh call edgeSpack(edgeMinMax,min_neigh(kbeg:kend,q,ie),kblk,kptr,ie) kptr = qsize*nlev + nlev*(q - 1) + kbeg - 1 call edgeSpack(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie) - enddo - enddo + end do + end do call bndry_exchange_start(hybrid,edgeMinMax,location='neighbor_minmax_start') @@ -731,9 +723,9 @@ subroutine neighbor_minmax_finish(hybrid,edgeMinMax,nets,nete,min_neigh,max_neig call edgeSunpackMAX(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie) do k=kbeg,kend min_neigh(k,q,ie) = max(min_neigh(k,q,ie),0.0_r8) - enddo - enddo - enddo + end do + end do + end do end subroutine neighbor_minmax_finish diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 1fac36667..03b5b3d9f 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -2,55 +2,15 @@ module dyn_comp ! CAM interfaces to the SE Dynamical Core -use shr_kind_mod, only: r8=>shr_kind_r8, shr_kind_cl +use shr_kind_mod, only: r8=>shr_kind_r8, cl=>shr_kind_cl use dynconst, only: pi -use spmd_utils, only: iam, masterproc -use cam_constituents, only: const_name, const_longname, num_advected -use cam_constituents, only: const_get_index, const_is_wet, const_qmin -use cam_constituents, only: readtrace -use air_composition, only: const_is_water_species -use cam_control_mod, only: initial_run -use cam_physics_control, only: simple_phys -use cam_initfiles, only: initial_file_get_id, topo_file_get_id, pertlim -use dyn_grid, only: ini_grid_name, timelevel, hvcoord, edgebuf - -use cam_grid_support, only: cam_grid_id, cam_grid_get_gcid, & - cam_grid_dimensions, cam_grid_get_dim_names, & - cam_grid_get_latvals, cam_grid_get_lonvals, & - max_hcoordname_len - -use inic_analytic, only: analytic_ic_active, analytic_ic_set_ic -use dyn_tests_utils, only: vcoord=>vc_dry_pressure - -!use cam_history, only: outfld, hist_fld_active, fieldname_len -!use cam_history_support, only: max_fieldname_len -use time_manager, only: get_step_size - -use cam_field_read, only: cam_read_field - -use pio, only: file_desc_t, pio_seterrorhandling, PIO_BCAST_ERROR, & - pio_inq_dimid, pio_inq_dimlen, PIO_NOERR - -use shr_infnan_mod, only: shr_infnan_isnan -use cam_logfile, only: iulog -use cam_abortutils, only: endrun, check_allocate -use cam_map_utils, only: iMap -use shr_sys_mod, only: shr_sys_flush - -use parallel_mod, only: par -use hybrid_mod, only: hybrid_t -use dimensions_mod, only: nelemd, nlev, np, npsq, ntrac, nc, fv_nphys, & - qsize -use element_mod, only: element_t, elem_state_t + +!SE dycore: +use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct -use time_mod, only: nsplit -use edge_mod, only: initEdgeBuffer, edgeVpack, edgeVunpack, FreeEdgeBuffer -use edgetype_mod, only: EdgeBuffer_t -use bndry_mod, only: bndry_exchange implicit none private -save public :: & dyn_import_t, & @@ -88,49 +48,63 @@ module dyn_comp real(r8), parameter :: rad2deg = 180.0_r8 / pi real(r8), parameter :: deg2rad = pi / 180.0_r8 -integer, parameter :: max_fieldname_len = 27 !Remove once history is enabled -JN +! Character array used to hold diagnostic names for constituent +! fields on GLL grid: +character(len=cl), allocatable, public, protected :: cnst_diag_name_gll(:) + +! Stash of namelist se_statediag_numtrac. The final statediag_numtrac +! is computed in dyn_init once num_advected (via qsize) is valid; it cannot +! be computed in dyn_readnl because that runs before cam_register_constituents. +integer, private :: se_statediag_numtrac_save = 0 + +!Index array to map CCPP constituent array indices to an array of +!only advected constituents (which is what the dycore needs): +integer, allocatable, public, protected :: advected_constituent_index(:) !=============================================================================== contains !=============================================================================== subroutine dyn_readnl(NLFileName) - use mpi, only: mpi_real8, mpi_integer, mpi_character, mpi_logical - use air_composition,only: thermodynamic_active_species_num - use shr_nl_mod, only: find_group_name => shr_nl_find_group_name - use spmd_utils, only: masterproc, masterprocid, mpicom, npes - use dyn_grid, only: se_write_grid_file, se_grid_filename, se_write_gll_corners - use native_mapping, only: native_mapping_readnl - use vert_coord, only: pver + use mpi, only: mpi_real8, mpi_integer, mpi_character, mpi_logical + use air_composition, only: thermodynamic_active_species_num + use shr_nl_mod, only: find_group_name => shr_nl_find_group_name + use spmd_utils, only: masterproc, masterprocid, mpicom, npes + use dyn_grid, only: se_write_grid_file, se_grid_filename, se_write_gll_corners + use native_mapping, only: native_mapping_readnl + use vert_coord, only: pver + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use cam_control_mod, only: initial_run !SE dycore: - use namelist_mod, only: homme_set_defaults, homme_postprocess_namelist - use control_mod, only: hypervis_subcycle, hypervis_subcycle_sponge - use control_mod, only: hypervis_subcycle_q, statefreq, runtype - use control_mod, only: nu, nu_div, nu_p, nu_q, nu_top, qsplit, rsplit - use control_mod, only: vert_remap_uvTq_alg, vert_remap_tracer_alg - use control_mod, only: tstep_type, rk_stage_user - use control_mod, only: ftype, limiter_option, partmethod - use control_mod, only: topology, phys_dyn_cp, variable_nsplit - use control_mod, only: fine_ne, hypervis_power, hypervis_scaling - use control_mod, only: max_hypervis_courant, statediag_numtrac,refined_mesh - use control_mod, only: raytau0, raykrange, rayk0, molecular_diff - use dimensions_mod, only: ne, npart - use dimensions_mod, only: lcp_moist - use dimensions_mod, only: hypervis_dynamic_ref_state,large_Courant_incr - use dimensions_mod, only: fvm_supercycling, fvm_supercycling_jet - use dimensions_mod, only: kmin_jet, kmax_jet - use params_mod, only: SFCURVE - use parallel_mod, only: initmpi - use thread_mod, only: initomp, max_num_threads - use thread_mod, only: horz_num_threads, vert_num_threads, tracer_num_threads + use namelist_mod, only: homme_set_defaults, homme_postprocess_namelist + use control_mod, only: hypervis_subcycle, hypervis_subcycle_sponge + use control_mod, only: hypervis_subcycle_q, statefreq, runtype + use control_mod, only: nu, nu_div, nu_p, nu_q, nu_top, qsplit, rsplit + use control_mod, only: vert_remap_uvTq_alg, vert_remap_tracer_alg + use control_mod, only: tstep_type, rk_stage_user + use control_mod, only: ftype, limiter_option, partmethod + use control_mod, only: topology, variable_nsplit + use control_mod, only: fine_ne, hypervis_power, hypervis_scaling + use control_mod, only: max_hypervis_courant, statediag_numtrac,refined_mesh + use control_mod, only: molecular_diff, pgf_formulation, dribble_in_rsplit_loop + use control_mod, only: sponge_del4_nu_div_fac, sponge_del4_nu_fac, sponge_del4_lev + use dimensions_mod, only: ne, npart, fv_nphys, use_cslam + use dimensions_mod, only: large_Courant_incr + use dimensions_mod, only: fvm_supercycling, fvm_supercycling_jet + use dimensions_mod, only: kmin_jet, kmax_jet + use params_mod, only: SFCURVE + use parallel_mod, only: par, initmpi + use thread_mod, only: initomp, max_num_threads + use thread_mod, only: horz_num_threads, vert_num_threads, tracer_num_threads + use se_dyn_time_mod, only: nsplit ! Dummy argument character(len=*), intent(in) :: NLFileName ! Local variables integer :: unitn, ierr,k - real(r8) :: uniform_res_hypervis_scaling,nu_fac ! SE Namelist variables integer :: se_fine_ne @@ -144,7 +118,7 @@ subroutine dyn_readnl(NLFileName) integer :: se_hypervis_subcycle_q integer :: se_limiter_option real(r8) :: se_max_hypervis_courant - character(len=SHR_KIND_CL) :: se_mesh_file + character(len=cl) :: se_mesh_file integer :: se_ne integer :: se_npes integer :: se_nsplit @@ -152,6 +126,9 @@ subroutine dyn_readnl(NLFileName) real(r8) :: se_nu_div real(r8) :: se_nu_p real(r8) :: se_nu_top + real(r8) :: se_sponge_del4_nu_fac + real(r8) :: se_sponge_del4_nu_div_fac + integer :: se_sponge_del4_lev integer :: se_qsplit logical :: se_refined_mesh integer :: se_rsplit @@ -163,19 +140,15 @@ subroutine dyn_readnl(NLFileName) integer :: se_horz_num_threads integer :: se_vert_num_threads integer :: se_tracer_num_threads - logical :: se_hypervis_dynamic_ref_state - logical :: se_lcp_moist logical :: se_write_restart_unstruct logical :: se_large_Courant_incr integer :: se_fvm_supercycling integer :: se_fvm_supercycling_jet integer :: se_kmin_jet integer :: se_kmax_jet - integer :: se_phys_dyn_cp - real(r8) :: se_raytau0 - real(r8) :: se_raykrange - integer :: se_rayk0 real(r8) :: se_molecular_diff + integer :: se_pgf_formulation + real(r8) :: se_dribble_in_rsplit_loop namelist /dyn_se_nl/ & se_fine_ne, & ! For refined meshes @@ -197,6 +170,9 @@ subroutine dyn_readnl(NLFileName) se_nu_div, & se_nu_p, & se_nu_top, & + se_sponge_del4_nu_fac, & + se_sponge_del4_nu_div_fac, & + se_sponge_del4_lev, & se_qsplit, & se_refined_mesh, & se_rsplit, & @@ -211,19 +187,15 @@ subroutine dyn_readnl(NLFileName) se_horz_num_threads, & se_vert_num_threads, & se_tracer_num_threads, & - se_hypervis_dynamic_ref_state,& - se_lcp_moist, & se_write_restart_unstruct, & se_large_Courant_incr, & se_fvm_supercycling, & se_fvm_supercycling_jet, & se_kmin_jet, & se_kmax_jet, & - se_phys_dyn_cp, & - se_raytau0, & - se_raykrange, & - se_rayk0, & - se_molecular_diff + se_molecular_diff, & + se_pgf_formulation, & + se_dribble_in_rsplit_loop !-------------------------------------------------------------------------- @@ -261,7 +233,7 @@ subroutine dyn_readnl(NLFileName) call MPI_bcast(se_hypervis_subcycle_q, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_limiter_option, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_max_hypervis_courant, 1, mpi_real8, masterprocid, mpicom, ierr) - call MPI_bcast(se_mesh_file, SHR_KIND_CL, mpi_character, masterprocid, mpicom, ierr) + call MPI_bcast(se_mesh_file, cl, mpi_character, masterprocid, mpicom, ierr) call MPI_bcast(se_ne, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_npes, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_nsplit, 1, mpi_integer, masterprocid, mpicom, ierr) @@ -269,6 +241,9 @@ subroutine dyn_readnl(NLFileName) call MPI_bcast(se_nu_div, 1, mpi_real8, masterprocid, mpicom, ierr) call MPI_bcast(se_nu_p, 1, mpi_real8, masterprocid, mpicom, ierr) call MPI_bcast(se_nu_top, 1, mpi_real8, masterprocid, mpicom, ierr) + call MPI_bcast(se_sponge_del4_nu_fac, 1, mpi_real8, masterprocid, mpicom, ierr) + call MPI_bcast(se_sponge_del4_nu_div_fac, 1, mpi_real8, masterprocid, mpicom, ierr) + call MPI_bcast(se_sponge_del4_lev, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_qsplit, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_refined_mesh, 1, mpi_logical, masterprocid, mpicom, ierr) call MPI_bcast(se_rsplit, 1, mpi_integer, masterprocid, mpicom, ierr) @@ -279,25 +254,20 @@ subroutine dyn_readnl(NLFileName) call MPI_bcast(se_vert_remap_tracer_alg, 32, mpi_character, masterprocid, mpicom, ierr) call MPI_bcast(se_fv_nphys, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_write_grid_file, 16, mpi_character, masterprocid, mpicom, ierr) - call MPI_bcast(se_grid_filename, shr_kind_cl, mpi_character, masterprocid, mpicom, ierr) + call MPI_bcast(se_grid_filename, cl, mpi_character, masterprocid, mpicom, ierr) call MPI_bcast(se_write_gll_corners, 1, mpi_logical, masterprocid, mpicom, ierr) call MPI_bcast(se_horz_num_threads, 1, MPI_integer, masterprocid, mpicom,ierr) call MPI_bcast(se_vert_num_threads, 1, MPI_integer, masterprocid, mpicom,ierr) call MPI_bcast(se_tracer_num_threads, 1, MPI_integer, masterprocid, mpicom,ierr) - call MPI_bcast(se_hypervis_dynamic_ref_state, 1, mpi_logical, masterprocid, mpicom, ierr) - call MPI_bcast(se_lcp_moist, 1, mpi_logical, masterprocid, mpicom, ierr) call MPI_bcast(se_write_restart_unstruct, 1, mpi_logical, masterprocid, mpicom, ierr) call MPI_bcast(se_large_Courant_incr, 1, mpi_logical, masterprocid, mpicom, ierr) call MPI_bcast(se_fvm_supercycling, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_fvm_supercycling_jet, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_kmin_jet, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_kmax_jet, 1, mpi_integer, masterprocid, mpicom, ierr) - call MPI_bcast(se_phys_dyn_cp, 1, mpi_integer, masterprocid, mpicom, ierr) - call MPI_bcast(se_rayk0 , 1, mpi_integer, masterprocid, mpicom, ierr) - call MPI_bcast(se_raykrange, 1, mpi_real8, masterprocid, mpicom, ierr) - call MPI_bcast(se_raytau0, 1, mpi_real8, masterprocid, mpicom, ierr) call MPI_bcast(se_molecular_diff, 1, mpi_real8, masterprocid, mpicom, ierr) - + call MPI_bcast(se_pgf_formulation, 1, mpi_integer, masterprocid, mpicom, ierr) + call MPI_bcast(se_dribble_in_rsplit_loop, 1, mpi_integer, masterprocid, mpicom, ierr) ! If se_npes is set to negative one, then make it match host model: if (se_npes == -1) then se_npes = npes @@ -324,19 +294,25 @@ subroutine dyn_readnl(NLFileName) ! Set HOMME defaults call homme_set_defaults() ! Set HOMME variables not in CAM's namelist but with different CAM defaults - partmethod = SFCURVE - npart = se_npes + partmethod = SFCURVE + npart = se_npes ! CAM requires forward-in-time, subcycled dynamics ! RK2 3 stage tracers, sign-preserving conservative - rk_stage_user = 3 - topology = "cube" + rk_stage_user = 3 + topology = "cube" ! Finally, set the HOMME variables which have different names - fine_ne = se_fine_ne - ftype = se_ftype - statediag_numtrac = MIN(se_statediag_numtrac,num_advected) - hypervis_power = se_hypervis_power - hypervis_scaling = se_hypervis_scaling - hypervis_subcycle = se_hypervis_subcycle + fine_ne = se_fine_ne + ftype = se_ftype + ! Stash the raw namelist value; the MIN with num_advected must be deferred + ! to dyn_init (num_advected is still 0 at this point — see module header + ! comment on se_statediag_numtrac_save). + se_statediag_numtrac_save = se_statediag_numtrac + sponge_del4_nu_fac = se_sponge_del4_nu_fac + sponge_del4_nu_div_fac = se_sponge_del4_nu_div_fac + sponge_del4_lev = se_sponge_del4_lev + hypervis_power = se_hypervis_power + hypervis_scaling = se_hypervis_scaling + hypervis_subcycle = se_hypervis_subcycle if (hypervis_subcycle_sponge<0) then hypervis_subcycle_sponge = hypervis_subcycle else @@ -360,20 +336,15 @@ subroutine dyn_readnl(NLFileName) vert_remap_uvTq_alg = set_vert_remap(se_vert_remap_T, se_vert_remap_uvTq_alg) vert_remap_tracer_alg = set_vert_remap(se_vert_remap_T, se_vert_remap_tracer_alg) fv_nphys = se_fv_nphys - hypervis_dynamic_ref_state = se_hypervis_dynamic_ref_state - lcp_moist = se_lcp_moist large_Courant_incr = se_large_Courant_incr fvm_supercycling = se_fvm_supercycling fvm_supercycling_jet = se_fvm_supercycling_jet kmin_jet = se_kmin_jet kmax_jet = se_kmax_jet variable_nsplit = .false. - phys_dyn_cp = se_phys_dyn_cp - raytau0 = se_raytau0 - raykrange = se_raykrange - rayk0 = se_rayk0 molecular_diff = se_molecular_diff - + pgf_formulation = se_pgf_formulation + dribble_in_rsplit_loop = se_dribble_in_rsplit_loop if (rsplit < 1) then call endrun('dyn_readnl: rsplit must be > 0') end if @@ -419,7 +390,7 @@ subroutine dyn_readnl(NLFileName) if (masterproc) then write(iulog, '(a,i0)') 'dyn_readnl: se_ftype = ',ftype - write(iulog, '(a,i0)') 'dyn_readnl: se_statediag_numtrac = ',statediag_numtrac + write(iulog, '(a,i0)') 'dyn_readnl: se_statediag_numtrac = ',se_statediag_numtrac_save write(iulog, '(a,i0)') 'dyn_readnl: se_hypervis_subcycle = ',se_hypervis_subcycle write(iulog, '(a,i0)') 'dyn_readnl: se_hypervis_subcycle_sponge = ',se_hypervis_subcycle_sponge write(iulog, '(a,i0)') 'dyn_readnl: se_hypervis_subcycle_q = ',se_hypervis_subcycle_q @@ -430,7 +401,6 @@ subroutine dyn_readnl(NLFileName) end if write(iulog, '(a,i0)') 'dyn_readnl: se_npes = ',se_npes write(iulog, '(a,i0)') 'dyn_readnl: se_nsplit = ',se_nsplit - write(iulog, '(a,i0)') 'dyn_readnl: se_phys_dyn_cp = ',se_phys_dyn_cp ! ! se_nu<0 then coefficients are set automatically in module global_norms_mod ! @@ -443,15 +413,20 @@ subroutine dyn_readnl(NLFileName) write(iulog, '(a)') 'Note that nu_q must be the same as nu_p for mass / tracer inconsistency' end if write(iulog, '(a,e9.2)') 'dyn_readnl: se_nu_top = ',se_nu_top + write(iulog, *) 'dyn_readnl: se_sponge_del4_nu_fac = ',se_sponge_del4_nu_fac + if (se_sponge_del4_nu_fac < 0) write(iulog, '(a)') ' (automatically set based on model top location)' + write(iulog, *) 'dyn_readnl: se_sponge_del4_nu_div_fac = ',se_sponge_del4_nu_div_fac + if (se_sponge_del4_nu_div_fac < 0) write(iulog, '(a)') ' (automatically set based on model top location)' + write(iulog, *) 'dyn_readnl: se_sponge_del4_lev = ',se_sponge_del4_lev + if (se_sponge_del4_lev < 0) write(iulog, '(a)') ' (automatically set based on model top location)' write(iulog, '(a,i0)') 'dyn_readnl: se_qsplit = ',se_qsplit write(iulog, '(a,i0)') 'dyn_readnl: se_rsplit = ',se_rsplit write(iulog, '(a,i0)') 'dyn_readnl: se_statefreq = ',se_statefreq + write(iulog, '(a,i0)') 'dyn_readnl: se_pgf_formulation = ',pgf_formulation write(iulog, '(a,i0)') 'dyn_readnl: se_tstep_type = ',se_tstep_type write(iulog, '(a,a)') 'dyn_readnl: se_vert_remap_T = ',trim(se_vert_remap_T) write(iulog, '(a,a)') 'dyn_readnl: se_vert_remap_uvTq_alg = ',trim(se_vert_remap_uvTq_alg) write(iulog, '(a,a)') 'dyn_readnl: se_vert_remap_tracer_alg = ',trim(se_vert_remap_tracer_alg) - write(iulog, '(a,l4)') 'dyn_readnl: se_hypervis_dynamic_ref_state = ',hypervis_dynamic_ref_state - write(iulog, '(a,l4)') 'dyn_readnl: lcp_moist = ',lcp_moist write(iulog, '(a,i0)') 'dyn_readnl: se_fvm_supercycling = ',fvm_supercycling write(iulog, '(a,i0)') 'dyn_readnl: se_fvm_supercycling_jet = ',fvm_supercycling_jet write(iulog, '(a,i0)') 'dyn_readnl: se_kmin_jet = ',kmin_jet @@ -470,7 +445,7 @@ subroutine dyn_readnl(NLFileName) end if end if - if (fv_nphys > 0) then + if (use_cslam) then write(iulog, '(a)') 'dyn_readnl: physics will run on FVM points; advection by CSLAM' write(iulog,'(a,i0)') 'dyn_readnl: se_fv_nphys = ', fv_nphys else @@ -488,10 +463,6 @@ subroutine dyn_readnl(NLFileName) se_write_gll_corners write(iulog,'(a,l1)') 'dyn_readnl: write restart data on unstructured grid = ', & se_write_restart_unstruct - - write(iulog, '(a,e9.2)') 'dyn_readnl: se_raytau0 = ', raytau0 - write(iulog, '(a,e9.2)') 'dyn_readnl: se_raykrange = ', raykrange - write(iulog, '(a,i0)' ) 'dyn_readnl: se_rayk0 = ', rayk0 write(iulog, '(a,e9.2)') 'dyn_readnl: se_molecular_diff = ', molecular_diff end if @@ -503,6 +474,9 @@ subroutine dyn_readnl(NLFileName) integer function set_vert_remap( remap_T, remap_alg ) + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + ! Convert namelist input strings to the internally used integers. character(len=*), intent(in) :: remap_T ! scheme for remapping temperature @@ -557,33 +531,47 @@ end subroutine dyn_readnl !========================================================================================= subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) - use runtime_obj, only: runtime_options - use dyn_grid, only: elem, fvm - use cam_pio_utils, only: clean_iodesc_list - use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx - use air_composition, only: thermodynamic_active_species_idx_dycore - use dynconst, only: cpair - use dyn_thermo, only: get_molecular_diff_coef_reference - !use cam_history, only: addfld, add_default, horiz_only, register_vector_field + use runtime_obj, only: runtime_options + use cam_logfile, only: iulog + use dyn_grid, only: elem, fvm, hvcoord + use dyn_grid, only: TimeLevel + use cam_pio_utils, only: clean_iodesc_list + use cam_abortutils, only: check_allocate + use spmd_utils, only: iam, masterproc + use cam_constituents, only: num_advected, num_constituents + use cam_constituents, only: const_name, const_longname, const_diag_name + use cam_constituents, only: const_get_index, const_qmin + use cam_constituents, only: const_is_wet, const_is_advected + use cam_initfiles, only: initial_file_get_id, topo_file_get_id + use cam_control_mod, only: initial_run + use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx + use air_composition, only: thermodynamic_active_species_idx_dycore + use dynconst, only: cpair, pstd + use dyn_thermo, only: get_molecular_diff_coef_reference + use cam_history, only: history_add_field + use cam_history_support, only: horiz_only + !use cam_history, only: register_vector_field use gravity_waves_sources, only: gws_init use cam_thermo_formula, only: energy_formula_dycore, ENERGY_FORMULA_DYCORE_SE use physics_types, only: dycore_energy_consistency_adjust use phys_vars_init_check, only: mark_as_initialized !SE dycore: + use parallel_mod, only: par use prim_advance_mod, only: prim_advance_init use thread_mod, only: horz_num_threads - use hybrid_mod, only: get_loop_ranges, config_thread_region - use dimensions_mod, only: nu_scale_top, nu_lev, nu_div_lev + use hybrid_mod, only: hybrid_t, get_loop_ranges, config_thread_region + use dimensions_mod, only: nu_scale_top, nlev, ntrac, qsize use dimensions_mod, only: ksponge_end, kmvis_ref, kmcnd_ref,rho_ref,km_sponge_factor - use dimensions_mod, only: kmvisi_ref, kmcndi_ref,rhoi_ref - use dimensions_mod, only: cnst_name_gll, cnst_longname_gll - use dimensions_mod, only: irecons_tracer_lev, irecons_tracer, otau, kord_tr, kord_tr_cslam + use dimensions_mod, only: cnst_name_gll, cnst_longname_gll, use_cslam + use dimensions_mod, only: irecons_tracer_lev, irecons_tracer, kord_tr, kord_tr_cslam + use dimensions_mod, only: qmin_cslam use prim_driver_mod, only: prim_init2 - use time_mod, only: time_at - use control_mod, only: runtype, raytau0, raykrange, rayk0, molecular_diff, nu_top - use test_fvm_mapping, only: test_mapping_addfld + use se_dyn_time_mod, only: time_at + use control_mod, only: runtype, nu_top, molecular_diff use control_mod, only: vert_remap_uvTq_alg, vert_remap_tracer_alg + use control_mod, only: statediag_numtrac + use std_atm_profile, only: std_atm_height ! Dummy arguments: type(runtime_options), intent(inout) :: cam_runtime_opts @@ -591,22 +579,26 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) type(dyn_export_t), intent(out) :: dyn_out ! Local variables - integer :: ithr, nets, nete, ie, k, kmol_end + integer :: nets, nete, ie, k, kmol_end, mfound real(r8), parameter :: Tinit = 300.0_r8 - real(r8) :: press, ptop, tref + real(r8) :: press(1), ptop, tref,z(1) type(hybrid_t) :: hybrid integer :: ixq, ixcldice, ixcldliq, ixrain, ixsnow, ixgraupel integer :: m_cnst, m integer :: iret + character(len=cl) :: errmsg ! variables for initializing energy and axial angular momentum diagnostics - character (len = 3), dimension(12) :: stage = (/"dED","dAF","dBD","dAD","dAR","dBF","dBH","dCH","dAH",'dBS','dAS','p2d'/) - character (len = 70),dimension(12) :: stage_txt = (/& + integer, parameter :: num_stages = 14 + character (len = 4), dimension(num_stages) :: stage = (/"dED","dAF","dBD","dBL","dAL","dAD","dAR","dBF","dBH","dCH","dAH","dBS","dAS","p2d"/) + character (len = 70),dimension(num_stages) :: stage_txt = (/& " end of previous dynamics ",& !dED " from previous remapping or state passed to dynamics",& !dAF - state in beginning of nsplit loop " state after applying CAM forcing ",& !dBD - state after applyCAMforcing + " before floating dynamics ",& !dBL + " after floating dynamics ",& !dAL " before vertical remapping ",& !dAD - state before vertical remapping " after vertical remapping ",& !dAR - state at end of nsplit loop " state passed to parameterizations ",& !dBF @@ -617,22 +609,6 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) " state after sponge layer diffusion ",& !dAS - state after sponge del2 " phys2dyn mapping errors (requires ftype-1) " & !p2d - for assessing phys2dyn mapping errors /) - character (len = 2) , dimension(8) :: vars = (/"WV" ,"WL" ,"WI" ,"SE" ,"KE" ,"MR" ,"MO" ,"TT" /) - !if ntrac>0 then tracers should be output on fvm grid but not energy (SE+KE) and AAM diags - logical , dimension(8) :: massv = (/.true.,.true.,.true.,.false.,.false.,.false.,.false.,.false./) - character (len = 70) , dimension(8) :: vars_descriptor = (/& - "Total column water vapor ",& - "Total column cloud water ",& - "Total column cloud ice ",& - "Total column dry static energy ",& - "Total column kinetic energy ",& - "Total column wind axial angular momentum",& - "Total column mass axial angular momentum",& - "Total column test tracer "/) - character (len = 14), dimension(8) :: & - vars_unit = (/& - "kg/m2 ","kg/m2 ","kg/m2 ","J/m2 ",& - "J/m2 ","kg*m2/s*rad2 ","kg*m2/s*rad2 ","kg/m2 "/) integer :: istage, ivars character (len=108) :: str1, str2, str3 @@ -642,7 +618,6 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) character(len=*), parameter :: subname = 'dyn_init' - real(r8) :: tau0, krange, otau0, scale real(r8) :: km_sponge_factor_local(nlev+1) !---------------------------------------------------------------------------- ! Set dynamical core energy formula for use in cam_thermo. @@ -657,26 +632,63 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) ! Set name of dycore in runtime object call cam_runtime_opts%set_dycore('se') + ! Allocate and populate advected constituent index map: + allocate(advected_constituent_index(num_advected), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'advected_constituent_index(num_advected)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + + m_cnst = 1 + do m=1, num_constituents + if (const_is_advected(m)) then + advected_constituent_index(m_cnst) = m + m_cnst = m_cnst + 1 + end if + end do + + ! Finalize statediag_numtrac now that the number of advected + ! constituents is known (qsize is set by dimensions_mod_init, which runs + ! after cam_register_constituents). + statediag_numtrac = MIN(se_statediag_numtrac_save, qsize) + if (masterproc) then + write(iulog, '(a,i0)') 'dyn_init: final statediag_numtrac = ', statediag_numtrac + end if + ! Now allocate and set condenstate vars - allocate(cnst_name_gll(qsize), stat=iret) ! constituent names for gll tracers + allocate(cnst_name_gll(qsize), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'cnst_name_gll(qsize)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(cnst_longname_gll(qsize), stat=iret) ! long name of constituents for gll tracers + allocate(cnst_longname_gll(qsize), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'cnst_longname_gll(qsize)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) + + allocate(cnst_diag_name_gll(qsize), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'cnst_diag_name_gll(qsize)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + - allocate(kord_tr(qsize), stat=iret) + allocate(kord_tr(qsize), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'kord_tr(qsize)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) kord_tr(:) = vert_remap_tracer_alg - if (ntrac>0) then - allocate(kord_tr_cslam(ntrac), stat=iret) + if (use_cslam) then + allocate(kord_tr_cslam(ntrac), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'kord_tr_cslam(ntrac)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) kord_tr_cslam(:) = vert_remap_tracer_alg + + allocate(qmin_cslam(ntrac), stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'qmin_cslam(ntrac)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + + ! CSLAM indexes its tracers 1:ntrac (advected constituents only), while + ! const_qmin takes a constituent index, so translate here rather than + ! inside the dycore. + do m = 1, ntrac + qmin_cslam(m) = const_qmin(advected_constituent_index(m)) + end do end if do m=1,qsize @@ -691,15 +703,23 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) ! CSLAM tracers are always indexed as in physics ! of no CSLAM then SE tracers are always indexed as in physics ! - if (ntrac>0) then + if (use_cslam) then ! ! note that in this case qsize = thermodynamic_active_species_num ! thermodynamic_active_species_idx_dycore(m) = m - kord_tr_cslam(thermodynamic_active_species_idx(m)) = vert_remap_uvTq_alg + ! kord_tr_cslam is in CSLAM tracer index space (1:ntrac), so map this + ! species constituent index into it instead of indexing it directly. + do mfound = 1, ntrac + if (advected_constituent_index(mfound) == thermodynamic_active_species_idx(m)) then + kord_tr_cslam(mfound) = vert_remap_uvTq_alg + exit + end if + end do kord_tr(m) = vert_remap_uvTq_alg cnst_name_gll (m) = const_name (thermodynamic_active_species_idx(m)) cnst_longname_gll(m) = const_longname(thermodynamic_active_species_idx(m)) + cnst_diag_name_gll(m) = const_diag_name(thermodynamic_active_species_idx(m)) else ! ! if not running with CSLAM then the condensate-loading water tracers are not necessarily @@ -709,12 +729,41 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) thermodynamic_active_species_idx_dycore(m) = thermodynamic_active_species_idx(m) kord_tr(thermodynamic_active_species_idx_dycore(m)) = vert_remap_uvTq_alg end if - cnst_name_gll (m) = const_name (m) - cnst_longname_gll(m) = const_longname(m) - + cnst_name_gll(m) = const_name(advected_constituent_index(m)) + cnst_longname_gll(m) = const_longname(advected_constituent_index(m)) + cnst_diag_name_gll(m) = const_diag_name(advected_constituent_index(m)) end if end do - +#ifdef energy_budget_code + do m=1,thermodynamic_active_species_liq_num + if (use_cslam) then + do mfound=1,qsize + if (TRIM(const_name(thermodynamic_active_species_liq_idx(m)))==TRIM(cnst_name_gll(mfound))) then + thermodynamic_active_species_liq_idx_dycore(m) = mfound + end if + end do + else + thermodynamic_active_species_liq_idx_dycore(m) = thermodynamic_active_species_liq_idx(m) + end if + if (masterproc) then + write(iulog,*) subname//": m,thermodynamic_active_species_idx_liq_dycore: ",m,thermodynamic_active_species_liq_idx_dycore(m) + end if + end do + do m=1,thermodynamic_active_species_ice_num + if (use_cslam) then + do mfound=1,qsize + if (TRIM(const_name(thermodynamic_active_species_ice_idx(m)))==TRIM(cnst_name_gll(mfound))) then + thermodynamic_active_species_ice_idx_dycore(m) = mfound + end if + end do + else + thermodynamic_active_species_ice_idx_dycore(m) = thermodynamic_active_species_ice_idx(m) + end if + if (masterproc) then + write(iulog,*) subname//": m,thermodynamic_active_species_idx_ice_dycore: ",m,thermodynamic_active_species_ice_idx_dycore(m) + end if + end do +#endif ! ! Initialize the import/export objects ! @@ -735,28 +784,15 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) if (initial_run) then call read_inidat(dyn_in) - call clean_iodesc_list() - end if - ! - ! initialize Rayleigh friction - ! - krange = raykrange - if (raykrange .eq. 0._r8) krange = (rayk0 - 1) / 2._r8 - tau0 = (86400._r8) * raytau0 ! convert to seconds - otau0 = 0._r8 - if (tau0 .ne. 0._r8) otau0 = 1._r8/tau0 - do k = 1, nlev - otau(k) = otau0 * (1.0_r8 + tanh((rayk0 - k) / krange)) / (2._r8) - enddo - if (masterproc) then - if (tau0 > 0._r8) then - write (iulog,*) 'SE dycore Rayleigh friction - krange = ', krange - write (iulog,*) 'SE dycore Rayleigh friction - otau0 = ', 1.0_r8/tau0 - write (iulog,*) 'SE dycore Rayleigh friction decay rate profile (only applied to (u,v))' - do k = 1, nlev - write (iulog,*) ' k = ', k, ' otau = ', otau(k) - enddo +#ifdef scam + if (use_iop .and. masterproc) then + call setiopupdate_init() + call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) + call scm_setinitial(dyn_in%elem) end if + call clean_iodesc +#endif + call clean_iodesc_list() end if ! ! initialize diffusion in dycore @@ -770,9 +806,6 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) tref = 1000._r8 !mean value at model top for solar max km_sponge_factor = molecular_diff km_sponge_factor_local = molecular_diff - call get_molecular_diff_coef_reference(tref,& - (hvcoord%hyai(:)+hvcoord%hybi(:))*hvcoord%ps0, km_sponge_factor_local,& - kmvisi_ref,kmcndi_ref,rhoi_ref) ! ! get rho, kmvis and kmcnd at mid-levels ! @@ -780,14 +813,17 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) (hvcoord%hyam(:)+hvcoord%hybm(:))*hvcoord%ps0,km_sponge_factor,& kmvis_ref,kmcnd_ref,rho_ref) + if (masterproc) then + write(iulog,*) "Molecular viscosity and thermal conductivity reference profile" + write(iulog,*) "k, p, z, km_sponge_factor, kmvis_ref/rho_ref, kmcnd_ref/(cp*rho_ref):" + end if do k=1,nlev ! only apply molecular viscosity where viscosity is > 1000 m/s^2 if (MIN(kmvis_ref(k)/rho_ref(k),kmcnd_ref(k)/(cpair*rho_ref(k)))>1000.0_r8) then if (masterproc) then - write(iulog,'(a,i3,2e11.4)') "k, p, km_sponge_factor :",k, & - (hvcoord%hyam(k)+hvcoord%hybm(k))*hvcoord%ps0,km_sponge_factor(k) - write(iulog,'(a,2e11.4)') "kmvis_ref/rho_ref, kmcnd_ref/(cp*rho_ref): ", & - kmvis_ref(k)/rho_ref(k),kmcnd_ref(k)/(cpair*rho_ref(k)) + press = hvcoord%hyam(k)*hvcoord%ps0+hvcoord%hybm(k)*pstd + call std_atm_height(press,z) + write(iulog,'(i3,5e11.4)') k,press, z,km_sponge_factor(k),kmvis_ref(k)/rho_ref(k),kmcnd_ref(k)/(cpair*rho_ref(k)) end if kmol_end = k else @@ -809,26 +845,61 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) ! nu_scale_top(:) = 0.0_r8 if (nu_top>0) then - if (masterproc) write(iulog,*) subname//": sponge layer viscosity scaling factor" - do k=1,nlev - press = (hvcoord%hyam(k)+hvcoord%hybm(k))*hvcoord%ps0 - ptop = hvcoord%hyai(1)*hvcoord%ps0 - nu_scale_top(k) = 8.0_r8*(1.0_r8+tanh(1.0_r8*log(ptop/press))) ! tau will be maximum 8 at model top - if (nu_scale_top(k).ge.0.15_r8) then - ksponge_end = k - else - nu_scale_top(k) = 0.0_r8 - end if - end do + ptop = hvcoord%hyai(1)*hvcoord%ps0 + if (ptop>300.0_r8) then + ! + ! for low tops the tanh formulae below makes the sponge excessively deep + ! + nu_scale_top(1) = 4.0_r8 + nu_scale_top(2) = 2.0_r8 + nu_scale_top(3) = 1.0_r8 + ksponge_end = 3 + else if (ptop>100.0_r8) then + ! + ! CAM6 top (~225 Pa) or CAM7 low top + ! + ! For backwards compatibility numbers below match tanh profile + ! used in FV + ! + nu_scale_top(1) = 4.4_r8 + nu_scale_top(2) = 1.3_r8 + nu_scale_top(3) = 3.9_r8 + ksponge_end = 3 + else if (ptop>1e-1_r8) then + ! + ! CAM7 FMT + ! + nu_scale_top(1) = 3.0_r8 + nu_scale_top(2) = 1.0_r8 + nu_scale_top(3) = 0.1_r8 + nu_scale_top(4) = 0.05_r8 + ksponge_end = 4 + else if (ptop>1e-4_r8) then + ! + ! WACCM and WACCM-x + ! + nu_scale_top(1) = 5.0_r8 + nu_scale_top(2) = 5.0_r8 + nu_scale_top(3) = 5.0_r8 + nu_scale_top(4) = 2.0_r8 + nu_scale_top(5) = 1.0_r8 + nu_scale_top(6) = 0.1_r8 + ksponge_end = 6 + end if else - ksponge_end = 0 + ksponge_end = 0 end if ksponge_end = MAX(MAX(ksponge_end,1),kmol_end) if (masterproc) then write(iulog,*) subname//": ksponge_end = ",ksponge_end + write(iulog,*) subname//": sponge layer Laplacian damping" + write(iulog,*) "k, p, z, nu_scale_top, nu (actual Laplacian damping coefficient)" if (nu_top>0) then - do k=1,ksponge_end - write(iulog,'(a,i3,1e11.4)') subname//": nu_scale_top ",k,nu_scale_top(k) + do k=1,ksponge_end+1 + press = (hvcoord%hyam(k)+hvcoord%hybm(k))*hvcoord%ps0 + call std_atm_height(press,z) + write(iulog,'(i3,4e11.4)') k,press,z,& + nu_scale_top(k),nu_scale_top(k)*nu_top end do end if end if @@ -845,58 +916,56 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) call gws_init(elem) end if ! iam < par%nprocs -!Remove/replace after CAMDEN history output is enabled -JN: -#if 0 - - call addfld ('nu_kmvis', (/ 'lev' /), 'A', '', 'Molecular viscosity Laplacian coefficient' , gridname='GLL') - call addfld ('nu_kmcnd', (/ 'lev' /), 'A', '', 'Thermal conductivity Laplacian coefficient' , gridname='GLL') - call addfld ('nu_kmcnd_dp',(/ 'lev' /), 'A', '', 'Thermal conductivity like Laplacian coefficient on dp', gridname='GLL') - + call history_add_field ('nu_kmvis', 'Molecular viscosity Laplacian coefficient', 'lev', 'avg', '1', gridname='GLL') + call history_add_field ('nu_kmcnd', 'Thermal conductivity Laplacian coefficient', 'lev', 'avg', '1', gridname='GLL') + call history_add_field ('nu_kmcnd_dp', 'Thermal conductivity like Laplacian coefficient on dp', 'lev', 'avg', '1', gridname='GLL') ! Forcing from physics on the GLL grid - call addfld ('FU', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind forcing term on GLL grid', gridname='GLL') - call addfld ('FV', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind forcing term on GLL grid',gridname='GLL') - call register_vector_field('FU', 'FV') - call addfld ('FT', (/ 'lev' /), 'A', 'K/s', 'Temperature forcing term on GLL grid',gridname='GLL') + call history_add_field ('FU', 'Zonal wind forcing term on GLL grid', 'lev', 'avg', 'm s-2', gridname='GLL_hist') + call history_add_field ('FV', 'Meridional wind forcing term on GLL grid', 'lev', 'avg', 'm s-2', gridname='GLL_hist') + !call register_vector_field('FU', 'FV') !<-For interpolated history output (not yet implemented) + call history_add_field ('FT', 'Temperature forcing term on GLL grid', 'lev', 'avg', 'K s-1', gridname='GLL_hist') ! Tracer forcing on fvm (CSLAM) grid and internal CSLAM pressure fields - if (ntrac>0) then + if (use_cslam) then do m = 1, ntrac - call addfld (trim(const_name(m))//'_fvm', (/ 'lev' /), 'I', 'kg/kg', & - trim(const_longname(m)), gridname='FVM') + call history_add_field (trim(const_diag_name(advected_constituent_index(m)))//'_fvm', trim(const_longname(m)), & + 'lev', 'inst', 'kg/kg', gridname='FVM') - call addfld ('F'//trim(const_name(m))//'_fvm', (/ 'lev' /), 'I', 'kg/kg/s', & - trim(const_longname(m))//' mixing ratio forcing term (q_new-q_old) on fvm grid', & - gridname='FVM') + call history_add_field ('F'//trim(const_diag_name(advected_constituent_index(m)))//'_fvm', & + trim(const_longname(m))//' mixing ratio forcing term (q_new-q_old) on fvm grid', & + 'lev', 'inst', 'kg kg-1 s-1', gridname='FVM') end do - call addfld ('dp_fvm' ,(/ 'lev' /), 'I', 'Pa','CSLAM Pressure level thickness', gridname='FVM') - call addfld ('PSDRY_fvm',horiz_only, 'I','Pa','CSLAM dry surface pressure' , gridname='FVM') + call history_add_field ('dp_fvm' , 'CSLAM Pressure level thickness', 'lev', 'inst', 'Pa', gridname='FVM') + call history_add_field ('PSDRY_fvm', 'CSLAM dry surface pressure', horiz_only, 'inst','Pa', gridname='FVM') end if do m_cnst = 1, qsize - call addfld ('F'//trim(cnst_name_gll(m_cnst))//'_gll', (/ 'lev' /), 'I', 'kg/kg/s', & - trim(const_longname_gll(m_cnst))//' mixing ratio forcing term (q_new-q_old) on GLL grid', gridname='GLL') + call history_add_field ('F'//trim(cnst_diag_name_gll(m_cnst))//'_gll', & + trim(cnst_longname_gll(m_cnst))//' mixing ratio forcing term (q_new-q_old) on GLL grid', & + 'lev', 'inst', 'kg kg-1 s-1', gridname='GLL') end do ! Energy diagnostics and axial angular momentum diagnostics - call addfld ('ABS_dPSdt', horiz_only, 'A', 'Pa/s', 'Absolute surface pressure tendency',gridname='GLL') + call history_add_field ('ABS_dPSdt', 'Absolute surface pressure tendency', horiz_only, 'avg', 'Pa s-1', gridname='GLL') - if (ntrac>0) then + if (use_cslam) then #ifdef waccm_debug - call addfld ('CSLAM_gamma', (/ 'lev' /), 'A', '', 'Courant number from CSLAM', gridname='FVM') + call history_add_field ('CSLAM_gamma', 'Courant number from CSLAM', 'lev', 'avg', '1', gridname='FVM') #endif - call addfld ('WV_PDC', horiz_only, 'A', 'kg/m2','Total column water vapor lost in physics-dynamics coupling',gridname='FVM') - call addfld ('WL_PDC', horiz_only, 'A', 'kg/m2','Total column cloud water lost in physics-dynamics coupling',gridname='FVM') - call addfld ('WI_PDC', horiz_only, 'A', 'kg/m2','Total column cloud ice lost in physics-dynamics coupling' ,gridname='FVM') - call addfld ('TT_PDC', horiz_only, 'A', 'kg/m2','Total column test tracer lost in physics-dynamics coupling',gridname='FVM') + call history_add_field ('WV_PDC', 'Total column water vapor lost in physics-dynamics coupling', horiz_only, 'avg', 'kg m-2', gridname='FVM') + call history_add_field ('WL_PDC', 'Total column cloud water lost in physics-dynamics coupling', horiz_only, 'avg', 'kg m-2', gridname='FVM') + call history_add_field ('WI_PDC', 'Total column cloud ice lost in physics-dynamics coupling' , horiz_only, 'avg', 'kg m-2', gridname='FVM') + call history_add_field ('TT_PDC', 'Total column test tracer lost in physics-dynamics coupling', horiz_only, 'avg', 'kg m-2', gridname='FVM') else - call addfld ('WV_PDC', horiz_only, 'A', 'kg/m2','Total column water vapor lost in physics-dynamics coupling',gridname='GLL') - call addfld ('WL_PDC', horiz_only, 'A', 'kg/m2','Total column cloud water lost in physics-dynamics coupling',gridname='GLL') - call addfld ('WI_PDC', horiz_only, 'A', 'kg/m2','Total column cloud ice lost in physics-dynamics coupling' ,gridname='GLL') - call addfld ('TT_PDC', horiz_only, 'A', 'kg/m2','Total column test tracer lost in physics-dynamics coupling',gridname='GLL') + call history_add_field ('WV_PDC', 'Total column water vapor lost in physics-dynamics coupling', horiz_only, 'avg', 'kg m-2', gridname='GLL') + call history_add_field ('WL_PDC', 'Total column cloud water lost in physics-dynamics coupling', horiz_only, 'avg', 'kg m-2', gridname='GLL') + call history_add_field ('WI_PDC', 'Total column cloud ice lost in physics-dynamics coupling' , horiz_only, 'avg', 'kg m-2', gridname='GLL') + call history_add_field ('TT_PDC', 'Total column test tracer lost in physics-dynamics coupling', horiz_only, 'avg', 'kg m-2', gridname='GLL') end if +#ifdef energy_budget_code do istage = 1,SIZE(stage) do ivars=1,SIZE(vars) write(str1,*) TRIM(ADJUSTL(vars(ivars))),TRIM(ADJUSTL("_")),TRIM(ADJUSTL(stage(istage))) @@ -904,27 +973,36 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) TRIM(ADJUSTL(" ")),TRIM(ADJUSTL(stage_txt(istage))) write(str3,*) TRIM(ADJUSTL(vars_unit(ivars))) if (ntrac>0.and.massv(ivars)) then - call addfld (TRIM(ADJUSTL(str1)), horiz_only, 'A', TRIM(ADJUSTL(str3)),TRIM(ADJUSTL(str2)),gridname='FVM') + call history_add_field (TRIM(ADJUSTL(str1)), horiz_only, 'avg', TRIM(ADJUSTL(str3)),TRIM(ADJUSTL(str2)), gridname='FVM') else - call addfld (TRIM(ADJUSTL(str1)), horiz_only, 'A', TRIM(ADJUSTL(str3)),TRIM(ADJUSTL(str2)),gridname='GLL') + call history_add_field (TRIM(ADJUSTL(str1)), horiz_only, 'avg', TRIM(ADJUSTL(str3)),TRIM(ADJUSTL(str2)), gridname='GLL') end if end do end do +#endif +#ifdef cam_thermo_history ! ! add dynamical core tracer tendency output ! - if (ntrac>0) then + if (use_cslam) then do m = 1, num_advected - call addfld(tottnam(m),(/ 'lev' /),'A','kg/kg/s',trim(const_name(m))//' horz + vert', & - gridname='FVM') + call history_add_field(tottnam(m), trim(const_name(advected_constituent_index(m)))//& + ' horz + vert', 'lev','avg','kg kg-1 s-1', gridname='FVM') end do else do m = 1, num_advected - call addfld(tottnam(m),(/ 'lev' /),'A','kg/kg/s',trim(const_name(m))//' horz + vert', & + call history_add_field(tottnam(m), trim(const_name(advected_constituent_index(m)))//& + ' horz + vert', 'lev','avg','kg kg-1 s-1', & gridname='GLL') end do end if +#endif + +! Need SIMA-specific mechanism to automatically add groups of history fields (maybe +! via labels in history_add_field?). For now, just comment out all references to +! add_default. +#if 0 call phys_getopts(history_budget_out=history_budget, history_budget_histfile_num_out=budget_hfile_num) if ( history_budget ) then call const_get_index('water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water', ixq) @@ -935,6 +1013,7 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) call add_default(tottnam(ixcldliq), budget_hfile_num, ' ') call add_default(tottnam(ixcldice), budget_hfile_num, ' ') end if +#endif ! constituent indices for waccm-x if ( cam_runtime_opts%waccmx_option() == 'ionosphere' .or. & @@ -945,11 +1024,69 @@ subroutine dyn_init(cam_runtime_opts, dyn_in, dyn_out) call const_get_index('hydrogen_mixing_ratio_wrt_total_mass', ixh2) end if - call test_mapping_addfld +#ifdef cam_thermo_history + if (thermo_budget_history) then + ! Register stages for budgets + do istage = 1, num_stages + call cam_budget_em_snapshot(TRIM(ADJUSTL(stage(istage))), 'dyn', & + longname=TRIM(ADJUSTL(stage_txt(istage)))) + end do + ! + ! Register tendency (difference) budgets + ! + call cam_budget_em_register('dEdt_floating_dyn' ,'dAL','dBL','dyn','dif', & + longname="dE/dt floating dynamics (dAL-dBL)" ) + call cam_budget_em_register('dEdt_vert_remap' ,'dAR','dAD','dyn','dif', & + longname="dE/dt vertical remapping (dAR-dAD)" ) + call cam_budget_em_register('dEdt_phys_tot_in_dyn','dBD','dAF','dyn','dif', & + longname="dE/dt physics tendency in dynamics (dBD-dAF)" ) + call cam_budget_em_register('dEdt_del4' ,'dCH','dBH','dyn','dif', & + longname="dE/dt del4 (dCH-dBH)" ) + call cam_budget_em_register('dEdt_del4_fric_heat','dAH','dCH','dyn','dif', & + longname="dE/dt del4 frictional heating (dAH-dCH)" ) + call cam_budget_em_register('dEdt_del4_tot' ,'dAH','dBH','dyn','dif', & + longname="dE/dt del4 + del4 frictional heating (dAH-dBH)" ) + call cam_budget_em_register('dEdt_del2_sponge' ,'dAS','dBS','dyn','dif', & + longname="dE/dt del2 sponge (dAS-dBS)" ) + ! + ! Register derived budgets + ! + call cam_budget_em_register('dEdt_dycore' ,'dEdt_floating_dyn','dEdt_vert_remap' ,'dyn','sum', & + longname="dE/dt adiabatic dynamics" ) + call cam_budget_em_register('dEdt_del2_del4_tot' ,'dEdt_del4_tot' ,'dEdt_del2_sponge' ,'dyn','sum', & + longname="dE/dt explicit diffusion total" ) + call cam_budget_em_register('dEdt_residual' ,'dEdt_floating_dyn','dEdt_del2_del4_tot','dyn','dif', & + longname="dE/dt residual (dEdt_floating_dyn-dEdt_del2_del4_tot)" ) + end if + ! + ! add dynamical core tracer tendency output + ! + if (use_cslam) then + do m = 1, num_advected + call history_add_field(tottnam(m), trim(const_name(advected_constituent_index(m)))//' horz + vert', 'lev','avg', & + 'kg kg-1 s-1', gridname='FVM') + end do + else + do m = 1, num_advected + call history_add_field(tottnam(m), trim(const_name(advected_constituent_index(m)))//' horz + vert', 'lev','avg', & + 'kg kg-1 s-1', gridname='GLL') + end do + end if + call phys_getopts(history_budget_out=history_budget, history_budget_histfile_num_out=budget_hfile_num) -!Remove/replace after CAMDEN history output is enabled -JN: +! Need SIMA-specific mechanism to automatically add groups of history fields (maybe +! via labels in history_add_field?). For now, just comment out all references to +! add_default. +#if 0 + if ( history_budget ) then + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + call add_default(tottnam( 1), budget_hfile_num, ' ') + call add_default(tottnam(ixcldliq), budget_hfile_num, ' ') + call add_default(tottnam(ixcldice), budget_hfile_num, ' ') + end if +#endif #endif - end subroutine dyn_init !========================================================================================= @@ -957,60 +1094,69 @@ end subroutine dyn_init subroutine dyn_run(dyn_state) use air_composition, only: thermodynamic_active_species_num, dry_air_species_num use air_composition, only: thermodynamic_active_species_idx_dycore + use cam_history, only: is_history_field_active, history_out_field + use spmd_utils, only: iam + use dyn_grid, only: TimeLevel, hvcoord + use time_manager, only: get_step_size + use cam_abortutils, only: check_allocate - !Se dycore: - use prim_advance_mod, only: calc_tot_energy_dynamics + !SE dycore: + use parallel_mod, only: par use prim_driver_mod, only: prim_run_subcycle - use dimensions_mod, only: cnst_name_gll - use time_mod, only: tstep, nsplit, timelevel_qdp - use hybrid_mod, only: config_thread_region, get_loop_ranges + use dimensions_mod, only: cnst_name_gll, nelemd, np, npsq + use dimensions_mod, only: nc, nlev, use_cslam, ntrac, qsize + use se_dyn_time_mod, only: tstep, nsplit, timelevel_qdp, tevolve + use hybrid_mod, only: hybrid_t, config_thread_region, get_loop_ranges use control_mod, only: qsplit, rsplit, ftype_conserve use thread_mod, only: horz_num_threads - use time_mod, only: tevolve + use bndry_mod, only: bndry_exchange +#ifdef scam + use scamMod, only: single_column, use_3dfrc + use se_single_column_mod, only: apply_SC_forcing,ie_scm +#else + logical, parameter :: single_column = .false. !Always assume single-column mode is off. + integer, parameter :: ie_scm = 1 !Make up a value so that the model compiles +#endif type(dyn_export_t), intent(inout) :: dyn_state - type(hybrid_t) :: hybrid - integer :: tl_f - integer :: n - integer :: nets, nete, ithr - integer :: i, ie, j, k, m, nq, m_cnst - integer :: n0_qdp, nsplit_local - integer :: iret - logical :: ldiag - - real(r8) :: ftmp(npsq,nlev,3) + type(hybrid_t) :: hybrid + integer :: tl_f + integer :: n + integer :: nets, nete, ithr + integer :: i, ie, j, k, m, nq, m_cnst + integer :: n0_qdp, nsplit_local + integer :: iret + logical :: ldiag + character(len=cl) :: errmsg + + real(r8), allocatable :: ftmp(:,:,:) real(r8) :: dtime real(r8) :: rec2dt, pdel real(r8), allocatable, dimension(:,:,:) :: ps_before real(r8), allocatable, dimension(:,:,:) :: abs_ps_tend real (kind=r8) :: omega_cn(2,nelemd) !min and max of vertical Courant number + integer :: nets_in,nete_in character(len=*), parameter :: subname = 'dyn_run' !---------------------------------------------------------------------------- -#ifdef debug_coupling - return -#endif - nsplit_local = nsplit tevolve = 0._r8 if (iam >= par%nprocs) return -!Un-comment once history output is enabled -JN -! ldiag = hist_fld_active('ABS_dPSdt') - ldiag = .false. + ldiag = is_history_field_active('ABS_dPSdt') if (ldiag) then - allocate(ps_before(np,np,nelemd), stat=iret) + allocate(ps_before(np,np,nelemd), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'ps_before(np,np,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(abs_ps_tend(np,np,nelemd), stat=iret) + allocate(abs_ps_tend(np,np,nelemd), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'abs_ps_tend(np,np,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) end if @@ -1024,53 +1170,64 @@ subroutine dyn_run(dyn_state) tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics call TimeLevel_Qdp(TimeLevel, qsplit, n0_qdp)!get n0_qdp for diagnostics call -!Uncomment once "outfld" is enabled in CAMDEN-JN: -#if 0 - ! output physics forcing - if (hist_fld_active('FU') .or. hist_fld_active('FV') .or.hist_fld_active('FT')) then + if (is_history_field_active('FU') .or. is_history_field_active('FV') .or. is_history_field_active('FT')) then + + allocate(ftmp(npsq*nelemd,nlev,3),stat=iret, errmsg=errmsg) + call check_allocate(iret, subname, 'ftmp(npsq*nelemd,nlev,3)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + + n = 0 do ie = nets, nete do k = 1, nlev do j = 1, np do i = 1, np - ftmp(i+(j-1)*np,k,1) = dyn_state%elem(ie)%derived%FM(i,j,1,k) - ftmp(i+(j-1)*np,k,2) = dyn_state%elem(ie)%derived%FM(i,j,2,k) - ftmp(i+(j-1)*np,k,3) = dyn_state%elem(ie)%derived%FT(i,j,k) + ftmp(n+(i+(j-1)*np),k,1) = dyn_state%elem(ie)%derived%FM(i,j,1,k) + ftmp(n+(i+(j-1)*np),k,2) = dyn_state%elem(ie)%derived%FM(i,j,2,k) + ftmp(n+(i+(j-1)*np),k,3) = dyn_state%elem(ie)%derived%FT(i,j,k) end do end do end do - call outfld('FU', ftmp(:,:,1), npsq, ie) - call outfld('FV', ftmp(:,:,2), npsq, ie) - call outfld('FT', ftmp(:,:,3), npsq, ie) + !Update element count: + n = n + npsq end do + + ! Write fields to history tape: + call history_out_field('FU', ftmp(:,:,1)) + call history_out_field('FV', ftmp(:,:,2)) + call history_out_field('FT', ftmp(:,:,3)) + + ! Deallocate temporary output variable: + deallocate(ftmp) + end if do m = 1, qsize - if (hist_fld_active('F'//trim(cnst_name_gll(m))//'_gll')) then + if (is_history_field_active('F'//trim(cnst_diag_name_gll(m))//'_gll')) then do ie = nets, nete - call outfld('F'//trim(cnst_name_gll(m))//'_gll',& - RESHAPE(dyn_state%elem(ie)%derived%FQ(:,:,:,m), (/np*np,nlev/)), npsq, ie) + call history_out_field('F'//trim(cnst_diag_name_gll(m))//'_gll',& + RESHAPE(dyn_state%elem(ie)%derived%FQ(:,:,:,m), (/np*np,nlev/))) end do end if end do -#endif ! convert elem(ie)%derived%fq to mass tendency - do ie = nets, nete - do m = 1, qsize + if (.not.use_cslam) then + do ie = nets, nete + do m = 1, qsize do k = 1, nlev - do j = 1, np - do i = 1, np - dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & - rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) - end do - end do + do j = 1, np + do i = 1, np + dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & + rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) + end do + end do end do - end do - end do - - if (ftype_conserve>0) then + end do + end do + end if + if (ftype_conserve>0.and..not.use_cslam) then do ie = nets, nete do k=1,nlev do j=1,np @@ -1086,26 +1243,23 @@ subroutine dyn_run(dyn_state) end do end do end if - - if (ntrac > 0) then - do ie = nets, nete - do m = 1, ntrac - do k = 1, nlev - do j = 1, nc - do i = 1, nc - dyn_state%fvm(ie)%fc(i,j,k,m) = dyn_state%fvm(ie)%fc(i,j,k,m)* & - rec2dt!*dyn_state%fvm(ie)%dp_fvm(i,j,k) - end do - end do - end do + if (use_cslam) then + do ie = nets, nete + do m = 1, ntrac + do k = 1, nlev + do j = 1, nc + do i = 1, nc + dyn_state%fvm(ie)%fc(i,j,k,m) = dyn_state%fvm(ie)%fc(i,j,k,m)* & + rec2dt!*dyn_state%fvm(ie)%dp_fvm(i,j,k) + end do + end do end do - end do + end do + end do end if - if (ldiag) then abs_ps_tend(:,:,nets:nete) = 0.0_r8 endif - do n = 1, nsplit_local if (ldiag) then @@ -1114,9 +1268,17 @@ subroutine dyn_run(dyn_state) end do end if + if (single_column) then + nets_in=ie_scm + nete_in=ie_scm + else + nets_in=nets + nete_in=nete + end if + ! forward-in-time RK, with subcycling - call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets, nete, & - tstep, TimeLevel, hvcoord, n, omega_cn) + call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets_in, nete_in, & + tstep, TimeLevel, hvcoord, n, single_column, omega_cn) if (ldiag) then do ie = nets, nete @@ -1128,27 +1290,26 @@ subroutine dyn_run(dyn_state) end do -!Uncomment once "outfld" is enabled in CAMDEN-JN: -#if 0 if (ldiag) then do ie=nets,nete abs_ps_tend(:,:,ie)=abs_ps_tend(:,:,ie)/DBLE(nsplit) - call outfld('ABS_dPSdt',RESHAPE(abs_ps_tend(:,:,ie),(/npsq/)),npsq,ie) + call history_out_field('ABS_dPSdt',RESHAPE(abs_ps_tend(:,:,ie),(/npsq/))) end do end if -#endif - call calc_tot_energy_dynamics(dyn_state%elem,dyn_state%fvm, nets, nete, TimeLevel%n0, n0_qdp,'dBF') !$OMP END PARALLEL -!Uncomment once "outfld" is enabled in CAMDEN-JN: -#if 0 if (ldiag) then deallocate(ps_before,abs_ps_tend) endif +#ifdef SCAM + if (single_column) then + call apply_SC_forcing(dyn_state%elem,hvcoord,TimeLevel,3,.false.) + end if +#endif + ! output vars on CSLAM fvm grid call write_dyn_vars(dyn_state) -#endif end subroutine dyn_run @@ -1156,6 +1317,9 @@ end subroutine dyn_run subroutine dyn_final(DYN_STATE, RESTART_FILE) + !SE dycore: + use element_mod, only: elem_state_t + type (elem_state_t), target :: DYN_STATE character(LEN=*) , intent(IN) :: RESTART_FILE @@ -1164,17 +1328,45 @@ end subroutine dyn_final !=============================================================================== subroutine read_inidat(dyn_in) + use pio, only: file_desc_t + use pio, only: pio_seterrorhandling, PIO_BCAST_ERROR use air_composition, only: thermodynamic_active_species_num, dry_air_species_num use air_composition, only: thermodynamic_active_species_idx use shr_sys_mod, only: shr_sys_flush use hycoef, only: hyai, hybi, ps0 use phys_vars_init_check, only: mark_as_initialized + use cam_history_support, only: max_fieldname_len + use spmd_utils, only: iam, masterproc + use cam_abortutils, only: endrun, check_allocate + use cam_logfile, only: iulog + use dyn_grid, only: ini_grid_name, hvcoord + use cam_map_utils, only: iMap + use cam_grid_support, only: cam_grid_id, cam_grid_get_gcid, cam_grid_get_latvals + use cam_grid_support, only: cam_grid_get_lonvals, cam_grid_dimensions, max_hcoordname_len + use inic_analytic, only: analytic_ic_active, analytic_ic_set_ic + use cam_initfiles, only: pertlim, initial_file_get_id, topo_file_get_id + use cam_constituents, only: num_advected, const_name + use cam_constituents, only: const_is_water_species, const_qmin, const_is_wet + use dyn_tests_utils, only: vcoord=>vc_dry_pressure + + !This should eventually be replaced with the "const_diag_name" function from "cam_constituents". + !The only issue is that right now atmospheric_physics doesn't add diagnostic names for all water + !species variables. + use phys_vars_init_check, only: phys_var_num, phys_var_stdnames, input_var_names + use physics_data, only: find_input_name_idx !SE-dycore: + use parallel_mod, only: par use element_mod, only: timelevels use fvm_mapping, only: dyn2fvm_mass_vars + use bndry_mod, only: bndry_exchange use control_mod, only: runtype,initial_global_ave_dry_ps use prim_driver_mod, only: prim_set_dry_mass + use cam_initfiles, only: scale_dry_air_mass + use edgetype_mod, only: edgebuffer_t + use edge_mod, only: initEdgeBuffer, FreeEdgeBuffer, edgeVpack, edgeVunpack + use dimensions_mod, only: np, npsq, nc, ntrac, qsize + use dimensions_mod, only: nlev, nelemd, use_cslam ! Arguments type (dyn_import_t), target, intent(inout) :: dyn_in ! dynamics import @@ -1218,9 +1410,13 @@ subroutine read_inidat(dyn_in) real(r8) :: pertval integer :: i, j, indx, nq integer :: dyn_cols - character(len=128) :: errmsg + character(len=cl) :: errmsg character(len=*), parameter :: subname='READ_INIDAT' + character(len=cl), allocatable :: const_ic_name(:) + character(len=cl) :: std_name + integer :: const_ic_names_idx + ! fvm vars real(r8), allocatable :: inv_dp_darea_fvm(:,:,:) real(r8) :: min_val, max_val @@ -1241,31 +1437,31 @@ subroutine read_inidat(dyn_in) nullify(elem) end if - allocate(qtmp(np,np,nlev,nelemd,num_advected), stat=ierr) + allocate(qtmp(np,np,nlev,nelemd,num_advected), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'qtmp(np,np,nlev,nelemd,num_advected)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) qtmp = 0._r8 ! Set mask to indicate which columns are active nullify(ldof) call cam_grid_get_gcid(cam_grid_id(ini_grid_name), ldof) - allocate(pmask(npsq*nelemd), stat=ierr) + allocate(pmask(npsq*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'pmask(npsq*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) pmask(:) = (ldof /= 0) ! lat/lon needed in radians latvals_deg => cam_grid_get_latvals(cam_grid_id(ini_grid_name)) lonvals_deg => cam_grid_get_lonvals(cam_grid_id(ini_grid_name)) - allocate(latvals(np*np*nelemd), stat=ierr) + allocate(latvals(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'latvals(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(lonvals(np*np*nelemd), stat=ierr) + allocate(lonvals(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'lonvals(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) latvals(:) = latvals_deg(:)*deg2rad lonvals(:) = lonvals_deg(:)*deg2rad @@ -1299,9 +1495,9 @@ subroutine read_inidat(dyn_in) end do inic_wet = .false. - allocate(glob_ind(npsq * nelemd), stat=ierr) + allocate(glob_ind(npsq * nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'glob_ind(npsq*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) j = 1 do ie = 1, nelemd @@ -1313,14 +1509,14 @@ subroutine read_inidat(dyn_in) end do ! First, initialize all the variables, then assign - allocate(dbuf4(npsq, nlev, nelemd, (qsize + 4)), stat=ierr) + allocate(dbuf4(npsq, nlev, nelemd, (qsize + 4)), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dbuf4(npsq,nlev,nelemd,(qsize+4))', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) dbuf4 = 0.0_r8 - allocate(m_ind(qsize), stat=ierr) + allocate(m_ind(qsize), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'm_ind(qsize)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do m_cnst = 1, qsize m_ind(m_cnst) = thermodynamic_active_species_idx(m_cnst) @@ -1382,13 +1578,13 @@ subroutine read_inidat(dyn_in) ! Read ICs from file. Assume all fields in the initial file are on the GLL grid. - allocate(dbuf2(npsq,nelemd), stat=ierr) + allocate(dbuf2(npsq,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dbuf2(npsq,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dbuf3(npsq,nlev,nelemd), stat=ierr) + allocate(dbuf3(npsq,nlev,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dbuf3(npsq,nlev,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! Check that number of columns in IC file matches grid definition. call check_file_layout(fh_ini, elem, dyn_cols, 'ncdata', .true., dimname) @@ -1479,9 +1675,9 @@ subroutine read_inidat(dyn_in) end if call random_seed(size=rndm_seed_sz) - allocate(rndm_seed(rndm_seed_sz), stat=ierr) + allocate(rndm_seed(rndm_seed_sz), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'rndm_seed(rndm_seed_sz)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemd ! seed random number generator based on element ID @@ -1530,35 +1726,68 @@ subroutine read_inidat(dyn_in) call endrun(trim(subname)//errmsg) end if + ! Generate list of all advected constituent input names: + !------------ + allocate(const_ic_name(num_advected), stat=ierr, errmsg=errmsg) + call check_allocate(ierr, subname, 'const_ic_name(num_advected)', & + file=__FILE__, line=__LINE__, errmsg=errmsg) + + ! Initialize to variable name that will likely never be found in the IC file: + const_ic_name(:) = 'NONAME_NEVERFOUND' + + do m_cnst = 1, num_advected + + ! Extract constituent standard name: + std_name = const_name(advected_constituent_index(m_cnst)) + + ! Find input name array index to extract correct input names: + const_ic_names_idx = -1 + do k=1, phys_var_num + if(trim(phys_var_stdnames(k)) == trim(std_name)) then + const_ic_names_idx = k + exit + end if + end do + + ! Skip to next constituent if not found in input names list: + if (const_ic_names_idx < 0) cycle + + ! The first name in IC names list should be the correct + ! name for standard CAM IC (ncdata) files: + const_ic_name(m_cnst) = input_var_names(1, const_ic_names_idx) + end do + !------------- + ! If using analytic ICs the initial file only needs the horizonal grid ! dimension checked in the case that the file contains constituent mixing ! ratios. + do m_cnst = 1, num_advected - if (readtrace .and. .not. const_is_water_species(m_cnst)) then - if (dyn_field_exists(fh_ini, trim(const_name(m_cnst)), required=.false.)) then + if (.not. const_is_water_species(advected_constituent_index(m_cnst))) then + if (dyn_field_exists(fh_ini, trim(const_ic_name(m_cnst)), required=.false.)) then call check_file_layout(fh_ini, elem, dyn_cols, 'ncdata', .true., dimname) exit end if end if end do - allocate(dbuf3(npsq,nlev,nelemd), stat=ierr) + allocate(dbuf3(npsq,nlev,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dbuf3(npsq,nlev,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) + + ! Initialize to zero to ensure that "max" call below works as expcted. + dbuf3(:,:,:) = 0._r8 do m_cnst = 1, num_advected - if (analytic_ic_active() .and. const_is_water_species(m_cnst)) cycle + if (analytic_ic_active() .and. const_is_water_species(advected_constituent_index(m_cnst))) cycle - found = .false. - if (readtrace) then - found = dyn_field_exists(fh_ini, trim(const_name(m_cnst)), required=.false.) - end if + found = dyn_field_exists(fh_ini, trim(const_ic_name(m_cnst)), required=.false.) if (found) then - call read_dyn_var(trim(const_name(m_cnst)), fh_ini, dimname, dbuf3) + call read_dyn_var(trim(const_ic_name(m_cnst)), fh_ini, dimname, dbuf3) else - !call cnst_init_default(m_cnst, latvals, lonvals, dbuf3, pmask) + dbuf3 = 0._r8 end if do ie = 1, nelemd @@ -1570,7 +1799,7 @@ subroutine read_inidat(dyn_in) do i = 1, np ! Set qtmp at the unique columns only: zero non-unique columns if (pmask(((ie - 1) * npsq) + indx)) then - qtmp(i,j, k, ie, m_cnst) = max(const_qmin(m_cnst),dbuf3(indx,k,ie)) + qtmp(i,j, k, ie, m_cnst) = max(const_qmin(advected_constituent_index(m_cnst)),dbuf3(indx,k,ie)) else qtmp(i,j, k, ie, m_cnst) = 0.0_r8 end if @@ -1638,9 +1867,9 @@ subroutine read_inidat(dyn_in) write(iulog,*) 'Convert specific/wet mixing ratios to dry' end if - allocate(factor_array(np,np,nlev,nelemd), stat=ierr) + allocate(factor_array(np,np,nlev,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'factor_array(np,np,nlev,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ! ! compute: factor_array = 1/(1-sum(q)) @@ -1655,7 +1884,7 @@ subroutine read_inidat(dyn_in) factor_array(:,:,:,:) = 1.0_r8/factor_array(:,:,:,:) do m_cnst = 1, num_advected - if (const_is_wet(m_cnst)) then + if (const_is_wet(advected_constituent_index(m_cnst))) then do ie = 1, nelemd do k = 1, nlev do j = 1, np @@ -1665,7 +1894,7 @@ subroutine read_inidat(dyn_in) ! truncate negative values if they were not analytically specified if (.not. analytic_ic_active()) then - qtmp(i,j,k,ie,m_cnst) = max(const_qmin(m_cnst), qtmp(i,j,k,ie,m_cnst)) + qtmp(i,j,k,ie,m_cnst) = max(const_qmin(advected_constituent_index(m_cnst)), qtmp(i,j,k,ie,m_cnst)) end if end do end do @@ -1740,28 +1969,22 @@ subroutine read_inidat(dyn_in) end do end if - ! scale PS to achieve prescribed dry mass following FV dycore (dryairm.F90) -#ifndef planet_mars + ! If scale_dry_air_mass > 0.0 then scale dry air mass to scale_dry_air_mass global average dry pressure if (runtype == 0) then - initial_global_ave_dry_ps = 98288.0_r8 - if (.not. associated(fh_topo)) then - initial_global_ave_dry_ps = 101325._r8 - 245._r8 - end if - if (simple_phys) then - initial_global_ave_dry_ps = 0 !do not scale psdry - end if - if (iam < par%nprocs) then - call prim_set_dry_mass(elem, hvcoord, initial_global_ave_dry_ps, qtmp) - end if - endif -#endif + if (scale_dry_air_mass > 0.0_r8) then + if (iam < par%nprocs) then + call prim_set_dry_mass(elem, hvcoord, scale_dry_air_mass, qtmp) + end if + end if + end if + ! store Q values: ! ! if CSLAM is NOT active then state%Qdp for all constituents ! if CSLAM active then we only advect water vapor and condensate ! loading tracers in state%qdp - if (ntrac > 0) then + if (use_cslam) then do ie = 1, nelemd do nq = 1, thermodynamic_active_species_num m_cnst = thermodynamic_active_species_idx(nq) @@ -1792,7 +2015,7 @@ subroutine read_inidat(dyn_in) ! interpolate fvm tracers and fvm pressure variables - if (ntrac > 0) then + if (use_cslam) then if (par%masterproc) then write(iulog,*) 'Initializing dp_fvm from spectral element dp' end if @@ -1838,9 +2061,9 @@ subroutine read_inidat(dyn_in) call mark_as_initialized("northward_wind") !northward wind call mark_as_initialized("air_temperature") - !Mark all constituents as initialized + !Mark all advected constituents as initialized do m_cnst = 1, num_advected - call mark_as_initialized(const_name(m_cnst)) + call mark_as_initialized(const_name(advected_constituent_index(m_cnst))) end do !These calls may be removed if geopotential_t is only allowed to run @@ -1902,7 +2125,34 @@ subroutine set_phis(dyn_in) ! which are computed on the physics grid. In this case phis on the physics grid ! will be interpolated to the GLL grid. + use pio, only: file_desc_t, pio_inq_dimid, pio_inq_dimlen + use pio, only: pio_seterrorhandling, PIO_NOERR, PIO_BCAST_ERROR + use cam_abortutils, only: endrun, check_allocate + use cam_logfile, only: iulog use phys_vars_init_check, only: mark_as_initialized + use cam_history_support, only: max_fieldname_len + use cam_grid_support, only: max_hcoordname_len, cam_grid_id + use cam_grid_support, only: cam_grid_get_latvals, cam_grid_get_lonvals + use cam_grid_support, only: cam_grid_dimensions, cam_grid_get_gcid + use cam_map_utils, only: iMap + use spmd_utils, only: iam, masterproc + use cam_initfiles, only: topo_file_get_id + use dyn_grid, only: ini_grid_name, edgebuf + use inic_analytic, only: analytic_ic_active, analytic_ic_set_ic + use dyn_tests_utils, only: vcoord=>vc_dry_pressure + + !SE dycore: + use dimensions_mod, only: np, npsq, nelemd, fv_nphys + use dimensions_mod, only: use_cslam + use parallel_mod, only: par + use bndry_mod, only: bndry_exchange + use edge_mod, only: edgeVpack, edgeVunpack + +#ifdef scam + use scamMod, only: single_column +#else + logical, parameter :: single_column = .false. !Always assume single-column mode is off. +#endif ! Arguments type (dyn_import_t), target, intent(inout) :: dyn_in ! dynamics import @@ -1912,13 +2162,15 @@ subroutine set_phis(dyn_in) type(element_t), pointer :: elem(:) - real(r8), allocatable :: phis_tmp(:,:) ! (npsp,nelemd) + real(r8), allocatable :: phis_tmp(:,:) ! (npsq,nelemd) real(r8), allocatable :: phis_phys_tmp(:,:) ! (fv_nphys**2,nelemd) integer :: i, ie, indx, j, kptr integer :: ierr, pio_errtype + character(len=cl) :: errmsg character(len=max_fieldname_len) :: fieldname + character(len=max_fieldname_len) :: fieldname_gll character(len=max_hcoordname_len):: grid_name integer :: dims(2) integer :: dyn_cols @@ -1949,16 +2201,16 @@ subroutine set_phis(dyn_in) nullify(elem) end if - allocate(phis_tmp(npsq,nelemd), stat=ierr) + allocate(phis_tmp(npsq,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'phis_tmp(npsq,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) phis_tmp = 0.0_r8 - if (fv_nphys > 0) then - allocate(phis_phys_tmp(fv_nphys**2,nelemd), stat=ierr) + if (use_cslam) then + allocate(phis_phys_tmp(fv_nphys**2,nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'phis_phys_tmp(fv_nphys**2,nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) phis_phys_tmp = 0.0_r8 do ie=1,nelemd @@ -1972,9 +2224,9 @@ subroutine set_phis(dyn_in) ! Set mask to indicate which columns are active in GLL grid. nullify(ldof) call cam_grid_get_gcid(cam_grid_id('GLL'), ldof) - allocate(pmask(npsq*nelemd), stat=ierr) + allocate(pmask(npsq*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'pmask(npsq*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) pmask(:) = (ldof /= 0) deallocate(ldof) @@ -1986,12 +2238,15 @@ subroutine set_phis(dyn_in) ! Set name of grid object which will be used to read data from file ! into internal data structure via PIO. - if (fv_nphys == 0) then - grid_name = 'GLL' + if (single_column) then + grid_name = 'SCM' else - grid_name = 'physgrid_d' + if (.not.use_cslam) then + grid_name = 'GLL' + else + grid_name = 'physgrid_d' + end if end if - ! Get number of global columns from the grid object and check that ! it matches the file data. call cam_grid_dimensions(grid_name, dims) @@ -2002,11 +2257,13 @@ subroutine set_phis(dyn_in) if (ierr /= PIO_NOERR) then call endrun(subname//': dimension ncol not found in bnd_topo file') end if + ierr = pio_inq_dimlen(fh_topo, ncol_did, ncol_size) if (ierr /= PIO_NOERR) then call endrun(subname//': dimension ncol does not have a value in bnd_topo file') end if - if (ncol_size /= dyn_cols) then + + if (ncol_size /= dyn_cols .and. .not. single_column) then if (masterproc) then write(iulog,*) subname//': ncol_size=', ncol_size, ' : dyn_cols=', dyn_cols end if @@ -2014,13 +2271,38 @@ subroutine set_phis(dyn_in) end if fieldname = 'PHIS' - if (dyn_field_exists(fh_topo, trim(fieldname))) then - if (fv_nphys == 0) then - call read_dyn_var(fieldname, fh_topo, 'ncol', phis_tmp) + fieldname_gll = 'PHIS_gll' + if (use_cslam.and.dyn_field_exists(fh_topo, trim(fieldname_gll),required=.false.)) then + ! + ! If physgrid it is recommended to read in PHIS on the GLL grid and then + ! map to the physgrid in d_p_coupling + ! + ! This requires a topo file with PHIS_gll on it ... + ! + if (masterproc) then + write(iulog, *) "Reading in PHIS on GLL grid (mapped to physgrid in d_p_coupling)" + end if + call read_dyn_var(fieldname_gll, fh_topo, 'ncol_gll', phis_tmp) + else if (dyn_field_exists(fh_topo, trim(fieldname))) then + if (.not.use_cslam) then + if (masterproc) then + write(iulog, *) "Reading in PHIS" + end if + call read_dyn_var(fieldname, fh_topo, 'ncol', phis_tmp) else - call read_phys_field_2d(fieldname, fh_topo, 'ncol', phis_phys_tmp) - call map_phis_from_physgrid_to_gll(dyn_in%fvm, elem, phis_phys_tmp, & - phis_tmp, pmask) + ! + ! For backwards compatibility we allow reading in PHIS on the physgrid + ! which is then mapped to the GLL grid and back to the physgrid in d_p_coupling + ! (the latter is to avoid noise in derived quantities such as PSL) + ! + if (masterproc) then + write(iulog, *) "Reading in PHIS on physgrid" + write(iulog, *) "Recommended to read in PHIS on GLL grid" + end if + call read_phys_field_2d(fieldname, fh_topo, 'ncol', phis_phys_tmp) + call map_phis_from_physgrid_to_gll(dyn_in%fvm, elem, phis_phys_tmp, & + phis_tmp, pmask) + deallocate(phis_phys_tmp) end if else call endrun(subname//': Could not find PHIS field on input datafile') @@ -2034,20 +2316,20 @@ subroutine set_phis(dyn_in) ! lat/lon needed in radians latvals_deg => cam_grid_get_latvals(cam_grid_id('GLL')) lonvals_deg => cam_grid_get_lonvals(cam_grid_id('GLL')) - allocate(latvals(np*np*nelemd), stat=ierr) + allocate(latvals(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'latvals(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(lonvals(np*np*nelemd), stat=ierr) + allocate(lonvals(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'lonvals(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) latvals(:) = latvals_deg(:)*deg2rad lonvals(:) = lonvals_deg(:)*deg2rad - allocate(glob_ind(npsq*nelemd), stat=ierr) + allocate(glob_ind(npsq*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'glob_ind(npsq*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) j = 1 do ie = 1, nelemd @@ -2060,57 +2342,8 @@ subroutine set_phis(dyn_in) call analytic_ic_set_ic(vcoord, latvals, lonvals, glob_ind, & PHIS_OUT=phis_tmp, mask=pmask(:)) deallocate(glob_ind) + end if - if (fv_nphys > 0) then - - ! initialize PHIS on physgrid - allocate(latvals_phys(fv_nphys*fv_nphys*nelemd), stat=ierr) - call check_allocate(ierr, subname, 'latvals_phys(fv_nphys*fv_nphys*nelemd)', & - file=__FILE__, line=__LINE__) - - allocate(lonvals_phys(fv_nphys*fv_nphys*nelemd), stat=ierr) - call check_allocate(ierr, subname, 'lonvals_phys(fv_nphys*fv_nphys*nelemd)', & - file=__FILE__, line=__LINE__) - - indx = 1 - do ie = 1, nelemd - do j = 1, fv_nphys - do i = 1, fv_nphys - latvals_phys(indx) = dyn_in%fvm(ie)%center_cart_physgrid(i,j)%lat - lonvals_phys(indx) = dyn_in%fvm(ie)%center_cart_physgrid(i,j)%lon - indx = indx + 1 - end do - end do - end do - - allocate(pmask_phys(fv_nphys*fv_nphys*nelemd), stat=ierr) - call check_allocate(ierr, subname, 'pmask_phys(fv_nphys*fv_nphys*nelemd)', & - file=__FILE__, line=__LINE__) - - pmask_phys(:) = .true. - allocate(glob_ind(fv_nphys*fv_nphys*nelemd), stat=ierr) - call check_allocate(ierr, subname, 'glob_ind(fv_nphys*fv_nphys*nelemd)', & - file=__FILE__, line=__LINE__) - - j = 1 - do ie = 1, nelemd - do i = 1, fv_nphys*fv_nphys - ! Create a global(ish) column index - glob_ind(j) = elem(ie)%GlobalId - j = j + 1 - end do - end do - - call analytic_ic_set_ic(vcoord, latvals_phys, lonvals_phys, glob_ind, & - PHIS_OUT=phis_phys_tmp, mask=pmask_phys) - - deallocate(latvals_phys) - deallocate(lonvals_phys) - deallocate(pmask_phys) - deallocate(glob_ind) - end if - - end if deallocate(pmask) @@ -2125,16 +2358,7 @@ subroutine set_phis(dyn_in) end do end do end do - if (fv_nphys > 0) then - do ie = 1, nelemd - dyn_in%fvm(ie)%phis_physgrid = RESHAPE(phis_phys_tmp(:,ie),(/fv_nphys,fv_nphys/)) - end do - end if - deallocate(phis_tmp) - if (fv_nphys > 0) then - deallocate(phis_phys_tmp) - end if ! boundary exchange to update the redundent columns in the element objects do ie = 1, nelemd @@ -2162,6 +2386,19 @@ subroutine check_file_layout(file, elem, dyn_cols, file_desc, dyn_ok, dimname) ! This routine is only called when data will be read from the initial file. It is not ! called when the initial file is only supplying vertical coordinate info. + use cam_history_support, only: max_fieldname_len + use spmd_utils, only: iam, masterproc + use pio, only: pio_inq_dimid, pio_inq_dimlen + use pio, only: PIO_NOERR, file_desc_t + use cam_abortutils, only: endrun + use shr_sys_mod, only: shr_sys_flush + use dyn_grid, only: ini_grid_name + use cam_logfile, only: iulog + use cam_grid_support, only: cam_grid_get_dim_names, cam_grid_id + + !SE dycore: + use dimensions_mod, only: nelemd, np, npsq + type(file_desc_t), pointer :: file type(element_t), pointer :: elem(:) integer, intent(in) :: dyn_cols @@ -2272,7 +2509,8 @@ end subroutine check_file_layout logical function dyn_field_exists(fh, fieldname, required) use pio, only: var_desc_t, PIO_inq_varid - use pio, only: PIO_NOERR + use pio, only: file_desc_t, PIO_NOERR + use cam_abortutils, only: endrun type(file_desc_t), intent(in) :: fh character(len=*), intent(in) :: fieldname @@ -2309,6 +2547,12 @@ end function dyn_field_exists subroutine read_dyn_field_2d(fieldname, fh, dimname, buffer) + use pio, only: file_desc_t + use cam_field_read, only: cam_read_field + use cam_abortutils, only: endrun + use shr_infnan_mod, only: shr_infnan_isnan + use dyn_grid, only: ini_grid_name + ! Dummy arguments character(len=*), intent(in) :: fieldname type(file_desc_t), intent(inout) :: fh @@ -2331,7 +2575,18 @@ subroutine read_dyn_field_2d(fieldname, fh, dimname, buffer) ! to NaN. In that case cam_read_field can return NaNs where the element ! GLL points are not "unique columns". ! Set NaNs or fillvalue points to zero: - where (shr_infnan_isnan(buffer) .or. (buffer==fillvalue)) buffer = 0.0_r8 + where (shr_infnan_isnan(buffer)) + ! check for NaN first, as comparing NaN to fillvalue raises floating invalid. + buffer = 0.0_r8 + end where + + if (.not. shr_infnan_isnan(fillvalue)) then + ! only compare against fillvalue if fillvalue is not NaN, otherwise the comparison + ! will raise floating invalid. + where (buffer == fillvalue) + buffer = 0.0_r8 + end where + end if end subroutine read_dyn_field_2d @@ -2339,6 +2594,15 @@ end subroutine read_dyn_field_2d subroutine read_dyn_field_3d(fieldname, fh, dimname, buffer) + use pio, only: file_desc_t + use cam_field_read, only: cam_read_field + use cam_abortutils, only: endrun + use shr_infnan_mod, only: shr_infnan_isnan + use dyn_grid, only: ini_grid_name + + ! SE dycore: + use dimensions_mod, only: nlev + ! Dummy arguments character(len=*), intent(in) :: fieldname type(file_desc_t), intent(inout) :: fh @@ -2361,7 +2625,18 @@ subroutine read_dyn_field_3d(fieldname, fh, dimname, buffer) ! to NaN. In that case cam_read_field can return NaNs where the element GLL ! points are not "unique columns". ! Set NaNs or fillvalue points to zero: - where (shr_infnan_isnan(buffer) .or. (buffer==fillvalue)) buffer = 0.0_r8 + where (shr_infnan_isnan(buffer)) + ! check for NaN first, as comparing NaN to fillvalue raises floating invalid. + buffer = 0.0_r8 + end where + + if (.not. shr_infnan_isnan(fillvalue)) then + ! only compare against fillvalue if fillvalue is not NaN, otherwise the comparison + ! will raise floating invalid. + where (buffer == fillvalue) + buffer = 0.0_r8 + end where + end if end subroutine read_dyn_field_3d @@ -2369,6 +2644,10 @@ end subroutine read_dyn_field_3d subroutine read_phys_field_2d(fieldname, fh, dimname, buffer) + use pio, only: file_desc_t + use cam_field_read, only: cam_read_field + use cam_abortutils, only: endrun + ! Dummy arguments character(len=*), intent(in) :: fieldname type(file_desc_t), intent(inout) :: fh @@ -2390,9 +2669,12 @@ end subroutine read_phys_field_2d subroutine map_phis_from_physgrid_to_gll(fvm,elem,phis_phys_tmp,phis_tmp,pmask) + use cam_abortutils, only: check_allocate + !SE dycore: - use hybrid_mod, only: get_loop_ranges, config_thread_region - use dimensions_mod, only: nhc_phys + use parallel_mod, only: par + use hybrid_mod, only: hybrid_t, get_loop_ranges, config_thread_region + use dimensions_mod, only: fv_nphys, nhc_phys, nelemd, np, npsq use fvm_mapping, only: phys2dyn use thread_mod, only: horz_num_threads @@ -2406,6 +2688,7 @@ subroutine map_phis_from_physgrid_to_gll(fvm,elem,phis_phys_tmp,phis_tmp,pmask) integer :: nets, nete, ie,i,j,indx, iret real(r8), allocatable :: fld_phys(:,:,:,:,:),fld_gll(:,:,:,:,:) logical :: llimiter(1) + character(len=cl) :: errmsg character(len=*), parameter :: subname = 'map_phis_from_physgrid_to_gll' @@ -2417,14 +2700,15 @@ subroutine map_phis_from_physgrid_to_gll(fvm,elem,phis_phys_tmp,phis_tmp,pmask) call get_loop_ranges(hybrid, ibeg=nets, iend=nete) - allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,1,1,nets:nete), stat=iret) + allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,1,1,nets:nete), & + stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,1,1,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(fld_gll(np,np,1,1,nets:nete), stat=iret) + allocate(fld_gll(np,np,1,1,nets:nete), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'fld_gll(np,np,1,1,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) fld_phys = 0.0_r8 do ie = nets, nete @@ -2452,37 +2736,41 @@ end subroutine map_phis_from_physgrid_to_gll !======================================================================================== -!Un-comment once "outfld has been enabled in CAMDEN -JN: -#if 0 subroutine write_dyn_vars(dyn_out) + use cam_history_support, only: fieldname_len + use cam_history, only: history_out_field + use cam_constituents, only: const_name + use cam_constituents, only: const_diag_name + + !SE dycore: + use dimensions_mod, only: nlev, ntrac, nc, nelemd, use_cslam + type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container character(len=fieldname_len) :: tfname integer :: ie, m !---------------------------------------------------------------------------- - if (ntrac > 0) then + if (use_cslam) then do ie = 1, nelemd - call outfld('dp_fvm', RESHAPE(dyn_out%fvm(ie)%dp_fvm(1:nc,1:nc,:), & - (/nc*nc,nlev/)), nc*nc, ie) - call outfld('PSDRY_fvm', RESHAPE(dyn_out%fvm(ie)%psc(1:nc,1:nc), & - (/nc*nc/)), nc*nc, ie) + call history_out_field('dp_fvm', RESHAPE(dyn_out%fvm(ie)%dp_fvm(1:nc,1:nc,:), & + (/nc*nc,nlev/))) + call history_out_field('PSDRY_fvm', RESHAPE(dyn_out%fvm(ie)%psc(1:nc,1:nc), & + (/nc*nc/))) do m = 1, ntrac - tfname = trim(const_name(m))//'_fvm' - call outfld(tfname, RESHAPE(dyn_out%fvm(ie)%c(1:nc,1:nc,:,m), & - (/nc*nc,nlev/)), nc*nc, ie) + tfname = trim(const_diag_name(advected_constituent_index(m)))//'_fvm' + call history_out_field(tfname, RESHAPE(dyn_out%fvm(ie)%c(1:nc,1:nc,:,m), & + (/nc*nc,nlev/))) - tfname = 'F'//trim(const_name(m))//'_fvm' - call outfld(tfname, RESHAPE(dyn_out%fvm(ie)%fc(1:nc,1:nc,:,m), & - (/nc*nc,nlev/)), nc*nc, ie) + tfname = 'F'//trim(const_diag_name(advected_constituent_index(m)))//'_fvm' + call history_out_field(tfname, RESHAPE(dyn_out%fvm(ie)%fc(1:nc,1:nc,:,m), & + (/nc*nc,nlev/))) end do end do end if end subroutine write_dyn_vars -#endif - !========================================================================================= end module dyn_comp diff --git a/src/dynamics/se/dyn_grid.F90 b/src/dynamics/se/dyn_grid.F90 index 51fdb2dae..781953c86 100644 --- a/src/dynamics/se/dyn_grid.F90 +++ b/src/dynamics/se/dyn_grid.F90 @@ -26,40 +26,27 @@ module dyn_grid ! !------------------------------------------------------------------------------- -use mpi, only: mpi_integer, mpi_real8 -use pio, only: file_desc_t use shr_kind_mod, only: r8 => shr_kind_r8, shr_kind_cl -use spmd_utils, only: masterproc, iam, mpicom, mstrid=>masterprocid, & - npes -use cam_constituents, only: num_advected use dynconst, only: pi -use cam_initfiles, only: initial_file_get_id use physics_column_type, only: physics_column_t, kind_pcol -use cam_map_utils, only: iMap - -use cam_logfile, only: iulog -use cam_abortutils, only: endrun, check_allocate !SE dycore: -use dimensions_mod, only: globaluniquecols, nelem, nelemd, nelemdmax, & - ne, np, npsq, fv_nphys, nlev, nlevp, nc, ntrac use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct use hybvcoord_mod, only: hvcoord_t -use prim_init, only: prim_init1 -use edge_mod, only: initEdgeBuffer use edgetype_mod, only: EdgeBuffer_t -use time_mod, only: TimeLevel_t -use dof_mod, only: UniqueCoords, UniquePoints +use se_dyn_time_mod, only: TimeLevel_t implicit none private -save integer, parameter :: dyn_decomp = 101 ! The SE dynamics grid integer, parameter :: fvm_decomp = 102 ! The FVM (CSLAM) grid integer, parameter :: physgrid_d = 103 ! physics grid on dynamics decomp integer, parameter :: ini_decomp = 104 ! alternate dynamics grid for reading initial file +integer, parameter :: dyn_hist_decomp = 105 ! The SE dynamics grid configured for history output. +integer, parameter :: ini_decomp_scm = 205 ! alternate dynamics grid for reading initial file + ! in single colum (SCAM) mode. character(len=3), protected :: ini_grid_name @@ -82,10 +69,7 @@ module dyn_grid public :: model_grid_init -!!XXgoldyXX: v try to remove? -public :: dyn_grid_get_colndx ! get element block/column and MPI process indices -!!XXgoldyXX: ^ try to remove? -public :: dyn_grid_get_elem_coords ! get coords of a specified block element +public :: dyn_grid_get_elem_coords ! get coords of a specified block element <-Is this actually used? -JN ! Namelist variables controlling grid writing. ! Read in dyn_readnl from dyn_se_inparm group. @@ -117,7 +101,14 @@ subroutine model_grid_init() ! and then initializes the physics grid and ! decomposition based on the dynamics (SE) grid. - use mpi, only: mpi_max + use pio, only: file_desc_t + use cam_constituents, only: num_advected + use cam_initfiles, only: initial_file_get_id + use cam_logfile, only: iulog + use cam_abortutils, only: endrun, check_allocate + use spmd_utils, only: masterproc, iam, mpicom, mstrid=>masterprocid, & + npes + use mpi, only: mpi_integer, mpi_max use vert_coord, only: vert_coord_init, pver use hycoef, only: hycoef_init, hypi, hypm, nprlev, & hyam, hybm, hyai, hybi, ps0 @@ -129,15 +120,19 @@ subroutine model_grid_init() use physics_grid, only: phys_grid_init use dp_mapping, only: dp_init, dp_write, nphys_pts use native_mapping, only: do_native_mapping, create_native_mapping_files + use prim_init, only: prim_init1 + use edge_mod, only: initEdgeBuffer !SE dycore: use parallel_mod, only: par use hybrid_mod, only: hybrid_t, init_loop_ranges, & get_loop_ranges, config_thread_region use control_mod, only: qsplit, rsplit - use time_mod, only: tstep, nsplit + use se_dyn_time_mod, only: tstep, nsplit use fvm_mod, only: fvm_init2, fvm_init3, fvm_pg_init + use dimensions_mod, only: nelem, nelemd, nelemdmax, globaluniquecols use dimensions_mod, only: irecons_tracer, dimensions_mod_init, qsize + use dimensions_mod, only: fv_nphys, npsq, use_cslam, nlev, nlevp use comp_gll_ctr_vol, only: gll_grid_write ! Local variables @@ -149,6 +144,7 @@ subroutine model_grid_init() type(hybrid_t) :: hybrid integer :: ierr + character(len=shr_kind_cl) :: errmsg integer :: dtime real(r8), allocatable :: clat(:), clon(:), areaa(:) @@ -164,13 +160,6 @@ subroutine model_grid_init() character(len=*), parameter :: subname = 'model_grid_init' !---------------------------------------------------------------------------- - if (fv_nphys > 0) then - ! Use CSLAM for tracer advection - qsize = thermodynamic_active_species_num ! number tracers advected by GLL - else - ! Use GLL for tracer advection - qsize = num_advected - end if ! Get file handle for initial file and first consistency check fh_ini => initial_file_get_id() @@ -181,8 +170,16 @@ subroutine model_grid_init() ! note that this must be done before "nlev" can be used: call dimensions_mod_init() + if (use_cslam) then + ! Use CSLAM for tracer advection + qsize = thermodynamic_active_species_num ! number tracers advected by GLL + else + ! Use GLL for tracer advection + qsize = num_advected + end if + ! Initialize total number of physics points per spectral element: - if (fv_nphys > 0) then + if (use_cslam) then ! Use finite volume physics grid nphys_pts = fv_nphys*fv_nphys else @@ -202,33 +199,33 @@ subroutine model_grid_init() !Allocate SE dycore "hvcoord" structure: !+++++++ - allocate(hvcoord%hyai(nlevp), stat=ierr) + allocate(hvcoord%hyai(nlevp), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'hvcoord%hyai(nlevp)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(hvcoord%hyam(nlev), stat=ierr) + allocate(hvcoord%hyam(nlev), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'hvcoord%hyam(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(hvcoord%hybi(nlevp), stat=ierr) + allocate(hvcoord%hybi(nlevp), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'hvcoord%hybi(nlevp)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(hvcoord%hybm(nlev), stat=ierr) + allocate(hvcoord%hybm(nlev), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'hvcoord%hybm(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(hvcoord%hybd(nlev), stat=ierr) + allocate(hvcoord%hybd(nlev), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'hvcoord%hybd(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(hvcoord%etam(nlev), stat=ierr) + allocate(hvcoord%etam(nlev), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'hvcoord%etam(nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(hvcoord%etai(nlevp), stat=ierr) + allocate(hvcoord%etai(nlevp), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'hvcoord%etai(nlevp)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) !+++++++ @@ -248,11 +245,11 @@ subroutine model_grid_init() if (iam < par%nprocs) then call prim_init1(elem, fvm, par, TimeLevel) - if (fv_nphys > 0) then + if (use_cslam) then call dp_init(elem, fvm) end if - if (fv_nphys > 0) then + if (use_cslam) then qsize_local = thermodynamic_active_species_num + 3 else qsize_local = num_advected + 3 @@ -265,7 +262,7 @@ subroutine model_grid_init() nelem = 0 nelemd = 0 nelemdmax = 0 - endif + end if ! nelemdmax is computed on the dycore comm, we need it globally. ngcols_d = nelemdmax @@ -296,7 +293,7 @@ subroutine model_grid_init() ! Physics grid on the physics decomposition is defined in phys_grid_init. call define_cam_grids() - if (fv_nphys > 0) then + if (use_cslam) then ! ================================================ ! finish fvm initialization @@ -320,7 +317,7 @@ subroutine model_grid_init() end if if (trim(se_write_grid_file) /= "no") then - if (fv_nphys > 0) then + if (use_cslam) then call dp_write(elem, fvm, trim(se_write_grid_file), trim(se_grid_filename)) else call gll_grid_write(elem, trim(se_write_grid_file), trim(se_grid_filename)) @@ -329,29 +326,29 @@ subroutine model_grid_init() if (do_native_mapping) then - allocate(areaA(ngcols_d), stat=ierr) + allocate(areaA(ngcols_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'areaA(ngcols_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(clat(ngcols_d), stat=ierr) + allocate(clat(ngcols_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'clat(ngcols_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(clon(ngcols_d), stat=ierr) + allocate(clon(ngcols_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'clon(ngcols_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) call get_horiz_grid_int(ngcols_d, clat_d_out=clat, clon_d_out=clon, area_d_out=areaA) ! Create mapping files using SE basis functions - call create_native_mapping_files(par, elem, 'native', ngcols_d, clat, clon, areaa) - call create_native_mapping_files(par, elem, 'bilin', ngcols_d, clat, clon, areaa) + call create_native_mapping_files(par, elem, 'native', ngcols_d, clat, clon, areaA) + call create_native_mapping_files(par, elem, 'bilin', ngcols_d, clat, clon, areaA) - deallocate(areaa, clat, clon) + deallocate(areaA, clat, clon) end if ! Calculate number of of local columns: - if (fv_nphys > 0) then ! physics uses an FVM grid + if (use_cslam) then ! physics uses an FVM grid num_local_columns = nelemd * fv_nphys * fv_nphys else num_local_columns = 0 @@ -372,14 +369,14 @@ subroutine model_grid_init() call set_dyn_col_values() ! Calculate horizontal dimensions (needed for physics grid): - if (fv_nphys > 0) then ! physics uses an FVM grid + if (use_cslam) then ! physics uses an FVM grid hdim1_d = nelem * fv_nphys * fv_nphys else hdim1_d = ngcols_d end if ! Determine grid name and attributes: - if (fv_nphys > 0) then + if (use_cslam) then gridname = 'physgrid_d' allocate(grid_attribute_names(2), stat=ierr) @@ -426,8 +423,11 @@ subroutine set_dyn_col_values() use physconst, only: pi use string_utils, only: to_str + use spmd_utils, only: iam + use cam_abortutils, only: check_allocate !SE dycore: + use dimensions_mod, only: nelemd, fv_nphys, use_cslam use coordinate_systems_mod, only: spherical_polar_t ! Local variables @@ -440,11 +440,12 @@ subroutine set_dyn_col_values() real(r8) :: dcoord real(kind_pcol), parameter :: radtodeg = 180.0_kind_pcol / pi real(kind_pcol), parameter :: degtorad = pi / 180.0_kind_pcol + character(len=shr_kind_cl) :: errmsg character(len=*), parameter :: subname = 'set_dyn_col_values' lindex = 0 do elem_ind = 1, nelemd - if (fv_nphys > 0) then ! physics uses an FVM grid + if (use_cslam) then ! physics uses an FVM grid do col_ind = 0, (fv_nphys * fv_nphys) - 1 lindex = lindex + 1 ii = MOD(col_ind, fv_nphys) + 1 @@ -471,11 +472,12 @@ subroutine set_dyn_col_values() local_dyn_columns(lindex)%global_dyn_block = & elem(elem_ind)%GlobalId - allocate(local_dyn_columns(lindex)%dyn_block_index(1), stat=ierr) + allocate(local_dyn_columns(lindex)%dyn_block_index(1), stat=ierr, & + errmsg=errmsg) call check_allocate(ierr, subname, & 'local_dyn_columns('//& to_str(lindex)//')%dyn_block_index(1)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) local_dyn_columns(lindex)%dyn_block_index(1) = col_ind + 1 end do @@ -506,11 +508,12 @@ subroutine set_dyn_col_values() local_dyn_columns(lindex)%global_dyn_block = & elem(elem_ind)%GlobalId - allocate(local_dyn_columns(lindex)%dyn_block_index(1), stat=ierr) + allocate(local_dyn_columns(lindex)%dyn_block_index(1), stat=ierr, & + errmsg=errmsg) call check_allocate(ierr, subname, & 'local_dyn_columns('//& to_str(lindex)//')%dyn_block_index(1)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) local_dyn_columns(lindex)%dyn_block_index(1) = col_ind end do @@ -524,6 +527,11 @@ end subroutine set_dyn_col_values subroutine get_horiz_grid_int(nxy, clat_d_out, clon_d_out, area_d_out, & wght_d_out, lat_d_out, lon_d_out) + use cam_abortutils, only: endrun, check_allocate + + !SE dycore: + use dimensions_mod, only: fv_nphys + ! Return global arrays of latitude and longitude (in radians), column ! surface area (in radians squared) and surface integration weights for ! global column indices that will be passed to/from physics @@ -599,9 +607,9 @@ subroutine get_horiz_grid_int(nxy, clat_d_out, clon_d_out, area_d_out, & if (present(clon_d_out)) then call create_global_coords(clat_d_out, clon_d_out, lat_d_out, lon_d_out) else - allocate(temp(nxy), stat=ierr) + allocate(temp(nxy), stat=ierr, errmsg=errormsg) call check_allocate(ierr, subname, 'temp(nxy)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) call create_global_coords(clat_d_out, temp, lat_d_out, lon_d_out) deallocate(temp) @@ -609,9 +617,9 @@ subroutine get_horiz_grid_int(nxy, clat_d_out, clon_d_out, area_d_out, & else if (present(clon_d_out)) then - allocate(temp(nxy), stat=ierr) + allocate(temp(nxy), stat=ierr, errmsg=errormsg) call check_allocate(ierr, subname, 'temp(nxy)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errormsg) call create_global_coords(temp, clon_d_out, lat_d_out, lon_d_out) deallocate(temp) @@ -622,32 +630,13 @@ end subroutine get_horiz_grid_int !========================================================================================= -subroutine dyn_grid_get_colndx(igcol, ncols, owners, col, lbk) - - ! For each global column index return the owning task. If the column is owned - ! by this task, then also return the local block number and column index in that - ! block. - ! - ! NOTE: this routine needs to be updated for the physgrid - - integer, intent(in) :: ncols - integer, intent(in) :: igcol(ncols) - integer, intent(out) :: owners(ncols) - integer, intent(out) :: col(ncols) - integer, intent(out) :: lbk(ncols) - - !---------------------------------------------------------------------------- - - owners = (igcol * 0) -1 ! Kill compiler warnings - col = -1 ! Kill compiler warnings - lbk = -1 ! Kill compiler warnings - call endrun('dyn_grid_get_colndx: not implemented for unstructured grids') - -end subroutine dyn_grid_get_colndx +subroutine dyn_grid_get_elem_coords(ie, rlon, rlat, cdex) -!========================================================================================= + use cam_abortutils, only: endrun, check_allocate -subroutine dyn_grid_get_elem_coords(ie, rlon, rlat, cdex) + !SE dycore: + use dof_mod, only: UniqueCoords + use dimensions_mod, only: ne, np, fv_nphys ! Returns coordinates of a specified block element of the dyn grid ! @@ -662,25 +651,27 @@ subroutine dyn_grid_get_elem_coords(ie, rlon, rlat, cdex) integer, optional, intent(out) :: cdex(:) ! global column index integer :: sb,eb, ii, i,j, icol, igcol, ierr - real(r8), allocatable :: clat(:), clon(:) + + real(r8), allocatable :: clat(:), clon(:) + character(len=shr_kind_cl) :: errmsg character(len=*), parameter :: subname = 'dyn_grid_get_elem_coords' !---------------------------------------------------------------------------- if (fv_nphys > 0) then - call endrun('dyn_grid_get_colndx: not implemented for the FVM physics grid') + call endrun(subname//': not implemented for the FVM physics grid') end if sb = elem(ie)%idxp%UniquePtOffset eb = sb + elem(ie)%idxp%NumUniquePts-1 - allocate(clat(sb:eb), stat=ierr) + allocate(clat(sb:eb), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'clat(sb:eb)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(clon(sb:eb), stat=ierr) + allocate(clon(sb:eb), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'clon(sb:eb)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) call UniqueCoords( elem(ie)%idxP, elem(ie)%spherep, clat(sb:eb), clon(sb:eb) ) @@ -707,8 +698,10 @@ end subroutine dyn_grid_get_elem_coords !========================================================================================= subroutine get_hdim_name(fh_ini, ini_grid_hdim_name) + use pio, only: pio_inq_dimid, pio_seterrorhandling use pio, only: PIO_BCAST_ERROR, PIO_NOERR + use pio, only: file_desc_t ! Determine whether the initial file uses 'ncol' or 'ncol_d' horizontal ! dimension in the unstructured grid. It is also possible when using @@ -779,17 +772,26 @@ subroutine define_cam_grids() use cam_grid_support, only: horiz_coord_t, horiz_coord_create use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register - + use cam_map_utils, only: iMap + use cam_abortutils, only: check_allocate +#ifdef SCAM + use scamMod, only: closeioplon,closeioplat,closeioplonidx,single_column +#endif !SE dycore: - use dimensions_mod, only: nc + use dimensions_mod, only: nc, ne, nelemd, np, npsq, use_cslam, fv_nphys ! Local variables integer :: i, ii, j, k, ie, mapind, ierr character(len=8) :: latname, lonname, ncolname, areaname + character(len=shr_kind_cl) :: errmsg type(horiz_coord_t), pointer :: lat_coord type(horiz_coord_t), pointer :: lon_coord integer(iMap), pointer :: grid_map(:,:) + integer(iMap), pointer :: grid_map_scm(:,:) !grid_map decomp for single column mode + + !DEBUG -JN: + integer(iMap), pointer :: grid_map_hist(:,:) real(r8), allocatable :: pelat_deg(:) ! pe-local latitudes (degrees) real(r8), allocatable :: pelon_deg(:) ! pe-local longitudes (degrees) @@ -797,6 +799,7 @@ subroutine define_cam_grids() real(r8) :: areaw(np,np) integer(iMap) :: fdofP_local(npsq,nelemd) ! pe-local map for dynamics decomp integer(iMap), allocatable :: pemap(:) ! pe-local map for PIO decomp + integer(iMap), allocatable :: pemap_scm(:) ! pe-local map for single column PIO decomp integer :: ncols_fvm, ngcols_fvm real(r8), allocatable :: fvm_coord(:) @@ -825,21 +828,21 @@ subroutine define_cam_grids() end do end do - allocate(pelat_deg(np*np*nelemd), stat=ierr) + allocate(pelat_deg(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'pelat_deg(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(pelon_deg(np*np*nelemd), stat=ierr) + allocate(pelon_deg(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'pelon_deg(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(pearea(np*np*nelemd), stat=ierr) + allocate(pearea(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'pearea(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(pemap(np*np*nelemd), stat=ierr) + allocate(pemap(np*np*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'pemap(np*np*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) pemap = 0_iMap ii = 1 @@ -900,6 +903,31 @@ subroutine define_cam_grids() call cam_grid_attribute_register('GLL', 'np', '', np) call cam_grid_attribute_register('GLL', 'ne', '', ne) + ! Register a second "GLL hist" grid that is needed for history output: + !-------------------------------------------------------------------- + allocate(grid_map_hist(3,npsq*nelemd), stat=ierr) + call check_allocate(ierr, subname, 'grid_map_hist(3,npsq*nelemd)', & + file=__FILE__, line=__LINE__) + + grid_map_hist = 0_iMap + mapind = 1 + do j = 1, nelemd + do i = 1, npsq + grid_map_hist(1, mapind) = mapind + grid_map_hist(2, mapind) = 0 + grid_map_hist(3, mapind) = pemap(mapind) + mapind = mapind + 1 + end do + end do + + call cam_grid_register('GLL_hist', dyn_hist_decomp, lat_coord, lon_coord, & + grid_map_hist, src_in=[1,0], block_indexed=.false., unstruct=.true.) + call cam_grid_attribute_register('GLL_hist', trim(areaname), 'gll grid areas', & + trim(ncolname), pearea, map=pemap) + call cam_grid_attribute_register('GLL_hist', 'np', '', np) + call cam_grid_attribute_register('GLL_hist', 'ne', '', ne) + !-------------------------------------------------------------------- + ! With CSLAM if the initial file uses the horizontal dimension 'ncol' rather than ! 'ncol_d' then we need a grid object with the names ncol,lat,lon to read it. ! Create that grid object here if it's needed. @@ -933,26 +961,62 @@ subroutine define_cam_grids() ! grid_map cannot be deallocated as the cam_filemap_t object just points ! to it. It can be nullified. nullify(grid_map) +#ifdef SCAM + !--------------------------------- + ! Create SCM grid object when running single column mode + !--------------------------------- + + if ( single_column) then + allocate(pemap_scm(1)) + pemap_scm = 0_iMap + pemap_scm = closeioplonidx + ! Map for scm grid + allocate(grid_map_scm(3,npsq)) + grid_map_scm = 0_iMap + mapind = 1 + j = 1 + do i = 1, npsq + grid_map_scm(1, mapind) = i + grid_map_scm(2, mapind) = j + grid_map_scm(3, mapind) = pemap_scm(1) + mapind = mapind + 1 + end do + latval=closeioplat + lonval=closeioplon + + lat_coord => horiz_coord_create('lat', 'ncol', 1, & + 'latitude', 'degrees_north', 1, 1, latval, map=pemap_scm) + lon_coord => horiz_coord_create('lon', 'ncol', 1, & + 'longitude', 'degrees_east', 1, 1, lonval, map=pemap_scm) + + call cam_grid_register('SCM', ini_decomp_scm, lat_coord, lon_coord, & + grid_map_scm, block_indexed=.false., unstruct=.true.) + deallocate(pemap_scm) + ! grid_map cannot be deallocated as the cam_filemap_t object just points + ! to it. It can be nullified. + nullify(grid_map_scm) + end if +#endif !--------------------------------- ! Create FVM grid object for CSLAM !--------------------------------- - if (ntrac > 0) then + if (use_cslam) then ncols_fvm = nc * nc * nelemd ngcols_fvm = nc * nc * nelem_d - allocate(fvm_coord(ncols_fvm), stat=ierr) + allocate(fvm_coord(ncols_fvm), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'fvm_coord(ncols_fvm)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(fvm_map(ncols_fvm), stat=ierr) + allocate(fvm_map(ncols_fvm), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'fvm_map(ncols_fvm)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(fvm_area(ncols_fvm), stat=ierr) + allocate(fvm_area(ncols_fvm), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'fvm_area(ncols_fvm)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemd k = 1 @@ -1024,17 +1088,17 @@ subroutine define_cam_grids() ncols_physgrid = fv_nphys * fv_nphys * nelemd ngcols_physgrid = fv_nphys * fv_nphys * nelem_d - allocate(physgrid_coord(ncols_physgrid), stat=ierr) + allocate(physgrid_coord(ncols_physgrid), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'physgrid_coord(ncols_physgrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(physgrid_map(ncols_physgrid), stat=ierr) + allocate(physgrid_map(ncols_physgrid), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'physgrid_map(ncols_physgrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(physgrid_area(ncols_physgrid), stat=ierr) + allocate(physgrid_area(ncols_physgrid), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'physgrid_area(ncols_physgrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemd k = 1 @@ -1067,9 +1131,9 @@ subroutine define_cam_grids() map=physgrid_map) ! Map for physics grid - allocate(grid_map(3, ncols_physgrid), stat=ierr) + allocate(grid_map(3, ncols_physgrid), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'grid_map(3, ncols_physgrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) grid_map = 0_iMap mapind = 1 @@ -1106,15 +1170,16 @@ end subroutine define_cam_grids subroutine write_grid_mapping(par, elem) - use cam_pio_utils, only: cam_pio_createfile, cam_pio_newdecomp - use pio, only: pio_def_dim, var_desc_t, pio_int, pio_def_var, & - pio_enddef, pio_closefile, io_desc_t, & - pio_write_darray, pio_freedecomp, & - pio_offset_kind + use cam_pio_utils, only: cam_pio_createfile, cam_pio_newdecomp + use pio, only: pio_def_dim, var_desc_t, pio_int, pio_def_var, & + pio_enddef, pio_closefile, io_desc_t, & + pio_write_darray, pio_freedecomp, & + file_desc_t, pio_offset_kind ! SE dycore: - use parallel_mod, only: parallel_t - use dof_mod, only: createmetadata + use parallel_mod, only: parallel_t + use dof_mod, only: createmetadata + use dimensions_mod, only: np, nelemd ! arguments type(parallel_t), intent(in) :: par @@ -1172,7 +1237,16 @@ end subroutine write_grid_mapping !========================================================================================= subroutine create_global_area(area_d) - use dp_mapping, only: dp_reorder, dp_allocate, dp_deallocate + + use mpi, only: mpi_integer, mpi_real8 + use spmd_utils, only: masterproc, iam, mpicom, mstrid=>masterprocid, npes + use cam_abortutils, only: endrun, check_allocate + use cam_logfile, only: iulog + + !SE dycore: + use dimensions_mod, only: fv_nphys, nelemd, nelemdmax, np + use dof_mod, only: UniquePoints + use dp_mapping, only: dp_reorder, dp_allocate, dp_deallocate ! Gather global array of column areas for the physics grid, ! reorder to global column order, then broadcast it to all tasks. @@ -1188,6 +1262,7 @@ subroutine create_global_area(area_d) integer :: ie, sb, eb, i, j, k integer :: ierr integer :: ibuf + character(len=shr_kind_cl) :: errmsg character(len=*), parameter :: subname = 'create_global_area' !---------------------------------------------------------------------------- @@ -1200,13 +1275,13 @@ subroutine create_global_area(area_d) ! first gather all data onto masterproc, in mpi task order (via ! mpi_gatherv) then redorder into globalID order (via dp_reorder) ncol = fv_nphys*fv_nphys*nelem_d - allocate(rbuf(ncol), stat=ierr) + allocate(rbuf(ncol), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'rbuf(ncol)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dp_area(fv_nphys*fv_nphys,nelem_d), stat=ierr) + allocate(dp_area(fv_nphys*fv_nphys,nelem_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dp_area(fv_nphys*fv_nphys,nelem_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemd k = 1 @@ -1248,9 +1323,9 @@ subroutine create_global_area(area_d) else ! physics is on the GLL grid - allocate(rbuf(ngcols_d), stat=ierr) + allocate(rbuf(ngcols_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'rbuf(ngcols_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemdmax if (ie <= nelemd) then @@ -1289,7 +1364,16 @@ end subroutine create_global_area !========================================================================================= subroutine create_global_coords(clat, clon, lat_out, lon_out) - use dp_mapping, only: dp_reorder, dp_allocate, dp_deallocate + + use mpi, only: mpi_integer, mpi_real8 + use spmd_utils, only: masterproc, iam, mpicom, mstrid=>masterprocid, npes + use cam_abortutils, only: check_allocate, endrun + use cam_logfile, only: iulog + + !SE dycore: + use dimensions_mod, only: fv_nphys, nelemd, nelemdmax + use dof_mod, only: UniqueCoords + use dp_mapping, only: dp_reorder, dp_allocate, dp_deallocate ! Gather global arrays of column coordinates for the physics grid, ! reorder to global column order, then broadcast to all tasks. @@ -1307,6 +1391,7 @@ subroutine create_global_coords(clat, clon, lat_out, lon_out) integer :: ierr integer :: ibuf integer :: ncol + character(len=shr_kind_cl) :: errmsg character(len=*), parameter :: subname = 'create_global_coords' !---------------------------------------------------------------------------- @@ -1329,17 +1414,17 @@ subroutine create_global_coords(clat, clon, lat_out, lon_out) ! mpi_gatherv) then redorder into globalID order (via dp_reorder) ncol = fv_nphys*fv_nphys*nelem_d - allocate(rbuf(ncol), stat=ierr) + allocate(rbuf(ncol), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'rbuf(ncol)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dp_lon(fv_nphys*fv_nphys,nelem_d), stat=ierr) + allocate(dp_lon(fv_nphys*fv_nphys,nelem_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dp_lon(fv_nphys*fv_nphys,nelem_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(dp_lat(fv_nphys*fv_nphys,nelem_d), stat=ierr) + allocate(dp_lat(fv_nphys*fv_nphys,nelem_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dp_lat(fv_nphys*fv_nphys,nelem_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemd k = 1 @@ -1402,9 +1487,9 @@ subroutine create_global_coords(clat, clon, lat_out, lon_out) else ! physics uses the GLL grid - allocate(rbuf(ngcols_d), stat=ierr) + allocate(rbuf(ngcols_d), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'rbuf(ngcols_d)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemdmax diff --git a/src/dynamics/se/gravity_waves_sources.F90 b/src/dynamics/se/gravity_waves_sources.F90 index 0591c3ef5..f525b35a3 100644 --- a/src/dynamics/se/gravity_waves_sources.F90 +++ b/src/dynamics/se/gravity_waves_sources.F90 @@ -1,16 +1,13 @@ module gravity_waves_sources + use shr_kind_mod, only: r8 => shr_kind_r8 !SE dycore: use derivative_mod, only: derivative_t - use dimensions_mod, only: np,nlev use edgetype_mod, only: EdgeBuffer_t - use element_mod, only: element_t - use hybrid_mod, only: hybrid_t implicit none private - save !! gravity_waves_sources created by S Santos, 10 Aug 2011 !! @@ -33,11 +30,13 @@ module gravity_waves_sources subroutine gws_init(elem) + use hycoef, only: hypi + !SE dycore: use parallel_mod, only: par use edge_mod, only: initEdgeBuffer - use hycoef, only: hypi - use dimensions_mod, only: nlevp + use element_mod, only: element_t + use dimensions_mod, only: nlev, nlevp use thread_mod, only: horz_num_threads ! Elem will be needed for future updates to edge code @@ -58,13 +57,14 @@ subroutine gws_src_fnct(elem, tl, tlq, frontgf, frontga,nphys) use shr_kind_mod, only: shr_kind_cl !SE dycore: + use element_mod, only: element_t use derivative_mod, only: derivinit - use dimensions_mod, only: npsq, nelemd + use dimensions_mod, only: npsq, nelemd, fv_nphys, nlev use dof_mod, only: UniquePoints + use hybrid_mod, only: hybrid_t use hybrid_mod, only: config_thread_region, get_loop_ranges use parallel_mod, only: par use thread_mod, only: horz_num_threads - use dimensions_mod, only: fv_nphys type (element_t), intent(inout), dimension(:) :: elem integer, intent(in) :: tl, nphys, tlq @@ -118,16 +118,20 @@ end subroutine gws_src_fnct !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine gws_src_vort(elem, tl, tlq, vort4gw, nphys) + + use cam_abortutils, only : check_allocate + use shr_kind_mod, only : shr_kind_cl + + !SE dycore: + use element_mod, only : element_t + use hybrid_mod, only : hybrid_t use derivative_mod, only : derivinit - use dimensions_mod, only : nelemd + use dimensions_mod, only : nelemd, fv_nphys, nlev use dof_mod, only : UniquePoints use hybrid_mod, only : config_thread_region, get_loop_ranges use parallel_mod, only : par use vert_coord, only : pver use thread_mod, only : horz_num_threads - use dimensions_mod, only : fv_nphys - use cam_abortutils, only : check_allocate - use shr_kind_mod, only : shr_kind_cl implicit none type (element_t), intent(in), dimension(:) :: elem @@ -185,10 +189,14 @@ subroutine compute_vorticity_4gw(vort4gw,tl,tlq,elem,ederiv,hybrid,nets,nete,nph ! ! * corresponding/blame-able !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !SE dycore: + use element_mod, only: element_t + use hybrid_mod, only: hybrid_t use derivative_mod, only: vorticity_sphere use edge_mod, only: edgevpack, edgevunpack use bndry_mod, only: bndry_exchange - use dimensions_mod, only: fv_nphys + use dimensions_mod, only: np, fv_nphys, nlev use fvm_mapping, only: dyn2phys type(hybrid_t), intent(in) :: hybrid @@ -270,11 +278,13 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, use dyn_grid, only: hvcoord !SE dycore: + use element_mod, only: element_t + use hybrid_mod, only: hybrid_t use derivative_mod, only: gradient_sphere, ugradv_sphere use edge_mod, only: edgevpack, edgevunpack use bndry_mod, only: bndry_exchange - use dimensions_mod, only: fv_nphys,ntrac - use fvm_mapping, only: dyn2phys_vector,dyn2phys + use dimensions_mod, only: np, fv_nphys, ntrac, nlev + use fvm_mapping, only: dyn2phys_vector, dyn2phys type(hybrid_t), intent(in) :: hybrid type(element_t), intent(inout), target :: elem(:) @@ -435,6 +445,10 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, end subroutine compute_frontogenesis subroutine compute_vertical_derivative(pint,pmid,data,ddata_dp) + + !SE dycore: + use dimensions_mod, only: np, nlev + !--------------------------------------------------------------------------- real(r8), intent(in ) :: pint(np,np,nlev+1) real(r8), intent(in ) :: pmid(np,np,nlev) diff --git a/src/dynamics/se/namelist_definition_se_dycore.xml b/src/dynamics/se/namelist_definition_se_dycore.xml index dcce50308..707f3a8a9 100644 --- a/src/dynamics/se/namelist_definition_se_dycore.xml +++ b/src/dynamics/se/namelist_definition_se_dycore.xml @@ -74,7 +74,7 @@ 3 - 4 + 1 @@ -89,66 +89,17 @@ 4 - - integer - se - dyn_se_nl - - Variable to specify the vertical index at which the - Rayleigh friction term is centered (the peak value). - Default: 2 - - - 2 - - - - real - se - dyn_se_nl - - Rayleigh friction parameter to determine the width of the profile. If set - to 0 then a width is chosen by the algorithm (see rayleigh_friction.F90). - Default: 0.5. - - - 0.5 - 3 - - - - real - se - dyn_se_nl - - Rayleigh friction parameter to determine the approximate value of the decay - time (days) at model top. If 0.0 then no Rayleigh friction is applied. - Default: 0. - - - 0.0 - - real se dyn_se_nl - Used by SE dycore to apply sponge layer diffusion to u, v, and T for - stability of WACCM configurations. The diffusion is modeled on 3D molecular - diffusion and thermal conductivity by using actual molecular diffusion and - thermal conductivity coefficients multiplied by the value of - se_molecular_diff. - - If set <= 0.0 then the code is not activated. If set > 0.0 then - the molecular diffusion and thermal conductivity coefficients will be - multiplied by a factor of se_molecular_diff. - - Default: 0. + Enable thermal conductivity and molecular diffusion in the horizontal in SE dycore. + Default: 1.0 for WACCM-X, 0.0 (i.e., not used) for all other configurations. 0.0 - 100.0 + 1.0 @@ -255,22 +206,6 @@ 7 - - integer - se - dyn_se_nl - 0,1,2 - - Scaling of temperature increment for different levels of - thermal energy consistency. - 0: no scaling - 1: scale increment for cp consistency between dynamics and physics - 2: do 1 as well as take into account condensate effect on thermal energy - - - 1 - - real se @@ -281,6 +216,7 @@ -1 + 6.e15 1.0e13 @@ -294,6 +230,7 @@ -1 + 6.e15 1.5625e13 @@ -307,6 +244,7 @@ -1 + 6.e15 1.5625e13 @@ -318,45 +256,64 @@ Second-order viscosity applied only near the model top [m^2/s]. - 5.0e5 - 1.0e6 - - 0.0 + 1.25e5 + 1.0e6 + 1.0e6 + 1.0e6 2.0e5 - - logical + + real se dyn_se_nl - Hyperscosity for T and dp is applied to (T-Tref) and (dp-dp_ref) where - Xref are reference states where the effect of topography has been removed - (Simmons and Jiabin, 1991, QJRMS, Section 2a). - If TRUE dp_ref is dynamic smoothed reference state derived by Patrick Callaghan - (Lauritzen et al., 2018, JAMES, Appendix A.2) and temperature reference state - based on Simmons and Jiabin (1991) but using smoothed dp_ref. - If FALSE Tref is static reference state (Simmons and Jiabin) and dp_ref state - derived from hydrostatic balance. + Hyperviscosity coefficient se_nu [m^4/s] for u,v, T is increased to + se_nu_p*se_sponge_del4_nu_fac following a hyperbolic tangent function + centered around pressure at vertical index se_sponge_del4_lev: + + 0.5_r8*(1.0_r8+tanh(2.0_r8*log(pmid(se_sponge_del4_lev)/press))) + + where press is pressure + + If < 0, se_sponge_del4_nu_fac is automatically set based on model top location. - .false. + -1 - - logical - se + + real + se> dyn_se_nl - If TRUE the continous equations the dynamical core is based on will conserve a - comprehensive moist total energy - If FALSE the continous equations the dynamical core is based on will conserve - a total energy based on cp for dry air and no condensates (same total energy as - CAM physics uses). - For more details see Lauritzen et al., (2018;DOI:10.1029/2017MS001257) + Divergence damping hyperviscosity coefficient se_nu_div [m^4/s] for u,v is increased to + se_nu_p*se_sponge_del4_nu_div_fac following a hyperbolic tangent function + centered around pressure at vertical index se_sponge_del4_lev: + + 0.5_r8*(1.0_r8+tanh(2.0_r8*log(pmid(se_sponge_del4_lev)/press))) + + where press is pressure + + If < 0, se_sponge_del4_nu_div_fac is automatically set based on model top location. - .true. + -1 + + + + real + se> + dyn_se_nl + + Level index around which increased del4 damping is centered. + + See se_sponge_del4_nu_fac and se_sponge_del4_nu_div_fac + + If < 0, se_sponge_del4_lev is automatically set based on model top location. + + + -1 @@ -689,4 +646,44 @@ 0 + + integer + se + dyn_se_nl + 1,2,3 + + 1: Exner version of pressure gradient force (PGF) + see Appendix A in Herrington et al., 2022, + doi: 10.1029/2022MS003192 + + 2: Traditional pressure gradient formulation (grad p) + + 3: Hybrid (formulation 1 where hybm>0 else formulation 2) + Use hybrid PGF option for WACCM-x to make WACCM-x consistent with PGF + used in CAM in the troposphere and traditional PGF formulation above + + + 1 + 3 + + + + integer + se + dyn_se_nl + 0,1 + + 0: physics tendencies will be added every vertical remapping time-step (dt_phys/se_nsplit) + for se_ftype=0,2 + + 1: physics tendencies will be added every dynamics time-step (dt_phys/se_nsplit*se_rsplit) + for se_ftype=0,2 + + If se_ftype=1 then se_dribble_in_rsplit_loop has no effect since physics tendencies are added as an adjustment + + + 0 + 1 + + diff --git a/src/dynamics/se/native_mapping.F90 b/src/dynamics/se/native_mapping.F90 index ed5a11e86..66a0cad38 100644 --- a/src/dynamics/se/native_mapping.F90 +++ b/src/dynamics/se/native_mapping.F90 @@ -6,12 +6,7 @@ module native_mapping ! using the SE basis functions. The output mapping file name is generated based on the SE model resolution ! and the input grid file name and ends in '_date_native.nc' ! - use mpi, only: mpi_character, mpi_logical, mpi_integer, mpi_max - use cam_logfile, only: iulog - use shr_kind_mod, only: r8 => shr_kind_r8, shr_kind_cl - use shr_const_mod, only: pi=>shr_const_pi - use cam_abortutils, only: endrun - use spmd_utils, only: iam, masterproc, mpicom, mstrid=>masterprocid + use shr_kind_mod, only: shr_kind_cl implicit none private @@ -27,8 +22,13 @@ module native_mapping subroutine native_mapping_readnl(NLFileName) - use shr_nl_mod, only: find_group_name => shr_nl_find_group_name - use runtime_obj, only: unset_str + use shr_nl_mod, only: find_group_name => shr_nl_find_group_name + use runtime_obj, only: unset_str + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc, mpicom + use spmd_utils, only: mstrid=>masterprocid + use mpi, only: mpi_character, mpi_logical character(len=*), intent(in) :: NLFileName @@ -82,9 +82,14 @@ end subroutine native_mapping_readnl subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, areaa) + use shr_kind_mod, only: r8=>shr_kind_r8 use shr_infnan_mod, only: isnan=>shr_infnan_isnan + use physconst, only: pi use cam_pio_utils, only: cam_pio_openfile, cam_pio_createfile - use cam_abortutils, only: check_allocate + use cam_logfile, only: iulog + use cam_abortutils, only: endrun, check_allocate + use spmd_utils, only: iam, masterproc + use mpi, only: mpi_integer, mpi_max use pio, only: pio_noerr, pio_openfile, pio_createfile, pio_closefile, & pio_get_var, pio_put_var, pio_write_darray,pio_int, pio_double, & @@ -121,7 +126,7 @@ subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, are real(r8), intent(in) :: clon(ncol) real(r8), intent(in) :: areaa(ncol) - character(len=shr_kind_cl) :: mappingfile, fname + character(len=shr_kind_cl) :: mappingfile, fname, errmsg type(hybrid_t) :: hybrid @@ -203,27 +208,27 @@ subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, are ierr = pio_inq_dimid( ogfile, 'grid_size', dimid) ierr = pio_inq_dimlen( ogfile, dimid, npts) - allocate(lat(npts), stat=ierr) + allocate(lat(npts), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'lat(npts)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(lon(npts), stat=ierr) + allocate(lon(npts), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'lon(npts)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(grid_imask(npts), stat=ierr) + allocate(grid_imask(npts), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'grid_mask(npts)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(areab(npts), stat=ierr) + allocate(areab(npts), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'areab(npts)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ierr = pio_inq_dimid( ogfile, 'grid_rank', dimid) ierr = pio_inq_dimlen(ogfile, dimid, dg_rank) - allocate(dg_dims(dg_rank), stat=ierr) + allocate(dg_dims(dg_rank), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'dg_dims(dg_rank)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ierr = pio_inq_varid( ogfile, 'grid_dims', vid) ierr = pio_get_var( ogfile, vid, dg_dims) @@ -327,17 +332,17 @@ subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, are ! allocate storage do ii=1,nelemd ngrid = interpdata(ii)%n_interp - allocate(interpdata(ii)%interp_xy( ngrid ), stat=ierr ) + allocate(interpdata(ii)%interp_xy( ngrid ), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'interpdata(ii)%interp_xy(ngrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(interpdata(ii)%ilat( ngrid ), stat=ierr ) + allocate(interpdata(ii)%ilat( ngrid ), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'interpdata(ii)%ilat(ngrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(interpdata(ii)%ilon( ngrid ), stat=ierr ) + allocate(interpdata(ii)%ilon( ngrid ), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'interpdata(ii)%ilon(ngrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) interpdata(ii)%n_interp=0 ! reset counter enddo @@ -365,21 +370,21 @@ subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, are end do - allocate(h(int(countx)), stat=ierr) + allocate(h(int(countx)), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'h(int(countx))', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(h1d(int(countx)*npsq*nelemd), stat=ierr) + allocate(h1d(int(countx)*npsq*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'h1d(int(countx)*npsq*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(row(int(countx)*npsq*nelemd), stat=ierr) + allocate(row(int(countx)*npsq*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'row(int(countx)*npsq*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(col(int(countx)*npsq*nelemd), stat=ierr) + allocate(col(int(countx)*npsq*nelemd), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'col(int(countx)*npsq*nelemd)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) row = 0 col = 0 @@ -425,9 +430,9 @@ subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, are call mpi_allreduce(cntperelem_in, cntperelem_out, nelem, MPI_INTEGER, MPI_MAX, par%comm, ierr) - allocate(ldof(ngrid), stat=ierr) + allocate(ldof(ngrid), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'ldof(ngrid)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) ldof = 0 ii=1 @@ -475,9 +480,6 @@ subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, are ierr = pio_def_var( ogfile, 'dst_grid_dims',pio_int, (/dg_dim/),dg_id) - - - ierr = pio_def_var( ogfile, 'col', pio_int, (/ns_dim/), colid) ierr = pio_def_var( ogfile, 'row', pio_int, (/ns_dim/), rowid) ierr = pio_def_var( ogfile, 'S', pio_double, (/ns_dim/), sid) @@ -576,7 +578,4 @@ subroutine create_native_mapping_files(par, elem, maptype, ncol, clat, clon, are end subroutine create_native_mapping_files - - - end module native_mapping diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index ac46e2af2..63628f1b9 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -1,19 +1,13 @@ module stepon -use shr_kind_mod, only: r8 => SHR_KIND_R8 -use dyn_comp, only: dyn_import_t, dyn_export_t -use physics_types, only: physics_state, physics_tend -use spmd_utils, only: iam, mpicom -use perf_mod, only: t_startf, t_stopf, t_barrierf -use runtime_obj, only: runtime_options - -!SE dycore: -use parallel_mod, only: par -use dimensions_mod, only: nelemd +#ifdef scam +use scamMod, only: use_iop, doiopupdate, single_column, & + setiopupdate, readiopdata +use se_single_column_mod, only: scm_setfield, iop_broadcast +#endif implicit none private -save public stepon_init public stepon_timestep_init @@ -26,12 +20,72 @@ module stepon !========================================================================================= subroutine stepon_init(cam_runtime_opts, dyn_in, dyn_out) + use cam_constituents, only: num_constituents + use cam_constituents, only: const_longname + use cam_constituents, only: const_diag_name + use runtime_obj, only: runtime_options + use cam_history, only: history_add_field + use cam_history_support, only: horiz_only + + ! SE/CAM interface: + use dyn_comp, only: dyn_import_t, dyn_export_t + use dyn_comp, only: cnst_diag_name_gll + + ! SE dycore: + use dimensions_mod, only: fv_nphys, cnst_longname_gll, qsize ! Dummy arguments type(runtime_options), intent(in) :: cam_runtime_opts ! Runtime settings object type(dyn_import_t), intent(in) :: dyn_in ! Dynamics import container type(dyn_export_t), intent(in) :: dyn_out ! Dynamics export container + ! local variables + integer :: m, m_cnst + + !---------------------------------------------------------------------------- + ! These fields on dynamics grid are output before the call to d_p_coupling. + do m_cnst = 1, qsize + call history_add_field(trim(cnst_diag_name_gll(m_cnst))//'_gll', trim(cnst_longname_gll(m_cnst)), & + 'lev', 'inst', 'kg kg-1', gridname='GLL') + call history_add_field(trim(cnst_diag_name_gll(m_cnst))//'dp_gll', trim(cnst_longname_gll(m_cnst))//'*dp', & + 'lev', 'inst', 'kg kg-1', gridname='GLL') + end do + + call history_add_field('U_gll' ,'U wind on gll grid' ,'lev' , 'inst', 'm s-1 ',gridname='GLL') + call history_add_field('V_gll' ,'V wind on gll grid' ,'lev' , 'inst', 'm s-1 ',gridname='GLL') + call history_add_field('T_gll' ,'T on gll grid' ,'lev' , 'inst', 'K ' ,gridname='GLL') + call history_add_field('dp_ref_gll' ,'dp dry / dp_ref on gll grid','lev' , 'inst', '1' ,gridname='GLL') + call history_add_field('PSDRY_gll' ,'psdry on gll grid' ,horiz_only , 'inst', 'Pa ' ,gridname='GLL') + call history_add_field('PS_gll' ,'ps on gll grid' ,horiz_only , 'inst', 'Pa ' ,gridname='GLL') + call history_add_field('PHIS_gll' ,'PHIS on gll grid' ,horiz_only , 'inst', 'Pa ' ,gridname='GLL') + + ! Fields for initial condition files + call history_add_field('U&IC', 'Zonal wind' ,'lev' , 'inst', 'm s-1', gridname='GLL') + call history_add_field('V&IC', 'Meridional wind' ,'lev' , 'inst', 'm s-1', gridname='GLL') + + ! Don't need to register U&IC V&IC as vector components since we don't interpolate IC files + !Uncomment or delete once history output "groups" have been + !implemented in CAM-SIMA -JN: + !call add_default('U&IC',0, 'inst') + !call add_default('V&IC',0, 'inst') + + call history_add_field('PS&IC', 'Surface pressure' ,horiz_only , 'inst', 'Pa', gridname='GLL') + call history_add_field('T&IC', 'Temperature' ,'lev' , 'inst', 'K ', gridname='GLL') + + !Uncomment or delete once history output "groups" have been + !implemented in CAM-SIMA -JN: + !call add_default('PS&IC', 0, 'inst') + !call add_default('T&IC', 0, 'inst') + + do m_cnst = 1, num_constituents + call history_add_field(trim(const_diag_name(m_cnst))//'&IC', trim(const_longname(m_cnst)), & + 'lev', 'inst', 'kg kg-1', gridname='GLL') + + !Uncomment or delete once history output "groups" have been + !implemented in CAM-SIMA -JN: + !call add_default(trim(const_diag_name(m_cnst))//'&IC', 0, 'inst') + end do + end subroutine stepon_init !========================================================================================= @@ -39,12 +93,21 @@ end subroutine stepon_init subroutine stepon_timestep_init(dtime_out, cam_runtime_opts, phys_state, & phys_tend, dyn_in, dyn_out) + use shr_kind_mod, only: r8=>shr_kind_r8 + use perf_mod, only: t_startf, t_stopf, t_barrierf + use runtime_obj, only: runtime_options + use physics_types, only: physics_state, physics_tend use time_manager, only: get_step_size use cam_abortutils, only: endrun - use dp_coupling, only: d_p_coupling ! dynamics-physics coupling + use spmd_utils, only: iam, mpicom + + ! SE/CAM interface: + use dyn_comp, only: dyn_import_t, dyn_export_t + use dp_coupling, only: d_p_coupling ! dynamics-physics coupling - !SE dycore: - use time_mod, only: tstep ! dynamics timestep + ! SE dycore: + use se_dyn_time_mod, only: tstep ! dynamics timestep + use parallel_mod, only: par ! Dummy arguments real(r8), intent(out) :: dtime_out ! Time-step (s) @@ -66,28 +129,61 @@ subroutine stepon_timestep_init(dtime_out, cam_runtime_opts, phys_state, & ! write diagnostic fields on gll grid and initial file call diag_dynvar_ic(dyn_out%elem, dyn_out%fvm) end if +#ifdef scam + + ! Determine whether it is time for an IOP update; + ! doiopupdate set to true if model time step > next available IOP + + if (use_iop .and. masterproc) then + call setiopupdate + end if + + if (single_column) then + + ! If first restart step then ensure that IOP data is read + if (is_first_restart_step()) then + if (masterproc) call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) + call iop_broadcast() + endif + + iop_update_phase1 = .true. + if ((is_first_restart_step() .or. doiopupdate) .and. masterproc) then + call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) + endif + call iop_broadcast() + + call scm_setfield(dyn_out%elem,iop_update_phase1) + endif +#endif ! Synchronize all PEs and then transfer dynamics variables to physics: call t_barrierf('sync_d_p_coupling', mpicom) call t_startf('d_p_coupling') ! Move data into phys_state structure. call d_p_coupling(cam_runtime_opts, phys_state, phys_tend, dyn_out) call t_stopf('d_p_coupling') - end subroutine stepon_timestep_init !========================================================================================= subroutine stepon_run2(cam_runtime_opts, phys_state, phys_tend, dyn_in, dyn_out) - !SE/CAM interface: - use dp_coupling, only: p_d_coupling - use dyn_grid, only: TimeLevel + use runtime_obj, only: runtime_options + use physics_types, only: physics_state, physics_tend + use perf_mod, only: t_startf, t_stopf, t_barrierf + use spmd_utils, only: mpicom, iam + + ! SE/CAM interface: + use dp_coupling, only: p_d_coupling + use dyn_grid, only: TimeLevel + use dyn_comp, only: dyn_import_t, dyn_export_t - !SE dycore: - use time_mod, only: TimeLevel_Qdp + ! SE dycore: + use se_dyn_time_mod, only: TimeLevel_Qdp use control_mod, only: qsplit - use prim_advance_mod, only: calc_tot_energy_dynamics + use prim_advance_mod, only: tot_energy_dyn + use dimensions_mod, only: nelemd + use parallel_mod, only: par ! Dummy arguments type(runtime_options), intent(in) :: cam_runtime_opts ! Runtime settings object @@ -98,12 +194,12 @@ subroutine stepon_run2(cam_runtime_opts, phys_state, phys_tend, dyn_in, dyn_out) ! Local variables integer :: tl_f, tl_fQdp + !---------------------------------------------------------------------------- !Determine appropriate time values: tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) - ! Synchronize all PEs and then transfer physics variables to dynamics: call t_barrierf('sync_p_d_coupling', mpicom) call t_startf('p_d_coupling') @@ -112,7 +208,7 @@ subroutine stepon_run2(cam_runtime_opts, phys_state, phys_tend, dyn_in, dyn_out) call t_stopf('p_d_coupling') if (iam < par%nprocs) then - call calc_tot_energy_dynamics(dyn_in%elem,dyn_in%fvm, 1, nelemd, tl_f, tl_fQdp,'dED') + call tot_energy_dyn(dyn_in%elem,dyn_in%fvm, 1, nelemd, tl_f, tl_fQdp,'dED') end if end subroutine stepon_run2 @@ -121,16 +217,25 @@ end subroutine stepon_run2 subroutine stepon_run3(dtime, cam_runtime_opts, cam_out, phys_state, dyn_in, dyn_out) - use physics_types, only: cam_out_t + use shr_kind_mod, only: r8=>shr_kind_r8 + use runtime_obj, only: runtime_options + use physics_types, only: cam_out_t, physics_state + use perf_mod, only: t_startf, t_stopf, t_barrierf + use spmd_utils, only: mpicom - !SE/CAM interface: + ! SE/CAM interface: + use dyn_comp, only: dyn_import_t, dyn_export_t use dyn_comp, only: dyn_run use dyn_grid, only: TimeLevel +#ifdef scam + use advect_tend, only: compute_write_iop_fields +#endif use advect_tend, only: compute_adv_tends_xyz - !SE dycore: - use time_mod, only: TimeLevel_Qdp + ! SE dycore: + use se_dyn_time_mod,only: TimeLevel_Qdp use control_mod, only: qsplit + use dimensions_mod, only: nelemd ! Dummy arguments real(r8), intent(in) :: dtime ! Time-step @@ -143,13 +248,26 @@ subroutine stepon_run3(dtime, cam_runtime_opts, cam_out, phys_state, dyn_in, dyn ! Local variables integer :: tl_f, tl_fQdp !-------------------------------------------------------------------------------------- - +#ifdef scam + if (single_column) then + ! Update IOP properties e.g. omega, divT, divQ + iop_update_phase1 = .false. + if (doiopupdate) then + if (masterproc) call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) + call iop_broadcast() + call scm_setfield(dyn_out%elem,iop_update_phase1) + endif + endif +#endif ! Determine appropriate time values and ! initalize advected constituent mixing ratios: call t_startf('comp_adv_tends1') tl_f = TimeLevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) call compute_adv_tends_xyz(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) +#ifdef scam + if (write_camiop) call compute_write_iop_fields(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) +#endif call t_stopf('comp_adv_tends1') ! Synchronize all PEs and then run dynamics (dyn_run): @@ -164,6 +282,9 @@ subroutine stepon_run3(dtime, cam_runtime_opts, cam_out, phys_state, dyn_in, dyn tl_f = TimeLevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) call compute_adv_tends_xyz(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) +#ifdef scam + if (write_camiop) call compute_write_iop_fields(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) +#endif call t_stopf('comp_adv_tends2') end subroutine stepon_run3 @@ -172,6 +293,13 @@ end subroutine stepon_run3 subroutine stepon_final(cam_runtime_opts, dyn_in, dyn_out) + use runtime_obj, only: runtime_options + + ! SE/CAM interface: + use dyn_comp, only: dyn_import_t, dyn_export_t + + ! SE dycore + ! Dummy arguments type(runtime_options), intent(in) :: cam_runtime_opts ! Runtime settings object type(dyn_import_t), intent(inout) :: dyn_in ! Dynamics import container @@ -182,23 +310,32 @@ end subroutine stepon_final !========================================================================================= subroutine diag_dynvar_ic(elem, fvm) - !use constituents, only: cnst_type, cnst_name - !use cam_history, only: write_inithist, outfld, hist_fld_active, fieldname_len - use dyn_grid, only: TimeLevel + + use shr_kind_mod, only: r8=>shr_kind_r8, cl=>shr_kind_cl + use cam_constituents, only: const_is_wet + use cam_constituents, only: const_diag_name + use cam_history, only: is_history_field_active, history_out_field + !use cam_history, only: write_inithist + use cam_history_support, only: fieldname_len use air_composition, only: thermodynamic_active_species_idx use air_composition, only: thermodynamic_active_species_idx_dycore use dyn_thermo, only: get_sum_species, get_ps, get_dp_ref use hycoef, only: hyai, hybi, ps0 use cam_abortutils, only: endrun, check_allocate - !SE dycore: - use time_mod, only: TimeLevel_Qdp ! dynamics typestep + ! SE/CAM interface: + use dyn_grid, only: TimeLevel + use dyn_comp, only: cnst_diag_name_gll, advected_constituent_index + + ! SE dycore: + use se_dyn_time_mod, only: TimeLevel_Qdp ! dynamics typestep use control_mod, only: qsplit use hybrid_mod, only: config_thread_region, get_loop_ranges use hybrid_mod, only: hybrid_t use dimensions_mod, only: np, npsq, nc, nhc, fv_nphys, qsize, ntrac, nlev - use dimensions_mod, only: cnst_name_gll + use dimensions_mod, only: nelemd use element_mod, only: element_t + use parallel_mod, only: par use fvm_control_volume_mod, only: fvm_struct use fvm_mapping, only: fvm2dyn @@ -210,7 +347,9 @@ subroutine diag_dynvar_ic(elem, fvm) integer :: ie, i, j, k, m, m_cnst, nq integer :: tl_f, tl_qdp integer :: iret - !character(len=fieldname_len) :: tfname !Uncomment once 'fieldname_len' or an equivalent is available -JN + character(len=cl) :: errmsg + + character(len=fieldname_len) :: tfname type(hybrid_t) :: hybrid integer :: nets, nete @@ -227,16 +366,14 @@ subroutine diag_dynvar_ic(elem, fvm) tl_f = timelevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_Qdp) - allocate(ftmp(npsq,nlev,2), stat=iret) + allocate(ftmp(npsq,nlev,2), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'ftmp(npsq,nlev,2)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) -!REMOVE ONCE TRACERS/CHEMISTRY IS ENABLED -JN: -#if 0 ! Output tracer fields for analysis of advection schemes do m_cnst = 1, qsize - tfname = trim(cnst_name_gll(m_cnst))//'_gll' - if (hist_fld_active(tfname)) then + tfname = trim(cnst_diag_name_gll(m_cnst))//'_gll' + if (is_history_field_active(tfname)) then do ie = 1, nelemd qtmp(:,:,:) = elem(ie)%state%Qdp(:,:,:,m_cnst,tl_qdp)/& elem(ie)%state%dp3d(:,:,:,tl_f) @@ -246,32 +383,26 @@ subroutine diag_dynvar_ic(elem, fvm) elem(ie)%state%dp3d(i,j,:,tl_f) end do end do - call outfld(tfname, ftmp(:,:,1), npsq, ie) + call history_out_field(tfname, ftmp(:,:,1)) end do end if end do do m_cnst = 1, qsize - tfname = trim(cnst_name_gll(m_cnst))//'dp_gll' - if (hist_fld_active(tfname)) then + tfname = trim(cnst_diag_name_gll(m_cnst))//'dp_gll' + if (is_history_field_active(tfname)) then do ie = 1, nelemd do j = 1, np do i = 1, np ftmp(i+(j-1)*np,:,1) = elem(ie)%state%Qdp(i,j,:,m_cnst,tl_qdp) end do end do - call outfld(tfname, ftmp(:,:,1), npsq, ie) + call history_out_field(tfname, ftmp(:,:,1)) end do end if end do -!REMOVE ONCE TRACERS/CHEMISTRY IS ENABLED -JN: -#endif - -!Remove once "outfld" is enabled in CAMDEN -JN: -#if 0 - - if (hist_fld_active('U_gll') .or. hist_fld_active('V_gll')) then + if (is_history_field_active('U_gll') .or. is_history_field_active('V_gll')) then do ie = 1, nelemd do j = 1, np do i = 1, np @@ -279,23 +410,23 @@ subroutine diag_dynvar_ic(elem, fvm) ftmp(i+(j-1)*np,:,2) = elem(ie)%state%v(i,j,2,:,tl_f) end do end do - call outfld('U_gll', ftmp(:,:,1), npsq, ie) - call outfld('V_gll', ftmp(:,:,2), npsq, ie) + call history_out_field('U_gll', ftmp(:,:,1)) + call history_out_field('V_gll', ftmp(:,:,2)) end do end if - if (hist_fld_active('T_gll')) then + if (is_history_field_active('T_gll')) then do ie = 1, nelemd do j = 1, np do i = 1, np ftmp(i+(j-1)*np,:,1) = elem(ie)%state%T(i,j,:,tl_f) end do end do - call outfld('T_gll', ftmp(:,:,1), npsq, ie) + call history_out_field('T_gll', ftmp(:,:,1)) end do end if - if (hist_fld_active('dp_ref_gll')) then + if (is_history_field_active('dp_ref_gll')) then do ie = 1, nelemd call get_dp_ref(hyai,hybi,ps0,elem(ie)%state%phis(:,:),dp_ref(:,:,:),ps_ref(:,:)) do j = 1, np @@ -303,25 +434,25 @@ subroutine diag_dynvar_ic(elem, fvm) ftmp(i+(j-1)*np,:,1) = elem(ie)%state%dp3d(i,j,:,tl_f)/dp_ref(i,j,:) end do end do - call outfld('dp_ref_gll', ftmp(:,:,1), npsq, ie) + call history_out_field('dp_ref_gll', ftmp(:,:,1)) end do end if - if (hist_fld_active('PSDRY_gll')) then + if (is_history_field_active('PSDRY_gll')) then do ie = 1, nelemd do j = 1, np do i = 1, np ftmp(i+(j-1)*np,1,1) = elem(ie)%state%psdry(i,j) end do end do - call outfld('PSDRY_gll', ftmp(:,1,1), npsq, ie) + call history_out_field('PSDRY_gll', ftmp(:,1,1)) end do end if - if (hist_fld_active('PS_gll')) then - allocate(fld_2d(np,np), stat=iret) + if (is_history_field_active('PS_gll')) then + allocate(fld_2d(np,np), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'fld_2d(np, np)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemd call get_ps(elem(ie)%state%Qdp(:,:,:,:,tl_Qdp),& @@ -331,25 +462,23 @@ subroutine diag_dynvar_ic(elem, fvm) ftmp(i+(j-1)*np,1,1) = fld_2d(i,j) end do end do - call outfld('PS_gll', ftmp(:,1,1), npsq, ie) + call history_out_field('PS_gll', ftmp(:,1,1)) + end do deallocate(fld_2d) end if - if (hist_fld_active('PHIS_gll')) then + if (is_history_field_active('PHIS_gll')) then do ie = 1, nelemd - call outfld('PHIS_gll', RESHAPE(elem(ie)%state%phis, (/np*np/)), np*np, ie) + call history_out_field('PHIS_gll', RESHAPE(elem(ie)%state%phis, (/np*np/))) end do end if -!Remove once history output is available in CAMDEN -JN: -#endif - - !if (write_inithist()) then !Un-comment once history output is available -JN - if (.false.) then !Remove once history output is available -JN - allocate(fld_2d(np,np), stat=iret) + !if (write_inithist()) then !Un-comment once IC file writing is available -JN + if (.false.) then + allocate(fld_2d(np,np), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'fld_2d(np, np)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) do ie = 1, nelemd call get_ps(elem(ie)%state%Qdp(:,:,:,:,tl_Qdp),& @@ -359,42 +488,38 @@ subroutine diag_dynvar_ic(elem, fvm) ftmp(i+(j-1)*np,1,1) = fld_2d(i,j) end do end do -! call outfld('PS&IC', ftmp(:,1,1), npsq, ie) + call history_out_field('PS&IC', ftmp(:,1,1)) end do deallocate(fld_2d) if (fv_nphys < 1) then - allocate(factor_array(np,np,nlev), stat=iret) + allocate(factor_array(np,np,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'factor_array(np,np,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) end if do ie = 1, nelemd - !Un-comment once history output is available -JN: - !call outfld('T&IC', RESHAPE(elem(ie)%state%T(:,:,:,tl_f), (/npsq,nlev/)), npsq, ie) - !call outfld('U&IC', RESHAPE(elem(ie)%state%v(:,:,1,:,tl_f), (/npsq,nlev/)), npsq, ie) - !call outfld('V&IC', RESHAPE(elem(ie)%state%v(:,:,2,:,tl_f), (/npsq,nlev/)), npsq, ie) + call history_out_field('T&IC', RESHAPE(elem(ie)%state%T(:,:,:,tl_f), (/npsq,nlev/))) + call history_out_field('U&IC', RESHAPE(elem(ie)%state%v(:,:,1,:,tl_f), (/npsq,nlev/))) + call history_out_field('V&IC', RESHAPE(elem(ie)%state%v(:,:,2,:,tl_f), (/npsq,nlev/))) -!REMOVE ONCE TRACERS/CHEMISTRY IS ENABLED -JN: -#if 0 if (fv_nphys < 1) then call get_sum_species(elem(ie)%state%Qdp(:,:,:,:,tl_qdp), & thermodynamic_active_species_idx_dycore, factor_array,dp_dry=elem(ie)%state%dp3d(:,:,:,tl_f)) factor_array(:,:,:) = 1.0_r8/factor_array(:,:,:) do m_cnst = 1, qsize - if (cnst_type(m_cnst) == 'wet') then - call outfld(trim(cnst_name(m_cnst))//'&IC', & + if (const_is_wet(advected_constituent_index(m_cnst))) then + call history_out_field(trim(const_diag_name(m_cnst))//'&IC', & RESHAPE(factor_array(:,:,:)*elem(ie)%state%Qdp(:,:,:,m_cnst,tl_qdp)/& - elem(ie)%state%dp3d(:,:,:,tl_f), (/npsq,nlev/)), npsq, ie) + elem(ie)%state%dp3d(:,:,:,tl_f), (/npsq,nlev/))) else - call outfld(trim(cnst_name(m_cnst))//'&IC', & + call history_out_field(trim(const_diag_name(m_cnst))//'&IC', & RESHAPE(elem(ie)%state%Qdp(:,:,:,m_cnst,tl_qdp)/& - elem(ie)%state%dp3d(:,:,:,tl_f), (/npsq,nlev/)), npsq, ie) + elem(ie)%state%dp3d(:,:,:,tl_f), (/npsq,nlev/))) end if end do end if -!REMOVE ONCE TRACERS/CHEMISTRY IS ENABLED -JN: -#endif + end do if (fv_nphys > 0) then @@ -403,34 +528,31 @@ subroutine diag_dynvar_ic(elem, fvm) hybrid = config_thread_region(par,'serial') call get_loop_ranges(hybrid, ibeg=nets, iend=nete) - allocate(fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,ntrac,nets:nete), stat=iret) + allocate(fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,ntrac,nets:nete), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,ntrac,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(fld_gll(np,np,nlev,ntrac,nets:nete), stat=iret) + allocate(fld_gll(np,np,nlev,ntrac,nets:nete), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, & 'fld_gll(np,np,nlev,ntrac,nets:nete)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(llimiter(ntrac), stat=iret) + allocate(llimiter(ntrac), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'llimiter(ntrac)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) - allocate(factor_array(nc,nc,nlev), stat=iret) + allocate(factor_array(nc,nc,nlev), stat=iret, errmsg=errmsg) call check_allocate(iret, subname, 'factor_array(nc,nc,nlev)', & - file=__FILE__, line=__LINE__) + file=__FILE__, line=__LINE__, errmsg=errmsg) llimiter = .true. -!REMOVE ONCE TRACERS/CHEMISTRY IS ENABLED -JN: -#if 0 - do ie = nets, nete call get_sum_species(fvm(ie)%c(1:nc,1:nc,:,:),thermodynamic_active_species_idx,factor_array) factor_array(:,:,:) = 1.0_r8/factor_array(:,:,:) do m_cnst = 1, ntrac - if (cnst_type(m_cnst) == 'wet') then + if (const_is_wet(advected_constituent_index(m_cnst))) then fld_fvm(1:nc,1:nc,:,m_cnst,ie) = fvm(ie)%c(1:nc,1:nc,:,m_cnst)*factor_array(:,:,:) else fld_fvm(1:nc,1:nc,:,m_cnst,ie) = fvm(ie)%c(1:nc,1:nc,:,m_cnst) @@ -442,14 +564,11 @@ subroutine diag_dynvar_ic(elem, fvm) do ie = nets, nete do m_cnst = 1, ntrac - call outfld(trim(cnst_name(m_cnst))//'&IC', & - RESHAPE(fld_gll(:,:,:,m_cnst,ie), (/npsq,nlev/)), npsq, ie) + call history_out_field(trim(const_diag_name(m_cnst))//'&IC', & + RESHAPE(fld_gll(:,:,:,m_cnst,ie), (/npsq,nlev/))) end do end do -!REMOVE ONCE TRACERS/CHEMISTRY IS ENABLED -JN: -#endif - deallocate(fld_fvm) deallocate(fld_gll) deallocate(llimiter) diff --git a/src/dynamics/se/test_fvm_mapping.F90 b/src/dynamics/se/test_fvm_mapping.F90 deleted file mode 100644 index 1fada43a4..000000000 --- a/src/dynamics/se/test_fvm_mapping.F90 +++ /dev/null @@ -1,851 +0,0 @@ -module test_fvm_mapping - use shr_kind_mod, only: r8=>shr_kind_r8 -! use cam_history, only: outfld - use dynconst, only: pi - - !SE dycore: - use fvm_control_volume_mod, only: fvm_struct - use dimensions_mod, only: np, nelemd, nlev, npsq, ntrac - use element_mod, only: element_t - implicit none - private - - real(r8), parameter, private :: deg2rad = pi/180.0_r8 - real(r8), parameter, private :: psurf_moist = 100000.0_r8 !moist surface pressure - integer, parameter, private :: cl_idx = 12 - integer, parameter, private :: cl2_idx = 13 - real(r8), parameter, private :: cly_constant = 4.e-6_r8 - integer, parameter, private :: num_fnc = 26 - integer, parameter, private :: offset = 15 - - public :: test_mapping_overwrite_tendencies, test_mapping_addfld - public :: test_mapping_output_mapped_tendencies, test_mapping_overwrite_dyn_state - public :: test_mapping_output_phys_state -contains - - subroutine test_mapping_addfld - -#ifdef debug_coupling - use cam_history, only: addfld, add_default, horiz_only, register_vector_field - use cam_constituents, only: const_name - character(LEN=128) :: name - integer :: nq,m_cnst - - name = 'd2p_u_gll' - call addfld(trim(name), (/ 'lev' /), 'I','m/2','Exact zonal wind on GLL grid',gridname='GLL') - !call add_default (trim(name), 1, ' ') - - name = 'd2p_v_gll' - call addfld(trim(name), (/ 'lev' /), 'I','m/2','Exact meridional wind on GLL grid',gridname='GLL') - !call add_default (trim(name), 1, ' ') - - name = 'd2p_scalar_gll' - call addfld(trim(name), (/ 'lev' /), 'I','','Exact scalar on GLL grid',gridname='GLL') - !call add_default (trim(name), 1, ' ') - - name = 'd2p_u' - call addfld(trim(name), (/ 'lev' /), 'I','m/2','Zonal wind mapped to physics grid') - !call add_default (trim(name), 1, ' ') - - name = 'd2p_u_err' - call addfld(trim(name), (/ 'lev' /), 'I','m/2','Error in zonal wind mapped to physics grid') - !call add_default (trim(name), 1, ' ') - - name = 'd2p_v_err' - call addfld(trim(name), (/ 'lev' /), 'I','m/2','Error in meridional wind mapped to physics grid') - !call add_default (trim(name), 1, ' ') - - name = 'd2p_v' - call addfld(trim(name), (/ 'lev' /), 'I','m/s','Meridional wind mapped to physics grid') - !call add_default (trim(name), 1, ' ') - - name = 'd2p_scalar' - call addfld(trim(name), (/ 'lev' /), 'I','','Scalar mapped to physics grid') - call add_default (trim(name), 1, ' ') - - name = 'd2p_scalar_err' - call addfld(trim(name), (/ 'lev' /), 'I','','Error in scalar mapped to physics grid') - call add_default (trim(name), 1, ' ') - - do nq=ntrac,ntrac - m_cnst = nq - name = 'f2p_'//trim(const_name(m_cnst))//'_fvm' - call addfld(trim(name), (/ 'lev' /), 'I','','Exact water tracer on fvm grid',gridname='FVM') - call add_default (trim(name), 1, ' ') - name = 'f2p_'//trim(const_name(m_cnst))//'_err' - call addfld(trim(name), (/ 'lev' /), 'I','','Error in water tracer on physics grid (mapped from fvm grid)') - call add_default (trim(name), 1, ' ') - name = 'f2p_'//trim(const_name(m_cnst))//'' - call addfld(trim(name), (/ 'lev' /), 'I','','Water tracer on physics grid (mapped from fvm grid') - call add_default (trim(name), 1, ' ') - ! - ! physgrid to gll (condensate loading tracers) - ! - name = 'p2d_'//trim(const_name(m_cnst))//'' - call addfld(trim(name), (/ 'lev' /), 'I','','Water tracer on physics grid') - !call add_default (trim(name), 1, ' ') - name = 'p2d_'//trim(const_name(m_cnst))//'_gll' - call addfld(trim(name), (/ 'lev' /), 'I','','Water tracer on GLL grid',gridname='GLL') - !call add_default (trim(name), 1, ' ') - name = 'p2d_'//trim(const_name(m_cnst))//'_err_gll' - call addfld(trim(name), (/ 'lev' /), 'I','','Error in water tracer mapped to GLL grid',gridname='GLL') - !call add_default (trim(name), 1, ' ') - ! - ! physgrid to fvm (condensate loading tracers) - ! - name = 'p2f_'//trim(const_name(m_cnst))//'' - call addfld(trim(name), (/ 'lev' /), 'I','','Water tracer on physics grid') - call add_default (trim(name), 1, ' ') - name = 'p2f_'//trim(const_name(m_cnst))//'_fvm' - call addfld(trim(name), (/ 'lev' /), 'I','','Water tracer on FVM grid',gridname='FVM') - call add_default (trim(name), 1, ' ') - name = 'p2f_'//trim(const_name(m_cnst))//'_err_fvm' - call addfld(trim(name), (/ 'lev' /), 'I','','Error in water tracer mapped to FVM grid',gridname='FVM') - call add_default (trim(name), 1, ' ') - end do - ! - ! temperature tendency - ! - name = 'p2d_ptend' - call addfld(trim(name), (/ 'lev' /), 'I','','T tendency on physics grid') - !call add_default (trim(name), 1, ' ') - name = 'p2d_ptend_gll' - call addfld(trim(name), (/ 'lev' /), 'I','','T tendency on GLL grid',gridname='GLL') - !call add_default (trim(name), 1, ' ') - name = 'p2d_ptend_err_gll' - call addfld(trim(name), (/ 'lev' /), 'I','','Error in T tendency mapped to GLL grid',gridname='GLL') - !call add_default (trim(name), 1, ' ') - - call addfld('p2d_u', (/ 'lev' /), 'I','m/2','Zonal wind on physics grid') - !call add_default ('p2d_u', 1, ' ') - call addfld('p2d_v', (/ 'lev' /), 'I','m/2','Meridional wind on physics grid') - !call add_default ('p2d_v', 1, ' ') - call addfld('p2d_u_gll', (/ 'lev' /), 'I','m/2','Zonal wind on physics grid',gridname='GLL') - !call add_default ('p2d_u_gll', 1, ' ') - call addfld('p2d_v_gll', (/ 'lev' /), 'I','m/2','Meridional wind on physics grid',gridname='GLL') - !call add_default ('p2d_v_gll', 1, ' ') - call addfld('p2d_u_gll_err', (/ 'lev' /), 'I','m/2','Error in zonal wind interpolation to GLL grid',gridname='GLL') - !call add_default ('p2d_u_gll_err', 1, ' ') - call addfld('p2d_v_gll_err', (/ 'lev' /), 'I','m/2','Error in meridional wind interpolation to GLL grid',& - gridname='GLL') - !call add_default ('p2d_v_gll_err', 1, ' ') - -! name = 'phys2dyn_'//trim(const_name(m_cnst))//'_physgrid' -! call outfld(trim(name),phys_state%q(:ncols,:,m_cnst),ncols,lchnk) -#endif - end subroutine test_mapping_addfld - - subroutine test_mapping_overwrite_tendencies(phys_state,phys_tend,ncols,q_prev,fvm) - use cam_constituents, only: const_name - use physics_types, only: physics_state, physics_tend - - !SE dycore: - use dimensions_mod, only: fv_nphys - - type(physics_state), intent(inout) :: phys_state - type(physics_tend), intent(inout) :: phys_tend - real(r8), dimension(:,:,:), intent(inout) :: q_prev - type(fvm_struct), intent(inout):: fvm(:) - integer, intent(in) :: ncols -#ifdef debug_coupling - integer :: icol,k - character(LEN=128) :: name - integer :: m_cnst, nq, ie - - q_prev(:,:,ntrac) = 0.0_r8 - do ie=1,nelemd -!xxx fvm(ie)%c(:,:,:,ntrac) = 0.0_r8 - end do - - phys_state%pdel(1:ncols,:) = phys_state%pdeldry(1:ncols,:) !make sure there is no conversion from wet to dry - do nq=ntrac,ntrac - m_cnst = nq - do icol=1,ncols - do k=1,num_fnc - phys_state%q(icol,k,m_cnst) = test_func(phys_state%lat(icol), phys_state%lon(icol), k, k) - end do - enddo - name = 'p2f_'//trim(const_name(m_cnst))//'' - call outfld(trim(name),phys_state%q(:ncols,:,m_cnst),ncols,lchnk) - name = 'p2d_'//trim(const_name(m_cnst))//'' - call outfld(trim(name),phys_state%q(:ncols,:,m_cnst),ncols,lchnk) - end do - - do icol=1,ncols - do k=ntrac,ntrac - phys_tend%dudt_total(icol,k) = test_func(phys_state%lat(icol), phys_state%lon(icol), k, k) - phys_tend%dvdt_total(icol,k) = test_func(phys_state%lat(icol), phys_state%lon(icol), k, k) - phys_tend%dTdt_total(icol,k) = test_func(phys_state%lat(icol), phys_state%lon(icol), k, k) - end do - enddo - name = 'p2d_u' - call outfld(trim(name),phys_tend%dudt_total(:ncols,:),ncols,lchnk) - name = 'p2d_v' - call outfld(trim(name),phys_tend%dvdt_total(:ncols,:),ncols,lchnk) - name = 'p2d_ptend' - call outfld(trim(name),phys_tend%dtdt_total(:ncols,:),ncols,lchnk) - - - do icol=1,ncols - do k=1,nlev -! phys_tend%dudt(icol,k) = 0.0_r8 -! phys_tend%dvdt(icol,k) = 0.0_r8 -! phys_tend%dtdt(icol,k) = 0.0_r8 - end do - enddo -#endif - end subroutine test_mapping_overwrite_tendencies - - subroutine test_mapping_output_mapped_tendencies(fvm,elem,nets,nete,tl_f,tl_qdp) - use cam_constituents, only: const_name - - !SE dycore: - use dimensions_mod, only: fv_nphys,nlev,nc - - integer, intent(in) :: nets,nete,tl_f,tl_qdp - type(fvm_struct), intent(inout):: fvm(nets:nete) - type(element_t), intent(inout):: elem(nets:nete) ! pointer to dyn_out element array -#ifdef debug_coupling - integer :: ie,i,j,k - character(LEN=128) :: name - integer :: nq,m_cnst - real(r8) :: diff(nc,nc,nlev,ntrac) - diff = 0.0_r8 - do ie = nets,nete - call outfld('p2d_u_gll', RESHAPE(elem(ie)%derived%fm(:,:,1,:),(/npsq,nlev/)), npsq, ie) - call outfld('p2d_v_gll', RESHAPE(elem(ie)%derived%fm(:,:,2,:),(/npsq,nlev/)), npsq, ie) - call outfld('p2d_ptend_gll', RESHAPE(elem(ie)%derived%ft(:,:,:),(/npsq,nlev/)), npsq, ie) - do k=ntrac,ntrac - do j=1,np - do i=1,np - elem(ie)%derived%fm(i,j,1,k) = elem(ie)%derived%fm(i,j,1,k) -& - test_func(elem(ie)%spherep(i,j)%lat, elem(ie)%spherep(i,j)%lon, k,k) - elem(ie)%derived%fm(i,j,2,k) = elem(ie)%derived%fm(i,j,2,k) - & - test_func(elem(ie)%spherep(i,j)%lat, elem(ie)%spherep(i,j)%lon, k,k) - elem(ie)%derived%ft(i,j,k) = elem(ie)%derived%ft(i,j,k) - & - test_func(elem(ie)%spherep(i,j)%lat, elem(ie)%spherep(i,j)%lon, k,k) - end do - end do - end do - call outfld('p2d_u_gll_err' , RESHAPE(elem(ie)%derived%fm(:,:,1,:),(/npsq,nlev/)), npsq, ie) - call outfld('p2d_v_gll_err' , RESHAPE(elem(ie)%derived%fm(:,:,2,:),(/npsq,nlev/)), npsq, ie) - call outfld('p2d_ptend_err_gll', RESHAPE(elem(ie)%derived%ft(:,:,:),(/npsq,nlev/)), npsq, ie) - elem(ie)%derived%ft(:,:,:) = 0.0_r8 - end do - - do ie = nets,nete - do nq=ntrac,ntrac - m_cnst = nq - name = 'p2d_'//trim(const_name(m_cnst))//'_gll' - call outfld(TRIM(name), RESHAPE(elem(ie)%derived%fq(:,:,:,nq),(/npsq,nlev/)), npsq, ie) - ! call outfld(trim(name),& - ! RESHAPE(fvm(ie)%fc(1:nc,1:nc,:,m_cnst),& - ! (/nc*nc,nlev/)),nc*nc,ie) - do k=1,num_fnc - do j=1,np - do i=1,np - elem(ie)%derived%fq(i,j,k,nq) = elem(ie)%derived%fq(i,j,k,nq)-& - test_func(elem(ie)%spherep(i,j)%lat, elem(ie)%spherep(i,j)%lon, k, k) - end do - end do - end do - name = 'p2d_'//trim(const_name(m_cnst))//'_err_gll' - call outfld(TRIM(name), RESHAPE(elem(ie)%derived%fq(:,:,:,nq),(/npsq,nlev/)), npsq, ie) - end do - if (ntrac>0) then - do nq=ntrac,ntrac - m_cnst = nq - name = 'p2f_'//trim(const_name(m_cnst))//'_fvm' - ! - ! cly - ! -! k=num_tracer+1 -! fvm(ie)%fc(1:nc,1:nc,k,:) = fvm(ie)%fc(1:nc,1:nc,cl_idx,:)+& -! 2.0_r8*fvm(ie)%fc(1:nc,1:nc,cl2_idx,:) - call outfld(trim(name),& - RESHAPE(fvm(ie)%fc(1:nc,1:nc,:,m_cnst)/fvm(ie)%dp_fvm(1:nc,1:nc,:),& - (/nc*nc,nlev/)),nc*nc,ie) - do k=1,num_fnc - do j=1,nc - do i=1,nc - diff(i,j,k,m_cnst) = fvm(ie)%fc(i,j,k,m_cnst)/fvm(ie)%dp_fvm(i,j,k)-& - test_func(fvm(ie)%center_cart(i,j)%lat,fvm(ie)%center_cart(i,j)%lon, k, k) - end do - end do - end do - name = 'p2f_'//trim(const_name(m_cnst))//'_err_fvm' - call outfld(TRIM(name), RESHAPE(diff(:,:,:,m_cnst),(/nc*nc,nlev/)), nc*nc, ie) - - end do - endif - end do -#endif - end subroutine test_mapping_output_mapped_tendencies - - subroutine test_mapping_overwrite_dyn_state(elem,fvm) - use cam_constituents, only: const_name - - !SE dycore: - use fvm_control_volume_mod, only: fvm_struct - use dimensions_mod, only: nc,nhc - use hybrid_mod, only: get_loop_ranges, hybrid_t,config_thread_region - use control_mod, only: north, south, east, west, neast, nwest, seast, swest - use fvm_mod, only: fill_halo_fvm,ghostBufQnhc_h - use parallel_mod, only: par - - type (fvm_struct), intent(inout) :: fvm(:) - type(element_t), intent(inout) :: elem(:) ! pointer to dyn_out element array -#ifdef debug_coupling - integer :: i,j,k,ie,nq,m_cnst - character(LEN=128) :: name - integer :: nets,nete - type(hybrid_t) :: hybrid - - hybrid = config_thread_region(par,'serial') - call get_loop_ranges(hybrid,ibeg=nets,iend=nete) - do ie=nets,nete - do nq=ntrac,ntrac - m_cnst = nq - name = 'f2p_'//trim(const_name(m_cnst))//'_fvm' - do k=1,num_fnc - do j=1,nc - do i=1,nc - fvm(ie)%c(i,j,k,m_cnst) = test_func(fvm(ie)%center_cart(i,j)%lat,fvm(ie)%center_cart(i,j)%lon, k, k) - end do - end do - end do - ! - ! cly - ! -! k=num_tracer+1 -! do j=1,nc -! do i=1,nc -! fvm(ie)%c(i,j,k,m_cnst) = test_func(fvm(ie)%center_cart(i,j)%lat,fvm(ie)%center_cart(i,j)%lon, k,cl_idx)+& -! 2.0_r8*test_func(fvm(ie)%center_cart(i,j)%lat,fvm(ie)%center_cart(i,j)%lon, k,cl2_idx) -! end do -! end do - call outfld(TRIM(name), RESHAPE(fvm(ie)%c(1:nc,1:nc,:,m_cnst),(/nc*nc,nlev/)), nc*nc, ie) - end do - - elem(ie)%state%Qdp(:,:,:,:,:) = 0.0_r8 !for testing the p2d map - do k=1,num_fnc - do j=1,np - do i=1,np - elem(ie)%state%v(i,j,1,k,:) = test_func(elem(ie)%spherep(i,j)%lat, elem(ie)%spherep(i,j)%lon, k, k ) - elem(ie)%state%v(i,j,2,k,:) = test_func(elem(ie)%spherep(i,j)%lat, elem(ie)%spherep(i,j)%lon, k, k) - end do - end do - end do - do k=1,num_fnc - do j=1,np - do i=1,np - elem(ie)%derived%omega(i,j,k) = test_func(elem(ie)%spherep(i,j)%lat, elem(ie)%spherep(i,j)%lon, k, k) - end do - end do - end do - call outfld('d2p_scalar_gll', RESHAPE(elem(ie)%derived%omega(:,:,:) ,(/npsq,nlev/)), npsq, ie) - call outfld('d2p_u_gll', RESHAPE(elem(ie)%state%v(:,:,1,:,1),(/npsq,nlev/)), npsq, ie) - call outfld('d2p_v_gll', RESHAPE(elem(ie)%state%v(:,:,2,:,1),(/npsq,nlev/)), npsq, ie) - end do - ! - ! do boundary exchange (this call should be indentical to call in prim_driver) - ! - call fill_halo_fvm(ghostBufQnhc_h,elem,fvm,hybrid,nets,nete,nhc,1,nlev,nlev) - do ie=nets,nete - if (fvm(ie)%cubeboundary>4) then - do k=ntrac,ntrac - select case(fvm(ie)%cubeboundary) - case (nwest) - fvm(ie)%c(0,nc+1,:,k) = fvm(ie)%c(1,nc+1,:,k) - case (swest) - fvm(ie)%c(0,0,:,k) = fvm(ie)%c(0,1,:,k) - case (seast) - fvm(ie)%c(nc+1,0,:,k) = fvm(ie)%c(0,nc,:,k) - case (neast) - fvm(ie)%c(nc+1,nc+1,:,k) = fvm(ie)%c(nc,nc+1,:,k) - end select - end do - end if - end do -! call fill_halo_fvm_noprealloc(elem,fvm,hybrid,nets,nete,nhc,1,nlev)!xxx nhr chould be a function of interp_method -#endif - end subroutine test_mapping_overwrite_dyn_state - - subroutine test_mapping_output_phys_state(phys_state,fvm) - use physics_types, only: physics_state -! use ppgrid, only: begchunk, endchunk, pver, pcols - use cam_constituents, only: const_name - - type(physics_state), intent(inout) :: phys_state - type(fvm_struct), pointer:: fvm(:) -#ifdef debug_coupling - integer :: lchnk, ncol,k,icol,m_cnst,nq,ie - character(LEN=128) :: name - - do ie=1,nelemd -!xxx fvm(ie)%c(:,:,:,ntrac) = 0.0_r8 - end do - - do lchnk = begchunk, endchunk - call outfld('d2p_scalar', phys_state(lchnk)%omega(1:pcols,1:pver), pcols, lchnk) - call outfld('d2p_u', phys_state(lchnk)%U(1:pcols,1:pver), pcols, lchnk) - call outfld('d2p_v', phys_state(lchnk)%V(1:pcols,1:pver), pcols, lchnk) - if (ntrac>0) then - do nq=ntrac,ntrac - m_cnst = nq - name = 'f2p_'//trim(const_name(m_cnst)) - ! - ! cly - ! - !phys_state(lchnk)%q(1:pcols,num_tracer+1,m_cnst)=phys_state(lchnk)%q(1:pcols,cl_idx,m_cnst)+& - ! 2.0_r8*phys_state(lchnk)%q(1:pcols,12,m_cnst) - call outfld(TRIM(name), phys_state(lchnk)%q(1:pcols,1:pver,m_cnst), pcols, lchnk) -! k=num_tracer+1 -! do icol=1,phys_state(lchnk)%ncol -! phys_state(lchnk)%q(icol,k,m_cnst) = phys_state(lchnk)%q(icol,cl_idx,m_cnst)+& -! 2.0_r8*phys_state(lchnk)%q(icol,cl2_idx,m_cnst)-& -! cly_constant -! end do - do k=1,num_fnc - do icol=1,phys_state(lchnk)%ncol - phys_state(lchnk)%q(icol,k,m_cnst) = phys_state(lchnk)%q(icol,k,m_cnst)& - -test_func(phys_state(lchnk)%lat(icol), phys_state(lchnk)%lon(icol), k,k) - end do - enddo - name = 'f2p_'//trim(const_name(m_cnst))//'_err' - call outfld(TRIM(name), phys_state(lchnk)%q(1:pcols,1:pver,m_cnst), pcols, lchnk) - phys_state(lchnk)%q(1:pcols,1:pver,m_cnst) = 0.0_r8 - end do - end if - end do - - - do lchnk = begchunk, endchunk - do k=1,nlev - do icol=1,phys_state(lchnk)%ncol - phys_state(lchnk)%U(icol,k) = phys_state(lchnk)%U(icol,k)& - -test_func(phys_state(lchnk)%lat(icol), phys_state(lchnk)%lon(icol), k, 9) - phys_state(lchnk)%V(icol,k) = phys_state(lchnk)%V(icol,k)& - -test_func(phys_state(lchnk)%lat(icol), phys_state(lchnk)%lon(icol), k,10) - end do - enddo - name = 'd2p_u_err' - call outfld(trim(name),phys_state(lchnk)%U(:pcols,:),pcols,lchnk) - name = 'd2p_v_err' - call outfld(trim(name),phys_state(lchnk)%V(:pcols,:),pcols,lchnk) - do k=1,num_fnc - do icol=1,phys_state(lchnk)%ncol - phys_state(lchnk)%omega(icol,k) = phys_state(lchnk)%omega(icol,k)& - -test_func(phys_state(lchnk)%lat(icol), phys_state(lchnk)%lon(icol), k,k) - end do - end do - name = 'd2p_scalar_err' - call outfld(trim(name),phys_state(lchnk)%omega(:pcols,:),pcols,lchnk) - end do -#endif - end subroutine test_mapping_output_phys_state - -#ifdef debug_coupling - function test_func(lat_in, lon_in, k, funcnum) result(fout) - use hycoef, only: hyai, hybi, hyam, hybm, ps0 - use shr_sys_mod, only: shr_sys_flush - use cam_abortutils, only: endrun - real(r8), intent(in) :: lon_in - real(r8), intent(in) :: lat_in - integer, intent(in) :: k - integer, intent(in) :: funcnum - real(r8) :: fout - real(r8) :: lon1,lat1,R0,Rg1,Rg2,lon2,lat2,cl,cl2 - real(r8) :: eta_c - - real(r8) :: radius = 10.0_r8 ! radius of the perturbation - real(r8) :: perturb_lon = 20.0_r8 ! longitudinal position, 20E - real(r8) :: perturb_lat = 40.0_r8 ! latitudinal position, 40N - real(r8) :: cos_tmp, sin_tmp, eta - real(r8) :: u_wind, v_wind, lat, lon, u_tmp, v_tmp - real(r8) :: rotation_angle - real(r8) :: det,r,k1,k2 - real(r8), parameter :: pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164_r8 - real(r8), parameter :: half_pi = pi*0.5_r8 - real(r8), parameter :: degrees_to_radians = pi/180.0_r8 - real(r8), parameter :: k1_lat_center = 20.d0*degrees_to_radians - real(r8), parameter :: k1_lon_center = 300.d0*degrees_to_radians - - lon = lon_in - lat = lat_in - - - select case(MOD(funcnum,8)+1) - case(1) - ! - ! Non-smooth scalar field (slotted cylinder) - ! - R0 = 0.5_r8 - lon1 = 5.0_r8 * PI / 6.0_r8 - lat1 = 0.0_r8 - Rg1 = acos(sin(lat1)*sin(lat)+cos(lat1)*cos(lat)*cos(lon-lon1)) - lon2 = 7.0_r8 * PI / 6.0_r8 - lat2 = 0.0_r8 - Rg2 = acos(sin(lat2)*sin(lat)+cos(lat2)*cos(lat)*cos(lon-lon2)) - - if ((Rg1 <= R0) .AND. (abs(lon-lon1) >= R0/6)) then - fout = 2.0_r8 - elseif ((Rg2 <= R0) .AND. (abs(lon-lon2) >= R0/6)) then - fout = 2.0_r8 - elseif ((Rg1 <= R0) .AND. (abs(lon-lon1) < R0/6) & - .AND. (lat-lat1 < -5.0_r8*R0/12.0_r8)) then - fout = 2.0_r8 - elseif ((Rg2 <= R0) .AND. (abs(lon-lon2) < R0/6) & - .AND. (lat-lat2 > 5.0_r8*R0/12.0_r8)) then - fout = 2.0_r8 - else - fout = 1.0_r8 - endif - case(2) - ! - ! Smooth Gaussian "ball" - ! - R0 = 10.0_r8 ! radius of the perturbation - lon1 = 20.0_r8*deg2rad ! longitudinal position, 20E - lat1 = 40.0_r8 *deg2rad ! latitudinal position, 40N - eta_c = 0.6_r8 - sin_tmp = SIN(lat1)*SIN(lat) - cos_tmp = COS(lat1)*COS(lat) - Rg1 = ACOS( sin_tmp + cos_tmp*COS(lon-lon1) ) ! great circle distance - eta = (hyam(k)*ps0 + hybm(k)*psurf_moist)/psurf_moist - fout = EXP(- ((Rg1*R0)**2 + ((eta-eta_c)/0.1_r8)**2)) - if (ABS(fout) < 1.0E-8_r8) then - fout = 0.0_r8 - end IF - case(3) - ! - ! - ! - fout = 0.5_r8 * ( tanh( 3.0_r8*abs(lat)-pi ) + 1.0_r8) - case(4) - fout = 2.0_r8+cos(5.0_r8+40*lon)!1.0e-8_r8 - fout = -0.5_r8-0.5_r8*(cos(16*lon)*(sin(2_r8*lat)**16)) - case(5) - ! - ! approximately Y^2_2 spherical harmonic - ! - fout = sin(lon)*cos(40*lat)!1.0e-8_r8 - fout = 0.5_r8*(cos(16*lon)*(sin(2_r8*lat)**16)) - case(6) - ! - ! approximately Y32_16 spherical harmonic - ! - fout = 0.5_r8 + 0.5_r8*(cos(16*lon)*(sin(2_r8*lat)**16)) - case(7) - fout = 2.0_r8 + lat - case(8) - fout = 2.0_r8 + cos(lon) - case(9) - rotation_angle = 45.0_r8*pi/180.0_r8 - CALL regrot(lon_in,lat_in,lon,lat,0.0_r8,-0.5_r8*pi+rotation_angle,1) - call Rossby_Haurwitz (lon, lat,u_wind, v_wind) - CALL turnwi(u_wind,v_wind,u_tmp,v_tmp,lon_in,lat_in,lon,lat,0.0_r8,-0.5_r8*pi+rotation_angle,-1) - fout = u_tmp - case(10) - rotation_angle = 45.0_r8*pi/180.0_r8 - CALL regrot(lon_in,lat_in,lon,lat,0.0_r8,-0.5_r8*pi+rotation_angle,1) - call Rossby_Haurwitz (lon, lat,u_wind, v_wind) - CALL turnwi(u_wind,v_wind,u_tmp,v_tmp,lon_in,lat_in,lon,lat,0.0_r8,-0.5_r8*pi+rotation_angle,-1) - fout = v_tmp - case(11) - fout = 1.0E-8_r8 - case(12) - ! - ! Terminator chemistry initial condition - ! - k1 = 1.0_r8*max(0.d0,sin(lat)*sin(k1_lat_center) + cos(lat)*cos(k1_lat_center)*cos(lon-k1_lon_center)) - k2 = 1._r8 - - r = k1 / (4._r8*k2) - det = sqrt(r*r + 2._r8*cly_constant*r) - - fout = (det-r) -! fout = cly_constant/2._r8 - (det-r)/2._r8 - case(13) - ! - ! Terminator chemistry initial condition - ! - k1 = 1.0_r8*max(0.d0,sin(lat)*sin(k1_lat_center) + cos(lat)*cos(k1_lat_center)*cos(lon-k1_lon_center)) - k2 = 1._r8 - - r = k1 / (4._r8*k2) - det = sqrt(r*r + 2._r8*cly_constant*r) - -! fout = (det-r) - fout = cly_constant/2._r8 - (det-r)/2._r8 - case default -! call endrun("Illegal funcnum_arg in test_func") - fout = 1.0_r8 - end select - end function test_func - - function test_wind(lat, lon, iwind) result(fout) - use cam_abortutils, only: endrun - real(r8), intent(in) :: lon - real(r8), intent(in) :: lat - integer, intent(in) :: iwind - - real(r8) :: fout - - - fout = 0 - end function test_wind - - - SUBROUTINE regrot(pxreg,pyreg,pxrot,pyrot,pxcen,pycen,kcall) -! -!---------------------------------------------------------------------- -! -!* conversion between regular and rotated spherical coordinates. -!* -!* pxreg longitudes of the regular coordinates -!* pyreg latitudes of the regular coordinates -!* pxrot longitudes of the rotated coordinates -!* pyrot latitudes of the rotated coordinates -!* all coordinates given in degrees n (negative for s) -!* and degrees e (negative values for w) -!* pxcen regular longitude of the south pole of the rotated grid -!* pycen regular latitude of the south pole of the rotated grid -!* -!* kcall=-1: find regular as functions of rotated coordinates. -!* kcall= 1: find rotated as functions of regular coordinates. -! -!----------------------------------------------------------------------- -! - integer kxdim,kydim,kx,ky,kcall - real(r8) :: pxreg,pyreg,& - pxrot,pyrot,& - pxcen,pycen -! -!----------------------------------------------------------------------- -! - real(r8) zsycen,zcycen,zxmxc,zsxmxc,zcxmxc,zsyreg,zcyreg, & - zsyrot,zcyrot,zcxrot,zsxrot,zpi,zpih - integer jy,jx - - zpih = pi*0.5_r8 -! - !---------------------------------------------------------------------- -! - zsycen = SIN((pycen+zpih)) - zcycen = COS((pycen+zpih)) -! - IF (kcall.eq.1) then -! - zxmxc = pxreg - pxcen - zsxmxc = SIN(zxmxc) - zcxmxc = COS(zxmxc) - zsyreg = SIN(pyreg) - zcyreg = COS(pyreg) - zsyrot = zcycen*zsyreg - zsycen*zcyreg*zcxmxc - zsyrot = max(zsyrot,-1.0_r8) - zsyrot = min(zsyrot,+1.0_r8) - ! - pyrot = ASIN(zsyrot) - ! - zcyrot = COS(pyrot) - zcxrot = (zcycen*zcyreg*zcxmxc +zsycen*zsyreg)/zcyrot - zcxrot = max(zcxrot,-1.0_r8) - zcxrot = min(zcxrot,+1.0_r8) - zsxrot = zcyreg*zsxmxc/zcyrot - ! - pxrot = ACOS(zcxrot) - ! - IF (zsxrot < 0.0_r8) then - pxrot = -pxrot - end IF - ! - ELSEIF (kcall.eq.-1) then - ! - zsxrot = SIN(pxrot) - zcxrot = COS(pxrot) - zsyrot = SIN(pyrot) - zcyrot = COS(pyrot) - zsyreg = zcycen*zsyrot + zsycen*zcyrot*zcxrot - zsyreg = max(zsyreg,-1.0_r8) - zsyreg = min(zsyreg,+1.0_r8) - ! - pyreg = ASIN(zsyreg) - ! - zcyreg = COS(pyreg) - zcxmxc = (zcycen*zcyrot*zcxrot -& - zsycen*zsyrot)/zcyreg - zcxmxc = max(zcxmxc,-1.0_r8) - zcxmxc = min(zcxmxc,+1.0_r8) - zsxmxc = zcyrot*zsxrot/zcyreg - zxmxc = ACOS(zcxmxc) - IF (zsxmxc < 0.0_r8) then - zxmxc = -zxmxc - end IF - ! - pxreg = zxmxc + pxcen - ! - ELSE - WRITE(6,'(1x,''invalid kcall in regrot'')') - STOP - ENDIF - END SUBROUTINE regrot - - SUBROUTINE turnwi(puarg,pvarg,pures,pvres,pxreg,pyreg,pxrot,pyrot,pxcen,pycen,kcall) - ! - !----------------------------------------------------------------------- - ! - !* turn horizontal velocity components between regular and - !* rotated spherical coordinates. - ! - !* puarg : input u components - !* pvarg : input v components - !* pures : output u components - !* pvres : output v components - !* pa : transformation coefficients - !* pb : -"- - !* pc : -"- - !* pd : -"- - !* pxreg : regular longitudes - !* pyreg : regular latitudes - !* pxrot : rotated longitudes - !* pyrot : rotated latitudes - !* kxdim : dimension in the x (longitude) direction - !* kydim : dimension in the y (latitude) direction - !* kx : number of gridpoints in the x direction - !* ky : number of gridpoints in the y direction - !* pxcen : regular longitude of the south pole of the - !* transformed grid - !* pycen : regular latitude of the south pole of the - !* transformed grid - !* - !* kcall < 0 : find wind components in regular coordinates - !* from wind components in rotated coordinates - !* kcall > 0 : find wind components in rotated coordinates - !* from wind components in regular coordinates - !* note that all coordinates are given in degrees n and degrees e. - !* (negative values for s and w) - ! - !----------------------------------------------------------------------- - - integer kxdim,kydim,kx,ky,kcall - real(r8) puarg,pvarg, & - pures,pvres, & - pa, pb, & - pc, pd, & - pxreg,pyreg, & - pxrot,pyrot - real(r8) pxcen,pycen - ! - !----------------------------------------------------------------------- - ! - integer jy,jx - real(r8) zpih,zsyc,zcyc,zsxreg,zcxreg,zsyreg,zcyreg,zxmxc,& - zsxmxc,zcxmxc,zsxrot,zcxrot,zsyrot,zcyrot - ! - !----------------------------------------------------------------------- - ! - IF (kcall.eq.1) then - zpih = pi*0.5_r8 - zsyc = SIN(pycen+zpih) - zcyc = COS(pycen+zpih) - ! - zsxreg = SIN(pxreg) - zcxreg = COS(pxreg) - zsyreg = SIN(pyreg) - zcyreg = COS(pyreg) - ! - zxmxc = pxreg - pxcen - zsxmxc = SIN(zxmxc) - zcxmxc = COS(zxmxc) - ! - zsxrot = SIN(pxrot) - zcxrot = COS(pxrot) - zsyrot = SIN(pyrot) - zcyrot = COS(pyrot) - ! - pa = zcyc*zsxmxc*zsxrot + zcxmxc*zcxrot - pb = zcyc*zcxmxc*zsyreg*zsxrot - zsyc*zcyreg*zsxrot - & - zsxmxc*zsyreg*zcxrot - pc = zsyc*zsxmxc/zcyrot - pd = (zsyc*zcxmxc*zsyreg + zcyc*zcyreg)/zcyrot - ! - pures = pa*puarg + pb*pvarg - pvres = pc*puarg + pd*pvarg - ELSEIF (kcall.eq.-1) then - zpih = pi*0.5_r8 - zsyc = SIN(pycen+zpih) - zcyc = COS(pycen+zpih) - ! - zsxreg = SIN(pxreg) - zcxreg = COS(pxreg) - zsyreg = SIN(pyreg) - zcyreg = COS(pyreg) - ! - zxmxc = pxreg - pxcen - zsxmxc = SIN(zxmxc) - zcxmxc = COS(zxmxc) - ! - zsxrot = SIN(pxrot) - zcxrot = COS(pxrot) - zsyrot = SIN(pyrot) - zcyrot = COS(pyrot) - ! - pa = zcxmxc*zcxrot + zcyc*zsxmxc*zsxrot - pb = zcyc*zsxmxc*zcxrot*zsyrot + zsyc*zsxmxc*zcyrot -& - zcxmxc*zsxrot*zsyrot - pc =-zsyc*zsxrot/zcyreg - pd = (zcyc*zcyrot - zsyc*zcxrot*zsyrot)/zcyreg - ! - pures = pa*puarg + pb*pvarg - pvres = pc*puarg + pd*pvarg - ELSE - write(6,'(1x,''invalid kcall in turnwi'')') - STOP - ENDIF - END SUBROUTINE turnwi - - SUBROUTINE Rossby_Haurwitz (lon, lat,u_wind, v_wind) - use dynconst, only: rearth -!----------------------------------------------------------------------- -! input parameters -!----------------------------------------------------------------------- - real(r8), intent(in) :: lon, & ! longitude in radians - lat ! latitude in radians - ! both coefficients 'a' and 'b' are needed at the full model level -!----------------------------------------------------------------------- -! input parameters -!----------------------------------------------------------------------- - real(r8), intent(out) :: u_wind, & ! zonal wind in m/s - v_wind ! meridional wind in m/s - -!----------------------------------------------------------------------- -! test case parameters -!----------------------------------------------------------------------- - real(r8),parameter :: u0 = 50._r8, & ! reference wind - n = 4._r8 ! wavenumber - -!----------------------------------------------------------------------- -! local -!----------------------------------------------------------------------- - real(r8) :: tmp1, tmp2, tmp3, KK, MM - real(r8) :: sin_lat, cos_lat, sin_slat, cos_slat - -!----------------------------------------------------------------------- -! initialize the wind components -!----------------------------------------------------------------------- - MM = u0/(n*rearth) ! parameter M - KK = u0/(n*rearth) ! parameter K - - - cos_lat = cos(lat) - sin_lat = sin(lat) - tmp1 = rearth * MM * cos_lat - tmp2 = rearth * KK * cos_lat**(n-1._r8)*(n*sin_lat**2 - cos_lat**2) - tmp3 = -rearth * KK * n * cos_lat**(n-1._r8) * sin_lat - u_wind = tmp1 + tmp2 * cos(n*lon) - v_wind = tmp3 * sin(n*lon) - end subroutine Rossby_Haurwitz - -#endif -end module test_fvm_mapping diff --git a/src/dynamics/utils/dynconst.F90 b/src/dynamics/utils/dynconst.F90 index 78c5b04c2..93c2d8636 100644 --- a/src/dynamics/utils/dynconst.F90 +++ b/src/dynamics/utils/dynconst.F90 @@ -45,6 +45,8 @@ module dynconst real(kind_dyn), protected, public :: lapse_rate ! R/Cp real(kind_dyn), protected, public :: cappa + ! Standard pressure [Pa] + real(kind_dyn), protected, public :: pstd !Public routines: @@ -72,6 +74,7 @@ subroutine dynconst_init use physconst, only: phys_cappa=>cappa use physconst, only: phys_rair=>rair use physconst, only: phys_rh2o=>rh2o + use physconst, only: phys_pstd=>pstd !Set constants used by the dynamics: @@ -86,7 +89,7 @@ subroutine dynconst_init tref = real(phys_tref, kind_dyn) lapse_rate = real(phys_lapse_rate, kind_dyn) cappa = real(phys_cappa, kind_dyn) - + pstd = real(phys_pstd, kind_dyn) end subroutine dynconst_init end module dynconst diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index a023b5574..316d9c15c 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -16,7 +16,6 @@ module cam_history implicit none private - save character(len=cl) :: model_doi_url = '' ! Model DOI character(len=cl) :: caseid = '' ! case ID @@ -24,7 +23,7 @@ module cam_history character(len=32) :: logname ! user name character(len=32) :: host ! host name - ! Functions + ! Core functions public :: history_readnl ! Namelist reader for CAM history public :: history_write_files ! Write files out public :: history_init_files ! Initialization @@ -32,6 +31,9 @@ module cam_history public :: history_out_field ! Accumulate field if its in use by one or more tapes public :: history_wrap_up ! Process history files at end of timestep or run + ! Helper functions + public :: is_history_field_active ! Check if a field is active on any history file + interface history_out_field module procedure history_out_field_1d module procedure history_out_field_2d @@ -433,7 +435,6 @@ subroutine history_add_field_1d(diagnostic_name, standard_name, vdim_name, & end if call history_add_field(diagnostic_name, standard_name, dimnames, avgflag, units, & gridname=gridname, flag_xyfill=flag_xyfill, fill_value=fill_value, mixing_ratio=mixing_ratio) - end subroutine history_add_field_1d !=========================================================================== @@ -601,7 +602,7 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla end do end if - field_ptr => possible_field_list_head + field_ptr => possible_field_list_head if (associated(field_ptr)) then ! Add to end of field list do @@ -676,7 +677,7 @@ subroutine history_out_field_1d(diagnostic_name, field_values) call endrun(errmsg) end if end if - + end do end subroutine history_out_field_1d @@ -775,7 +776,7 @@ subroutine history_out_field_3d(diagnostic_name, field_values) ! call endrun(errmsg) ! end if !end if - + end do end subroutine history_out_field_3d @@ -810,7 +811,7 @@ subroutine history_wrap_up(restart_write, last_timestep) ! Original version: CCM2 ! !----------------------------------------------------------------------- - ! + ! ! Dummy arguments logical, intent(in) :: restart_write logical, intent(in) :: last_timestep @@ -898,4 +899,41 @@ recursive function get_entry_by_name(listentry, name) result(entry) end if end function get_entry_by_name +!####################################################################### +! Helper functions +!######################################################################### + + logical function is_history_field_active(diagnostic_name) result(is_active) + !----------------------------------------------------------------------- + ! + ! Purpose: Check if a field is active on any history file + ! + !----------------------------------------------------------------------- + use cam_abortutils, only: endrun + + ! Input variables: + character(len=*), intent(in) :: diagnostic_name + + ! Local variables: + integer :: file_idx + character(len=cl) :: errmsg + class(hist_field_info_t), pointer :: field_info + character(len=*), parameter :: subname = 'is_history_field_active: ' + + is_active = .false. + errmsg = '' + + do file_idx = 1, size(hist_configs) + ! Check if the named field is on the current file + call hist_configs(file_idx)%find_in_field_list(diagnostic_name, field_info, errmsg) + if (len_trim(errmsg) /= 0) then + call endrun('ERROR: '//subname//errmsg, file=__FILE__, line=__LINE__) + end if + if (associated(field_info)) then + is_active = .true. + return + end if + end do + end function is_history_field_active + end module cam_history diff --git a/src/history/cam_history_support.F90 b/src/history/cam_history_support.F90 index c5a26d148..d7bf45dd5 100644 --- a/src/history/cam_history_support.F90 +++ b/src/history/cam_history_support.F90 @@ -12,7 +12,6 @@ module cam_history_support implicit none private - save integer, parameter, public :: fieldname_len = 32 ! max chars for field name integer, parameter, public :: fieldname_suffix_len = 3 ! length of field name suffix ("&IC") @@ -143,7 +142,7 @@ module cam_history_support end interface !!--------------------------------------------------------------------------- - + CONTAINS pure integer function get_hist_coord_index(mdimname) @@ -921,7 +920,7 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid) end if ! (.not. dimonly) end subroutine write_hist_coord_attr - + !--------------------------------------------------------------------------- ! ! write_hist_coord_attrs @@ -1054,7 +1053,7 @@ subroutine write_hist_coord_var(File, mdimind) if (associated(hist_coords(mdimind)%formula_terms%a_values)) then ! Check to make sure the variable already exists in the file ! NB: Reusing vardesc, no longer assocated with previous variables - ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%a_name), vardesc) + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%a_name), vardesc) write(errormsg,*) subname, ': Error writing values for nonexistent "a" formula_terms for variable "', & trim(hist_coords(mdimind)%name), '" (formula_terms%a_name="', & trim(hist_coords(mdimind)%formula_terms%a_name), '")' diff --git a/src/physics/utils/cam_constituents.F90 b/src/physics/utils/cam_constituents.F90 index eabddffa5..2b8098c4e 100644 --- a/src/physics/utils/cam_constituents.F90 +++ b/src/physics/utils/cam_constituents.F90 @@ -7,11 +7,11 @@ module cam_constituents private ! Public system functions - public :: cam_constituents_readnl public :: cam_constituents_init ! Public accessor functions public :: const_name ! Constituent standard name public :: const_longname + public :: const_diag_name ! Constituent diagnostic (file output) name public :: const_molec_weight public :: const_get_index public :: const_is_advected @@ -29,8 +29,6 @@ module cam_constituents type(ccpp_constituent_prop_ptr_t), pointer :: const_props(:) => NULL() ! Namelist variable - ! readtrace: Obtain initial tracer data from IC file if .true. - logical, public :: readtrace = .true. ! Only allow initialization once logical, private :: initialized = .false. @@ -100,66 +98,6 @@ module cam_constituents CONTAINS - subroutine cam_constituents_readnl(nlfile) - - use mpi, only: mpi_logical - use shr_nl_mod, only: find_group_name => shr_nl_find_group_name - use spmd_utils, only: masterproc, mpicom, mstrid=>masterprocid - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - - ! nlfile: filepath for file containing namelist input - character(len=*), intent(in) :: nlfile - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: sub = 'cam_constituents_readnl' - - namelist /constituents_nl/ readtrace - !------------------------------------------------------------------------ - - !!XXgoldyXX: v Need to figure out how to figure out pcnst - !! Update physconst so that we can use 'dry_air_species' and - !! 'water_species_in_air' from air_composition_nl. - !! Register CCPP constituents (see call below) - !! Count up species from air_composition_nl plus CCPP advected - !! constituents not in that namelist. - !! Make sure there are indices for all thermodynamically-active species - !! in runtime DDT object. Pack them at front of state Q array. - !!XXgoldyXX: ^ Need to figure out how to figure out pcnst - - if (masterproc) then - open(newunit=unitn, file=trim(nlfile), status='old') - call find_group_name(unitn, 'constituents_nl', status=ierr) - if (ierr == 0) then - read(unitn, constituents_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub//': FATAL: reading namelist', & - file=__FILE__, line=__LINE__) - end if - end if - close(unitn) - end if - - call mpi_bcast(readtrace, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) then - call endrun(sub//": FATAL: mpi_bcast: readtrace", & - file=__FILE__, line=__LINE__) - end if - - if (masterproc) then - write(iulog,*)'Summary of constituent module options:' - if (readtrace) then - write(iulog,*)' Attempt to read constituent initial values ', & - 'from the initial file by default' - else - write(iulog,*)' Do not read constituent initial values ', & - 'from the initial file' - end if - end if - - end subroutine cam_constituents_readnl - !####################################################################### subroutine cam_constituents_init(cnst_prop_ptr, num_advect) @@ -286,6 +224,32 @@ function const_longname(const_ind) end function const_longname + !####################################################################### + function const_diag_name(const_ind) + use cam_abortutils, only: endrun + use string_utils, only: to_str + use shr_kind_mod, only: CL => shr_kind_cl + + ! Return the diagnostic name of the constituent at . + ! Dummy arguments + integer, intent(in) :: const_ind + character(len=CL) :: const_diag_name + ! Local variables + integer :: err_code + character(len=256) :: err_msg + character(len=*), parameter :: subname = 'const_diag_name: ' + + if (check_index_bounds(const_ind, subname)) then + call const_props(const_ind)%diagnostic_name(const_diag_name, & + err_code, err_msg) + if (err_code /= 0) then + call endrun(subname//"Error "//to_str(err_code)//": "// & + trim(err_msg), file=__FILE__, line=__LINE__) + end if + end if + + end function const_diag_name + !####################################################################### function const_molec_weight(const_ind) diff --git a/src/utils/cam_abortutils.F90 b/src/utils/cam_abortutils.F90 index 1eddccb43..b328a9eb7 100644 --- a/src/utils/cam_abortutils.F90 +++ b/src/utils/cam_abortutils.F90 @@ -9,7 +9,6 @@ module cam_abortutils implicit none private - save public :: endrun public :: safe_endrun @@ -57,7 +56,7 @@ subroutine check_allocate(errcode, subname, fieldname, file, line, errmsg) ! If the optional fortran allocate error message is passed in, include it in the abort message if(present(errmsg)) then - write(abort_msg, '(a)') trim(abort_msg) // new_line('a') // "Allocation failed with: " // trim(errmsg) + write(abort_msg, '(a)') trim(abort_msg) // new_line('a') // "Allocation failed with: " // adjustl(trim(errmsg)) endif ! End the simulation diff --git a/src/utils/cam_map_utils.F90 b/src/utils/cam_map_utils.F90 index ae4969b19..ac2e3166e 100644 --- a/src/utils/cam_map_utils.F90 +++ b/src/utils/cam_map_utils.F90 @@ -646,8 +646,9 @@ end subroutine cam_filemap_coordDests !--------------------------------------------------------------------------- subroutine cam_filemap_get_filemap(this, fieldlens, filelens, filemap, & src_in, dest_in, permutation_in) - use spmd_utils, only: iam - use cam_logfile, only: debug_output, cam_log_multiwrite, DEBUGOUT_DEBUG + use shr_kind_mod, only: cl=>shr_kind_cl + use spmd_utils, only: iam + use cam_logfile, only: debug_output, cam_log_multiwrite, DEBUGOUT_DEBUG ! Dummy arguments class(cam_filemap_t) :: this @@ -670,7 +671,8 @@ subroutine cam_filemap_get_filemap(this, fieldlens, filelens, filemap, & integer :: tind, tlen ! Temporarys integer :: i1, i2, i3, i4, i5, i6, i7 integer :: i(7) - character(len=128) :: errmsg + character(len=cl) :: errmsg + character(len=32) :: errfmt character(len=*), parameter :: subname = 'cam_filemap_get_filemap: ' ! This shouldn't happen but, who knows what evil lurks in the hearts of SEs @@ -731,7 +733,15 @@ subroutine cam_filemap_get_filemap(this, fieldlens, filelens, filemap, & ! it is still an error if the map has more elements than the array mapSize = this%num_elem() if (mapPos < this%num_mapped()) then - call endrun(subname//'Map size too large for array dims') + if (mapcnt > 1) then + write(errfmt, '(a,i0,2a)') "(a,i0,a,", mapcnt, '(i0,", "),")")' + else + write(errfmt, '(a,i0,2a)') '(a,i0,a,i0,")")' + end if + write(errmsg, errfmt) 'Map size (', this%num_mapped(), & + ') too large for array dims (', & + srclens(mapind(1:mapcnt)) + call endrun(subname//trim(errmsg)) end if ! dsize is a global offset for each dimension