diff --git a/Makefile b/Makefile index bf80bc87b..be1d4de00 100644 --- a/Makefile +++ b/Makefile @@ -23,10 +23,13 @@ xlf: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) ftn: @@ -44,10 +47,13 @@ ftn: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) titan-cray: @@ -62,10 +68,13 @@ titan-cray: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pgi: @@ -87,10 +96,13 @@ pgi: "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC = -Mnofma -acc -ta=tesla:cc60 -Minfo" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pgi-nersc: @@ -108,10 +120,13 @@ pgi-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pgi-llnl: @@ -129,10 +144,13 @@ pgi-llnl: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) ifort: @@ -144,9 +162,9 @@ ifort: "CC_SERIAL = icc" \ "CXX_SERIAL = icpc" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -FR" \ - "CFLAGS_OPT = -O3" \ - "CXXFLAGS_OPT = -O3" \ + "FFLAGS_OPT = -O3 -convert big_endian -FR -xMIC-AVX512" \ + "CFLAGS_OPT = -O3 -xMIC-AVX512" \ + "CXXFLAGS_OPT = -O3 -xMIC-AVX512" \ "LDFLAGS_OPT = -O3" \ "FFLAGS_DEBUG = -g -convert big_endian -FR -CU -CB -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ @@ -154,10 +172,13 @@ ifort: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) ifort-scorep: @@ -179,10 +200,13 @@ ifort-scorep: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) ifort-gcc: @@ -204,10 +228,13 @@ ifort-gcc: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) gfortran: @@ -229,10 +256,13 @@ gfortran: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) gfortran-clang: @@ -254,10 +284,13 @@ gfortran-clang: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) g95: @@ -275,10 +308,13 @@ g95: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pathscale-nersc: @@ -296,10 +332,13 @@ pathscale-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) cray-nersc: @@ -317,10 +356,13 @@ cray-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) gnu-nersc: @@ -361,6 +403,8 @@ intel-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -FR -CU -CB -check all -gen-interfaces -warn interfaces -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ @@ -369,6 +413,7 @@ intel-nersc: "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) bluegene: @@ -390,10 +435,13 @@ bluegene: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) CPPINCLUDES = @@ -508,6 +556,13 @@ ifeq "$(OPENMP)" "true" LDFLAGS += $(FFLAGS_OMP) endif #OPENMP IF +ifeq "$(OPENACC)" "true" + FFLAGS += $(FFLAGS_ACC) + CFLAGS += $(CFLAGS_ACC) + override CPPFLAGS += "-DMPAS_OPENACC" + LDFLAGS += $(FFLAGS_ACC) +endif #OPENACC IF + ifeq "$(PRECISION)" "single" CFLAGS += "-DSINGLE_PRECISION" CXXFLAGS += "-DSINGLE_PRECISION" @@ -580,6 +635,12 @@ else OPENMP_MESSAGE="MPAS was built without OpenMP support." endif +ifeq "$(OPENACC)" "true" + OPENACC_MESSAGE="MPAS was built with OpenACC enabled." +else + OPENACC_MESSAGE="MPAS was built without OpenACC support." +endif + ifneq ($(wildcard .mpas_core_*), ) # CHECK FOR BUILT CORE ifneq ($(wildcard .mpas_core_$(CORE)), ) # CHECK FOR SAME CORE AS ATTEMPTED BUILD. @@ -680,6 +741,10 @@ ifeq "$(OPENMP)" "true" @rm -fr conftest.* endif +ifeq "$(OPENACC)" "true" + @echo "Testing compiler for OpenACC support" +endif + mpas_main: compiler_test ifeq "$(AUTOCLEAN)" "true" @@ -717,6 +782,7 @@ endif @echo $(PAPI_MESSAGE) @echo $(TAU_MESSAGE) @echo $(OPENMP_MESSAGE) + @echo $(OPENACC_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) endif @@ -798,6 +864,7 @@ errmsg: @echo " TIMER_LIB=gptl - Uses gptl for the timer interface instead of the native interface" @echo " TIMER_LIB=tau - Uses TAU for the timer interface instead of the native interface" @echo " OPENMP=true - builds and links with OpenMP flags. Default is to not use OpenMP." + @echo " OPENACC=true - builds and links with OpenACC flags. Default is to not use OpenACC." @echo " USE_PIO2=true - links with the PIO 2 library. Default is to use the PIO 1.x library." @echo " PRECISION=single - builds with default single-precision real kind. Default is to use double-precision." @echo "" diff --git a/src/Makefile b/src/Makefile index cc0cc020d..b0004ba4d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -25,7 +25,7 @@ drver: $(AUTOCLEAN_DEPS) externals frame ops dycore endif build_tools: externals - (cd tools; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CC="$(SCC)" CFLAGS="$(CFLAGS)") + (cd tools; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CC="$(SCC)" CFLAGS="-O") frame: $(AUTOCLEAN_DEPS) externals ( cd framework; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all ) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index ca73840fc..dbb86c876 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -1,7 +1,7 @@ .SUFFIXES: .F .o -PHYSICS=-DDO_PHYSICS -#PHYSICS= +#PHYSICS=-DDO_PHYSICS +PHYSICS= OBJS = mpas_atm_core.o \ mpas_atm_core_interface.o \ @@ -34,7 +34,7 @@ physcore: mpas_atm_dimensions.o ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*TBL .) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*DATA* .) -dycore: mpas_atm_dimensions.o +dycore: mpas_atm_dimensions.o physcore ( cd dynamics; $(MAKE) all PHYSICS="$(PHYSICS)" ) diagcore: physcore dycore @@ -48,7 +48,7 @@ atmcore: physcore dycore diagcore $(OBJS) mpas_atm_core_interface.o: mpas_atm_core.o -mpas_atm_core.o: dycore mpas_atm_threading.o +mpas_atm_core.o: dycore diagcore mpas_atm_threading.o mpas_atm_dimensions.o: diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 7d5b8c01e..41e5d401a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -27,22 +27,30 @@ module atm_time_integration use mpas_atm_iau +#ifdef MPAS_OPENACC + use openacc +#endif + integer :: timerid, secs, u_secs ! Used to store physics tendencies for dynamics variables real (kind=RKIND), allocatable, dimension(:,:) :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics - +!$acc declare create(tend_ru_physics, tend_rtheta_physics, tend_rho_physics) ! Used in compute_dyn_tend real (kind=RKIND), allocatable, dimension(:,:) :: qtot +!$acc declare create(qtot) real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_w, delsq_divergence +!$acc declare create(delsq_theta, delsq_w, delsq_divergence) real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u ! real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation ! no longer used -> removed real (kind=RKIND), allocatable, dimension(:,:) :: delsq_vorticity real (kind=RKIND), allocatable, dimension(:,:) :: dpdz +!$acc declare create(delsq_u,delsq_vorticity,dpdz) ! Used in atm_advance_scalars real (kind=RKIND), dimension(:,:,:), allocatable :: horiz_flux_array + ! Used in atm_advance_scalars_mono real (kind=RKIND), dimension(:,:), allocatable :: scalar_old_arr, scalar_new_arr real (kind=RKIND), dimension(:,:), allocatable :: s_max_arr, s_min_arr @@ -57,6 +65,7 @@ module atm_time_integration ! Used in compute_solve_diagnostics real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex real (kind=RKIND), allocatable, dimension(:,:) :: ke_edge +!$acc declare create(ke_vertex,ke_edge) contains @@ -94,8 +103,8 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) if (trim(config_time_integration) == 'SRK3') then call atm_srk3(domain, dt, itimestep) else - call mpas_log_write('Unknown time integration option '//trim(config_time_integration), messageType=MPAS_LOG_ERR) - call mpas_log_write('Currently, only ''SRK3'' is supported.', messageType=MPAS_LOG_CRIT) + call mpas_log_write('Unknown time integration option'//trim(config_time_integration), messageType=MPAS_LOG_ERR) + call mpas_log_write('Currently, only ''SRK3'' is supported.',messageType=MPAS_LOG_CRIT) end if call mpas_set_time(currTime, dateTimeString=timeStamp) @@ -106,7 +115,7 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'xtime', xtime, 2) + call mpas_pool_get_array_gpu(state, 'xtime', xtime, 2) xtime = xtime_new block => block % next end do @@ -202,6 +211,18 @@ subroutine atm_srk3(domain, dt, itimestep) logical, parameter :: debug = .false. + real (kind=RKIND), dimension(:,:), pointer :: gpu_theta_m_1, gpu_theta_m_2, gpu_pressure_p, gpu_rtheta_p, gpu_exner + real (kind=RKIND), dimension(:,:), pointer :: gpu_rtheta_pp, gpu_u_1, gpu_u_2, gpu_w_1, gpu_w_2 + real (kind=RKIND), dimension(:,:), pointer :: gpu_tend_u, gpu_ru_p, gpu_rw_p, gpu_rho_pp, gpu_pv_edge, gpu_rho_edge + real (kind=RKIND), dimension(:,:,:), pointer :: gpu_scalars_1 + +#ifdef MPAS_OPENACC + integer :: rrpk_rank, rrpk_devices, rrpk_local_gpu_id + rrpk_rank = domain % dminfo % my_proc_id + rrpk_devices = acc_get_num_devices(acc_device_nvidia) + rrpk_local_gpu_id = mod(rrpk_rank,rrpk_devices) + call acc_set_device_num(rrpk_local_gpu_id,acc_device_nvidia) +#endif ! ! Retrieve configuration options @@ -229,6 +250,11 @@ subroutine atm_srk3(domain, dt, itimestep) ! ! Retrieve fields ! + call mpas_pool_get_array_gpu(state,'theta_m',gpu_theta_m_1,1) + call mpas_pool_get_array_gpu(state,'scalars',gpu_scalars_1,1) + call mpas_pool_get_array_gpu(diag,'pressure_p',gpu_pressure_p) + call mpas_pool_get_array_gpu(diag,'rtheta_p',gpu_rtheta_p) + call mpas_pool_get_field(state, 'theta_m', theta_m_field, 1) call mpas_pool_get_field(state, 'scalars', scalars_field, 1) call mpas_pool_get_field(diag, 'pressure_p', pressure_p_field) @@ -240,16 +266,17 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(state, 'nCells', nCells) call mpas_pool_get_dimension(state, 'nEdges', nEdges) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'nVertices', nVertices) allocate(qtot(nVertLevels,nCells+1)) - qtot(:,nCells+1) = 0.0_RKIND +! qtot(:,nCells+1) = 0.0_RKIND allocate(tend_rtheta_physics(nVertLevels,nCells+1)) - tend_rtheta_physics(:,nCells+1) = 0.0_RKIND +! tend_rtheta_physics(:,nCells+1) = 0.0_RKIND allocate(tend_rho_physics(nVertLevels,nCells+1)) - tend_rho_physics(:,nCells+1) = 0.0_RKIND +! tend_rho_physics(:,nCells+1) = 0.0_RKIND allocate(tend_ru_physics(nVertLevels,nEdges+1)) - tend_ru_physics(:,nEdges+1) = 0.0_RKIND - +! tend_ru_physics(:,nEdges+1) = 0.0_RKIND +!!$acc update device(qtot,tend_rtheta_physics,tend_rho_physics,tend_ru_physics) ! ! Initialize RK weights ! @@ -257,13 +284,13 @@ subroutine atm_srk3(domain, dt, itimestep) dynamics_split = config_dynamics_split if (config_split_dynamics_transport) then dt_dynamics = dt/real(dynamics_split) - call mpas_log_write(' split dynamics-transport integration $i', intArgs=(/dynamics_split/)) + call mpas_log_write(' split dynamics-transport integration $i',intArgs=(/dynamics_split/)) else dynamics_split = 1 dt_dynamics = dt call mpas_log_write(' coupled RK3 dynamics-transport integration ') end if - if (.not. config_scalar_advection ) call mpas_log_write(' scalar advection turned off ') + if (.not. config_scalar_advection ) call mpas_log_write(' scalar advection turned off ') number_of_sub_steps = config_number_of_sub_steps @@ -296,7 +323,8 @@ subroutine atm_srk3(domain, dt, itimestep) number_sub_steps(3) = number_of_sub_steps end if - +!!$acc update host(gpu_theta_m_1,gpu_scalars_1,gpu_pressure_p,gpu_rtheta_p) +!$acc update host(gpu_theta_m_1,gpu_pressure_p,gpu_rtheta_p) ! theta_m call mpas_dmpar_exch_halo_field(theta_m_field) @@ -308,6 +336,8 @@ subroutine atm_srk3(domain, dt, itimestep) ! rtheta_p call mpas_dmpar_exch_halo_field(rtheta_p_field) +!!$acc update device(gpu_theta_m_1,gpu_scalars_1,gpu_pressure_p,gpu_rtheta_p) +!$acc update device(gpu_theta_m_1,gpu_pressure_p,gpu_rtheta_p) call mpas_timer_start('atm_rk_integration_setup') @@ -433,6 +463,16 @@ subroutine atm_srk3(domain, dt, itimestep) end do end if + allocate(delsq_theta(nVertLevels,nCells+1)) + allocate(delsq_w(nVertLevels,nCells+1)) + allocate(delsq_divergence(nVertLevels,nCells+1)) + allocate(delsq_u(nVertLevels,nEdges+1)) + allocate(delsq_vorticity(nVertLevels,nVertices+1)) + allocate(dpdz(nVertLevels,nCells+1)) + allocate(ke_vertex(nVertLevels,nVertices+1)) +! ke_vertex(:,nVertices+1) = 0.0_RKIND + allocate(ke_edge(nVertLevels,nEdges+1)) +! ke_edge(:,nEdges+1) = 0.0_RKIND DYNAMICS_SUBSTEPS : do dynamics_substep = 1, dynamics_split @@ -473,9 +513,11 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do call mpas_timer_stop('atm_compute_vert_imp_coefs') - + call mpas_pool_get_array_gpu(diag,'exner',gpu_exner) + !$acc update host(gpu_exner) call mpas_pool_get_field(diag, 'exner', exner_field) call mpas_dmpar_exch_halo_field(exner_field) + !$acc update device(gpu_exner) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -554,21 +596,21 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - allocate(delsq_theta(nVertLevels,nCells+1)) - delsq_theta(:,nCells+1) = 0.0_RKIND - allocate(delsq_w(nVertLevels,nCells+1)) - delsq_w(:,nCells+1) = 0.0_RKIND +! allocate(delsq_theta(nVertLevels,nCells+1)) +! delsq_theta(:,nCells+1) = 0.0_RKIND +! allocate(delsq_w(nVertLevels,nCells+1)) +! delsq_w(:,nCells+1) = 0.0_RKIND !! allocate(qtot(nVertLevels,nCells+1)) ! initializing this earlier in solution sequence - allocate(delsq_divergence(nVertLevels,nCells+1)) - delsq_divergence(:,nCells+1) = 0.0_RKIND - allocate(delsq_u(nVertLevels,nEdges+1)) - delsq_u(:,nEdges+1) = 0.0_RKIND +! allocate(delsq_divergence(nVertLevels,nCells+1)) +! delsq_divergence(:,nCells+1) = 0.0_RKIND +! allocate(delsq_u(nVertLevels,nEdges+1)) +! delsq_u(:,nEdges+1) = 0.0_RKIND !! allocate(delsq_circulation(nVertLevels,nVertices+1)) ! no longer used -> removed - allocate(delsq_vorticity(nVertLevels,nVertices+1)) - delsq_vorticity(:,nVertices+1) = 0.0_RKIND - allocate(dpdz(nVertLevels,nCells+1)) - dpdz(:,nCells+1) = 0.0_RKIND - +! allocate(delsq_vorticity(nVertLevels,nVertices+1)) +! delsq_vorticity(:,nVertices+1) = 0.0_RKIND +! allocate(dpdz(nVertLevels,nCells+1)) +! dpdz(:,nCells+1) = 0.0_RKIND +!!$acc update device(delsq_theta,delsq_w,delsq_divergence,delsq_u,delsq_vorticity,dpdz) !$OMP PARALLEL DO do thread=1,nThreads call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & @@ -581,14 +623,6 @@ subroutine atm_srk3(domain, dt, itimestep) end do !$OMP END PARALLEL DO - deallocate(delsq_theta) - deallocate(delsq_w) -!! deallocate(qtot) ! deallocation after dynamics step complete, see below - deallocate(delsq_divergence) - deallocate(delsq_u) -!! deallocate(delsq_circulation) ! no longer used -> removed - deallocate(delsq_vorticity) - deallocate(dpdz) block => block % next end do @@ -626,9 +660,11 @@ subroutine atm_srk3(domain, dt, itimestep) ! tend_u call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tend) + call mpas_pool_get_array_gpu(tend,'u',gpu_tend_u) +!$acc update host(gpu_tend_u) call mpas_pool_get_field(tend, 'u', tend_u_field) call mpas_dmpar_exch_halo_field(tend_u_field, (/ 1 /)) - +!$acc update device(gpu_tend_u) call mpas_timer_start('small_step_prep') block => domain % blocklist @@ -672,9 +708,11 @@ subroutine atm_srk3(domain, dt, itimestep) do small_step = 1, number_sub_steps(rk_step) call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag, 'rho_pp',gpu_rho_pp) +!$acc update host(gpu_rho_pp) call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) call mpas_dmpar_exch_halo_field(rho_pp_field, (/ 1 /)) - +!$acc update device(gpu_rho_pp) call mpas_timer_start('atm_advance_acoustic_step') block => domain % blocklist do while (associated(block)) @@ -725,37 +763,17 @@ subroutine atm_srk3(domain, dt, itimestep) ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag,'rtheta_pp',gpu_rtheta_pp) call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 1 /)) -! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step - - call mpas_timer_start('atm_divergence_damping_3d') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - -!$OMP PARALLEL DO - do thread=1,nThreads - call atm_divergence_damping_3d( state, diag, mesh, block % configs, rk_sub_timestep(rk_step), & - edgeThreadStart(thread), edgeThreadEnd(thread) ) - end do -!$OMP END PARALLEL DO - - block => block % next - end do - call mpas_timer_stop('atm_divergence_damping_3d') - end do ! end of acoustic steps loop !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag,'rw_p',gpu_rw_p) + call mpas_pool_get_array_gpu(diag,'ru_p',gpu_ru_p) +!$acc update host(gpu_rw_p,gpu_ru_p,gpu_rho_pp,gpu_rtheta_pp) call mpas_pool_get_field(diag, 'rw_p', rw_p_field) call mpas_dmpar_exch_halo_field(rw_p_field) @@ -770,6 +788,7 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 2 /)) +!$acc update device(gpu_rw_p,gpu_ru_p,gpu_rho_pp,gpu_rtheta_pp) call mpas_timer_start('atm_recover_large_step_variables') block => domain % blocklist do while (associated(block)) @@ -816,8 +835,11 @@ subroutine atm_srk3(domain, dt, itimestep) ! u !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % state % time_levs(2) % state % u, (/ 3 /)) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_array_gpu(state, 'u',gpu_u_2, 2) +!$acc update host(gpu_u_2) call mpas_pool_get_field(state, 'u', u_field, 2) call mpas_dmpar_exch_halo_field(u_field) +!$acc update device(gpu_u_2) ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. @@ -962,22 +984,16 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - allocate(ke_vertex(nVertLevels,nVertices+1)) - ke_vertex(:,nVertices+1) = 0.0_RKIND - allocate(ke_edge(nVertLevels,nEdges+1)) - ke_edge(:,nEdges+1) = 0.0_RKIND - +!!$acc update device(ke_vertex,ke_edge) !$OMP PARALLEL DO do thread=1,nThreads - call atm_compute_solve_diagnostics(dt, state, 2, diag, mesh, block % configs, & + call atm_compute_solve_diagnostics_gpu(dt, state, 2, diag, mesh, block % configs, & cellThreadStart(thread), cellThreadEnd(thread), & vertexThreadStart(thread), vertexThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), rk_step) end do !$OMP END PARALLEL DO - deallocate(ke_vertex) - deallocate(ke_edge) block => block % next end do @@ -986,18 +1002,25 @@ subroutine atm_srk3(domain, dt, itimestep) ! w call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_array_gpu(state, 'w', gpu_w_2, 2) +!$acc update host(gpu_w_2) call mpas_pool_get_field(state, 'w', w_field, 2) call mpas_dmpar_exch_halo_field(w_field) ! pv_edge call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag, 'pv_edge', gpu_pv_edge) +!$acc update host(gpu_pv_edge) call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) call mpas_dmpar_exch_halo_field(pv_edge_field) ! rho_edge + call mpas_pool_get_array_gpu(diag, 'rho_edge', gpu_rho_edge) +!$acc update host(gpu_rho_edge) call mpas_pool_get_field(diag, 'rho_edge', rho_edge_field) call mpas_dmpar_exch_halo_field(rho_edge_field) +!$acc update device(gpu_w_2,gpu_pv_edge,gpu_rho_edge) ! scalars if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then call mpas_pool_get_field(state, 'scalars', scalars_field, 2) @@ -1009,10 +1032,12 @@ subroutine atm_srk3(domain, dt, itimestep) if (dynamics_substep < dynamics_split) then call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) call mpas_pool_get_field(state, 'theta_m', theta_m_field, 2) - + call mpas_pool_get_array_gpu(state, 'theta_m', gpu_theta_m_2, 2) +!$acc update host(gpu_theta_m_2,gpu_pressure_p,gpu_rtheta_p) call mpas_dmpar_exch_halo_field(theta_m_field) call mpas_dmpar_exch_halo_field(pressure_p_field) call mpas_dmpar_exch_halo_field(rtheta_p_field) +!$acc update device(gpu_theta_m_2,gpu_pressure_p,gpu_rtheta_p) ! ! Note: A halo exchange for 'exner' here as well as after the call @@ -1069,6 +1094,16 @@ subroutine atm_srk3(domain, dt, itimestep) end do DYNAMICS_SUBSTEPS + deallocate(ke_vertex) + deallocate(ke_edge) + deallocate(delsq_theta) + deallocate(delsq_w) +!! deallocate(qtot) ! deallocation after dynamics step complete, see below + deallocate(delsq_divergence) + deallocate(delsq_u) +!! deallocate(delsq_circulation) ! no longer used -> removed + deallocate(delsq_vorticity) + deallocate(dpdz) deallocate(qtot) ! we are finished with these now deallocate(tend_rtheta_physics) @@ -1225,18 +1260,21 @@ subroutine atm_srk3(domain, dt, itimestep) ! ! reconstruct full velocity vectors at cell centers: ! + call mpas_timer_start('atm_rk_reconstruct') block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) - call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) - call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) - call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) - call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + call mpas_pool_get_array_gpu(state, 'u', u, 2) +! call mpas_pool_get_array_gpu(state, 'u', gpu_u_2, 2) +!!$acc update host(gpu_u_2) + call mpas_pool_get_array_gpu(diag, 'uReconstructX', uReconstructX) + call mpas_pool_get_array_gpu(diag, 'uReconstructY', uReconstructY) + call mpas_pool_get_array_gpu(diag, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array_gpu(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array_gpu(diag, 'uReconstructMeridional', uReconstructMeridional) call mpas_reconstruct(mesh, u, & uReconstructX, & @@ -1248,6 +1286,7 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do + call mpas_timer_stop('atm_rk_reconstruct') ! ! call to parameterizations of cloud microphysics. calculation of the tendency of water vapor to horizontal and @@ -1264,8 +1303,8 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_array(state, 'scalars', scalars_1, 1) - call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_2, 2) call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) @@ -1277,7 +1316,7 @@ subroutine atm_srk3(domain, dt, itimestep) config_convection_scheme == 'cu_tiedtke' .or. & config_convection_scheme == 'cu_ntiedtke') then - call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) + call mpas_pool_get_array_gpu(tend_physics, 'rqvdynten', rqvdynten) !NOTE: The calculation of the tendency due to horizontal and vertical advection for the water vapor mixing ratio !requires that the subroutine atm_advance_scalars_mono was called on the third Runge Kutta step, so that a halo @@ -1316,7 +1355,9 @@ subroutine atm_srk3(domain, dt, itimestep) ! #endif + call mpas_timer_start('atm_rk_summary') call summarize_timestep(domain) + call mpas_timer_stop('atm_rk_summary') end subroutine atm_srk3 @@ -1347,42 +1388,105 @@ subroutine atm_rk_integration_setup( state, diag, & real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2 real (kind=RKIND), dimension(:,:,:), pointer :: scalars_1, scalars_2 + integer, pointer :: num_scalars, nCells,nEdges,nVertLevels + + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_zz_old_split', rho_zz_old_split) + + call mpas_pool_get_array_gpu(state, 'u', u_1, 1) + call mpas_pool_get_array_gpu(state, 'u', u_2, 2) + call mpas_pool_get_array_gpu(state, 'w', w_1, 1) + call mpas_pool_get_array_gpu(state, 'w', w_2, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_1, 1) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_2, 2) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_1, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_2, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_2, 2) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'nCells', nCells) + call mpas_pool_get_dimension(state, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) - - call mpas_pool_get_array(state, 'u', u_1, 1) - call mpas_pool_get_array(state, 'u', u_2, 2) - call mpas_pool_get_array(state, 'w', w_1, 1) - call mpas_pool_get_array(state, 'w', w_2, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) - call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) - call mpas_pool_get_array(state, 'scalars', scalars_1, 1) - call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - - ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) - rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) - rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) - rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) - - u_2(:,edgeStart:edgeEnd) = u_1(:,edgeStart:edgeEnd) - w_2(:,cellStart:cellEnd) = w_1(:,cellStart:cellEnd) - theta_m_2(:,cellStart:cellEnd) = theta_m_1(:,cellStart:cellEnd) - rho_zz_2(:,cellStart:cellEnd) = rho_zz_1(:,cellStart:cellEnd) - rho_zz_old_split(:,cellStart:cellEnd) = rho_zz_1(:,cellStart:cellEnd) - scalars_2(:,:,cellStart:cellEnd) = scalars_1(:,:,cellStart:cellEnd) - + call atm_rk_integration_setup_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, num_scalars, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2, & + scalars_1, scalars_2) end subroutine atm_rk_integration_setup + subroutine atm_rk_integration_setup_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, num_scalars, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2, & + scalars_1, scalars_2) + + implicit none + integer, intent(in) :: nVertLevels, edgeStart, edgeEnd,cellStart, cellEnd, & + nCells, nEdges, num_scalars + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw, rw_save + real (kind=RKIND), dimension(nVertLevels,nEdges+1):: ru, ru_save, u_1, u_2 + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: w_1,w_2 + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_p, rho_p_save, & + rtheta_p,rtheta_p_save, & + rho_zz_old_split, & + rho_zz_1, rho_zz_2, & + theta_m_1, theta_m_2 + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars_1, scalars_2 + integer:: i,j, k +!$acc data present(ru, ru_save, rw, rw_save, & +!$acc rtheta_p,rtheta_p_save,rho_p,rho_p_save, & +!$acc rho_zz_old_split, & +!$acc u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2) + +!!$acc update host(ru, ru_save, rw, rw_save, & +!!$acc rtheta_p,rtheta_p_save,rho_p,rho_p_save, & +!!$acc rho_zz_old_split, & +!!$acc u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2) +!$acc parallel vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels + rtheta_p_save(j,i) = rtheta_p(j,i) + rho_p_save(j,i) = rho_p(j,i) + theta_m_2(j,i) = theta_m_1(j,i) + rho_zz_2(j,i) = rho_zz_1(j,i) + rho_zz_old_split(j,i) = rho_zz_1(j,i) + do k=1,num_scalars + scalars_2(k,j,i) = scalars_1(k,j,i) + enddo + enddo +!$acc loop vector + do j=1,nVertLevels+1 + rw_save(j,i) = rw(j,i) + w_2(j,i) = w_1(j,i) + enddo + enddo +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ru_save(j,i) = ru(j,i) + u_2(j,i) = u_1(j,i) + enddo + enddo +!$acc end parallel + +!$acc end data + end subroutine atm_rk_integration_setup_work + subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -1401,52 +1505,77 @@ subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd integer :: iEdge, iCell, k, cell1, cell2, iq - integer, pointer :: nCells, nEdges, nVertLevels, nCellsSolve + integer, pointer :: pnCells, pnEdges, pnVertLevels, pnCellsSolve + integer :: nCells, nEdges, nVertLevels, nCellsSolve real (kind=RKIND) :: qtotal integer, dimension(:,:), pointer :: cellsOnEdge - integer, pointer :: moist_start, moist_end + integer, pointer :: pmoist_start, pmoist_end + integer :: moist_start, moist_end real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:), pointer :: cqw real (kind=RKIND), dimension(:,:), pointer :: cqu - call mpas_pool_get_dimension(dims, 'nCells', nCells) - call mpas_pool_get_dimension(dims, 'nEdges', nEdges) - call mpas_pool_get_dimension(dims, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'moist_start', moist_start) - call mpas_pool_get_dimension(state, 'moist_end', moist_end) - - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(state, 'scalars', scalars, 2) - call mpas_pool_get_array(diag, 'cqw', cqw) - call mpas_pool_get_array(diag, 'cqu', cqu) - -! do iCell = cellSolveStart,cellSolveEnd + call mpas_pool_get_dimension(dims, 'nCells', pnCells) + call mpas_pool_get_dimension(dims, 'nEdges', pnEdges) + call mpas_pool_get_dimension(dims, 'nVertLevels', pnVertLevels) + call mpas_pool_get_dimension(dims, 'nCellsSolve', pnCellsSolve) + call mpas_pool_get_dimension(state, 'moist_start', pmoist_start) + call mpas_pool_get_dimension(state, 'moist_end', pmoist_end) + + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) + call mpas_pool_get_array_gpu(diag, 'cqw', cqw) + call mpas_pool_get_array_gpu(diag, 'cqu', cqu) + + nCells = pnCells + nEdges = pnEdges + nVertLevels = pnVertLevels + nCellsSolve = pnCellsSolve + moist_start = pmoist_start + moist_end = pmoist_end + +!$acc data present(scalars,cqw,cqu, qtot) +!!$acc update host(scalars) +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do iCell = edgeStart,edgeEnd +!$acc loop vector + do k = 1,nVertLevels + tend_ru_physics(k,iCell) = 0.0_RKIND + end do + end do +!$acc end parallel +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang do iCell = cellStart,cellEnd - qtot(1:nVertLevels,iCell) = 0.0 +!$acc loop vector do k = 1,nVertLevels + qtot(k,iCell) = 0.0 + tend_rtheta_physics(k,iCell) = 0.0_RKIND + tend_rho_physics(k,iCell) = 0.0_RKIND +!$acc loop seq do iq = moist_start, moist_end qtot(k,iCell) = qtot(k,iCell) + scalars(iq, k, iCell) end do end do - end do - -! do iCell = cellSolveStart,cellSolveEnd - do iCell = cellStart,cellEnd +!$acc loop vector do k = 2, nVertLevels qtotal = 0.5*(qtot(k,iCell)+qtot(k-1,iCell)) cqw(k,iCell) = 1.0 / (1.0 + qtotal) end do end do +!$acc end parallel -! would need to compute qtot for all cells and an openmp barrier to use qtot below. - +!$acc parallel vector_length(32) +!$acc loop gang do iEdge = edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then - do k = 1, nVertLevels +!$acc loop vector + do k = 1, nVertLevels qtotal = 0.0 +!$acc loop seq do iq = moist_start, moist_end qtotal = qtotal + 0.5 * ( scalars(iq, k, cell1) + scalars(iq, k, cell2) ) end do @@ -1454,6 +1583,9 @@ subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & end do end if end do +!$acc end parallel +!!$acc update device(qtot,cqw,cqu) +!$acc end data end subroutine atm_compute_moist_coefficients @@ -1494,30 +1626,30 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d call mpas_pool_get_config(configs, 'config_epssm', epssm) - call mpas_pool_get_array(mesh, 'rdzu', rdzu) - call mpas_pool_get_array(mesh, 'rdzw', rdzw) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'zz', zz) - - call mpas_pool_get_array(diag, 'cqw', cqw) - call mpas_pool_get_array(diag, 'exner', p) - call mpas_pool_get_array(diag, 'exner_base', pb) - call mpas_pool_get_array(diag, 'rtheta_p', rt) - call mpas_pool_get_array(diag, 'rtheta_base', rtb) - call mpas_pool_get_array(diag, 'rho_base', rb) - - call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) - call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) - call mpas_pool_get_array(diag, 'a_tri', a_tri) - call mpas_pool_get_array(diag, 'cofwr', cofwr) - call mpas_pool_get_array(diag, 'cofwz', cofwz) - call mpas_pool_get_array(diag, 'coftz', coftz) - call mpas_pool_get_array(diag, 'cofwt', cofwt) - call mpas_pool_get_array(diag, 'cofrz', cofrz) - - call mpas_pool_get_array(state, 'theta_m', t, 2) - call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_array_gpu(mesh, 'rdzu', rdzu) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdzw) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + + call mpas_pool_get_array_gpu(diag, 'cqw', cqw) + call mpas_pool_get_array_gpu(diag, 'exner', p) + call mpas_pool_get_array_gpu(diag, 'exner_base', pb) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rt) + call mpas_pool_get_array_gpu(diag, 'rtheta_base', rtb) + call mpas_pool_get_array_gpu(diag, 'rho_base', rb) + + call mpas_pool_get_array_gpu(diag, 'alpha_tri', alpha_tri) + call mpas_pool_get_array_gpu(diag, 'gamma_tri', gamma_tri) + call mpas_pool_get_array_gpu(diag, 'a_tri', a_tri) + call mpas_pool_get_array_gpu(diag, 'cofwr', cofwr) + call mpas_pool_get_array_gpu(diag, 'cofwz', cofwz) + call mpas_pool_get_array_gpu(diag, 'coftz', coftz) + call mpas_pool_get_array_gpu(diag, 'cofwt', cofwt) + call mpas_pool_get_array_gpu(diag, 'cofrz', cofrz) + + call mpas_pool_get_array_gpu(state, 'theta_m', t, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) call mpas_pool_get_dimension(state, 'nCells', nCells) call mpas_pool_get_dimension(state, 'moist_start', moist_start) @@ -1583,21 +1715,31 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, ! integer :: iCell, k, iq real (kind=RKIND) :: dtseps, c2, qtotal, rcv - real (kind=RKIND), dimension( nVertLevels ) :: b_tri, c_tri - + real (kind=RKIND), dimension( nVertLevels ,nCells+1) :: b_tri, c_tri +!$acc data present(cofrz, gamma_tri, a_tri, alpha_tri, & +!$acc coftz, cofwr, cofwt, cofwz, & +!$acc rdzw, cqw, fzm, fzp, p, pb, qtot, rb, rdzu, rt, rtb, t, zz)& +!$acc create(b_tri,c_tri) + ! set coefficients dtseps = .5*dts*(1.+epssm) rcv = rgas/(cp-rgas) c2 = cp*rcv + +!$acc parallel num_workers(8) vector_length(32) +!$acc loop vector ! MGD bad to have all threads setting this variable? do k=1,nVertLevels cofrz(k) = dtseps*rdzw(k) end do +!$acc end parallel - do iCell = cellSolveStart,cellSolveEnd ! we only need to do cells we are solving for, not halo cells +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd ! we only need to do cells we are solving for, not halo cells !DIR$ IVDEP do k=2,nVertLevels cofwr(k,iCell) =.5*dtseps*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) @@ -1610,48 +1752,65 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, coftz(k,iCell) = dtseps* (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) end do coftz(nVertLevels+1,iCell) = 0.0 + end do +!$acc end parallel + +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(qtotal) + do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP do k=1,nVertLevels -! qtotal = 0. -! do iq = moist_start, moist_end -! qtotal = qtotal + scalars(iq, k, iCell) -! end do qtotal = qtot(k,iCell) cofwt(k,iCell) = .5*dtseps*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & *p(k,iCell)/((rtb(k,iCell)+rt(k,iCell))*pb(k,iCell)) -! cofwt(k,iCell) = 0. + end do + end do +!$acc end parallel +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd a_tri(1,iCell) = 0. ! note, this value is never used - b_tri(1) = 1. ! note, this value is never used - c_tri(1) = 0. ! note, this value is never used + b_tri(1,iCell) = 1. ! note, this value is never used + c_tri(1,iCell) = 0. ! note, this value is never used gamma_tri(1,iCell) = 0. alpha_tri(1,iCell) = 0. ! note, this value is never used + enddo +!$acc end parallel +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP do k=2,nVertLevels a_tri(k,iCell) = -cofwz(k ,iCell)* coftz(k-1,iCell)*rdzw(k-1)*zz(k-1,iCell) & +cofwr(k ,iCell)* cofrz(k-1 ) & -cofwt(k-1,iCell)* coftz(k-1,iCell)*rdzw(k-1) - b_tri(k) = 1. & + b_tri(k,iCell) = 1. & +cofwz(k ,iCell)*(coftz(k ,iCell)*rdzw(k )*zz(k ,iCell) & +coftz(k ,iCell)*rdzw(k-1)*zz(k-1,iCell)) & -coftz(k ,iCell)*(cofwt(k ,iCell)*rdzw(k ) & -cofwt(k-1,iCell)*rdzw(k-1)) & +cofwr(k, iCell)*(cofrz(k )-cofrz(k-1)) - c_tri(k) = -cofwz(k ,iCell)* coftz(k+1,iCell)*rdzw(k )*zz(k ,iCell) & + c_tri(k,iCell) = -cofwz(k ,iCell)* coftz(k+1,iCell)*rdzw(k )*zz(k ,iCell) & -cofwr(k ,iCell)* cofrz(k ) & +cofwt(k ,iCell)* coftz(k+1,iCell)*rdzw(k ) end do +! end do !MGD VECTOR DEPENDENCE +! do iCell = cellSolveStart,cellSolveEnd do k=2,nVertLevels - alpha_tri(k,iCell) = 1./(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) - gamma_tri(k,iCell) = c_tri(k)*alpha_tri(k,iCell) + alpha_tri(k,iCell) = 1./(b_tri(k,iCell)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) + gamma_tri(k,iCell) = c_tri(k,iCell)*alpha_tri(k,iCell) end do end do ! loop over cells +!$acc end parallel + +!$acc end data end subroutine atm_compute_vert_imp_coefs_work @@ -1694,40 +1853,40 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, mesh, configs, & call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zb', zb) - call mpas_pool_get_array(mesh, 'zb3', zb3) - call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) - call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - - call mpas_pool_get_array(tend, 'w', w_tend) - call mpas_pool_get_array(tend, 'u', u_tend) - - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - - call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - - call mpas_pool_get_array(diag, 'ru_p', ru_p) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'ru', ru) - - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) - - call mpas_pool_get_array(diag, 'rw_p', rw_p) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zb', zb) + call mpas_pool_get_array_gpu(mesh, 'zb3', zb3) + call mpas_pool_get_array_gpu(mesh, 'zb_cell', zb_cell) + call mpas_pool_get_array_gpu(mesh, 'zb3_cell', zb3_cell) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + + call mpas_pool_get_array_gpu(tend, 'w', w_tend) + call mpas_pool_get_array_gpu(tend, 'u', u_tend) + + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + + call mpas_pool_get_array_gpu(diag, 'ru_p', ru_p) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + + call mpas_pool_get_array_gpu(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_pp_old', rtheta_pp_old) + + call mpas_pool_get_array_gpu(diag, 'rw_p', rw_p) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) call atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & nEdgesOnCell, cellsOnEdge, edgesOnCell, fzm, fzp, ruAvg, wwAvg, zb, zb3, zb_cell, zb3_cell, & @@ -1801,7 +1960,11 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & ! here we need to compute the omega tendency in a manner consistent with our diagnosis of omega. ! this requires us to use the same flux divergence as is used in the theta eqn - see Klemp et al MWR 2003. -!! do iCell=cellStart,cellEnd +!$acc data present(w_tend, & +!$acc edgesoncell, edgesoncell_sign, fzm, fzp,nedgesoncell, u_tend, & +!$acc zb3_cell, zb_cell, zz) +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(iEdge, flux) do iCell=cellSolveStart,cellSolveEnd do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -1817,6 +1980,8 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & w_tend(k,iCell) = ( fzm(k) * zz(k,iCell) + fzp(k) * zz(k-1,iCell) ) * w_tend(k,iCell) end do end do +!$acc end parallel +!$acc end data end subroutine atm_set_smlstep_pert_variables_work @@ -1875,70 +2040,73 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, integer, pointer :: nEdges, nCellsSolve - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) -! call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, 2) +! call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 1) ! change needed for rw_p, change 6 (see rayleigh damping) - call mpas_pool_get_array(state, 'w', w, 2) -! call mpas_pool_get_array(state, 'w', w, 1) - - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) - call mpas_pool_get_array(diag, 'ru_p', ru_p) - call mpas_pool_get_array(diag, 'rw_p', rw_p) - call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'cqu', cqu) - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - call mpas_pool_get_array(diag, 'cofwt', cofwt) - call mpas_pool_get_array(diag, 'coftz', coftz) - call mpas_pool_get_array(diag, 'cofrz', cofrz) - call mpas_pool_get_array(diag, 'cofwr', cofwr) - call mpas_pool_get_array(diag, 'cofwz', cofwz) - call mpas_pool_get_array(diag, 'a_tri', a_tri) - call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) - call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) - - call mpas_pool_get_array(mesh, 'dss', dss) - - call mpas_pool_get_array(tend, 'u', tend_ru) - call mpas_pool_get_array(tend, 'rho_zz', tend_rho) - call mpas_pool_get_array(tend, 'theta_m', tend_rt) - call mpas_pool_get_array(tend, 'w', tend_rw) - - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zxu', zxu) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'rdzw', rdzw) - call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(state, 'w', w, 2) +! call mpas_pool_get_array_gpu(state, 'w', w, 1) + + call mpas_pool_get_array_gpu(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array_gpu(diag, 'rtheta_pp_old', rtheta_pp_old) + call mpas_pool_get_array_gpu(diag, 'ru_p', ru_p) + call mpas_pool_get_array_gpu(diag, 'rw_p', rw_p) + call mpas_pool_get_array_gpu(diag, 'exner', exner) + call mpas_pool_get_array_gpu(diag, 'cqu', cqu) + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array_gpu(diag, 'cofwt', cofwt) + call mpas_pool_get_array_gpu(diag, 'coftz', coftz) + call mpas_pool_get_array_gpu(diag, 'cofrz', cofrz) + call mpas_pool_get_array_gpu(diag, 'cofwr', cofwr) + call mpas_pool_get_array_gpu(diag, 'cofwz', cofwz) + call mpas_pool_get_array_gpu(diag, 'a_tri', a_tri) + call mpas_pool_get_array_gpu(diag, 'alpha_tri', alpha_tri) + call mpas_pool_get_array_gpu(diag, 'gamma_tri', gamma_tri) + + call mpas_pool_get_array_gpu(mesh, 'dss', dss) + + call mpas_pool_get_array_gpu(tend, 'u', tend_ru) + call mpas_pool_get_array_gpu(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array_gpu(tend, 'theta_m', tend_rt) + call mpas_pool_get_array_gpu(tend, 'w', tend_rw) + + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zxu', zxu) + call mpas_pool_get_array_gpu(mesh, 'zgrid', zgrid) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdzw) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(mesh, 'cf1', cf1) - call mpas_pool_get_array(mesh, 'cf2', cf2) - call mpas_pool_get_array(mesh, 'cf3', cf3) + call mpas_pool_get_array_gpu(mesh, 'cf1', cf1) + call mpas_pool_get_array_gpu(mesh, 'cf2', cf2) + call mpas_pool_get_array_gpu(mesh, 'cf3', cf3) ! redefine ru_p to be perturbation from time t, change 3b ! temporary - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) ! redefine rw_p to be perturbation from time t, change 3b ! temporary - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) ! epssm is the offcentering coefficient for the vertically implicit integration. + ! smdiv is the 3D divergence-damping coefficients. call mpas_pool_get_config(configs, 'config_epssm', epssm) +! call mpas_pool_get_config(configs, 'config_smdiv', smdiv) +! call mpas_pool_get_config(configs, 'config_smdiv_p_forward', smdiv_p_forward) call atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -2023,7 +2191,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign integer, intent(in) :: small_step - real (kind=RKIND), intent(in) :: dts, epssm,cf1, cf2, cf3 + real (kind=RKIND), intent(in) :: dts, epssm, cf1, cf2, cf3 real (kind=RKIND), dimension(nVertLevels) :: ts, rs @@ -2039,37 +2207,38 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart c2 = cp * rcv resm = (1.0 - epssm) / (1.0 + epssm) rdts = 1./dts + +!$acc data present(rtheta_pp, rtheta_pp_old, ru_p, ruavg, rho_pp, & +!$acc rw_p, wwavg, & +!$acc zz, cellsonedge, cqu, dcedge, exner, invdcedge, & +!$acc tend_ru, zxu, tend_rho, a_tri, alpha_tri, cofrz, & +!$acc coftz, cofwr, cofwt, cofwz, dss, dvedge, edgesoncell, edgesoncell_sign, & +!$acc fzm, fzp, gamma_tri, invareacell, nedgesoncell, rdzw, rho_zz, rw, & +!$acc rw_save, tend_rho, tend_rt, tend_rw, theta_m, w) if(small_step /= 1) then ! not needed on first small step - ! forward-backward acoustic step integration. - ! begin by updating the horizontal velocity u, - ! and accumulating the contribution from the updated u to the other tendencies. - - ! we are looping over all edges, but only computing on edges of owned cells. This will include updates of - ! all owned edges plus some edges that are owned by other blocks. We perform these redundant computations - ! so that we do not have to communicate updates of u to update the cell variables (rho, w, and theta). - - !MGD this loop will not be very load balanced with if-test below - +!$acc parallel vector_length(32) +!$acc loop gang do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? - + cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) ! update edges for block-owned cells if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels pgrad = ((rtheta_pp(k,cell2)-rtheta_pp(k,cell1))*invDcEdge(iEdge) )/(.5*(zz(k,cell2)+zz(k,cell1))) pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) + ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) end do ! accumulate ru_p for use later in scalar transport !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) end do @@ -2077,9 +2246,13 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end if ! end test for block-owned cells end do ! end loop over edges +!$acc end parallel + end if - else ! this is all that us needed for ru_p update for first acoustic step in RK substep - + if(small_step ==1) then +! else ! this is all that us needed for ru_p update for first acoustic step in RK substep +!$acc parallel vector_length(32) +!$acc loop gang do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? cell1 = cellsOnEdge(1,iEdge) @@ -2087,34 +2260,48 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart ! update edges for block-owned cells if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels ru_p(k,iEdge) = dts*tend_ru(k,iEdge) end do !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels +!! ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) ruAvg(k,iEdge) = ru_p(k,iEdge) end do end if ! end test for block-owned cells end do ! end loop over edges - +!$acc end parallel end if ! test for first acoustic step +!$OMP BARRIER + if (small_step == 1) then ! initialize here on first small timestep. +!$acc parallel vector_length(32) +!$acc loop gang vector do iCell=cellStart,cellEnd rtheta_pp_old(1:nVertLevels,iCell) = 0.0 end do +!$acc end parallel else - do iCell=cellStart,cellEnd - rtheta_pp_old(1:nVertLevels,iCell) = rtheta_pp(1:nVertLevels,iCell) - end do +!$acc parallel vector_length(32) +!$acc loop gang vector + do iCell=cellStart,cellEnd + rtheta_pp_old(1:nVertLevels,iCell) = rtheta_pp(1:nVertLevels,iCell) + end do +!$acc end parallel end if -!$OMP BARRIER +!!!OMP BARRIER -- not needed, since rtheta_pp_old not used below when small_step == 1 +!$acc parallel vector_length(32) +!$acc loop gang private(ts, rs) do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve +!!$acc cache(ts) +!!$acc cache(rs) ts(:) = 0.0 rs(:) = 0.0 @@ -2123,26 +2310,30 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart wwAvg(1:nVertLevels+1,iCell) = 0.0 rho_pp(1:nVertLevels,iCell) = 0.0 rtheta_pp(1:nVertLevels,iCell) = 0.0 +!MGD moved to loop above over all cells +! rtheta_pp_old(1:nVertLevels,iCell) = 0.0 rw_p(:,iCell) = 0.0 - end if - + end if + +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels flux = edgesOnCell_sign(i,iCell)*dts*dvEdge(iEdge)*ru_p(k,iEdge) * invAreaCell(iCell) rs(k) = rs(k)-flux ts(k) = ts(k)-flux*0.5*(theta_m(k,cell2)+theta_m(k,cell1)) end do end do - ! vertically implicit acoustic and gravity wave integration. ! this follows Klemp et al MWR 2007, with the addition of an implicit Rayleigh damping of w ! serves as a gravity-wave absorbing layer, from Klemp et al 2008. !DIR$ IVDEP +!$acc loop vector do k=1, nVertLevels rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) @@ -2152,11 +2343,13 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end do !DIR$ IVDEP +!$acc loop vector do k=2, nVertLevels wwavg(k,iCell) = wwavg(k,iCell) + 0.5*(1.0-epssm)*rw_p(k,iCell) end do !DIR$ IVDEP +!$acc loop vector do k=2, nVertLevels rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) & - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & @@ -2165,25 +2358,27 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & - cofwr(k,iCell)*((rs(k)+rs(k-1)) & +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & - + cofwt(k ,iCell)*(ts(k )+resm*rtheta_pp(k ,iCell)) & + + cofwt(k ,iCell)*(ts(k)+resm*rtheta_pp(k ,iCell)) & + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) end do ! tridiagonal solve sweeping up and then down the column !MGD VECTOR DEPENDENCE +!$acc loop seq do k=2,nVertLevels rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) end do !MGD VECTOR DEPENDENCE +!$acc loop seq do k=nVertLevels,1,-1 rw_p(k,iCell) = rw_p(k,iCell) - gamma_tri(k,iCell)*rw_p(k+1,iCell) end do ! the implicit Rayleigh damping on w (gravity-wave absorbing) - !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels rw_p(k,iCell) = (rw_p(k,iCell) + (rw_save(k ,iCell) - rw(k ,iCell)) -dts*dss(k,iCell)* & (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) & @@ -2194,13 +2389,14 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart ! accumulate (rho*omega)' for use later in scalar transport !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) end do ! update rho_pp and theta_pp given updated rw_p - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & @@ -2208,80 +2404,11 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end do end do ! end of loop over cells - +!$acc end parallel +!$acc end data end subroutine atm_advance_acoustic_step_work - subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart, edgeEnd ) - - ! This subroutine updates the horizontal momentum with the 3d divergence damping component. - - implicit none - - type (mpas_pool_type), intent(inout) :: state - type (mpas_pool_type), intent(inout) :: diag - type (mpas_pool_type), intent(inout) :: mesh - type (mpas_pool_type), intent(in) :: configs - real (kind=RKIND), intent(in) :: dts - integer, intent(in) :: edgeStart, edgeEnd - - real (kind=RKIND), dimension(:,:), pointer :: theta_m, ru_p, rtheta_pp, rtheta_pp_old -! real (kind=RKIND), dimension(:), pointer :: dcEdge - real (kind=RKIND), pointer :: smdiv, config_len_disp - - integer, dimension(:,:), pointer :: cellsOnEdge - integer, pointer :: nCellsSolve - integer, pointer :: nVertLevels - - real (kind=RKIND) :: divCell1, divCell2, rdts, coef_divdamp - integer :: cell1, cell2, iEdge, k - - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) -! call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(state, 'theta_m', theta_m, 1) - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) - call mpas_pool_get_array(diag, 'ru_p', ru_p) - - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_config(configs, 'config_smdiv', smdiv) - call mpas_pool_get_config(configs, 'config_len_disp', config_len_disp) - - rdts = 1.0_RKIND / dts - coef_divdamp = 2.0_RKIND * smdiv * config_len_disp * rdts - - do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - ! update edges for block-owned cells - if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - -!DIR$ IVDEP - do k=1,nVertLevels - -!! unscaled 3d divergence damping -!! divCell1 = -(rtheta_pp(k,cell1)-rtheta_pp_old(k,cell1))*rdts -!! divCell2 = -(rtheta_pp(k,cell2)-rtheta_pp_old(k,cell2))*rdts -!! ru_p(k,iEdge) = ru_p(k,iEdge) + 2.*smdiv*dcEdge(iEdge)*(divCell2-divCell1) & -!! /(theta_m(k,cell1)+theta_m(k,cell2)) - -!! scaled 3d divergence damping - divCell1 = -(rtheta_pp(k,cell1)-rtheta_pp_old(k,cell1)) - divCell2 = -(rtheta_pp(k,cell2)-rtheta_pp_old(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + coef_divdamp*(divCell2-divCell1) & - /(theta_m(k,cell1)+theta_m(k,cell2)) - - end do - end if ! edges for block-owned cells - end do ! end loop over edges - - end subroutine atm_divergence_damping_3d - - subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, dt, ns, rk_step, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2322,49 +2449,49 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d real (kind=RKIND), pointer :: cf1, cf2, cf3 - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_p', rw_p) - call mpas_pool_get_array(state, 'w', w, 2) - - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) - call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) - call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_array(state, 'scalars', scalars, 2) - - call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - call mpas_pool_get_array(diag, 'rho_base', rho_base) - - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'ru_p', ru_p) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(state, 'u', u, 2) - - call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'exner_base', exner_base) - - call mpas_pool_get_array(diag, 'pressure_p', pressure_p) - call mpas_pool_get_array(diag, 'pressure_base', pressure_b) - - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zb', zb) - call mpas_pool_get_array(mesh, 'zb3', zb3) - call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) - call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_p', rw_p) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array_gpu(diag, 'rtheta_base', rtheta_base) + call mpas_pool_get_array_gpu(tend, 'rt_diabatic_tend', rt_diabatic_tend) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) + + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array_gpu(diag, 'rho_base', rho_base) + + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'ru_p', ru_p) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(state, 'u', u, 2) + + call mpas_pool_get_array_gpu(diag, 'exner', exner) + call mpas_pool_get_array_gpu(diag, 'exner_base', exner_base) + + call mpas_pool_get_array_gpu(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array_gpu(diag, 'pressure_base', pressure_b) + + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zb', zb) + call mpas_pool_get_array_gpu(mesh, 'zb3', zb3) + call mpas_pool_get_array_gpu(mesh, 'zb_cell', zb_cell) + call mpas_pool_get_array_gpu(mesh, 'zb3_cell', zb3_cell) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(mesh, 'nCells', nCells) @@ -2372,9 +2499,9 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_array(mesh, 'cf1', cf1) - call mpas_pool_get_array(mesh, 'cf2', cf2) - call mpas_pool_get_array(mesh, 'cf3', cf3) + call mpas_pool_get_array_gpu(mesh, 'cf1', cf1) + call mpas_pool_get_array_gpu(mesh, 'cf2', cf2) + call mpas_pool_get_array_gpu(mesh, 'cf3', cf3) call atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nEdgesSolve, dt, ns, rk_step, & @@ -2389,6 +2516,7 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d end subroutine atm_recover_large_step_variables + subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nEdgesSolve, dt, ns, rk_step, & wwAvg, rw_save, w, rw, rw_p, rtheta_p, rtheta_pp, rtheta_p_save, rt_diabatic_tend, rho_p, & rho_p_save, rho_pp, rho_zz, rho_base, ruAvg, ru_save, ru_p, u, ru, exner, exner_base, & @@ -2464,17 +2592,28 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE rcv = rgas/(cp-rgas) p0 = 1.0e+05 ! this should come from somewhere else... +!$acc data present(rho_zz, exner, pressure_p, rho_p, rtheta_p, rw, theta_m, w, & +!$acc wwavg, ru, ruavg, u, & +!$acc exner_base, fzm, fzp, rho_base, rho_p_save, rho_pp, rt_diabatic_tend, & +!$acc rtheta_base, rtheta_p_save, rtheta_pp, rw_p, rw_save, zz, cellsonedge, & +!$acc ru_p, ru_save, edgesoncell, edgesoncell_sign, nedgesoncell, zb3_cell, & +!$acc zb_cell) + ! Avoid FP errors caused by a potential division by zero below by ! initializing the "garbage cell" of rho_zz to a non-zero value +!$acc parallel num_workers(8) vector_length(32) +!$acc loop vector do k=1,nVertLevels rho_zz(k,nCells+1) = 1.0 end do - +!$acc end parallel ! compute new density everywhere so we can compute u from ru. ! we will also need it to compute theta_m below invNs = 1 / real(ns,RKIND) +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker do iCell=cellStart,cellEnd !DIR$ IVDEP @@ -2483,9 +2622,14 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE rho_zz(k,iCell) = rho_p(k,iCell) + rho_base(k,iCell) end do - + w(1,iCell) = 0.0 + end do +!$acc end parallel +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell=cellStart,cellEnd !DIR$ IVDEP do k = 2, nVertLevels wwAvg(k,iCell) = rw_save(k,iCell) + (wwAvg(k,iCell) * invNs) @@ -2497,8 +2641,14 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end do w(nVertLevels+1,iCell) = 0.0 + end do +!$acc end parallel + if (rk_step == 3) then +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker collapse(2) + do iCell=cellStart,cellEnd !DIR$ IVDEP do k = 1, nVertLevels rtheta_p(k,iCell) = rtheta_p_save(k,iCell) + rtheta_pp(k,iCell) & @@ -2509,15 +2659,24 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE pressure_p(k,iCell) = zz(k,iCell) * rgas * (exner(k,iCell)*rtheta_p(k,iCell)+rtheta_base(k,iCell) & * (exner(k,iCell)-exner_base(k,iCell))) end do - else + end do +!$acc end parallel + end if + + if (rk_step /= 3) then +! else +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker collapse(2) + do iCell=cellStart,cellEnd !DIR$ IVDEP do k = 1, nVertLevels rtheta_p(k,iCell) = rtheta_p_save(k,iCell) + rtheta_pp(k,iCell) theta_m(k,iCell) = (rtheta_p(k,iCell) + rtheta_base(k,iCell))/rho_zz(k,iCell) end do + end do +!$acc end parallel end if - end do ! recover time-averaged ruAvg on all edges of owned cells (for upcoming scalar transport). ! we solved for these in the acoustic-step loop. @@ -2525,6 +2684,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE !$OMP BARRIER +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(cell1, cell2) do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) @@ -2537,9 +2698,10 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE u(k,iEdge) = 2.*ru(k,iEdge)/(rho_zz(k,cell1)+rho_zz(k,cell2)) end do end do - +!$acc end parallel !$OMP BARRIER - +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(iEdge, flux) do iCell=cellStart,cellEnd ! finish recovering w from (rho*omega)_p. as when we formed (rho*omega)_p from u and w, we need @@ -2569,7 +2731,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end do end do - +!$acc end parallel +!$acc end data end subroutine atm_recover_large_step_variables_work @@ -2637,38 +2800,38 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) - call mpas_pool_get_array(state, 'scalars', scalar_old, 1) - call mpas_pool_get_array(state, 'scalars', scalar_new, 2) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - - call mpas_pool_get_array(diag, 'kdiff', kdiff) - call mpas_pool_get_array(diag, 'ruAvg', uhAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - - call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) - - call mpas_pool_get_array(mesh, 'fzm', fnm) - call mpas_pool_get_array(mesh, 'fzp', fnp) - call mpas_pool_get_array(mesh, 'rdzw', rdnw) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) - - call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) - call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) - call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) - call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - - call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - call mpas_pool_get_array(mesh, 'qv_init', qv_init) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array_gpu(state, 'scalars', scalar_old, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalar_new, 2) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_old, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_new, 2) + + call mpas_pool_get_array_gpu(diag, 'kdiff', kdiff) + call mpas_pool_get_array_gpu(diag, 'ruAvg', uhAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array_gpu(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(tend, 'scalars_tend', scalar_tend_save) + + call mpas_pool_get_array_gpu(mesh, 'fzm', fnm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fnp) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdnw) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel4', meshScalingDel4) + + call mpas_pool_get_array_gpu(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + + call mpas_pool_get_array_gpu(diag, 'rho_edge', rho_edge) + call mpas_pool_get_array_gpu(mesh, 'qv_init', qv_init) + call mpas_pool_get_array_gpu(mesh, 'zgrid', zgrid) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -2720,6 +2883,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n end subroutine atm_advance_scalars + subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -2874,7 +3038,7 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm if (local_advance_density) then if ((.not.present(scalar_tend)) .or. (.not.present(rho_zz_int))) then - call mpas_log_write('Error: rho_zz_int or scalar_tend not supplied to atm_advance_scalars( ) when advance_density=.true.', messageType=MPAS_LOG_CRIT) + call mpas_log_write('Error: rho_zz_int or scalar_tend not supplied to atm_advance_scalars( ) when advance_density=.true.',messageType=MPAS_LOG_CRIT) end if do iCell=cellSolveStart,cellSolveEnd @@ -3293,30 +3457,30 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(diag, 'ruAvg', uhAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend) - - call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(state, 'scalars', scalars_old, 1) - call mpas_pool_get_array(state, 'scalars', scalars_new, 2) - - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'fzm', fnm) - call mpas_pool_get_array(mesh, 'fzp', fnp) - call mpas_pool_get_array(mesh, 'rdzw', rdnw) - call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) - call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) - call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) - call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_array_gpu(diag, 'ruAvg', uhAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array_gpu(tend, 'scalars_tend', scalar_tend) + + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_old, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_new, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_old, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_new, 2) + + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'fzm', fnm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fnp) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdnw) + call mpas_pool_get_array_gpu(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs_3rd', adv_coefs_3rd) call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -3331,6 +3495,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe end subroutine atm_advance_scalars_mono + subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels_dummy, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -3484,7 +3649,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve if (local_advance_density) then if (.not.present(rho_zz_int)) then - call mpas_log_write('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.', messageType=MPAS_LOG_CRIT) + call mpas_log_write('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.',messageType=MPAS_LOG_CRIT) end if ! begin with update of density @@ -3535,7 +3700,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_old(k,iCell)) end do end do - call mpas_log_write(' scmin, scmin old in $r $r', realArgs=(/scmin,scmax/)) + call mpas_log_write(' scmin, scmin old in $r $r',realArgs=(/scmin,scmax/)) scmin = scalar_new(1,1) scmax = scalar_new(1,1) @@ -3632,7 +3797,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then ! only for owned cells - ! special treatment of calculations involving edges between hexagonal cells + ! speclal treatment of calculations involving edges between hexagonal cells ! original code retained in select "default" case ! be sure to see additional declarations near top of subroutine select case(nAdvCellsForEdge(iEdge)) @@ -3666,8 +3831,6 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do end select - else - flux_arr(:,iEdge) = 0.0_RKIND end if end do @@ -3887,14 +4050,14 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_new(k,iCell)) scmin = min(scmin,scalar_new(k,iCell)) if (s_max(k,iCell) < scalar_new(k,iCell)) then - call mpas_log_write(' over - k,iCell,s_min,s_max,scalar_new ', intArgs=(/k,iCell/), realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) + call mpas_log_write(' over - k,iCell,s_min,s_max,scalar_new ',intArgs=(/k,iCell/),realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) end if if (s_min(k,iCell) > scalar_new(k,iCell)) then - call mpas_log_write(' under - k,iCell,s_min,s_max,scalar_new ', intArgs=(/k,iCell/), realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) + call mpas_log_write(' under - k,iCell,s_min,s_max,scalar_new ',intArgs=(/k,iCell/),realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) end if end do end do - call mpas_log_write(' scmin, scmax new out $r $r', realArgs=(/scmin,scmax/)) + call mpas_log_write(' scmin, scmax new out $r $r',realArgs=(/scmin,scmax/)) call mpas_log_write(' icell_min, k_min ', intArgs=(/icellmax, kmax/)) #endif @@ -3994,7 +4157,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy - real (kind=RKIND), pointer :: coef_3rd_order, c_s + real (kind=RKIND), pointer :: coef_3rd_order, c_s, smdiv logical, pointer :: config_mix_full character (len=StrKIND), pointer :: config_horiz_mixing real (kind=RKIND), pointer :: config_del4u_div_factor @@ -4022,88 +4185,89 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_config(configs, 'config_visc4_2dsmag', config_visc4_2dsmag) call mpas_pool_get_config(configs, 'config_len_disp', config_len_disp) call mpas_pool_get_config(configs, 'config_smagorinsky_coef', c_s) + call mpas_pool_get_config(configs, 'config_smdiv', smdiv) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) - call mpas_pool_get_array(state, 'scalars', scalars, 2) - - call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) - call mpas_pool_get_array(diag, 'uReconstructMeridional', vr_cell) - call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - call mpas_pool_get_array(diag, 'rho_base', rb) - call mpas_pool_get_array(diag, 'rho_p', rr) - call mpas_pool_get_array(diag, 'rho_p_save', rr_save) - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(diag, 'kdiff', kdiff) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'divergence', divergence) - call mpas_pool_get_array(diag, 'vorticity', vorticity) - call mpas_pool_get_array(diag, 'ke', ke) - call mpas_pool_get_array(diag, 'pv_edge', pv_edge) - call mpas_pool_get_array(diag, 'pressure_p', pp) - call mpas_pool_get_array(diag, 'pressure_base', pressure_b) - call mpas_pool_get_array(diag, 'h_divergence', h_divergence) - call mpas_pool_get_array(diag, 'exner', exner) - - call mpas_pool_get_array(diag, 'tend_rtheta_adv', tend_rtheta_adv) - call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) - - call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) - call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) - call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) - call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) - call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) - call mpas_pool_get_array(mesh, 'fEdge', fEdge) - call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zxu', zxu) - call mpas_pool_get_array(mesh, 'latCell', latCell) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) - call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) - call mpas_pool_get_array(mesh, 'defc_a', defc_a) - call mpas_pool_get_array(mesh, 'defc_b', defc_b) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) - call mpas_pool_get_array(mesh, 'u_init', u_init) - call mpas_pool_get_array(mesh, 't_init', t_init) - call mpas_pool_get_array(mesh, 'qv_init', qv_init) - - call mpas_pool_get_array(mesh, 'rdzu', rdzu) - call mpas_pool_get_array(mesh, 'rdzw', rdzw) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - - call mpas_pool_get_array(tend, 'u', tend_u) - call mpas_pool_get_array(tend, 'theta_m', tend_theta) - call mpas_pool_get_array(tend, 'w', tend_w) - call mpas_pool_get_array(tend, 'rho_zz', tend_rho) - call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) - call mpas_pool_get_array(tend, 'u_euler', tend_u_euler) - call mpas_pool_get_array(tend, 'theta_euler', tend_theta_euler) - call mpas_pool_get_array(tend, 'w_euler', tend_w_euler) - call mpas_pool_get_array(tend, 'w_pgf', tend_w_pgf) - call mpas_pool_get_array(tend, 'w_buoy', tend_w_buoy) - - call mpas_pool_get_array(diag, 'cqw', cqw) - call mpas_pool_get_array(diag, 'cqu', cqu) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array_gpu(state, 'u', u, 2) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_save, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) + + call mpas_pool_get_array_gpu(diag, 'uReconstructZonal', ur_cell) + call mpas_pool_get_array_gpu(diag, 'uReconstructMeridional', vr_cell) + call mpas_pool_get_array_gpu(diag, 'rho_edge', rho_edge) + call mpas_pool_get_array_gpu(diag, 'rho_base', rb) + call mpas_pool_get_array_gpu(diag, 'rho_p', rr) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rr_save) + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(diag, 'kdiff', kdiff) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'divergence', divergence) + call mpas_pool_get_array_gpu(diag, 'vorticity', vorticity) + call mpas_pool_get_array_gpu(diag, 'ke', ke) + call mpas_pool_get_array_gpu(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array_gpu(diag, 'pressure_p', pp) + call mpas_pool_get_array_gpu(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array_gpu(diag, 'h_divergence', h_divergence) + call mpas_pool_get_array_gpu(diag, 'exner', exner) + + call mpas_pool_get_array_gpu(diag, 'tend_rtheta_adv', tend_rtheta_adv) + call mpas_pool_get_array_gpu(tend_physics, 'rthdynten', rthdynten) + + call mpas_pool_get_array_gpu(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array_gpu(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array_gpu(mesh, 'fEdge', fEdge) + call mpas_pool_get_array_gpu(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zxu', zxu) + call mpas_pool_get_array_gpu(mesh, 'latCell', latCell) + call mpas_pool_get_array_gpu(mesh, 'latEdge', latEdge) + call mpas_pool_get_array_gpu(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array_gpu(mesh, 'defc_a', defc_a) + call mpas_pool_get_array_gpu(mesh, 'defc_b', defc_b) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array_gpu(mesh, 'u_init', u_init) + call mpas_pool_get_array_gpu(mesh, 't_init', t_init) + call mpas_pool_get_array_gpu(mesh, 'qv_init', qv_init) + + call mpas_pool_get_array_gpu(mesh, 'rdzu', rdzu) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdzw) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'zgrid', zgrid) + + call mpas_pool_get_array_gpu(tend, 'u', tend_u) + call mpas_pool_get_array_gpu(tend, 'theta_m', tend_theta) + call mpas_pool_get_array_gpu(tend, 'w', tend_w) + call mpas_pool_get_array_gpu(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array_gpu(tend, 'rt_diabatic_tend', rt_diabatic_tend) + call mpas_pool_get_array_gpu(tend, 'u_euler', tend_u_euler) + call mpas_pool_get_array_gpu(tend, 'theta_euler', tend_theta_euler) + call mpas_pool_get_array_gpu(tend, 'w_euler', tend_w_euler) + call mpas_pool_get_array_gpu(tend, 'w_pgf', tend_w_pgf) + call mpas_pool_get_array_gpu(tend, 'w_buoy', tend_w_buoy) + + call mpas_pool_get_array_gpu(diag, 'cqw', cqw) + call mpas_pool_get_array_gpu(diag, 'cqu', cqu) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -4118,15 +4282,15 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'moist_start', moist_start) call mpas_pool_get_dimension(state, 'moist_end', moist_end) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) - call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) - call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) - call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - call mpas_pool_get_array(mesh, 'cf1', cf1) - call mpas_pool_get_array(mesh, 'cf2', cf2) - call mpas_pool_get_array(mesh, 'cf3', cf3) + call mpas_pool_get_array_gpu(mesh, 'cf1', cf1) + call mpas_pool_get_array_gpu(mesh, 'cf2', cf2) + call mpas_pool_get_array_gpu(mesh, 'cf3', cf3) ! ! rthdynten is currently associated with packages, and if those packages @@ -4139,8 +4303,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, rthdynten(:,nCells+1) = 0.0_RKIND inactive_rthdynten = .true. end if + + if(rk_step == 1) then - call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & + call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & @@ -4151,13 +4317,38 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & tend_rtheta_adv, rthdynten, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + + + else + call atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & + fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & + weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & + h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & + latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + tend_rtheta_adv, rthdynten, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + + end if + if (inactive_rthdynten) then deallocate(rthdynten) end if @@ -4165,6 +4356,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, end subroutine atm_compute_dyn_tend + subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & @@ -4176,7 +4368,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & tend_rtheta_adv, rthdynten, & @@ -4285,7 +4477,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_pgf real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy - real (kind=RKIND) :: coef_3rd_order, c_s + real (kind=RKIND) :: coef_3rd_order, c_s, smdiv logical :: config_mix_full character (len=StrKIND) :: config_horiz_mixing real (kind=RKIND) :: config_del4u_div_factor @@ -4305,24 +4497,26 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - ! + ! ! Local variables ! integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq, iAdvCell !real (kind=RKIND), parameter :: c_s = 0.125 - real (kind=RKIND), dimension( nVertLevels+1 ) :: d_diag, d_off_diag, flux_arr - real (kind=RKIND), dimension( nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx - real (kind=RKIND), dimension( nVertLevels ) :: ru_edge_w, q, u_mix + real (kind=RKIND), dimension( 64 ) :: d_diag, d_off_diag, flux_arr, ru_edge_w, tend_wk, delsq_wk, wduz, wdwz, wdtz, we_w, u_mix, h_wk + integer, dimension(15) :: iadv_cell_w + integer, dimension(64) :: eoe_w + real (kind=RKIND), dimension(15) :: coefs_w, coefs_3rd_w + real (kind=RKIND), dimension( nVertLevels + 1 ) :: dpzx real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r real (kind=RKIND) :: scalar_weight real (kind=RKIND) :: inv_r_earth - real (kind=RKIND) :: invDt, flux, workpv + real (kind=RKIND) :: invDt, flux, workpv, tendk real (kind=RKIND) :: edge_sign, pr_scale, r_dc, r_dv, u_mix_scale real (kind=RKIND) :: h_mom_eddy_visc4, v_mom_eddy_visc2 real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 - real (kind=RKIND) :: u_diffusion + real (kind=RKIND) :: u_diffusion, t_w, q1, q2 real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp @@ -4345,38 +4539,66 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm v_mom_eddy_visc2 = config_v_mom_eddy_visc2 v_theta_eddy_visc2 = config_v_theta_eddy_visc2 + rgas_cprcv = rgas*cp/cv + + +!$acc data present(kdiff, h_divergence, dpdz, tend_rho, tend_u_euler, & +!$acc tend_u, delsq_u, delsq_vorticity, delsq_divergence, & +!$acc tend_w, delsq_w, tend_w_euler, tend_theta, & +!$acc delsq_theta, tend_theta_euler, & +!$acc defc_a, defc_b, edgesoncell, nedgesoncell, u, v, & +!$acc dvedge, edgesoncell_sign, invareacell, ru, qtot, rb, rdzw, rr_save, rw, & +!$acc tend_rho_physics, cellsonedge, cqu, invdcedge, pp, zxu, zz, & +!$acc fzm, fzp, edgesonedge, ke, nedgesonedge, pv_edge, rho_edge, weightsonedge, & +!$acc divergence, invdvedge, meshscalingdel2, verticesonedge, vorticity, & +!$acc dcedge, edgesonvertex, edgesonvertex_sign, invareatriangle, & +!$acc meshscalingdel4, zgrid, angleedge, u_init, tend_ru_physics, adv_coefs, & +!$acc adv_coefs_3rd, advcellsforedge, nadvcellsforedge, w, cqw, rdzu, rho_zz, & +!$acc theta_m, theta_m_save, rt_diabatic_tend, tend_rtheta_physics, t_init, & +!$acc rw_save,tend_rtheta_adv) & +!$acc copy(rthdynten) - if (rk_step == 1) then - -! tend_u_euler(1:nVertLevels,edgeStart:edgeEnd) = 0.0 ! Smagorinsky eddy viscosity, based on horizontal deformation (in this case on model coordinate surfaces). ! The integration coefficients were precomputed and stored in defc_a and defc_b - - if(config_horiz_mixing == "2d_smagorinsky") then - do iCell = cellStart,cellEnd - d_diag(1:nVertLevels) = 0.0 - d_off_diag(1:nVertLevels) = 0.0 - do iEdge=1,nEdgesOnCell(iCell) - do k=1,nVertLevels - d_diag(k) = d_diag(k) + defc_a(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - end do +!!$acc kernels + +if (config_horiz_mixing == "2d_smagorinsky") then +!$acc parallel vector_length(64) +!$acc loop gang private(d_diag,d_off_diag) + do iCell = cellStart,cellEnd +!$acc cache(d_diag) +!$acc cache(d_off_diag) +!$acc loop vector + do k=1,nVertLevels + d_diag(k) = 0.0 + d_off_diag(k) = 0.0 + end do +!$acc loop seq + do iEdge=1,nEdgesOnCell(iCell) +!$acc loop vector + do k=1,nVertLevels + d_diag(k) = d_diag(k) + defc_a(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) end do + end do !DIR$ IVDEP - do k=1, nVertLevels - ! here is the Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity - kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) - end do +!$acc loop vector + do k=1, nVertLevels + kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) end do + end do + + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 +!$acc end parallel - else if(config_horiz_mixing == "2d_fixed") then + end if + ! else + if(config_horiz_mixing == "2d_fixed") then kdiff(1:nVertLevels,cellStart:cellEnd) = config_h_theta_eddy_visc2 h_mom_eddy_visc4 = config_h_mom_eddy_visc4 @@ -4384,51 +4606,57 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if - end if ! tendency for density. ! accumulate total water here for later use in w tendency calculation. ! accumulate horizontal mass-flux - do iCell=cellStart,cellEnd - h_divergence(1:nVertLevels,iCell) = 0.0 +!$acc parallel vector_length(64) +!$acc loop gang private(h_wk) + do iCell=cellStart,cellEnd +!$acc cache(h_wk) +!$acc loop vector + do k=1,nVertLevels + h_wk(k) = 0.0 + end do +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - h_divergence(k,iCell) = h_divergence(k,iCell) + edge_sign * ru(k,iEdge) + h_wk(k) = h_wk(k) + edge_sign * ru(k,iEdge) end do end do - end do - - ! compute horiontal mass-flux divergence, add vertical mass flux divergence to complete tend_rho - - do iCell = cellStart,cellEnd - r = invAreaCell(iCell) - do k = 1,nVertLevels - h_divergence(k,iCell) = h_divergence(k,iCell) * r +!$acc loop vector + do k=1,nVertLevels + r = invAreaCell(iCell) + h_divergence(k,iCell) = h_wk(k) * r end do - end do + end do +!$acc end parallel ! ! dp / dz and tend_rho ! ! only needed on first rk_step with pert variables defined a pert from time t ! - if(rk_step == 1) then - rgas_cprcv = rgas*cp/cv - do iCell = cellStart,cellEnd + ! rgas_cprcv = rgas*cp/cv +!$acc parallel vector_length(64) +!$acc loop gang + do iCell = cellStart,cellEnd !DIR$ IVDEP +!$acc loop vector do k = 1,nVertLevels tend_rho(k,iCell) = -h_divergence(k,iCell)-rdzw(k)*(rw(k+1,iCell)-rw(k,iCell)) + tend_rho_physics(k,iCell) dpdz(k,iCell) = -gravity*(rb(k,iCell)*(qtot(k,iCell)) + rr_save(k,iCell)*(1.+qtot(k,iCell))) end do end do - end if +!$acc end parallel !$OMP BARRIER @@ -4436,73 +4664,66 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Compute u (normal) velocity tendency for each edge (cell face) ! +!$acc parallel vector_length(64) +!$acc loop gang private(wduz, tend_wk, eoe_w, we_w) do iEdge=edgeSolveStart,edgeSolveEnd +!$acc cache(tend_wk) +!$acc cache(wduz) +!$acc cache(eoe_w) +!$acc cache(we_w) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) ! horizontal pressure gradient - - if(rk_step == 1) then -!DIR$ IVDEP - do k=1,nVertLevels - tend_u_euler(k,iEdge) = - cqu(k,iEdge)*( (pp(k,cell2)-pp(k,cell1))*invDcEdge(iEdge)/(.5*(zz(k,cell2)+zz(k,cell1))) & - -0.5*zxu(k,iEdge)*(dpdz(k,cell1)+dpdz(k,cell2)) ) - end do - - end if - - ! vertical transport of u - - wduz(1) = 0. - - k = 2 - wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) - do k=3,nVertLevels-1 - wduz(k) = flux3( u(k-2,iEdge),u(k-1,iEdge),u(k,iEdge),u(k+1,iEdge),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) - end do - k = nVertLevels - wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) - - wduz(nVertLevels+1) = 0. - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - tend_u(k,iEdge) = - rdzw(k)*(wduz(k+1)-wduz(k)) ! first use of tend_u + tend_u_euler(k,iEdge) = - cqu(k,iEdge) * & + ( (pp(k,cell2)-pp(k,cell1))*invDcEdge(iEdge)/ & + (.5*(zz(k,cell2)+zz(k,cell1))) & + -0.5*zxu(k,iEdge)*(dpdz(k,cell1)+dpdz(k,cell2)) ) + tend_wk(k) = u(k,iEdge) end do - ! Next, nonlinear Coriolis term (q) following Ringler et al JCP 2009 +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wduz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*tend_wk(k)+fzp(k)*tend_wk(k-1)) + end do +!$acc loop vector + do k=3,nVertLevels-1 + wduz(k) = flux3( tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) + end do - q(:) = 0.0 +!$acc loop vector shortloop do j = 1,nEdgesOnEdge(iEdge) - eoe = edgesOnEdge(j,iEdge) - do k=1,nVertLevels - workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe)) -! the original definition of pv_edge had a factor of 1/density. We have removed that factor -! given that it was not integral to any conservation property of the system - q(k) = q(k) + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv - end do + eoe_w(j) = edgesOnEdge(j,iEdge) + we_w(j) = weightsOnEdge(j,iEdge) end do !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - - ! horizontal ke gradient and vorticity terms in the vector invariant formulation - ! of the horizontal momentum equation - tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(k,iEdge)* (q(k) - (ke(k,cell2) - ke(k,cell1)) & - * invDcEdge(iEdge)) & - - u(k,iEdge)*0.5*(h_divergence(k,cell1)+h_divergence(k,cell2)) -#ifdef CURVATURE - ! curvature terms for the sphere - tend_u(k,iEdge) = tend_u(k,iEdge) & - - 2.*omega*cos(angleEdge(iEdge))*cos(latEdge(iEdge)) & - *rho_edge(k,iEdge)*.25*(w(k,cell1)+w(k+1,cell1)+w(k,cell2)+w(k+1,cell2)) & - - u(k,iEdge)*.25*(w(k+1,cell1)+w(k,cell1)+w(k,cell2)+w(k+1,cell2)) & - *rho_edge(k,iEdge) * inv_r_earth -#endif + q1 = pv_edge(k,iEdge) + q2 = 0.0 +!$acc loop seq + do j = 1,nEdgesOnEdge(iEdge) + eoe = eoe_w(j) + workpv = 0.5 * (q1 + pv_edge(k,eoe)) + q2 = q2 + we_w(j) * u(k,eoe) * workpv + end do + t_w = - rdzw(k)*(wduz(k+1)-wduz(k)) + tend_u(k,iEdge) = t_w + rho_edge(k,iEdge) * & + (q2 - (ke(k,cell2) - ke(k,cell1)) * & + invDcEdge(iEdge)) - tend_wk(k) * 0.5 * & + (h_divergence(k,cell1)+h_divergence(k,cell2)) end do - end do +!$acc end parallel ! @@ -4511,15 +4732,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! first Runge-Kutta substep and saved for use in later RK substeps 2 and 3. ! - if (rk_step == 1) then !$OMP BARRIER ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). ! First, storage to hold the result from the first del^2 computation. - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -4527,16 +4747,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm vertex2 = verticesOnEdge(2,iEdge) r_dc = invDcEdge(iEdge) r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + delsq_u(k,iEdge) = u_diffusion kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) @@ -4546,36 +4764,64 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do +!$acc end parallel - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - + if (h_mom_eddy_visc4 > 0.0) then !$OMP BARRIER - +!$acc parallel vector_length(64) +!$acc loop gang private(delsq_wk) do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 - do i=1,vertexDegree +!$acc cache(delsq_wk) +!$acc loop vector + do k=1,nVertLevels + delsq_wk(k) = 0.0 + end do +!$acc loop seq + do i=1,vertexDegree iEdge = edgesOnVertex(i,iVertex) edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) +!$acc loop vector do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) + delsq_wk(k) = delsq_wk(k) + edge_sign * delsq_u(k,iEdge) end do end do +!$acc loop vector + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_wk(k) + end do end do +!$acc end parallel +!$acc parallel vector_length(64) +!$acc loop gang private(delsq_wk) do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 +!$acc cache(delsq_wk) +!$acc loop vector + do k=1,nVertLevels + delsq_wk(k) = 0.0 + end do r = invAreaCell(iCell) +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) +!$acc loop vector do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) + delsq_wk(k) = delsq_wk(k) + edge_sign * delsq_u(k,iEdge) end do end do +!$acc loop vector + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_wk(k) + end do end do +!$acc end parallel + end if + if (h_mom_eddy_visc4 > 0.0) then !$OMP BARRIER - +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -4587,6 +4833,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity @@ -4596,27 +4843,28 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! relative to the rotational part. The stability constraint on the divergence component is much less ! stringent than the rotational part, and this flexibility may be useful. ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - end do end do - - end if ! 4th order mixing is active +!$acc end parallel + end if ! ! vertical mixing for u - 2nd order filter in physical (z) space ! if ( v_mom_eddy_visc2 > 0.0 ) then - if (config_mix_full) then ! mix full state +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) +!$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -4633,22 +4881,27 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) end do end do +!$acc end parallel + end if - else ! idealized cases where we mix on the perturbation from the initial 1-D state - + if (.not. config_mix_full) then ! mix full state + !else ! idealized cases where we mix on the perturbation from the initial 1-D state +!$acc parallel vector_length(64) +!$acc loop gang private(u_mix) do iEdge=edgeSolveStart,edgeSolveEnd +!$acc cache(u_mix) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) +!$acc loop vector do k=1,nVertLevels -#ifdef ROTATED_GRID - u_mix(k) = u(k,iEdge) - u_init(k) * sin( angleEdge(iEdge) ) -#else + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) -#endif + end do +!$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -4666,23 +4919,25 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do +!$acc end parallel end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum - end if ! (rk_step 1 test for computing mixing terms) !$OMP BARRIER ! add in mixing for u +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeSolveStart,edgeSolveEnd !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels -! tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) - tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) + tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) end do end do +!$acc end parallel !----------- rhs for w @@ -4692,58 +4947,74 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! horizontal advection for w ! +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - tend_w(1:nVertLevels+1,iCell) = 0.0 +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) - edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * 0.5 - +!$acc loop vector do k=2,nVertLevels ru_edge_w(k) = fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) end do - flux_arr(1:nVertLevels) = 0.0 +!$acc loop vector + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop vector + do k=1,nVertLevels + flux_arr(k) = 0.0 + end do - ! flux_arr stores the value of w at the cell edge used in the horizontal transport + ! flux_arr stores the value of w at the cell edge used in the + ! horizontal transport +!$acc loop seq do j=1,nAdvCellsForEdge(iEdge) - iAdvCell = advCellsForEdge(j,iEdge) +!$acc loop vector do k=2,nVertLevels - scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,ru_edge_w(k)) * adv_coefs_3rd(j,iEdge) + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k)) * coefs_3rd_w(j) flux_arr(k) = flux_arr(k) + scalar_weight * w(k,iAdvCell) end do end do !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) - edgesOnCell_sign(i,iCell) * ru_edge_w(k)*flux_arr(k) + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell)*ru_edge_w(k)*flux_arr(k) end do - end do - end do -#ifdef CURVATURE - do iCell = cellSolveStart, cellSolveEnd !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) + (rho_zz(k,iCell)*fzm(k)+rho_zz(k-1,iCell)*fzp(k))* & - ( (fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell))**2. & - +(fzm(k)*vr_cell(k,iCell)+fzp(k)*vr_cell(k-1,iCell))**2. )/r_earth & - + 2.*omega*cos(latCell(iCell)) & - *(fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell)) & - *(rho_zz(k,iCell)*fzm(k)+rho_zz(k-1,iCell)*fzp(k)) - + tend_w(k,iCell) = tend_wk(k) end do end do -#endif - +!$acc end parallel ! ! horizontal mixing for w - we could combine this with advection directly (i.e. as a turbulent flux), ! but here we can also code in hyperdiffusion if we wish (2nd order at present) ! - if (rk_step == 1) then ! !OMP BARRIER why is this openmp barrier here??? @@ -4752,12 +5023,21 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. - - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 - +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, delsq_wk) do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 +!$acc cache(tend_wk) +!$acc cache(delsq_wk) + r_areaCell = invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels+1 + delsq_wk(k) = 0.0 + tend_wk(k) = 0.0 + end do + +! BDL could do something here with edgesOnCell and edgesOnCell_sign +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -4767,41 +5047,60 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_wk(k) = delsq_wk(k) + w_turb_flux w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + tend_wk(k) = tend_wk(k) + w_turb_flux end do end do +!$acc loop vector + do k=1,nVertLevels + delsq_w(k,iCell) = delsq_wk(k) + tend_w_euler(k,iCell) = tend_wk(k) + end do end do +!$acc end parallel -!$OMP BARRIER - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active +!$OMP BARRIER - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + if(h_mom_eddy_visc4 > 0.0) then +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(tend_wk) + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels + tend_wk(k) = tend_w_euler(k,iCell) + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do - +!$acc loop vector + do k=2,nVertLevels + tend_wk(k) = tend_wk(k) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) end do - end do - - end if ! 4th order mixing is active + end do +!$acc loop vector + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel end if ! horizontal mixing for w computed in first rk_step + ! Note for OpenMP parallelization: We could avoid allocating the delsq_w scratch ! array, and just use the delsq_theta array as was previously done; however, ! particularly when oversubscribing cores with threads, there is the risk that @@ -4813,257 +5112,1370 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! vertical advection, pressure gradient and buoyancy for w ! +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, wdwz) do iCell=cellSolveStart,cellSolveEnd - wdwz(1) = 0.0 +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = w(k,iCell) + end do - k = 2 - wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell)) +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdwz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wdwz(k) = 0.25*(rw(k,iCell)+rw(k-1,iCell))*(tend_wk(k)+tend_wk(k-1)) + end do +!$acc loop vector do k=3,nVertLevels-1 - wdwz(k) = flux3( w(k-2,iCell),w(k-1,iCell),w(k,iCell),w(k+1,iCell),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND ) + wdwz(k) = flux3(tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND ) end do - k = nVertLevels - wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell)) - - wdwz(nVertLevels+1) = 0.0 - - ! Note: next we are also dividing through by the cell area after the horizontal flux divergence !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) -rdzu(k)*(wdwz(k+1)-wdwz(k)) + tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) - rdzu(k)*(wdwz(k+1)-wdwz(k)) end do - if(rk_step == 1) then !DIR$ IVDEP - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - cqw(k,iCell)*( & +!$acc loop vector + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - cqw(k,iCell)*( & rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) & - (fzm(k)*dpdz(k,iCell) + fzp(k)*dpdz(k-1,iCell)) ) ! dpdz is the buoyancy term here. end do - end if - end do - - if (rk_step == 1) then +!$acc end parallel if ( v_mom_eddy_visc2 > 0.0 ) then - +!$acc parallel vector_length(64) +!$acc loop gang do iCell=cellSolveStart,cellSolveEnd !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) end do end do - +!$acc end parallel end if - end if ! mixing term computed first rk_step +!$acc parallel vector_length(64) +!$acc loop gang + do iCell = cellSolveStart,cellSolveEnd +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) + end do + end do +!$acc end parallel + +!----------- rhs for theta + + ! + ! horizontal advection for theta + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + +!$acc loop vector + do k=1,nVertLevels + ru_edge_w(k) = ru(k,iEdge) + flux_arr(k) = 0.0 + end do + +!$acc loop vector shortloop + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) +!$acc loop vector + do k=1,nVertLevels + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k))*coefs_3rd_w(j) + flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iAdvCell) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell) * ru_edge_w(k) * flux_arr(k) + end do + + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + + ! + ! horizontal mixing for theta_m - we could combine this with advection directly (i.e. as a turbulent flux), + ! but here we can also code in hyperdiffusion if we wish (2nd order at present) + ! +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, delsq_wk) + do iCell=cellStart,cellEnd +!$acc cache(tend_wk) +!$acc cache(delsq_wk) + + r_areaCell = invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels + delsq_wk(k) = 0.0 + tend_wk(k) = 0.0 + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP +!$acc loop vector + do k = 1, nVertLevels + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_wk(k) = delsq_wk(k) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale + tend_wk(k) = tend_wk(k) + theta_turb_flux + end do + end do +!DIR$ IVDEP +!$acc loop vector + do k = 1, nVertLevels + delsq_theta(k,iCell) = delsq_wk(k) + tend_theta_euler(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + + +!$OMP BARRIER + + if(h_theta_eddy_visc4 > 0.0) then +!$acc parallel vector_length(64) private(tend_wk) +!$acc loop gang + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(tend_wk) + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels + tend_wk(k) = tend_theta_euler(k,iCell) + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_wk(k) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + + end do +!$acc loop vector + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + end if ! theta mixing calculated first rk_step + + + ! + ! vertical advection plus diabatic term + ! Note: we are also dividing through by the cell area after the horizontal flux divergence + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(wdtz) + do iCell = cellSolveStart,cellSolveEnd +!$acc cache(wdtz) + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdtz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + if (k.eq.2) then + wdtz(k) = rw(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) + wdtz(k) = wdtz(k)+(rw_save(k,icell)-rw(k,icell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) + else + wdtz(k) = rw_save(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) !rtheta_pp redefinition + end if + end do +!$acc loop vector + do k=3,nVertLevels-1 + wdtz(k) = flux3( theta_m(k-2,iCell),theta_m(k-1,iCell),theta_m(k,iCell),theta_m(k+1,iCell), rw(k,iCell), coef_3rd_order ) + wdtz(k) = wdtz(k) + (rw_save(k,icell)-rw(k,iCell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) ! rtheta_pp redefinition + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) + tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme + rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme + tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) + end do + end do +!$acc end parallel + + ! + ! vertical mixing for theta - 2nd order + ! + + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m +!$acc parallel num_gangs(256) num_workers(4) vector_length(32) + if (config_mix_full) then +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + end if +!$acc end parallel + +!$acc parallel num_gangs(256) num_workers(4) vector_length(32) + if (.not.config_mix_full) then + !else ! idealized cases where we mix on the perturbation from the initial 1-D state +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do - ! add in mixing terms for w + end if +!$acc end parallel + end if +!$acc parallel vector_length(64) +!$acc loop gang do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP - do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) + end do + end do +!$acc end parallel +!$acc end data + end subroutine atm_compute_dyn_tend_work + + subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels_dummy, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end, & + fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & + weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & + h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & + latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + tend_rtheta_adv, rthdynten, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + + USE mpas_atm_dimensions + + + implicit none + + + ! + ! Dummy arguments + ! + integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end + + real (kind=RKIND), dimension(nEdges+1) :: fEdge + real (kind=RKIND), dimension(nEdges+1) :: dvEdge + real (kind=RKIND), dimension(nEdges+1) :: dcEdge + real (kind=RKIND), dimension(nEdges+1) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1) :: invDvEdge + real (kind=RKIND), dimension(nCells+1) :: invAreaCell + real (kind=RKIND), dimension(nVertices+1) :: invAreaTriangle + real (kind=RKIND), dimension(nEdges+1) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1) :: meshScalingDel4 + real (kind=RKIND), dimension(maxEdges2,nEdges+1) :: weightsOnEdge + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: zgrid + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: rho_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: ru + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: v + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: tend_u + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rho + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rt_diabatic_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_theta + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: cqw + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rb + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rr + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: pp + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: pressure_b + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: zxu + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff + real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: ru_save + + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m_save + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: exner + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rr_save + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: tend_u_euler + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_euler + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_theta_euler + real (kind=RKIND), dimension(15,2,nEdges+1) :: deriv_two + integer, dimension(2,nEdges+1) :: cellsOnEdge + integer, dimension(2,nEdges+1) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1) :: edgesOnCell + integer, dimension(maxEdges2,nEdges+1) :: edgesOnEdge + integer, dimension(maxEdges,nCells+1) :: cellsOnCell + integer, dimension(vertexDegree,nVertices+1) :: edgesOnVertex + integer, dimension(nCells+1) :: nEdgesOnCell + integer, dimension(nEdges+1) :: nEdgesOnEdge + real (kind=RKIND), dimension(nCells+1) :: latCell + real (kind=RKIND), dimension(nEdges+1) :: latEdge + real (kind=RKIND), dimension(nEdges+1) :: angleEdge + real (kind=RKIND), dimension(nVertLevels) :: u_init + + integer, dimension(15,nEdges+1) :: advCellsForEdge + integer, dimension(nEdges+1) :: nAdvCellsForEdge + real (kind=RKIND), dimension(15,nEdges+1) :: adv_coefs + real (kind=RKIND), dimension(15,nEdges+1) :: adv_coefs_3rd + + real (kind=RKIND), dimension(nVertLevels) :: rdzu + real (kind=RKIND), dimension(nVertLevels) :: rdzw + real (kind=RKIND), dimension(nVertLevels) :: fzm + real (kind=RKIND), dimension(nVertLevels) :: fzp + real (kind=RKIND), dimension(nVertLevels) :: qv_init + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: t_init + + real (kind=RKIND) :: cf1, cf2, cf3 + real (kind=RKIND) :: prandtl_inv, r_areaCell, rgas_cprcv + + real (kind=RKIND) :: r_earth + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ur_cell + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: vr_cell + + real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_a + real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_b + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_pgf + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy + + real (kind=RKIND) :: coef_3rd_order, c_s, smdiv + logical :: config_mix_full + character (len=StrKIND) :: config_horiz_mixing + real (kind=RKIND) :: config_del4u_div_factor + real (kind=RKIND) :: config_h_theta_eddy_visc4 + real (kind=RKIND) :: config_h_mom_eddy_visc4 + real (kind=RKIND) :: config_visc4_2dsmag + real (kind=RKIND) :: config_len_disp + real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 + + integer, intent(in) :: rk_step + real (kind=RKIND), intent(in) :: dt + + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rtheta_adv + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rthdynten + + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + + ! + ! Local variables + ! + integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq, iAdvCell + + !real (kind=RKIND), parameter :: c_s = 0.125 + real (kind=RKIND), dimension( 64 ) :: d_diag, d_off_diag,flux_arr1, flux_arr, ru_edge_w, ru_save_temp , tend_wk, delsq_wk, wduz, wdwz, wdtz, we_w, u_mix, h_wk + integer, dimension(15) :: iadv_cell_w + integer, dimension(64) :: eoe_w + real (kind=RKIND), dimension(15) :: coefs_w, coefs_3rd_w + real (kind=RKIND), dimension( nVertLevels + 1 ) :: dpzx + real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r + real (kind=RKIND) :: scalar_weight + real (kind=RKIND) :: inv_r_earth + + real (kind=RKIND) :: invDt, flux, workpv, tendk + real (kind=RKIND) :: edge_sign, pr_scale, r_dc, r_dv, u_mix_scale + real (kind=RKIND) :: h_mom_eddy_visc4, v_mom_eddy_visc2 + real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 + real (kind=RKIND) :: u_diffusion, t_w, q1, q2 + + real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp + + + + real (kind=RKIND) :: flux3, flux4 + real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 + + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & + ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 + + flux3(q_im2, q_im1, q_i, q_ip1, ua, coef3) = & + flux4(q_im2, q_im1, q_i, q_ip1, ua) + & + coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 + + + prandtl_inv = 1.0_RKIND / prandtl + invDt = 1.0_RKIND / dt + inv_r_earth = 1.0_RKIND / r_earth + + v_mom_eddy_visc2 = config_v_mom_eddy_visc2 + v_theta_eddy_visc2 = config_v_theta_eddy_visc2 + +!$acc data present(cellsonedge,dvedge,edgesoncell, & +!$acc tend_ru_physics, & +!$acc tend_rtheta_physics, & +!$acc edgesoncell_sign,fzm,fzp,invareacell,nedgesoncell & +!$acc ,ru,rw,u,edgesonedge, & +!$acc invdcedge,ke,nedgesonedge, & +!$acc pv_edge,rdzw,rho_edge, & +!$acc weightsonedge,adv_coefs,adv_coefs_3rd,advcellsforedge, & +!$acc w,rdzu, tend_w_euler, & +!$acc theta_m,ru_save,theta_m_save,tend_u_euler, & +!$acc nadvcellsforedge,rho_zz, & +!$acc rt_diabatic_tend,rw_save, & +!$acc tend_theta_euler, & +!$acc h_divergence,tend_u, & +!$acc tend_theta,tend_w,& +!$acc tend_rtheta_adv) & +!$acc copy(rthdynten) + + + + + ! tendency for density. + ! accumulate total water here for later use in w tendency calculation. + + ! accumulate horizontal mass-flux +!$acc parallel vector_length(64) +!$acc loop gang private(h_wk) + do iCell=cellStart,cellEnd +!$acc cache(h_wk) +!$acc loop vector + do k=1,nVertLevels + h_wk(k) = 0.0 + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + h_wk(k) = h_wk(k) + edge_sign * ru(k,iEdge) + end do + end do +!$acc loop vector + do k=1,nVertLevels + r = invAreaCell(iCell) + h_divergence(k,iCell) = h_wk(k) * r + end do + end do +!$acc end parallel + + + + ! + ! dp / dz and tend_rho + ! + ! only needed on first rk_step with pert variables defined a pert from time t + ! +!$OMP BARRIER + ! + ! Compute u (normal) velocity tendency for each edge (cell face) + ! +!$acc parallel vector_length(64) +!$acc loop gang private(wduz, tend_wk, eoe_w, we_w) + do iEdge=edgeSolveStart,edgeSolveEnd +!$acc cache(tend_wk) +!$acc cache(wduz) +!$acc cache(eoe_w) +!$acc cache(we_w) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! horizontal pressure gradient +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = u(k,iEdge) + end do + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wduz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*tend_wk(k)+fzp(k)*tend_wk(k-1)) + end do +!$acc loop vector + do k=3,nVertLevels-1 + wduz(k) = flux3( tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) + end do + +!$acc loop vector shortloop + do j = 1,nEdgesOnEdge(iEdge) + eoe_w(j) = edgesOnEdge(j,iEdge) + we_w(j) = weightsOnEdge(j,iEdge) + end do + +!$acc loop vector + do k=1,nVertLevels + q1 = pv_edge(k,iEdge) + q2 = 0.0 +!$acc loop seq + do j = 1,nEdgesOnEdge(iEdge) + eoe = eoe_w(j) + workpv = 0.5 * (q1 + pv_edge(k,eoe)) + q2 = q2 + we_w(j) * u(k,eoe) * workpv + end do + t_w = - rdzw(k)*(wduz(k+1)-wduz(k)) + tend_u(k,iEdge) = t_w + rho_edge(k,iEdge) * & + (q2 - (ke(k,cell2) - ke(k,cell1)) * & + invDcEdge(iEdge)) - tend_wk(k) * 0.5 * & + (h_divergence(k,cell1)+h_divergence(k,cell2)) + end do + end do +!$acc end parallel + +!$acc parallel vector_length(64) +!$acc loop gang + do iEdge=edgeSolveStart,edgeSolveEnd +!$acc loop vector + do k=1,nVertLevels + tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) + end do + end do +!$acc end parallel + + ! mixing terms are integrated using forward-Euler, so this tendency is only computed in the + ! first Runge-Kutta substep and saved for use in later RK substeps 2 and 3. + ! + + +!$OMP BARRIER + +! add in mixing for u + + +!----------- rhs for w + + + ! + ! horizontal advection for w + ! +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) +!$acc loop vector + do k=2,nVertLevels + ru_edge_w(k) = fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) + end do + +!$acc loop vector + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop vector + do k=1,nVertLevels + flux_arr(k) = 0.0 + end do + + ! flux_arr stores the value of w at the cell edge used in the + ! horizontal transport + +!$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) +!$acc loop vector + do k=2,nVertLevels + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k)) * coefs_3rd_w(j) + flux_arr(k) = flux_arr(k) + scalar_weight * w(k,iAdvCell) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell)*ru_edge_w(k)*flux_arr(k) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_w(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + + + + ! + ! horizontal mixing for w - we could combine this with advection directly (i.e. as a turbulent flux), + ! but here we can also code in hyperdiffusion if we wish (2nd order at present) + ! + + +! Note for OpenMP parallelization: We could avoid allocating the delsq_w scratch +! array, and just use the delsq_theta array as was previously done; however, +! particularly when oversubscribing cores with threads, there is the risk that +! some threads may reach code further below that re-uses the delsq_theta array, +! in which case we would need a barrier somewhere between here and that code +! below to ensure correct behavior. + + ! + ! vertical advection, pressure gradient and buoyancy for w + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, wdwz) + do iCell=cellSolveStart,cellSolveEnd + +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = w(k,iCell) + end do + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdwz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wdwz(k) = 0.25*(rw(k,iCell)+rw(k-1,iCell))*(tend_wk(k)+tend_wk(k-1)) + end do +!$acc loop vector + do k=3,nVertLevels-1 + wdwz(k) = flux3(tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND ) + end do + +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) - rdzu(k)*(wdwz(k+1)-wdwz(k)) + end do + end do +!$acc end parallel + +!$acc parallel vector_length(64) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) + end do + end do +!$acc end parallel + + +!----------- rhs for theta + + ! + ! horizontal advection for theta + ! +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + +!$acc loop vector + do k=1,nVertLevels + ru_edge_w(k) = ru(k,iEdge) + flux_arr(k) = 0.0 + end do + +!$acc loop vector shortloop + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) +!$acc loop vector + do k=1,nVertLevels + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k))*coefs_3rd_w(j) + flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iAdvCell) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell) * ru_edge_w(k) * flux_arr(k) + end do + + end do + +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel +! addition to pick up perturbation flux for rtheta_pp equation + +!$acc parallel vector_length(64) +!$acc loop gang private(flux_arr1,tend_wk, ru_edge_w,ru_save_temp) + do iCell=cellSolveStart,cellSolveEnd +!$acc cache(ru_edge_w) +!$acc cache(flux_arr1) +!$acc cache(ru_save_temp) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_theta(k,iCell) + end do + +!$acc loop vector + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!$acc loop vector + do k=1,nVertLevels + ru_edge_w(k) = ru(k,iEdge) + ru_save_temp(k) = ru_save(k,iEdge) + flux_arr1(k) = 0.0 + end do +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + flux_arr1(k) = edgesOnCell_sign(i,iCell)*dvEdge(iEdge)*(ru_save_temp(k)-ru_edge_w(k))*0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) + !flux_arr1(k) = edgesOnCell_sign(i,iCell) *dvEdge(iEdge)*(ru_save(k,iCell)-ru_edge_w(k)) & + ! *0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) + end do +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels +! tend_theta(k,iCell) = tend_theta(k,iCell)-flux_arr1(k) ! division by areaCell picked up down below + tend_wk(k) = tend_wk(k)-flux_arr1(k) + end do + end do +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_wk(k) + end do + + end do +!$acc end parallel + + ! + ! horizontal mixing for theta_m - we could combine this with advection directly (i.e. as a turbulent flux), + ! but here we can also code in hyperdiffusion if we wish (2nd order at present) + ! vertical advection plus diabatic term + ! Note: we are also dividing through by the cell area after the horizontal flux divergence + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(wdtz) + do iCell = cellSolveStart,cellSolveEnd +!$acc cache(wdtz) + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdtz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + if (k.eq.2) then + wdtz(k) = rw(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) + wdtz(k) = wdtz(k)+(rw_save(k,icell)-rw(k,icell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) + else + wdtz(k) = rw_save(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) !rtheta_pp redefinition + end if + end do +!$acc loop vector + do k=3,nVertLevels-1 + wdtz(k) = flux3( theta_m(k-2,iCell),theta_m(k-1,iCell),theta_m(k,iCell),theta_m(k+1,iCell), rw(k,iCell), coef_3rd_order ) + wdtz(k) = wdtz(k) + (rw_save(k,icell)-rw(k,iCell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell))! rtheta_pp redefinition + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) + tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme + rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme + tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) + tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) + end do + end do +!$acc end parallel + +!$acc end data + end subroutine atm_compute_dyn_tend_work_rk23 + + + subroutine atm_compute_solve_diagnostics_gpu(dt, state, time_lev, diag, mesh, configs, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + rk_step ) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Compute diagnostic fields used in the tendency computations + ! + ! Input: state (s), grid - grid metadata + ! + ! Output: diag - computed diagnostics + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + implicit none + + real (kind=RKIND), intent(in) :: dt + type (mpas_pool_type), intent(inout) :: state + integer, intent(in) :: time_lev ! which time level of state to use + integer, intent(in), optional :: rk_step ! which rk_step + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + + + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree + real (kind=RKIND), dimension(:), pointer :: fVertex, fEdge, invAreaTriangle, invAreaCell + real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, invDvEdge, invDcEdge + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, & + vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, & + divergence + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, & + kiteForCell, verticesOnCell + real (kind=RKIND), dimension(:,:), pointer :: edgesOnVertex_sign, edgesOnCell_sign + integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge + + real (kind=RKIND), pointer :: config_apvm_upwinding + + + call mpas_pool_get_config(configs, 'config_apvm_upwinding', config_apvm_upwinding) + + call mpas_pool_get_array_gpu(state, 'rho_zz', h, time_lev) + call mpas_pool_get_array_gpu(state, 'u', u, time_lev) + + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(diag, 'rho_edge', h_edge) + call mpas_pool_get_array_gpu(diag, 'vorticity', vorticity) + call mpas_pool_get_array_gpu(diag, 'divergence', divergence) + call mpas_pool_get_array_gpu(diag, 'ke', ke) + call mpas_pool_get_array_gpu(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array_gpu(diag, 'pv_vertex', pv_vertex) + call mpas_pool_get_array_gpu(diag, 'pv_cell', pv_cell) + call mpas_pool_get_array_gpu(diag, 'gradPVn', gradPVn) + call mpas_pool_get_array_gpu(diag, 'gradPVt', gradPVt) + + call mpas_pool_get_array_gpu(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array_gpu(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'kiteForCell', kiteForCell) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array_gpu(mesh, 'fVertex', fVertex) + call mpas_pool_get_array_gpu(mesh, 'fEdge', fEdge) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) + + call atm_compute_solve_diagnostics_work_gpu(nCells, nEdges, nVertices, & + vertexDegree, dt, config_apvm_upwinding, & + fVertex, fEdge, invAreaTriangle, invAreaCell, dvEdge, dcEdge, invDvEdge, invDcEdge, & + weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, vorticity, ke, pv_edge, pv_vertex, pv_cell, & + gradPVn, gradPVt, divergence, cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, & + edgesOnVertex, kiteForCell, verticesOnCell, edgesOnVertex_sign, edgesOnCell_sign, nEdgesOnCell, nEdgesOnEdge, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + rk_step) + + end subroutine atm_compute_solve_diagnostics_gpu + + + subroutine atm_compute_solve_diagnostics_work_gpu(nCells, nEdges, nVertices, & + vertexDegree, dt, config_apvm_upwinding, & + fVertex, fEdge, invAreaTriangle, invAreaCell, dvEdge, dcEdge, invDvEdge, invDcEdge, & + weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, vorticity, ke, pv_edge, pv_vertex, pv_cell, & + gradPVn, gradPVt, divergence, cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, & + edgesOnVertex, kiteForCell, verticesOnCell, edgesOnVertex_sign, edgesOnCell_sign, nEdgesOnCell, nEdgesOnEdge, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + rk_step) + + use mpas_atm_dimensions + + implicit none + + ! + ! Dummy arguments + ! + integer, intent(in) :: nCells, nEdges, nVertices, vertexDegree + real (kind=RKIND), intent(in) :: dt, config_apvm_upwinding + real (kind=RKIND), dimension(nVertices+1) :: fVertex + real (kind=RKIND), dimension(nEdges+1) :: fEdge + real (kind=RKIND), dimension(nVertices+1) :: invAreaTriangle + real (kind=RKIND), dimension(nCells+1) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1) :: dvEdge + real (kind=RKIND), dimension(nEdges+1) :: dcEdge + real (kind=RKIND), dimension(nEdges+1) :: invDvEdge + real (kind=RKIND), dimension(nEdges+1) :: invDcEdge + real (kind=RKIND), dimension(maxEdges2,nEdges+1) :: weightsOnEdge + real (kind=RKIND), dimension(3,nVertices+1) :: kiteAreasOnVertex + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: h_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: v + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: pv_vertex + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: pv_cell + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: gradPVn + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: gradPVt + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence + integer, dimension(2,nEdges+1) :: cellsOnEdge + integer, dimension(3,nVertices+1) :: cellsOnVertex + integer, dimension(2,nEdges+1) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1) :: edgesOnCell + integer, dimension(maxEdges2,nEdges+1) :: edgesOnEdge + integer, dimension(3,nVertices+1) :: edgesOnVertex + integer, dimension(maxEdges,nCells+1) :: kiteForCell + integer, dimension(maxEdges,nCells+1) :: verticesOnCell + real (kind=RKIND), dimension(3,nVertices+1) :: edgesOnVertex_sign + real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + integer, dimension(nCells+1) :: nEdgesOnCell + integer, dimension(nEdges+1) :: nEdgesOnEdge + + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + + integer, intent(in), optional :: rk_step + + ! + ! Local variables + ! + integer :: iEdge, iCell, iVertex, k, cell1, cell2, eoe, i, j, v1, v2 + real (kind=RKIND) :: h_vertex, r, s + real (kind=RKIND) :: r1, r2, rtemp + + logical, parameter :: hollingsworth=.true. + real (kind=RKIND) :: ke_fact, efac + logical :: reconstruct_v + integer :: temp1,temp2,temp3, gpu_i,gpu_j + + ke_fact = 1.0 - .375 + rtemp = config_apvm_upwinding * dt + +!$acc data present(h_edge, vorticity, divergence, ke, & +!$acc ke_vertex, v, pv_vertex, pv_edge, pv_cell, gradpvn, & +!$acc gradpvt, ke_edge, & +!$acc cellsonedge, dcedge, dvedge, h, u, edgesonvertex, & +!$acc edgesonvertex_sign, invareatriangle, edgesoncell, & +!$acc edgesoncell_sign, invareacell, nedgesoncell, & +!$acc kiteareasonvertex, kiteforcell, verticesoncell, edgesonedge, & +!$acc nedgesonedge, weightsonedge, fvertex, verticesonedge, & +!$acc invdcedge, invdvedge) + + ! + ! Compute height on cell edges at velocity locations + ! +!$acc parallel vector_length(32) +!$acc loop gang + do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + efac = dcEdge(iEdge)*dvEdge(iEdge) + ! efactemp = dcEdge(iEdge) + ! efac = efactemp * efactemp +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2)) + ke_edge(k,iEdge) = efac*u(k,iEdge)**2 + end do + end do +!$acc end parallel + + ! + ! Compute circulation and relative vorticity at each vertex + ! + +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iVertex=vertexStart,vertexEnd +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + vorticity(k,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + s = edgesOnVertex_sign(i,iVertex) * dcEdge(iEdge) + vorticity(k,iVertex) = vorticity(k,iVertex) + s * u(k,iEdge) + end do + vorticity(k,iVertex) = vorticity(k,iVertex) * invAreaTriangle(iVertex) end do end do +!$acc end parallel -!----------- rhs for theta ! - ! horizontal advection for theta + ! Compute the divergence at each cell center ! - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - tend_theta(1:nVertLevels,iCell) = 0.0 +!$acc parallel vector_length(32) +!$acc loop gang + do iCell=cellStart,cellEnd + r = invAreaCell(iCell) +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + divergence(k,iCell) = 0.0 do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) + s = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) + divergence(k,iCell) = divergence(k,iCell) + s * u(k,iEdge) + end do + divergence(k,iCell) = divergence(k,iCell) * r + end do + end do +!$acc end parallel - flux_arr(1:nVertLevels) = 0.0 - - do j=1,nAdvCellsForEdge(iEdge) - iAdvCell = advCellsForEdge(j,iEdge) - do k=1,nVertLevels - scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,ru(k,iEdge))*adv_coefs_3rd(j,iEdge) - flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iAdvCell) - end do - end do +!$OMP BARRIER + ! + ! Compute kinetic energy in each cell (Ringler et al JCP 2009) + ! + ! Replace 2.0 with 2 in exponentiation to avoid outside chance that + ! compiler will actually allow "float raised to float" operation +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iCell=cellStart,cellEnd !DIR$ IVDEP - do k=1,nVertLevels - tend_theta(k,iCell) = tend_theta(k,iCell) - edgesOnCell_sign(i,iCell) * ru(k,iEdge) * flux_arr(k) - end do - +!$acc loop vector + do k=1,nVertLevels + ke(k,iCell) = 0.0 + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + ke(k,iCell) = ke(k,iCell) + 0.25 * ke_edge(k,iEdge) + end do + ke(k,iCell) = ke(k,iCell) * invAreaCell(iCell) end do end do +!$acc end parallel -! addition to pick up perturbation flux for rtheta_pp equation - if(rk_step > 1) then - do iCell=cellSolveStart,cellSolveEnd - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP + if (hollingsworth) then +!$acc parallel vector_length(32) + ! if (hollingsworth) then +!$acc loop gang + do iVertex=vertexStart,vertexEnd + temp1 = EdgesOnVertex(1,iVertex) + temp2 = EdgesOnVertex(2,iVertex) + temp3 = EdgesOnVertex(3,iVertex) + r = 0.25 * invAreaTriangle(iVertex) +!$acc loop vector do k=1,nVertLevels - flux = edgesOnCell_sign(i,iCell)*dvEdge(iEdge)*(ru_save(k,iEdge)-ru(k,iEdge))*0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) - tend_theta(k,iCell) = tend_theta(k,iCell)-flux ! division by areaCell picked up down below + + ke_vertex(k,iVertex) = ( ke_edge(k,temp1)+ke_edge(k,temp2)+ke_edge(k,temp3) )*r end do - end do - end do - end if + end do +!$acc end parallel - ! - ! horizontal mixing for theta_m - we could combine this with advection directly (i.e. as a turbulent flux), - ! but here we can also code in hyperdiffusion if we wish (2nd order at present) - ! +!$OMP BARRIER - if (rk_step == 1) then + ! adjust ke at cell vertices - AG's new KE construction, part 2 + ! - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below +!$acc loop vector + do k=1,nVertLevels + ke(k,iCell) = ke_fact * ke(k,iCell) + end do + end do +!$acc end parallel - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux +!$acc parallel vector_length(32) +!$acc loop gang + do iCell=cellStart,cellEnd +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iVertex = verticesOnCell(i,iCell) + j = kiteForCell(i,iCell) + ke(k,iCell) = ke(k,iCell) + (1.-ke_fact)*kiteAreasOnVertex(j,iVertex) * ke_vertex(k,iVertex) * r end do end do - end do - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + end do +!$acc end parallel + end if - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + ! + ! Compute v (tangential) velocities following Thuburn et al JCP 2009 + ! The tangential velocity is only used to compute the Smagorinsky coefficient - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + reconstruct_v = .true. + if(present(rk_step)) then + if(rk_step /= 3) reconstruct_v = .false. + end if - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do + if (reconstruct_v) then +!$acc parallel vector_length(32) +!$acc loop gang + do iEdge = edgeStart,edgeEnd +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels + v(k,iEdge) = 0.0 + do i=1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(i,iEdge) +! temp = temp + weightsOnEdge(i,iEdge) * u(k, eoe) + v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe) end do +! v(k,iEdge) = temp + end do + end do +!$acc end parallel + end if - end if ! 4th order mixing is active - - end if ! theta mixing calculated first rk_step ! - ! vertical advection plus diabatic term - ! Note: we are also dividing through by the cell area after the horizontal flux divergence + ! Compute height at vertices, pv at vertices, and average pv to edge locations + ! ( this computes pv_vertex at all vertices bounding real cells ) ! - do iCell = cellSolveStart,cellSolveEnd - - wdtz(1) = 0.0 - - k = 2 - wdtz(k) = rw(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) - wdtz(k) = wdtz(k)+(rw_save(k,icell)-rw(k,icell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) - do k=3,nVertLevels-1 - wdtz(k) = flux3( theta_m(k-2,iCell),theta_m(k-1,iCell),theta_m(k,iCell),theta_m(k+1,iCell), rw(k,iCell), coef_3rd_order ) - wdtz(k) = wdtz(k) + (rw_save(k,icell)-rw(k,iCell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) ! rtheta_pp redefinition - end do - k = nVertLevels - wdtz(k) = rw_save(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) ! rtheta_pp redefinition - - wdtz(nVertLevels+1) = 0.0 + ! Avoid dividing h_vertex by areaTriangle and move areaTriangle into + ! numerator for the pv_vertex calculation +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iVertex = vertexStart,vertexEnd !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) - tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme - rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme - tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) + pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) end do end do +!$acc end parallel - ! - ! vertical mixing for theta - 2nd order - ! - - if (rk_step == 1) then - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) +!$OMP BARRIER - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + ! + ! Compute pv at the edges + ! ( this computes pv_edge at all edges bounding real cells ) + ! - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iEdge = edgeStart,edgeEnd +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + pv_edge(k,iEdge) = 0.5 * (pv_vertex(k,verticesOnEdge(1,iEdge)) + pv_vertex(k,verticesOnEdge(2,iEdge))) + end do + end do +!$acc end parallel - else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) + if (config_apvm_upwinding > 0.0) then +!$acc parallel vector_length(32) +!$acc loop gang + do iCell=cellStart,cellEnd +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels + pv_cell(k,iCell) = 0.0 + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iVertex = verticesOnCell(i,iCell) + j = kiteForCell(i,iCell) + pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(j,iVertex) * pv_vertex(k,iVertex) * r + end do + end do + end do +!$acc end parallel - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) +!$OMP BARRIER - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do + ! + ! Modify PV edge with upstream bias. + ! + ! Compute gradient of PV in the tangent direction + ! ( this computes gradPVt at all edges bounding real cells ) + ! + ! Compute gradient of PV in normal direction + ! (tdr: 2009-10-02: this is not correct because the pv_cell in the halo is not correct) + ! + ! Modify PV edge with upstream bias. + ! + ! Merged loops for calculating gradPVt, gradPVn and pv_edge + ! Also precomputed inverses of dvEdge and dcEdge to avoid repeated divisions + ! - end if +!$acc parallel vector_length(32) +!$acc loop gang + do iEdge = edgeStart,edgeEnd + r1 = 1.0_RKIND * invDvEdge(iEdge) + r2 = 1.0_RKIND * invDcEdge(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + v1 = verticesOnEdge(1,iEdge) + v2 = verticesOnEdge(2,iEdge) +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels - end if + gradPVt(k,iEdge) = (pv_vertex(k,v2) - pv_vertex(k,v1)) * r1 + gradPVn(k,iEdge) = (pv_cell(k,cell2) - pv_cell(k,cell1)) * r2 + pv_edge(k,iEdge) = pv_edge(k,iEdge) - rtemp * (v(k,iEdge) * gradPVt(k,iEdge) + u(k,iEdge) * gradPVn(k,iEdge)) - end if ! compute vertical theta mixing on first rk_step - do iCell = cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k=1,nVertLevels -! tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) - tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) + end do end do - end do +!$acc end parallel + end if ! apvm upwinding +!$acc end data + - end subroutine atm_compute_dyn_tend_work + end subroutine atm_compute_solve_diagnostics_work_gpu subroutine atm_compute_solve_diagnostics(dt, state, time_lev, diag, mesh, configs, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -5104,42 +6516,42 @@ subroutine atm_compute_solve_diagnostics(dt, state, time_lev, diag, mesh, config call mpas_pool_get_config(configs, 'config_apvm_upwinding', config_apvm_upwinding) - call mpas_pool_get_array(state, 'rho_zz', h, time_lev) - call mpas_pool_get_array(state, 'u', u, time_lev) - - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(diag, 'rho_edge', h_edge) - call mpas_pool_get_array(diag, 'vorticity', vorticity) - call mpas_pool_get_array(diag, 'divergence', divergence) - call mpas_pool_get_array(diag, 'ke', ke) - call mpas_pool_get_array(diag, 'pv_edge', pv_edge) - call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) - call mpas_pool_get_array(diag, 'pv_cell', pv_cell) - call mpas_pool_get_array(diag, 'gradPVn', gradPVn) - call mpas_pool_get_array(diag, 'gradPVt', gradPVt) - - call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) - call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) - call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) - call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) - call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'kiteForCell', kiteForCell) - call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) - call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) - call mpas_pool_get_array(mesh, 'fVertex', fVertex) - call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array_gpu(state, 'rho_zz', h, time_lev) + call mpas_pool_get_array_gpu(state, 'u', u, time_lev) + + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(diag, 'rho_edge', h_edge) + call mpas_pool_get_array_gpu(diag, 'vorticity', vorticity) + call mpas_pool_get_array_gpu(diag, 'divergence', divergence) + call mpas_pool_get_array_gpu(diag, 'ke', ke) + call mpas_pool_get_array_gpu(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array_gpu(diag, 'pv_vertex', pv_vertex) + call mpas_pool_get_array_gpu(diag, 'pv_cell', pv_cell) + call mpas_pool_get_array_gpu(diag, 'gradPVn', gradPVn) + call mpas_pool_get_array_gpu(diag, 'gradPVt', gradPVt) + + call mpas_pool_get_array_gpu(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array_gpu(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'kiteForCell', kiteForCell) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array_gpu(mesh, 'fVertex', fVertex) + call mpas_pool_get_array_gpu(mesh, 'fEdge', fEdge) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -5519,35 +6931,35 @@ subroutine atm_init_coupled_diagnostics(state, time_lev, diag, mesh, configs, & call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - - call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) - call mpas_pool_get_array(diag, 'theta', theta) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, time_lev) - call mpas_pool_get_array(diag, 'rho', rho) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_base', rho_base) - call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) - call mpas_pool_get_array(diag, 'theta_base', theta_base) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(state, 'scalars', scalars, time_lev) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(state, 'u', u, time_lev) - call mpas_pool_get_array(state, 'w', w, time_lev) - call mpas_pool_get_array(diag, 'pressure_p', pressure_p) - call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'exner_base', exner_base) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'zb', zb) - call mpas_pool_get_array(mesh, 'zb3', zb3) - call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) - call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, time_lev) + call mpas_pool_get_array_gpu(diag, 'theta', theta) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, time_lev) + call mpas_pool_get_array_gpu(diag, 'rho', rho) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_base', rho_base) + call mpas_pool_get_array_gpu(diag, 'rtheta_base', rtheta_base) + call mpas_pool_get_array_gpu(diag, 'theta_base', theta_base) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, time_lev) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(state, 'u', u, time_lev) + call mpas_pool_get_array_gpu(state, 'w', w, time_lev) + call mpas_pool_get_array_gpu(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array_gpu(diag, 'exner', exner) + call mpas_pool_get_array_gpu(diag, 'exner_base', exner_base) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'zb', zb) + call mpas_pool_get_array_gpu(mesh, 'zb3', zb3) + call mpas_pool_get_array_gpu(mesh, 'zb_cell', zb_cell) + call mpas_pool_get_array_gpu(mesh, 'zb3_cell', zb3_cell) rcv = rgas / (cp-rgas) @@ -5653,7 +7065,6 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynami integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - real (kind=RKIND) :: inv_dynamics_split real (kind=RKIND), dimension(:,:), pointer :: ru real (kind=RKIND), dimension(:,:), pointer :: ru_save @@ -5669,63 +7080,181 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynami real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2, rho_zz_old_split real (kind=RKIND), dimension(:,:), pointer :: ruAvg, wwAvg, ruAvg_split, wwAvg_split + integer, pointer:: nCells,nEdges,nVertLevels + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_zz_old_split', rho_zz_old_split) + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'ruAvg_split', ruAvg_split) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg_split', wwAvg_split) + + call mpas_pool_get_array_gpu(state, 'u', u_1, 1) + call mpas_pool_get_array_gpu(state, 'u', u_2, 2) + call mpas_pool_get_array_gpu(state, 'w', w_1, 1) + call mpas_pool_get_array_gpu(state, 'w', w_2, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_1, 1) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_2, 2) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_1, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_2, 2) + + call mpas_pool_get_dimension(state, 'nCells', nCells) + call mpas_pool_get_dimension(state, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'ruAvg_split', ruAvg_split) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(diag, 'wwAvg_split', wwAvg_split) - - call mpas_pool_get_array(state, 'u', u_1, 1) - call mpas_pool_get_array(state, 'u', u_2, 2) - call mpas_pool_get_array(state, 'w', w_1, 1) - call mpas_pool_get_array(state, 'w', w_2, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) - call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) - inv_dynamics_split = 1.0_RKIND / real(dynamics_split) - - if (dynamics_substep < dynamics_split) then + call atm_rk_dynamics_substep_finish_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split,ruAvg,ruAvg_split, wwAvg, wwAvg_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2,dynamics_substep, dynamics_split) + + end subroutine atm_rk_dynamics_substep_finish - ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) - rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) - rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) - rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) + subroutine atm_rk_dynamics_substep_finish_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split,ruAvg,ruAvg_split, wwAvg, wwAvg_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2,dynamics_substep, dynamics_split) - u_1(:,edgeStart:edgeEnd) = u_2(:,edgeStart:edgeEnd) - w_1(:,cellStart:cellEnd) = w_2(:,cellStart:cellEnd) - theta_m_1(:,cellStart:cellEnd) = theta_m_2(:,cellStart:cellEnd) - rho_zz_1(:,cellStart:cellEnd) = rho_zz_2(:,cellStart:cellEnd) + implicit none + integer, intent(in) :: nVertLevels, edgeStart, edgeEnd,cellStart, cellEnd, & + nCells, nEdges + integer, intent(in) :: dynamics_substep, dynamics_split + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw, rw_save + real (kind=RKIND), dimension(nVertLevels,nEdges+1):: ru, ru_save, u_1, u_2 + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: ruAvg, ruAvg_split + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: wwAvg,wwAvg_split, & + w_1,w_2 + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_p, rho_p_save, & + rtheta_p,rtheta_p_save, & + rho_zz_old_split, & + rho_zz_1, rho_zz_2, & + theta_m_1, theta_m_2 + real (kind=RKIND) :: inv_dynamics_split + integer:: i,j + inv_dynamics_split = 1.0_RKIND / real(dynamics_split) +!$acc data present(ru, ru_save, rw, rw_save, & +!$acc rtheta_p,rtheta_p_save,rho_p,rho_p_save, & +!$acc rho_zz_old_split,ruAvg,ruAvg_split, wwAvg, wwAvg_split, & +!$acc u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2) + if (dynamics_substep < dynamics_split) then +!$acc parallel vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels + rho_p_save(j,i) = rho_p(j,i) + theta_m_1(j,i) = theta_m_2(j,i) + rtheta_p_save(j,i) = rtheta_p(j,i) + rho_zz_1(j,i) = rho_zz_2(j,i) + enddo +!$acc loop vector + do j=1,nVertLevels+1 + rw_save(j,i) = rw(j,i) + w_1(j,i) = w_2(j,i) + enddo + enddo +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ru_save(j,i) = ru(j,i) + u_1(j,i) = u_2(j,i) + enddo + enddo +!$acc end parallel + +! ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) +! rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) +! rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) +! rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) + +! u_1(:,edgeStart:edgeEnd) = u_2(:,edgeStart:edgeEnd) +! w_1(:,cellStart:cellEnd) = w_2(:,cellStart:cellEnd) +! theta_m_1(:,cellStart:cellEnd) = theta_m_2(:,cellStart:cellEnd) +! rho_zz_1(:,cellStart:cellEnd) = rho_zz_2(:,cellStart:cellEnd) end if - if (dynamics_substep == 1) then - ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd) - wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd) + +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels+1 + wwAvg_split(j,i) = wwAvg(j,i) + enddo + enddo + +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ruAvg_split(j,i) = ruAvg(j,i) + enddo + enddo +!$acc end parallel else - ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd)+ruAvg_split(:,edgeStart:edgeEnd) - wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd)+wwAvg_split(:,cellStart:cellEnd) + +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels+1 + wwAvg_split(j,i) = wwAvg(j,i)+wwAvg_split(j,i) + enddo + enddo + +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ruAvg_split(j,i) = ruAvg(j,i)+ruAvg_split(j,i) + enddo + enddo +!$acc end parallel + end if + if (dynamics_substep == dynamics_split) then - ruAvg(:,edgeStart:edgeEnd) = ruAvg_split(:,edgeStart:edgeEnd) * inv_dynamics_split - wwAvg(:,cellStart:cellEnd) = wwAvg_split(:,cellStart:cellEnd) * inv_dynamics_split - rho_zz_1(:,cellStart:cellEnd) = rho_zz_old_split(:,cellStart:cellEnd) +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels+1 + wwAvg(j,i) = wwAvg_split(j,i) * inv_dynamics_split + enddo + do j=1,nVertLevels + rho_zz_1(j,i) = rho_zz_old_split(j,i) + enddo + enddo + +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ruAvg(j,i) = ruAvg_split(j,i) * inv_dynamics_split + enddo + enddo +!$acc end parallel +!$acc update host(u_2,w_2) end if - end subroutine atm_rk_dynamics_substep_finish +!$acc end data + + end subroutine atm_rk_dynamics_substep_finish_work subroutine summarize_timestep(domain) use ieee_arithmetic, only : ieee_is_nan @@ -5735,7 +7264,7 @@ subroutine summarize_timestep(domain) type (domain_type), intent(inout) :: domain real (kind=RKIND), parameter :: pi_const = 2.0_RKIND*asin(1.0_RKIND) - + logical, pointer :: config_print_global_minmax_vel logical, pointer :: config_print_detailed_minmax_vel logical, pointer :: config_print_global_minmax_sca @@ -5781,18 +7310,18 @@ subroutine summarize_timestep(domain) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(mesh, 'indexToCellID', indexToCellID) - call mpas_pool_get_array(mesh, 'latCell', latCell) - call mpas_pool_get_array(mesh, 'lonCell', lonCell) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) - call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + call mpas_pool_get_array_gpu(state, 'u', u, 2) + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(mesh, 'indexToCellID', indexToCellID) + call mpas_pool_get_array_gpu(mesh, 'latCell', latCell) + call mpas_pool_get_array_gpu(mesh, 'lonCell', lonCell) + call mpas_pool_get_array_gpu(mesh, 'latEdge', latEdge) + call mpas_pool_get_array_gpu(mesh, 'lonEdge', lonEdge) call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - +!!$acc update host(w,u) scalar_min = 1.0e20 indexMax = -1 kMax = -1 @@ -5827,7 +7356,7 @@ subroutine summarize_timestep(domain) end if ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' call mpas_log_write(' global min w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + realArgs=(/global_scalar_min, latMax_global,lonMax_global/)) scalar_max = -1.0e20 indexMax = -1 @@ -5862,8 +7391,8 @@ subroutine summarize_timestep(domain) lonMax_global = lonMax_global - 360.0 end if ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global,lonMax_global/)) scalar_min = 1.0e20 indexMax = -1 @@ -5898,8 +7427,8 @@ subroutine summarize_timestep(domain) lonMax_global = lonMax_global - 360.0 end if ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_min, latMax_global,lonMax_global/)) scalar_max = -1.0e20 indexMax = -1 @@ -5934,8 +7463,8 @@ subroutine summarize_timestep(domain) lonMax_global = lonMax_global - 360.0 end if ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global,lonMax_global/)) scalar_max = -1.0e20 indexMax = -1 @@ -5971,8 +7500,8 @@ subroutine summarize_timestep(domain) lonMax_global = lonMax_global - 360.0 end if ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global,lonMax_global/)) ! ! Check for NaNs @@ -5980,7 +7509,7 @@ subroutine summarize_timestep(domain) do iCell = 1, nCellsSolve do k = 1, nVertLevels if (ieee_is_nan(w(k,iCell))) then - call mpas_log_write('NaN detected in ''w'' field.', messageType=MPAS_LOG_CRIT) + call mpas_log_write('NaN detected in ''w'' field.',messageType=MPAS_LOG_CRIT) end if end do end do @@ -5988,7 +7517,7 @@ subroutine summarize_timestep(domain) do iEdge = 1, nEdgesSolve do k = 1, nVertLevels if (ieee_is_nan(u(k,iEdge))) then - call mpas_log_write('NaN detected in ''u'' field.', messageType=MPAS_LOG_CRIT) + call mpas_log_write('NaN detected in ''u''field.',messageType=MPAS_LOG_CRIT) end if end do end do @@ -6003,8 +7532,8 @@ subroutine summarize_timestep(domain) do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + call mpas_pool_get_array_gpu(state, 'u', u, 2) call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) @@ -6019,7 +7548,7 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max w $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + call mpas_log_write('global min, max w $r $r',realArgs=(/global_scalar_min, global_scalar_max/)) scalar_min = 0.0 scalar_max = 0.0 @@ -6031,7 +7560,7 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max u $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + call mpas_log_write('global min, max u $r $r',realArgs=(/global_scalar_min, global_scalar_max/)) block => block % next end do @@ -6046,7 +7575,7 @@ subroutine summarize_timestep(domain) do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) @@ -6062,7 +7591,7 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write(' global min, max scalar $i $r $r', intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) + call mpas_log_write(' global min, max scalar $i $r $r',intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) end do block => block % next diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 8aa3ca304..e8cb03f6f 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,15 +4,16 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif +all: lookup_tables core_physics_init core_physics_wrf core_physics + dummy: - echo "****** make non-hydrostatic core ******" + echo "****** compiling physics ******" OBJS_init = \ mpas_atmphys_constants.o \ mpas_atmphys_date_time.o \ mpas_atmphys_functions.o \ - mpas_atmphys_utilities.o \ - mpas_atmphys_o3climatology.o + mpas_atmphys_utilities.o OBJS = \ mpas_atmphys_camrad_init.o \ @@ -23,6 +24,7 @@ OBJS = \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_microphysics.o \ + mpas_atmphys_driver_oml.o \ mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ @@ -30,10 +32,11 @@ OBJS = \ mpas_atmphys_finalize.o \ mpas_atmphys_init.o \ mpas_atmphys_init_microphysics.o \ + mpas_atmphys_interface.o \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ mpas_atmphys_manager.o \ - mpas_atmphys_driver_oml.o \ + mpas_atmphys_o3climatology.o \ mpas_atmphys_packages.o \ mpas_atmphys_rrtmg_lwinit.o \ mpas_atmphys_rrtmg_swinit.o \ @@ -42,30 +45,25 @@ OBJS = \ mpas_atmphys_update.o \ mpas_atmphys_vars.o -OBJS_dyn = mpas_atmphys_interface.o - -all: lookup_tables core_physics_init core_physics_wrf core_dyn core_physics - lookup_tables: ./checkout_data_files.sh core_physics_wrf: - (cd physics_wrf; make all COREDEF="$(COREDEF)") - -core_dyn: $(OBJS_dyn) - ar -ru libphys.a $(OBJS_dyn) + (cd physics_wrf; $(MAKE) all COREDEF="$(COREDEF)") core_physics_init: $(OBJS_init) ar -ru libphys.a $(OBJS_init) -core_physics: $(OBJS) +core_physics: core_physics_wrf + ($(MAKE) phys_interface COREDEF="$(COREDEF)") ar -ru libphys.a $(OBJS) +phys_interface: $(OBJS) + # DEPENDENCIES: mpas_atmphys_camrad_init.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_cam_support.o + mpas_atmphys_utilities.o mpas_atmphys_control.o: \ mpas_atmphys_utilities.o \ @@ -88,54 +86,36 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_cloudiness.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_mp_thompson_cldfra3.o + mpas_atmphys_vars.o mpas_atmphys_driver_convection.o: \ mpas_atmphys_constants.o \ mpas_atmphys_utilities.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_cu_gf.mpas.o \ - ./physics_wrf/module_cu_kfeta.o \ - ./physics_wrf/module_cu_tiedtke.o \ - ./physics_wrf/module_cu_ntiedtke.o - -mpas_atmphys_finalize.o: \ - ./physics_wrf/module_mp_thompson.o - -mpas_atmphys_finalize.o: \ - ./physics_wrf/module_mp_thompson.o + mpas_atmphys_vars.o mpas_atmphys_driver_gwdo.o: \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_bl_gwdo.o + mpas_atmphys_vars.o mpas_atmphys_driver_lsm.o: \ mpas_atmphys_constants.o \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_sf_noahdrv.o + mpas_atmphys_vars.o mpas_atmphys_driver_microphysics.o: \ mpas_atmphys_constants.o \ mpas_atmphys_init_microphysics.o \ mpas_atmphys_interface.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_mp_kessler.o \ - ./physics_wrf/module_mp_thompson.o \ - ./physics_wrf/module_mp_wsm6.o + mpas_atmphys_vars.o mpas_atmphys_driver_oml.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_sf_oml.o + mpas_atmphys_landuse.o \ + mpas_atmphys_vars.o mpas_atmphys_driver_pbl.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_bl_mynn.o \ - ./physics_wrf/module_bl_ysu.o + mpas_atmphys_vars.o mpas_atmphys_driver_radiation_lw.o: \ mpas_atmphys_camrad_init.o \ @@ -143,24 +123,18 @@ mpas_atmphys_driver_radiation_lw.o: \ mpas_atmphys_driver_radiation_sw.o \ mpas_atmphys_manager.o \ mpas_atmphys_rrtmg_lwinit.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_ra_cam.o \ - ./physics_wrf/module_ra_rrtmg_lw.o + mpas_atmphys_vars.o mpas_atmphys_driver_radiation_sw.o: \ mpas_atmphys_camrad_init.o \ mpas_atmphys_constants.o \ mpas_atmphys_manager.o \ mpas_atmphys_rrtmg_swinit.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_ra_cam.o \ - ./physics_wrf/module_ra_rrtmg_sw.o + mpas_atmphys_vars.o mpas_atmphys_driver_sfclayer.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_sf_mynn.o \ - ./physics_wrf/module_sf_sfclay.o + mpas_atmphys_vars.o mpas_atmphys_init.o: \ mpas_atmphys_driver_convection.o \ @@ -172,9 +146,6 @@ mpas_atmphys_init.o: \ mpas_atmphys_landuse.o \ mpas_atmphys_o3climatology.o -mpas_atmphys_init_microphysics.o: \ - ./physics_wrf/module_mp_thompson.o - mpas_atmphys_interface.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o @@ -185,8 +156,7 @@ mpas_atmphys_landuse.o: \ mpas_atmphys_lsm_noahinit.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_sf_noahlsm.o + mpas_atmphys_utilities.o mpas_atmphys_manager.o: \ mpas_atmphys_constants.o \ @@ -198,18 +168,15 @@ mpas_atmphys_manager.o: \ mpas_atmphys_o3climatology.o: \ mpas_atmphys_date_time.o \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_cam_support.o + mpas_atmphys_utilities.o mpas_atmphys_rrtmg_lwinit.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_rrtmg_lw.o + mpas_atmphys_utilities.o mpas_atmphys_rrtmg_swinit.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_rrtmg_sw.o + mpas_atmphys_utilities.o mpas_atmphys_todynamics.o: \ mpas_atmphys_constants.o \ @@ -227,7 +194,7 @@ mpas_atmphys_update.o: \ clean: $(RM) *.o *.mod *.f90 libphys.a - ( cd physics_wrf; make clean ) + ( cd physics_wrf; $(MAKE) clean ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process $(RM) *.i @@ -236,7 +203,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I./physics_wrf -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I./physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F index 27830c02d..be44ddaba 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F @@ -15,7 +15,6 @@ module mpas_atmphys_camrad_init use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants,only: cp,degrad,ep_2,gravity,R_d,R_v,stbolt diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index ace27ea81..3ea3e9687 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -9,7 +9,6 @@ module mpas_atmphys_control use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_utilities diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 29eb7a943..b120d0ccc 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_driver_cloudiness @@ -189,14 +188,14 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) !allocate arrays shared by all physics parameterizations: - call allocate_forall_physics + call allocate_forall_physics(block%configs) !physics prep step: time_lev = 1 !$OMP PARALLEL DO do thread=1,nThreads - call MPAS_to_physics(mesh,state,time_lev,diag,diag_physics, & + call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO @@ -215,7 +214,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to short wave radiation scheme: if(l_radtsw) then time_lev = 1 - call allocate_radiation_sw(xtime_s) + call allocate_radiation_sw(block%configs,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_radiation_sw(itimestep,block%configs,mesh,state,time_lev,diag_physics, & @@ -228,7 +227,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to long wave radiation scheme: if(l_radtlw) then time_lev = 1 - call allocate_radiation_lw(xtime_s) + call allocate_radiation_lw(block%configs,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_radiation_lw(xtime_s,block%configs,mesh,state,time_lev,diag_physics, & @@ -251,19 +250,19 @@ subroutine physics_driver(domain,itimestep,xtime_s) !deallocate all radiation arrays: if(config_radt_sw_scheme.ne.'off' .or. config_radt_lw_scheme.ne.'off') & call deallocate_cloudiness - if(config_radt_sw_scheme.ne.'off') call deallocate_radiation_sw - if(config_radt_lw_scheme.ne.'off') call deallocate_radiation_lw + if(config_radt_sw_scheme.ne.'off') call deallocate_radiation_sw(block%configs) + if(config_radt_lw_scheme.ne.'off') call deallocate_radiation_lw(block%configs) !call to surface-layer scheme: if(config_sfclayer_scheme .ne. 'off') then - call allocate_sfclayer(config_frac_seaice) + call allocate_sfclayer(block%configs) !$OMP PARALLEL DO do thread=1,nThreads call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_sfclayer(config_frac_seaice) + call deallocate_sfclayer(block%configs) endif !call to 1d ocean mixed-layer model @@ -283,14 +282,15 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to pbl schemes: if(config_pbl_scheme .ne. 'off' .and. config_sfclayer_scheme .ne. 'off') then - call allocate_pbl + call allocate_pbl(block%configs) !$OMP PARALLEL DO do thread=1,nThreads call driver_pbl(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_pbl + call deallocate_pbl(block%configs) + endif !call to gravity wave drag over orography scheme: @@ -308,19 +308,19 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to convection scheme: !$OMP PARALLEL DO do thread=1,nThreads - call update_convection_step1(diag_physics,tend_physics, & + call update_convection_step1(block%configs,diag_physics,tend_physics, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO if(l_conv) then - call allocate_convection + call allocate_convection(block%configs) !$OMP PARALLEL DO do thread=1,nThreads call driver_convection(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_convection + call deallocate_convection(block%configs) endif !update diagnostics: if(config_convection_scheme .ne. 'off') then @@ -333,7 +333,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) end if !deallocate arrays shared by all physics parameterizations: - call deallocate_forall_physics + call deallocate_forall_physics(block%configs) block => block % next end do diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F index 71d9eb6c2..3296025dc 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_cloudiness use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants, only: ep_2 @@ -49,6 +48,9 @@ module mpas_atmphys_driver_cloudiness ! cloud formation, but changes to the cloud water and cloud ice mixing ratios only affect the long wave and ! short wave radiation codes. ! Laura D. Fowler (laura@ucar.edu) / 2016-07-05. +! * since we removed the local variable radt_cld_scheme from mpas_atmphys_vars.F, now defines radt_cld_scheme +! as a pointer to config_radt_cld_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains @@ -177,13 +179,17 @@ subroutine driver_cloudiness(configs,mesh,diag_physics,sfc_input,its,ite) !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics -!local variables: +!local variables and pointers: + character(len=StrKIND),pointer:: radt_cld_scheme + integer:: i,j,k !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_cloudiness:') + call mpas_pool_get_config(configs,'config_radt_cld_scheme',radt_cld_scheme) + !copy MPAS arrays to local arrays: call cloudiness_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index defcc920d..c62f8c747 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_convection use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -88,20 +87,30 @@ module mpas_atmphys_driver_convection ! * for the kain_fritsch parameterization of convection, change the definition of dx_p to match that used in the ! Grell-Freitas and "new Tiedtke" parameterization. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. +! * since we removed the local variable convection_scheme from mpas_atmphys_vars.F, now defines convection_scheme +! as a pointer to config_convection_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_convection + subroutine allocate_convection(configs) !================================================================================================================= -!local variables: +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local variables and pointers: + character(len=StrKIND),pointer:: convection_scheme + integer:: i,k,j !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + if(.not.allocated(cu_act_flag)) allocate(cu_act_flag(ims:ime,jms:jme) ) if(.not.allocated(rthcuten_p) ) allocate(rthcuten_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(rqvcuten_p) ) allocate(rqvcuten_p(ims:ime,kms:kme,jms:jme)) @@ -252,9 +261,19 @@ subroutine allocate_convection end subroutine allocate_convection !================================================================================================================= - subroutine deallocate_convection + subroutine deallocate_convection(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: convection_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + if(allocated(cu_act_flag)) deallocate(cu_act_flag) if(allocated(rthcuten_p) ) deallocate(rthcuten_p ) if(allocated(rqvcuten_p) ) deallocate(rqvcuten_p ) @@ -347,6 +366,8 @@ subroutine init_convection(mesh,configs,diag_physics) !local pointers: logical,pointer:: config_do_restart + character(len=StrKIND),pointer:: convection_scheme + integer,pointer:: nCells real(kind=RKIND),dimension(:),pointer:: nca @@ -356,7 +377,8 @@ subroutine init_convection(mesh,configs,diag_physics) !----------------------------------------------------------------------------------------------------------------- call mpas_pool_get_dimension(mesh,'nCells',nCells) - call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart) + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) convection_select: select case(convection_scheme) @@ -402,6 +424,7 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ !local pointers: logical,pointer:: config_do_restart integer,pointer:: gfconv_closure_deep,gfconv_closure_shallow + character(len=StrKIND),pointer:: convection_scheme real(kind=RKIND),pointer:: len_disp !variables specific to Kain_Fritsch parameterization: @@ -417,8 +440,9 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ call mpas_pool_get_config(configs,'config_gfconv_closure_deep',gfconv_closure_deep) call mpas_pool_get_config(configs,'config_gfconv_closure_shallow',gfconv_closure_shallow) - call mpas_pool_get_config(configs,'config_len_disp',len_disp) - call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_config(configs,'config_len_disp' ,len_disp ) + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart) + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) !initialize instantaneous precipitation, and copy convective tendencies from the dynamics to !the physics grid: @@ -568,7 +592,7 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ !copy instantaneous and accumulated precipitation, convective tendencies, and "other" arrays !specific to convection parameterization back to the dynamics grid: - call convection_to_MPAS(diag_physics,tend_physics,its,ite) + call convection_to_MPAS(configs,diag_physics,tend_physics,its,ite) !call mpas_log_write('--- end subroutine driver_convection.') !call mpas_log_write('') @@ -590,6 +614,7 @@ subroutine convection_from_MPAS(dt_dyn,configs,mesh,sfc_input,diag_physics,tend_ real(kind=RKIND),intent(in):: dt_dyn !local pointers: + character(len=StrKIND),pointer:: convection_scheme integer,dimension(:),pointer:: kpbl,k22_shallow,kbcon_shallow,ktop_shallow,ktop_deep real(kind=RKIND),dimension(:),pointer :: areaCell,meshDensity real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv @@ -609,6 +634,8 @@ subroutine convection_from_MPAS(dt_dyn,configs,mesh,sfc_input,diag_physics,tend_ !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_array(diag_physics,'cuprec',cuprec) call mpas_pool_get_array(diag_physics,'raincv',raincv) @@ -812,10 +839,11 @@ subroutine convection_from_MPAS(dt_dyn,configs,mesh,sfc_input,diag_physics,tend_ end subroutine convection_from_MPAS !================================================================================================================= - subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) + subroutine convection_to_MPAS(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !inout arguments: @@ -826,6 +854,7 @@ subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) integer:: i,k,j !local pointers: + character(len=StrKIND),pointer:: convection_scheme integer,dimension(:),pointer:: k22_shallow,kbcon_shallow,ktop_shallow,ktop_deep real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv real(kind=RKIND),dimension(:),pointer :: xmb_total,xmb_shallow @@ -836,6 +865,8 @@ subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_array(diag_physics,'cuprec',cuprec) call mpas_pool_get_array(diag_physics,'raincv',raincv) @@ -936,10 +967,11 @@ subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) end subroutine convection_to_MPAS !================================================================================================================= - subroutine update_convection_step1(diag_physics,tend_physics,its,ite) + subroutine update_convection_step1(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !inout arguments: @@ -947,6 +979,7 @@ subroutine update_convection_step1(diag_physics,tend_physics,its,ite) type(mpas_pool_type),intent(inout):: tend_physics !local pointers: + character(len=StrKIND),pointer:: convection_scheme real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten,rqicuten,rqrcuten,rqscuten @@ -955,6 +988,8 @@ subroutine update_convection_step1(diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + convection_select: select case(convection_scheme) case ("cu_kain_fritsch") diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F index 0d6596ead..d021a370b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_gwdo use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -267,6 +266,8 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic type(mpas_pool_type),intent(inout):: tend_physics !local variables: + character(len=StrKIND),pointer:: gwdo_scheme + integer:: i,iCell,iEdge real(kind=RKIND),dimension(:),allocatable:: dx_max @@ -274,6 +275,8 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_gwdo:') + call mpas_pool_get_config(configs,'config_gwdo_scheme',gwdo_scheme) + !copy MPAS arrays to local arrays: call gwdo_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index 0911eb2e6..dee4c0d65 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_lsm use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -82,6 +81,10 @@ module mpas_atmphys_driver_lsm ! Laura D. Fowler (laura@ucar.edu) / 2016-05-11. ! * added the calculation of surface variables over seaice cells when config_frac_seaice is set to true. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-03. +! * since we removed the local variable lsm_scheme from mpas_atmphys_vars.F, now defines lsm_scheme as a +! pointer to config_lsm_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. + ! ! DOCUMENTATION: @@ -685,8 +688,13 @@ subroutine init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: sfc_input +!local pointers: + character(len=StrKIND),pointer:: lsm_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_lsm_scheme',lsm_scheme) + lsm_select: select case (trim(lsm_scheme)) case ("noah") @@ -715,18 +723,19 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !local pointers: logical,pointer:: config_sfc_albedo + character(len=StrKIND),pointer:: lsm_scheme character(len=StrKIND),pointer:: mminlu !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_lsm:') - call mpas_pool_get_config(configs,'config_sfc_albedo' ,config_sfc_albedo ) + call mpas_pool_get_config(configs,'config_sfc_albedo',config_sfc_albedo) + call mpas_pool_get_config(configs,'config_lsm_scheme',lsm_scheme) call mpas_pool_get_array(sfc_input,'mminlu',mminlu) !copy MPAS arrays to local arrays: call lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) -! call mpas_log_write('--- end lsm_from_MPAS') !call to land-surface scheme: lsm_select: select case (trim(lsm_scheme)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index 92157639f..d3ec40861 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_microphysics use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -81,6 +80,9 @@ module mpas_atmphys_driver_microphysics ! * added parameterization of the WSM6 cloud microphysics from WRF version 3.8.1. To initialize WSM6 as in its ! original version, set the hail_option to 0. ! Laura D. Fowler (laura@ucar.edu) / 2016-09-19. +! * since we removed the local variable microp_scheme from mpas_atmphys_vars.F, now defines microp_scheme as a +! pointer to config_microp_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. !--- initialization option for WSM6 from WRF version 3.8.1. this option could also be set as a namelist parameter. integer,parameter:: hail_opt = 0 @@ -90,9 +92,19 @@ module mpas_atmphys_driver_microphysics !================================================================================================================= - subroutine allocate_microphysics + subroutine allocate_microphysics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: microp_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + !sounding variables: if(.not.allocated(rho_p) ) allocate(rho_p(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(th_p) ) allocate(th_p(ims:ime,kms:kme,jms:jme) ) @@ -154,9 +166,19 @@ subroutine allocate_microphysics end subroutine allocate_microphysics !================================================================================================================= - subroutine deallocate_microphysics + subroutine deallocate_microphysics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: microp_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + !sounding variables: if(allocated(rho_p) ) deallocate(rho_p ) if(allocated(th_p) ) deallocate(th_p ) @@ -218,19 +240,25 @@ subroutine deallocate_microphysics end subroutine deallocate_microphysics !================================================================================================================= - subroutine microphysics_init(dminfo,mesh,sfc_input,diag_physics) + subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) !================================================================================================================= !input arguments: type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: sfc_input !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics +!local pointer: + character(len=StrKIND),pointer:: microp_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + microp_select: select case(microp_scheme) case("mp_thompson") @@ -264,6 +292,9 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend +!local pointers: + character(len=StrKIND),pointer:: microp_scheme + !local variables and arrays: logical:: log_microphysics integer:: i,icell,icount,istep,j,k,kk @@ -272,17 +303,19 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !call mpas_log_write('') !call mpas_log_write('---enter subroutine driver_microphysics:') + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + !... allocation of microphysics arrays: !$OMP MASTER - call allocate_microphysics + call allocate_microphysics(configs) !$OMP END MASTER !$OMP BARRIER !... initialization of precipitation related arrays: - call precip_from_MPAS(diag_physics,its,ite) + call precip_from_MPAS(configs,diag_physics,its,ite) !... initialization of soundings for non-hydrostatic dynamical cores. - call microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) + call microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) !... call to different cloud microphysics schemes: microp_select: select case(microp_scheme) @@ -355,7 +388,7 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !the computation of simulated radar reflectivity: if(trim(microp_scheme) == "mp_wsm6" .or. & trim(microp_scheme) == "mp_thompson") then - call compute_radar_reflectivity(diag_physics,its,ite) + call compute_radar_reflectivity(configs,diag_physics,its,ite) else call mpas_log_write('*** NOTICE: NOT computing simulated radar reflectivity') call mpas_log_write(' since WSM6 or Thompson microphysics scheme was not selected') @@ -372,12 +405,12 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !... copy updated cloud microphysics variables from the wrf-physics grid back to the geodesic- ! dynamics grid: - call microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + call microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) !... deallocation of all microphysics arrays: !$OMP BARRIER !$OMP MASTER - call deallocate_microphysics + call deallocate_microphysics(configs) !$OMP END MASTER !call mpas_log_write('---enter subroutine driver_microphysics:') @@ -386,16 +419,18 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten end subroutine driver_microphysics !================================================================================================================= - subroutine precip_from_MPAS(diag_physics,its,ite) + subroutine precip_from_MPAS(configs,diag_physics,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !output variables: type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,pointer:: nCellsSolve real,dimension(:),pointer:: graupelncv,rainncv,snowncv,sr @@ -404,6 +439,8 @@ subroutine precip_from_MPAS(diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) @@ -422,7 +459,7 @@ subroutine precip_from_MPAS(diag_physics,its,ite) enddo !variables specific to different cloud microphysics schemes: - microp_select_init: select case(microp_scheme) + microp_select: select case(microp_scheme) case ("mp_thompson","mp_wsm6") do j = jts, jte @@ -443,7 +480,7 @@ subroutine precip_from_MPAS(diag_physics,its,ite) case default - end select microp_select_init + end select microp_select end subroutine precip_from_MPAS @@ -453,13 +490,13 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) !input arguments: type(mpas_pool_type),intent(in):: configs - integer,intent(in):: its,ite !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,dimension(:),pointer:: i_rainnc real(kind=RKIND),pointer:: config_bucket_rainnc @@ -473,6 +510,7 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme ) call mpas_pool_get_config(configs,'config_bucket_rainnc',config_bucket_rainnc) call mpas_pool_get_array(diag_physics,'i_rainnc' ,i_rainnc ) @@ -538,16 +576,18 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) end subroutine precip_to_MPAS !================================================================================================================= - subroutine compute_radar_reflectivity(diag_physics,its,ite) + subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme real(kind=RKIND),dimension(:),pointer:: refl10cm_max,refl10cm_1km,refl10cm_1km_max !local variables and arrays: @@ -557,6 +597,8 @@ subroutine compute_radar_reflectivity(diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(diag_physics,'refl10cm_max',refl10cm_max) call mpas_pool_get_array(diag_physics,'refl10cm_1km',refl10cm_1km) call mpas_pool_get_array(diag_physics,'refl10cm_1km_max',refl10cm_1km_max) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F index ca000cb77..eaa898f98 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_oml use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 51d62d96e..04c41006c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_pbl use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -63,15 +62,28 @@ module mpas_atmphys_driver_pbl ! * updated the call to subroutine ysu in comjunction with updating module_bl_ysu.F from WRF version 3.6.1 to ! WRF version 3.8.1 ! Laura D. Fowler (laura@ucar.edu) / 2016-10-27. +! * since we removed the local variable pbl_scheme from mpas_atmphys_vars.F, now defines pbl_scheme as a pointer +! to config_pbl_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_pbl + subroutine allocate_pbl(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(.not.allocated(hfx_p) ) allocate(hfx_p(ims:ime,jms:jme) ) if(.not.allocated(qfx_p) ) allocate(qfx_p(ims:ime,jms:jme) ) if(.not.allocated(ust_p) ) allocate(ust_p(ims:ime,jms:jme) ) @@ -148,9 +160,19 @@ subroutine allocate_pbl end subroutine allocate_pbl !================================================================================================================= - subroutine deallocate_pbl + subroutine deallocate_pbl(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(allocated(hfx_p) ) deallocate(hfx_p ) if(allocated(qfx_p) ) deallocate(qfx_p ) if(allocated(ust_p) ) deallocate(ust_p ) @@ -241,6 +263,8 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it integer:: i,k,j !local pointers: + character(len=StrKIND),pointer:: pbl_scheme + real(kind=RKIND),dimension(:),pointer:: hfx,hpbl,qfx,ust,wspd,xland,znt real(kind=RKIND),dimension(:),pointer:: delta,wstar @@ -257,6 +281,8 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) @@ -408,9 +434,12 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it end subroutine pbl_from_MPAS !================================================================================================================= - subroutine pbl_to_MPAS(diag_physics,tend_physics,its,ite) + subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend_physics @@ -421,7 +450,10 @@ subroutine pbl_to_MPAS(diag_physics,tend_physics,its,ite) integer:: i,k,j !local pointers: + character(len=StrKIND),pointer:: pbl_scheme + integer,dimension(:),pointer:: kpbl + real(kind=RKIND),dimension(:),pointer :: hpbl real(kind=RKIND),dimension(:,:),pointer:: kzh,kzm,kzq real(kind=RKIND),dimension(:,:),pointer:: rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten, & @@ -437,6 +469,8 @@ subroutine pbl_to_MPAS(diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_array(diag_physics,'kpbl' ,kpbl ) call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) call mpas_pool_get_array(diag_physics,'kzh' ,kzh ) @@ -554,6 +588,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics !local pointers: logical,pointer:: config_do_restart + character(len=StrKIND),pointer:: pbl_scheme !local variables: integer:: initflag @@ -564,6 +599,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics !call mpas_log_write('--- enter subroutine driver_pbl:') call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme ) !copy MPAS arrays to local arrays: call pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) @@ -636,7 +672,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics end select pbl_select !copy local arrays to MPAS grid: - call pbl_to_MPAS(diag_physics,tend_physics,its,ite) + call pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) !call mpas_log_write('--- end subroutine driver_pbl.') diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F index 836f0a5af..8f9b07a08 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -9,12 +9,10 @@ module mpas_atmphys_driver_radiation_lw use mpas_kind_types use mpas_pool_routines - use mpas_derived_types use mpas_atmphys_driver_radiation_sw, only: radconst use mpas_atmphys_constants use mpas_atmphys_manager, only: gmt,curr_julday,julday,year - use mpas_atmphys_o3climatology, only: vinterp_ozn use mpas_atmphys_camrad_init use mpas_atmphys_rrtmg_lwinit use mpas_atmphys_vars @@ -22,6 +20,7 @@ module mpas_atmphys_driver_radiation_lw !wrf physics: use module_ra_cam use module_ra_rrtmg_lw + use module_ra_rrtmg_vinterp implicit none private @@ -82,24 +81,36 @@ module mpas_atmphys_driver_radiation_lw ! * in the call to rrtmg_lwrad, substituted the variables qv_p, qc_p, qi_p, and qs_p with qvrad_p, qcrad_p, ! qirad_p, and qsrad_p initialized in subroutine cloudiness_from_MPAS. ! Laura D. Fowler (laura@ucar.edu) / 2016-07-09. +! * substituted "use mpas_atmphys_o3climatology" with "use module_ra_rrtmg_vinterp" since we moved subroutine +! vinterp_ozn to is own module in physics_wrf. +! laura D. Fowler (laura@ucar.edu) / 2017-01-27. ! * in subroutines radiation_lw_from_MPAS and radiation_lw_to_MPAS, revised the initialization of re_cloud, ! re_ice, re_snow, and rre_cloud, rre_ice, and rre_snow to handle the case when the cloud microphysics ! parameterization is turned off, i.e. config_microp_scheme='off'. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-10. +! * since we removed the local variable radt_lw_scheme from mpas_atmphys_vars.F, now defines radt_lw_scheme +! as a pointer to config_radt_lw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_radiation_lw(xtime_s) + subroutine allocate_radiation_lw(configs,xtime_s) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs real(kind=RKIND),intent(in):: xtime_s +!local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) + if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) ) @@ -194,9 +205,19 @@ subroutine allocate_radiation_lw(xtime_s) end subroutine allocate_radiation_lw !================================================================================================================= - subroutine deallocate_radiation_lw + subroutine deallocate_radiation_lw(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) + if(allocated(f_ice) ) deallocate(f_ice ) if(allocated(f_rain) ) deallocate(f_rain ) if(allocated(sfc_emiss_p) ) deallocate(sfc_emiss_p ) @@ -296,6 +317,8 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_lw_scheme + character(len=StrKIND),pointer:: microp_scheme logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: latCell,lonCell @@ -313,8 +336,10 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) - call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -600,6 +625,8 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) integer,intent(in):: its,ite !local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + character(len=StrKIND),pointer:: microp_scheme logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: glw,lwcf,lwdnb,lwdnbc,lwdnt,lwdntc,lwupb,lwupbc, & @@ -614,7 +641,9 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_microp_re',config_microp_re) + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re) call mpas_pool_get_array(diag_physics,'glw' ,glw ) call mpas_pool_get_array(diag_physics,'lwcf' ,lwcf ) @@ -738,11 +767,12 @@ subroutine radiation_camlw_to_MPAS(diag_physics,its,ite) end subroutine radiation_camlw_to_MPAS !================================================================================================================= - subroutine init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) + subroutine init_radiation_lw(dminfo,configs,mesh,atm_input,diag,state,time_lev) !================================================================================================================= !input arguments: type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in),optional:: mesh type(mpas_pool_type),intent(in),optional:: diag @@ -752,8 +782,13 @@ subroutine init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) type(mpas_pool_type),intent(inout),optional:: atm_input type(mpas_pool_type),intent(inout),optional:: state +!local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) + radiation_lw_select: select case (trim(radt_lw_scheme)) case ("rrtmg_lw") @@ -790,6 +825,7 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_lw_scheme !local variables: integer:: o3input @@ -798,7 +834,8 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write(' --- enter subroutine driver_radiation_lw: ') - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) !copy MPAS arrays to local arrays: call radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physics,atm_input,sfc_input,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index 7538d323d..f2d2ea5da 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_radiation_sw use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -80,20 +79,29 @@ module mpas_atmphys_driver_radiation_sw ! * in subroutines radiation_sw_from_MPAS, revised the initialization of re_cloud, re_ice, re_snow, to ! handle the case when the cloud microphysics parameterization is turned off, i.e. config_microp_scheme='off'. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-10. +! * since we removed the local variable radt_sw_scheme from mpas_atmphys_vars.F, now defines radt_sw_scheme +! as a pointer to config_radt_sw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_radiation_sw(xtime_s) + subroutine allocate_radiation_sw(configs,xtime_s) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs real(kind=RKIND),intent(in):: xtime_s +!local pointers: + character(len=StrKIND),pointer:: radt_sw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) ) @@ -193,9 +201,19 @@ subroutine allocate_radiation_sw(xtime_s) end subroutine allocate_radiation_sw !================================================================================================================= - subroutine deallocate_radiation_sw + subroutine deallocate_radiation_sw(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: radt_sw_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + if(allocated(f_ice) ) deallocate(f_ice ) if(allocated(f_rain) ) deallocate(f_rain ) if(allocated(xlat_p) ) deallocate(xlat_p ) @@ -299,6 +317,8 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_sw_scheme + character(len=StrKIND),pointer:: microp_scheme logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: latCell,lonCell @@ -311,8 +331,10 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) - call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme ) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -610,11 +632,12 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) end subroutine radiation_sw_to_MPAS !================================================================================================================= - subroutine init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) + subroutine init_radiation_sw(dminfo,configs,mesh,atm_input,diag,state,time_lev) !================================================================================================================= !input arguments: type(dm_info), intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in),optional:: mesh type(mpas_pool_type),intent(in),optional:: diag @@ -624,8 +647,13 @@ subroutine init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) type(mpas_pool_type),intent(inout),optional:: atm_input type(mpas_pool_type),intent(inout),optional:: state +!local pointers: + character(len=StrKIND),pointer:: radt_sw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -666,6 +694,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_sw_scheme !local variables: integer:: o3input @@ -674,7 +703,8 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write(' --- enter subroutine driver_radiation_sw: $i',intArgs=(/itimestep/)) - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme ) xtime_m = xtime_s/60. diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index d7b4c57c2..09b9f091b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_sfclayer use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -76,17 +75,30 @@ module mpas_atmphys_driver_sfclayer ! * changed the definition of dx_p to match that used in other physics parameterizations. ! parameterizations. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. +! * since we removed the local variable sfclayer_scheme from mpas_atmphys_vars.F, now defines sfclayer_scheme +! as a pointer to config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. + contains !================================================================================================================= - subroutine allocate_sfclayer(config_frac_seaice) + subroutine allocate_sfclayer(configs) !================================================================================================================= - logical,intent(in):: config_frac_seaice +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) ) if(.not.allocated(cd_p) ) allocate(cd_p(ims:ime,jms:jme) ) @@ -200,12 +212,21 @@ subroutine allocate_sfclayer(config_frac_seaice) end subroutine allocate_sfclayer !================================================================================================================= - subroutine deallocate_sfclayer(config_frac_seaice) + subroutine deallocate_sfclayer(configs) !================================================================================================================= - logical,intent(in):: config_frac_seaice +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + if(allocated(dx_p) ) deallocate(dx_p ) if(allocated(br_p) ) deallocate(br_p ) if(allocated(cd_p) ) deallocate(cd_p ) @@ -324,6 +345,7 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !local pointers: logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),pointer:: len_disp real(kind=RKIND),dimension(:),pointer:: meshDensity @@ -343,8 +365,9 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !----------------------------------------------------------------------------------------------------------------- !input variables: - call mpas_pool_get_config(configs,'config_len_disp' ,len_disp) - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + call mpas_pool_get_config(configs,'config_len_disp' ,len_disp ) call mpas_pool_get_array(mesh,'meshDensity',meshDensity) call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) @@ -568,6 +591,7 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) !local pointers: logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: br,cpm,chs,chs2,cqs2,flhc,flqc,gz1oz0,hfx,qfx, & qgh,qsfc,lh,mol,psim,psih,regime,rmol,ust,wspd, & @@ -585,7 +609,8 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) !inout variables: call mpas_pool_get_array(diag_physics,'br' ,br ) @@ -755,14 +780,20 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) end subroutine sfclayer_to_MPAS !================================================================================================================= - subroutine init_sfclayer + subroutine init_sfclayer(configs) !================================================================================================================= -!local variables: +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local variables and pointers: logical, parameter:: allowed_to_read = .false. !actually not used in subroutine sfclayinit. + character(len=StrKIND),pointer:: sfclayer_scheme !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme) + sfclayer_select: select case (trim(sfclayer_scheme)) case("sf_monin_obukhov") @@ -775,7 +806,6 @@ subroutine init_sfclayer end select sfclayer_select - end subroutine init_sfclayer !================================================================================================================= @@ -795,6 +825,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite !local pointers: logical,pointer:: config_do_restart,config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: areaCell !local variables: @@ -805,8 +836,9 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_sfclayer:') - call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) call mpas_pool_get_array(mesh,'areaCell',areaCell) diff --git a/src/core_atmosphere/physics/mpas_atmphys_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F index 19424e876..8ad924819 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F +++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F @@ -7,7 +7,6 @@ ! !================================================================================================================= module mpas_atmphys_finalize - use mpas_derived_types use mpas_pool_routines use module_mp_thompson diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index adcfda04f..0f5b5972c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_init use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_timekeeping @@ -355,10 +354,10 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !initialization of cloud microphysics processes: if(config_microp_scheme .ne. 'off') & - call microphysics_init(dminfo,mesh,sfc_input,diag_physics) + call microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) !initialization of surface layer processes: - if(config_sfclayer_scheme .ne. 'off') call init_sfclayer + if(config_sfclayer_scheme .ne. 'off') call init_sfclayer(configs) !initialization of land-surface model: !if(.not. config_do_restart) then @@ -370,10 +369,10 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ init_done = .false. if(config_radt_sw_scheme.ne.'off') then if(trim(config_radt_sw_scheme) .eq. 'cam_sw') then - call init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) + call init_radiation_sw(dminfo,configs,mesh,atm_input,diag,state,time_lev) init_done = .true. else - call init_radiation_sw(dminfo) + call init_radiation_sw(dminfo,configs) endif endif @@ -383,13 +382,13 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ if(config_radt_lw_scheme.ne.'off') then if(trim(config_radt_lw_scheme) .eq. 'cam_lw') then if(.not. init_done) then - call init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) + call init_radiation_lw(dminfo,configs,mesh,atm_input,diag,state,time_lev) else ! call mpas_log_write('') ! call mpas_log_write('--- camrad lw initialization done above') endif else - call init_radiation_lw(dminfo) + call init_radiation_lw(dminfo,configs) endif endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F index fac384368..99db47ced 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F @@ -10,7 +10,6 @@ module mpas_atmphys_init_microphysics use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_utilities diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index 6ee58cfcb..303c1ce33 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -9,7 +9,6 @@ module mpas_atmphys_initialize_real use mpas_kind_types use mpas_dmpar - use mpas_derived_types use mpas_pool_routines use mpas_init_atm_surface use mpas_log, only : mpas_log_write diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 4d0dfbb91..f4ec44652 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_interface use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants @@ -71,9 +70,19 @@ module mpas_atmphys_interface !================================================================================================================= - subroutine allocate_forall_physics + subroutine allocate_forall_physics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(.not.allocated(psfc_p) ) allocate(psfc_p(ims:ime,jms:jme) ) if(.not.allocated(ptop_p) ) allocate(ptop_p(ims:ime,jms:jme) ) @@ -125,9 +134,19 @@ subroutine allocate_forall_physics end subroutine allocate_forall_physics !================================================================================================================= - subroutine deallocate_forall_physics + subroutine deallocate_forall_physics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(allocated(psfc_p) ) deallocate(psfc_p ) if(allocated(ptop_p) ) deallocate(ptop_p ) @@ -178,10 +197,11 @@ subroutine deallocate_forall_physics end subroutine deallocate_forall_physics !================================================================================================================= - subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics,its,ite) + subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: diag @@ -193,6 +213,8 @@ subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics,its,ite) type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: pbl_scheme + integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg integer,pointer:: index_ni @@ -224,6 +246,8 @@ subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics,its,ite) !call mpas_log_write('kts=$i kte=$i',intArgs=(/kts,kte/)) !initialization: + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) call mpas_pool_get_array(mesh,'fzm' ,fzm ) @@ -446,10 +470,11 @@ subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics,its,ite) end subroutine MPAS_to_physics !================================================================================================================= - subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) + subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: diag @@ -459,6 +484,7 @@ subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) integer:: time_lev !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg integer,pointer:: index_ni,index_nr real(kind=RKIND),dimension(:),pointer :: nt_c,mu_c @@ -476,6 +502,8 @@ subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(mesh,'zgrid',zgrid) call mpas_pool_get_array(mesh,'zz' ,zz ) @@ -585,10 +613,11 @@ subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) end subroutine microphysics_from_MPAS !================================================================================================================= - subroutine microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh integer,intent(in):: itimestep,time_lev @@ -601,6 +630,7 @@ subroutine microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itime type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg integer,pointer:: index_ni,index_nr real(kind=RKIND),dimension(:),pointer :: surface_pressure,tend_sfc_pressure @@ -621,6 +651,8 @@ subroutine microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itime !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(mesh,'zz' ,zz ) call mpas_pool_get_array(mesh,'zgrid',zgrid) diff --git a/src/core_atmosphere/physics/mpas_atmphys_landuse.F b/src/core_atmosphere/physics/mpas_atmphys_landuse.F index ca6be0ddf..0e2aa5578 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_landuse.F +++ b/src/core_atmosphere/physics/mpas_atmphys_landuse.F @@ -13,7 +13,6 @@ module mpas_atmphys_landuse use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_utilities diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F index e850a328f..497603a94 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F @@ -15,7 +15,6 @@ module mpas_atmphys_lsm_noahinit use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index 5b26a2a04..fe8ee5c27 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_manager use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_timekeeping use mpas_stream_manager @@ -97,7 +96,34 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. ! * added initialization of variables has_reqc,has_reqi,and has_reqs needed in the calls to radiation codes ! rrtmg_lwrad and rrmtg_swrad. -! Laura D. Fowler (laura@ucar.edu) / 2016-07-007. +! Laura D. Fowler (laura@ucar.edu) / 2016-07-07. +! * in subroutine physics_run_init, removed the initialization of the local variable gwdo_scheme. gwdo_scheme +! is no longer needed and can be replaced with config_gwdo_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable lsm_scheme. lsm_scheme +! is no longer needed and can be replaced with config_lsm_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable sfclayer_scheme. +! sfclayer_scheme is no longer needed and can be replaced with config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable pbl_scheme. pbl_scheme +! is no longer needed and can be replaced with config_pbl_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable radt_cld_scheme. +! radt_cld_scheme is no longer needed and can be replaced with config_radt_cld_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable radt_lw_scheme. +! radt_lw_scheme is no longer needed and can be replaced with config_radt_lw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable radt_sw_scheme. +! radt_sw_scheme is no longer needed and can be replaced with config_radt_sw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable convection_scheme. +! convection_scheme is no longer needed and can be replaced with config_convection_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable microp_scheme. +! microp_scheme is no longer needed and can be replaced with config_microp_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. contains @@ -357,14 +383,10 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !local pointers: character(len=StrKIND),pointer:: config_convection_scheme, & - config_gwdo_scheme, & config_lsm_scheme, & config_microp_scheme, & - config_pbl_scheme, & - config_radt_cld_scheme, & config_radt_lw_scheme, & - config_radt_sw_scheme, & - config_sfclayer_scheme + config_radt_sw_scheme character(len=StrKIND),pointer:: config_conv_interval, & config_pbl_interval, & @@ -397,14 +419,10 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !call mpas_log_write('--- enter subroutine physics_run_init:') call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) - call mpas_pool_get_config(configs,'config_gwdo_scheme' ,config_gwdo_scheme ) call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) - call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_scheme ) - call mpas_pool_get_config(configs,'config_radt_cld_scheme' ,config_radt_cld_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) - call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) call mpas_pool_get_config(configs,'config_conv_interval' ,config_conv_interval ) call mpas_pool_get_config(configs,'config_pbl_interval' ,config_pbl_interval ) @@ -654,16 +672,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) num_months = nMonths num_soils = nSoilLevels - convection_scheme = trim(config_convection_scheme) - lsm_scheme = trim(config_lsm_scheme) - microp_scheme = trim(config_microp_scheme) - pbl_scheme = trim(config_pbl_scheme) - gwdo_scheme = trim(config_gwdo_scheme) - radt_cld_scheme = trim(config_radt_cld_scheme) - radt_lw_scheme = trim(config_radt_lw_scheme) - radt_sw_scheme = trim(config_radt_sw_scheme) - sfclayer_scheme = trim(config_sfclayer_scheme) - if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 !initialization of local physics time-steps: @@ -672,13 +680,13 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !... cloud microphysics: dt_microp = dt_dyn n_microp = 1 - if(trim(microp_scheme)=='mp_thompson') then + if(trim(config_microp_scheme)=='mp_thompson') then dt_microp = 90._RKIND n_microp = max(nint(dt_dyn/dt_microp),1) dt_microp = dt_dyn / n_microp if(dt_dyn <= dt_microp) dt_microp = dt_dyn endif - call mpas_log_write('--- specifics on cloud microphysics option microp_scheme = '//trim(microp_scheme)) + call mpas_log_write('--- specifics on cloud microphysics option microp_scheme = '//trim(config_microp_scheme)) call mpas_log_write('--- dt_microp = $r', realArgs=(/dt_microp/)) call mpas_log_write('--- n_microp = $i', intArgs=(/n_microp/)) !... convection: @@ -733,9 +741,9 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) has_reqi = 0 has_reqs = 0 if(config_microp_re) then - if(trim(microp_scheme)=='mp_thompson' .or. & - trim(microp_scheme)=='mp_wsm6') then - if(trim(radt_lw_scheme)=='rrtmg_lw' .and. trim(radt_sw_scheme)=='rrtmg_sw') then + if(trim(config_microp_scheme)=='mp_thompson' .or. & + trim(config_microp_scheme)=='mp_wsm6') then + if(trim(config_radt_lw_scheme)=='rrtmg_lw' .and. trim(config_radt_sw_scheme)=='rrtmg_sw') then has_reqc = 1 has_reqi = 1 has_reqs = 1 diff --git a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F index f68b989dc..04d4f7f5b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F +++ b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_o3climatology use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_date_time use mpas_atmphys_constants @@ -21,8 +20,7 @@ module mpas_atmphys_o3climatology private public:: init_o3climatology, & update_o3climatology, & - o3climatology_from_MPAS, & - vinterp_ozn + o3climatology_from_MPAS integer,parameter:: latsiz = 64 integer,parameter:: lonsiz = 1 @@ -42,8 +40,6 @@ module mpas_atmphys_o3climatology ! as done for the greeness fraction in the MPAS time manager. ! o3climatology_from_MPAS: interpolates the ozone volume mixing ratio to the current Julian day ! as in the CAM radiation codes. -! vinterp_ozn : vertical interpolation of the ozone volume mixing ratios from fixed -! ozone pressure levels to the MPAS pressure levels. ! ! add-ons and modifications to sourcecode: ! ---------------------------------------- @@ -51,6 +47,8 @@ module mpas_atmphys_o3climatology ! Laura D. Fowler (laura@ucar.edu) / 2014-04-22. ! * modified sourcecode to use pools. ! Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +! * moved the subroutine vinterp_ozn to its own module module_ra_rrtmg_vinterp.F in physics_wrf. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-27. contains @@ -323,164 +321,6 @@ subroutine o3climatology_from_MPAS(julian,mesh,atm_input,diag_physics) end subroutine o3climatology_from_MPAS -!================================================================================================================= - subroutine vinterp_ozn (lchnk, ncol, pcols, pver, pmid_in, pin_in, levsiz, ozmix_in, o3vmr_out) -!-------------------------------------------------------------------------------------------------- -! -! Purpose: Interpolate ozone from current time-interpolated values to model levels -! -! Method: Use pressure values to determine interpolation levels -! -! Author: Bruce Briegleb -! -!----------------------------------------------------------------------------------------------------------------- -! use shr_kind_mod, only: r8 => shr_kind_r8 -! use ppgrid -! use phys_grid, only: get_lat_all_p, get_lon_all_p -! use comozp -! use abortutils, only: endrun -!----------------------------------------------------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------------------------------------------------- -! -! Arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: pcols, pver - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: levsiz ! number of ozone layers - -!ldf begin: -! real(kind=RKIND), intent(in) :: pmid(pcols,pver) ! level pressures (mks) -! real(kind=RKIND), intent(in) :: pin(levsiz) ! ozone data level pressures (mks) -! real(kind=RKIND), intent(in) :: ozmix(pcols,levsiz)! ozone mixing ratio - -! real(kind=RKIND), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio - - real(kind=RKIND), intent(in) :: pmid_in(pcols,pver) ! level pressures (mks) - real(kind=RKIND), intent(in) :: pin_in(levsiz) ! ozone data level pressures (mks) - real(kind=RKIND), intent(in) :: ozmix_in(pcols,levsiz)! ozone mixing ratio - - real(kind=RKIND), intent(out) :: o3vmr_out(pcols,pver)! ozone volume mixing ratio -!ldf end. -! -! local storage -! - integer i ! longitude index - integer k, kk, kkstart ! level indices - integer kupper(pcols) ! Level indices for interpolation - integer kount ! Counter - integer lats(pcols) ! latitude indices - integer lons(pcols) ! latitude indices - - real(kind=RKIND) dpu ! upper level pressure difference - real(kind=RKIND) dpl ! lower level pressure difference - -!ldf begin: - real(kind=RKIND):: pmid(pcols,pver) ! level pressures (mks) - real(kind=RKIND):: pin(levsiz) ! ozone data level pressures (mks) - real(kind=RKIND):: ozmix(pcols,levsiz) ! ozone mixing ratio - real(kind=RKIND):: o3vmr(pcols,pver) ! ozone volume mixing ratio -! -! Initialize latitude indices -! -! call get_lat_all_p(lchnk, ncol, lats) -! call get_lon_all_p(lchnk, ncol, lons) -! - -!ldf begin: - do k = 1,levsiz - pin(k) = pin_in(k) - enddo - do i = 1,pcols - do k = 1,levsiz - ozmix(i,k) = ozmix_in(i,k) - enddo - enddo - do i = 1,pcols - do k = 1,pver - kk = pver-k+1 - pmid(i,kk) = pmid_in(i,k) - enddo - enddo -!ldf end. - -! Initialize index array -! - do i=1,ncol - kupper(i) = 1 - end do - - do k=1,pver -! -! Top level we need to start looking is the top level for the previous k -! for all longitude points -! - kkstart = levsiz - do i=1,ncol - kkstart = min0(kkstart,kupper(i)) - end do - kount = 0 -! -! Store level indices for interpolation -! - do kk=kkstart,levsiz-1 - do i=1,ncol - if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then - kupper(i) = kk - kount = kount + 1 - end if - end do -! -! If all indices for this level have been found, do the interpolation and -! go to the next level -! - if (kount.eq.ncol) then - do i=1,ncol - dpu = pmid(i,k) - pin(kupper(i)) - dpl = pin(kupper(i)+1) - pmid(i,k) - o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & - ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) - end do - goto 35 - end if - end do -! -! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and -! must extrapolate from the bottom or top ozone data level for at least some -! of the longitude points. -! - do i=1,ncol - if (pmid(i,k) .lt. pin(1)) then - o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1) - else if (pmid(i,k) .gt. pin(levsiz)) then - o3vmr(i,k) = ozmix(i,levsiz) - else - dpu = pmid(i,k) - pin(kupper(i)) - dpl = pin(kupper(i)+1) - pmid(i,k) - o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & - ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) - end if - end do - - if (kount.gt.ncol) then -! call endrun ('VINTERP_OZN: Bad ozone data: non-monotonicity suspected') - end if -35 continue - end do - -!ldf begin: - do i = 1,pcols - do k = 1,pver - kk = pver-k+1 - o3vmr_out(i,kk) = o3vmr(i,k) - enddo - enddo -!ldf end. - - return -end subroutine vinterp_ozn - !================================================================================================================= end module mpas_atmphys_o3climatology !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 524f18de4..a470a6876 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -8,12 +8,10 @@ !================================================================================================================= module mpas_atmphys_todynamics use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_dmpar use mpas_atmphys_constants, only: R_d,R_v,degrad - use mpas_atmphys_vars, only: pbl_scheme,convection_scheme implicit none private @@ -522,7 +520,7 @@ subroutine physics_addtend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdges enddo enddo - pbl_select: select case (trim(pbl_scheme)) + pbl_select: select case (trim(config_pbl_scheme)) case("bl_mynn") @@ -549,7 +547,7 @@ subroutine physics_addtend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdges enddo enddo - convection_select: select case(convection_scheme) + convection_select: select case(config_convection_scheme) case('cu_grell_freitas') @@ -706,7 +704,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge enddo enddo - pbl_select: select case (trim(pbl_scheme)) + pbl_select: select case (trim(config_pbl_scheme)) case("bl_mynn") @@ -733,7 +731,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge enddo enddo - convection_select: select case(convection_scheme) + convection_select: select case(config_convection_scheme) case('cu_kain_fritsch') do i = 1, nCellsSolve diff --git a/src/core_atmosphere/physics/mpas_atmphys_update.F b/src/core_atmosphere/physics/mpas_atmphys_update.F index d05e37ad0..421a90e28 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_update use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_driver_convection diff --git a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F index 1a1125f37..684c27458 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F @@ -9,7 +9,6 @@ module mpas_atmphys_update_surface use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_date_time diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index bdd26ce10..012f63bef 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -68,22 +68,35 @@ module mpas_atmphys_vars ! * moved the declarations of arrays delta_p,wstar_p,uoce_p,and voce_p since they are now used in both modules ! module_bl_ysu.F and module_bl_mynn.F. ! Laura D. Fowler (laura@ucar.edu) / 20016-10-27. +! * removed the initialization local variable gwdo_scheme. gwdo_scheme is no longer needed and can be replaced +! with config_gwdo_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable lsm_scheme. lsm_scheme is no longer needed and can be replaced +! with config_lsm_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable sfclayer_scheme. sfclayer_scheme is no longer needed and can be +! replaced with config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable pbl_scheme. pbl_scheme is no longer needed and can be replaced +! replaced with config_pbl_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable radt_cld_scheme. radt_cld_scheme is no longer needed and can be +! replaced replaced with config_radt_cld_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable radt_lw_scheme. radt_lw_scheme is no longer needed and can be +! replaced replaced with config_radt_lw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable radt_sw_scheme. radt_sw_scheme is no longer needed and can be +! replaced replaced with config_radt_sw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable convection_scheme. convection_scheme is no longer needed and can be +! replaced replaced with config_convection_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable microp_scheme. microp_scheme is no longer needed and can be +! replaced replaced with config_microp_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. -!================================================================================================================= -!list of physics parameterizations: -!================================================================================================================= - - character(len=StrKIND),public:: microp_scheme - character(len=StrKIND),public:: convection_scheme - character(len=StrKIND),public:: gwdo_scheme - character(len=StrKIND),public:: lsm_scheme - character(len=StrKIND),public:: pbl_scheme - character(len=StrKIND),public:: radt_cld_scheme - character(len=StrKIND),public:: radt_lw_scheme - character(len=StrKIND),public:: radt_sw_scheme - character(len=StrKIND),public:: sfclayer_scheme - !================================================================================================================= !wrf-variables:these variables are needed to keep calls to different physics parameterizations !as in wrf model. diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index 68810446e..8480c1bd1 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -3,7 +3,7 @@ all: dummy physics_wrf dummy: - echo "****** compile physics_wrf ******" + echo "****** compiling physics_wrf ******" OBJS = \ libmassv.o \ @@ -26,6 +26,7 @@ OBJS = \ module_ra_cam_support.o \ module_ra_rrtmg_lw.o \ module_ra_rrtmg_sw.o \ + module_ra_rrtmg_vinterp.o \ module_sf_bem.o \ module_sf_bep.o \ module_sf_bep_bem.o \ @@ -42,41 +43,24 @@ physics_wrf: $(OBJS) # DEPENDENCIES: module_bl_mynn.o: \ - module_cam_error_function.o \ - ../mpas_atmphys_constants.o + module_cam_error_function.o module_cam_support.o: \ - module_cam_shr_kind_mod.o \ - ../mpas_atmphys_utilities.o - -module_cu_tiedtke.o: \ - ../mpas_atmphys_constants.o - -module_cu_ntiedtke.o: \ - ../mpas_atmphys_constants.o - -module_mp_radar.o: \ - ../mpas_atmphys_functions.o \ - ../mpas_atmphys_utilities.o + module_cam_shr_kind_mod.o module_mp_thompson.o: \ - module_mp_radar.o \ - ../mpas_atmphys_functions.o \ - ../mpas_atmphys_utilities.o + module_mp_radar.o module_ra_cam.o: \ module_cam_support.o \ - module_ra_cam_support.o \ - ../mpas_atmphys_utilities.o - -module_ra_cam_support.o: \ - ../mpas_atmphys_utilities.o + module_ra_cam_support.o module_ra_rrtmg_lw.o: \ - ../mpas_atmphys_constants.o + module_ra_rrtmg_vinterp.o module_ra_rrtmg_sw.o: \ - ../mpas_atmphys_constants.o + module_ra_rrtmg_lw.o \ + module_ra_rrtmg_vinterp.o module_sf_bep.o: \ module_sf_urban.o @@ -87,8 +71,7 @@ module_sf_bep_bem.o: \ module_sf_mynn.o: \ module_bl_mynn.o \ - module_sf_sfclay.o \ - ../mpas_atmphys_constants.o + module_sf_sfclay.o module_sf_noahdrv.o: \ module_sf_bem.o \ @@ -97,10 +80,6 @@ module_sf_noahdrv.o: \ module_sf_noahlsm.o \ module_sf_urban.o -module_sf_noahlsm.o: \ - ../mpas_atmphys_constants.o \ - ../mpas_atmphys_utilities.o - clean: $(RM) *.f90 *.o *.mod @# Certain systems with intel compilers generate *.i files @@ -110,7 +89,7 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../../framework -I../../../operators -I.. -I../../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../../framework -I../../../operators -I.. -I../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_cam_support.F b/src/core_atmosphere/physics/physics_wrf/module_cam_support.F index fed7f2674..2f8499e13 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cam_support.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cam_support.F @@ -7,9 +7,12 @@ MODULE module_cam_support ! Author: William.Gustafson@pnl.gov, Nov 2009 !------------------------------------------------------------------------ #if defined(mpas) - use mpas_atmphys_utilities + use mpas_atmphys_utilities,only:physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) #else use module_state_description, only: param_num_moist + use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) #endif use shr_kind_mod @@ -87,28 +90,7 @@ MODULE module_cam_support !!$END FUNCTION cnst_get_type_byind -#if defined(mpas) -!------------------------------------------------------------------------ -SUBROUTINE endrun(msg) -! Pass through routine to wrf_error_fatal that mimics endrun in module -! abortutils of CAM. -! -! Replaces endrun in abortutils module in CAM. -! -! Author: William.Gustafson@pnl.gov, Nov 2009 -! Modified : Balwinder.Singh@pnl.gov - Argument made optional -!------------------------------------------------------------------------ -! Argument of the subroutine is made optional to accomodate endrun calls with no argument - character(len=*), intent(in), optional :: msg - if(present(msg)) then - call physics_error_fatal(msg) - else -! The error message is written to iulog bwfore the endrun call - call physics_error_fatal(iulog) - endif -END SUBROUTINE endrun -#else !------------------------------------------------------------------------ SUBROUTINE endrun(msg) ! Pass through routine to wrf_error_fatal that mimics endrun in module @@ -119,19 +101,17 @@ SUBROUTINE endrun(msg) ! Author: William.Gustafson@pnl.gov, Nov 2009 ! Modified : Balwinder.Singh@pnl.gov - Argument made optional !------------------------------------------------------------------------ - USE module_wrf_error - ! Argument of the subroutine is made optional to accomodate endrun calls with no argument character(len=*), intent(in), optional :: msg if(present(msg)) then - call wrf_error_fatal(msg) + FATAL_ERROR(msg) else ! The error message is written to iulog bwfore the endrun call - call wrf_error_fatal(iulog) + FATAL_ERROR(iulog) endif END SUBROUTINE endrun -#endif + !------------------------------------------------------------------------ diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F index 20190e3fd..a2d28456b 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F @@ -61,7 +61,7 @@ MODULE module_mp_thompson use mpas_kind_types - use mpas_atmphys_functions + use mpas_atmphys_functions, only: gammp,wgamma,rslf,rsif use mpas_atmphys_utilities use module_mp_radar diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F index bb5ded6e2..bf47aae2e 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F @@ -14,6 +14,7 @@ module module_mp_thompson_cldfra3 ! than the model-top index. ! Laura D. Fowler (laura@ucar.edu)/2016-09-23. + use mpas_atmphys_functions,only: rslf,rsif implicit none private @@ -47,8 +48,8 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte) ! - USE module_mp_thompson , ONLY : rsif, rslf - IMPLICIT NONE +! USE module_mp_thompson , ONLY : rsif, rslf +! IMPLICIT NONE ! INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F index 30d6c014b..6d59bcb82 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F @@ -2634,6 +2634,15 @@ end module mcica_subcol_gen_lw ! module rrtmg_lw_cldprmc +#if defined(mpas) + use mpas_atmphys_utilities,only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#endif + + ! -------------------------------------------------------------------------- ! | | ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | @@ -2853,7 +2862,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, ciwpmc(ig,lay), radice - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if ncbands = 16 factor = (radice - 2._rb)/3._rb @@ -2875,7 +2884,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, cswpmc(ig,lay), radsno - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if ncbands = 16 factor = (radsno - 2._rb)/3._rb @@ -11382,8 +11391,8 @@ MODULE module_ra_rrtmg_lw #if defined(mpas) !MPAS specific (Laura D. Fowler): -use mpas_atmphys_constants,only: cp,g=>gravity -use mpas_atmphys_o3climatology,only: vinterp_ozn +use mpas_atmphys_constants,only : cp,g=>gravity +use module_ra_rrtmg_vinterp,only: vinterp_ozn !> add-ons and modifications to sourcecode: !> ---------------------------------------- @@ -11420,6 +11429,7 @@ MODULE module_ra_rrtmg_lw #else use module_model_constants, only : cp use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) #if (HWRF == 1) USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF #else diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index 414fc6b41..a2ee96b62 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -1948,6 +1948,14 @@ end module mcica_subcol_gen_sw module rrtmg_sw_cldprmc +#if defined(mpas) + use mpas_atmphys_utilities,only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#endif + ! -------------------------------------------------------------------------- ! | | ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | @@ -2173,7 +2181,7 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, ciwpmc(ig,lay), radice - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if factor = (radice - 2._rb)/3._rb index = int(factor) @@ -2190,11 +2198,11 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & (fdlice3(index+1,ib) - fdlice3(index,ib)) if (fdelta(ig) .lt. 0.0_rb) then write(errmess, *) 'FDELTA LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (fdelta(ig) .gt. 1.0_rb) then write(errmess, *) 'FDELTA GT THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if forwice(ig) = fdelta(ig) + 0.5_rb / ssacoice(ig) ! See Fu 1996 p. 2067 @@ -2222,7 +2230,7 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, cswpmc(ig,lay), radsno - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if factor = (radsno - 2._rb)/3._rb index = int(factor) @@ -2239,11 +2247,11 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & (fdlice3(index+1,ib) - fdlice3(index,ib)) if (fdelta(ig) .lt. 0.0_rb) then write(errmess, *) 'FDELTA LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (fdelta(ig) .gt. 1.0_rb) then write(errmess, *) 'FDELTA GT THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if forwsno(ig) = fdelta(ig) + 0.5_rb / ssacosno(ig) ! See Fu 1996 p. 2067 @@ -2251,23 +2259,23 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & ! Check to ensure all calculated quantities are within physical limits. if (extcosno(ig) .lt. 0.0_rb) then write(errmess, *) 'SNOW EXTINCTION LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (ssacosno(ig) .gt. 1.0_rb) then write(errmess, *) 'SNOW SSA GRTR THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (ssacosno(ig) .lt. 0.0_rb) then write(errmess, *) 'SNOW SSA LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (gsno(ig) .gt. 1.0_rb) then write(errmess, *) 'SNOW ASYM GRTR THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (gsno(ig) .lt. 0.0_rb) then write(errmess, *) 'SNOW ASYM LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if else extcosno(ig) = 0.0_rb @@ -9810,8 +9818,8 @@ MODULE module_ra_rrtmg_sw #if defined(mpas) !MPAS specific (Laura D. Fowler): -use mpas_atmphys_constants,only: cp,g=>gravity -use mpas_atmphys_o3climatology,only: vinterp_ozn +use mpas_atmphys_constants,only : cp,g=>gravity +use module_ra_rrtmg_vinterp,only: vinterp_ozn !> add-ons and modifications to sourcecode: !> ---------------------------------------- diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F new file mode 100644 index 000000000..6ec6c41cc --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F @@ -0,0 +1,181 @@ +!================================================================================================================= +!in module_ra_rrtmg_vinterp, the subroutine vinterp_ozn was originally the same as subroutine radozn and copied +!from module_ra_cam.F. module_ra_cam.F was itself copied from WRF 3.3.0. + +!subroutine vinterp_ozn is called from the subroutines rrtmg_lwrad (in module_ra_rrtmg_lw.F) and rrtmg_swrad (in +!module_ra_rrtmg_sw.F) for interpolation of climatological ozone onto the MPAS pressure levels. vinterp_ozn is +!also called from subroutine radiation_lw_from_MPAS (in mpas_atmphys_driver_radiation_lw.F) for diagnostic only. +!Laura D. Fowler (laura@ucar.edu)/2017-02-10. +!================================================================================================================= + module module_ra_rrtmg_vinterp + use mpas_kind_types + + implicit none + private + public:: vinterp_ozn + + + contains + + +!================================================================================================================= + subroutine vinterp_ozn (lchnk, ncol, pcols, pver, pmid_in, pin_in, levsiz, ozmix_in, o3vmr_out) +!-------------------------------------------------------------------------------------------------- +! +! Purpose: Interpolate ozone from current time-interpolated values to model levels +! +! Method: Use pressure values to determine interpolation levels +! +! Author: Bruce Briegleb +! +!----------------------------------------------------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use phys_grid, only: get_lat_all_p, get_lon_all_p +! use comozp +! use abortutils, only: endrun +!----------------------------------------------------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: pcols, pver + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: levsiz ! number of ozone layers + +!ldf begin: +! real(kind=RKIND), intent(in) :: pmid(pcols,pver) ! level pressures (mks) +! real(kind=RKIND), intent(in) :: pin(levsiz) ! ozone data level pressures (mks) +! real(kind=RKIND), intent(in) :: ozmix(pcols,levsiz)! ozone mixing ratio + +! real(kind=RKIND), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio + + real(kind=RKIND), intent(in) :: pmid_in(pcols,pver) ! level pressures (mks) + real(kind=RKIND), intent(in) :: pin_in(levsiz) ! ozone data level pressures (mks) + real(kind=RKIND), intent(in) :: ozmix_in(pcols,levsiz)! ozone mixing ratio + + real(kind=RKIND), intent(out) :: o3vmr_out(pcols,pver)! ozone volume mixing ratio +!ldf end. +! +! local storage +! + integer i ! longitude index + integer k, kk, kkstart ! level indices + integer kupper(pcols) ! Level indices for interpolation + integer kount ! Counter + integer lats(pcols) ! latitude indices + integer lons(pcols) ! latitude indices + + real(kind=RKIND) dpu ! upper level pressure difference + real(kind=RKIND) dpl ! lower level pressure difference + +!ldf begin: + real(kind=RKIND):: pmid(pcols,pver) ! level pressures (mks) + real(kind=RKIND):: pin(levsiz) ! ozone data level pressures (mks) + real(kind=RKIND):: ozmix(pcols,levsiz) ! ozone mixing ratio + real(kind=RKIND):: o3vmr(pcols,pver) ! ozone volume mixing ratio +! +! Initialize latitude indices +! +! call get_lat_all_p(lchnk, ncol, lats) +! call get_lon_all_p(lchnk, ncol, lons) +! + +!ldf begin: + do k = 1,levsiz + pin(k) = pin_in(k) + enddo + do i = 1,pcols + do k = 1,levsiz + ozmix(i,k) = ozmix_in(i,k) + enddo + enddo + do i = 1,pcols + do k = 1,pver + kk = pver-k+1 + pmid(i,kk) = pmid_in(i,k) + enddo + enddo +!ldf end. + +! Initialize index array +! + do i=1,ncol + kupper(i) = 1 + end do + + do k=1,pver +! +! Top level we need to start looking is the top level for the previous k +! for all longitude points +! + kkstart = levsiz + do i=1,ncol + kkstart = min0(kkstart,kupper(i)) + end do + kount = 0 +! +! Store level indices for interpolation +! + do kk=kkstart,levsiz-1 + do i=1,ncol + if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then + kupper(i) = kk + kount = kount + 1 + end if + end do +! +! If all indices for this level have been found, do the interpolation and +! go to the next level +! + if (kount.eq.ncol) then + do i=1,ncol + dpu = pmid(i,k) - pin(kupper(i)) + dpl = pin(kupper(i)+1) - pmid(i,k) + o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & + ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) + end do + goto 35 + end if + end do +! +! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and +! must extrapolate from the bottom or top ozone data level for at least some +! of the longitude points. +! + do i=1,ncol + if (pmid(i,k) .lt. pin(1)) then + o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1) + else if (pmid(i,k) .gt. pin(levsiz)) then + o3vmr(i,k) = ozmix(i,levsiz) + else + dpu = pmid(i,k) - pin(kupper(i)) + dpl = pin(kupper(i)+1) - pmid(i,k) + o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & + ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) + end if + end do + + if (kount.gt.ncol) then +! call endrun ('VINTERP_OZN: Bad ozone data: non-monotonicity suspected') + end if +35 continue + end do + +!ldf begin: + do i = 1,pcols + do k = 1,pver + kk = pver-k+1 + o3vmr_out(i,kk) = o3vmr(i,k) + enddo + enddo +!ldf end. + + return +end subroutine vinterp_ozn + +!================================================================================================================= + end module module_ra_rrtmg_vinterp +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F index 261956735..544b802f3 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F @@ -3,9 +3,9 @@ MODULE module_sf_bem ! Variables and constants used in the BEM module ! ----------------------------------------------------------------------- -use mpas_abort, only : mpas_dmpar_global_abort #ifdef mpas -#define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) #else #define FATAL_ERROR(M) write(0,*) M ; stop #endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F index 8bf465b46..9434dc8fa 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F @@ -1,9 +1,9 @@ MODULE module_sf_bep -use mpas_abort, only : mpas_dmpar_global_abort #ifdef mpas -#define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) -#else +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else #define FATAL_ERROR(M) write(0,*) M ; stop #endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F index e5c441837..5235fd372 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F @@ -1,9 +1,9 @@ MODULE module_sf_bep_bem -use mpas_abort, only : mpas_dmpar_global_abort #ifdef mpas -#define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) -#else +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else #define FATAL_ERROR(M) write(0,*) M ; stop #endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F index c4e680b1e..a854f41f8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F @@ -3,9 +3,11 @@ MODULE module_sf_noahlsm #if defined(mpas) !MPAS specific (Laura D. Fowler): use mpas_atmphys_constants, rhowater => rho_w -use mpas_atmphys_utilities +use mpas_atmphys_utilities,only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) #else - USE module_model_constants +USE module_model_constants +#define FATAL_ERROR(M) write(0,*) M ; stop #endif !MPAS specific end. @@ -492,7 +494,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ELSE SNDENS = SNEQV / SNOWH IF(SNDENS > 1.0) THEN -! CALL wrf_error_fatal ( 'Physical snow depth is less than snow water equiv.' ) + FATAL_ERROR( 'Physical snow depth is less than snow water equiv.' ) ENDIF CALL CSNOW (SNCOND,SNDENS) END IF @@ -2419,7 +2421,7 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & IF (NROOT .gt. NSOIL) THEN WRITE (err_message,*) 'Error: too many root layers ', & NSOIL,NROOT -! CALL wrf_error_fatal ( err_message ) + FATAL_ERROR( err_message ) ! ---------------------------------------------------------------------- ! CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM ! DISTRIBUTION BASED ON SOIL LAYER DEPTHS. diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F index 66b38e7db..d2ac6a0b4 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F @@ -1,5 +1,12 @@ MODULE module_sf_urban +#ifdef mpas +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else +#define FATAL_ERROR(M) write(0,*) M ; stop +#endif + !=============================================================================== ! Single-Layer Urban Canopy Model for WRF Noah-LSM ! Original Version: 2002/11/06 by Hiroyuki Kusaka @@ -503,8 +510,7 @@ SUBROUTINE urban(LSOLAR, & ! L if(ahoption==1) AH=AH*ahdiuprf(tloc) IF( ZDC+Z0C+2. >= ZA) THEN -! CALL wrf_error_fatal ("ZDC + Z0C + 2m is larger than the 1st WRF level "// & -! "Stop in subroutine urban - change ZDC and Z0C" ) + FATAL_ERROR("ZDC + Z0C + 2m is larger than the 1st WRF level - Stop in subroutine urban - change ZDC and Z0C" ) END IF IF(.NOT.LSOLAR) THEN @@ -1508,7 +1514,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & IOSTAT=IOSTATUS) IF (IOSTATUS > 0) THEN -! CALL wrf_error_fatal('ERROR OPEN URBPARM.TBL') + FATAL_ERROR('ERROR OPEN URBPARM.TBL') ENDIF READLOOP : do @@ -1525,118 +1531,118 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) icate IF (.not. ALLOCATED(ZR_TBL)) then ALLOCATE( ZR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ZR_TBL in urban_param_init') ALLOCATE( SIGMA_ZED_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0)CALL wrf_error_fatal('Error allocating SIGMA_ZED_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating SIGMA_ZED_TBL in urban_param_init') ALLOCATE( Z0C_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0C_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0C_TBL in urban_param_init') ALLOCATE( Z0HC_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HC_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0HC_TBL in urban_param_init') ALLOCATE( ZDC_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZDC_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ZDC_TBL in urban_param_init') ALLOCATE( SVF_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SVF_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating SVF_TBL in urban_param_init') ALLOCATE( R_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating R_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating R_TBL in urban_param_init') ALLOCATE( RW_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating RW_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating RW_TBL in urban_param_init') ALLOCATE( HGT_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HGT_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HGT_TBL in urban_param_init') ALLOCATE( AH_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AH_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AH_TBL in urban_param_init') ALLOCATE( BETR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETR_TBL in urban_param_init') ALLOCATE( BETB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETB_TBL in urban_param_init') ALLOCATE( BETG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETG_TBL in urban_param_init') ALLOCATE( CAPR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating CAPR_TBL in urban_param_init') ALLOCATE( CAPB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating CAPB_TBL in urban_param_init') ALLOCATE( CAPG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating CAPG_TBL in urban_param_init') ALLOCATE( AKSR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKSR_TBL in urban_param_init') ALLOCATE( AKSB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKSB_TBL in urban_param_init') ALLOCATE( AKSG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKSG_TBL in urban_param_init') ALLOCATE( ALBR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ALBR_TBL in urban_param_init') ALLOCATE( ALBB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ALBB_TBL in urban_param_init') ALLOCATE( ALBG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ALBG_TBL in urban_param_init') ALLOCATE( EPSR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating EPSR_TBL in urban_param_init') ALLOCATE( EPSB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating EPSB_TBL in urban_param_init') ALLOCATE( EPSG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating EPSG_TBL in urban_param_init') ALLOCATE( Z0R_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0R_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0R_TBL in urban_param_init') ALLOCATE( Z0B_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0B_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0B_TBL in urban_param_init') ALLOCATE( Z0G_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0G_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0G_TBL in urban_param_init') ALLOCATE( AKANDA_URBAN_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKANDA_URBAN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKANDA_URBAN_TBL in urban_param_init') ALLOCATE( Z0HB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0HB_TBL in urban_param_init') ALLOCATE( Z0HG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0HG_TBL in urban_param_init') ALLOCATE( TRLEND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TRLEND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TRLEND_TBL in urban_param_init') ALLOCATE( TBLEND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TBLEND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TBLEND_TBL in urban_param_init') ALLOCATE( TGLEND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TGLEND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TGLEND_TBL in urban_param_init') ALLOCATE( FRC_URB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating FRC_URB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating FRC_URB_TBL in urban_param_init') ! ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status ) - ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROOF_WIDTH in urban_param_init') ! ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status ) - ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROAD_WIDTH in urban_param_init') !for BEP ALLOCATE( NUMDIR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMDIR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating NUMDIR_TBL in urban_param_init') ALLOCATE( STREET_DIRECTION_TBL(MAXDIRS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_DIRECTION_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating STREET_DIRECTION_TBL in urban_param_init') ALLOCATE( STREET_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_WIDTH_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating STREET_WIDTH_TBL in urban_param_init') ALLOCATE( BUILDING_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BUILDING_WIDTH_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BUILDING_WIDTH_TBL in urban_param_init') ALLOCATE( NUMHGT_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMHGT_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating NUMHGT_TBL in urban_param_init') ALLOCATE( HEIGHT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HEIGHT_BIN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HEIGHT_BIN_TBL in urban_param_init') ALLOCATE( HPERCENT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HPERCENT_BIN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HPERCENT_BIN_TBL in urban_param_init') ALLOCATE( COP_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating COP_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating COP_TBL in urban_param_init') ALLOCATE( PWIN_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PWIN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating PWIN_TBL in urban_param_init') ALLOCATE( BETA_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETA_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETA_TBL in urban_param_init') ALLOCATE( SW_COND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SW_COND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating SW_COND_TBL in urban_param_init') ALLOCATE( TIME_ON_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_ON_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TIME_ON_TBL in urban_param_init') ALLOCATE( TIME_OFF_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_OFF_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TIME_OFF_TBL in urban_param_init') ALLOCATE( TARGTEMP_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGTEMP_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TARGTEMP_TBL in urban_param_init') ALLOCATE( GAPTEMP_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPTEMP_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating GAPTEMP_TBL in urban_param_init') ALLOCATE( TARGHUM_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGHUM_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TARGHUM_TBL in urban_param_init') ALLOCATE( GAPHUM_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPHUM_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating GAPHUM_TBL in urban_param_init') ALLOCATE( PERFLO_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PERFLO_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating PERFLO_TBL in urban_param_init') ALLOCATE( HSESF_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HSESF_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HSESF_TBL in urban_param_init') endif numdir_tbl = 0 street_direction_tbl = -1.E36 @@ -1653,12 +1659,12 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) sigma_zed_tbl(1:icate) else if (name == "ROOF_WIDTH") then ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROOF_WIDTH in urban_param_init') read(string(indx+1:),*) roof_width(1:icate) else if (name == "ROAD_WIDTH") then ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROAD_WIDTH in urban_param_init') read(string(indx+1:),*) road_width(1:icate) else if (name == "AH") then read(string(indx+1:),*) ah_tbl(1:icate) @@ -1771,7 +1777,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if ( pctsum /= 100.) then write (*,'(//,"Building height percentages for category ", I2, " must sum to 100.0")') k write (*,'("Currently, they sum to ", F6.2,/)') pctsum -! CALL wrf_error_fatal('pctsum is not equal to 100.') + FATAL_ERROR('pctsum is not equal to 100.') endif else if ( name == "Z0R") then read(string(indx+1:),*) Z0R_tbl(1:icate) @@ -1803,7 +1809,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) hsesf_tbl(1:icate) !end BEP else -! CALL wrf_error_fatal('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT') + FATAL_ERROR('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT') endif enddo READLOOP diff --git a/src/core_atmosphere/utils/Makefile b/src/core_atmosphere/utils/Makefile index 885a4e23c..03034c741 100644 --- a/src/core_atmosphere/utils/Makefile +++ b/src/core_atmosphere/utils/Makefile @@ -4,7 +4,7 @@ all: build_tables mv build_tables ../../.. build_tables: build_tables.o atmphys_build_tables_thompson.o - $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework + $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) -L../../external/esmf_time_f90 -lesmf_time build_tables.o: \ diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index fbac46bec..2738e187d 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -12,6 +12,10 @@ module mpas_io use mpas_dmpar use mpas_log +#ifndef USE_PIO2 + use netcdf_nf_data +#endif + use pio use piolib_mod use pionfatt_mod diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 6d99e56be..9d78a9a75 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -81,6 +81,21 @@ module mpas_pool_routines module procedure mpas_pool_get_array_1d_char end interface + interface mpas_pool_get_array_gpu + module procedure mpas_pool_get_array_0d_real_gpu + module procedure mpas_pool_get_array_1d_real_gpu + module procedure mpas_pool_get_array_2d_real_gpu + module procedure mpas_pool_get_array_3d_real_gpu + module procedure mpas_pool_get_array_4d_real_gpu + module procedure mpas_pool_get_array_5d_real_gpu + module procedure mpas_pool_get_array_0d_int_gpu + module procedure mpas_pool_get_array_1d_int_gpu + module procedure mpas_pool_get_array_2d_int_gpu + module procedure mpas_pool_get_array_3d_int_gpu + module procedure mpas_pool_get_array_0d_char_gpu + module procedure mpas_pool_get_array_1d_char_gpu + end interface + interface mpas_pool_add_config module procedure mpas_pool_add_config_real module procedure mpas_pool_add_config_int @@ -4238,6 +4253,25 @@ subroutine mpas_pool_get_array_0d_real(inPool, key, scalar, timeLevel)!{{{ end subroutine mpas_pool_get_array_0d_real!}}} + subroutine mpas_pool_get_array_0d_real_gpu(inPool, key, scalar, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), pointer :: scalar + integer, intent(in), optional :: timeLevel + + type (field0DReal), pointer :: field + + + call mpas_pool_get_field_0d_real(inPool, key, field, timeLevel) + + nullify(scalar) + if (associated(field)) scalar => field % scalar + !$acc enter data copyin(field%scalar) + end subroutine mpas_pool_get_array_0d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_1d_real @@ -4268,6 +4302,25 @@ subroutine mpas_pool_get_array_1d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_1d_real!}}} + subroutine mpas_pool_get_array_1d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DReal), pointer :: field + + + call mpas_pool_get_field_1d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + end subroutine mpas_pool_get_array_1d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_2d_real @@ -4298,6 +4351,26 @@ subroutine mpas_pool_get_array_2d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_2d_real!}}} + subroutine mpas_pool_get_array_2d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field2DReal), pointer :: field + + + call mpas_pool_get_field_2d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_2d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_3d_real @@ -4329,6 +4402,26 @@ subroutine mpas_pool_get_array_3d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_3d_real!}}} + subroutine mpas_pool_get_array_3d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field3DReal), pointer :: field + + + call mpas_pool_get_field_3d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_3d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_4d_real ! @@ -4358,6 +4451,26 @@ subroutine mpas_pool_get_array_4d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_4d_real!}}} + subroutine mpas_pool_get_array_4d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field4DReal), pointer :: field + + + call mpas_pool_get_field_4d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_4d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_5d_real @@ -4388,6 +4501,26 @@ subroutine mpas_pool_get_array_5d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_5d_real!}}} + subroutine mpas_pool_get_array_5d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field5DReal), pointer :: field + + + call mpas_pool_get_field_5d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_5d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_0d_int @@ -4418,6 +4551,26 @@ subroutine mpas_pool_get_array_0d_int(inPool, key, scalar, timeLevel)!{{{ end subroutine mpas_pool_get_array_0d_int!}}} + subroutine mpas_pool_get_array_0d_int_gpu(inPool, key, scalar, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, pointer :: scalar + integer, intent(in), optional :: timeLevel + + type (field0DInteger), pointer :: field + + + call mpas_pool_get_field_0d_int(inPool, key, field, timeLevel) + + nullify(scalar) + if (associated(field)) scalar => field % scalar + !$acc enter data copyin(field%scalar) + + end subroutine mpas_pool_get_array_0d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_1d_int @@ -4448,6 +4601,26 @@ subroutine mpas_pool_get_array_1d_int(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_1d_int!}}} + subroutine mpas_pool_get_array_1d_int_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DInteger), pointer :: field + + + call mpas_pool_get_field_1d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_1d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_2d_int @@ -4478,6 +4651,26 @@ subroutine mpas_pool_get_array_2d_int(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_2d_int!}}} + subroutine mpas_pool_get_array_2d_int_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field2DInteger), pointer :: field + + + call mpas_pool_get_field_2d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_2d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_3d_int @@ -4508,6 +4701,26 @@ subroutine mpas_pool_get_array_3d_int(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_3d_int!}}} + subroutine mpas_pool_get_array_3d_int_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field3DInteger), pointer :: field + + + call mpas_pool_get_field_3d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_3d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_0d_char @@ -4538,6 +4751,26 @@ subroutine mpas_pool_get_array_0d_char(inPool, key, string, timeLevel)!{{{ end subroutine mpas_pool_get_array_0d_char!}}} + subroutine mpas_pool_get_array_0d_char_gpu(inPool, key, string, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + character (len=StrKIND), pointer :: string + integer, intent(in), optional :: timeLevel + + type (field0DChar), pointer :: field + + + call mpas_pool_get_field_0d_char(inPool, key, field, timeLevel) + + nullify(string) + if (associated(field)) string => field % scalar + !$acc enter data copyin(field%scalar) + + end subroutine mpas_pool_get_array_0d_char_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_1d_char @@ -4568,6 +4801,26 @@ subroutine mpas_pool_get_array_1d_char(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_1d_char!}}} + subroutine mpas_pool_get_array_1d_char_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + character (len=StrKIND), dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DChar), pointer :: field + + + call mpas_pool_get_field_1d_char(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_1d_char_gpu!}}} + !----------------------------------------------------------------------- ! routine mpas_pool_add_config_real