!KGEN-generated Fortran source file !Generated at : 2020-05-29 19:47:47 !KGEN version : 0.9.0 module crm_module USE abcoefs_mod, ONLY: abcoefs USE kurant_mod, ONLY: kurant USE boundaries_mod, ONLY: boundaries USE forcing_mod, ONLY: forcing USE advect_mom_mod, ONLY: advect_mom USE adams_mod, ONLY: adams USE advect_all_scalars_mod, ONLY: advect_all_scalars USE crm_surface_mod USE zero_mod USE buoyancy_mod USE pressure_mod USE uvw_mod USE diagnose_mod USE damping_mod USE ice_fall_mod USE coriolis_mod USE crm_output_module !--------------------------------------------------------------- ! Super-parameterization's main driver ! Marat Khairoutdinov, 2001-2009 !--------------------------------------------------------------- USE kgen_utils_mod, ONLY: kgen_dp, kgen_array_sumcheck USE tprof_mod, ONLY: tstart, tstop, tnull, tprnt PUBLIC crm #ifdef _MPI include "mpif.h" #endif contains SUBROUTINE crm(kgen_unit, kgen_measure, kgen_isverified, kgen_filepath, ncrms, plev) !----------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------- USE EXTRAE_MODULE USE shr_kind_mod, ONLY: r8 => shr_kind_r8 USE vars USE microphysics USE sgs USE scalar_momentum_mod USE crmdims, ONLY: crm_nx_rad, crm_ny_rad USE accelerate_crm_mod, ONLY: use_crm_accel, accelerate_crm USE kgen_utils_mod, ONLY: kgen_dp, kgen_array_sumcheck USE kgen_utils_mod, ONLY: kgen_perturb_real USE vars, ONLY: kr_externs_out_vars USE grid, ONLY: kr_externs_out_grid USE sgs, ONLY: kr_externs_out_sgs USE params, ONLY: kr_externs_out_params USE microphysics, ONLY: kr_externs_out_microphysics USE micro_params, ONLY: kr_externs_out_micro_params USE crm_output_module, ONLY: kr_externs_out_crm_output_module USE accelerate_crm_mod, ONLY: kr_externs_out_accelerate_crm_mod USE kgen_utils_mod, ONLY: check_t, kgen_init_check, kgen_init_verify, kgen_tolerance, kgen_minvalue, kgen_verboselevel, & &CHECK_IDENTICAL, CHECK_IN_TOL, CHECK_OUT_TOL USE vars, ONLY: kv_externs_vars USE grid, ONLY: kv_externs_grid USE params, ONLY: kv_externs_params USE microphysics, ONLY: kv_externs_microphysics USE micro_params, ONLY: kv_externs_micro_params USE crm_output_module, ONLY: kv_externs_crm_output_module IMPLICIT NONE !----------------------------------------------------------------------------------------------- ! Interface variable declarations !----------------------------------------------------------------------------------------------- INTEGER, INTENT(INOUT) :: ncrms INTEGER, INTENT(INOUT) :: plev !----------------------------------------------------------------------------------------------- ! Local variable declarations !----------------------------------------------------------------------------------------------- real(r8), parameter :: wmin = 2. ! minimum up/downdraft velocity for stat real(crm_rknd), parameter :: cwp_threshold = 0.001 ! threshold for cloud condensate for shaded fraction calculation REAL(KIND=crm_rknd) :: tmp1, tmp INTEGER :: i, j, k, l, nn, icyc, icrm INTEGER :: kx REAL(KIND=crm_rknd) :: qsat REAL(KIND=crm_rknd), allocatable :: bflx(:) ! These should all be inputs ! variables for radiation grouping method INTEGER :: i_rad INTEGER :: j_rad LOGICAL :: crm_accel_ceaseflag ! Arrays REAL(KIND=crm_rknd), allocatable :: cwp (:,:,:) REAL(KIND=crm_rknd), allocatable :: cwph (:,:,:) REAL(KIND=crm_rknd), allocatable :: cwpm (:,:,:) REAL(KIND=crm_rknd), allocatable :: cwpl (:,:,:) LOGICAL, allocatable :: flag_top(:,:,:) REAL(KIND=crm_rknd), allocatable :: cltemp (:,:,:) REAL(KIND=crm_rknd), allocatable :: cmtemp (:,:,:) REAL(KIND=crm_rknd), allocatable :: chtemp (:,:,:) REAL(KIND=crm_rknd), allocatable :: cttemp (:,:,:) REAL(KIND=r8), allocatable :: mui_crm(:,:) REAL(KIND=r8), allocatable :: mdi_crm(:,:) REAL(KIND=crm_rknd), pointer :: crm_rad_temperature (:,:,:,:) REAL(KIND=crm_rknd), pointer :: crm_rad_qv (:,:,:,:) REAL(KIND=crm_rknd), pointer :: crm_rad_qc (:,:,:,:) REAL(KIND=crm_rknd), pointer :: crm_rad_qi (:,:,:,:) REAL(KIND=crm_rknd), pointer :: crm_rad_cld (:,:,:,:) REAL(KIND=crm_rknd), pointer :: crm_rad_qrad (:,:,:,:) !----------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------- INTEGER, INTENT(IN) :: kgen_unit REAL(KIND=kgen_dp), INTENT(OUT) :: kgen_measure LOGICAL, INTENT(OUT) :: kgen_isverified CHARACTER(LEN=*), INTENT(IN) :: kgen_filepath LOGICAL :: kgen_istrue REAL(KIND=8) :: kgen_array_sum INTEGER :: kgen_intvar, kgen_ierr INTEGER :: kgen_mpirank, kgen_openmptid, kgen_kernelinvoke LOGICAL :: kgen_evalstage, kgen_warmupstage, kgen_mainstage COMMON / state / kgen_mpirank, kgen_openmptid, kgen_kernelinvoke, kgen_evalstage, kgen_warmupstage, kgen_mainstage INTEGER, PARAMETER :: KGEN_MAXITER = 100 TYPE(check_t) :: check_status INTEGER*8 :: kgen_start_clock, kgen_stop_clock, kgen_rate_clock REAL(KIND=kgen_dp) :: gkgen_measure REAL(KIND=crm_rknd) :: kgenref_tmp1 REAL(KIND=crm_rknd) :: kgenref_tmp INTEGER :: kgenref_icrm INTEGER :: kgenref_icyc INTEGER :: kgenref_k INTEGER :: kgenref_j INTEGER :: kgenref_i INTEGER :: kgenref_nn INTEGER :: kgenref_l INTEGER :: kgenref_kx REAL(KIND=crm_rknd) :: kgenref_qsat INTEGER :: kgenref_i_rad INTEGER :: kgenref_j_rad LOGICAL :: kgenref_crm_accel_ceaseflag REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_cwp REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_cwph REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_cwpm REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_cwpl LOGICAL, allocatable, dimension(:,:,:) :: kgenref_flag_top REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_cltemp REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_cmtemp REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_chtemp REAL(KIND=crm_rknd), allocatable, dimension(:,:,:) :: kgenref_cttemp REAL(KIND=r8), allocatable, dimension(:,:) :: kgenref_mui_crm REAL(KIND=r8), allocatable, dimension(:,:) :: kgenref_mdi_crm REAL(KIND=crm_rknd), pointer, dimension(:,:,:,:) :: kgenref_crm_rad_temperature REAL(KIND=crm_rknd), pointer, dimension(:,:,:,:) :: kgenref_crm_rad_qv REAL(KIND=crm_rknd), pointer, dimension(:,:,:,:) :: kgenref_crm_rad_qc REAL(KIND=crm_rknd), pointer, dimension(:,:,:,:) :: kgenref_crm_rad_qi REAL(KIND=crm_rknd), pointer, dimension(:,:,:,:) :: kgenref_crm_rad_cld !parent block preprocessing #ifdef _MPI call mpi_comm_rank(mpi_comm_world, kgen_mpirank, kgen_ierr) #else kgen_mpirank = 0 #endif !local input variables READ (UNIT = kgen_unit) tmp1 READ (UNIT = kgen_unit) tmp READ (UNIT = kgen_unit) icrm READ (UNIT = kgen_unit) icyc READ (UNIT = kgen_unit) i READ (UNIT = kgen_unit) j READ (UNIT = kgen_unit) k READ (UNIT = kgen_unit) nn READ (UNIT = kgen_unit) l READ (UNIT = kgen_unit) kx READ (UNIT = kgen_unit) qsat CALL kr_crm_real__crm_rknd_dim1(bflx, kgen_unit, "bflx", .FALSE.) READ (UNIT = kgen_unit) i_rad READ (UNIT = kgen_unit) j_rad READ (UNIT = kgen_unit) crm_accel_ceaseflag CALL kr_crm_real__crm_rknd_dim3(cwp, kgen_unit, "cwp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(cwph, kgen_unit, "cwph", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(cwpm, kgen_unit, "cwpm", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(cwpl, kgen_unit, "cwpl", .FALSE.) CALL kr_crm_logical___dim3(flag_top, kgen_unit, "flag_top", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(cltemp, kgen_unit, "cltemp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(cmtemp, kgen_unit, "cmtemp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(chtemp, kgen_unit, "chtemp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(cttemp, kgen_unit, "cttemp", .FALSE.) CALL kr_crm_real__r8_dim2(mui_crm, kgen_unit, "mui_crm", .FALSE.) CALL kr_crm_real__r8_dim2(mdi_crm, kgen_unit, "mdi_crm", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(crm_rad_temperature, kgen_unit, "crm_rad_temperature", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(crm_rad_qv, kgen_unit, "crm_rad_qv", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(crm_rad_qc, kgen_unit, "crm_rad_qc", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(crm_rad_qi, kgen_unit, "crm_rad_qi", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(crm_rad_cld, kgen_unit, "crm_rad_cld", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(crm_rad_qrad, kgen_unit, "crm_rad_qrad", .FALSE.) !extern output variables CALL kr_externs_out_vars(kgen_unit) CALL kr_externs_out_grid(kgen_unit) CALL kr_externs_out_sgs(kgen_unit) CALL kr_externs_out_params(kgen_unit) CALL kr_externs_out_microphysics(kgen_unit) CALL kr_externs_out_micro_params(kgen_unit) CALL kr_externs_out_crm_output_module(kgen_unit) CALL kr_externs_out_accelerate_crm_mod(kgen_unit) !local output variables READ (UNIT = kgen_unit) kgenref_tmp1 READ (UNIT = kgen_unit) kgenref_tmp READ (UNIT = kgen_unit) kgenref_icrm READ (UNIT = kgen_unit) kgenref_icyc READ (UNIT = kgen_unit) kgenref_k READ (UNIT = kgen_unit) kgenref_j READ (UNIT = kgen_unit) kgenref_i READ (UNIT = kgen_unit) kgenref_nn READ (UNIT = kgen_unit) kgenref_l READ (UNIT = kgen_unit) kgenref_kx READ (UNIT = kgen_unit) kgenref_qsat READ (UNIT = kgen_unit) kgenref_i_rad READ (UNIT = kgen_unit) kgenref_j_rad READ (UNIT = kgen_unit) kgenref_crm_accel_ceaseflag CALL kr_crm_real__crm_rknd_dim3(kgenref_cwp, kgen_unit, "kgenref_cwp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(kgenref_cwph, kgen_unit, "kgenref_cwph", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(kgenref_cwpm, kgen_unit, "kgenref_cwpm", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(kgenref_cwpl, kgen_unit, "kgenref_cwpl", .FALSE.) CALL kr_crm_logical___dim3(kgenref_flag_top, kgen_unit, "kgenref_flag_top", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(kgenref_cltemp, kgen_unit, "kgenref_cltemp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(kgenref_cmtemp, kgen_unit, "kgenref_cmtemp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(kgenref_chtemp, kgen_unit, "kgenref_chtemp", .FALSE.) CALL kr_crm_real__crm_rknd_dim3(kgenref_cttemp, kgen_unit, "kgenref_cttemp", .FALSE.) CALL kr_crm_real__r8_dim2(kgenref_mui_crm, kgen_unit, "kgenref_mui_crm", .FALSE.) CALL kr_crm_real__r8_dim2(kgenref_mdi_crm, kgen_unit, "kgenref_mdi_crm", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(kgenref_crm_rad_temperature, kgen_unit, "kgenref_crm_rad_temperature", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(kgenref_crm_rad_qv, kgen_unit, "kgenref_crm_rad_qv", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(kgenref_crm_rad_qc, kgen_unit, "kgenref_crm_rad_qc", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(kgenref_crm_rad_qi, kgen_unit, "kgenref_crm_rad_qi", .FALSE.) CALL kr_crm_real__crm_rknd_dim4_ptr(kgenref_crm_rad_cld, kgen_unit, "kgenref_crm_rad_cld", .FALSE.) !$omp target enter data map(alloc: t00 ) !$omp target enter data map(alloc: tln ) !$omp target enter data map(alloc: qln ) !$omp target enter data map(alloc: qccln ) !$omp target enter data map(alloc: qiiln ) !$omp target enter data map(alloc: uln ) !$omp target enter data map(alloc: vln ) !$omp target enter data map(alloc: cwp ) !$omp target enter data map(alloc: cwph ) !$omp target enter data map(alloc: cwpm ) !$omp target enter data map(alloc: cwpl ) !$omp target enter data map(alloc: flag_top ) !$omp target enter data map(alloc: cltemp ) !$omp target enter data map(alloc: cmtemp ) !$omp target enter data map(alloc: chtemp ) !$omp target enter data map(alloc: cttemp ) !$omp target enter data map(alloc: dd_crm ) !$omp target enter data map(alloc: mui_crm ) !$omp target enter data map(alloc: mdi_crm ) !$omp target enter data map(alloc: ustar ) !$omp target enter data map(alloc: bflx ) !$omp target enter data map(alloc: wnd ) !$omp target enter data map(alloc: qtot ) !$omp target enter data map(alloc: colprec ) !$omp target enter data map(alloc: colprecs ) !$omp target enter data map(alloc: crm_rad_temperature ) !$omp target enter data map(alloc: crm_rad_qv ) !$omp target enter data map(alloc: crm_rad_qc ) !$omp target enter data map(alloc: crm_rad_qi ) !$omp target enter data map(alloc: crm_rad_cld ) !$omp target enter data map(alloc: crm_rad_qrad ) !$omp target enter data map(alloc: crm_state_u_wind ) !$omp target enter data map(alloc: crm_state_v_wind ) !$omp target enter data map(alloc: crm_state_w_wind ) !$omp target enter data map(alloc: crm_state_temperature ) !$omp target enter data map(alloc: crm_state_qt ) !$omp target enter data map(alloc: crm_state_qp ) !$omp target enter data map(alloc: crm_state_qn ) !Loop over "vector columns" !----------------------------------------------- !----------------------------------------- ! update data at device !$omp taskwait ! Initialize CRM fields: !$omp target teams distribute parallel do collapse(4) ! limit the velocity at the very first step: ! Populate microphysics array from crm_state !$omp target teams distribute parallel do collapse(4) ! initialize sgs fields !$omp target teams distribute parallel do !$omp target teams distribute parallel do collapse(2) !$omp target teams distribute parallel do collapse(4) !$omp target teams distribute parallel do collapse(2) !$omp target teams distribute parallel do !--------------------------------------------------- !$omp target teams distribute parallel do collapse(2) !$omp target teams distribute parallel do !-------------------------------------------------- !======================================================================================== !---------------------------------------------------------------------------------------- ! Main time loop !---------------------------------------------------------------------------------------- !======================================================================================== !$omp taskwait IF (kgen_evalstage) THEN END IF IF (kgen_warmupstage) THEN END IF IF (kgen_mainstage) THEN END IF !Uncomment following call statement to turn on perturbation experiment. !Adjust perturbation value and/or kind parameter if required. !CALL kgen_perturb_real( your_variable, 1.0D-15 ) !call to kgen kernel nstep = nstep + 1 !$omp target teams distribute parallel do do icrm = 1 , ncrms crm_output_timing_factor(icrm) = crm_output_timing_factor(icrm)+1 enddo !------------------------------------------------------------------ ! Check if the dynamical time step should be decreased ! to handle the cases when the flow being locally linearly unstable !------------------------------------------------------------------ call kurant(ncrms) !$omp taskwait do icyc=1,ncycle icycle = icyc dtn = dt/ncycle dt3(na) = dtn dtfactor = dtn/dt !--------------------------------------------- ! the Adams-Bashforth scheme in time call abcoefs(ncrms) !--------------------------------------------- ! initialize stuff: call zero(ncrms) !----------------------------------------------------------- ! Buoyancy term: call buoyancy(ncrms) !------------------------------------------------------------ ! Large-scale and surface forcing: call forcing(ncrms) ! Apply radiative tendency !$omp target teams distribute parallel do collapse(4) do k=1,nzm do j=1,ny do i=1,nx do icrm = 1 , ncrms i_rad = (i-1) / (nx/crm_nx_rad) + 1 j_rad = (j-1) / (ny/crm_ny_rad) + 1 !$omp atomic update t(icrm,i,j,k) = t(icrm,i,j,k) + crm_rad_qrad(icrm,i_rad,j_rad,k)*dtn enddo enddo enddo enddo !---------------------------------------------------------- ! suppress turbulence near the upper boundary (spange): if (dodamping) call damping(ncrms) !--------------------------------------------------------- ! Ice fall-out if(docloud) then call ice_fall(ncrms) endif !---------------------------------------------------------- ! Update scalar boundaries after large-scale processes: call boundaries(ncrms,3) !--------------------------------------------------------- ! Update boundaries for velocities: call boundaries(ncrms,0) !----------------------------------------------- ! surface fluxes: if (dosurface) call crm_surface(ncrms,bflx) !----------------------------------------------------------- ! SGS physics: if (dosgs) call sgs_proc(ncrms) !---------------------------------------------------------- ! Fill boundaries for SGS diagnostic fields: call boundaries(ncrms,4) !----------------------------------------------- ! advection of momentum: call advect_mom(ncrms) !---------------------------------------------------------- ! SGS effects on momentum: if(dosgs) call sgs_mom(ncrms) !----------------------------------------------------------- ! Coriolis force: if (docoriolis) call coriolis(ncrms) !--------------------------------------------------------- ! compute rhs of the Poisson equation and solve it for pressure. call pressure(ncrms) !--------------------------------------------------------- ! find velocity field at n+1/2 timestep needed for advection of scalars: ! Note that at the end of the call, the velocities are in nondimensional form. call adams(ncrms) !---------------------------------------------------------- ! Update boundaries for all prognostic scalar fields for advection: call boundaries(ncrms,2) !--------------------------------------------------------- ! advection of scalars : call advect_all_scalars(ncrms) !----------------------------------------------------------- ! Convert velocity back from nondimensional form: call uvw(ncrms) !---------------------------------------------------------- ! Update boundaries for scalars to prepare for SGS effects: call boundaries(ncrms,3) !--------------------------------------------------------- ! SGS effects on scalars : if (dosgs) call sgs_scalars(ncrms) !----------------------------------------------------------- ! Calculate PGF for scalar momentum tendency !----------------------------------------------------------- ! Cloud condensation/evaporation and precipitation processes: if(docloud) call micro_proc(ncrms) !----------------------------------------------------------- ! Apply mean-state acceleration if (use_crm_accel .and. .not. crm_accel_ceaseflag) then ! Use Jones-Bretherton-Pritchard methodology to accelerate ! CRM horizontal mean evolution artificially. call accelerate_crm(ncrms, nstep, nstop, crm_accel_ceaseflag) endif !----------------------------------------------------------- ! Compute diagnostics fields: call diagnose(ncrms) !---------------------------------------------------------- ! Rotate the dynamic tendency arrays for Adams-bashforth scheme: nn=na na=nc nc=nb nb=nn enddo ! icycle !$omp target teams distribute parallel do collapse(3) do j = 1 , ny do i = 1 , nx do icrm = 1 , ncrms cwp(icrm,i,j) = 0. cwph(icrm,i,j) = 0. cwpm(icrm,i,j) = 0. cwpl(icrm,i,j) = 0. flag_top(icrm,i,j) = .true. cltemp(icrm,i,j) = 0.0; cmtemp(icrm,i,j) = 0.0 chtemp(icrm,i,j) = 0.0; cttemp(icrm,i,j) = 0.0 enddo enddo enddo !$omp target teams distribute parallel do collapse(3) do j=1,ny do i=1,nx do icrm = 1 , ncrms do k=1,nzm l = plev-k+1 tmp1 = rho(icrm,nz-k)*adz(icrm,nz-k)*dz(icrm)*(qcl(icrm,i,j,nz-k)+qci(icrm,i,j,nz-k)) !$omp atomic update cwp(icrm,i,j) = cwp(icrm,i,j)+tmp1 cttemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), cttemp(icrm,i,j)) if(cwp(icrm,i,j).gt.cwp_threshold.and.flag_top(icrm,i,j)) then !$omp atomic update crm_output_cldtop(icrm,l) = crm_output_cldtop(icrm,l) + 1 flag_top(icrm,i,j) = .false. endif if(pres(icrm,nz-k).ge.700.) then !$omp atomic update cwpl(icrm,i,j) = cwpl(icrm,i,j)+tmp1 cltemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), cltemp(icrm,i,j)) else if(pres(icrm,nz-k).lt.400.) then !$omp atomic update cwph(icrm,i,j) = cwph(icrm,i,j)+tmp1 chtemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), chtemp(icrm,i,j)) else !$omp atomic update cwpm(icrm,i,j) = cwpm(icrm,i,j)+tmp1 cmtemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), cmtemp(icrm,i,j)) endif tmp1 = rho(icrm,k)*adz(icrm,k)*dz(icrm) if(tmp1*(qcl(icrm,i,j,k)+qci(icrm,i,j,k)).gt.cwp_threshold) then !$omp atomic update crm_output_cld(icrm,l) = crm_output_cld(icrm,l) + cf3d(icrm,i,j,k) if(w(icrm,i,j,k+1)+w(icrm,i,j,k).gt.2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * cf3d(icrm,i,j,k) !$omp atomic update crm_output_mcup (icrm,l) = crm_output_mcup (icrm,l) + tmp tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * (1.0 - cf3d(icrm,i,j,k)) !$omp atomic update crm_output_mcuup(icrm,l) = crm_output_mcuup(icrm,l) + tmp endif if(w(icrm,i,j,k+1)+w(icrm,i,j,k).lt.-2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * cf3d(icrm,i,j,k) !$omp atomic update crm_output_mcdn (icrm,l) = crm_output_mcdn (icrm,l) + tmp tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * (1. - cf3d(icrm,i,j,k)) !$omp atomic update crm_output_mcudn(icrm,l) = crm_output_mcudn(icrm,l) + tmp endif else if(w(icrm,i,j,k+1)+w(icrm,i,j,k).gt.2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) !$omp atomic update crm_output_mcuup(icrm,l) = crm_output_mcuup(icrm,l) + tmp endif if(w(icrm,i,j,k+1)+w(icrm,i,j,k).lt.-2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) !$omp atomic update crm_output_mcudn(icrm,l) = crm_output_mcudn(icrm,l) + tmp endif endif !$omp atomic update crm_output_gliqwp(icrm,l) = crm_output_gliqwp(icrm,l) + qcl(icrm,i,j,k) !$omp atomic update crm_output_gicewp(icrm,l) = crm_output_gicewp(icrm,l) + qci(icrm,i,j,k) enddo enddo enddo enddo !$omp target teams distribute parallel do collapse(4) do k=1,nzm do j=1,ny do i=1,nx do icrm = 1 , ncrms ! Reduced radiation method allows for fewer radiation calculations ! by collecting statistics and doing radiation over column groups i_rad = (i-1) / (nx/crm_nx_rad) + 1 j_rad = (j-1) / (ny/crm_ny_rad) + 1 !$omp atomic update crm_rad_temperature(icrm,i_rad,j_rad,k) = crm_rad_temperature(icrm,i_rad,j_rad,k) + tabs(icrm,i,j,k) tmp = max(real(0.,crm_rknd),qv(icrm,i,j,k)) !$omp atomic update crm_rad_qv (icrm,i_rad,j_rad,k) = crm_rad_qv (icrm,i_rad,j_rad,k) + tmp !$omp atomic update crm_rad_qc (icrm,i_rad,j_rad,k) = crm_rad_qc (icrm,i_rad,j_rad,k) + qcl(icrm,i,j,k) !$omp atomic update crm_rad_qi (icrm,i_rad,j_rad,k) = crm_rad_qi (icrm,i_rad,j_rad,k) + qci(icrm,i,j,k) if (qcl(icrm,i,j,k) + qci(icrm,i,j,k) > 0) then !$omp atomic update crm_rad_cld (icrm,i_rad,j_rad,k) = crm_rad_cld (icrm,i_rad,j_rad,k) + cf3d(icrm,i,j,k) endif enddo enddo enddo enddo ! Diagnose mass fluxes to drive None's convective transport of tracers. ! definition of mass fluxes is taken from Xu et al., 2002, QJRMS. !$omp target teams distribute parallel do collapse(3) do j=1, ny do i=1, nx do icrm = 1 , ncrms do k=1, nzm+1 l=plev+1-k+1 if(w(icrm,i,j,k).gt.0.) then kx=max(1, k-1) qsat = qsatw_crm(tabs(icrm,i,j,kx),pres(icrm,kx)) if(qcl(icrm,i,j,kx)+qci(icrm,i,j,kx).gt.min(real(1.e-5,crm_rknd),0.01*qsat)) then tmp = rhow(icrm,k)*w(icrm,i,j,k) !$omp atomic update mui_crm(icrm,l) = mui_crm(icrm,l)+tmp endif else if (w(icrm,i,j,k).lt.0.) then kx=min(k+1, nzm) qsat = qsatw_crm(tabs(icrm,i,j,kx),pres(icrm,kx)) if(qcl(icrm,i,j,kx)+qci(icrm,i,j,kx).gt.min(real(1.e-5,crm_rknd),0.01*qsat)) then tmp = rhow(icrm,k)*w(icrm,i,j,k) !$omp atomic update mdi_crm(icrm,l) = mdi_crm(icrm,l)+tmp else if(qpl(icrm,i,j,kx)+qpi(icrm,i,j,kx).gt.1.0e-4) then tmp = rhow(icrm,k)*w(icrm,i,j,k) !$omp atomic update mdi_crm(icrm,l) = mdi_crm(icrm,l)+tmp endif endif enddo enddo enddo enddo !$omp target teams distribute parallel do collapse(3) do j=1,ny do i=1,nx do icrm = 1 , ncrms if(cwp(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_cltot(icrm) = crm_output_cltot(icrm) + cttemp(icrm,i,j) endif if(cwph(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_clhgh(icrm) = crm_output_clhgh(icrm) + chtemp(icrm,i,j) endif if(cwpm(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_clmed(icrm) = crm_output_clmed(icrm) + cmtemp(icrm,i,j) endif if(cwpl(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_cllow(icrm) = crm_output_cllow(icrm) + cltemp(icrm,i,j) endif enddo enddo enddo IF (kgen_mainstage) THEN !verify init CALL kgen_init_verify(tolerance=1.D-14, minvalue=1.D-14, verboseLevel=1) !CALL kgen_init_verify(tolerance=1.D-7, minvalue=1.D-14, verboseLevel=1) CALL kgen_init_check(check_status, rank=kgen_mpirank) !extern verify variables CALL kv_externs_vars(check_status) CALL kv_externs_grid(check_status) CALL kv_externs_params(check_status) CALL kv_externs_microphysics(check_status) CALL kv_externs_micro_params(check_status) CALL kv_externs_crm_output_module(check_status) !local verify variables !TMPVAR CALL kv_crm_real__crm_rknd("tmp", check_status, tmp, kgenref_tmp) !TMPVAR CALL kv_crm_real__crm_rknd("tmp1", check_status, tmp1, kgenref_tmp1) !TMPVAR CALL kv_crm_integer__("nn", check_status, nn, kgenref_nn) !TMPVAR CALL kv_crm_integer__("icrm", check_status, icrm, kgenref_icrm) !TMPVAR CALL kv_crm_integer__("i", check_status, i, kgenref_i) !TMPVAR CALL kv_crm_integer__("k", check_status, k, kgenref_k) !TMPVAR CALL kv_crm_integer__("j", check_status, j, kgenref_j) !TMPVAR CALL kv_crm_integer__("l", check_status, l, kgenref_l) !TMPVAR CALL kv_crm_integer__("icyc", check_status, icyc, kgenref_icyc) !TMPVAR CALL kv_crm_integer__("kx", check_status, kx, kgenref_kx) CALL kv_crm_real__crm_rknd("qsat", check_status, qsat, kgenref_qsat) !TMPVAR CALL kv_crm_integer__("i_rad", check_status, i_rad, kgenref_i_rad) !TMPVAR CALL kv_crm_integer__("j_rad", check_status, j_rad, kgenref_j_rad) CALL kv_crm_logical__("crm_accel_ceaseflag", check_status, crm_accel_ceaseflag, kgenref_crm_accel_ceaseflag) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("cwp", check_status, cwp, kgenref_cwp) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("cwph", check_status, cwph, kgenref_cwph) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("cwpm", check_status, cwpm, kgenref_cwpm) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("cwpl", check_status, cwpl, kgenref_cwpl) !TMPVAR CALL kv_crm_logical___dim3("flag_top", check_status, flag_top, kgenref_flag_top) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("cltemp", check_status, cltemp, kgenref_cltemp) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("cmtemp", check_status, cmtemp, kgenref_cmtemp) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("chtemp", check_status, chtemp, kgenref_chtemp) !TMPVAR CALL kv_crm_real__crm_rknd_dim3("cttemp", check_status, cttemp, kgenref_cttemp) CALL kv_crm_real__r8_dim2("mui_crm", check_status, mui_crm, kgenref_mui_crm) CALL kv_crm_real__r8_dim2("mdi_crm", check_status, mdi_crm, kgenref_mdi_crm) CALL kv_crm_real__crm_rknd_dim4_ptr("crm_rad_temperature", check_status, crm_rad_temperature, & &kgenref_crm_rad_temperature) CALL kv_crm_real__crm_rknd_dim4_ptr("crm_rad_qv", check_status, crm_rad_qv, kgenref_crm_rad_qv) CALL kv_crm_real__crm_rknd_dim4_ptr("crm_rad_qc", check_status, crm_rad_qc, kgenref_crm_rad_qc) CALL kv_crm_real__crm_rknd_dim4_ptr("crm_rad_qi", check_status, crm_rad_qi, kgenref_crm_rad_qi) CALL kv_crm_real__crm_rknd_dim4_ptr("crm_rad_cld", check_status, crm_rad_cld, kgenref_crm_rad_cld) IF (check_status%rank == 0) THEN WRITE (*, *) "" END IF IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Number of output variables: ", check_status%numTotal WRITE (*, *) "Number of identical variables: ", check_status%numIdentical WRITE (*, *) "Number of non-identical variables within tolerance: ", check_status%numInTol WRITE (*, *) "Number of non-identical variables out of tolerance: ", check_status%numOutTol WRITE (*, *) "Tolerance: ", kgen_tolerance END IF END IF IF (check_status%rank == 0) THEN WRITE (*, *) "" END IF IF (check_status%numOutTol > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Verification FAILED with" // TRIM(ADJUSTL(kgen_filepath)) END IF check_status%Passed = .FALSE. kgen_isverified = .FALSE. ELSE IF (check_status%rank == 0) THEN WRITE (*, *) "Verification PASSED with " // TRIM(ADJUSTL(kgen_filepath)) END IF check_status%Passed = .TRUE. kgen_isverified = .TRUE. END IF IF (check_status%rank == 0) THEN WRITE (*, *) "" END IF #ifdef _MPI call mpi_barrier(mpi_comm_world, kgen_ierr) #endif CALL SYSTEM_CLOCK(kgen_start_clock, kgen_rate_clock) DO kgen_intvar = 1, KGEN_MAXITER call extrae_user_function(1) nstep = nstep + 1 !$omp target teams distribute parallel do do icrm = 1 , ncrms crm_output_timing_factor(icrm) = crm_output_timing_factor(icrm)+1 enddo !------------------------------------------------------------------ ! Check if the dynamical time step should be decreased ! to handle the cases when the flow being locally linearly unstable !------------------------------------------------------------------ call kurant(ncrms) !$omp taskwait do icyc=1,ncycle icycle = icyc dtn = dt/ncycle dt3(na) = dtn dtfactor = dtn/dt !--------------------------------------------- ! the Adams-Bashforth scheme in time call abcoefs(ncrms) !--------------------------------------------- ! initialize stuff: call zero(ncrms) !----------------------------------------------------------- ! Buoyancy term: call buoyancy(ncrms) !------------------------------------------------------------ ! Large-scale and surface forcing: call forcing(ncrms) ! Apply radiative tendency !$omp target teams distribute parallel do collapse(4) do k=1,nzm do j=1,ny do i=1,nx do icrm = 1 , ncrms i_rad = (i-1) / (nx/crm_nx_rad) + 1 j_rad = (j-1) / (ny/crm_ny_rad) + 1 !$omp atomic update t(icrm,i,j,k) = t(icrm,i,j,k) + crm_rad_qrad(icrm,i_rad,j_rad,k)*dtn enddo enddo enddo enddo !---------------------------------------------------------- ! suppress turbulence near the upper boundary (spange): if (dodamping) call damping(ncrms) !--------------------------------------------------------- ! Ice fall-out if(docloud) then call ice_fall(ncrms) endif !---------------------------------------------------------- ! Update scalar boundaries after large-scale processes: call boundaries(ncrms,3) !--------------------------------------------------------- ! Update boundaries for velocities: call boundaries(ncrms,0) !----------------------------------------------- ! surface fluxes: if (dosurface) call crm_surface(ncrms,bflx) !----------------------------------------------------------- ! SGS physics: if (dosgs) call sgs_proc(ncrms) !---------------------------------------------------------- ! Fill boundaries for SGS diagnostic fields: call boundaries(ncrms,4) !----------------------------------------------- ! advection of momentum: call advect_mom(ncrms) !---------------------------------------------------------- ! SGS effects on momentum: if(dosgs) call sgs_mom(ncrms) !----------------------------------------------------------- ! Coriolis force: if (docoriolis) call coriolis(ncrms) !--------------------------------------------------------- ! compute rhs of the Poisson equation and solve it for pressure. call pressure(ncrms) !--------------------------------------------------------- ! find velocity field at n+1/2 timestep needed for advection of scalars: ! Note that at the end of the call, the velocities are in nondimensional form. call adams(ncrms) !---------------------------------------------------------- ! Update boundaries for all prognostic scalar fields for advection: call boundaries(ncrms,2) !--------------------------------------------------------- ! advection of scalars : call advect_all_scalars(ncrms) !----------------------------------------------------------- ! Convert velocity back from nondimensional form: call uvw(ncrms) !---------------------------------------------------------- ! Update boundaries for scalars to prepare for SGS effects: call boundaries(ncrms,3) !--------------------------------------------------------- ! SGS effects on scalars : if (dosgs) call sgs_scalars(ncrms) !----------------------------------------------------------- ! Calculate PGF for scalar momentum tendency !----------------------------------------------------------- ! Cloud condensation/evaporation and precipitation processes: if(docloud) call micro_proc(ncrms) !----------------------------------------------------------- ! Apply mean-state acceleration if (use_crm_accel .and. .not. crm_accel_ceaseflag) then ! Use Jones-Bretherton-Pritchard methodology to accelerate ! CRM horizontal mean evolution artificially. call accelerate_crm(ncrms, nstep, nstop, crm_accel_ceaseflag) endif !----------------------------------------------------------- ! Compute diagnostics fields: call diagnose(ncrms) !---------------------------------------------------------- ! Rotate the dynamic tendency arrays for Adams-bashforth scheme: nn=na na=nc nc=nb nb=nn enddo ! icycle !$omp target teams distribute parallel do collapse(3) do j = 1 , ny do i = 1 , nx do icrm = 1 , ncrms cwp(icrm,i,j) = 0. cwph(icrm,i,j) = 0. cwpm(icrm,i,j) = 0. cwpl(icrm,i,j) = 0. flag_top(icrm,i,j) = .true. cltemp(icrm,i,j) = 0.0; cmtemp(icrm,i,j) = 0.0 chtemp(icrm,i,j) = 0.0; cttemp(icrm,i,j) = 0.0 enddo enddo enddo !$omp target teams distribute parallel do collapse(3) do j=1,ny do i=1,nx do icrm = 1 , ncrms do k=1,nzm l = plev-k+1 tmp1 = rho(icrm,nz-k)*adz(icrm,nz-k)*dz(icrm)*(qcl(icrm,i,j,nz-k)+qci(icrm,i,j,nz-k)) !$omp atomic update cwp(icrm,i,j) = cwp(icrm,i,j)+tmp1 cttemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), cttemp(icrm,i,j)) if(cwp(icrm,i,j).gt.cwp_threshold.and.flag_top(icrm,i,j)) then !$omp atomic update crm_output_cldtop(icrm,l) = crm_output_cldtop(icrm,l) + 1 flag_top(icrm,i,j) = .false. endif if(pres(icrm,nz-k).ge.700.) then !$omp atomic update cwpl(icrm,i,j) = cwpl(icrm,i,j)+tmp1 cltemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), cltemp(icrm,i,j)) else if(pres(icrm,nz-k).lt.400.) then !$omp atomic update cwph(icrm,i,j) = cwph(icrm,i,j)+tmp1 chtemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), chtemp(icrm,i,j)) else !$omp atomic update cwpm(icrm,i,j) = cwpm(icrm,i,j)+tmp1 cmtemp(icrm,i,j) = max(cf3d(icrm,i,j,nz-k), cmtemp(icrm,i,j)) endif tmp1 = rho(icrm,k)*adz(icrm,k)*dz(icrm) if(tmp1*(qcl(icrm,i,j,k)+qci(icrm,i,j,k)).gt.cwp_threshold) then !$omp atomic update crm_output_cld(icrm,l) = crm_output_cld(icrm,l) + cf3d(icrm,i,j,k) if(w(icrm,i,j,k+1)+w(icrm,i,j,k).gt.2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * cf3d(icrm,i,j,k) !$omp atomic update crm_output_mcup (icrm,l) = crm_output_mcup (icrm,l) + tmp tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * (1.0 - cf3d(icrm,i,j,k)) !$omp atomic update crm_output_mcuup(icrm,l) = crm_output_mcuup(icrm,l) + tmp endif if(w(icrm,i,j,k+1)+w(icrm,i,j,k).lt.-2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * cf3d(icrm,i,j,k) !$omp atomic update crm_output_mcdn (icrm,l) = crm_output_mcdn (icrm,l) + tmp tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) * (1. - cf3d(icrm,i,j,k)) !$omp atomic update crm_output_mcudn(icrm,l) = crm_output_mcudn(icrm,l) + tmp endif else if(w(icrm,i,j,k+1)+w(icrm,i,j,k).gt.2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) !$omp atomic update crm_output_mcuup(icrm,l) = crm_output_mcuup(icrm,l) + tmp endif if(w(icrm,i,j,k+1)+w(icrm,i,j,k).lt.-2*wmin) then tmp = rho(icrm,k)*0.5*(w(icrm,i,j,k+1)+w(icrm,i,j,k)) !$omp atomic update crm_output_mcudn(icrm,l) = crm_output_mcudn(icrm,l) + tmp endif endif !$omp atomic update crm_output_gliqwp(icrm,l) = crm_output_gliqwp(icrm,l) + qcl(icrm,i,j,k) !$omp atomic update crm_output_gicewp(icrm,l) = crm_output_gicewp(icrm,l) + qci(icrm,i,j,k) enddo enddo enddo enddo !$omp target teams distribute parallel do collapse(4) do k=1,nzm do j=1,ny do i=1,nx do icrm = 1 , ncrms ! Reduced radiation method allows for fewer radiation calculations ! by collecting statistics and doing radiation over column groups i_rad = (i-1) / (nx/crm_nx_rad) + 1 j_rad = (j-1) / (ny/crm_ny_rad) + 1 !$omp atomic update crm_rad_temperature(icrm,i_rad,j_rad,k) = crm_rad_temperature(icrm,i_rad,j_rad,k) + tabs(icrm,i,j,k) tmp = max(real(0.,crm_rknd),qv(icrm,i,j,k)) !$omp atomic update crm_rad_qv (icrm,i_rad,j_rad,k) = crm_rad_qv (icrm,i_rad,j_rad,k) + tmp !$omp atomic update crm_rad_qc (icrm,i_rad,j_rad,k) = crm_rad_qc (icrm,i_rad,j_rad,k) + qcl(icrm,i,j,k) !$omp atomic update crm_rad_qi (icrm,i_rad,j_rad,k) = crm_rad_qi (icrm,i_rad,j_rad,k) + qci(icrm,i,j,k) if (qcl(icrm,i,j,k) + qci(icrm,i,j,k) > 0) then !$omp atomic update crm_rad_cld (icrm,i_rad,j_rad,k) = crm_rad_cld (icrm,i_rad,j_rad,k) + cf3d(icrm,i,j,k) endif enddo enddo enddo enddo ! Diagnose mass fluxes to drive None's convective transport of tracers. ! definition of mass fluxes is taken from Xu et al., 2002, QJRMS. !$omp target teams distribute parallel do collapse(3) do j=1, ny do i=1, nx do icrm = 1 , ncrms do k=1, nzm+1 l=plev+1-k+1 if(w(icrm,i,j,k).gt.0.) then kx=max(1, k-1) qsat = qsatw_crm(tabs(icrm,i,j,kx),pres(icrm,kx)) if(qcl(icrm,i,j,kx)+qci(icrm,i,j,kx).gt.min(real(1.e-5,crm_rknd),0.01*qsat)) then tmp = rhow(icrm,k)*w(icrm,i,j,k) !$omp atomic update mui_crm(icrm,l) = mui_crm(icrm,l)+tmp endif else if (w(icrm,i,j,k).lt.0.) then kx=min(k+1, nzm) qsat = qsatw_crm(tabs(icrm,i,j,kx),pres(icrm,kx)) if(qcl(icrm,i,j,kx)+qci(icrm,i,j,kx).gt.min(real(1.e-5,crm_rknd),0.01*qsat)) then tmp = rhow(icrm,k)*w(icrm,i,j,k) !$omp atomic update mdi_crm(icrm,l) = mdi_crm(icrm,l)+tmp else if(qpl(icrm,i,j,kx)+qpi(icrm,i,j,kx).gt.1.0e-4) then tmp = rhow(icrm,k)*w(icrm,i,j,k) !$omp atomic update mdi_crm(icrm,l) = mdi_crm(icrm,l)+tmp endif endif enddo enddo enddo enddo !$omp target teams distribute parallel do collapse(3) do j=1,ny do i=1,nx do icrm = 1 , ncrms if(cwp(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_cltot(icrm) = crm_output_cltot(icrm) + cttemp(icrm,i,j) endif if(cwph(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_clhgh(icrm) = crm_output_clhgh(icrm) + chtemp(icrm,i,j) endif if(cwpm(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_clmed(icrm) = crm_output_clmed(icrm) + cmtemp(icrm,i,j) endif if(cwpl(icrm,i,j).gt.cwp_threshold) then !$omp atomic update crm_output_cllow(icrm) = crm_output_cllow(icrm) + cltemp(icrm,i,j) endif enddo enddo enddo END DO call extrae_user_function(0) call extrae_next_hwc_set() CALL SYSTEM_CLOCK(kgen_stop_clock, kgen_rate_clock) kgen_measure = 1.0D6*(kgen_stop_clock - kgen_start_clock)/DBLE(kgen_rate_clock*KGEN_MAXITER) #ifdef _MPI CALL mpi_allreduce(kgen_measure, gkgen_measure, 1, mpi_real8, mpi_max, mpi_comm_world, kgen_ierr) kgen_measure = gkgen_measure #endif IF (check_status%rank==0) THEN WRITE (*, *) "crm_main : Time per call (usec): ", kgen_measure END IF END IF IF (kgen_warmupstage) THEN END IF IF (kgen_evalstage) THEN END IF !$omp taskwait ! for time-averaging crm output statistics !======================================================================================== !---------------------------------------------------------------------------------------- ! End main time loop !---------------------------------------------------------------------------------------- !======================================================================================== !$omp target teams distribute parallel do collapse(4) ! no CRM tendencies above its top !$omp target teams distribute parallel do collapse(2) ! Compute tendencies due to CRM: !$omp target teams distribute parallel do collapse(2) !$omp target teams distribute parallel do !$omp target teams distribute parallel do collapse(4) !$omp target teams distribute parallel do collapse(2) !$omp target teams distribute parallel do collapse(2) !$omp target teams distribute parallel do ! don't use CRM tendencies from two crm top levels ! radiation tendencies are added back after the CRM call (see crm_physics_tend) !$omp target teams distribute parallel do collapse(2) !------------------------------------------------------------- ! Save the last step to the permanent core: ! !$omp target teams distribute parallel do collapse(4) !$omp target teams distribute parallel do !--------------------------------------------------------------- ! Diagnostics: ! hm add 9/7/11, change from GCM-time step avg to end-of-timestep !$omp target teams distribute parallel do collapse(4) !$omp target teams distribute parallel do collapse(2) !$omp target teams distribute parallel do !$omp target teams distribute parallel do collapse(3) !$omp target teams distribute parallel do collapse(3) !$omp target teams distribute parallel do !$omp target teams distribute parallel do collapse(2) !------------------------------------------------------------- ! Fluxes and other stat: !------------------------------------------------------------- !$omp target teams distribute parallel do collapse(2) !$omp taskwait !$omp target exit data map(delete: t00 ) !$omp target exit data map(delete: tln ) !$omp target exit data map(delete: qln ) !$omp target exit data map(delete: qccln ) !$omp target exit data map(delete: qiiln ) !$omp target exit data map(delete: uln ) !$omp target exit data map(delete: vln ) !$omp target exit data map(delete: cwp ) !$omp target exit data map(delete: cwph ) !$omp target exit data map(delete: cwpm ) !$omp target exit data map(delete: cwpl ) !$omp target exit data map(delete: flag_top ) !$omp target exit data map(delete: cltemp ) !$omp target exit data map(delete: cmtemp ) !$omp target exit data map(delete: chtemp ) !$omp target exit data map(delete: cttemp ) !$omp target exit data map(delete: dd_crm ) !$omp target exit data map(delete: mui_crm ) !$omp target exit data map(delete: mdi_crm ) !$omp target exit data map(delete: ustar ) !$omp target exit data map(delete: bflx ) !$omp target exit data map(delete: wnd ) !$omp target exit data map(delete: qtot ) !$omp target exit data map(delete: colprec ) !$omp target exit data map(delete: colprecs ) !$omp target exit data map(delete: crm_rad_temperature ) !$omp target exit data map(delete: crm_rad_qv ) !$omp target exit data map(delete: crm_rad_qc ) !$omp target exit data map(delete: crm_rad_qi ) !$omp target exit data map(delete: crm_rad_cld ) !$omp target exit data map(delete: crm_rad_qrad ) !$omp target exit data map(delete: crm_state_u_wind ) !$omp target exit data map(delete: crm_state_v_wind ) !$omp target exit data map(delete: crm_state_w_wind ) !$omp target exit data map(delete: crm_state_temperature ) !$omp target exit data map(delete: crm_state_qt ) !$omp target exit data map(delete: crm_state_qp ) !$omp target exit data map(delete: crm_state_qn ) CONTAINS ! ! update host from device !/ !read state subroutine for kr_crm_real__crm_rknd_dim1 SUBROUTINE kr_crm_real__crm_rknd_dim1(var, kgen_unit, printname, printvar) REAL(KIND=crm_rknd), INTENT(INOUT), ALLOCATABLE, DIMENSION(:) :: var INTEGER, INTENT(IN) :: kgen_unit CHARACTER(LEN=*), INTENT(IN) :: printname LOGICAL, INTENT(IN), OPTIONAL :: printvar LOGICAL :: kgen_istrue REAL(KIND=8) :: kgen_array_sum INTEGER :: idx1 INTEGER, DIMENSION(2,1) :: kgen_bound READ (UNIT = kgen_unit) kgen_istrue IF (kgen_istrue) THEN IF (ALLOCATED( var )) THEN DEALLOCATE (var) END IF READ (UNIT = kgen_unit) kgen_array_sum READ (UNIT = kgen_unit) kgen_bound(1, 1) READ (UNIT = kgen_unit) kgen_bound(2, 1) ALLOCATE (var(kgen_bound(1,1):kgen_bound(2,1))) READ (UNIT = kgen_unit) var CALL kgen_array_sumcheck(printname, kgen_array_sum, DBLE(SUM(var, mask=(var .eq. var))), .TRUE.) IF (PRESENT( printvar ) .AND. printvar) THEN WRITE (*, *) "KGEN DEBUG: DBLE(SUM(" // printname // ")) = ", DBLE(SUM(var, mask=(var .eq. var))) END IF END IF END SUBROUTINE kr_crm_real__crm_rknd_dim1 !read state subroutine for kr_crm_real__crm_rknd_dim3 SUBROUTINE kr_crm_real__crm_rknd_dim3(var, kgen_unit, printname, printvar) REAL(KIND=crm_rknd), INTENT(INOUT), ALLOCATABLE, DIMENSION(:,:,:) :: var INTEGER, INTENT(IN) :: kgen_unit CHARACTER(LEN=*), INTENT(IN) :: printname LOGICAL, INTENT(IN), OPTIONAL :: printvar LOGICAL :: kgen_istrue REAL(KIND=8) :: kgen_array_sum INTEGER :: idx1, idx2, idx3 INTEGER, DIMENSION(2,3) :: kgen_bound READ (UNIT = kgen_unit) kgen_istrue IF (kgen_istrue) THEN IF (ALLOCATED( var )) THEN DEALLOCATE (var) END IF READ (UNIT = kgen_unit) kgen_array_sum READ (UNIT = kgen_unit) kgen_bound(1, 1) READ (UNIT = kgen_unit) kgen_bound(2, 1) READ (UNIT = kgen_unit) kgen_bound(1, 2) READ (UNIT = kgen_unit) kgen_bound(2, 2) READ (UNIT = kgen_unit) kgen_bound(1, 3) READ (UNIT = kgen_unit) kgen_bound(2, 3) ALLOCATE (var(kgen_bound(1,1):kgen_bound(2,1), kgen_bound(1,2):kgen_bound(2,2), kgen_bound(1,3):kgen_bound(2,3))) READ (UNIT = kgen_unit) var CALL kgen_array_sumcheck(printname, kgen_array_sum, DBLE(SUM(var, mask=(var .eq. var))), .TRUE.) IF (PRESENT( printvar ) .AND. printvar) THEN WRITE (*, *) "KGEN DEBUG: DBLE(SUM(" // printname // ")) = ", DBLE(SUM(var, mask=(var .eq. var))) END IF END IF END SUBROUTINE kr_crm_real__crm_rknd_dim3 !read state subroutine for kr_crm_logical___dim3 SUBROUTINE kr_crm_logical___dim3(var, kgen_unit, printname, printvar) LOGICAL, INTENT(INOUT), ALLOCATABLE, DIMENSION(:,:,:) :: var INTEGER, INTENT(IN) :: kgen_unit CHARACTER(LEN=*), INTENT(IN) :: printname LOGICAL, INTENT(IN), OPTIONAL :: printvar LOGICAL :: kgen_istrue REAL(KIND=8) :: kgen_array_sum INTEGER :: idx1, idx2, idx3 INTEGER, DIMENSION(2,3) :: kgen_bound READ (UNIT = kgen_unit) kgen_istrue IF (kgen_istrue) THEN IF (ALLOCATED( var )) THEN DEALLOCATE (var) END IF READ (UNIT = kgen_unit) kgen_bound(1, 1) READ (UNIT = kgen_unit) kgen_bound(2, 1) READ (UNIT = kgen_unit) kgen_bound(1, 2) READ (UNIT = kgen_unit) kgen_bound(2, 2) READ (UNIT = kgen_unit) kgen_bound(1, 3) READ (UNIT = kgen_unit) kgen_bound(2, 3) ALLOCATE (var(kgen_bound(1,1):kgen_bound(2,1), kgen_bound(1,2):kgen_bound(2,2), kgen_bound(1,3):kgen_bound(2,3))) READ (UNIT = kgen_unit) var IF (PRESENT( printvar ) .AND. printvar) THEN WRITE (*, *) "KGEN DEBUG: " // printname // " = ", var END IF END IF END SUBROUTINE kr_crm_logical___dim3 !read state subroutine for kr_crm_real__r8_dim2 SUBROUTINE kr_crm_real__r8_dim2(var, kgen_unit, printname, printvar) REAL(KIND=r8), INTENT(INOUT), ALLOCATABLE, DIMENSION(:,:) :: var INTEGER, INTENT(IN) :: kgen_unit CHARACTER(LEN=*), INTENT(IN) :: printname LOGICAL, INTENT(IN), OPTIONAL :: printvar LOGICAL :: kgen_istrue REAL(KIND=8) :: kgen_array_sum INTEGER :: idx1, idx2 INTEGER, DIMENSION(2,2) :: kgen_bound READ (UNIT = kgen_unit) kgen_istrue IF (kgen_istrue) THEN IF (ALLOCATED( var )) THEN DEALLOCATE (var) END IF READ (UNIT = kgen_unit) kgen_array_sum READ (UNIT = kgen_unit) kgen_bound(1, 1) READ (UNIT = kgen_unit) kgen_bound(2, 1) READ (UNIT = kgen_unit) kgen_bound(1, 2) READ (UNIT = kgen_unit) kgen_bound(2, 2) ALLOCATE (var(kgen_bound(1,1):kgen_bound(2,1), kgen_bound(1,2):kgen_bound(2,2))) READ (UNIT = kgen_unit) var CALL kgen_array_sumcheck(printname, kgen_array_sum, DBLE(SUM(var, mask=(var .eq. var))), .TRUE.) IF (PRESENT( printvar ) .AND. printvar) THEN WRITE (*, *) "KGEN DEBUG: DBLE(SUM(" // printname // ")) = ", DBLE(SUM(var, mask=(var .eq. var))) END IF END IF END SUBROUTINE kr_crm_real__r8_dim2 !read state subroutine for kr_crm_real__crm_rknd_dim4_ptr SUBROUTINE kr_crm_real__crm_rknd_dim4_ptr(var, kgen_unit, printname, printvar) REAL(KIND=crm_rknd), INTENT(INOUT), POINTER, DIMENSION(:,:,:,:) :: var INTEGER, INTENT(IN) :: kgen_unit CHARACTER(LEN=*), INTENT(IN) :: printname LOGICAL, INTENT(IN), OPTIONAL :: printvar LOGICAL :: kgen_istrue REAL(KIND=8) :: kgen_array_sum INTEGER :: idx1, idx2, idx3, idx4 INTEGER, DIMENSION(2,4) :: kgen_bound READ (UNIT = kgen_unit) kgen_istrue IF (kgen_istrue) THEN IF (ASSOCIATED( var )) THEN NULLIFY (var) END IF READ (UNIT = kgen_unit) kgen_array_sum READ (UNIT = kgen_unit) kgen_bound(1, 1) READ (UNIT = kgen_unit) kgen_bound(2, 1) READ (UNIT = kgen_unit) kgen_bound(1, 2) READ (UNIT = kgen_unit) kgen_bound(2, 2) READ (UNIT = kgen_unit) kgen_bound(1, 3) READ (UNIT = kgen_unit) kgen_bound(2, 3) READ (UNIT = kgen_unit) kgen_bound(1, 4) READ (UNIT = kgen_unit) kgen_bound(2, 4) ALLOCATE (var(kgen_bound(1,1):kgen_bound(2,1), kgen_bound(1,2):kgen_bound(2,2), kgen_bound(1,3):kgen_bound(2,3), & &kgen_bound(1,4):kgen_bound(2,4))) READ (UNIT = kgen_unit) var CALL kgen_array_sumcheck(printname, kgen_array_sum, DBLE(SUM(var, mask=(var .eq. var))), .TRUE.) IF (PRESENT( printvar ) .AND. printvar) THEN WRITE (*, *) "KGEN DEBUG: DBLE(SUM(" // printname // ")) = ", DBLE(SUM(var, mask=(var .eq. var))) END IF END IF END SUBROUTINE kr_crm_real__crm_rknd_dim4_ptr !verify state subroutine for kv_crm_real__crm_rknd RECURSIVE SUBROUTINE kv_crm_real__crm_rknd(varname, check_status, var, kgenref_var) CHARACTER(LEN=*), INTENT(IN) :: varname TYPE(check_t), INTENT(INOUT) :: check_status REAL(KIND=crm_rknd), INTENT(IN) :: var, kgenref_var INTEGER :: check_result LOGICAL :: is_print = .FALSE. real(KIND=crm_rknd) :: diff check_status%numTotal = check_status%numTotal + 1 IF (var == kgenref_var) THEN check_status%numIdentical = check_status%numIdentical + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is IDENTICAL." END IF END IF check_result = CHECK_IDENTICAL ELSE diff = ABS(var - kgenref_var) IF (diff <= kgen_tolerance) THEN check_status%numInTol = check_status%numInTol + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(within tolerance)." END IF END IF check_result = CHECK_IN_TOL ELSE check_status%numOutTol = check_status%numOutTol + 1 IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(out of tolerance)." END IF END IF check_result = CHECK_OUT_TOL END IF END IF IF (check_result == CHECK_IDENTICAL) THEN IF (kgen_verboseLevel > 2) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Difference is ", 0 WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_OUT_TOL) THEN IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Difference is ", diff WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_IN_TOL) THEN IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Difference is ", diff WRITE (*, *) "" END IF END IF END IF END SUBROUTINE kv_crm_real__crm_rknd !verify state subroutine for kv_crm_integer__ RECURSIVE SUBROUTINE kv_crm_integer__(varname, check_status, var, kgenref_var) CHARACTER(LEN=*), INTENT(IN) :: varname TYPE(check_t), INTENT(INOUT) :: check_status INTEGER, INTENT(IN) :: var, kgenref_var INTEGER :: check_result LOGICAL :: is_print = .FALSE. integer :: diff check_status%numTotal = check_status%numTotal + 1 IF (var == kgenref_var) THEN check_status%numIdentical = check_status%numIdentical + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is IDENTICAL." END IF END IF check_result = CHECK_IDENTICAL ELSE diff = ABS(var - kgenref_var) IF (diff <= kgen_tolerance) THEN check_status%numInTol = check_status%numInTol + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(within tolerance)." END IF END IF check_result = CHECK_IN_TOL ELSE check_status%numOutTol = check_status%numOutTol + 1 IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(out of tolerance)." END IF END IF check_result = CHECK_OUT_TOL END IF END IF IF (check_result == CHECK_IDENTICAL) THEN IF (kgen_verboseLevel > 2) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Difference is ", 0 WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_OUT_TOL) THEN IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Difference is ", diff WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_IN_TOL) THEN IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "Difference is ", diff WRITE (*, *) "" END IF END IF END IF END SUBROUTINE kv_crm_integer__ !verify state subroutine for kv_crm_logical__ RECURSIVE SUBROUTINE kv_crm_logical__(varname, check_status, var, kgenref_var) CHARACTER(LEN=*), INTENT(IN) :: varname TYPE(check_t), INTENT(INOUT) :: check_status LOGICAL, INTENT(IN) :: var, kgenref_var INTEGER :: check_result LOGICAL :: is_print = .FALSE. logical :: diff check_status%numTotal = check_status%numTotal + 1 IF (var .EQV. kgenref_var) THEN check_status%numIdentical = check_status%numIdentical + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is IDENTICAL." END IF END IF check_result = CHECK_IDENTICAL ELSE check_status%numOutTol = check_status%numOutTol + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL." END IF END IF check_result = CHECK_OUT_TOL END IF IF (check_result == CHECK_IDENTICAL) THEN IF (kgen_verboseLevel > 2) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "NOT IMPLEMENTED" WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_OUT_TOL) THEN IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "NOT IMPLEMENTED" WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_IN_TOL) THEN IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "NOT IMPLEMENTED" WRITE (*, *) "" END IF END IF END IF END SUBROUTINE kv_crm_logical__ !verify state subroutine for kv_crm_real__crm_rknd_dim3 RECURSIVE SUBROUTINE kv_crm_real__crm_rknd_dim3(varname, check_status, var, kgenref_var) CHARACTER(LEN=*), INTENT(IN) :: varname TYPE(check_t), INTENT(INOUT) :: check_status REAL(KIND=crm_rknd), allocatable, INTENT(IN), DIMENSION(:,:,:) :: var, kgenref_var INTEGER :: check_result LOGICAL :: is_print = .FALSE. INTEGER :: idx1, idx2, idx3 INTEGER :: n real(KIND=crm_rknd) :: nrmsdiff, rmsdiff real(KIND=crm_rknd), ALLOCATABLE :: buf1(:,:,:), buf2(:,:,:) IF (ALLOCATED(var)) THEN check_status%numTotal = check_status%numTotal + 1 IF (ALL(var == kgenref_var)) THEN check_status%numIdentical = check_status%numIdentical + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is IDENTICAL." END IF END IF check_result = CHECK_IDENTICAL ELSE ALLOCATE (buf1(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) ALLOCATE (buf2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) n = SIZE(var) WHERE ( ABS(kgenref_var) > kgen_minvalue ) buf1 = ((var-kgenref_var)/kgenref_var)**2 buf2 = (var-kgenref_var)**2 ELSEWHERE buf1 = (var-kgenref_var)**2 buf2 = buf1 END WHERE nrmsdiff = SQRT(SUM(buf1)/DBLE(n)) rmsdiff = SQRT(SUM(buf2)/DBLE(n)) IF (rmsdiff > kgen_tolerance) THEN check_status%numOutTol = check_status%numOutTol + 1 IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(out of tolerance)." END IF END IF check_result = CHECK_OUT_TOL ELSE check_status%numInTol = check_status%numInTol + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(within tolerance)." END IF END IF check_result = CHECK_IN_TOL END IF END IF IF (check_result == CHECK_IDENTICAL) THEN IF (kgen_verboseLevel > 2) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", 0 WRITE (*, *) "Normalized RMS of difference is ", 0 WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_OUT_TOL) THEN IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", rmsdiff WRITE (*, *) "Normalized RMS of difference is ", nrmsdiff WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_IN_TOL) THEN IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", rmsdiff WRITE (*, *) "Normalized RMS of difference is ", nrmsdiff WRITE (*, *) "" END IF END IF END IF END IF END SUBROUTINE kv_crm_real__crm_rknd_dim3 !verify state subroutine for kv_crm_logical___dim3 RECURSIVE SUBROUTINE kv_crm_logical___dim3(varname, check_status, var, kgenref_var) CHARACTER(LEN=*), INTENT(IN) :: varname TYPE(check_t), INTENT(INOUT) :: check_status LOGICAL, allocatable, INTENT(IN), DIMENSION(:,:,:) :: var, kgenref_var INTEGER :: check_result LOGICAL :: is_print = .FALSE. INTEGER :: idx1, idx2, idx3 INTEGER :: n IF (ALLOCATED(var)) THEN check_status%numTotal = check_status%numTotal + 1 IF (ALL(var .EQV. kgenref_var)) THEN check_status%numIdentical = check_status%numIdentical + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is IDENTICAL." END IF END IF check_result = CHECK_IDENTICAL ELSE n = COUNT(var .NEQV. kgenref_var) check_status%numOutTol = check_status%numOutTol + 1 IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(out of tolerance)." END IF END IF check_result = CHECK_OUT_TOL END IF IF (check_result == CHECK_IDENTICAL) THEN IF (kgen_verboseLevel > 2) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "NOT IMPLEMENTED" WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_OUT_TOL) THEN IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "NOT IMPLEMENTED" WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_IN_TOL) THEN IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) "NOT IMPLEMENTED" WRITE (*, *) "" END IF END IF END IF END IF END SUBROUTINE kv_crm_logical___dim3 !verify state subroutine for kv_crm_real__r8_dim2 RECURSIVE SUBROUTINE kv_crm_real__r8_dim2(varname, check_status, var, kgenref_var) CHARACTER(LEN=*), INTENT(IN) :: varname TYPE(check_t), INTENT(INOUT) :: check_status REAL(KIND=r8), allocatable, INTENT(IN), DIMENSION(:,:) :: var, kgenref_var INTEGER :: check_result LOGICAL :: is_print = .FALSE. INTEGER :: idx1, idx2 INTEGER :: n real(KIND=r8) :: nrmsdiff, rmsdiff real(KIND=r8), ALLOCATABLE :: buf1(:,:), buf2(:,:) IF (ALLOCATED(var)) THEN check_status%numTotal = check_status%numTotal + 1 IF (ALL(var == kgenref_var)) THEN check_status%numIdentical = check_status%numIdentical + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is IDENTICAL." END IF END IF check_result = CHECK_IDENTICAL ELSE ALLOCATE (buf1(SIZE(var,dim=1),SIZE(var,dim=2))) ALLOCATE (buf2(SIZE(var,dim=1),SIZE(var,dim=2))) n = SIZE(var) WHERE ( ABS(kgenref_var) > kgen_minvalue ) buf1 = ((var-kgenref_var)/kgenref_var)**2 buf2 = (var-kgenref_var)**2 ELSEWHERE buf1 = (var-kgenref_var)**2 buf2 = buf1 END WHERE nrmsdiff = SQRT(SUM(buf1)/DBLE(n)) rmsdiff = SQRT(SUM(buf2)/DBLE(n)) IF (rmsdiff > kgen_tolerance) THEN check_status%numOutTol = check_status%numOutTol + 1 IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(out of tolerance)." END IF END IF check_result = CHECK_OUT_TOL ELSE check_status%numInTol = check_status%numInTol + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(within tolerance)." END IF END IF check_result = CHECK_IN_TOL END IF END IF IF (check_result == CHECK_IDENTICAL) THEN IF (kgen_verboseLevel > 2) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", 0 WRITE (*, *) "Normalized RMS of difference is ", 0 WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_OUT_TOL) THEN IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", rmsdiff WRITE (*, *) "Normalized RMS of difference is ", nrmsdiff WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_IN_TOL) THEN IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", rmsdiff WRITE (*, *) "Normalized RMS of difference is ", nrmsdiff WRITE (*, *) "" END IF END IF END IF END IF END SUBROUTINE kv_crm_real__r8_dim2 !verify state subroutine for kv_crm_real__crm_rknd_dim4_ptr RECURSIVE SUBROUTINE kv_crm_real__crm_rknd_dim4_ptr(varname, check_status, var, kgenref_var) CHARACTER(LEN=*), INTENT(IN) :: varname TYPE(check_t), INTENT(INOUT) :: check_status REAL(KIND=crm_rknd), pointer, INTENT(IN), DIMENSION(:,:,:,:) :: var, kgenref_var INTEGER :: check_result LOGICAL :: is_print = .FALSE. INTEGER :: idx1, idx2, idx3, idx4 INTEGER :: n real(KIND=crm_rknd) :: nrmsdiff, rmsdiff real(KIND=crm_rknd), ALLOCATABLE :: buf1(:,:,:,:), buf2(:,:,:,:) IF (ASSOCIATED(var)) THEN check_status%numTotal = check_status%numTotal + 1 IF (ALL(var == kgenref_var)) THEN check_status%numIdentical = check_status%numIdentical + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is IDENTICAL." END IF END IF check_result = CHECK_IDENTICAL ELSE ALLOCATE (buf1(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) ALLOCATE (buf2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) n = SIZE(var) WHERE ( ABS(kgenref_var) > kgen_minvalue ) buf1 = ((var-kgenref_var)/kgenref_var)**2 buf2 = (var-kgenref_var)**2 ELSEWHERE buf1 = (var-kgenref_var)**2 buf2 = buf1 END WHERE nrmsdiff = SQRT(SUM(buf1)/DBLE(n)) rmsdiff = SQRT(SUM(buf2)/DBLE(n)) IF (rmsdiff > kgen_tolerance) THEN check_status%numOutTol = check_status%numOutTol + 1 IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(out of tolerance)." END IF END IF check_result = CHECK_OUT_TOL ELSE check_status%numInTol = check_status%numInTol + 1 IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) trim(adjustl(varname)), " is NOT IDENTICAL(within tolerance)." END IF END IF check_result = CHECK_IN_TOL END IF END IF IF (check_result == CHECK_IDENTICAL) THEN IF (kgen_verboseLevel > 2) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", 0 WRITE (*, *) "Normalized RMS of difference is ", 0 WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_OUT_TOL) THEN IF (kgen_verboseLevel > 0) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", rmsdiff WRITE (*, *) "Normalized RMS of difference is ", nrmsdiff WRITE (*, *) "" END IF END IF ELSE IF (check_result == CHECK_IN_TOL) THEN IF (kgen_verboseLevel > 1) THEN IF (check_status%rank == 0) THEN WRITE (*, *) count( var /= kgenref_var), " of ", size( var ), " elements are different." WRITE (*, *) "Average - kernel ", sum(var)/real(size(var)) WRITE (*, *) "Average - reference ", sum(kgenref_var)/real(size(kgenref_var)) WRITE (*, *) "RMS of difference is ", rmsdiff WRITE (*, *) "Normalized RMS of difference is ", nrmsdiff WRITE (*, *) "" END IF END IF END IF END IF END SUBROUTINE kv_crm_real__crm_rknd_dim4_ptr END SUBROUTINE crm end module crm_module