diff --git a/README.md b/README.md index 0a3ea9db0..d9ad667c5 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,5 @@ -# GFDL_atmos_cubed_sphere - This is for the FV3 dynamical core and the GFDL Microphysics for use by NCEP/EMC within GFS. +The source in this branch reflects the codebase delivered to NCEP/EMC for use in GFS. Updates will be forthcoming. # Where to find information diff --git a/driver/fvGFS/atmosphere.F90 b/driver/fvGFS/atmosphere.F90 index 48b8d1d54..37f8bb64d 100644 --- a/driver/fvGFS/atmosphere.F90 +++ b/driver/fvGFS/atmosphere.F90 @@ -112,7 +112,7 @@ module atmosphere_mod ! ! mpp_mod ! mpp_error, stdout, FATAL, NOTE, input_nml_file, mpp_root_pe, -! mpp_npes, mpp_pe, mpp_chksum,mpp_get_current_pelist, +! mpp_npes, mpp_pe, mpp_chksum,mpp_get_current_pelist, ! mpp_set_current_pelist ! ! @@ -155,17 +155,17 @@ module atmosphere_mod mpp_clock_id, mpp_clock_begin, & mpp_clock_end, CLOCK_SUBCOMPONENT, & clock_flag_default, nullify_domain -use mpp_mod, only: mpp_error, stdout, FATAL, NOTE, & +use mpp_mod, only: mpp_error, stdout, FATAL, WARNING, NOTE, & input_nml_file, mpp_root_pe, & mpp_npes, mpp_pe, mpp_chksum, & mpp_get_current_pelist, & - mpp_set_current_pelist + mpp_set_current_pelist, mpp_sync use mpp_parameter_mod, only: EUPDATE, WUPDATE, SUPDATE, NUPDATE use mpp_domains_mod, only: domain2d, mpp_update_domains use xgrid_mod, only: grid_box_type use field_manager_mod, only: MODEL_ATMOS use tracer_manager_mod, only: get_tracer_index, get_number_tracers, & - NO_TRACER + NO_TRACER, get_tracer_names use DYCORE_typedefs, only: DYCORE_data_type use IPD_typedefs, only: IPD_data_type, kind_phys => IPD_kind_phys use fv_iau_mod, only: IAU_external_data_type @@ -173,8 +173,8 @@ module atmosphere_mod !----------------- ! FV core modules: !----------------- -use fv_arrays_mod, only: fv_atmos_type, R_GRID -use fv_control_mod, only: fv_init, fv_end, ngrids +use fv_arrays_mod, only: fv_atmos_type, R_GRID, fv_grid_bounds_type, phys_diag_type +use fv_control_mod, only: fv_control_init, fv_end, ngrids use fv_eta_mod, only: get_eta_level use fv_fill_mod, only: fill_gfs use fv_dynamics_mod, only: fv_dynamics @@ -183,9 +183,10 @@ module atmosphere_mod use fv_nggps_diags_mod, only: fv_nggps_diag_init, fv_nggps_diag, fv_nggps_tavg use fv_restart_mod, only: fv_restart, fv_write_restart use fv_timing_mod, only: timing_on, timing_off -use fv_mp_mod, only: switch_current_Atm +use fv_mp_mod, only: is_master use fv_sg_mod, only: fv_subgrid_z use fv_update_phys_mod, only: fv_update_phys +use fv_io_mod, only: fv_io_register_nudge_restart use fv_nwp_nudge_mod, only: fv_nwp_nudge_init, fv_nwp_nudge_end, do_adiabatic_init #ifdef MULTI_GASES use multi_gases_mod, only: virq, virq_max, num_gas, ri, cpi @@ -194,6 +195,7 @@ module atmosphere_mod a_step, p_step, current_time_in_seconds use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain +use fv_grid_utils_mod, only: g_sum implicit none private @@ -213,7 +215,8 @@ module atmosphere_mod atmosphere_diss_est, & ! dissipation estimate for SKEB atmosphere_get_bottom_layer, & atmosphere_nggps_diag, & - set_atmosphere_pelist + get_bottom_mass, get_bottom_wind, & + get_stock_pe, set_atmosphere_pelist !--- physics/radiation data exchange routines public :: atmos_phys_driver_statein @@ -226,7 +229,7 @@ module atmosphere_mod !---- private data ---- type (time_type) :: Time_step_atmos - public Atm, mytile + public Atm, mygrid !These are convenience variables for local use only, and are set to values in Atm% real :: dt_atmos @@ -245,7 +248,7 @@ module atmosphere_mod integer :: cld_amt #endif - integer :: mytile = 1 + integer :: mygrid = 1 integer :: p_split = 1 integer, allocatable :: pelist(:) logical, allocatable :: grids_on_this_pe(:) @@ -269,30 +272,13 @@ module atmosphere_mod !! and diagnostics. subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) #ifdef CCPP -#ifdef STATIC -! For static builds, the ccpp_physics_{init,run,finalize} calls -! are not pointing to code in the CCPP framework, but to auto-generated -! ccpp_suite_cap and ccpp_group_*_cap modules behind a ccpp_static_api - use ccpp_api, only: ccpp_init use ccpp_static_api, only: ccpp_physics_init -#else - use iso_c_binding, only: c_loc - use ccpp_api, only: ccpp_init, & - ccpp_physics_init, & - ccpp_field_add, & - ccpp_error -#endif use CCPP_data, only: ccpp_suite, & cdata => cdata_tile, & CCPP_interstitial #ifdef OPENMP use omp_lib #endif -#ifndef STATIC -! Begin include auto-generated list of modules for ccpp -#include "ccpp_modules_fast_physics.inc" -! End include auto-generated list of modules for ccpp -#endif #endif type (time_type), intent(in) :: Time_init, Time, Time_step type(grid_box_type), intent(inout) :: Grid_box @@ -308,6 +294,11 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) integer :: ierr #endif + integer :: nlunit = 9999 + character (len = 64) :: fn_nml = 'input.nml' + + !For regional + a_step = 0 current_time_in_seconds = time_type_to_real( Time - Time_init ) if (mpp_pe() == 0) write(*,"('atmosphere_init: current_time_seconds = ',f9.1)")current_time_in_seconds @@ -327,16 +318,11 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) !NOTE do we still need the second file_exist call? cold_start = (.not.file_exist('INPUT/fv_core.res.nc') .and. .not.file_exist('INPUT/fv_core.res.tile1.nc')) - call fv_init( Atm, dt_atmos, grids_on_this_pe, p_split ) ! allocates Atm components + call fv_control_init( Atm, dt_atmos, mygrid, grids_on_this_pe, p_split ) ! allocates Atm components; sets mygrid - do n=1,ngrids - if (grids_on_this_pe(n)) mytile = n - enddo - - Atm(mytile)%Time_init = Time_init + Atm(mygrid)%Time_init = Time_init - a_step = 0 - if(Atm(mytile)%flagstruct%warm_start) then + if(Atm(mygrid)%flagstruct%warm_start) then a_step = nint(current_time_in_seconds/dt_atmos) endif @@ -345,21 +331,21 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) !----------------------------------- - npx = Atm(mytile)%npx - npy = Atm(mytile)%npy - npz = Atm(mytile)%npz - ncnst = Atm(mytile)%ncnst - pnats = Atm(mytile)%flagstruct%pnats + npx = Atm(mygrid)%npx + npy = Atm(mygrid)%npy + npz = Atm(mygrid)%npz + ncnst = Atm(mygrid)%ncnst + pnats = Atm(mygrid)%flagstruct%pnats - isc = Atm(mytile)%bd%isc - iec = Atm(mytile)%bd%iec - jsc = Atm(mytile)%bd%jsc - jec = Atm(mytile)%bd%jec + isc = Atm(mygrid)%bd%isc + iec = Atm(mygrid)%bd%iec + jsc = Atm(mygrid)%bd%jsc + jec = Atm(mygrid)%bd%jec - isd = isc - Atm(mytile)%bd%ng - ied = iec + Atm(mytile)%bd%ng - jsd = jsc - Atm(mytile)%bd%ng - jed = jec + Atm(mytile)%bd%ng + isd = isc - Atm(mygrid)%bd%ng + ied = iec + Atm(mygrid)%bd%ng + jsd = jsc - Atm(mygrid)%bd%ng + jed = jec + Atm(mygrid)%bd%ng nq = ncnst-pnats sphum = get_tracer_index (MODEL_ATMOS, 'sphum' ) @@ -372,14 +358,15 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt') #endif - if (max(sphum,liq_wat,ice_wat,rainwat,snowwat,graupel) > Atm(mytile)%flagstruct%nwat) then + if (max(sphum,liq_wat,ice_wat,rainwat,snowwat,graupel) > Atm(mygrid)%flagstruct%nwat) then call mpp_error (FATAL,' atmosphere_init: condensate species are not first in the list of & &tracers defined in the field_table') endif ! Allocate grid variables to be used to calculate gradient in 2nd order flux exchange ! This data is only needed for the COARSEST grid. - call switch_current_Atm(Atm(mytile)) + !call switch_current_Atm(Atm(mygrid)) + call set_domain(Atm(mygrid)%domain) allocate(Grid_box%dx ( isc:iec , jsc:jec+1)) allocate(Grid_box%dy ( isc:iec+1, jsc:jec )) @@ -392,21 +379,21 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) allocate(Grid_box%en2 (3, isc:iec+1, jsc:jec )) allocate(Grid_box%vlon (3, isc:iec , jsc:jec )) allocate(Grid_box%vlat (3, isc:iec , jsc:jec )) - Grid_box%dx ( isc:iec , jsc:jec+1) = Atm(mytile)%gridstruct%dx ( isc:iec, jsc:jec+1) - Grid_box%dy ( isc:iec+1, jsc:jec ) = Atm(mytile)%gridstruct%dy ( isc:iec+1, jsc:jec ) - Grid_box%area ( isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%area ( isc:iec , jsc:jec ) - Grid_box%edge_w( jsc:jec+1) = Atm(mytile)%gridstruct%edge_w( jsc:jec+1) - Grid_box%edge_e( jsc:jec+1) = Atm(mytile)%gridstruct%edge_e( jsc:jec+1) - Grid_box%edge_s( isc:iec+1 ) = Atm(mytile)%gridstruct%edge_s( isc:iec+1) - Grid_box%edge_n( isc:iec+1 ) = Atm(mytile)%gridstruct%edge_n( isc:iec+1) - Grid_box%en1 (:, isc:iec , jsc:jec+1) = Atm(mytile)%gridstruct%en1 (:, isc:iec , jsc:jec+1) - Grid_box%en2 (:, isc:iec+1, jsc:jec ) = Atm(mytile)%gridstruct%en2 (:, isc:iec+1, jsc:jec ) + Grid_box%dx ( isc:iec , jsc:jec+1) = Atm(mygrid)%gridstruct%dx ( isc:iec, jsc:jec+1) + Grid_box%dy ( isc:iec+1, jsc:jec ) = Atm(mygrid)%gridstruct%dy ( isc:iec+1, jsc:jec ) + Grid_box%area ( isc:iec , jsc:jec ) = Atm(mygrid)%gridstruct%area ( isc:iec , jsc:jec ) + Grid_box%edge_w( jsc:jec+1) = Atm(mygrid)%gridstruct%edge_w( jsc:jec+1) + Grid_box%edge_e( jsc:jec+1) = Atm(mygrid)%gridstruct%edge_e( jsc:jec+1) + Grid_box%edge_s( isc:iec+1 ) = Atm(mygrid)%gridstruct%edge_s( isc:iec+1) + Grid_box%edge_n( isc:iec+1 ) = Atm(mygrid)%gridstruct%edge_n( isc:iec+1) + Grid_box%en1 (:, isc:iec , jsc:jec+1) = Atm(mygrid)%gridstruct%en1 (:, isc:iec , jsc:jec+1) + Grid_box%en2 (:, isc:iec+1, jsc:jec ) = Atm(mygrid)%gridstruct%en2 (:, isc:iec+1, jsc:jec ) do i = 1,3 - Grid_box%vlon(i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlon (isc:iec , jsc:jec, i ) - Grid_box%vlat(i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlat (isc:iec , jsc:jec, i ) + Grid_box%vlon (i, isc:iec , jsc:jec ) = Atm(mygrid)%gridstruct%vlon (isc:iec , jsc:jec, i ) + Grid_box%vlat (i, isc:iec , jsc:jec ) = Atm(mygrid)%gridstruct%vlat (isc:iec , jsc:jec, i ) enddo allocate (area(isc:iec , jsc:jec )) - area(isc:iec,jsc:jec) = Atm(mytile)%gridstruct%area_64(isc:iec,jsc:jec) + area(isc:iec,jsc:jec) = Atm(mygrid)%gridstruct%area_64(isc:iec,jsc:jec) !----- allocate and zero out the dynamics (and accumulated) tendencies allocate( u_dt(isd:ied,jsd:jed,npz), & @@ -415,22 +402,21 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) !--- allocate pref allocate(pref(npz+1,2), dum1d(npz+1)) - call set_domain ( Atm(mytile)%domain ) - call fv_restart(Atm(mytile)%domain, Atm, dt_atmos, seconds, days, cold_start, Atm(mytile)%gridstruct%grid_type, grids_on_this_pe) + call fv_restart(Atm(mygrid)%domain, Atm, dt_atmos, seconds, days, cold_start, Atm(mygrid)%gridstruct%grid_type, mygrid) fv_time = Time !----- initialize atmos_axes and fv_dynamics diagnostics !I've had trouble getting this to work with multiple grids at a time; worth revisiting? - call fv_diag_init(Atm(mytile:mytile), Atm(mytile)%atmos_axes, Time, npx, npy, npz, Atm(mytile)%flagstruct%p_ref) + call fv_diag_init(Atm(mygrid:mygrid), Atm(mygrid)%atmos_axes, Time, npx, npy, npz, Atm(mygrid)%flagstruct%p_ref) !---------- reference profile ----------- ps1 = 101325. ps2 = 81060. pref(npz+1,1) = ps1 pref(npz+1,2) = ps2 - call get_eta_level ( npz, ps1, pref(1,1), dum1d, Atm(mytile)%ak, Atm(mytile)%bk ) - call get_eta_level ( npz, ps2, pref(1,2), dum1d, Atm(mytile)%ak, Atm(mytile)%bk ) + call get_eta_level ( npz, ps1, pref(1,1), dum1d, Atm(mygrid)%ak, Atm(mygrid)%bk ) + call get_eta_level ( npz, ps2, pref(1,2), dum1d, Atm(mygrid)%ak, Atm(mygrid)%bk ) ! --- initialize clocks for dynamics, physics_down and physics_up id_dynam = mpp_clock_id ('FV dy-core', flags = clock_flag_default, grain=CLOCK_SUBCOMPONENT ) @@ -442,15 +428,8 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) #ifdef CCPP ! Do CCPP fast physics initialization before call to adiabatic_init (since this calls fv_dynamics) - ! Initialize the cdata structure - call ccpp_init(trim(ccpp_suite), cdata, ierr) - if (ierr/=0) then - cdata%errmsg = ' atmosphere_dynamics: error in ccpp_init: ' // trim(cdata%errmsg) - call mpp_error (FATAL, cdata%errmsg) - end if - - ! For fast physics running over the entire domain, block and thread - ! number are not used; set to safe values + ! For fast physics running over the entire domain, block + ! and thread number are not used; set to safe values cdata%blk_no = 1 cdata%thrd_no = 1 @@ -462,42 +441,34 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) #endif ! Create interstitial data type for fast physics; for multi-gases physics, ! pass q(:,:,:,1:num_gas) as qvi, otherwise pass q(:,:,:,1:1) as 4D array - call CCPP_interstitial%create(Atm(mytile)%bd%is, Atm(mytile)%bd%ie, Atm(mytile)%bd%isd, Atm(mytile)%bd%ied, & - Atm(mytile)%bd%js, Atm(mytile)%bd%je, Atm(mytile)%bd%jsd, Atm(mytile)%bd%jed, & - Atm(mytile)%npz, Atm(mytile)%ng, & - dt_atmos, p_split, Atm(mytile)%flagstruct%k_split, & - zvir, Atm(mytile)%flagstruct%p_ref, Atm(mytile)%ak, Atm(mytile)%bk, & - cld_amt>0, kappa, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%flagstruct%do_sat_adj, & - Atm(mytile)%delp, Atm(mytile)%delz, Atm(mytile)%gridstruct%area_64, & - Atm(mytile)%peln, Atm(mytile)%phis, Atm(mytile)%pkz, Atm(mytile)%pt, & + call CCPP_interstitial%create(Atm(mygrid)%bd%is, Atm(mygrid)%bd%ie, Atm(mygrid)%bd%isd, Atm(mygrid)%bd%ied, & + Atm(mygrid)%bd%js, Atm(mygrid)%bd%je, Atm(mygrid)%bd%jsd, Atm(mygrid)%bd%jed, & + Atm(mygrid)%npz, Atm(mygrid)%ng, & + dt_atmos, p_split, Atm(mygrid)%flagstruct%k_split, & + zvir, Atm(mygrid)%flagstruct%p_ref, Atm(mygrid)%ak, Atm(mygrid)%bk, & + liq_wat>0, ice_wat>0, rainwat>0, snowwat>0, graupel>0, & + cld_amt>0, kappa, Atm(mygrid)%flagstruct%hydrostatic, & + Atm(mygrid)%flagstruct%do_sat_adj, & + Atm(mygrid)%delp, Atm(mygrid)%delz, Atm(mygrid)%gridstruct%area_64, & + Atm(mygrid)%peln, Atm(mygrid)%phis, Atm(mygrid)%pkz, Atm(mygrid)%pt, & #ifdef MULTI_GASES - Atm(mytile)%q(:,:,:,1:max(1,num_gas)), & + Atm(mygrid)%q(:,:,:,1:max(1,num_gas)), & #else - Atm(mytile)%q(:,:,:,1:1), & + Atm(mygrid)%q(:,:,:,1:1), & #endif - Atm(mytile)%q(:,:,:,sphum), Atm(mytile)%q(:,:,:,liq_wat), & - Atm(mytile)%q(:,:,:,ice_wat), Atm(mytile)%q(:,:,:,rainwat), & - Atm(mytile)%q(:,:,:,snowwat), Atm(mytile)%q(:,:,:,graupel), & - Atm(mytile)%q(:,:,:,cld_amt), Atm(mytile)%q_con, nthreads, & - Atm(mytile)%flagstruct%nwat, & + Atm(mygrid)%q(:,:,:,sphum), Atm(mygrid)%q(:,:,:,liq_wat), & + Atm(mygrid)%q(:,:,:,ice_wat), Atm(mygrid)%q(:,:,:,rainwat), & + Atm(mygrid)%q(:,:,:,snowwat), Atm(mygrid)%q(:,:,:,graupel), & + Atm(mygrid)%q(:,:,:,cld_amt), Atm(mygrid)%q_con, nthreads, & + Atm(mygrid)%flagstruct%nwat, & #ifdef MULTI_GASES ngas=num_gas, rilist=ri, cpilist=cpi, & #endif mpirank=mpp_pe(), mpiroot=mpp_root_pe()) -#ifndef STATIC -! Populate cdata structure with fields required to run fast physics (auto-generated). -#include "ccpp_fields_fast_physics.inc" -#endif - - if (Atm(mytile)%flagstruct%do_sat_adj) then + if (Atm(mygrid)%flagstruct%do_sat_adj) then ! Initialize fast physics -#ifdef STATIC call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), group_name="fast_physics", ierr=ierr) -#else - call ccpp_physics_init(cdata, group_name="fast_physics", ierr=ierr) -#endif if (ierr/=0) then cdata%errmsg = ' atmosphere_dynamics: error in ccpp_physics_init for group fast_physics: ' // trim(cdata%errmsg) call mpp_error (FATAL, cdata%errmsg) @@ -506,24 +477,33 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) #endif ! --- initiate the start for a restarted regional forecast - if ( Atm(mytile)%gridstruct%regional .and. Atm(mytile)%flagstruct%warm_start ) then + if ( Atm(mygrid)%gridstruct%regional .and. Atm(mygrid)%flagstruct%warm_start ) then - call start_regional_restart(Atm(1), & + call start_regional_restart(Atm(1), dt_atmos, & isc, iec, jsc, jec, & isd, ied, jsd, jed ) endif - if ( Atm(mytile)%flagstruct%na_init>0 ) then + + if ( Atm(mygrid)%flagstruct%nudge ) then + call fv_nwp_nudge_init( Time, Atm(mygrid)%atmos_axes, npz, zvir, Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%ts, & + Atm(mygrid)%phis, Atm(mygrid)%gridstruct, Atm(mygrid)%ks, Atm(mygrid)%npx, Atm(mygrid)%neststruct, Atm(mygrid)%bd) + call mpp_error(NOTE, 'NWP nudging is active') + endif + call fv_io_register_nudge_restart ( Atm ) + + + if ( Atm(mygrid)%flagstruct%na_init>0 ) then call nullify_domain ( ) - if ( .not. Atm(mytile)%flagstruct%hydrostatic ) then - call prt_maxmin('Before adi: W', Atm(mytile)%w, isc, iec, jsc, jec, Atm(mytile)%ng, npz, 1.) + if ( .not. Atm(mygrid)%flagstruct%hydrostatic ) then + call prt_maxmin('Before adi: W', Atm(mygrid)%w, isc, iec, jsc, jec, Atm(mygrid)%ng, npz, 1.) endif - call adiabatic_init(zvir,Atm(mytile)%flagstruct%nudge_dz,time) - if ( .not. Atm(mytile)%flagstruct%hydrostatic ) then - call prt_maxmin('After adi: W', Atm(mytile)%w, isc, iec, jsc, jec, Atm(mytile)%ng, npz, 1.) + call adiabatic_init(zvir,Atm(mygrid)%flagstruct%nudge_dz, time) + if ( .not. Atm(mygrid)%flagstruct%hydrostatic ) then + call prt_maxmin('After adi: W', Atm(mygrid)%w, isc, iec, jsc, jec, Atm(mygrid)%ng, npz, 1.) ! Not nested? - call prt_height('na_ini Z500', isc,iec, jsc,jec, 3, npz, 500.E2, Atm(mytile)%phis, Atm(mytile)%delz, & - Atm(mytile)%peln, Atm(mytile)%gridstruct%area_64(isc:iec,jsc:jec), Atm(mytile)%gridstruct%agrid_64(isc:iec,jsc:jec,2)) + call prt_height('na_ini Z500', isc,iec, jsc,jec, 3, npz, 500.E2, Atm(mygrid)%phis, Atm(mygrid)%delz, & + Atm(mygrid)%peln, Atm(mygrid)%gridstruct%area_64(isc:iec,jsc:jec), Atm(mygrid)%gridstruct%agrid_64(isc:iec,jsc:jec,2)) endif else call mpp_error(NOTE,'No adiabatic initialization correction in use') @@ -531,11 +511,10 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) #ifdef DEBUG call nullify_domain() - call fv_diag(Atm(mytile:mytile), zvir, Time, -1) + call fv_diag(Atm(mygrid:mygrid), zvir, Time, -1) #endif - n = mytile - call switch_current_Atm(Atm(n)) + call set_domain(Atm(mygrid)%domain) end subroutine atmosphere_init @@ -611,7 +590,7 @@ subroutine atmosphere_dynamics ( Time ) call mpp_clock_begin (id_dynam) - n = mytile + n = mygrid call get_time (time, seconds, days) ! if (seconds < 10800 .and. days == 0) then @@ -661,8 +640,9 @@ subroutine atmosphere_dynamics ( Time ) call timing_off('fv_dynamics') if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then + call mpp_sync() call timing_on('TWOWAY_UPDATE') - call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir) + call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir, fv_time, mygrid) call timing_off('TWOWAY_UPDATE') endif @@ -712,32 +692,21 @@ end subroutine atmosphere_dynamics !>@brief The subroutine 'atmosphere_end' is an API for the termination of the !! FV3 dynamical core responsible for writing out a restart and final diagnostic state. - subroutine atmosphere_end (Time, Grid_box) + subroutine atmosphere_end (Time, Grid_box, restart_endfcst) #ifdef CCPP -#ifdef STATIC -! For static builds, the ccpp_physics_{init,run,finalize} calls -! are not pointing to code in the CCPP framework, but to auto-generated -! ccpp_suite_cap and ccpp_group_*_cap modules behind a ccpp_static_api use ccpp_static_api, only: ccpp_physics_finalize use CCPP_data, only: ccpp_suite -#else - use ccpp_api, only: ccpp_physics_finalize -#endif use CCPP_data, only: cdata => cdata_tile #endif type (time_type), intent(in) :: Time type(grid_box_type), intent(inout) :: Grid_box + logical, intent(in) :: restart_endfcst #ifdef CCPP integer :: ierr - - if (Atm(mytile)%flagstruct%do_sat_adj) then + if (Atm(mygrid)%flagstruct%do_sat_adj) then ! Finalize fast physics -#ifdef STATIC call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), group_name="fast_physics", ierr=ierr) -#else - call ccpp_physics_finalize(cdata, group_name="fast_physics", ierr=ierr) -#endif if (ierr/=0) then cdata%errmsg = ' atmosphere_dynamics: error in ccpp_physics_finalize for group fast_physics: ' // trim(cdata%errmsg) call mpp_error (FATAL, cdata%errmsg) @@ -745,16 +714,21 @@ subroutine atmosphere_end (Time, Grid_box) end if #endif + ! initialize domains for writing global physics data + call set_domain ( Atm(mygrid)%domain ) + + if ( Atm(mygrid)%flagstruct%nudge ) call fv_nwp_nudge_end call nullify_domain ( ) if (first_diag) then call timing_on('FV_DIAG') - call fv_diag(Atm(mytile:mytile), zvir, fv_time, Atm(mytile)%flagstruct%print_freq) - call fv_nggps_diag(Atm(mytile:mytile), zvir, fv_time) + call fv_diag(Atm(mygrid:mygrid), zvir, fv_time, Atm(mygrid)%flagstruct%print_freq) + call fv_nggps_diag_init(Atm(mygrid:mygrid), Atm(mygrid)%atmos_axes, fv_time) + call fv_nggps_diag(Atm(mygrid:mygrid), zvir, fv_time) first_diag = .false. call timing_off('FV_DIAG') endif - call fv_end(Atm, grids_on_this_pe) + call fv_end(Atm, mygrid, restart_endfcst) deallocate (Atm) deallocate( u_dt, v_dt, t_dt, pref, dum1d ) @@ -769,7 +743,7 @@ end subroutine atmosphere_end subroutine atmosphere_restart(timestamp) character(len=*), intent(in) :: timestamp - call fv_write_restart(Atm, grids_on_this_pe, timestamp) + call fv_write_restart(Atm(mygrid), timestamp) end subroutine atmosphere_restart @@ -809,15 +783,15 @@ subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro, tile_num integer, intent(out) :: i1, i2, j1, j2, kt logical, intent(out), optional :: p_hydro, hydro integer, intent(out), optional :: tile_num - i1 = Atm(mytile)%bd%isc - i2 = Atm(mytile)%bd%iec - j1 = Atm(mytile)%bd%jsc - j2 = Atm(mytile)%bd%jec - kt = Atm(mytile)%npz + i1 = Atm(mygrid)%bd%isc + i2 = Atm(mygrid)%bd%iec + j1 = Atm(mygrid)%bd%jsc + j2 = Atm(mygrid)%bd%jec + kt = Atm(mygrid)%npz - if (present(tile_num)) tile_num = Atm(mytile)%tile - if (present(p_hydro)) p_hydro = Atm(mytile)%flagstruct%phys_hydrostatic - if (present( hydro)) hydro = Atm(mytile)%flagstruct%hydrostatic + if (present(tile_num)) tile_num = Atm(mygrid)%tile_of_mosaic + if (present(p_hydro)) p_hydro = Atm(mygrid)%flagstruct%phys_hydrostatic + if (present( hydro)) hydro = Atm(mygrid)%flagstruct%hydrostatic end subroutine atmosphere_control_data @@ -831,8 +805,8 @@ subroutine atmosphere_grid_ctr (lon, lat) do j=jsc,jec do i=isc,iec - lon(i-isc+1,j-jsc+1) = Atm(mytile)%gridstruct%agrid_64(i,j,1) - lat(i-isc+1,j-jsc+1) = Atm(mytile)%gridstruct%agrid_64(i,j,2) + lon(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%agrid_64(i,j,1) + lat(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%agrid_64(i,j,2) enddo end do @@ -854,8 +828,8 @@ subroutine atmosphere_grid_bdry (blon, blat, global) do j=jsc,jec+1 do i=isc,iec+1 - blon(i-isc+1,j-jsc+1) = Atm(mytile)%gridstruct%grid(i,j,1) - blat(i-isc+1,j-jsc+1) = Atm(mytile)%gridstruct%grid(i,j,2) + blon(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%grid(i,j,1) + blat(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%grid(i,j,2) enddo end do @@ -863,7 +837,7 @@ end subroutine atmosphere_grid_bdry subroutine set_atmosphere_pelist () - call mpp_set_current_pelist(Atm(mytile)%pelist, no_sync=.TRUE.) + call mpp_set_current_pelist(Atm(mygrid)%pelist, no_sync=.TRUE.) end subroutine set_atmosphere_pelist @@ -880,12 +854,12 @@ subroutine atmosphere_domain ( fv_domain, layout, regional, nested, pelist ) ! returns the domain2d variable associated with the coupling grid ! note: coupling is done using the mass/temperature grid with no halos - fv_domain = Atm(mytile)%domain_for_coupler - layout(1:2) = Atm(mytile)%layout(1:2) - regional = Atm(mytile)%flagstruct%regional + fv_domain = Atm(mygrid)%domain_for_coupler + layout(1:2) = Atm(mygrid)%layout(1:2) + regional = Atm(mygrid)%flagstruct%regional nested = ngrids > 1 call set_atmosphere_pelist() - pelist => Atm(mytile)%pelist + pelist => Atm(mygrid)%pelist end subroutine atmosphere_domain @@ -900,7 +874,7 @@ subroutine atmosphere_diag_axes ( axes ) 'get_atmosphere_axes in atmosphere_mod', & 'size of argument is incorrect', FATAL ) - axes (1:size(axes(:))) = Atm(mytile)%atmos_axes (1:size(axes(:))) + axes (1:size(axes(:))) = Atm(mygrid)%atmos_axes (1:size(axes(:))) end subroutine atmosphere_diag_axes @@ -917,11 +891,11 @@ subroutine atmosphere_etalvls (ak, bk, flip) allocate(bk(npz+1)) if (flip) then - ak(1:npz+1) = Atm(mytile)%ak(npz+1:1:-1) - bk(1:npz+1) = Atm(mytile)%bk(npz+1:1:-1) + ak(1:npz+1) = Atm(mygrid)%ak(npz+1:1:-1) + bk(1:npz+1) = Atm(mygrid)%bk(npz+1:1:-1) else - ak(1:npz+1) = Atm(mytile)%ak(1:npz+1) - bk(1:npz+1) = Atm(mytile)%bk(1:npz+1) + ak(1:npz+1) = Atm(mygrid)%ak(1:npz+1) + bk(1:npz+1) = Atm(mygrid)%bk(1:npz+1) endif end subroutine atmosphere_etalvls @@ -937,52 +911,65 @@ subroutine atmosphere_hgt (hgt, position, relative, flip) logical, intent(in) :: relative !< control absolute vs. relative height logical, intent(in) :: flip !< control vertical index flipping !--- local variables --- - integer:: lev, k, j, i, npx, npy - real(kind=kind_phys), dimension(isc:iec,jsc:jec,1:npz+1) :: z - real(kind=kind_phys), dimension(isc:iec,jsc:jec,1:npz) :: dz + integer:: lev, k, j, i + real(kind=kind_phys), allocatable, dimension(:,:,:) :: z, dz if ((position .ne. "layer") .and. (position .ne. "level")) then call mpp_error (FATAL, 'atmosphere_hgt:: incorrect position specification') endif - npx = iec-isc+1 - npy = jec-jsc+1 + allocate(z(iec-isc+1,jec-jsc+1,npz+1)) + allocate(dz(iec-isc+1,jec-jsc+1,npz)) z = 0 dz = 0 - if (Atm(mytile)%flagstruct%hydrostatic) then + if (Atm(mygrid)%flagstruct%hydrostatic) then !--- generate dz using hydrostatic assumption - dz(isc:iec,jsc:jec,1:npz) = (rdgas/grav)*Atm(mytile)%pt(isc:iec,jsc:jec,1:npz) & - * (Atm(mytile)%peln(isc:iec,1:npz,jsc:jec) & - - Atm(mytile)%peln(isc:iec,2:npz+1,jsc:jec)) + do j = jsc, jec + do i = isc, iec + dz(i-isc+1,j-jsc+1,1:npz) = (rdgas/grav)*Atm(mygrid)%pt(i,j,1:npz) & + * (Atm(mygrid)%peln(i,1:npz,j) - Atm(mygrid)%peln(i,2:npz+1,j)) + enddo + enddo else !--- use non-hydrostatic delz directly - dz(isc:iec,jsc:jec,1:npz) = Atm(mytile)%delz(isc:iec,jsc:jec,1:npz) + do j = jsc, jec + do i = isc, iec + dz(i-isc+1,j-jsc+1,1:npz) = Atm(mygrid)%delz(i,j,1:npz) + enddo + enddo endif !--- calculate geometric heights at the interfaces (levels) !--- if needed, flip the indexing during this step if (flip) then - if (.not. relative) z(isc:iec,jsc:jec,1) = Atm(mytile)%phis(isc:iec,jsc:jec)/grav + if (.not. relative) then + z(1:iec-isc+1,1:jec-jsc+1,1) = Atm(mygrid)%phis(isc:iec,jsc:jec)/grav + endif do k = 2,npz+1 - z(isc:iec,jsc:jec,k) = z(isc:iec,jsc:jec,k-1) - dz(isc:iec,jsc:jec,npz+2-k) + z(:,:,k) = z(:,:,k-1) - dz(:,:,npz+2-k) enddo else - if (.not. relative) z(isc:iec,jsc:jec,npz+1) = Atm(mytile)%phis(isc:iec,jsc:jec)/grav + if (.not. relative) then + z(1:iec-isc+1,1:jec-jsc+1,npz+1) = Atm(mygrid)%phis(isc:iec,jsc:jec)/grav + endif do k = npz,1,-1 - z(isc:iec,jsc:jec,k) = z(isc:iec,jsc:jec,k+1) - dz(isc:iec,jsc:jec,k) + z(:,:,k) = z(:,:,k+1) - dz(:,:,k) enddo endif !--- allocate and set either the level or layer height for return if (position == "level") then - allocate (hgt(npx,npy,npz+1)) - hgt(1:npx,1:npy,1:npz+1) = z(isc:iec,jsc:jec,1:npz+1) + allocate (hgt(iec-isc+1,jec-jsc+1,npz+1)) + hgt = z elseif (position == "layer") then - allocate (hgt(npx,npy,npz)) - hgt(1:npx,1:npy,1:npz) = 0.5d0 * (z(isc:iec,jsc:jec,1:npz) + z(isc:iec,jsc:jec,2:npz+1)) + allocate (hgt(iec-isc+1,jec-jsc+1,npz)) + hgt(:,:,1:npz) = 0.5d0 * (z(:,:,1:npz) + z(:,:,2:npz+1)) endif + deallocate (z) + deallocate (dz) + end subroutine atmosphere_hgt @@ -1041,9 +1028,9 @@ subroutine atmosphere_scalar_field_halo (data, halo, isize, jsize, ksize, data_p mpp_flags = EUPDATE + WUPDATE + SUPDATE + NUPDATE if (halo == 1) then - call mpp_update_domains(data, Atm(mytile)%domain_for_coupler, flags=mpp_flags, complete=.true.) + call mpp_update_domains(data, Atm(mygrid)%domain_for_coupler, flags=mpp_flags, complete=.true.) elseif (halo == 3) then - call mpp_update_domains(data, Atm(mytile)%domain, flags=mpp_flags, complete=.true.) + call mpp_update_domains(data, Atm(mygrid)%domain, flags=mpp_flags, complete=.true.) else call mpp_error(FATAL, modname//' - unsupported halo size') endif @@ -1077,18 +1064,18 @@ subroutine atmosphere_diss_est (npass) !horizontally smooth dissiapation estimate for SKEB ! 3 passes before taking absolute value do k = 1,min(3,npass) - call del2_cubed(Atm(mytile)%diss_est, 0.25*Atm(mytile)%gridstruct%da_min, Atm(mytile)%gridstruct, & - Atm(mytile)%domain, npx, npy, npz, 3, Atm(mytile)%bd) + call del2_cubed(Atm(mygrid)%diss_est, 0.25*Atm(mygrid)%gridstruct%da_min, Atm(mygrid)%gridstruct, & + Atm(mygrid)%domain, npx, npy, npz, 3, Atm(mygrid)%bd) enddo - Atm(mytile)%diss_est=abs(Atm(mytile)%diss_est) + Atm(mygrid)%diss_est=abs(Atm(mygrid)%diss_est) do k = 4,npass - call del2_cubed(Atm(mytile)%diss_est, 0.25*Atm(mytile)%gridstruct%da_min, Atm(mytile)%gridstruct, & - Atm(mytile)%domain, npx, npy, npz, 3, Atm(mytile)%bd) + call del2_cubed(Atm(mygrid)%diss_est, 0.25*Atm(mygrid)%gridstruct%da_min, Atm(mygrid)%gridstruct, & + Atm(mygrid)%domain, npx, npy, npz, 3, Atm(mygrid)%bd) enddo ! provide back sqrt of dissipation estimate - Atm(mytile)%diss_est=sqrt(abs(Atm(mytile)%diss_est)) + Atm(mygrid)%diss_est=sqrt(abs(Atm(mygrid)%diss_est)) end subroutine atmosphere_diss_est @@ -1103,7 +1090,7 @@ subroutine atmosphere_nggps_diag (Time, init, ltavg,avg_max_length) real, optional, intent(in) :: avg_max_length if (PRESENT(init)) then if (init) then - call fv_nggps_diag_init(Atm(mytile:mytile), Atm(mytile)%atmos_axes, Time) + call fv_nggps_diag_init(Atm(mygrid:mygrid), Atm(mygrid)%atmos_axes, Time) return else call mpp_error(FATAL, 'atmosphere_nggps_diag - calling with init present, but set to .false.') @@ -1111,11 +1098,11 @@ subroutine atmosphere_nggps_diag (Time, init, ltavg,avg_max_length) endif if (PRESENT(ltavg)) then if (ltavg) then - call fv_nggps_tavg(Atm(mytile:mytile), Time_step_atmos,avg_max_length,zvir) + call fv_nggps_tavg(Atm(mygrid:mygrid), Time_step_atmos,avg_max_length,zvir) return endif else - call fv_nggps_diag(Atm(mytile:mytile), zvir, Time) + call fv_nggps_diag(Atm(mygrid:mygrid), zvir, Time) endif end subroutine atmosphere_nggps_diag @@ -1132,7 +1119,7 @@ end subroutine atmosphere_nggps_diag !rab !rab if( nq<3 ) call mpp_error(FATAL, 'GFS phys must have 3 interactive tracers') !rab -!rab n = mytile +!rab n = mygrid !rab nwat = Atm(n)%flagstruct%nwat !rab !rab!$OMP parallel do default (none) & @@ -1178,23 +1165,23 @@ subroutine get_bottom_mass ( t_bot, tr_bot, p_bot, z_bot, p_surf, slp ) do j=jsc,jec do i=isc,iec - p_surf(i,j) = Atm(mytile)%ps(i,j) - t_bot(i,j) = Atm(mytile)%pt(i,j,npz) - p_bot(i,j) = Atm(mytile)%delp(i,j,npz)/(Atm(mytile)%peln(i,npz+1,j)-Atm(mytile)%peln(i,npz,j)) - z_bot(i,j) = rrg*t_bot(i,j)*(1. - Atm(mytile)%pe(i,npz,j)/p_bot(i,j)) + p_surf(i,j) = Atm(mygrid)%ps(i,j) + t_bot(i,j) = Atm(mygrid)%pt(i,j,npz) + p_bot(i,j) = Atm(mygrid)%delp(i,j,npz)/(Atm(mygrid)%peln(i,npz+1,j)-Atm(mygrid)%peln(i,npz,j)) + z_bot(i,j) = rrg*t_bot(i,j)*(1. - Atm(mygrid)%pe(i,npz,j)/p_bot(i,j)) #ifdef MULTI_GASES - z_bot(i,j) = z_bot(i,j)*virq(Atm(mytile)%q(i,j,npz,:)) + z_bot(i,j) = z_bot(i,j)*virq(Atm(mygrid)%q(i,j,npz,:)) #else - z_bot(i,j) = z_bot(i,j)*(1.+zvir*Atm(mytile)%q(i,j,npz,1)) + z_bot(i,j) = z_bot(i,j)*(1.+zvir*Atm(mygrid)%q(i,j,npz,1)) #endif enddo enddo if ( present(slp) ) then ! determine 0.8 sigma reference level - sigtop = Atm(mytile)%ak(1)/pstd_mks+Atm(mytile)%bk(1) + sigtop = Atm(mygrid)%ak(1)/pstd_mks+Atm(mygrid)%bk(1) do k = 1, npz - sigbot = Atm(mytile)%ak(k+1)/pstd_mks+Atm(mytile)%bk(k+1) + sigbot = Atm(mygrid)%ak(k+1)/pstd_mks+Atm(mygrid)%bk(k+1) if (sigbot+sigtop > 1.6) then kr = k exit @@ -1204,9 +1191,9 @@ subroutine get_bottom_mass ( t_bot, tr_bot, p_bot, z_bot, p_surf, slp ) do j=jsc,jec do i=isc,iec ! sea level pressure - tref(i,j) = Atm(mytile)%pt(i,j,kr) * (Atm(mytile)%delp(i,j,kr)/ & - ((Atm(mytile)%peln(i,kr+1,j)-Atm(mytile)%peln(i,kr,j))*Atm(mytile)%ps(i,j)))**(-rrg*tlaps) - slp(i,j) = Atm(mytile)%ps(i,j)*(1.+tlaps*Atm(mytile)%phis(i,j)/(tref(i,j)*grav))**(1./(rrg*tlaps)) + tref(i,j) = Atm(mygrid)%pt(i,j,kr) * (Atm(mygrid)%delp(i,j,kr)/ & + ((Atm(mygrid)%peln(i,kr+1,j)-Atm(mygrid)%peln(i,kr,j))*Atm(mygrid)%ps(i,j)))**(-rrg*tlaps) + slp(i,j) = Atm(mygrid)%ps(i,j)*(1.+tlaps*Atm(mygrid)%phis(i,j)/(tref(i,j)*grav))**(1./(rrg*tlaps)) enddo enddo endif @@ -1215,7 +1202,7 @@ subroutine get_bottom_mass ( t_bot, tr_bot, p_bot, z_bot, p_surf, slp ) do m=1,nq do j=jsc,jec do i=isc,iec - tr_bot(i,j,m) = Atm(mytile)%q(i,j,npz,m) + tr_bot(i,j,m) = Atm(mygrid)%q(i,j,npz,m) enddo enddo enddo @@ -1234,8 +1221,8 @@ subroutine get_bottom_wind ( u_bot, v_bot ) do j=jsc,jec do i=isc,iec - u_bot(i,j) = Atm(mytile)%u_srf(i,j) - v_bot(i,j) = Atm(mytile)%v_srf(i,j) + u_bot(i,j) = Atm(mygrid)%u_srf(i,j) + v_bot(i,j) = Atm(mygrid)%v_srf(i,j) enddo enddo @@ -1267,11 +1254,10 @@ subroutine atmosphere_get_bottom_layer (Atm_block, DYCORE_Data) rrg = rdgas / grav if (first_time) then - print *, 'calculating slp kr value' ! determine 0.8 sigma reference level - sigtop = Atm(mytile)%ak(1)/pstd_mks+Atm(mytile)%bk(1) + sigtop = Atm(mygrid)%ak(1)/pstd_mks+Atm(mygrid)%bk(1) do k = 1, npz - sigbot = Atm(mytile)%ak(k+1)/pstd_mks+Atm(mytile)%bk(k+1) + sigbot = Atm(mygrid)%ak(k+1)/pstd_mks+Atm(mygrid)%bk(k+1) if (sigbot+sigtop > 1.6) then kr = k exit @@ -1286,31 +1272,31 @@ subroutine atmosphere_get_bottom_layer (Atm_block, DYCORE_Data) endif !$OMP parallel do default (none) & -!$OMP shared (Atm_block, DYCORE_Data, Atm, mytile, npz, kr, rrg, zvir, nq) & +!$OMP shared (Atm_block, DYCORE_Data, Atm, mygrid, npz, kr, rrg, zvir, nq) & !$OMP private (nb, ix, i, j, tref, nt) do nb = 1,Atm_block%nblks do ix = 1,Atm_block%blksz(nb) i = Atm_block%index(nb)%ii(ix) j = Atm_block%index(nb)%jj(ix) !--- surface pressure - DYCORE_Data(nb)%Coupling%p_srf(ix) = Atm(mytile)%ps(i,j) + DYCORE_Data(nb)%Coupling%p_srf(ix) = Atm(mygrid)%ps(i,j) !--- bottom layer temperature, pressure, & winds - DYCORE_Data(nb)%Coupling%t_bot(ix) = Atm(mytile)%pt(i,j,npz) - DYCORE_Data(nb)%Coupling%p_bot(ix) = Atm(mytile)%delp(i,j,npz)/(Atm(mytile)%peln(i,npz+1,j)-Atm(mytile)%peln(i,npz,j)) - DYCORE_Data(nb)%Coupling%u_bot(ix) = Atm(mytile)%u_srf(i,j) - DYCORE_Data(nb)%Coupling%v_bot(ix) = Atm(mytile)%v_srf(i,j) + DYCORE_Data(nb)%Coupling%t_bot(ix) = Atm(mygrid)%pt(i,j,npz) + DYCORE_Data(nb)%Coupling%p_bot(ix) = Atm(mygrid)%delp(i,j,npz)/(Atm(mygrid)%peln(i,npz+1,j)-Atm(mygrid)%peln(i,npz,j)) + DYCORE_Data(nb)%Coupling%u_bot(ix) = Atm(mygrid)%u_srf(i,j) + DYCORE_Data(nb)%Coupling%v_bot(ix) = Atm(mygrid)%v_srf(i,j) !--- bottom layer height based on hydrostatic assumptions DYCORE_Data(nb)%Coupling%z_bot(ix) = rrg*DYCORE_Data(nb)%Coupling%t_bot(ix) * & - (1. - Atm(mytile)%pe(i,npz,j)/DYCORE_Data(nb)%Coupling%p_bot(ix)) + (1. - Atm(mygrid)%pe(i,npz,j)/DYCORE_Data(nb)%Coupling%p_bot(ix)) #ifdef MULTI_GASES - DYCORE_Data(nb)%Coupling%z_bot(ix) = DYCORE_Data(nb)%Coupling%z_bot(ix)*virq(Atm(mytile)%q(i,j,npz,:)) + DYCORE_Data(nb)%Coupling%z_bot(ix) = DYCORE_Data(nb)%Coupling%z_bot(ix)*virq(Atm(mygrid)%q(i,j,npz,:)) #else - DYCORE_Data(nb)%Coupling%z_bot(ix) = DYCORE_Data(nb)%Coupling%z_bot(ix)*(1.+zvir*Atm(mytile)%q(i,j,npz,1)) + DYCORE_Data(nb)%Coupling%z_bot(ix) = DYCORE_Data(nb)%Coupling%z_bot(ix)*(1.+zvir*Atm(mygrid)%q(i,j,npz,1)) #endif !--- sea level pressure - tref = Atm(mytile)%pt(i,j,kr) * (Atm(mytile)%delp(i,j,kr)/ & - ((Atm(mytile)%peln(i,kr+1,j)-Atm(mytile)%peln(i,kr,j))*Atm(mytile)%ps(i,j)))**(-rrg*tlaps) - DYCORE_Data(nb)%Coupling%slp(ix) = Atm(mytile)%ps(i,j)*(1.+tlaps*Atm(mytile)%phis(i,j)/(tref*grav))**(1./(rrg*tlaps)) + tref = Atm(mygrid)%pt(i,j,kr) * (Atm(mygrid)%delp(i,j,kr)/ & + ((Atm(mygrid)%peln(i,kr+1,j)-Atm(mygrid)%peln(i,kr,j))*Atm(mygrid)%ps(i,j)))**(-rrg*tlaps) + DYCORE_Data(nb)%Coupling%slp(ix) = Atm(mygrid)%ps(i,j)*(1.+tlaps*Atm(mygrid)%phis(i,j)/(tref*grav))**(1./(rrg*tlaps)) enddo !--- bottom layer tracers @@ -1318,7 +1304,7 @@ subroutine atmosphere_get_bottom_layer (Atm_block, DYCORE_Data) do ix = 1,Atm_block%blksz(nb) i = Atm_block%index(nb)%ii(ix) j = Atm_block%index(nb)%jj(ix) - DYCORE_Data(nb)%Coupling%tr_bot(ix,nt) = Atm(mytile)%q(i,j,npz,nt) + DYCORE_Data(nb)%Coupling%tr_bot(ix,nt) = Atm(mygrid)%q(i,j,npz,nt) enddo enddo enddo @@ -1338,7 +1324,7 @@ subroutine get_stock_pe(index, value) integer i,j,k real, pointer :: area(:,:) - area => Atm(mytile)%gridstruct%area + area => Atm(mygrid)%gridstruct%area select case (index) @@ -1356,9 +1342,9 @@ subroutine get_stock_pe(index, value) do k=1,npz do i=isc,iec ! Warning: the following works only with AM2 physics: water vapor; cloud water, cloud ice. - wm(i,j) = wm(i,j) + Atm(mytile)%delp(i,j,k) * ( Atm(mytile)%q(i,j,k,1) + & - Atm(mytile)%q(i,j,k,2) + & - Atm(mytile)%q(i,j,k,3) ) + wm(i,j) = wm(i,j) + Atm(mygrid)%delp(i,j,k) * ( Atm(mygrid)%q(i,j,k,1) + & + Atm(mygrid)%q(i,j,k,2) + & + Atm(mygrid)%q(i,j,k,3) ) enddo enddo enddo @@ -1394,18 +1380,32 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block, flip_vc integer :: i, j, ix, k, k1, n, w_diff, nt_dyn, iq integer :: nb, blen, nwat, dnats, nq_adv real(kind=kind_phys):: rcp, q0, qwat(nq), qt, rdt + real psum, qsum, psumb, qsumb, betad + character(len=32) :: tracer_name Time_prev = Time Time_next = Time + Time_step_atmos rdt = 1.d0 / dt_atmos - n = mytile + n = mygrid nwat = Atm(n)%flagstruct%nwat - dnats = Atm(mytile)%flagstruct%dnats + dnats = Atm(mygrid)%flagstruct%dnats nq_adv = nq - dnats if( nq<3 ) call mpp_error(FATAL, 'GFS phys must have 3 interactive tracers') if (IAU_Data%in_interval) then + if (IAU_Data%drymassfixer) then + ! global mean total pressure and water before IAU + psumb = g_sum(Atm(n)%domain,sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz),dim=3),& + isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.) + qsumb = g_sum(Atm(n)%domain,& + sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz)*sum(Atm(n)%q(isc:iec,jsc:jec,1:npz,1:nwat),4),dim=3),& + isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.) + if (is_master()) then + print *,'dry ps before IAU/physics',psumb+Atm(n)%ptop-qsumb + endif + endif + ! IAU increments are in units of 1/sec ! add analysis increment to u,v,t tendencies @@ -1420,7 +1420,7 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block, flip_vc enddo enddo enddo - if (.not. Atm(mytile)%flagstruct%hydrostatic) then + if (.not. Atm(mygrid)%flagstruct%hydrostatic) then do k = 1, npz do j = jsc,jec do i = isc,iec @@ -1448,31 +1448,42 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block, flip_vc enddo endif - call set_domain ( Atm(mytile)%domain ) + call set_domain ( Atm(mygrid)%domain ) call timing_on('GFS_TENDENCIES') + call atmos_phys_qdt_diag(Atm(n)%q, Atm(n)%phys_diag, nt_dyn, dt_atmos, .true.) !--- put u/v tendencies into haloed arrays u_dt and v_dt !$OMP parallel do default (none) & -!$OMP shared (rdt, n, nq, dnats, npz, ncnst, nwat, mytile, u_dt, v_dt, t_dt,& +!$OMP shared (rdt, n, nq, dnats, npz, ncnst, nwat, mygrid, u_dt, v_dt, t_dt,& !$OMP Atm, IPD_Data, Atm_block, sphum, liq_wat, rainwat, ice_wat, & #ifdef MULTI_GASES !$OMP num_gas, & #endif !$OMP snowwat, graupel, nq_adv, flip_vc) & -!$OMP private (nb, blen, i, j, k, k1, ix, q0, qwat, qt) +!$OMP private (nb, blen, i, j, k, k1, ix, q0, qwat, qt, tracer_name) do nb = 1,Atm_block%nblks !SJL: perform vertical filling to fix the negative humidity if the SAS convection scheme is used ! This call may be commented out if RAS or other positivity-preserving CPS is used. blen = Atm_block%blksz(nb) - call fill_gfs(blen, npz, IPD_Data(nb)%Statein%prsi, IPD_Data(nb)%Stateout%gq0, 1.e-9_kind_phys) + if (Atm(n)%flagstruct%fill_gfs) call fill_gfs(blen, npz, IPD_Data(nb)%Statein%prsi, IPD_Data(nb)%Stateout%gq0, 1.e-9_kind_phys) + +!LMH 28sep18: If the name of a tracer ends in 'nopbl' then do NOT update it; + !override this by setting Stateout%gq0(:,:,iq) to the input value + do iq = 1, nq + call get_tracer_names (MODEL_ATMOS, iq, tracer_name) + if (index(tracer_name, 'nopbl') > 0) then + IPD_Data(nb)%Stateout%gq0(:,:,iq) = IPD_Data(nb)%Statein%qgrs(:,:,iq) + endif + enddo + do k = 1, npz - if(flip_vc) then - k1 = npz+1-k !reverse the k direction - else - k1 = k - endif + if(flip_vc) then + k1 = npz+1-k !reverse the k direction + else + k1 = k + endif do ix = 1, blen i = Atm_block%index(nb)%ii(ix) j = Atm_block%index(nb)%jj(ix) @@ -1514,21 +1525,44 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block, flip_vc !--- See Note in statein... do iq = nq+1, ncnst do k = 1, npz - if(flip_vc) then - k1 = npz+1-k !reverse the k direction - else - k1 = k - endif + if(flip_vc) then + k1 = npz+1-k !reverse the k direction + else + k1 = k + endif do ix = 1, blen i = Atm_block%index(nb)%ii(ix) j = Atm_block%index(nb)%jj(ix) - Atm(mytile)%qdiag(i,j,k1,iq) = IPD_Data(nb)%Stateout%gq0(ix,k,iq) + Atm(mygrid)%qdiag(i,j,k1,iq) = IPD_Data(nb)%Stateout%gq0(ix,k,iq) enddo enddo enddo enddo ! nb-loop +! dry mass fixer in IAU interval following +! https://onlinelibrary.wiley.com/doi/full/10.1111/j.1600-0870.2007.00299.x + if (IAU_Data%in_interval .and. IAU_data%drymassfixer) then + ! global mean total pressure + psum = g_sum(Atm(n)%domain,sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz),dim=3),& + isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.) + ! global mean total water (before adjustment) + qsum = g_sum(Atm(n)%domain,& + sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz)*sum(Atm(n)%q(isc:iec,jsc:jec,1:npz,1:nwat),4),dim=3),& + isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1,reproduce=.true.) + betad = (psum - (psumb - qsumb))/qsum + if (is_master()) then + print *,'dry ps after IAU/physics',psum+Atm(n)%ptop-qsum + endif + Atm(n)%q(:,:,:,1:nwat) = betad*Atm(n)%q(:,:,:,1:nwat) + !qsum = g_sum(Atm(n)%domain,& + ! sum(Atm(n)%delp(isc:iec,jsc:jec,1:npz)*sum(Atm(n)%q(isc:iec,jsc:jec,1:npz,1:nwat),4),dim=3),& + ! isc,iec,jsc,jec,Atm(n)%ng,Atm(n)%gridstruct%area_64,1) + !if (is_master()) then + ! print *,'dry ps after iau_drymassfixer',psum+Atm(n)%ptop-qsum + !endif + endif + call timing_off('GFS_TENDENCIES') w_diff = get_tracer_index (MODEL_ATMOS, 'w_diff' ) @@ -1570,21 +1604,22 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block, flip_vc .true., Time_next, Atm(n)%flagstruct%nudge, Atm(n)%gridstruct, & Atm(n)%gridstruct%agrid(:,:,1), Atm(n)%gridstruct%agrid(:,:,2), & Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%bd, Atm(n)%domain, Atm(n)%ptop) + Atm(n)%neststruct, Atm(n)%bd, Atm(n)%domain, Atm(n)%ptop, Atm(n)%phys_diag) call timing_off('FV_UPDATE_PHYS') call mpp_clock_end (id_dynam) !--- nesting update after updating atmospheric variables with !--- physics tendencies if (ngrids > 1 .and. p_split > 0) then + call mpp_sync() call timing_on('TWOWAY_UPDATE') - call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir) + call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir, fv_time, mygrid) call timing_off('TWOWAY_UPDATE') endif call nullify_domain() !---- diagnostics for FV dynamics ----- - if (Atm(mytile)%flagstruct%print_freq /= -99) then + if (Atm(mygrid)%flagstruct%print_freq /= -99) then call mpp_clock_begin(id_fv_diag) fv_time = Time_next @@ -1592,7 +1627,7 @@ subroutine atmosphere_state_update (Time, IPD_Data, IAU_Data, Atm_block, flip_vc call nullify_domain() call timing_on('FV_DIAG') - call fv_diag(Atm(mytile:mytile), zvir, fv_time, Atm(mytile)%flagstruct%print_freq) + call fv_diag(Atm(mygrid:mygrid), zvir, fv_time, Atm(mygrid)%flagstruct%print_freq) first_diag = .false. call timing_off('FV_DIAG') @@ -1629,18 +1664,18 @@ subroutine adiabatic_init(zvir,nudge_dz,time) xt = 1./(1.+wt) - write(errstr,'(A, I4, A)') 'Performing adiabatic init', Atm(mytile)%flagstruct%na_init, ' times' + write(errstr,'(A, I4, A)') 'Performing adiabatic init', Atm(mygrid)%flagstruct%na_init, ' times' call mpp_error(NOTE, errstr) sphum = get_tracer_index (MODEL_ATMOS, 'sphum' ) - npz = Atm(mytile)%npz + npz = Atm(mygrid)%npz - isc = Atm(mytile)%bd%isc - iec = Atm(mytile)%bd%iec - jsc = Atm(mytile)%bd%jsc - jec = Atm(mytile)%bd%jec + isc = Atm(mygrid)%bd%isc + iec = Atm(mygrid)%bd%iec + jsc = Atm(mygrid)%bd%jsc + jec = Atm(mygrid)%bd%jec - ngc = Atm(mytile)%ng + ngc = Atm(mygrid)%ng isd = isc - ngc ied = iec + ngc jsd = jsc - ngc @@ -1653,7 +1688,7 @@ subroutine adiabatic_init(zvir,nudge_dz,time) allocate ( v0(isc:iec+1,jsc:jec, npz) ) allocate (dp0(isc:iec,jsc:jec, npz) ) - if ( Atm(mytile)%flagstruct%hydrostatic ) nudge_dz = .false. + if ( Atm(mygrid)%flagstruct%hydrostatic ) nudge_dz = .false. if ( nudge_dz ) then allocate (dz0(isc:iec,jsc:jec, npz) ) @@ -1662,100 +1697,100 @@ subroutine adiabatic_init(zvir,nudge_dz,time) endif !$omp parallel do default (none) & -!$omp shared (nudge_dz, npz, jsc, jec, isc, iec, n, sphum, u0, v0, t0, dz0, dp0, Atm, zvir, mytile) & +!$omp shared (nudge_dz, npz, jsc, jec, isc, iec, n, sphum, u0, v0, t0, dz0, dp0, Atm, zvir, mygrid) & !$omp private (k, j, i) do k=1,npz do j=jsc,jec+1 do i=isc,iec - u0(i,j,k) = Atm(mytile)%u(i,j,k) + u0(i,j,k) = Atm(mygrid)%u(i,j,k) enddo enddo do j=jsc,jec do i=isc,iec+1 - v0(i,j,k) = Atm(mytile)%v(i,j,k) + v0(i,j,k) = Atm(mygrid)%v(i,j,k) enddo enddo if ( nudge_dz ) then do j=jsc,jec do i=isc,iec - dp0(i,j,k) = Atm(mytile)%delp(i,j,k) - dz0(i,j,k) = Atm(mytile)%delz(i,j,k) + dp0(i,j,k) = Atm(mygrid)%delp(i,j,k) + dz0(i,j,k) = Atm(mygrid)%delz(i,j,k) enddo enddo else do j=jsc,jec do i=isc,iec #ifdef MULTI_GASES - t0(i,j,k) = Atm(mytile)%pt(i,j,k)*virq(Atm(mytile)%q(i,j,k,:)) ! virt T + t0(i,j,k) = Atm(mygrid)%pt(i,j,k)*virq(Atm(mygrid)%q(i,j,k,:)) ! virt T #else - t0(i,j,k) = Atm(mytile)%pt(i,j,k)*(1.+zvir*Atm(mytile)%q(i,j,k,sphum)) ! virt T + t0(i,j,k) = Atm(mygrid)%pt(i,j,k)*(1.+zvir*Atm(mygrid)%q(i,j,k,sphum)) ! virt T #endif - dp0(i,j,k) = Atm(mytile)%delp(i,j,k) + dp0(i,j,k) = Atm(mygrid)%delp(i,j,k) enddo enddo endif enddo call get_time (time, seconds, days) - if (seconds < nint(3600*Atm(mytile)%flagstruct%fhouri) .and. Atm(mytile)%flagstruct%fac_n_spl > 1.0) then - n_split_loc = nint(Atm(mytile)%flagstruct%n_split * Atm(mytile)%flagstruct%fac_n_spl) + if (seconds < nint(3600*Atm(mygrid)%flagstruct%fhouri) .and. Atm(mygrid)%flagstruct%fac_n_spl > 1.0) then + n_split_loc = nint(Atm(mygrid)%flagstruct%n_split * Atm(mygrid)%flagstruct%fac_n_spl) else - n_split_loc = Atm(mytile)%flagstruct%n_split + n_split_loc = Atm(mygrid)%flagstruct%n_split endif ! write(0,*)' before calling init n_split_loc=',n_split_loc,' seconds=',seconds,' days=',days,& -! ' n_split=',Atm(mytile)%flagstruct%n_split,' mytile=',mytile +! ' n_split=',Atm(mygrid)%flagstruct%n_split,' mygrid=',mygrid - do m=1,Atm(mytile)%flagstruct%na_init + do m=1,Atm(mygrid)%flagstruct%na_init ! Forward call - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & -! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, dt_atmos, 0., & + Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & +! Atm(mygrid)%ptop, Atm(mygrid)%ks, nq, Atm(mygrid)%flagstruct%n_split, & + Atm(mygrid)%ptop, Atm(mygrid)%ks, nq, n_split_loc, & + Atm(mygrid)%flagstruct%q_split, Atm(mygrid)%u, Atm(mygrid)%v, Atm(mygrid)%w, & + Atm(mygrid)%delz, Atm(mygrid)%flagstruct%hydrostatic, & + Atm(mygrid)%pt, Atm(mygrid)%delp, Atm(mygrid)%q, Atm(mygrid)%ps, & + Atm(mygrid)%pe, Atm(mygrid)%pk, Atm(mygrid)%peln, Atm(mygrid)%pkz, Atm(mygrid)%phis, & + Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & + Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & + Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & + Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain,Atm(mygrid)%diss_est) ! Backward - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, -dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & -! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, -dt_atmos, 0., & + Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & +! Atm(mygrid)%ptop, Atm(mygrid)%ks, nq, Atm(mygrid)%flagstruct%n_split, & + Atm(mygrid)%ptop, Atm(mygrid)%ks, nq, n_split_loc, & + Atm(mygrid)%flagstruct%q_split, Atm(mygrid)%u, Atm(mygrid)%v, Atm(mygrid)%w, & + Atm(mygrid)%delz, Atm(mygrid)%flagstruct%hydrostatic, & + Atm(mygrid)%pt, Atm(mygrid)%delp, Atm(mygrid)%q, Atm(mygrid)%ps, & + Atm(mygrid)%pe, Atm(mygrid)%pk, Atm(mygrid)%peln, Atm(mygrid)%pkz, Atm(mygrid)%phis, & + Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & + Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & + Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & + Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain,Atm(mygrid)%diss_est) !Nudging back to IC !$omp parallel do default (none) & -!$omp shared (pref, npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dp0, xt, zvir, mytile, nudge_dz, dz0) & +!$omp shared (pref, npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dp0, xt, zvir, mygrid, nudge_dz, dz0) & !$omp private (i, j, k, p00, q00) do k=1,npz do j=jsc,jec+1 do i=isc,iec - Atm(mytile)%u(i,j,k) = xt*(Atm(mytile)%u(i,j,k) + wt*u0(i,j,k)) + Atm(mygrid)%u(i,j,k) = xt*(Atm(mygrid)%u(i,j,k) + wt*u0(i,j,k)) enddo enddo do j=jsc,jec do i=isc,iec+1 - Atm(mytile)%v(i,j,k) = xt*(Atm(mytile)%v(i,j,k) + wt*v0(i,j,k)) + Atm(mygrid)%v(i,j,k) = xt*(Atm(mygrid)%v(i,j,k) + wt*v0(i,j,k)) enddo enddo - if( Atm(mytile)%flagstruct%nudge_qv ) then + if( Atm(mygrid)%flagstruct%nudge_qv ) then ! SJL note: Nudging water vaport towards HALOE climatology: ! In case of better IC (IFS) this step may not be necessary - p00 = Atm(mytile)%pe(isc,k,jsc) + p00 = Atm(mygrid)%pe(isc,k,jsc) if ( p00 < 30.E2 ) then if ( p00 < 1. ) then q00 = q1_h2o @@ -1772,7 +1807,7 @@ subroutine adiabatic_init(zvir,nudge_dz,time) endif do j=jsc,jec do i=isc,iec - Atm(mytile)%q(i,j,k,sphum) = xt*(Atm(mytile)%q(i,j,k,sphum) + wt*q00) + Atm(mygrid)%q(i,j,k,sphum) = xt*(Atm(mygrid)%q(i,j,k,sphum) + wt*q00) enddo enddo endif @@ -1780,19 +1815,19 @@ subroutine adiabatic_init(zvir,nudge_dz,time) if ( nudge_dz ) then do j=jsc,jec do i=isc,iec - Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) - Atm(mytile)%delz(i,j,k) = xt*(Atm(mytile)%delz(i,j,k) + wt*dz0(i,j,k)) + Atm(mygrid)%delp(i,j,k) = xt*(Atm(mygrid)%delp(i,j,k) + wt*dp0(i,j,k)) + Atm(mygrid)%delz(i,j,k) = xt*(Atm(mygrid)%delz(i,j,k) + wt*dz0(i,j,k)) enddo enddo else do j=jsc,jec do i=isc,iec #ifdef MULTI_GASES - Atm(mytile)%pt(i,j,k) = xt*(Atm(mytile)%pt(i,j,k) + wt*t0(i,j,k)/virq(Atm(mytile)%q(i,j,k,:))) + Atm(mygrid)%pt(i,j,k) = xt*(Atm(mygrid)%pt(i,j,k) + wt*t0(i,j,k)/virq(Atm(mygrid)%q(i,j,k,:))) #else - Atm(mytile)%pt(i,j,k) = xt*(Atm(mytile)%pt(i,j,k) + wt*t0(i,j,k)/(1.+zvir*Atm(mytile)%q(i,j,k,sphum))) + Atm(mygrid)%pt(i,j,k) = xt*(Atm(mygrid)%pt(i,j,k) + wt*t0(i,j,k)/(1.+zvir*Atm(mygrid)%q(i,j,k,sphum))) #endif - Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) + Atm(mygrid)%delp(i,j,k) = xt*(Atm(mygrid)%delp(i,j,k) + wt*dp0(i,j,k)) enddo enddo endif @@ -1800,66 +1835,64 @@ subroutine adiabatic_init(zvir,nudge_dz,time) enddo ! Backward - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, -dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & -! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, -dt_atmos, 0., & + Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & + Atm(mygrid)%ptop, Atm(mygrid)%ks, nq, Atm(mygrid)%flagstruct%n_split, & + Atm(mygrid)%flagstruct%q_split, Atm(mygrid)%u, Atm(mygrid)%v, Atm(mygrid)%w, & + Atm(mygrid)%delz, Atm(mygrid)%flagstruct%hydrostatic, & + Atm(mygrid)%pt, Atm(mygrid)%delp, Atm(mygrid)%q, Atm(mygrid)%ps, & + Atm(mygrid)%pe, Atm(mygrid)%pk, Atm(mygrid)%peln, Atm(mygrid)%pkz, Atm(mygrid)%phis, & + Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & + Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & + Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & + Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain,Atm(mygrid)%diss_est) ! Forward call - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & -! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mygrid)%npx, Atm(mygrid)%npy, npz, nq, Atm(mygrid)%ng, dt_atmos, 0., & + Atm(mygrid)%flagstruct%fill, Atm(mygrid)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & + Atm(mygrid)%ptop, Atm(mygrid)%ks, nq, Atm(mygrid)%flagstruct%n_split, & + Atm(mygrid)%flagstruct%q_split, Atm(mygrid)%u, Atm(mygrid)%v, Atm(mygrid)%w, & + Atm(mygrid)%delz, Atm(mygrid)%flagstruct%hydrostatic, & + Atm(mygrid)%pt, Atm(mygrid)%delp, Atm(mygrid)%q, Atm(mygrid)%ps, & + Atm(mygrid)%pe, Atm(mygrid)%pk, Atm(mygrid)%peln, Atm(mygrid)%pkz, Atm(mygrid)%phis, & + Atm(mygrid)%q_con, Atm(mygrid)%omga, Atm(mygrid)%ua, Atm(mygrid)%va, Atm(mygrid)%uc, Atm(mygrid)%vc, & + Atm(mygrid)%ak, Atm(mygrid)%bk, Atm(mygrid)%mfx, Atm(mygrid)%mfy, & + Atm(mygrid)%cx, Atm(mygrid)%cy, Atm(mygrid)%ze0, Atm(mygrid)%flagstruct%hybrid_z, & + Atm(mygrid)%gridstruct, Atm(mygrid)%flagstruct, & + Atm(mygrid)%neststruct, Atm(mygrid)%idiag, Atm(mygrid)%bd, Atm(mygrid)%parent_grid, & + Atm(mygrid)%domain,Atm(mygrid)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & -!$omp shared (nudge_dz,npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dz0, dp0, xt, zvir, mytile) & +!$omp shared (nudge_dz,npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dz0, dp0, xt, zvir, mygrid) & !$omp private (i, j, k) do k=1,npz do j=jsc,jec+1 do i=isc,iec - Atm(mytile)%u(i,j,k) = xt*(Atm(mytile)%u(i,j,k) + wt*u0(i,j,k)) + Atm(mygrid)%u(i,j,k) = xt*(Atm(mygrid)%u(i,j,k) + wt*u0(i,j,k)) enddo enddo do j=jsc,jec do i=isc,iec+1 - Atm(mytile)%v(i,j,k) = xt*(Atm(mytile)%v(i,j,k) + wt*v0(i,j,k)) + Atm(mygrid)%v(i,j,k) = xt*(Atm(mygrid)%v(i,j,k) + wt*v0(i,j,k)) enddo enddo if ( nudge_dz ) then do j=jsc,jec do i=isc,iec - Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) - Atm(mytile)%delz(i,j,k) = xt*(Atm(mytile)%delz(i,j,k) + wt*dz0(i,j,k)) + Atm(mygrid)%delp(i,j,k) = xt*(Atm(mygrid)%delp(i,j,k) + wt*dp0(i,j,k)) + Atm(mygrid)%delz(i,j,k) = xt*(Atm(mygrid)%delz(i,j,k) + wt*dz0(i,j,k)) enddo enddo else do j=jsc,jec do i=isc,iec #ifdef MULTI_GASES - Atm(mytile)%pt(i,j,k) = xt*(Atm(mytile)%pt(i,j,k) + wt*t0(i,j,k)/virq(Atm(mytile)%q(i,j,k,:))) + Atm(mygrid)%pt(i,j,k) = xt*(Atm(mygrid)%pt(i,j,k) + wt*t0(i,j,k)/virq(Atm(mygrid)%q(i,j,k,:))) #else - Atm(mytile)%pt(i,j,k) = xt*(Atm(mytile)%pt(i,j,k) + wt*t0(i,j,k)/(1.+zvir*Atm(mytile)%q(i,j,k,sphum))) + Atm(mygrid)%pt(i,j,k) = xt*(Atm(mygrid)%pt(i,j,k) + wt*t0(i,j,k)/(1.+zvir*Atm(mygrid)%q(i,j,k,sphum))) #endif - Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) + Atm(mygrid)%delp(i,j,k) = xt*(Atm(mygrid)%delp(i,j,k) + wt*dp0(i,j,k)) enddo enddo endif @@ -1905,17 +1938,21 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) real(kind=kind_phys) :: pk0inv, ptop, pktop real(kind=kind_phys) :: rTv, dm, qgrs_rad integer :: nb, blen, npz, i, j, k, ix, k1, kz, dnats, nq_adv +#ifdef MULTI_GASES + real :: q_grs(nq), q_min +#endif + !!! NOTES: lmh 6nov15 !!! - "Layer" means "layer mean", ie. the average value in a layer !!! - "Level" means "level interface", ie the point values at the top or bottom of a layer - ptop = _DBL_(_RL_(Atm(mytile)%ak(1))) + ptop = _DBL_(_RL_(Atm(mygrid)%ak(1))) pktop = (ptop/p00)**kappa pk0inv = (1.0_kind_phys/p00)**kappa npz = Atm_block%npz - dnats = Atm(mytile)%flagstruct%dnats + dnats = Atm(mygrid)%flagstruct%dnats nq_adv = nq - dnats !--------------------------------------------------------------------- @@ -1924,8 +1961,14 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) !$OMP parallel do default (none) & !$OMP shared (Atm_block, Atm, IPD_Data, npz, nq, ncnst, sphum, liq_wat, & !$OMP ice_wat, rainwat, snowwat, graupel, pk0inv, ptop, & -!$OMP pktop, zvir, mytile, dnats, nq_adv, flip_vc) & +!$OMP pktop, zvir, mygrid, dnats, nq_adv, flip_vc) & +#ifdef MULTI_GASES + +!$OMP private (dm, nb, blen, i, j, ix, k1, kz, rTv, qgrs_rad, q_min, q_grs) + +#else !$OMP private (dm, nb, blen, i, j, ix, k1, kz, rTv, qgrs_rad) +#endif do nb = 1,Atm_block%nblks ! gas_phase_mass <-- prsl @@ -1955,32 +1998,32 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) i = Atm_block%index(nb)%ii(ix) j = Atm_block%index(nb)%jj(ix) - IPD_Data(nb)%Statein%tgrs(ix,k) = _DBL_(_RL_(Atm(mytile)%pt(i,j,k1))) - IPD_Data(nb)%Statein%ugrs(ix,k) = _DBL_(_RL_(Atm(mytile)%ua(i,j,k1))) - IPD_Data(nb)%Statein%vgrs(ix,k) = _DBL_(_RL_(Atm(mytile)%va(i,j,k1))) - IPD_Data(nb)%Statein%vvl(ix,k) = _DBL_(_RL_(Atm(mytile)%omga(i,j,k1))) - IPD_Data(nb)%Statein%prsl(ix,k) = _DBL_(_RL_(Atm(mytile)%delp(i,j,k1))) ! Total mass - if (Atm(mytile)%flagstruct%do_skeb)IPD_Data(nb)%Statein%diss_est(ix,k) = _DBL_(_RL_(Atm(mytile)%diss_est(i,j,k1))) + IPD_Data(nb)%Statein%tgrs(ix,k) = _DBL_(_RL_(Atm(mygrid)%pt(i,j,k1))) + IPD_Data(nb)%Statein%ugrs(ix,k) = _DBL_(_RL_(Atm(mygrid)%ua(i,j,k1))) + IPD_Data(nb)%Statein%vgrs(ix,k) = _DBL_(_RL_(Atm(mygrid)%va(i,j,k1))) + IPD_Data(nb)%Statein%vvl(ix,k) = _DBL_(_RL_(Atm(mygrid)%omga(i,j,k1))) + IPD_Data(nb)%Statein%prsl(ix,k) = _DBL_(_RL_(Atm(mygrid)%delp(i,j,k1))) ! Total mass + if (Atm(mygrid)%flagstruct%do_skeb)IPD_Data(nb)%Statein%diss_est(ix,k) = _DBL_(_RL_(Atm(mygrid)%diss_est(i,j,k1))) if(flip_vc) then - if (.not.Atm(mytile)%flagstruct%hydrostatic .and. (.not.Atm(mytile)%flagstruct%use_hydro_pressure)) & - IPD_Data(nb)%Statein%phii(ix,k+1) = IPD_Data(nb)%Statein%phii(ix,k) - _DBL_(_RL_(Atm(mytile)%delz(i,j,k1)*grav)) + if (.not.Atm(mygrid)%flagstruct%hydrostatic .and. (.not.Atm(mygrid)%flagstruct%use_hydro_pressure)) & + IPD_Data(nb)%Statein%phii(ix,k+1) = IPD_Data(nb)%Statein%phii(ix,k) - _DBL_(_RL_(Atm(mygrid)%delz(i,j,k1)*grav)) else - if (.not.Atm(mytile)%flagstruct%hydrostatic .and. (.not.Atm(mytile)%flagstruct%use_hydro_pressure)) & - IPD_Data(nb)%Statein%phii(ix,kz) = IPD_Data(nb)%Statein%phii(ix,kz+1) - _DBL_(_RL_(Atm(mytile)%delz(i,j,kz)*grav)) + if (.not.Atm(mygrid)%flagstruct%hydrostatic .and. (.not.Atm(mygrid)%flagstruct%use_hydro_pressure)) & + IPD_Data(nb)%Statein%phii(ix,kz) = IPD_Data(nb)%Statein%phii(ix,kz+1) - _DBL_(_RL_(Atm(mygrid)%delz(i,j,kz)*grav)) endif ! Convert to tracer mass: - IPD_Data(nb)%Statein%qgrs(ix,k,1:nq_adv) = _DBL_(_RL_(Atm(mytile)%q(i,j,k1,1:nq_adv))) & + IPD_Data(nb)%Statein%qgrs(ix,k,1:nq_adv) = _DBL_(_RL_(Atm(mygrid)%q(i,j,k1,1:nq_adv))) & * IPD_Data(nb)%Statein%prsl(ix,k) if (dnats > 0) & - IPD_Data(nb)%Statein%qgrs(ix,k,nq_adv+1:nq) = _DBL_(_RL_(Atm(mytile)%q(i,j,k1,nq_adv+1:nq))) + IPD_Data(nb)%Statein%qgrs(ix,k,nq_adv+1:nq) = _DBL_(_RL_(Atm(mygrid)%q(i,j,k1,nq_adv+1:nq))) !--- SHOULD THESE BE CONVERTED TO MASS SINCE THE DYCORE DOES NOT TOUCH THEM IN ANY WAY??? !--- See Note in state update... if ( ncnst > nq) & - IPD_Data(nb)%Statein%qgrs(ix,k,nq+1:ncnst) = _DBL_(_RL_(Atm(mytile)%qdiag(i,j,k1,nq+1:ncnst))) + IPD_Data(nb)%Statein%qgrs(ix,k,nq+1:ncnst) = _DBL_(_RL_(Atm(mygrid)%qdiag(i,j,k1,nq+1:ncnst))) ! Remove the contribution of condensates to delp (mass): - if ( Atm(mytile)%flagstruct%nwat == 6 ) then + if ( Atm(mygrid)%flagstruct%nwat == 6 ) then IPD_Data(nb)%Statein%prsl(ix,k) = IPD_Data(nb)%Statein%prsl(ix,k) & - IPD_Data(nb)%Statein%qgrs(ix,k,liq_wat) & - IPD_Data(nb)%Statein%qgrs(ix,k,ice_wat) & @@ -1989,7 +2032,7 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) - IPD_Data(nb)%Statein%qgrs(ix,k,graupel) else !variable condensate numbers IPD_Data(nb)%Statein%prsl(ix,k) = IPD_Data(nb)%Statein%prsl(ix,k) & - - sum(IPD_Data(nb)%Statein%qgrs(ix,k,2:Atm(mytile)%flagstruct%nwat)) + - sum(IPD_Data(nb)%Statein%qgrs(ix,k,2:Atm(mygrid)%flagstruct%nwat)) endif enddo enddo @@ -2032,12 +2075,14 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) do i=1,blen ! Geo-potential at interfaces: #ifdef MULTI_GASES - rTv = rdgas*IPD_Data(nb)%Statein%tgrs(i,k)*virq_max(IPD_Data(nb)%Statein%qgrs(i,k,:),qmin) + q_grs(1:nq_adv) = IPD_Data(nb)%Statein%qgrs(i,k,1:nq_adv) + q_min = qmin + rTv = rdgas*IPD_Data(nb)%Statein%tgrs(i,k)*virq_max(q_grs(:),q_min) #else qgrs_rad = max(qmin,IPD_Data(nb)%Statein%qgrs(i,k,sphum)) rTv = rdgas*IPD_Data(nb)%Statein%tgrs(i,k)*(1.+zvir*qgrs_rad) #endif - if ( Atm(mytile)%flagstruct%hydrostatic .or. Atm(mytile)%flagstruct%use_hydro_pressure ) & + if ( Atm(mygrid)%flagstruct%hydrostatic .or. Atm(mygrid)%flagstruct%use_hydro_pressure ) & IPD_Data(nb)%Statein%phii(i,k+1) = IPD_Data(nb)%Statein%phii(i,k) & + rTv*(IPD_Data(nb)%Statein%prsik(i,k) & - IPD_Data(nb)%Statein%prsik(i,k+1)) @@ -2047,7 +2092,7 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) - IPD_Data(nb)%Statein%phii(i,k)) !!! Ensure subgrid MONOTONICITY of Pressure: SJL 09/11/2016 - if ( .not.Atm(mytile)%flagstruct%hydrostatic ) then + if ( .not.Atm(mygrid)%flagstruct%hydrostatic ) then ! If violated, replaces it with hydrostatic pressure IPD_Data(nb)%Statein%prsl(i,k) = min(IPD_Data(nb)%Statein%prsl(i,k), & IPD_Data(nb)%Statein%prsi(i,k) - 0.01*dm) @@ -2074,7 +2119,7 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) IPD_Data(nb)%Statein%prsik(i,npz+1) = pktop ! TOA enddo - if ( Atm(mytile)%flagstruct%hydrostatic .or. Atm(mytile)%flagstruct%use_hydro_pressure ) then + if ( Atm(mygrid)%flagstruct%hydrostatic .or. Atm(mygrid)%flagstruct%use_hydro_pressure ) then do k=2,npz do i=1,blen IPD_Data(nb)%Statein%prsik(i,k) = exp( kappa*IPD_Data(nb)%Statein%prsik(i,k) )*pk0inv @@ -2085,4 +2130,62 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) end subroutine atmos_phys_driver_statein + subroutine atmos_phys_qdt_diag(q, phys_diag, nq, dt, begin) + + integer, intent(IN) :: nq + real, intent(IN) :: dt + logical, intent(IN) :: begin + real, intent(IN) :: q(isd:ied,jsd:jed,npz,nq) + type(phys_diag_type), intent(INOUT) :: phys_diag + + integer sphum, liq_wat, ice_wat ! GFDL AM physics + integer rainwat, snowwat, graupel ! GFDL Cloud Microphysics + + sphum = get_tracer_index (MODEL_ATMOS, 'sphum') + liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat') + ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat') + rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') + snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') + graupel = get_tracer_index (MODEL_ATMOS, 'graupel') + + if (begin) then + if (allocated(phys_diag%phys_qv_dt)) phys_diag%phys_qv_dt = q(isc:iec,jsc:jec,:,sphum) + if (allocated(phys_diag%phys_ql_dt)) then + if (liq_wat < 0) call mpp_error(FATAL, " phys_ql_dt needs at least one liquid water tracer defined") + phys_diag%phys_ql_dt = q(isc:iec,jsc:jec,:,liq_wat) + endif + if (allocated(phys_diag%phys_qi_dt)) then + if (ice_wat < 0) then + call mpp_error(WARNING, " phys_qi_dt needs at least one ice water tracer defined") + phys_diag%phys_qi_dt = 0. + endif + phys_diag%phys_qi_dt = q(isc:iec,jsc:jec,:,ice_wat) + endif + else + if (allocated(phys_diag%phys_qv_dt)) phys_diag%phys_qv_dt = q(isc:iec,jsc:jec,:,sphum) - phys_diag%phys_qv_dt + if (allocated(phys_diag%phys_ql_dt)) then + phys_diag%phys_ql_dt = q(isc:iec,jsc:jec,:,liq_wat) - phys_diag%phys_ql_dt + endif + if (allocated(phys_diag%phys_qi_dt)) then + phys_diag%phys_qi_dt = q(isc:iec,jsc:jec,:,ice_wat) - phys_diag%phys_qv_dt + endif + endif + + if (allocated(phys_diag%phys_ql_dt)) then + if (rainwat > 0) phys_diag%phys_ql_dt = q(isc:iec,jsc:jec,:,rainwat) + phys_diag%phys_ql_dt + endif + if (allocated(phys_diag%phys_qi_dt)) then + if (snowwat > 0) phys_diag%phys_qi_dt = q(isc:iec,jsc:jec,:,snowwat) + phys_diag%phys_qi_dt + if (graupel > 0) phys_diag%phys_qi_dt = q(isc:iec,jsc:jec,:,graupel) + phys_diag%phys_qi_dt + endif + + if (.not. begin) then + if (allocated(phys_diag%phys_qv_dt)) phys_diag%phys_qv_dt = phys_diag%phys_qv_dt / dt + if (allocated(phys_diag%phys_ql_dt)) phys_diag%phys_ql_dt = phys_diag%phys_ql_dt / dt + if (allocated(phys_diag%phys_qi_dt)) phys_diag%phys_qi_dt = phys_diag%phys_qi_dt / dt + endif + + + end subroutine atmos_phys_qdt_diag + end module atmosphere_mod diff --git a/makefile b/makefile index 523dc111b..e35a9baba 100644 --- a/makefile +++ b/makefile @@ -23,7 +23,7 @@ endif LIBRARY = libfv3core.a -FFLAGS += -I$(FMS_DIR) -I../gfsphysics -I../ipd -I../io -I../namphysics +FFLAGS += -I$(FMS_DIR) -I../gfsphysics -I../ipd -I../io -I. SRCS_f = diff --git a/model/a2b_edge.F90 b/model/a2b_edge.F90 index af138f658..5e8d9413b 100644 --- a/model/a2b_edge.F90 +++ b/model/a2b_edge.F90 @@ -114,7 +114,7 @@ subroutine a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace ! Corners: ! 3-way extrapolation - if (gridstruct%nested .or. gridstruct%regional) then + if (gridstruct%bounded_domain) then do j=js-2,je+2 do i=is,ie+1 @@ -201,7 +201,7 @@ subroutine a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace ! Y-Interior: !------------ - if (gridstruct%nested .or. gridstruct%regional) then + if (gridstruct%bounded_domain) then do j=js,je+1 @@ -257,7 +257,7 @@ subroutine a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace end if !-------------------------------------- - if (gridstruct%nested .or. gridstruct%regional) then + if (gridstruct%bounded_domain) then do j=js, je+1 do i=is,ie+1 @@ -463,7 +463,7 @@ subroutine a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace !------------ ! X-Interior: !------------ - if (gridstruct%nested .or. gridstruct%regional) then + if (gridstruct%bounded_domain) then do j=js-2,je+2 do i=is, ie+1 @@ -534,7 +534,7 @@ subroutine a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace !------------ ! Y-Interior: !------------ - if (gridstruct%nested .or. gridstruct%regional) then + if (gridstruct%bounded_domain) then do j=js,je+1 do i=is-2, ie+2 @@ -602,7 +602,7 @@ subroutine a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace end if - if (gridstruct%nested .or. gridstruct%regional) then + if (gridstruct%bounded_domain) then do j=js,je+1 do i=is,ie+1 @@ -722,7 +722,7 @@ subroutine a2b_ord2(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace if (gridstruct%grid_type < 3) then - if (gridstruct%nested .or. gridstruct%regional) then + if (gridstruct%bounded_domain) then do j=js-2,je+1+2 do i=is-2,ie+1+2 diff --git a/model/boundary.F90 b/model/boundary.F90 index 49c882bf6..5c087c483 100644 --- a/model/boundary.F90 +++ b/model/boundary.F90 @@ -59,12 +59,13 @@ module boundary_mod ! ! - use fv_mp_mod, only: ng, isc,jsc,iec,jec, isd,jsd,ied,jed, is,js,ie,je, is_master + use fv_mp_mod, only: is_master use constants_mod, only: grav use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain use mpp_domains_mod, only: CENTER, CORNER, NORTH, EAST use mpp_domains_mod, only: mpp_global_field, mpp_get_pelist + use mpp_domains_mod, only: AGRID, BGRID_NE, CGRID_NE, DGRID_NE use mpp_mod, only: mpp_error, FATAL, mpp_sum, mpp_sync, mpp_npes, mpp_broadcast, WARNING, mpp_pe use fv_mp_mod, only: mp_bcst @@ -87,15 +88,28 @@ module boundary_mod !! apply the interpolated data directly to the boundary halo cells without saving the datatype. interface nested_grid_BC module procedure nested_grid_BC_2d - module procedure nested_grid_BC_mpp - module procedure nested_grid_BC_mpp_send +! module procedure nested_grid_BC_mpp_2d + module procedure nested_grid_BC_mpp_3d + module procedure nested_grid_BC_mpp_send_2d + module procedure nested_grid_BC_mpp_send_3d module procedure nested_grid_BC_2D_mpp module procedure nested_grid_BC_3d + module procedure nested_grid_BC_mpp_3d_vector end interface + interface nested_grid_BC_send + module procedure nested_grid_BC_send_scalar + module procedure nested_grid_BC_send_vector + end interface + + interface nested_grid_BC_recv + module procedure nested_grid_BC_recv_scalar + module procedure nested_grid_BC_recv_vector + end interface !>@brief The interface 'fill_nested_grid' includes subroutines 'fill_nested_grid_2d' and 'fill_nested_grid_3d' !! that fill nested-grid data with interpolated data from the coarse grid. !>@details This is one method to create a new nested grid, and may be useful when cold-starting. + interface fill_nested_grid module procedure fill_nested_grid_2d module procedure fill_nested_grid_3d @@ -108,6 +122,7 @@ module boundary_mod interface update_coarse_grid module procedure update_coarse_grid_mpp module procedure update_coarse_grid_mpp_2d + module procedure update_coarse_grid_mpp_vector end interface contains @@ -574,9 +589,38 @@ subroutine fill_nested_grid_3D(var_nest, var_coarse, ind, wt, istag, jstag, & end do end subroutine fill_nested_grid_3D + +!!$ subroutine nested_grid_BC_mpp_2d(var_nest, nest_domain, ind, wt, istag, jstag, & +!!$ npx, npy, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in) +!!$ +!!$ type(fv_grid_bounds_type), intent(IN) :: bd +!!$ real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag), intent(INOUT) :: var_nest +!!$ real, dimension(isg:ieg+istag,jsg:jeg+jstag), intent(IN) :: var_coarse +!!$ type(nest_domain_type), intent(INOUT) :: nest_domain +!!$ integer, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,2), intent(IN) :: ind +!!$ real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,4), intent(IN) :: wt +!!$ integer, intent(IN) :: istag, jstag, npx, npy, isg, ieg, jsg, jeg +!!$ integer, intent(IN), OPTIONAL :: nstep_in, nsplit_in +!!$ logical, intent(IN), OPTIONAL :: proc_in +!!$ +!!$ real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,1) :: var_nest_3d +!!$ +!!$ integer :: i,j +!!$ +!!$ do j=bd%jsd,bd%jed+jstag +!!$ do i=bd%isd,bd%ied+istag +!!$ var_nest_3d(i,j,1) = var_nest(i,j) +!!$ enddo +!!$ enddo +!!$ +!!$ call nested_grid_BC_mpp_3d(var_nest_3d, nest_domain, ind, wt, istag, jstag, & +!!$ npx, npy, 1, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in) +!!$ +!!$ +!!$ end subroutine nested_grid_BC_mpp_2d - subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, jstag, & - npx, npy, npz, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in) + subroutine nested_grid_BC_mpp_3d(var_nest, var_coarse, nest_domain, ind, wt, istag, jstag, & + npx, npy, npz, bd, isg, ieg, jsg, jeg, nest_level, nstep_in, nsplit_in, proc_in) type(fv_grid_bounds_type), intent(IN) :: bd real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,npz), intent(INOUT) :: var_nest @@ -585,6 +629,7 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, integer, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,2), intent(IN) :: ind real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,4), intent(IN) :: wt integer, intent(IN) :: istag, jstag, npx, npy, npz, isg, ieg, jsg, jeg + integer, intent(IN) :: nest_level integer, intent(IN), OPTIONAL :: nstep_in, nsplit_in logical, intent(IN), OPTIONAL :: proc_in @@ -631,13 +676,13 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, end if call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, & - WEST, position=position) + WEST, nest_level=nest_level, position=position) call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, & - EAST, position=position) + EAST, nest_level=nest_level, position=position) call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, & - SOUTH, position=position) + SOUTH, nest_level=nest_level, position=position) call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, & - NORTH, position=position) + NORTH, nest_level=nest_level, position=position) if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c ) then allocate(wbuffer(isw_c:iew_c, jsw_c:jew_c,npz)) @@ -669,12 +714,14 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, & + nest_level=nest_level, position=position) call timing_off('COMM_TOTAL') if (process) then if (is == 1) then +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,isd,ind,var_nest,wt,wbuffer) private(ic,jc) do k=1,npz do j=jsd,jed+jstag do i=isd,0 @@ -707,6 +754,7 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, iend = ied end if +!OMP parallel do default(none) shared(npz,jsd,istart,iend,istag,ind,var_nest,wt,sbuffer) private(ic,jc) do k=1,npz do j=jsd,0 do i=istart,iend+istag @@ -727,6 +775,7 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, if (ie == npx-1) then +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,npx,ied,istag,ind,var_nest,wt,ebuffer) private(ic,jc) do k=1,npz do j=jsd,jed+jstag do i=npx+istag,ied+istag @@ -759,6 +808,7 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, iend = ied end if +!OMP parallel do default(none) shared(npz,jstag,npy,jed,istart,iend,istag,ind,var_nest,wt,nbuffer) private(ic,jc) do k=1,npz do j=npy+jstag,jed+jstag do i=istart,iend+istag @@ -781,13 +831,323 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, deallocate(wbuffer, ebuffer, sbuffer, nbuffer) - end subroutine nested_grid_BC_mpp + end subroutine nested_grid_BC_mpp_3d + + subroutine get_vector_position(position_x, position_y, gridtype) + integer, intent(OUT) :: position_x, position_y + integer, optional, intent(IN) :: gridtype + + integer :: grid_offset_type + + grid_offset_type = AGRID + if(present(gridtype)) grid_offset_type = gridtype + + select case(grid_offset_type) + case (AGRID) + position_x = CENTER + position_y = CENTER + case (BGRID_NE) + position_x = CORNER + position_y = CORNER + case (CGRID_NE) + position_x = EAST + position_y = NORTH + case (DGRID_NE) + position_y = EAST + position_x = NORTH + case default + call mpp_error(FATAL, "get_vector_position: invalid value of gridtype") + end select + + + end subroutine get_vector_position + + subroutine init_buffer(nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, npz, nest_level, position) + type(nest_domain_type), intent(INOUT) :: nest_domain + real, allocatable, dimension(:,:,:), intent(OUT) :: wbuffer, sbuffer, ebuffer, nbuffer + integer, intent(IN) :: npz, position, nest_level + integer :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c + integer :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c + integer :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c + integer :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c + + call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, & + WEST, nest_level=nest_level, position=position) + call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, & + EAST, nest_level=nest_level, position=position) + call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, & + SOUTH, nest_level=nest_level, position=position) + call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, & + NORTH, nest_level=nest_level, position=position) + + if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c ) then + allocate(wbuffer(isw_c:iew_c, jsw_c:jew_c,npz)) + else + allocate(wbuffer(1,1,1)) + endif + wbuffer = 0 + + if( iee_c .GE. ise_c .AND. jee_c .GE. jse_c ) then + allocate(ebuffer(ise_c:iee_c, jse_c:jee_c,npz)) + else + allocate(ebuffer(1,1,1)) + endif + ebuffer = 0 + + if( ies_c .GE. iss_c .AND. jes_c .GE. jss_c ) then + allocate(sbuffer(iss_c:ies_c, jss_c:jes_c,npz)) + else + allocate(sbuffer(1,1,1)) + endif + sbuffer = 0 + + if( ien_c .GE. isn_c .AND. jen_c .GE. jsn_c ) then + allocate(nbuffer(isn_c:ien_c, jsn_c:jen_c,npz)) + else + allocate(nbuffer(1,1,1)) + endif + nbuffer = 0 + + end subroutine init_buffer + + + subroutine nested_grid_BC_mpp_3d_vector(u_nest, v_nest, u_coarse, v_coarse, nest_domain, ind_u, ind_v, wt_u, wt_v, & + istag_u, jstag_u, istag_v, jstag_v, npx, npy, npz, bd, isg, ieg, jsg, jeg, nest_level, nstep_in, nsplit_in, proc_in, & + flags, gridtype) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: istag_u, jstag_u, istag_v, jstag_v, npx, npy, npz, isg, ieg, jsg, jeg + real, dimension(bd%isd:bd%ied+istag_u,bd%jsd:bd%jed+jstag_u,npz), intent(INOUT) :: u_nest + real, dimension(bd%isd:bd%ied+istag_v,bd%jsd:bd%jed+jstag_v,npz), intent(INOUT) :: v_nest + real, dimension(isg:ieg+istag_u,jsg:jeg+jstag_u,npz), intent(IN) :: u_coarse + real, dimension(isg:ieg+istag_v,jsg:jeg+jstag_v,npz), intent(IN) :: v_coarse + type(nest_domain_type), intent(INOUT) :: nest_domain + integer, dimension(bd%isd:bd%ied+istag_u,bd%jsd:bd%jed+jstag_u,2), intent(IN) :: ind_u + integer, dimension(bd%isd:bd%ied+istag_v,bd%jsd:bd%jed+jstag_v,2), intent(IN) :: ind_v + real, dimension(bd%isd:bd%ied+istag_u,bd%jsd:bd%jed+jstag_u,4), intent(IN) :: wt_u + real, dimension(bd%isd:bd%ied+istag_v,bd%jsd:bd%jed+jstag_v,4), intent(IN) :: wt_v + integer, intent(IN) :: nest_level + integer, intent(IN), OPTIONAL :: nstep_in, nsplit_in + logical, intent(IN), OPTIONAL :: proc_in + integer, intent(IN), OPTIONAL :: flags, gridtype + + real, allocatable :: wbufferx(:,:,:), wbuffery(:,:,:) + real, allocatable :: ebufferx(:,:,:), ebuffery(:,:,:) + real, allocatable :: sbufferx(:,:,:), sbuffery(:,:,:) + real, allocatable :: nbufferx(:,:,:), nbuffery(:,:,:) + + integer :: i,j, ic, jc, istart, iend, k + + integer :: position_x, position_y + logical :: process + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (PRESENT(proc_in)) then + process = proc_in + else + process = .true. + endif + + call get_vector_position(position_x, position_y, gridtype) + call init_buffer(nest_domain, wbufferx, sbufferx, ebufferx, nbufferx, npz, nest_level, position_x) + call init_buffer(nest_domain, wbuffery, sbuffery, ebuffery, nbuffery, npz, nest_level, position_x) + + call timing_on ('COMM_TOTAL') + call mpp_update_nest_fine(u_coarse, v_coarse, nest_domain, wbufferx, wbuffery, sbufferx, sbuffery, & + ebufferx, ebuffery, nbufferx, nbuffery, flags=flags, nest_level=nest_level, gridtype=gridtype) + call timing_off('COMM_TOTAL') + + if (process) then + + if (is == 1) then +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,isd,ind,var_nest,wt,wbuffer) private(ic,jc) + do k=1,npz + do j=jsd,jed+jstag_u + do i=isd,0 + + ic = ind_u(i,j,1) + jc = ind_u(i,j,2) + + u_nest(i,j,k) = & + wt_u(i,j,1)*wbufferx(ic, jc, k) + & + wt_u(i,j,2)*wbufferx(ic, jc+1,k) + & + wt_u(i,j,3)*wbufferx(ic+1,jc+1,k) + & + wt_u(i,j,4)*wbufferx(ic+1,jc, k) + + end do + end do + do j=jsd,jed+jstag_v + do i=isd,0 + + ic = ind_v(i,j,1) + jc = ind_v(i,j,2) + + v_nest(i,j,k) = & + wt_v(i,j,1)*wbuffery(ic, jc, k) + & + wt_v(i,j,2)*wbuffery(ic, jc+1,k) + & + wt_v(i,j,3)*wbuffery(ic+1,jc+1,k) + & + wt_v(i,j,4)*wbuffery(ic+1,jc, k) + + end do + end do + end do + + end if + + if (js == 1) then + + if (is == 1) then + istart = is + else + istart = isd + end if + + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + +!OMP parallel do default(none) shared(npz,jsd,istart,iend,istag,ind,var_nest,wt,sbuffer) private(ic,jc) + do k=1,npz + do j=jsd,0 + do i=istart,iend+istag_u + + ic = ind_u(i,j,1) + jc = ind_u(i,j,2) - subroutine nested_grid_BC_mpp_send(var_coarse, nest_domain, istag, jstag) + u_nest(i,j,k) = & + wt_u(i,j,1)*sbufferx(ic, jc, k) + & + wt_u(i,j,2)*sbufferx(ic, jc+1,k) + & + wt_u(i,j,3)*sbufferx(ic+1,jc+1,k) + & + wt_u(i,j,4)*sbufferx(ic+1,jc, k) + + end do + end do + do j=jsd,0 + do i=istart,iend+istag_v + + ic = ind_v(i,j,1) + jc = ind_v(i,j,2) + + v_nest(i,j,k) = & + wt_v(i,j,1)*sbuffery(ic, jc, k) + & + wt_v(i,j,2)*sbuffery(ic, jc+1,k) + & + wt_v(i,j,3)*sbuffery(ic+1,jc+1,k) + & + wt_v(i,j,4)*sbuffery(ic+1,jc, k) + + end do + end do + end do + end if + + + if (ie == npx-1) then +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,npx,ied,istag,ind,var_nest,wt,ebuffer) private(ic,jc) + do k=1,npz + do j=jsd,jed+jstag_u + do i=npx+istag_u,ied+istag_u + + ic = ind_u(i,j,1) + jc = ind_u(i,j,2) + + u_nest(i,j,k) = & + wt_u(i,j,1)*ebufferx(ic, jc, k) + & + wt_u(i,j,2)*ebufferx(ic, jc+1,k) + & + wt_u(i,j,3)*ebufferx(ic+1,jc+1,k) + & + wt_u(i,j,4)*ebufferx(ic+1,jc, k) + + end do + end do + do j=jsd,jed+jstag_v + do i=npx+istag_v,ied+istag_v + + ic = ind_v(i,j,1) + jc = ind_v(i,j,2) + + v_nest(i,j,k) = & + wt_v(i,j,1)*ebuffery(ic, jc, k) + & + wt_v(i,j,2)*ebuffery(ic, jc+1,k) + & + wt_v(i,j,3)*ebuffery(ic+1,jc+1,k) + & + wt_v(i,j,4)*ebuffery(ic+1,jc, k) + + end do + end do + end do + end if + + if (je == npy-1) then + + if (is == 1) then + istart = is + else + istart = isd + end if + + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + +!OMP parallel do default(none) shared(npz,jstag,npy,jed,istart,iend,istag,ind,var_nest,wt,nbuffer) private(ic,jc) + do k=1,npz + do j=npy+jstag_u,jed+jstag_u + do i=istart,iend+istag_u + + ic = ind_u(i,j,1) + jc = ind_u(i,j,2) + + u_nest(i,j,k) = & + wt_u(i,j,1)*nbufferx(ic, jc, k) + & + wt_u(i,j,2)*nbufferx(ic, jc+1,k) + & + wt_u(i,j,3)*nbufferx(ic+1,jc+1,k) + & + wt_u(i,j,4)*nbufferx(ic+1,jc, k) + + end do + end do + do j=npy+jstag_v,jed+jstag_v + do i=istart,iend+istag_v + + ic = ind_v(i,j,1) + jc = ind_v(i,j,2) + + v_nest(i,j,k) = & + wt_v(i,j,1)*nbuffery(ic, jc, k) + & + wt_v(i,j,2)*nbuffery(ic, jc+1,k) + & + wt_v(i,j,3)*nbuffery(ic+1,jc+1,k) + & + wt_v(i,j,4)*nbuffery(ic+1,jc, k) + + end do + end do + end do + end if + + endif !process + + deallocate(wbufferx, ebufferx, sbufferx, nbufferx) + deallocate(wbuffery, ebuffery, sbuffery, nbuffery) + + end subroutine nested_grid_BC_mpp_3d_vector + + + subroutine nested_grid_BC_mpp_send_3d(var_coarse, nest_domain, istag, jstag, nest_level) real, dimension(:,:,:), intent(IN) :: var_coarse type(nest_domain_type), intent(INOUT) :: nest_domain integer, intent(IN) :: istag, jstag + integer, intent(IN) :: nest_level real, allocatable :: wbuffer(:,:,:) real, allocatable :: ebuffer(:,:,:) @@ -820,16 +1180,62 @@ subroutine nested_grid_BC_mpp_send(var_coarse, nest_domain, istag, jstag) call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=nest_level, position=position) + call timing_off('COMM_TOTAL') + + + deallocate(wbuffer, ebuffer, sbuffer, nbuffer) + + end subroutine nested_grid_BC_mpp_send_3d + + subroutine nested_grid_BC_mpp_send_2d(var_coarse, nest_domain, istag, jstag, nest_level) + + real, dimension(:,:), intent(IN) :: var_coarse + type(nest_domain_type), intent(INOUT) :: nest_domain + integer, intent(IN) :: istag, jstag + integer, intent(IN) :: nest_level + + real, allocatable :: wbuffer(:,:) + real, allocatable :: ebuffer(:,:) + real, allocatable :: sbuffer(:,:) + real, allocatable :: nbuffer(:,:) + + integer :: i,j, ic, jc, istart, iend, k + + integer :: position + + + if (istag == 1 .and. jstag == 1) then + position = CORNER + else if (istag == 0 .and. jstag == 1) then + position = NORTH + else if (istag == 1 .and. jstag == 0) then + position = EAST + else + position = CENTER + end if + + + allocate(wbuffer(1,1)) + + allocate(ebuffer(1,1)) + + allocate(sbuffer(1,1)) + + allocate(nbuffer(1,1)) + + + call timing_on ('COMM_TOTAL') + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=nest_level, position=position) call timing_off('COMM_TOTAL') deallocate(wbuffer, ebuffer, sbuffer, nbuffer) - end subroutine nested_grid_BC_mpp_send + end subroutine nested_grid_BC_mpp_send_2d subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, jstag, & - npx, npy, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in) + npx, npy, bd, isg, ieg, jsg, jeg, nest_level, nstep_in, nsplit_in, proc_in) type(fv_grid_bounds_type), intent(IN) :: bd real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag), intent(INOUT) :: var_nest @@ -838,6 +1244,7 @@ subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, ist integer, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,2), intent(IN) :: ind real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,4), intent(IN) :: wt integer, intent(IN) :: istag, jstag, npx, npy, isg, ieg, jsg, jeg + integer, intent(IN), OPTIONAL :: nest_level integer, intent(IN), OPTIONAL :: nstep_in, nsplit_in logical, intent(IN), OPTIONAL :: proc_in @@ -851,6 +1258,7 @@ subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, ist real, allocatable :: nbuffer(:,:) integer :: i,j, ic, jc, istart, iend, k + integer :: nl = 1 !nest_level integer :: position logical :: process @@ -873,6 +1281,10 @@ subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, ist process = .true. endif + if (PRESENT(nest_level)) then + nl = nest_level + endif + if (istag == 1 .and. jstag == 1) then position = CORNER else if (istag == 0 .and. jstag == 1) then @@ -884,13 +1296,13 @@ subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, ist end if call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, & - WEST, position=position) + WEST, nest_level=nl, position=position) call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, & - EAST, position=position) + EAST, nest_level=nl, position=position) call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, & - SOUTH, position=position) + SOUTH, nest_level=nl, position=position) call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, & - NORTH, position=position) + NORTH, nest_level=nl, position=position) if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c ) then allocate(wbuffer(isw_c:iew_c, jsw_c:jew_c)) @@ -921,7 +1333,7 @@ subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, ist nbuffer = 0 call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=nl, position=position) call timing_off('COMM_TOTAL') if (process) then @@ -1198,6 +1610,7 @@ subroutine nested_grid_BC_3D(var_nest, var_coarse, ind, wt, istag, jstag, & end if if (is == 1) then +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,isd,ind,var_nest,wt,var_coarse) private(ic,jc) do k=1,npz do j=jsd,jed+jstag do i=isd,0 @@ -1230,6 +1643,7 @@ subroutine nested_grid_BC_3D(var_nest, var_coarse, ind, wt, istag, jstag, & iend = ied end if +!OMP parallel do default(none) shared(npz,jsd,istart,iend,istag,ind,var_nest,wt,var_coarse) private(ic,jc) do k=1,npz do j=jsd,0 do i=istart,iend+istag @@ -1250,6 +1664,7 @@ subroutine nested_grid_BC_3D(var_nest, var_coarse, ind, wt, istag, jstag, & if (ie == npx-1) then +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,npx,ied,istag,ind,var_nest,wt,var_coarse) private(ic,jc) do k=1,npz do j=jsd,jed+jstag do i=npx+istag,ied+istag @@ -1282,6 +1697,7 @@ subroutine nested_grid_BC_3D(var_nest, var_coarse, ind, wt, istag, jstag, & iend = ied end if +!OMP parallel do default(none) shared(npz,npy,jed,jstag,istart,iend,istag,ind,var_nest,wt,var_coarse) private(ic,jc) do k=1,npz do j=npy+jstag,jed+jstag do i=istart,iend+istag @@ -1303,13 +1719,13 @@ subroutine nested_grid_BC_3D(var_nest, var_coarse, ind, wt, istag, jstag, & end subroutine nested_grid_BC_3D - !>@brief The subroutine 'nested_grid_BC_send' sends coarse-grid data to create boundary conditions. - subroutine nested_grid_BC_send(var_coarse, nest_domain, istag, jstag) + subroutine nested_grid_BC_send_scalar(var_coarse, nest_domain, istag, jstag, nest_level) real, dimension(:,:,:), intent(IN) :: var_coarse type(nest_domain_type), intent(INOUT) :: nest_domain integer, intent(IN) :: istag, jstag + integer, intent(IN) :: nest_level integer :: position @@ -1330,29 +1746,29 @@ subroutine nested_grid_BC_send(var_coarse, nest_domain, istag, jstag) end if call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=nest_level, position=position) call timing_off('COMM_TOTAL') - end subroutine nested_grid_BC_send + end subroutine nested_grid_BC_send_scalar -!>@briefThe subroutine 'nested_grid_BC_recv' receives coarse-grid data to create boundary conditions. - subroutine nested_grid_BC_recv(nest_domain, istag, jstag, npz, & - bd, nest_BC_buffers) + subroutine nested_grid_BC_recv_scalar(nest_domain, istag, jstag, npz, & + bd, nest_BC_buffers, nest_level) type(fv_grid_bounds_type), intent(IN) :: bd type(nest_domain_type), intent(INOUT) :: nest_domain integer, intent(IN) :: istag, jstag, npz + integer, intent(IN) :: nest_level type(fv_nest_BC_type_3d), intent(INOUT), target :: nest_BC_buffers - + real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,npz) :: var_coarse_dummy integer :: position - integer :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c - integer :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c - integer :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c - integer :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c +!!$ integer :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c +!!$ integer :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c +!!$ integer :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c +!!$ integer :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c integer :: i,j, k @@ -1367,80 +1783,151 @@ subroutine nested_grid_BC_recv(nest_domain, istag, jstag, npz, & end if if (.not. allocated(nest_BC_buffers%west_t1) ) then + call init_nest_bc_type(nest_domain, nest_BC_buffers, npz, nest_level, position) + endif + + call timing_on ('COMM_TOTAL') + call mpp_update_nest_fine(var_coarse_dummy, nest_domain, nest_BC_buffers%west_t1, nest_BC_buffers%south_t1, & + nest_BC_buffers%east_t1, nest_BC_buffers%north_t1, nest_level=nest_level, position=position) + call timing_off('COMM_TOTAL') + + end subroutine nested_grid_BC_recv_scalar + + subroutine nested_grid_BC_send_vector(u_coarse, v_coarse, nest_domain, nest_level, flags, gridtype) + real, dimension(:,:,:), intent(IN) :: u_coarse, v_coarse + type(nest_domain_type), intent(INOUT) :: nest_domain + integer, intent(IN) :: nest_level + integer, optional, intent(IN) :: flags, gridtype + + real :: wbufferx(1,1,1), wbuffery(1,1,1) + real :: ebufferx(1,1,1), ebuffery(1,1,1) + real :: sbufferx(1,1,1), sbuffery(1,1,1) + real :: nbufferx(1,1,1), nbuffery(1,1,1) + + integer :: nl = 1 + + call timing_on ('COMM_TOTAL') + call mpp_update_nest_fine(u_coarse, v_coarse, nest_domain, wbufferx,wbuffery, sbufferx, sbuffery, & + ebufferx, ebuffery, nbufferx, nbuffery, nest_level=nest_level, flags=flags, gridtype=gridtype) + call timing_off('COMM_TOTAL') + + end subroutine nested_grid_BC_send_vector + + subroutine init_nest_bc_type(nest_domain, nest_BC_buffers, npz, nest_level, position) + type(nest_domain_type), intent(INOUT) :: nest_domain + type(fv_nest_BC_type_3d), intent(INOUT) :: nest_BC_buffers + integer, intent(IN) :: npz, position, nest_level + + integer :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c + integer :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c + integer :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c + integer :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c + integer :: i, j, k call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, & - WEST, position=position) + WEST, nest_level=nest_level, position=position) call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, & - EAST, position=position) + EAST, nest_level=nest_level, position=position) call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, & - SOUTH, position=position) + SOUTH, nest_level=nest_level, position=position) call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, & - NORTH, position=position) + NORTH, nest_level=nest_level, position=position) if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c ) then If (.not. allocated(nest_BC_buffers%west_t1)) allocate(nest_BC_buffers%west_t1(isw_c:iew_c, jsw_c:jew_c,npz)) !compatible with first touch principle +!OMP parallel do default(none) shared(npz,jsw_c,jew_c,isw_c,iew_c,nest_BC_buffers) do k=1,npz do j=jsw_c,jew_c do i=isw_c,iew_c - nest_BC_buffers%west_t1(i,j,k) = 0. + nest_BC_buffers%west_t1(i,j,k) = 1.e24 enddo enddo enddo else allocate(nest_BC_buffers%west_t1(1,1,1)) - nest_BC_buffers%west_t1(1,1,1) = 0. + nest_BC_buffers%west_t1(1,1,1) = 1.e24 endif if( iee_c .GE. ise_c .AND. jee_c .GE. jse_c ) then If (.not. allocated(nest_BC_buffers%east_t1)) allocate(nest_BC_buffers%east_t1(ise_c:iee_c, jse_c:jee_c,npz)) +!OMP parallel do default(none) shared(npz,jse_c,jee_c,ise_c,iee_c,nest_BC_buffers) do k=1,npz do j=jse_c,jee_c do i=ise_c,iee_c - nest_BC_buffers%east_t1(i,j,k) = 0. + nest_BC_buffers%east_t1(i,j,k) = 1.e24 enddo enddo enddo else allocate(nest_BC_buffers%east_t1(1,1,1)) - nest_BC_buffers%east_t1(1,1,1) = 0. + nest_BC_buffers%east_t1(1,1,1) = 1.e24 endif if( ies_c .GE. iss_c .AND. jes_c .GE. jss_c ) then If (.not. allocated(nest_BC_buffers%south_t1)) allocate(nest_BC_buffers%south_t1(iss_c:ies_c, jss_c:jes_c,npz)) +!OMP parallel do default(none) shared(npz,jss_c,jes_c,iss_c,ies_c,nest_BC_buffers) do k=1,npz do j=jss_c,jes_c do i=iss_c,ies_c - nest_BC_buffers%south_t1(i,j,k) = 0. + nest_BC_buffers%south_t1(i,j,k) = 1.e24 enddo enddo enddo else allocate(nest_BC_buffers%south_t1(1,1,1)) - nest_BC_buffers%south_t1(1,1,1) = 0. + nest_BC_buffers%south_t1(1,1,1) = 1.e24 endif if( ien_c .GE. isn_c .AND. jen_c .GE. jsn_c ) then If (.not. allocated(nest_BC_buffers%north_t1)) allocate(nest_BC_buffers%north_t1(isn_c:ien_c, jsn_c:jen_c,npz)) +!OMP parallel do default(none) shared(npz,jsn_c,jen_c,isn_c,ien_c,nest_BC_buffers) do k=1,npz do j=jsn_c,jen_c do i=isn_c,ien_c - nest_BC_buffers%north_t1(i,j,k) = 0. + nest_BC_buffers%north_t1(i,j,k) = 1.e24 enddo enddo enddo else allocate(nest_BC_buffers%north_t1(1,1,1)) - nest_BC_buffers%north_t1(1,1,1) = 0 + nest_BC_buffers%north_t1(1,1,1) = 1.e24 endif + + end subroutine init_nest_bc_type + + subroutine nested_grid_BC_recv_vector(nest_domain, npz, bd, nest_BC_u_buffers, nest_BC_v_buffers, nest_level, flags, gridtype) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(nest_domain_type), intent(INOUT) :: nest_domain + integer, intent(IN) :: npz + type(fv_nest_BC_type_3d), intent(INOUT), target :: nest_BC_u_buffers, nest_BC_v_buffers + integer, intent(IN) :: nest_level + integer, optional, intent(IN) :: flags, gridtype + + real, dimension(1,1,npz) :: u_coarse_dummy, v_coarse_dummy + + integer :: i,j, k + integer :: position_x, position_y + + call get_vector_position(position_x, position_y, gridtype) + + if (.not. allocated(nest_BC_u_buffers%west_t1) ) then + call init_nest_bc_type(nest_domain, nest_BC_u_buffers, npz, nest_level, position_x) + endif + if (.not. allocated(nest_BC_v_buffers%west_t1) ) then + call init_nest_bc_type(nest_domain, nest_BC_v_buffers, npz, nest_level, position_y) endif call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse_dummy, nest_domain, nest_BC_buffers%west_t1, nest_BC_buffers%south_t1, nest_BC_buffers%east_t1, nest_BC_buffers%north_t1, position=position) + call mpp_update_nest_fine(u_coarse_dummy, v_coarse_dummy, nest_domain, & + nest_BC_u_buffers%west_t1, nest_BC_v_buffers%west_t1, nest_BC_u_buffers%south_t1, nest_BC_v_buffers%south_t1, & + nest_BC_u_buffers%east_t1, nest_BC_v_buffers%east_t1, nest_BC_u_buffers%north_t1, nest_BC_v_buffers%north_t1, & + nest_level, flags, gridtype) call timing_off('COMM_TOTAL') - end subroutine nested_grid_BC_recv + end subroutine nested_grid_BC_recv_vector !>@brief The subroutine 'nested_grid_BC_save_proc' saves data received by 'nested_grid_BC_recv' !! into the datatype 'fv_nest_BC_type'. @@ -1502,7 +1989,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & !To do this more securely, instead of using is/etc we could use the fine-grid indices defined above if (is == 1 ) then -!$NO-MP parallel do default(none) shared(npz,isd,ied,jsd,jed,jstag,ind,var_west,wt,buf_west) private(ic,jc) +!$OMP parallel do default(none) shared(npz,isd,ied,jsd,jed,jstag,ind,var_west,wt,buf_west) private(ic,jc) do k=1,npz do j=jsd,jed+jstag do i=isd,0 @@ -1522,7 +2009,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & end do if (pd) then -!$NO-MP parallel do default(none) shared(npz,jsd,jed,jstag,isd,var_west,nest_BC) +!$OMP parallel do default(none) shared(npz,jsd,jed,jstag,isd,var_west,nest_BC) do k=1,npz do j=jsd,jed+jstag do i=isd,0 @@ -1549,7 +2036,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & iend = ied end if -!$NO-MP parallel do default(none) shared(npz,istart,iend,jsd,jed,istag,ind,var_south,wt,buf_south) private(ic,jc) +!$OMP parallel do default(none) shared(npz,istart,iend,jsd,jed,istag,ind,var_south,wt,buf_south) private(ic,jc) do k=1,npz do j=jsd,0 do i=istart,iend+istag @@ -1569,7 +2056,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & end do if (pd) then -!$NO-MP parallel do default(none) shared(npz,jsd,jed,istart,iend,istag,var_south,nest_BC) +!$OMP parallel do default(none) shared(npz,jsd,jed,istart,iend,istag,var_south,nest_BC) do k=1,npz do j=jsd,0 do i=istart,iend+istag @@ -1586,7 +2073,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & if (ie == npx-1 ) then -!$NO-MP parallel do default(none) shared(npx,npz,isd,ied,jsd,jed,istag,jstag,ind,var_east,wt,buf_east) private(ic,jc) +!$OMP parallel do default(none) shared(npx,npz,isd,ied,jsd,jed,istag,jstag,ind,var_east,wt,buf_east) private(ic,jc) do k=1,npz do j=jsd,jed+jstag do i=npx+istag,ied+istag @@ -1606,7 +2093,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & end do if (pd) then -!$NO-MP parallel do default(none) shared(npx,npz,jsd,jed,istag,jstag,ied,var_east,nest_BC) +!$OMP parallel do default(none) shared(npx,npz,jsd,jed,istag,jstag,ied,var_east,nest_BC) do k=1,npz do j=jsd,jed+jstag do i=npx+istag,ied+istag @@ -1634,7 +2121,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & iend = ied end if -!$NO-MP parallel do default(none) shared(npy,npz,istart,iend,jsd,jed,istag,jstag,ind,var_north,wt,buf_north) private(ic,jc) +!$OMP parallel do default(none) shared(npy,npz,istart,iend,jsd,jed,istag,jstag,ind,var_north,wt,buf_north) private(ic,jc) do k=1,npz do j=npy+jstag,jed+jstag do i=istart,iend+istag @@ -1654,7 +2141,7 @@ subroutine nested_grid_BC_save_proc(nest_domain, ind, wt, istag, jstag, & end do if (pd) then -!$NO-MP parallel do default(none) shared(npy,npz,jsd,jed,istart,iend,istag,jstag,ied,var_north,nest_BC) +!$OMP parallel do default(none) shared(npy,npz,jsd,jed,istart,iend,istag,jstag,ied,var_north,nest_BC) do k=1,npz do j=npy+jstag,jed+jstag do i=istart,iend+istag @@ -1712,6 +2199,7 @@ subroutine nested_grid_BC_apply_intT(var_nest, istag, jstag, & if (is == 1 ) then var_t0 => BC%west_t0 var_t1 => BC%west_t1 +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,isd,var_nest,var_t0,var_t1,split,step,denom) do k=1,npz do j=jsd,jed+jstag do i=isd,0 @@ -1738,6 +2226,7 @@ subroutine nested_grid_BC_apply_intT(var_nest, istag, jstag, & var_t0 => BC%south_t0 var_t1 => BC%south_t1 +!OMP parallel do default(none) shared(npz,jsd,istart,iend,istag,var_nest,var_t0,var_t1,split,step,denom) do k=1,npz do j=jsd,0 do i=istart,iend+istag @@ -1752,6 +2241,7 @@ subroutine nested_grid_BC_apply_intT(var_nest, istag, jstag, & if (ie == npx-1 ) then var_t0 => BC%east_t0 var_t1 => BC%east_t1 +!OMP parallel do default(none) shared(npz,jsd,jed,jstag,npx,isd,istag,var_nest,var_t0,var_t1,split,step,denom) do k=1,npz do j=jsd,jed+jstag do i=npx+istag,ied+istag @@ -1779,6 +2269,7 @@ subroutine nested_grid_BC_apply_intT(var_nest, istag, jstag, & var_t0 => BC%north_t0 var_t1 => BC%north_t1 +!OMP parallel do default(none) shared(npz,npy,jed,jstag,istart,iend,istag,var_nest,var_t0,var_t1,split,step,denom) do k=1,npz do j=npy+jstag,jed+jstag do i=istart,iend+istag @@ -1794,71 +2285,74 @@ subroutine nested_grid_BC_apply_intT(var_nest, istag, jstag, & end subroutine nested_grid_BC_apply_intT - subroutine update_coarse_grid_mpp_2d(var_coarse, var_nest, nest_domain, ind_update, dx, dy, area, & - isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, isu, ieu, jsu, jeu, npx, npy, & - istag, jstag, r, nestupdate, upoff, nsponge, parent_proc, child_proc, parent_grid) + subroutine update_coarse_grid_mpp_2d(var_coarse, var_nest, nest_domain, dx, dy, area, & + bd, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, isu, ieu, jsu, jeu, npx, npy, & + istag, jstag, r, nestupdate, upoff, nsponge, parent_proc, child_proc, parent_grid, nest_level) + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n integer, intent(IN) :: isu, ieu, jsu, jeu integer, intent(IN) :: istag, jstag, r, nestupdate, upoff, nsponge - integer, intent(IN) :: ind_update(isd_p:ied_p+1,jsd_p:jed_p+1,2) integer, intent(IN) :: npx, npy - real, intent(IN) :: var_nest(is_n:ie_n+istag,js_n:je_n+jstag) - real, intent(INOUT) :: var_coarse(isd_p:ied_p+istag,jsd_p:jed_p+jstag) - real, intent(IN) :: dx(isd:ied,jsd:jed+1) - real, intent(IN) :: dy(isd:ied+1,jsd:jed) - real, intent(IN) :: area(isd:ied,jsd:jed) + real, intent(IN), target :: var_nest(is_n:ie_n+istag,js_n:je_n+jstag) + real, intent(INOUT), target :: var_coarse(isd_p:ied_p+istag,jsd_p:jed_p+jstag) + real, intent(IN) :: dx(bd%isd:bd%ied, bd%jsd:bd%jed+1) + real, intent(IN) :: dy(bd%isd:bd%ied+1,bd%jsd:bd%jed) + real, intent(IN) :: area(bd%isd:bd%ied,bd%jsd:bd%jed) logical, intent(IN) :: parent_proc, child_proc - type(fv_atmos_type), intent(INOUT) :: parent_grid + type(fv_atmos_type), pointer, intent(IN) :: parent_grid type(nest_domain_type), intent(INOUT) :: nest_domain + integer, intent(IN) :: nest_level real :: var_nest_3d(is_n:ie_n+istag,js_n:je_n+jstag,1) real :: var_coarse_3d(isd_p:ied_p+istag,jsd_p:jed_p+jstag,1) + pointer(ptr_nest, var_nest_3d) + pointer(ptr_coarse, var_coarse_3d) - if (child_proc .and. size(var_nest) > 1) var_nest_3d(is_n:ie_n+istag,js_n:je_n+jstag,1) = var_nest(is_n:ie_n+istag,js_n:je_n+jstag) - if (parent_proc .and. size(var_coarse) > 1) var_coarse_3d(isd_p:ied_p+istag,jsd_p:jed_p,1) = var_coarse(isd_p:ied_p+istag,jsd_p:jed_p+jstag) - +! if (child_proc .and. size(var_nest) > 1) ptr_nest = LOC(var_nest) +! if (parent_proc .and. size(var_coarse) > 1) ptr_coarse = LOC(var_coarse) + ptr_nest = LOC(var_nest) + ptr_coarse = LOC(var_coarse) call update_coarse_grid_mpp(var_coarse_3d, var_nest_3d, & - nest_domain, ind_update, dx, dy, area, & - isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, & + nest_domain, dx, dy, area, & + bd, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, & isu, ieu, jsu, jeu, npx, npy, 1, & istag, jstag, r, nestupdate, upoff, nsponge, & - parent_proc, child_proc, parent_grid) - - if (size(var_coarse) > 1 .and. parent_proc) var_coarse(isd_p:ied_p+istag,jsd_p:jed_p+jstag) = var_coarse_3d(isd_p:ied_p+istag,jsd_p:jed_p,1) + parent_proc, child_proc, parent_grid, nest_level ) end subroutine update_coarse_grid_mpp_2d - subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, dx, dy, area, & - isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, & + subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, dx, dy, area, & + bd, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, & isu, ieu, jsu, jeu, npx, npy, npz, & istag, jstag, r, nestupdate, upoff, nsponge, & - parent_proc, child_proc, parent_grid) + parent_proc, child_proc, parent_grid, nest_level) !This routine assumes the coarse and nested grids are properly ! aligned, and that in particular for odd refinement ratios all ! coarse-grid cells (faces) coincide with nested-grid cells (faces) + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n integer, intent(IN) :: isu, ieu, jsu, jeu integer, intent(IN) :: istag, jstag, npx, npy, npz, r, nestupdate, upoff, nsponge - integer, intent(IN) :: ind_update(isd_p:ied_p+1,jsd_p:jed_p+1,2) real, intent(IN) :: var_nest(is_n:ie_n+istag,js_n:je_n+jstag,npz) real, intent(INOUT) :: var_coarse(isd_p:ied_p+istag,jsd_p:jed_p+jstag,npz) - real, intent(IN) :: area(isd:ied,jsd:jed) - real, intent(IN) :: dx(isd:ied,jsd:jed+1) - real, intent(IN) :: dy(isd:ied+1,jsd:jed) + real, intent(IN) :: area(bd%isd:bd%ied,bd%jsd:bd%jed) + real, intent(IN) :: dx(bd%isd:bd%ied,bd%jsd:bd%jed+1) + real, intent(IN) :: dy(bd%isd:bd%ied+1,bd%jsd:bd%jed) logical, intent(IN) :: parent_proc, child_proc - type(fv_atmos_type), intent(INOUT) :: parent_grid + type(fv_atmos_type), pointer, intent(IN) :: parent_grid type(nest_domain_type), intent(INOUT) :: nest_domain + integer, intent(IN) :: nest_level integer :: in, jn, ini, jnj, s, qr integer :: is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f integer :: istart, istop, jstart, jstop, ishift, jshift, j, i, k real :: val - real, allocatable, dimension(:,:,:) :: nest_dat - real :: var_nest_send(is_n:ie_n+istag,js_n:je_n+jstag,npz) + real, allocatable, dimension(:,:,:) :: coarse_dat_send + real, allocatable :: coarse_dat_recv(:,:,:) integer :: position if (istag == 1 .and. jstag == 1) then @@ -1871,28 +2365,82 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, position = CENTER end if - call mpp_get_F2C_index(nest_domain, is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f, position=position) - if (ie_f > is_f .and. je_f > js_f) then - allocate(nest_dat (is_f:ie_f, js_f:je_f,npz)) - else - allocate(nest_dat(1,1,1)) + !Note that *_c does not have values on the parent_proc. + !Must use isu, etc. to get bounds of update region on parent. + call mpp_get_F2C_index(nest_domain, is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f, nest_level=nest_level, position=position) + if (child_proc) then + allocate(coarse_dat_send(is_c:ie_c, js_c:je_c,npz)) + coarse_dat_send = -1200. endif - nest_dat = -600 + allocate(coarse_dat_recv(isd_p:ied_p+istag, jsd_p:jed_p+jstag, npz)) if (child_proc) then -!! IF an area average (for istag == jstag == 0) or a linear average then multiply in the areas before sending data + call fill_coarse_data_send(coarse_dat_send, var_nest, dx, dy, area, & + bd, is_c, ie_c, js_c, je_c, is_f, js_f, is_n, ie_n, js_n, je_n, & + npx, npy, npz, istag, jstag, r, nestupdate) + endif + + call timing_on('COMM_TOTAL') + call mpp_update_nest_coarse(field_in=coarse_dat_send, nest_domain=nest_domain, field_out=coarse_dat_recv, & + nest_level=nest_level, position=position) + + if (allocated(coarse_dat_send)) then + deallocate(coarse_dat_send) + end if + + call timing_off('COMM_TOTAL') + + s = r/2 !rounds down (since r > 0) + qr = r*upoff + nsponge - s + + if (parent_proc .and. .not. (ieu < isu .or. jeu < jsu)) then + call fill_var_coarse(var_coarse, coarse_dat_recv, isd_p, ied_p, jsd_p, jed_p, & + isu, ieu, jsu, jeu, npx, npy, npz, istag, jstag, nestupdate, parent_grid) + endif + + if (allocated(coarse_dat_recv)) deallocate(coarse_dat_recv) + + end subroutine update_coarse_grid_mpp + + subroutine fill_coarse_data_send(coarse_dat_send, var_nest, dx, dy, area, & + bd, is_c, ie_c, js_c, je_c, is_f, js_f, is_n, ie_n, js_n, je_n, & + npx, npy, npz, istag, jstag, r, nestupdate) + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: is_c, ie_c, js_c, je_c, is_n, ie_n, js_n, je_n + integer, intent(IN) :: is_f, js_f + integer, intent(IN) :: istag, jstag + integer, intent(IN) :: npx, npy, npz, r, nestupdate + real, intent(INOUT) :: coarse_dat_send(is_c:ie_c,js_c:je_c,npz) + real, intent(IN) :: var_nest(is_n:ie_n+istag,js_n:je_n+jstag,npz) + real, intent(IN) :: area(bd%isd:bd%ied,bd%jsd:bd%jed) + real, intent(IN) :: dx(bd%isd:bd%ied,bd%jsd:bd%jed+1) + real, intent(IN) :: dy(bd%isd:bd%ied+1,bd%jsd:bd%jed) + integer :: in, jn, ini, jnj, k, j, i + real :: val + + if (istag == 0 .and. jstag == 0) then select case (nestupdate) case (1,2,6,7,8) -!$NO-MP parallel do default(none) shared(npz,js_n,je_n,is_n,ie_n,var_nest_send,var_nest,area) +!$OMP parallel do default(none) shared(npz,js_c,je_c,is_c,ie_c,js_f,is_f,coarse_dat_send,var_nest,area,r) private(in,jn,val) do k=1,npz - do j=js_n,je_n - do i=is_n,ie_n + jn = js_f + do j=js_c,je_c + in = is_f + do i=is_c,ie_c - var_nest_send(i,j,k) = var_nest(i,j,k)*area(i,j) + val = 0. + do jnj=jn,jn+r-1 + do ini=in,in+r-1 + val = val + var_nest(ini,jnj,k)*area(ini,jnj) + end do + end do + coarse_dat_send(i,j,k) = val !divide area on coarse grid + in = in + r end do + jn = jn + r end do end do @@ -1902,15 +2450,22 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, select case (nestupdate) case (1,6,7,8) -!$NO-MP parallel do default(none) shared(npz,js_n,je_n,is_n,ie_n,var_nest_send,var_nest,dx) +!$OMP parallel do default(none) shared(npz,js_c,je_c,is_c,ie_c,js_f,is_f,coarse_dat_send,var_nest,dx,r) private(in,jn,val) do k=1,npz - do j=js_n,je_n+1 - do i=is_n,ie_n - + jn = js_f + do j=js_c,je_c!+1 + in = is_f + do i=is_c,ie_c - var_nest_send(i,j,k) = var_nest(i,j,k)*dx(i,j) + val = 0. + do ini=in,in+r-1 + val = val + var_nest(ini,jn,k)*dx(ini,jn) + end do + coarse_dat_send(i,j,k) = val + in = in + r end do + jn = jn + r end do end do @@ -1925,14 +2480,22 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, case (1,6,7,8) !averaging update; in-line average for face-averaged values instead of areal average -!$NO-MP parallel do default(none) shared(npz,js_n,je_n,is_n,ie_n,var_nest_send,var_nest,dy) +!$OMP parallel do default(none) shared(npz,js_c,je_c,is_c,ie_c,js_f,is_f,coarse_dat_send,var_nest,dy,r) private(in,jn,val) do k=1,npz - do j=js_n,je_n - do i=is_n,ie_n+1 + jn = js_f + do j=js_c,je_c + in = is_f + do i=is_c,ie_c!+1 - var_nest_send(i,j,k) = var_nest(i,j,k)*dy(i,j) + val = 0. + do jnj=jn,jn+r-1 + val = val + var_nest(in,jnj,k)*dy(in,jnj) + end do + coarse_dat_send(i,j,k) = val + in = in + r end do + jn = jn + r end do end do @@ -1946,50 +2509,38 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, call mpp_error(FATAL, "Cannot have both nonzero istag and jstag.") - endif endif - call timing_on('COMM_TOTAL') - call mpp_update_nest_coarse(var_nest_send, nest_domain, nest_dat, position=position) - call timing_off('COMM_TOTAL') - s = r/2 !rounds down (since r > 0) - qr = r*upoff + nsponge - s + end subroutine fill_coarse_data_send + + subroutine fill_var_coarse(var_coarse, coarse_dat_recv, isd_p, ied_p, jsd_p, jed_p, & + isu, ieu, jsu, jeu, npx, npy, npz, istag, jstag, nestupdate, parent_grid) + + !This routine assumes the coarse and nested grids are properly + ! aligned, and that in particular for odd refinement ratios all + ! coarse-grid cells (faces) coincide with nested-grid cells (faces) + + integer, intent(IN) :: isd_p, ied_p, jsd_p, jed_p + integer, intent(IN) :: isu, ieu, jsu, jeu + integer, intent(IN) :: istag, jstag + integer, intent(IN) :: npx, npy, npz, nestupdate + real, intent(INOUT) :: var_coarse(isd_p:ied_p+istag,jsd_p:jed_p+jstag,npz) + real, intent(INOUT) :: coarse_dat_recv(isd_p:ied_p+istag,jsd_p:jed_p+jstag,npz) + type(fv_atmos_type), intent(IN) :: parent_grid + + integer :: i, j, k - if (parent_proc .and. .not. (ieu < isu .or. jeu < jsu)) then if (istag == 0 .and. jstag == 0) then select case (nestupdate) case (1,2,6,7,8) ! 1 = Conserving update on all variables; 2 = conserving update for cell-centered values; 6 = conserving remap-update -!$NO-MP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,ind_update,nest_dat,parent_grid,var_coarse,r) & -!$NO-MP private(in,jn,val) +!$OMP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,coarse_dat_recv,parent_grid,var_coarse) do k=1,npz do j=jsu,jeu do i=isu,ieu - - in = ind_update(i,j,1) - jn = ind_update(i,j,2) - -!!$ if (in < max(1+qr,is_f) .or. in > min(npx-1-qr-r+1,ie_f) .or. & -!!$ jn < max(1+qr,js_f) .or. jn > min(npy-1-qr-r+1,je_f)) then -!!$ write(mpp_pe()+3000,'(A, 14I6)') 'SKIP: ', i, j, in, jn, 1+qr, is_f, ie_f, js_f, je_f, npy-1-qr-r+1, isu, ieu, jsu, jeu -!!$ cycle -!!$ endif - - val = 0. - do jnj=jn,jn+r-1 - do ini=in,in+r-1 - val = val + nest_dat(ini,jnj,k) - end do - end do - - !var_coarse(i,j,k) = val/r**2. - - !!! CLEANUP: Couldn't rarea and rdx and rdy be built into the weight arrays? - !!! Two-way updates do not yet have weights, tho - var_coarse(i,j,k) = val*parent_grid%gridstruct%rarea(i,j) - + var_coarse(i,j,k) = coarse_dat_recv(i,j,k)*parent_grid%gridstruct%rarea(i,j) end do end do end do @@ -2008,29 +2559,11 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, select case (nestupdate) case (1,6,7,8) -!$NO-MP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,ind_update,nest_dat,parent_grid,var_coarse,r) & -!$NO-MP private(in,jn,val) +!$OMP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,coarse_dat_recv,parent_grid,var_coarse) do k=1,npz do j=jsu,jeu+1 do i=isu,ieu - - in = ind_update(i,j,1) - jn = ind_update(i,j,2) - -!!$ if (in < max(1+qr,is_f) .or. in > min(npx-1-qr-r+1,ie_f) .or. & -!!$ jn < max(1+qr+s,js_f) .or. jn > min(npy-1-qr-s+1,je_f)) then -!!$ write(mpp_pe()+3000,'(A, 14I)') 'SKIP u: ', i, j, in, jn, 1+qr, is_f, ie_f, js_f, je_f, npy-1-qr-s+1, isu, ieu, jsu, jeu -!!$ cycle -!!$ endif - - val = 0. - do ini=in,in+r-1 - val = val + nest_dat(ini,jn,k) - end do - -! var_coarse(i,j,k) = val/r - var_coarse(i,j,k) = val*parent_grid%gridstruct%rdx(i,j) - + var_coarse(i,j,k) = coarse_dat_recv(i,j,k)*parent_grid%gridstruct%rdx(i,j) end do end do end do @@ -2046,29 +2579,11 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, select case (nestupdate) case (1,6,7,8) !averaging update; in-line average for face-averaged values instead of areal average -!$NO-MP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,ind_update,nest_dat,parent_grid,var_coarse,r) & -!$NO-MP private(in,jn,val) +!$OMP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,coarse_dat_recv,parent_grid,var_coarse) do k=1,npz do j=jsu,jeu do i=isu,ieu+1 - - in = ind_update(i,j,1) - jn = ind_update(i,j,2) - -!!$ if (in < max(1+qr+s,is_f) .or. in > min(npx-1-qr-s+1,ie_f) .or. & -!!$ jn < max(1+qr,js_f) .or. jn > min(npy-1-qr-r+1,je_f)) then -!!$ write(mpp_pe()+3000,'(A, 14I6)') 'SKIP v: ', i, j, in, jn, 1+qr, is_f, ie_f, js_f, je_f, npx-1-qr-s+1, isu, ieu, jsu, jeu -!!$ cycle -!!$ endif - - val = 0. - do jnj=jn,jn+r-1 - val = val + nest_dat(in,jnj,k) - end do - -! var_coarse(i,j,k) = val/r - var_coarse(i,j,k) = val*parent_grid%gridstruct%rdy(i,j) - + var_coarse(i,j,k) = coarse_dat_recv(i,j,k)*parent_grid%gridstruct%rdy(i,j) end do end do end do @@ -2082,11 +2597,93 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, end if + end subroutine fill_var_coarse + + subroutine update_coarse_grid_mpp_vector(u_coarse, v_coarse, u_nest, v_nest, nest_domain, dx, dy, area, & + bd, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, & + isu, ieu, jsu, jeu, npx, npy, npz, istag_u, jstag_u, istag_v, jstag_v, & + r, nestupdate, upoff, nsponge, & + parent_proc, child_proc, parent_grid, nest_level, flags, gridtype) + + !This routine assumes the coarse and nested grids are properly + ! aligned, and that in particular for odd refinement ratios all + ! coarse-grid cells (faces) coincide with nested-grid cells (faces) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n + integer, intent(IN) :: isu, ieu, jsu, jeu + integer, intent(IN) :: istag_u, jstag_u, istag_v, jstag_v + integer, intent(IN) :: npx, npy, npz, r, nestupdate, upoff, nsponge + real, intent(IN) :: u_nest(is_n:ie_n+istag_u,js_n:je_n+jstag_u,npz) + real, intent(INOUT) :: u_coarse(isd_p:ied_p+istag_u,jsd_p:jed_p+jstag_u,npz) + real, intent(IN) :: v_nest(is_n:ie_n+istag_v,js_n:je_n+jstag_v,npz) + real, intent(INOUT) :: v_coarse(isd_p:ied_p+istag_v,jsd_p:jed_p+jstag_v,npz) + real, intent(IN) :: area(bd%isd:bd%ied,bd%jsd:bd%jed) + real, intent(IN) :: dx(bd%isd:bd%ied,bd%jsd:bd%jed+1) + real, intent(IN) :: dy(bd%isd:bd%ied+1,bd%jsd:bd%jed) + logical, intent(IN) :: parent_proc, child_proc + type(fv_atmos_type), intent(INOUT) :: parent_grid + integer, intent(IN) :: nest_level + type(nest_domain_type), intent(INOUT) :: nest_domain + integer, optional, intent(IN) :: flags, gridtype + + integer :: s, qr + integer :: is_cx, ie_cx, js_cx, je_cx, is_fx, ie_fx, js_fx, je_fx + integer :: is_cy, ie_cy, js_cy, je_cy, is_fy, ie_fy, js_fy, je_fy + integer :: istart, istop, jstart, jstop, ishift, jshift, j, i, k + real :: val + real, allocatable, dimension(:,:,:) :: coarse_dat_send_u, coarse_dat_send_v + real, allocatable :: coarse_dat_recv_u(:,:,:), coarse_dat_recv_v(:,:,:) + integer :: position_x, position_y + + call get_vector_position(position_x, position_y, gridtype) + + call mpp_get_F2C_index(nest_domain, is_cx, ie_cx, js_cx, je_cx, is_fx, ie_fx, js_fx, je_fx, & + nest_level=nest_level, position=position_x) + call mpp_get_F2C_index(nest_domain, is_cy, ie_cy, js_cy, je_cy, is_fy, ie_fy, js_fy, je_fy, & + nest_level=nest_level, position=position_y) + if (child_proc) then + allocate(coarse_dat_send_u(is_cx:ie_cx, js_cx:je_cx,npz)) + allocate(coarse_dat_send_v(is_cy:ie_cy, js_cy:je_cy,npz)) + coarse_dat_send_u = -1200. + coarse_dat_send_v = -1200. endif - deallocate(nest_dat) - - end subroutine update_coarse_grid_mpp + allocate(coarse_dat_recv_u(isd_p:ied_p+istag_u, jsd_p:jed_p+jstag_u, npz)) + allocate(coarse_dat_recv_v(isd_p:ied_p+istag_v, jsd_p:jed_p+jstag_v, npz)) + + if (child_proc) then + call fill_coarse_data_send(coarse_dat_send_u, u_nest, dx, dy, area, & + bd, is_cx, ie_cx, js_cx, je_cx, is_fx, js_fx, is_n, ie_n, js_n, je_n, & + npx, npy, npz, istag_u, jstag_u, r, nestupdate) + call fill_coarse_data_send(coarse_dat_send_v, v_nest, dx, dy, area, & + bd, is_cy, ie_cy, js_cy, je_cy, is_fy, js_fy, is_n, ie_n, js_n, je_n, & + npx, npy, npz, istag_v, jstag_v, r, nestupdate) + endif + + call timing_on('COMM_TOTAL') + call mpp_update_nest_coarse(coarse_dat_send_u, coarse_dat_send_v, nest_domain, coarse_dat_recv_u, & + coarse_dat_recv_v, nest_level, flags, gridtype) + if (allocated(coarse_dat_send_u)) deallocate(coarse_dat_send_u) + if (allocated(coarse_dat_send_v)) deallocate(coarse_dat_send_v) + call timing_off('COMM_TOTAL') + + s = r/2 !rounds down (since r > 0) + qr = r*upoff + nsponge - s + + if (parent_proc .and. .not. (ieu < isu .or. jeu < jsu)) then + call fill_var_coarse(u_coarse, coarse_dat_recv_u, isd_p, ied_p, jsd_p, jed_p, & + isu, ieu, jsu, jeu, npx, npy, npz, istag_u, jstag_u, nestupdate, parent_grid) + endif + if (parent_proc .and. .not. (ieu < isu .or. jeu < jsu)) then + call fill_var_coarse(v_coarse, coarse_dat_recv_v, isd_p, ied_p, jsd_p, jed_p, & + isu, ieu, jsu, jeu, npx, npy, npz, istag_v, jstag_v, nestupdate, parent_grid) + endif + + if (allocated(coarse_dat_recv_u)) deallocate(coarse_dat_recv_u) + if (allocated(coarse_dat_recv_v)) deallocate(coarse_dat_recv_v) + + end subroutine update_coarse_grid_mpp_vector end module boundary_mod diff --git a/model/dyn_core.F90 b/model/dyn_core.F90 index 763654714..6923b2030 100644 --- a/model/dyn_core.F90 +++ b/model/dyn_core.F90 @@ -114,12 +114,12 @@ module dyn_core_mod use fv_mp_mod, only: group_halo_update_type use sw_core_mod, only: c_sw, d_sw use a2b_edge_mod, only: a2b_ord2, a2b_ord4 - use nh_core_mod, only: Riem_Solver3, Riem_Solver_C, update_dz_c, update_dz_d, nest_halo_nh + use nh_core_mod, only: Riem_Solver3, Riem_Solver_C, update_dz_c, update_dz_d, nh_bc use tp_core_mod, only: copy_corners use fv_timing_mod, only: timing_on, timing_off use fv_diagnostics_mod, only: prt_maxmin, fv_time, prt_mxm #ifdef ROT3 - use fv_update_phys_mod, only: update_dwinds_phys + use fv_grid_utils_mod, only: update_dwinds_phys #endif #if defined (ADA_NUDGE) use fv_ada_nudge_mod, only: breed_slp_inline_ada @@ -128,11 +128,12 @@ module dyn_core_mod #endif use diag_manager_mod, only: send_data use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_diag_type, & - fv_grid_bounds_type, R_GRID + fv_grid_bounds_type, R_GRID, fv_nest_BC_type_3d use boundary_mod, only: extrapolation_BC, nested_grid_BC_apply_intT use fv_regional_mod, only: regional_boundary_update - use fv_regional_mod, only: current_time_in_seconds + use fv_regional_mod, only: current_time_in_seconds, bc_time_interval + use fv_regional_mod, only: delz_regBC ! TEMPORARY --- lmh #ifdef SW_DYNAMICS use test_cases_mod, only: test_case, case9_forcing1, case9_forcing2 @@ -168,7 +169,7 @@ module dyn_core_mod ! dyn_core :: FV Lagrangian dynamics driver !----------------------------------------------------------------------- - subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, cappa, & + subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_map, n_split, zvir, cp, akap, cappa, & #ifdef MULTI_GASES kapad, & #endif @@ -182,7 +183,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, integer, intent(IN) :: npy integer, intent(IN) :: npz integer, intent(IN) :: ng, nq, sphum - integer, intent(IN) :: n_split + integer, intent(IN) :: n_map, n_split real , intent(IN) :: bdt real , intent(IN) :: zvir, cp, akap, grav real , intent(IN) :: ptop @@ -196,7 +197,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, real, intent(inout), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz):: u !< D grid zonal wind (m/s) real, intent(inout), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz):: v !< D grid meridional wind (m/s) real, intent(inout) :: w( bd%isd:,bd%jsd:,1:) !< vertical vel. (m/s) - real, intent(inout) :: delz(bd%isd:,bd%jsd:,1:) !< delta-height (m, negative) + real, intent(inout) :: delz(bd%is:,bd%js:,1:) !< delta-height (m, negative) real, intent(inout) :: cappa(bd%isd:,bd%jsd:,1:) !< moist kappa #ifdef MULTI_GASES real, intent(inout) :: kapad(bd%isd:bd%ied,bd%jsd:bd%jed,1:npz) !< multi_gases kappa @@ -364,10 +365,10 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, allocate( dv(isd:ied+1,jsd:jed, npz) ) call init_ijk_mem(isd,ied+1, jsd,jed , npz, dv, 0.) endif -!$OMP parallel do default(none) shared(is,ie,js,je,npz,diss_est) +!$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,diss_est) do k=1,npz - do j=js,je - do i=is,ie + do j=jsd,jed + do i=isd,ied diss_est(i,j,k) = 0. enddo enddo @@ -415,7 +416,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, if ( flagstruct%fv_debug ) then if(is_master()) write(*,*) 'n_split loop, it=', it if ( .not. flagstruct%hydrostatic ) & - call prt_mxm('delz', delz, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) + call prt_mxm('delz', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) endif if (gridstruct%nested) then @@ -440,31 +441,38 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, call timing_off('COMM_TOTAL') if ( it==1 ) then - if (gridstruct%nested .or. gridstruct%regional) then -!$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,gz,zs,delz) - do j=jsd,jed + if (gridstruct%bounded_domain) then +!$OMP parallel do default(none) shared(isd,ied,jsd,jed,gz,zs,npz) + do j=jsd,jed do i=isd,ied gz(i,j,npz+1) = zs(i,j) enddo - do k=npz,1,-1 - do i=isd,ied - gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k) - enddo enddo - enddo + if (gridstruct%nested) then + call gz_bc(gz,neststruct%delz_BC,bd,npx,npy,npz,split_timestep_BC, real(n_split*flagstruct%k_split)) + endif + if (gridstruct%regional) then + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(it-1)*dt + if (is_master() .and. flagstruct%fv_debug) print*, ' REG_BC_UPDATE_TIME: ', it, current_time_in_seconds+bdt*(n_map-1)+(it-1)*dt + call gz_bc(gz, delz_regBC,bd,npx,npy,npz,mod(reg_bc_update_time,bc_time_interval*3600.), bc_time_interval*3600.) + endif else -!$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zs,delz) - do j=js,je +!$OMP parallel do default(none) shared(is,ie,js,je,gz,zs,npz) + do j=js,je do i=is,ie gz(i,j,npz+1) = zs(i,j) enddo + enddo + endif + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,delz) + do j=js,je do k=npz,1,-1 do i=is,ie gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k) enddo enddo enddo - endif call timing_on('COMM_TOTAL') call start_group_halo_update(i_pack(5), gz, domain) call timing_off('COMM_TOTAL') @@ -472,6 +480,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, endif + #ifdef SW_DYNAMICS if (test_case>1) then #ifdef USE_OLD @@ -546,7 +555,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, endif if (flagstruct%regional) then - reg_bc_update_time=current_time_in_seconds+(0.5+(it-1))*dt + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(0.5+(it-1))*dt call regional_boundary_update(delpc, 'delp', & isd, ied, jsd, jed, npz, & is, ie, js, je, & @@ -567,7 +576,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, kapad, & #endif q_con, pkz, npz, akap, .true., & - gridstruct%nested, .false., npx, npy, flagstruct%a2b_ord, bd) + gridstruct%bounded_domain, .false., npx, npy, flagstruct%a2b_ord, bd) else #ifndef SW_DYNAMICS if ( it == 1 ) then @@ -587,6 +596,18 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, enddo else + + if (gridstruct%bounded_domain) then + if (gridstruct%nested) then + call gz_bc(gz,neststruct%delz_BC,bd,npx,npy,npz,split_timestep_BC, real(n_split*flagstruct%k_split)) + endif + if (gridstruct%regional) then + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(it-1)*dt + if (is_master() .and. flagstruct%fv_debug) print*, ' REG_BC_UPDATE_TIME: ', it, current_time_in_seconds+bdt*(n_map-1)+(it-1)*dt + call gz_bc(gz, delz_regBC,bd,npx,npy,npz,mod(reg_bc_update_time,bc_time_interval*3600.), bc_time_interval*3600.) + endif + endif + !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz) do k=1, npz+1 do j=jsd,jed @@ -595,6 +616,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, enddo enddo enddo + endif call timing_on('UPDATE_DZ_C') call update_dz_c(is, ie, js, je, npz, ng, dt2, dp_ref, zs, gridstruct%area, ut, vt, gz, ws3, & @@ -614,26 +636,25 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, call timing_off('Riem_Solver') if (gridstruct%nested) then - call nested_grid_BC_apply_intT(delz, & - 0, 0, npx, npy, npz, bd, split_timestep_BC+0.5, real(n_split*flagstruct%k_split), & - neststruct%delz_BC, bctype=neststruct%nestbctype ) + call nh_bc(ptop, grav, akap, cp, delpc, neststruct%delz_BC, ptc, phis, & +#ifdef MULTI_GASES + q, & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + split_timestep_BC+0.5, real(n_split*flagstruct%k_split), & + npx, npy, npz, gridstruct%bounded_domain, .false., .false., .false., bd) endif if (flagstruct%regional) then - reg_bc_update_time=current_time_in_seconds+(0.5+(it-1))*dt - call regional_boundary_update(delz, 'delz', & - isd, ied, jsd, jed, ubound(delz,3), & - is, ie, js, je, & - isd, ied, jsd, jed, & - reg_bc_update_time ) - endif - if (gridstruct%nested .or. flagstruct%regional) then - !Compute gz/pkc - !NOTE: nominally only need to compute quantities one out in the halo for p_grad_c - !(instead of entire halo) - - call nest_halo_nh(ptop, grav, akap, cp, delpc, delz, ptc, phis, & + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(0.5+(it-1))*dt + call nh_bc(ptop, grav, akap, cp, delpc, delz_regBC, ptc, phis, & #ifdef MULTI_GASES q, & #endif @@ -644,8 +665,11 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, #endif #endif pkc, gz, pk3, & - npx, npy, npz, gridstruct%nested, .false., .false., .false., bd, flagstruct%regional) + mod(reg_bc_update_time,bc_time_interval*3600.), bc_time_interval*3600., & + npx, npy, npz, gridstruct%bounded_domain, .false., .false., .false., bd) + endif + #endif SW_DYNAMICS endif ! end hydro check @@ -695,9 +719,10 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, if (flagstruct%regional) then - call exch_uv(domain, bd, npz, vc, uc) + !call exch_uv(domain, bd, npz, vc, uc) + call mpp_update_domains(uc, vc, domain, gridtype=CGRID_NE) - reg_bc_update_time=current_time_in_seconds+(0.5+(it-1))*dt + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(0.5+(it-1))*dt call regional_boundary_update(vc, 'vc', & isd, ied, jsd, jed+1, npz, & is, ie, js, je, & @@ -708,8 +733,9 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, is, ie, js, je, & isd, ied, jsd, jed, & reg_bc_update_time ) + call mpp_update_domains(uc, vc, domain, gridtype=CGRID_NE) !!! Currently divgd is always 0.0 in the regional domain boundary area. - reg_bc_update_time=current_time_in_seconds+(it-1)*dt + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(it-1)*dt call regional_boundary_update(divgd, 'divgd', & isd, ied+1, jsd, jed+1, npz, & is, ie, js, je, & @@ -725,9 +751,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, neststruct%q_BC(iq), bctype=neststruct%nestbctype ) end do endif - if (flagstruct%regional) then - reg_bc_update_time=current_time_in_seconds+(it-1)*dt + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(it-1)*dt do iq=1,nq call regional_boundary_update(q(:,:,:,iq), 'q', & isd, ied, jsd, jed, npz, & @@ -739,8 +764,6 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, endif - if (flagstruct%regional) call exch_uv(domain, bd, npz, vc, uc) - if (first_call .and. is_master() .and. last_step) write(6,*) 'Sponge layer divergence damping coefficent:' call timing_on('d_sw') !$OMP parallel do default(none) shared(npz,flagstruct,nord_v,pfull,damp_vt,hydrostatic,last_step, & @@ -900,8 +923,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, enddo ! end openMP k-loop if (flagstruct%regional) then - call exch_uv(domain, bd, npz, vc, uc) - call exch_uv(domain, bd, npz, u, v ) + call mpp_update_domains(uc, vc, domain, gridtype=CGRID_NE) + call mpp_update_domains(u , v , domain, gridtype=DGRID_NE) endif call timing_off('d_sw') @@ -945,7 +968,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, call timing_off('COMM_TOTAL') if ( flagstruct%fv_debug ) then if ( .not. flagstruct%hydrostatic ) & - call prt_mxm('delz', delz, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) + call prt_mxm('delz', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) endif !Want to move this block into the hydro/nonhydro branch above and merge the two if structures @@ -971,7 +994,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, end if if (flagstruct%regional) then - reg_bc_update_time=current_time_in_seconds+bdt+(it-1)*dt + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+(it-1)*dt call regional_boundary_update(delp, 'delp', & isd, ied, jsd, jed, npz, & is, ie, js, je, & @@ -1001,17 +1024,16 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, kapad, & #endif q_con, pkz, npz, akap, .false., & - gridstruct%nested, .true., npx, npy, flagstruct%a2b_ord, bd) + gridstruct%bounded_domain, .true., npx, npy, flagstruct%a2b_ord, bd) else #ifndef SW_DYNAMICS call timing_on('UPDATE_DZ') call update_dz_d(nord_v, damp_vt, flagstruct%hord_tm, is, ie, js, je, npz, ng, npx, npy, gridstruct%area, & - gridstruct%rarea, dp_ref, zs, zh, crx, cry, xfx, yfx, delz, ws, rdt, gridstruct, bd, flagstruct%lim_fac, & - flagstruct%regional) - call timing_off('UPDATE_DZ') + gridstruct%rarea, dp_ref, zs, zh, crx, cry, xfx, yfx, ws, rdt, gridstruct, bd, flagstruct%lim_fac) + call timing_off('UPDATE_DZ') if ( flagstruct%fv_debug ) then if ( .not. flagstruct%hydrostatic ) & - call prt_mxm('delz updated', delz, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) + call prt_mxm('delz updated', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) endif if (idiag%id_ws>0 .and. last_step) then @@ -1049,25 +1071,26 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, else call pk3_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, akap, pk3, delp) endif - if (gridstruct%nested) then - call nested_grid_BC_apply_intT(delz, & - 0, 0, npx, npy, npz, bd, split_timestep_BC+1., real(n_split*flagstruct%k_split), & - neststruct%delz_BC, bctype=neststruct%nestbctype ) - endif - if (flagstruct%regional) then - reg_bc_update_time=current_time_in_seconds+it*dt - call regional_boundary_update(delz, 'delz', & - isd, ied, jsd, jed, ubound(delz,3), & - is, ie, js, je, & - isd, ied, jsd, jed, & - reg_bc_update_time ) - endif - - if (gridstruct%nested .or. flagstruct%regional) then - !Compute gz/pkc/pk3; note that now pkc should be nonhydro pert'n pressure - - call nest_halo_nh(ptop, grav, akap, cp, delp, delz, pt, phis, & + if (gridstruct%nested) then + call nh_bc(ptop, grav, akap, cp, delp, neststruct%delz_BC, pt, phis, & +#ifdef MULTI_GASES + q, & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + split_timestep_BC+1., real(n_split*flagstruct%k_split), & + npx, npy, npz, gridstruct%bounded_domain, .true., .true., .true., bd) + endif + + if (flagstruct%regional) then + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+it*dt + call nh_bc(ptop, grav, akap, cp, delp, delz_regBC, pt, phis, & #ifdef MULTI_GASES q, & #endif @@ -1077,7 +1100,10 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, cappa, & #endif #endif - pkc, gz, pk3, npx, npy, npz, gridstruct%nested, .true., .true., .true., bd, flagstruct%regional) + pkc, gz, pk3, & + mod(reg_bc_update_time,bc_time_interval*3600.), bc_time_interval*3600., & + npx, npy, npz, gridstruct%bounded_domain, .true., .true., .true., bd) + endif call timing_on('COMM_TOTAL') @@ -1195,7 +1221,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, !------------------------------------------------------------------------------------------------------- call timing_on('COMM_TOTAL') - if( it==n_split .and. gridstruct%grid_type<4 .and. .not. (gridstruct%nested .or. gridstruct%regional)) then + if( it==n_split .and. gridstruct%grid_type<4 .and. .not. gridstruct%bounded_domain) then ! Prevent accumulation of rounding errors at overlapped domain edges: call mpp_get_boundary(u, v, domain, ebuffery=ebuffer, & nbufferx=nbuffer, gridtype=DGRID_NE ) @@ -1296,7 +1322,7 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, #ifndef SW_DYNAMICS if (.not. hydrostatic) then - reg_bc_update_time=current_time_in_seconds+it*dt + reg_bc_update_time=current_time_in_seconds+bdt*(n_map-1)+it*dt call regional_boundary_update(w, 'w', & isd, ied, jsd, jed, ubound(w,3), & is, ie, js, je, & @@ -1316,8 +1342,8 @@ subroutine dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, isd, ied, jsd, jed, & reg_bc_update_time ) - call exch_uv(domain, bd, npz, u, v ) - endif + call mpp_update_domains(u, v, domain, gridtype=DGRID_NE) + end if !----------------------------------------------------- enddo ! time split loop @@ -2243,7 +2269,7 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, & #ifdef MULTI_GASES kapad, & #endif - q_con, pkz, km, akap, CG, nested, computehalo, npx, npy, a2b_ord, bd) + q_con, pkz, km, akap, CG, bounded_domain, computehalo, npx, npy, a2b_ord, bd) integer, intent(IN) :: km, npx, npy, a2b_ord real , intent(IN) :: akap, ptop @@ -2254,7 +2280,7 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, & real, intent(IN) :: kapad(bd%isd:bd%ied,bd%jsd:bd%jed,km) #endif real, intent(IN), dimension(bd%isd:,bd%jsd:,1:):: q_con - logical, intent(IN) :: CG, nested, computehalo + logical, intent(IN) :: CG, bounded_domain, computehalo ! !OUTPUT PARAMETERS real, intent(OUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,km+1):: gz, pk real, intent(OUT) :: pe(bd%is-1:bd%ie+1,km+1,bd%js-1:bd%je+1) @@ -2289,7 +2315,7 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, & jsd = bd%jsd jed = bd%jed - if ( (.not. CG .and. a2b_ord==4) .or. (nested .and. .not. CG) ) then ! D-Grid + if ( (.not. CG .and. a2b_ord==4) .or. (bounded_domain .and. .not. CG) ) then ! D-Grid ifirst = is-2; ilast = ie+2 jfirst = js-2; jlast = je+2 else @@ -2297,7 +2323,7 @@ subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, & jfirst = js-1; jlast = je+1 endif - if (nested .and. computehalo) then + if (bounded_domain .and. computehalo) then if (is == 1) ifirst = isd if (ie == npx-1) ilast = ied if (js == 1) jfirst = jsd @@ -2494,7 +2520,7 @@ subroutine del2_cubed(q, cd, gridstruct, domain, npx, npy, km, nmax, bd) q(1,npy,k) = q(1,je,k) endif - if(nt>0 .and. (.not. gridstruct%regional)) call copy_corners(q(isd,jsd,k), npx, npy, 1, gridstruct%nested, bd, & + if(nt>0 .and. (.not. gridstruct%bounded_domain)) call copy_corners(q(isd,jsd,k), npx, npy, 1, gridstruct%bounded_domain, bd, & gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner ) do j=js-nt,je+nt do i=is-nt,ie+1+nt @@ -2506,7 +2532,7 @@ subroutine del2_cubed(q, cd, gridstruct, domain, npx, npy, km, nmax, bd) enddo enddo - if(nt>0 .and. (.not. gridstruct%regional)) call copy_corners(q(isd,jsd,k), npx, npy, 2, gridstruct%nested, bd, & + if(nt>0 .and. (.not. gridstruct%bounded_domain)) call copy_corners(q(isd,jsd,k), npx, npy, 2, gridstruct%bounded_domain, bd, & gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) do j=js-nt,je+1+nt do i=is-nt,ie+nt @@ -2664,5 +2690,92 @@ subroutine Ray_fast(dt, npx, npy, npz, pfull, tau, u, v, w, & end subroutine Ray_fast + subroutine gz_bc(gz,delzBC,bd,npx,npy,npz,step,split) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npx, npy, npz + real, intent(INOUT) :: gz(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1) + type(fv_nest_BC_type_3d), intent(IN) :: delzBC + real, intent(IN) :: step, split + + real :: a1, a2 + integer i, j, k + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + integer :: istart, iend + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + a1 = (split-step)/split + a2 = step/split + + if (is == 1) then +!$OMP parallel do default(none) shared(jsd,jed,npz,isd,delzBC,gz,a1,a2) + do j=jsd,jed + do k=npz,1,-1 + do i=isd,0 + gz(i,j,k) = gz(i,j,k+1) - (delzBC%west_t1(i,j,k)*a2 + delzBC%west_t0(i,j,k)*a1) + enddo + enddo + enddo + endif + + if (ie == npx-1) then +!$OMP parallel do default(none) shared(jsd,jed,npz,npx,ied,delzBC,gz,a1,a2) + do j=jsd,jed + do k=npz,1,-1 + do i=npx,ied + gz(i,j,k) = gz(i,j,k+1) - (delzBC%east_t1(i,j,k)*a2 + delzBC%east_t0(i,j,k)*a1) + enddo + enddo + enddo + endif + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then +!$OMP parallel do default(none) shared(jsd,npz,istart,iend,delzBC,gz,a1,a2) + do j=jsd,0 + do k=npz,1,-1 + do i=istart,iend + gz(i,j,k) = gz(i,j,k+1) - (delzBC%south_t1(i,j,k)*a2 + delzBC%south_t0(i,j,k)*a1) + !if (gz(i,j,k) <= gz(i,j,k+1) .or. abs(gz(i,j,k)) > 1.e6) print*, ' BAD GZ (bc): ', i, j, k, gz(i,j,k:k+1), delzBC%west_t1(i,j,k), delzBC%west_t0(i,j,k) + enddo + enddo + enddo + endif + + if (je == npy-1) then +!$OMP parallel do default(none) shared(npy,jed,npz,istart,iend,delzBC,gz,a1,a2) + do j=npy,jed + do k=npz,1,-1 + do i=istart,iend + gz(i,j,k) = gz(i,j,k+1) - (delzBC%north_t1(i,j,k)*a2 + delzBC%north_t0(i,j,k)*a1) + !if (gz(i,j,k) <= gz(i,j,k+1) .or. abs(gz(i,j,k)) > 1.e6) print*, ' BAD GZ (bc): ', i, j, k, gz(i,j,k:k+1), delzBC%west_t1(i,j,k), delzBC%west_t0(i,j,k) + enddo + enddo + enddo + endif + + end subroutine gz_bc + end module dyn_core_mod diff --git a/model/fv_arrays.F90 b/model/fv_arrays.F90 index 1e7c6a686..b00185d08 100644 --- a/model/fv_arrays.F90 +++ b/model/fv_arrays.F90 @@ -27,7 +27,6 @@ module fv_arrays_mod use fms_io_mod, only: restart_file_type use time_manager_mod, only: time_type use horiz_interp_type_mod, only: horiz_interp_type - use mpp_domains_mod, only: nest_domain_type use mpp_mod, only: mpp_broadcast use platform_mod, only: r8_kind public @@ -44,12 +43,9 @@ module fv_arrays_mod !--- MAY NEED TO TEST THIS #ifdef OVERLOAD_R4 real, parameter:: real_big = 1.e8 ! big enough to cause blowup if used - real, parameter:: real_snan=x'FFBFFFFF' #else real, parameter:: real_big = 1.e30 ! big enough to cause blowup if used - real, parameter:: real_snan=x'FFF7FFFFFFFFFFFF' #endif - real, parameter:: i4_in=-huge(1) type fv_diag_type @@ -86,7 +82,7 @@ module fv_arrays_mod integer :: id_rh1000_cmip, id_rh925_cmip, id_rh850_cmip, id_rh700_cmip, id_rh500_cmip, & id_rh300_cmip, id_rh250_cmip, id_rh100_cmip, id_rh50_cmip, id_rh10_cmip - integer :: id_hght + integer :: id_hght3d, id_any_hght integer :: id_u100m, id_v100m, id_w100m ! For initial conditions: @@ -103,6 +99,13 @@ module fv_arrays_mod real, allocatable :: zxg(:,:) real, allocatable :: pt1(:) + integer :: id_prer, id_prei, id_pres, id_preg + integer :: id_qv_dt_gfdlmp, id_T_dt_gfdlmp, id_ql_dt_gfdlmp, id_qi_dt_gfdlmp + integer :: id_u_dt_gfdlmp, id_v_dt_gfdlmp + integer :: id_t_dt_phys, id_qv_dt_phys, id_ql_dt_phys, id_qi_dt_phys, id_u_dt_phys, id_v_dt_phys + integer :: id_intqv, id_intql, id_intqi, id_intqr, id_intqs, id_intqg + + integer :: id_uw, id_vw, id_hw, id_qvw, id_qlw, id_qiw, id_o3w logical :: initialized = .false. real sphum, liq_wat, ice_wat ! GFDL physics @@ -237,8 +240,8 @@ module fv_arrays_mod !< supported and will likely not run. The default value is 0. logical, pointer :: nested !< Whether this is a nested grid. .false. by default. - - logical, pointer :: regional !< Is this a limited area regional domain? + logical, pointer :: regional !< Is this a (stand-alone) limited area regional domain? + logical :: bounded_domain !< Is this a regional or nested domain? end type fv_grid_type @@ -531,7 +534,7 @@ module fv_arrays_mod logical :: adiabatic = .false. !< Run without physics (full or idealized). #endif !----------------------------------------------------------- -! Grid shifting, rotation, and the Schmidt transformation: +! Grid shifting, rotation, and cube transformations: !----------------------------------------------------------- real :: shift_fac = 18. !< Westward zonal rotation (or shift) of cubed-sphere grid from !< its natural orientation with cube face centers at 0, 90, 180, and 270 @@ -546,6 +549,7 @@ module fv_arrays_mod logical :: do_schmidt = .false. !< Whether to enable grid stretching and rotation using !< stretch_fac, target_lat, and target_lon. !< The default value is .false. + logical :: do_cube_transform = .false. real(kind=R_GRID) :: stretch_fac = 1. !< Stretching factor for the Schmidt transformation. This !< is the factor by which tile 6 of the cubed sphere will !< be shrunk, with the grid size shrinking accordingly. @@ -659,6 +663,11 @@ module fv_arrays_mod integer :: npz !< Number of vertical levels. Each choice of npz comes with a !< pre-defined set of hybrid sigma-pressure levels and model top !< (see fv_eta.F90). Must be set. +#ifdef USE_GFSL63 + character(24) :: npz_type = 'gfs' !< Option for selecting vertical level setup (gfs levels, when available, by default) +#else + character(24) :: npz_type = '' !< Option for selecting vertical level setup (empty by default) +#endif integer :: npz_rst = 0 !< If using a restart file with a different number of vertical !< levels, set npz_rst to be the number of levels in your restart file. @@ -679,6 +688,7 @@ module fv_arrays_mod integer :: dnats = 0 !< The number of tracers which are not to be advected by the dynamical core, !< but still passed into the dynamical core; the last dnats+pnats tracers !< in field_table are not advected. 0 by default. + integer :: dnrts = -1 !< Number of non-remapped consituents. Only makes sense for dnrts <= dnats integer :: ntiles = 1 !< Number of tiles on the domain. For the cubed sphere, this !< should be 6, one tile for each face of the cubed sphere; normally for @@ -697,6 +707,8 @@ module fv_arrays_mod !< then the mixing is applied only to the top n_sponge layers of the !< domain. Set to -1 (inactive) by default. The proper range is 0 to 3600. + real :: sg_cutoff = -1 !< cutoff level for fv_sg_adj (2dz filter; overrides n_sponge) + integer :: na_init = 0 !< Number of forward-backward dynamics steps used to initialize !< adiabatic solver. This is useful for spinning up the nonhydrostatic !< state from the hydrostatic GFS analyses. 0 by default. Recommended @@ -801,6 +813,7 @@ module fv_arrays_mod logical :: fill_wz = .false. + logical :: fill_gfs = .true. ! default behavior logical :: check_negative = .false. !< Whether to print the most negative global value of microphysical tracers. logical :: non_ortho = .true. logical :: moist_phys = .true. !< Run with moist physics @@ -974,6 +987,10 @@ module fv_arrays_mod !< Useful for perturbing initial conditions. -1 by default; !< disabled if 0 or negative. + logical :: butterfly_effect = .false. !< Flip the least-significant-bit of the lowest level temperature + !< at the center of the domain (the center of tile 1), if set to .true. + !< The default value is .false. + integer :: a2b_ord = 4 !< Order of interpolation used by the pressure gradient force !< to interpolate cell-centered (A-grid) values to the grid corners. !< The default value is 4 (recommended), which uses fourth-order @@ -985,6 +1002,7 @@ module fv_arrays_mod !< The default value is 4 (recommended); fourth-order interpolation !< is used unless c2l_ord = 2. + integer :: nrows_blend = 0 !< # of blending rows in the outer integration domain. real(kind=R_GRID) :: dx_const = 1000. !< Specifies the (uniform) grid-cell-width in the x-direction !< on a doubly-periodic grid (grid_type = 4) in meters. @@ -1006,6 +1024,10 @@ module fv_arrays_mod integer :: bc_update_interval = 3 !< Default setting for interval (hours) between external regional BC data files. + logical :: regional_bcs_from_gsi = .false. !< Default setting for using DA-updated BC files. + + logical :: write_restart_with_bcs = .false. !< Default setting for writing restart files with boundary rows. + !>Convenience pointers integer, pointer :: grid_number @@ -1044,6 +1066,14 @@ module fv_arrays_mod end type fv_nest_BC_type_4D + type nest_level_type + !Interpolation arrays for grid nesting + logical :: on_level ! indicate if current processor on this level. + logical :: do_remap_BC + integer, allocatable, dimension(:,:,:) :: ind_h, ind_u, ind_v, ind_b ! I don't think these are necessary since BC interpolation is done locally + real, allocatable, dimension(:,:,:) :: wt_h, wt_u, wt_v, wt_b + end type nest_level_type + type fv_nest_type !nested grid flags: @@ -1067,13 +1097,14 @@ module fv_arrays_mod integer :: nestbctype = 1 integer :: nsponge = 0 - integer :: nestupdate = 0 !< Type of nested-grid update to use; details are given in - !< model/fv_nesting.F90. The default is 0. + integer :: nestupdate = 7 !< Type of nested-grid update to use; details are given in + !< model/fv_nesting.F90. The default is 7. logical :: twowaynest = .false. !< Whether to use two-way nesting, the process by which !< the nested-grid solution can feed back onto the !< coarse-grid solution. The default value is .false. integer :: ioffset, joffset ! NULL() + + !These are for tracer flux BCs logical :: do_flux_BCs, do_2way_flux_BCs !@brief 'allocate_fv_nest_BC_type' is an interface to subroutines !! that allocate the 'fv_nest_BC_type' structure that holds the nested-grid BCs. !>@details The subroutines can pass the array bounds explicitly or not. -!! The bounds in Atm%bd are used for the non-explicit case. - interface allocate_fv_nest_BC_type +!! The bounds in Atm%bd are used for the non-explicit case. +interface allocate_fv_nest_BC_type module procedure allocate_fv_nest_BC_type_3D module procedure allocate_fv_nest_BC_type_3D_Atm end interface @@ -1140,7 +1190,7 @@ module fv_arrays_mod integer :: isd, ied, jsd, jed integer :: isc, iec, jsc, jec - integer :: ng + integer :: ng = 3 !default end type fv_grid_bounds_type @@ -1168,11 +1218,17 @@ module fv_arrays_mod logical :: allocated = .false. logical :: dummy = .false. ! same as grids_on_this_pe(n) integer :: grid_number = 1 + character(len=32) :: nml_filename = "input.nml" !Timestep-related variables. type(time_type) :: Time_init, Time, Run_length, Time_end, Time_step_atmos +#ifdef GFS_PHYS + !--- DUMMY for backwards-compatibility. Will be removed + real, dimension(2048) :: fdiag = 0. +#endif + logical :: grid_active = .true. !Always active for now !This is kept here instead of in neststruct% simply for convenience @@ -1267,7 +1323,7 @@ module fv_arrays_mod type(domain2D) :: domain_for_coupler !< domain used in coupled model with halo = 1. - integer :: num_contact, npes_per_tile, tile, npes_this_grid + integer :: num_contact, npes_per_tile, global_tile, tile_of_mosaic, npes_this_grid integer :: layout(2), io_layout(2) = (/ 1,1 /) !< layout: Processor layout on each tile. !< The number of PEs assigned to a domain must equal !< layout(1)*layout(2)*ntiles. Must be set. @@ -1309,8 +1365,10 @@ module fv_arrays_mod !Hold on to coarse-grid global grid, so we don't have to waste processor time getting it again when starting to do grid nesting real(kind=R_GRID), allocatable, dimension(:,:,:,:) :: grid_global - - integer :: atmos_axes(4) + + integer :: atmos_axes(4) + + type(phys_diag_type) :: phys_diag end type fv_atmos_type @@ -1320,7 +1378,7 @@ module fv_arrays_mod !>@details It includes an option to define dummy grids that have scalar and !! small arrays defined as null 3D arrays. subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie_in, js_in, je_in, & - npx_in, npy_in, npz_in, ndims_in, ncnst_in, nq_in, ng_in, dummy, alloc_2d, ngrids_in) + npx_in, npy_in, npz_in, ndims_in, ncnst_in, nq_in, dummy, alloc_2d, ngrids_in) !WARNING: Before calling this routine, be sure to have set up the ! proper domain parameters from the namelists (as is done in @@ -1329,7 +1387,7 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie implicit none type(fv_atmos_type), intent(INOUT), target :: Atm integer, intent(IN) :: isd_in, ied_in, jsd_in, jed_in, is_in, ie_in, js_in, je_in - integer, intent(IN) :: npx_in, npy_in, npz_in, ndims_in, ncnst_in, nq_in, ng_in + integer, intent(IN) :: npx_in, npy_in, npz_in, ndims_in, ncnst_in, nq_in logical, intent(IN) :: dummy, alloc_2d integer, intent(IN) :: ngrids_in integer:: isd, ied, jsd, jed, is, ie, js, je @@ -1358,7 +1416,6 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie ndims= 1 ncnst= 1 nq= 1 - ng = 1 else isd = isd_in ied= ied_in @@ -1374,7 +1431,6 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie ndims= ndims_in ncnst= ncnst_in nq= nq_in - ng = ng_in endif if ((.not. dummy) .or. alloc_2d) then @@ -1392,7 +1448,6 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie ndims_2d= ndims_in ncnst_2d= ncnst_in nq_2d= nq_in - ng_2d = ng_in else isd_2d = 0 ied_2d= -1 @@ -1408,7 +1463,6 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie ndims_2d= 1 ncnst_2d= 1 nq_2d= 1 - ng_2d = 1 endif !This should be set up in fv_mp_mod @@ -1427,8 +1481,6 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie !!$ Atm%bd%jsc = Atm%bd%js !!$ Atm%bd%jec = Atm%bd%je - Atm%bd%ng = ng - !Convenience pointers Atm%npx => Atm%flagstruct%npx Atm%npy => Atm%flagstruct%npy @@ -1442,80 +1494,78 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie !!$ Atm%npz = npz_in Atm%flagstruct%ndims = ndims_in - allocate ( Atm%u(isd:ied ,jsd:jed+1,npz) ) ; Atm%u=real_snan - allocate ( Atm%v(isd:ied+1,jsd:jed ,npz) ) ; Atm%v=real_snan + allocate ( Atm%u(isd:ied ,jsd:jed+1,npz) ) + allocate ( Atm%v(isd:ied+1,jsd:jed ,npz) ) - allocate ( Atm%pt(isd:ied ,jsd:jed ,npz) ) ; Atm%pt=real_snan - allocate ( Atm%delp(isd:ied ,jsd:jed ,npz) ) ; Atm%delp=real_snan - allocate ( Atm%q(isd:ied ,jsd:jed ,npz, nq) ) ; Atm%q=real_snan - allocate (Atm%qdiag(isd:ied ,jsd:jed ,npz, nq+1:ncnst) ) ; Atm%qdiag=real_snan + allocate ( Atm%pt(isd:ied ,jsd:jed ,npz) ) + allocate ( Atm%delp(isd:ied ,jsd:jed ,npz) ) + allocate ( Atm%q(isd:ied ,jsd:jed ,npz, nq) ) + allocate (Atm%qdiag(isd:ied ,jsd:jed ,npz, nq+1:ncnst) ) ! Allocate Auxilliary pressure arrays - allocate ( Atm%ps(isd:ied ,jsd:jed) ) ; Atm%ps=real_snan - allocate ( Atm%pe(is-1:ie+1, npz+1,js-1:je+1) ) ; Atm%pe=real_snan - allocate ( Atm%pk(is:ie ,js:je , npz+1) ) ; Atm%pk=real_snan -!!! allocate ( Atm%peln(isd:ied,npz+1,jsd:jed) ) ! Does regional need this or is the following lines okay? - allocate ( Atm%peln(is:ie,npz+1,js:je) ) ; Atm%peln=real_snan - allocate ( Atm%pkz(is:ie,js:je,npz) ) ; Atm%pkz=real_snan + allocate ( Atm%ps(isd:ied ,jsd:jed) ) + allocate ( Atm%pe(is-1:ie+1, npz+1,js-1:je+1) ) + allocate ( Atm%pk(is:ie ,js:je , npz+1) ) + allocate ( Atm%peln(is:ie,npz+1,js:je) ) + allocate ( Atm%pkz(is:ie,js:je,npz) ) - allocate ( Atm%u_srf(is:ie,js:je) ) ; Atm%u_srf=real_snan - allocate ( Atm%v_srf(is:ie,js:je) ) ; Atm%v_srf=real_snan + allocate ( Atm%u_srf(is:ie,js:je) ) + allocate ( Atm%v_srf(is:ie,js:je) ) if ( Atm%flagstruct%fv_land ) then - allocate ( Atm%sgh(is:ie,js:je) ) ; Atm%sgh=real_snan - allocate ( Atm%oro(is:ie,js:je) ) ; Atm%oro=real_snan + allocate ( Atm%sgh(is:ie,js:je) ) + allocate ( Atm%oro(is:ie,js:je) ) else - allocate ( Atm%oro(1,1) ) ; Atm%oro=real_snan + allocate ( Atm%oro(1,1) ) endif ! Allocate others - allocate ( Atm%diss_est(isd:ied ,jsd:jed ,npz) ) ; Atm%diss_est=real_snan - allocate ( Atm%ts(is:ie,js:je) ) ; Atm%ts=real_snan - allocate ( Atm%phis(isd:ied ,jsd:jed ) ) ; Atm%phis=real_snan + allocate ( Atm%diss_est(isd:ied ,jsd:jed ,npz) ) + allocate ( Atm%ts(is:ie,js:je) ) + allocate ( Atm%phis(isd:ied ,jsd:jed ) ) allocate ( Atm%omga(isd:ied ,jsd:jed ,npz) ); Atm%omga=0. - allocate ( Atm%ua(isd:ied ,jsd:jed ,npz) ) ; Atm%ua=real_snan - allocate ( Atm%va(isd:ied ,jsd:jed ,npz) ) ; Atm%va=real_snan - allocate ( Atm%uc(isd:ied+1,jsd:jed ,npz) ) ; Atm%uc=real_snan - allocate ( Atm%vc(isd:ied ,jsd:jed+1,npz) ) ; Atm%vc=real_snan + allocate ( Atm%ua(isd:ied ,jsd:jed ,npz) ) + allocate ( Atm%va(isd:ied ,jsd:jed ,npz) ) + allocate ( Atm%uc(isd:ied+1,jsd:jed ,npz) ) + allocate ( Atm%vc(isd:ied ,jsd:jed+1,npz) ) ! For tracer transport: - allocate ( Atm%mfx(is:ie+1, js:je, npz) ) ; Atm%mfx=real_snan - allocate ( Atm%mfy(is:ie , js:je+1,npz) ) ; Atm%mfy=real_snan - allocate ( Atm%cx(is:ie+1, jsd:jed, npz) ) ; Atm%cx=real_snan - allocate ( Atm%cy(isd:ied ,js:je+1, npz) ) ; Atm%cy=real_snan + allocate ( Atm%mfx(is:ie+1, js:je, npz) ) + allocate ( Atm%mfy(is:ie , js:je+1,npz) ) + allocate ( Atm%cx(is:ie+1, jsd:jed, npz) ) + allocate ( Atm%cy(isd:ied ,js:je+1, npz) ) - allocate ( Atm%ak(npz_2d+1) ) ; Atm%ak=real_snan - allocate ( Atm%bk(npz_2d+1) ) ; Atm%bk=real_snan + allocate ( Atm%ak(npz_2d+1) ) + allocate ( Atm%bk(npz_2d+1) ) !-------------------------- ! Non-hydrostatic dynamics: !-------------------------- if ( Atm%flagstruct%hydrostatic ) then !Note length-one initialization if hydrostatic = .true. - allocate ( Atm%w(isd:isd, jsd:jsd ,1) ) ; Atm%w=real_snan - allocate ( Atm%delz(isd:isd, jsd:jsd ,1) ) ; Atm%delz=real_snan - allocate ( Atm%ze0(is:is, js:js ,1) ) ; Atm%ze0=real_snan + allocate ( Atm%w(isd:isd, jsd:jsd ,1) ) + allocate ( Atm%delz(is:is, js:js ,1) ) + allocate ( Atm%ze0(is:is, js:js ,1) ) else - allocate ( Atm%w(isd:ied, jsd:jed ,npz ) ) ; Atm%w=real_snan - allocate ( Atm%delz(isd:ied, jsd:jed ,npz) ) ; Atm%delz=real_snan + allocate ( Atm%w(isd:ied, jsd:jed ,npz ) ) + allocate ( Atm%delz(is:ie, js:je ,npz) ) if( Atm%flagstruct%hybrid_z ) then - allocate ( Atm%ze0(is:ie, js:je ,npz+1) ) ; Atm%ze0=real_snan + allocate ( Atm%ze0(is:ie, js:je ,npz+1) ) else - allocate ( Atm%ze0(is:is, js:js ,1) ) ; Atm%ze0=real_snan + allocate ( Atm%ze0(is:is, js:js ,1) ) endif ! allocate ( mono(isd:ied, jsd:jed, npz)) endif #ifdef USE_COND - allocate ( Atm%q_con(isd:ied,jsd:jed,1:npz) ) ; Atm%q_con=real_snan; Atm%q_con=0.0 + allocate ( Atm%q_con(isd:ied,jsd:jed,1:npz) ) #else - allocate ( Atm%q_con(isd:isd,jsd:jsd,1) ) ; Atm%q_con=real_snan; Atm%q_con=0.0 + allocate ( Atm%q_con(isd:isd,jsd:jsd,1) ) #endif -#ifndef NO_TOUCH_MEM ! Notes by SJL ! Place the memory in the optimal shared mem space ! This will help the scaling with OpenMP -!$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,Atm,nq,ncnst) +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,Atm,nq,ncnst) do k=1, npz do j=jsd, jed do i=isd, ied @@ -1527,13 +1577,13 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie enddo do j=jsd, jed+1 do i=isd, ied - Atm%u(i,j,k) = real_big + Atm%u(i,j,k) = 0. Atm%vc(i,j,k) = real_big enddo enddo do j=jsd, jed do i=isd, ied+1 - Atm%v(i,j,k) = real_big + Atm%v(i,j,k) = 0. Atm%uc(i,j,k) = real_big enddo enddo @@ -1541,6 +1591,10 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie do j=jsd, jed do i=isd, ied Atm%w(i,j,k) = real_big + enddo + enddo + do j=js, je + do i=is, ie Atm%delz(i,j,k) = real_big enddo enddo @@ -1560,126 +1614,131 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie enddo enddo enddo -#endif + do j=js, je + do i=is, ie + Atm%ts(i,j) = 300. + Atm%phis(i,j) = real_big + enddo + enddo - allocate ( Atm%gridstruct% area(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct% area=real_snan ! Cell Centered - allocate ( Atm%gridstruct% area_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct% area_64=real_snan ! Cell Centered - allocate ( Atm%gridstruct%rarea(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct%rarea=real_snan ! Cell Centered + allocate ( Atm%gridstruct% area(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ! Cell Centered + allocate ( Atm%gridstruct% area_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ! Cell Centered + allocate ( Atm%gridstruct%rarea(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ! Cell Centered - allocate ( Atm%gridstruct% area_c(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% area_c=real_snan ! Cell Corners - allocate ( Atm%gridstruct% area_c_64(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% area_c_64=real_snan ! Cell Corners - allocate ( Atm%gridstruct%rarea_c(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%rarea_c=real_snan ! Cell Corners + allocate ( Atm%gridstruct% area_c(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! Cell Corners + allocate ( Atm%gridstruct% area_c_64(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) )! Cell Corners + allocate ( Atm%gridstruct%rarea_c(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! Cell Corners - allocate ( Atm%gridstruct% dx(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% dx=real_snan - allocate ( Atm%gridstruct% dx_64(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% dx_64=real_snan - allocate ( Atm%gridstruct%rdx(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%rdx=real_snan - allocate ( Atm%gridstruct% dy(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dy=real_snan - allocate ( Atm%gridstruct% dy_64(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dy_64=real_snan - allocate ( Atm%gridstruct%rdy(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) ; Atm%gridstruct%rdy=real_snan + allocate ( Atm%gridstruct% dx(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% dx_64(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%rdx(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% dy(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dy_64(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdy(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) - allocate ( Atm%gridstruct% dxc(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dxc=real_snan - allocate ( Atm%gridstruct% dxc_64(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dxc_64=real_snan - allocate ( Atm%gridstruct%rdxc(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) ; Atm%gridstruct%rdxc=real_snan - allocate ( Atm%gridstruct% dyc(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% dyc=real_snan - allocate ( Atm%gridstruct% dyc_64(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% dyc_64=real_snan - allocate ( Atm%gridstruct%rdyc(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%rdyc=real_snan + allocate ( Atm%gridstruct% dxc(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dxc_64(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdxc(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dyc(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% dyc_64(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%rdyc(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) - allocate ( Atm%gridstruct% dxa(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dxa=real_snan - allocate ( Atm%gridstruct% dxa_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dxa_64=real_snan - allocate ( Atm%gridstruct%rdxa(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct%rdxa=real_snan - allocate ( Atm%gridstruct% dya(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dya=real_snan - allocate ( Atm%gridstruct% dya_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct% dya_64=real_snan - allocate ( Atm%gridstruct%rdya(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct%rdya=real_snan + allocate ( Atm%gridstruct% dxa(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dxa_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdxa(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dya(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dya_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdya(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) - allocate ( Atm%gridstruct%grid (isd_2d:ied_2d+1,jsd_2d:jed_2d+1,1:ndims_2d) ) ; Atm%gridstruct%grid=real_snan - allocate ( Atm%gridstruct%grid_64 (isd_2d:ied_2d+1,jsd_2d:jed_2d+1,1:ndims_2d) ) ; Atm%gridstruct%grid_64=real_snan - allocate ( Atm%gridstruct%agrid(isd_2d:ied_2d ,jsd_2d:jed_2d ,1:ndims_2d) ) ; Atm%gridstruct%agrid=real_snan - allocate ( Atm%gridstruct%agrid_64(isd_2d:ied_2d ,jsd_2d:jed_2d ,1:ndims_2d) ) ; Atm%gridstruct%agrid_64=real_snan - allocate ( Atm%gridstruct% sina(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% sina=real_snan ! SIN(angle of intersection) - allocate ( Atm%gridstruct% sina_64(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% sina_64=real_snan ! SIN(angle of intersection) - allocate ( Atm%gridstruct%rsina(is_2d:ie_2d+1,js_2d:je_2d+1) ) ; Atm%gridstruct%rsina=real_snan ! Why is the size different? - allocate ( Atm%gridstruct% cosa(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% cosa=real_snan ! COS(angle of intersection) - allocate ( Atm%gridstruct% cosa_64(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct% cosa_64=real_snan ! COS(angle of intersection) + allocate ( Atm%gridstruct%grid (isd_2d:ied_2d+1,jsd_2d:jed_2d+1,1:ndims_2d) ) + allocate ( Atm%gridstruct%grid_64 (isd_2d:ied_2d+1,jsd_2d:jed_2d+1,1:ndims_2d) ) + allocate ( Atm%gridstruct%agrid(isd_2d:ied_2d ,jsd_2d:jed_2d ,1:ndims_2d) ) + allocate ( Atm%gridstruct%agrid_64(isd_2d:ied_2d ,jsd_2d:jed_2d ,1:ndims_2d) ) + allocate ( Atm%gridstruct% sina(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! SIN(angle of intersection) + allocate ( Atm%gridstruct% sina_64(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! SIN(angle of intersection) + allocate ( Atm%gridstruct%rsina(is_2d:ie_2d+1,js_2d:je_2d+1) ) ! Why is the size different? + allocate ( Atm%gridstruct% cosa(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! COS(angle of intersection) + allocate ( Atm%gridstruct% cosa_64(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! COS(angle of intersection) - allocate ( Atm%gridstruct% e1(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%e1=real_snan - allocate ( Atm%gridstruct% e2(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%e2=real_snan + allocate ( Atm%gridstruct% e1(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% e2(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) allocate (Atm%gridstruct%iinta(4, isd_2d:ied_2d ,jsd_2d:jed_2d), & Atm%gridstruct%jinta(4, isd_2d:ied_2d ,jsd_2d:jed_2d), & Atm%gridstruct%iintb(4, is_2d:ie_2d+1 ,js_2d:je_2d+1), & Atm%gridstruct%jintb(4, is_2d:ie_2d+1 ,js_2d:je_2d+1) ) - allocate ( Atm%gridstruct%edge_s(npx_2d) ) ; Atm%gridstruct%edge_s=real_snan - allocate ( Atm%gridstruct%edge_n(npx_2d) ) ; Atm%gridstruct%edge_n=real_snan - allocate ( Atm%gridstruct%edge_w(npy_2d) ) ; Atm%gridstruct%edge_w=real_snan - allocate ( Atm%gridstruct%edge_e(npy_2d) ) ; Atm%gridstruct%edge_e=real_snan + allocate ( Atm%gridstruct%edge_s(npx_2d) ) + allocate ( Atm%gridstruct%edge_n(npx_2d) ) + allocate ( Atm%gridstruct%edge_w(npy_2d) ) + allocate ( Atm%gridstruct%edge_e(npy_2d) ) - allocate ( Atm%gridstruct%edge_vect_s(isd_2d:ied_2d) ) ; Atm%gridstruct%edge_vect_s=real_snan - allocate ( Atm%gridstruct%edge_vect_n(isd_2d:ied_2d) ) ; Atm%gridstruct%edge_vect_n=real_snan - allocate ( Atm%gridstruct%edge_vect_w(jsd_2d:jed_2d) ) ; Atm%gridstruct%edge_vect_w=real_snan - allocate ( Atm%gridstruct%edge_vect_e(jsd_2d:jed_2d) ) ; Atm%gridstruct%edge_vect_e=real_snan + allocate ( Atm%gridstruct%edge_vect_s(isd_2d:ied_2d) ) + allocate ( Atm%gridstruct%edge_vect_n(isd_2d:ied_2d) ) + allocate ( Atm%gridstruct%edge_vect_w(jsd_2d:jed_2d) ) + allocate ( Atm%gridstruct%edge_vect_e(jsd_2d:jed_2d) ) - allocate ( Atm%gridstruct%ex_s(npx_2d) ) ; Atm%gridstruct%ex_s=real_snan - allocate ( Atm%gridstruct%ex_n(npx_2d) ) ; Atm%gridstruct%ex_n=real_snan - allocate ( Atm%gridstruct%ex_w(npy_2d) ) ; Atm%gridstruct%ex_w=real_snan - allocate ( Atm%gridstruct%ex_e(npy_2d) ) ; Atm%gridstruct%ex_e=real_snan + allocate ( Atm%gridstruct%ex_s(npx_2d) ) + allocate ( Atm%gridstruct%ex_n(npx_2d) ) + allocate ( Atm%gridstruct%ex_w(npy_2d) ) + allocate ( Atm%gridstruct%ex_e(npy_2d) ) - allocate ( Atm%gridstruct%l2c_u(is_2d:ie_2d, js_2d:je_2d+1) ) ; Atm%gridstruct%l2c_u=real_snan - allocate ( Atm%gridstruct%l2c_v(is_2d:ie_2d+1,js_2d:je_2d) ) ; Atm%gridstruct%l2c_v=real_snan + allocate ( Atm%gridstruct%l2c_u(is_2d:ie_2d, js_2d:je_2d+1) ) + allocate ( Atm%gridstruct%l2c_v(is_2d:ie_2d+1,js_2d:je_2d) ) ! For diveregnce damping: - allocate ( Atm%gridstruct%divg_u(isd_2d:ied_2d, jsd_2d:jed_2d+1) ) ; Atm%gridstruct%divg_u=real_snan - allocate ( Atm%gridstruct%divg_v(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) ; Atm%gridstruct%divg_v=real_snan + allocate ( Atm%gridstruct%divg_u(isd_2d:ied_2d, jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%divg_v(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) ! For del6 diffusion: - allocate ( Atm%gridstruct%del6_u(isd_2d:ied_2d, jsd_2d:jed_2d+1) ) ; Atm%gridstruct%del6_u=real_snan - allocate ( Atm%gridstruct%del6_v(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) ; Atm%gridstruct%del6_v=real_snan + allocate ( Atm%gridstruct%del6_u(isd_2d:ied_2d, jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%del6_v(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) - allocate ( Atm%gridstruct%z11(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%z11=real_snan - allocate ( Atm%gridstruct%z12(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%z12=real_snan - allocate ( Atm%gridstruct%z21(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%z21=real_snan - allocate ( Atm%gridstruct%z22(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%z22=real_snan + allocate ( Atm%gridstruct%z11(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + allocate ( Atm%gridstruct%z12(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + allocate ( Atm%gridstruct%z21(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + allocate ( Atm%gridstruct%z22(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ! if (.not.Atm%flagstruct%hydrostatic) & -! allocate ( Atm%gridstruct%w00(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%w00=real_snan - - allocate ( Atm%gridstruct%a11(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%a11=real_snan - allocate ( Atm%gridstruct%a12(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%a12=real_snan - allocate ( Atm%gridstruct%a21(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%a21=real_snan - allocate ( Atm%gridstruct%a22(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) ; Atm%gridstruct%a22=real_snan - allocate ( Atm%gridstruct%vlon(is_2d-2:ie_2d+2,js_2d-2:je_2d+2,3) ) ; Atm%gridstruct%vlon=real_snan - allocate ( Atm%gridstruct%vlat(is_2d-2:ie_2d+2,js_2d-2:je_2d+2,3) ) ; Atm%gridstruct%vlat=real_snan +! allocate ( Atm%gridstruct%w00(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + + allocate ( Atm%gridstruct%a11(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + allocate ( Atm%gridstruct%a12(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + allocate ( Atm%gridstruct%a21(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + allocate ( Atm%gridstruct%a22(is_2d-1:ie_2d+1,js_2d-1:je_2d+1) ) + allocate ( Atm%gridstruct%vlon(is_2d-2:ie_2d+2,js_2d-2:je_2d+2,3) ) + allocate ( Atm%gridstruct%vlat(is_2d-2:ie_2d+2,js_2d-2:je_2d+2,3) ) ! Coriolis parameters: - allocate ( Atm%gridstruct%f0(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) ; Atm%gridstruct%f0=real_snan - allocate ( Atm%gridstruct%fC(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%fc=real_snan + allocate ( Atm%gridstruct%f0(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%fC(isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! Corner unit vectors: - allocate( Atm%gridstruct%ee1(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%ee1=real_snan - allocate( Atm%gridstruct%ee2(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%ee2=real_snan + allocate( Atm%gridstruct%ee1(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) + allocate( Atm%gridstruct%ee2(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) ! Center unit vectors: - allocate( Atm%gridstruct%ec1(3,isd_2d:ied_2d,jsd_2d:jed_2d) ) ; Atm%gridstruct%ec1=real_snan - allocate( Atm%gridstruct%ec2(3,isd_2d:ied_2d,jsd_2d:jed_2d) ) ; Atm%gridstruct%ec2=real_snan + allocate( Atm%gridstruct%ec1(3,isd_2d:ied_2d,jsd_2d:jed_2d) ) + allocate( Atm%gridstruct%ec2(3,isd_2d:ied_2d,jsd_2d:jed_2d) ) ! Edge unit vectors: - allocate( Atm%gridstruct%ew(3,isd_2d:ied_2d+1,jsd_2d:jed_2d, 2) ) ; Atm%gridstruct%ew=real_snan - allocate( Atm%gridstruct%es(3,isd_2d:ied_2d ,jsd_2d:jed_2d+1,2) ) ; Atm%gridstruct%es=real_snan + allocate( Atm%gridstruct%ew(3,isd_2d:ied_2d+1,jsd_2d:jed_2d, 2) ) + allocate( Atm%gridstruct%es(3,isd_2d:ied_2d ,jsd_2d:jed_2d+1,2) ) ! Edge unit "Normal" vectors: (for omega computation) - allocate( Atm%gridstruct%en1(3,is_2d:ie_2d, js_2d:je_2d+1) ) ; Atm%gridstruct%en1=real_snan ! E-W edges - allocate( Atm%gridstruct%en2(3,is_2d:ie_2d+1,js_2d:je_2d ) ) ; Atm%gridstruct%en2=real_snan ! N-S egdes + allocate( Atm%gridstruct%en1(3,is_2d:ie_2d, js_2d:je_2d+1) ) ! E-W edges + allocate( Atm%gridstruct%en2(3,is_2d:ie_2d+1,js_2d:je_2d ) ) ! N-S egdes - allocate ( Atm%gridstruct%cosa_u(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) ; Atm%gridstruct%cosa_u=real_snan - allocate ( Atm%gridstruct%sina_u(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) ; Atm%gridstruct%sina_u=real_snan - allocate ( Atm%gridstruct%rsin_u(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) ; Atm%gridstruct%rsin_u=real_snan + allocate ( Atm%gridstruct%cosa_u(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) + allocate ( Atm%gridstruct%sina_u(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) + allocate ( Atm%gridstruct%rsin_u(isd_2d:ied_2d+1,jsd_2d:jed_2d) ) - allocate ( Atm%gridstruct%cosa_v(isd_2d:ied_2d,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%cosa_v=real_snan - allocate ( Atm%gridstruct%sina_v(isd_2d:ied_2d,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%sina_v=real_snan - allocate ( Atm%gridstruct%rsin_v(isd_2d:ied_2d,jsd_2d:jed_2d+1) ) ; Atm%gridstruct%rsin_v=real_snan + allocate ( Atm%gridstruct%cosa_v(isd_2d:ied_2d,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%sina_v(isd_2d:ied_2d,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%rsin_v(isd_2d:ied_2d,jsd_2d:jed_2d+1) ) - allocate ( Atm%gridstruct%cosa_s(isd_2d:ied_2d,jsd_2d:jed_2d) ) ; Atm%gridstruct%rsin_v=real_snan ! cell center + allocate ( Atm%gridstruct%cosa_s(isd_2d:ied_2d,jsd_2d:jed_2d) ) ! cell center - allocate ( Atm%gridstruct%rsin2(isd_2d:ied_2d,jsd_2d:jed_2d) ) ; Atm%gridstruct%rsin_v=real_snan ! cell center + allocate ( Atm%gridstruct%rsin2(isd_2d:ied_2d,jsd_2d:jed_2d) ) ! cell center ! Super (composite) grid: @@ -1690,23 +1749,24 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie ! | | ! 6---2---7 - allocate ( Atm%gridstruct%cos_sg(isd_2d:ied_2d,jsd_2d:jed_2d,9) ) ; Atm%gridstruct%cos_sg=real_snan - allocate ( Atm%gridstruct%sin_sg(isd_2d:ied_2d,jsd_2d:jed_2d,9) ) ; Atm%gridstruct%sin_sg=real_snan + allocate ( Atm%gridstruct%cos_sg(isd_2d:ied_2d,jsd_2d:jed_2d,9) ) + allocate ( Atm%gridstruct%sin_sg(isd_2d:ied_2d,jsd_2d:jed_2d,9) ) - allocate( Atm%gridstruct%eww(3,4) ) ; Atm%gridstruct%eww=real_snan - allocate( Atm%gridstruct%ess(3,4) ) ; Atm%gridstruct%ess=real_snan + allocate( Atm%gridstruct%eww(3,4) ) + allocate( Atm%gridstruct%ess(3,4) ) if (Atm%neststruct%nested) then - allocate(Atm%neststruct%ind_h(isd:ied,jsd:jed,4)) ; Atm%neststruct%ind_h=i4_in - allocate(Atm%neststruct%ind_u(isd:ied,jsd:jed+1,4)) ; Atm%neststruct%ind_u=i4_in - allocate(Atm%neststruct%ind_v(isd:ied+1,jsd:jed,4)) ; Atm%neststruct%ind_v=i4_in - allocate(Atm%neststruct%wt_h(isd:ied, jsd:jed, 4)) ; Atm%neststruct%wt_h=real_snan - allocate(Atm%neststruct%wt_u(isd:ied, jsd:jed+1,4)) ; Atm%neststruct%wt_u=real_snan - allocate(Atm%neststruct%wt_v(isd:ied+1, jsd:jed, 4)) ; Atm%neststruct%wt_v=real_snan - allocate(Atm%neststruct%ind_b(isd:ied+1,jsd:jed+1,4)) ; Atm%neststruct%ind_b=i4_in - allocate(Atm%neststruct%wt_b(isd:ied+1, jsd:jed+1,4)) ; Atm%neststruct%wt_b=real_snan + allocate(Atm%neststruct%ind_h(isd:ied,jsd:jed,4)) + allocate(Atm%neststruct%ind_u(isd:ied,jsd:jed+1,4)) + allocate(Atm%neststruct%ind_v(isd:ied+1,jsd:jed,4)) + + allocate(Atm%neststruct%wt_h(isd:ied, jsd:jed, 4)) + allocate(Atm%neststruct%wt_u(isd:ied, jsd:jed+1,4)) + allocate(Atm%neststruct%wt_v(isd:ied+1, jsd:jed, 4)) + allocate(Atm%neststruct%ind_b(isd:ied+1,jsd:jed+1,4)) + allocate(Atm%neststruct%wt_b(isd:ied+1, jsd:jed+1,4)) ns = Atm%neststruct%nsponge @@ -1740,25 +1800,27 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie #endif - if (Atm%neststruct%twowaynest) allocate(& - Atm%neststruct%ind_update_h( & - Atm%parent_grid%bd%isd:Atm%parent_grid%bd%ied+1, & - Atm%parent_grid%bd%jsd:Atm%parent_grid%bd%jed+1,2)); Atm%neststruct%ind_update_h=i4_in - end if !--- Do the memory allocation only for nested model if( ngrids_in > 1 ) then if (Atm%flagstruct%grid_type < 4) then if (Atm%neststruct%nested) then - allocate(Atm%grid_global(1-ng_2d:npx_2d +ng_2d,1-ng_2d:npy_2d +ng_2d,2,1)); Atm%grid_global=real_snan + allocate(Atm%grid_global(1-Atm%ng:npx_2d +Atm%ng,1-Atm%ng:npy_2d +Atm%ng,2,1)) else - allocate(Atm%grid_global(1-ng_2d:npx_2d +ng_2d,1-ng_2d:npy_2d +ng_2d,2,1:6)); Atm%grid_global=real_snan + allocate(Atm%grid_global(1-Atm%ng:npx_2d +Atm%ng,1-Atm%ng:npy_2d +Atm%ng,2,1:6)) endif end if endif - Atm%ptop = real_snan + + !!Convenience pointers + Atm%gridstruct%nested => Atm%neststruct%nested + Atm%gridstruct%grid_type => Atm%flagstruct%grid_type + Atm%flagstruct%grid_number => Atm%grid_number + Atm%gridstruct%regional => Atm%flagstruct%regional + Atm%gridstruct%bounded_domain = Atm%flagstruct%regional .or. Atm%neststruct%nested + if (Atm%neststruct%nested) Atm%neststruct%parent_grid => Atm%parent_grid Atm%allocated = .true. if (dummy) Atm%dummy = .true. @@ -1966,9 +2028,6 @@ subroutine deallocate_fv_atmos_type(Atm) endif #endif - - if (Atm%neststruct%twowaynest) deallocate(Atm%neststruct%ind_update_h) - end if if (Atm%flagstruct%grid_type < 4) then diff --git a/model/fv_cmp.F90 b/model/fv_cmp.F90 index 16b679b9f..34e4b3479 100644 --- a/model/fv_cmp.F90 +++ b/model/fv_cmp.F90 @@ -136,8 +136,8 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, te0 real, intent (in) :: zvir, mdt ! remapping time step - real, intent (in), dimension (is - ng:ie + ng, js - ng:je + ng) :: dp, delz, hs - real, intent (in), dimension (is:ie, js:je) :: dpln + real, intent (in), dimension (is - ng:ie + ng, js - ng:je + ng) :: dp, hs + real, intent (in), dimension (is:ie, js:je) :: dpln, delz #ifdef MULTI_GASES diff --git a/model/fv_control.F90 b/model/fv_control.F90 index 52743734c..694c6588e 100644 --- a/model/fv_control.F90 +++ b/model/fv_control.F90 @@ -119,11 +119,12 @@ module fv_control_mod use field_manager_mod, only: MODEL_ATMOS use fms_mod, only: write_version_number, open_namelist_file, & check_nml_error, close_file, file_exist + use fms_io_mod, only: set_domain use mpp_mod, only: FATAL, mpp_error, mpp_pe, stdlog, & mpp_npes, mpp_get_current_pelist, & input_nml_file, get_unit, WARNING, & read_ascii_file, INPUT_STR_LENGTH - use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain + use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain, mpp_get_tile_id use tracer_manager_mod, only: tm_get_number_tracers => get_number_tracers, & tm_get_tracer_index => get_tracer_index, & tm_get_tracer_indices => get_tracer_indices, & @@ -139,225 +140,42 @@ module fv_control_mod use fv_grid_utils_mod, only: grid_utils_init, grid_utils_end, ptop_min use fv_eta_mod, only: set_eta use fv_grid_tools_mod, only: init_grid - use fv_mp_mod, only: mp_start, mp_assign_gid, domain_decomp - use fv_mp_mod, only: ng, switch_current_Atm - use fv_mp_mod, only: broadcast_domains, mp_barrier, is_master, setup_master -!!! CLEANUP: should be replaced by a getter function? - use test_cases_mod, only: test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size + use fv_mp_mod, only: mp_start, domain_decomp, mp_assign_gid, global_nest_domain + use fv_mp_mod, only: broadcast_domains, mp_barrier, is_master, setup_master, grids_master_procs, tile_fine + use fv_mp_mod, only: MAX_NNEST, MAX_NTILE + use test_cases_mod, only: read_namelist_test_case_nml use fv_timing_mod, only: timing_on, timing_off, timing_init, timing_prt use mpp_domains_mod, only: domain2D use mpp_domains_mod, only: mpp_define_nest_domains, nest_domain_type, mpp_get_global_domain - use mpp_domains_mod, only: mpp_get_C2F_index, mpp_get_F2C_index, mpp_broadcast_domain + use mpp_domains_mod, only: mpp_get_C2F_index, mpp_get_F2C_index use mpp_domains_mod, only: CENTER, CORNER, NORTH, EAST, WEST, SOUTH - use mpp_mod, only: mpp_send, mpp_sync, mpp_transmit, mpp_set_current_pelist, mpp_declare_pelist, mpp_root_pe, mpp_recv, mpp_sync_self, mpp_broadcast, read_input_nml + use mpp_mod, only: mpp_send, mpp_sync, mpp_transmit, mpp_set_current_pelist, & + mpp_declare_pelist, mpp_root_pe, mpp_recv, mpp_sync_self, read_input_nml, & + mpp_max use fv_diagnostics_mod, only: fv_diag_init_gn #ifdef MULTI_GASES use constants_mod, only: rvgas, cp_air use multi_gases_mod, only: multi_gases_init, & - rilist => ri, & - cpilist => cpi + read_namelist_multi_gases_nml #endif implicit none private -!----------------------------------------------------------------------- -! Grid descriptor file setup -!----------------------------------------------------------------------- -!------------------------------------------ -! Model Domain parameters -! See fv_arrays.F90 for descriptions -!------------------------------------------ -!CLEANUP module pointers - character(len=80) , pointer :: grid_name - character(len=120), pointer :: grid_file - integer, pointer :: grid_type - integer , pointer :: hord_mt - integer , pointer :: kord_mt - integer , pointer :: kord_wz - integer , pointer :: hord_vt - integer , pointer :: hord_tm - integer , pointer :: hord_dp - integer , pointer :: kord_tm - integer , pointer :: hord_tr - integer , pointer :: kord_tr - real , pointer :: scale_z - real , pointer :: w_max - real , pointer :: z_min - real , pointer :: lim_fac - - integer , pointer :: nord - integer , pointer :: nord_tr - real , pointer :: dddmp - real , pointer :: d2_bg - real , pointer :: d4_bg - real , pointer :: vtdm4 - real , pointer :: trdm2 - real , pointer :: d2_bg_k1 - real , pointer :: d2_bg_k2 - real , pointer :: d2_divg_max_k1 - real , pointer :: d2_divg_max_k2 - real , pointer :: damp_k_k1 - real , pointer :: damp_k_k2 - integer , pointer :: n_zs_filter - integer , pointer :: nord_zs_filter - logical , pointer :: full_zs_filter - - logical , pointer :: RF_fast - logical , pointer :: consv_am - logical , pointer :: do_sat_adj - logical , pointer :: do_f3d - logical , pointer :: no_dycore - logical , pointer :: convert_ke - logical , pointer :: do_vort_damp - logical , pointer :: use_old_omega -! PG off centering: - real , pointer :: beta - integer , pointer :: n_sponge - real , pointer :: d_ext - integer , pointer :: nwat - logical , pointer :: warm_start - logical , pointer :: inline_q - real , pointer :: shift_fac - logical , pointer :: do_schmidt - real(kind=R_GRID) , pointer :: stretch_fac - real(kind=R_GRID) , pointer :: target_lat - real(kind=R_GRID) , pointer :: target_lon - - logical , pointer :: reset_eta - real , pointer :: p_fac - real , pointer :: a_imp - integer , pointer :: n_split - - real , pointer :: fac_n_spl - real , pointer :: fhouri - ! Default - integer , pointer :: m_split - integer , pointer :: k_split - logical , pointer :: use_logp - - integer , pointer :: q_split - integer , pointer :: print_freq - logical , pointer :: write_3d_diags - - integer , pointer :: npx - integer , pointer :: npy - integer , pointer :: npz - integer , pointer :: npz_rst - - integer , pointer :: ncnst - integer , pointer :: pnats - integer , pointer :: dnats - integer , pointer :: ntiles - integer , pointer :: nf_omega - integer , pointer :: fv_sg_adj - - integer , pointer :: na_init - logical , pointer :: nudge_dz - real , pointer :: p_ref - real , pointer :: dry_mass - integer , pointer :: nt_prog - integer , pointer :: nt_phys - real , pointer :: tau_h2o - - real , pointer :: delt_max - real , pointer :: d_con - real , pointer :: ke_bg - real , pointer :: consv_te - real , pointer :: tau - real , pointer :: rf_cutoff - logical , pointer :: filter_phys - logical , pointer :: dwind_2d - logical , pointer :: breed_vortex_inline - logical , pointer :: range_warn - logical , pointer :: fill - logical , pointer :: fill_dp - logical , pointer :: fill_wz - logical , pointer :: check_negative - logical , pointer :: non_ortho - logical , pointer :: adiabatic - logical , pointer :: moist_phys - logical , pointer :: do_Held_Suarez - logical , pointer :: do_reed_physics - logical , pointer :: reed_cond_only - logical , pointer :: reproduce_sum - logical , pointer :: adjust_dry_mass - logical , pointer :: fv_debug - logical , pointer :: srf_init - logical , pointer :: mountain - logical , pointer :: remap_t - logical , pointer :: z_tracer - - logical , pointer :: old_divg_damp - logical , pointer :: fv_land - logical , pointer :: nudge - logical , pointer :: nudge_ic - logical , pointer :: ncep_ic - logical , pointer :: nggps_ic - logical , pointer :: ecmwf_ic - logical , pointer :: gfs_phil - logical , pointer :: agrid_vel_rst - logical , pointer :: use_new_ncep - logical , pointer :: use_ncep_phy - logical , pointer :: fv_diag_ic - logical , pointer :: external_ic - logical , pointer :: external_eta - logical , pointer :: read_increment - character(len=128) , pointer :: res_latlon_dynamics - character(len=128) , pointer :: res_latlon_tracers - logical , pointer :: hydrostatic - logical , pointer :: phys_hydrostatic - logical , pointer :: use_hydro_pressure - logical , pointer :: do_uni_zfull !miz - logical , pointer :: adj_mass_vmr ! f1p - logical , pointer :: hybrid_z - logical , pointer :: Make_NH - logical , pointer :: make_hybrid_z - logical , pointer :: nudge_qv - real, pointer :: add_noise - - integer , pointer :: a2b_ord - integer , pointer :: c2l_ord - - integer, pointer :: ndims - - real(kind=R_GRID), pointer :: dx_const - real(kind=R_GRID), pointer :: dy_const - real(kind=R_GRID), pointer :: deglon_start, deglon_stop, & ! boundaries of latlon patch - deglat_start, deglat_stop - real(kind=R_GRID), pointer :: deglat - - logical, pointer :: nested, twowaynest - logical, pointer :: regional - integer, pointer :: bc_update_interval - integer, pointer :: parent_tile, refinement, nestbctype, nestupdate, nsponge, ioffset, joffset - real, pointer :: s_weight, update_blend - - integer, pointer :: layout(:), io_layout(:) - - integer :: ntilesMe ! Number of tiles on this process =1 for now - #ifdef OVERLOAD_R4 real :: too_big = 1.E8 #else real :: too_big = 1.E35 #endif - public :: fv_init, fv_end + public :: fv_control_init, fv_end integer, public :: ngrids = 1 - integer, public, allocatable :: pelist_all(:) - integer :: commID, max_refinement_of_global = 1. - integer :: gid - - real :: umax = 350. !< max wave speed for grid_type>3 - integer :: parent_grid_num = -1 - - integer :: halo_update_type = 1 !< 1 for two-interfaces non-block - !< 2 for block - !< 3 for four-interfaces non-block - + integer :: commID, global_commID + integer :: halo_update_type = 1 ! 1 for two-interfaces non-block + ! 2 for block + ! 3 for four-interfaces non-block ! version number of this module ! Include variable "version" to be written to log file. @@ -366,287 +184,847 @@ module fv_control_mod contains !------------------------------------------------------------------------------- -!>@brief The subroutine 'fv_init' initializes FV3. -!>@details It allocates memory, sets up MPI and processor lists, -!! sets up the grid, and controls FV3 namelist parameters. - subroutine fv_init(Atm, dt_atmos, grids_on_this_pe, p_split) - - type(fv_atmos_type), allocatable, intent(inout), target :: Atm(:) - real, intent(in) :: dt_atmos - logical, allocatable, intent(INOUT) :: grids_on_this_pe(:) - integer, intent(INOUT) :: p_split - - integer :: i, j, k, n, p - real :: sdt - -! tracers - integer :: num_family !< output of register_tracers - - integer :: isc_p, iec_p, jsc_p, jec_p, isg, ieg, jsg, jeg, upoff, jind - integer :: ic, jc - - gid = mpp_pe() - call init_nesting(Atm, grids_on_this_pe, p_split) - - !This call is needed to set up the pointers for fv_current_grid, even for a single-grid run - !call switch_current_Atm(Atm(1), .false.) - call setup_pointers(Atm(1)) - -! Start up MPI - - !call mp_assign_gid - - ! Initialize timing routines - call timing_init - call timing_on('TOTAL') - - ! Setup the run from namelist - ntilesMe = size(Atm(:)) !Full number of Atm arrays; one less than number of grids, if multiple grids - - call run_setup(Atm,dt_atmos, grids_on_this_pe, p_split) ! initializes domain_decomp - - do n=1,ntilesMe - - !In a single-grid run this will still be needed to correctly set the domain - call switch_current_Atm(Atm(n)) - call setup_pointers(Atm(n)) - target_lon = target_lon * pi/180. - target_lat = target_lat * pi/180. - -!-------------------------------------------------- -! override number of tracers by reading field_table -!-------------------------------------------------- - - !not sure if this works with multiple grids - call tm_register_tracers (MODEL_ATMOS, ncnst, nt_prog, pnats, num_family) - if(is_master()) then - write(*,*) 'ncnst=', ncnst,' num_prog=',nt_prog,' pnats=',pnats,' dnats=',dnats,' num_family=',num_family - print*, '' - endif - - if (grids_on_this_pe(n)) then - call allocate_fv_atmos_type(Atm(n), Atm(n)%bd%isd, Atm(n)%bd%ied, Atm(n)%bd%jsd, Atm(n)%bd%jed, & - Atm(n)%bd%isc, Atm(n)%bd%iec, Atm(n)%bd%jsc, Atm(n)%bd%jec, & - npx, npy, npz, ndims, ncnst, ncnst-pnats, ng, .false., grids_on_this_pe(n), ngrids) - - if (grids_on_this_pe(n)) then - - call switch_current_Atm(Atm(n)) - call setup_pointers(Atm(n)) - - if ( (Atm(n)%bd%iec-Atm(n)%bd%isc+1).lt.4 .or. (Atm(n)%bd%jec-Atm(n)%bd%jsc+1).lt.4 ) then - if (is_master()) write(*,'(6I6)') Atm(n)%bd%isc, Atm(n)%bd%iec, Atm(n)%bd%jsc, Atm(n)%bd%jec, n - call mpp_error(FATAL,'Domain Decomposition: Cubed Sphere compute domain has a & - &minium requirement of 4 points in X and Y, respectively') - end if - - endif - - !!CLEANUP: Convenience pointers - Atm(n)%gridstruct%nested => Atm(n)%neststruct%nested - Atm(n)%gridstruct%grid_type => Atm(n)%flagstruct%grid_type - Atm(n)%flagstruct%grid_number => Atm(n)%grid_number - Atm(n)%gridstruct%regional => Atm(n)%flagstruct%regional - - call init_grid(Atm(n), grid_name, grid_file, npx, npy, npz, ndims, ntiles, ng) - - ! Initialize the SW (2D) part of the model - !!!CLEANUP: this call could definitely use some cleaning up - call grid_utils_init(Atm(n), npx, npy, npz, non_ortho, grid_type, c2l_ord) - - !!!CLEANUP: Are these correctly writing out on all pes? - if ( is_master() ) then - sdt = dt_atmos/real(n_split*k_split*abs(p_split)) - write(*,*) ' ' - write(*,*) 'Divergence damping Coefficients' - write(*,*) 'For small dt=', sdt - write(*,*) 'External mode del-2 (m**2/s)=', d_ext*Atm(n)%gridstruct%da_min_c/sdt - write(*,*) 'Internal mode del-2 SMAG dimensionless coeff=', dddmp - write(*,*) 'Internal mode del-2 background diff=', d2_bg*Atm(n)%gridstruct%da_min_c/sdt - - if (nord==1) then - write(*,*) 'Internal mode del-4 background diff=', d4_bg - write(*,*) 'Vorticity del-4 (m**4/s)=', (vtdm4*Atm(n)%gridstruct%da_min)**2/sdt*1.E-6 - endif - if (nord==2) write(*,*) 'Internal mode del-6 background diff=', d4_bg - if (nord==3) write(*,*) 'Internal mode del-8 background diff=', d4_bg - write(*,*) 'tracer del-2 diff=', trdm2 - - write(*,*) 'Vorticity del-4 (m**4/s)=', (vtdm4*Atm(n)%gridstruct%da_min)**2/sdt*1.E-6 - write(*,*) 'beta=', beta - write(*,*) ' ' - endif - - - Atm(n)%ts = 300. - Atm(n)%phis = too_big - ! The following statements are to prevent the phatom corner regions from - ! growing instability - Atm(n)%u = 0. - Atm(n)%v = 0. - Atm(n)%ua = too_big - Atm(n)%va = too_big - - else !this grid is NOT defined on this pe - - !Allocate dummy arrays - call allocate_fv_atmos_type(Atm(n), Atm(n)%bd%isd, Atm(n)%bd%ied, Atm(n)%bd%jsd, Atm(n)%bd%jed, & - Atm(n)%bd%isc, Atm(n)%bd%iec, Atm(n)%bd%jsc, Atm(n)%bd%jec, & - npx, npy, npz, ndims, ncnst, ncnst-pnats, ng, .true., .false., ngrids) - - !Need to SEND grid_global to any child grids; this is received in setup_aligned_nest in fv_grid_tools - if (Atm(n)%neststruct%nested) then - - call mpp_get_global_domain( Atm(n)%parent_grid%domain, & - isg, ieg, jsg, jeg) - - !FIXME: Should replace this by generating the global grid (or at least one face thereof) on the - ! nested PEs instead of sending it around. - if (gid == Atm(n)%parent_grid%pelist(1)) then - call mpp_send(Atm(n)%parent_grid%grid_global(isg-ng:ieg+1+ng,jsg-ng:jeg+1+ng,1:2,parent_tile), & - size(Atm(n)%parent_grid%grid_global(isg-ng:ieg+1+ng,jsg-ng:jeg+1+ng,1:2,parent_tile)), & - Atm(n)%pelist(1)) !send to p_ind in setup_aligned_nest - call mpp_sync_self() - endif - - if (Atm(n)%neststruct%twowaynest) then - - !This in reality should be very simple. With the - ! restriction that only the compute domain data is - ! sent from the coarse grid, we can compute - ! exactly which coarse grid cells should use - ! which nested-grid data. We then don't need to send around p_ind. - - Atm(n)%neststruct%ind_update_h = -99999 - - if (Atm(n)%parent_grid%tile == Atm(n)%neststruct%parent_tile) then - - isc_p = Atm(n)%parent_grid%bd%isc - iec_p = Atm(n)%parent_grid%bd%iec - jsc_p = Atm(n)%parent_grid%bd%jsc - jec_p = Atm(n)%parent_grid%bd%jec - upoff = Atm(n)%neststruct%upoff - - Atm(n)%neststruct%jsu = jsc_p - Atm(n)%neststruct%jeu = jsc_p-1 - do j=jsc_p,jec_p+1 - if (j < joffset+upoff) then - do i=isc_p,iec_p+1 - Atm(n)%neststruct%ind_update_h(i,j,2) = -9999 - enddo - Atm(n)%neststruct%jsu = Atm(n)%neststruct%jsu + 1 - elseif (j > joffset + (npy-1)/refinement - upoff) then - do i=isc_p,iec_p+1 - Atm(n)%neststruct%ind_update_h(i,j,2) = -9999 - enddo - else - jind = (j - joffset)*refinement + 1 - do i=isc_p,iec_p+1 - Atm(n)%neststruct%ind_update_h(i,j,2) = jind - enddo - if ( (j < joffset + (npy-1)/refinement - upoff) .and. j <= jec_p) Atm(n)%neststruct%jeu = j - endif - !write(mpp_pe()+4000,*) j, joffset, upoff, Atm(n)%neststruct%ind_update_h(isc_p,j,2) - enddo - - Atm(n)%neststruct%isu = isc_p - Atm(n)%neststruct%ieu = isc_p-1 - do i=isc_p,iec_p+1 - if (i < ioffset+upoff) then - Atm(n)%neststruct%ind_update_h(i,:,1) = -9999 - Atm(n)%neststruct%isu = Atm(n)%neststruct%isu + 1 - elseif (i > ioffset + (npx-1)/refinement - upoff) then - Atm(n)%neststruct%ind_update_h(i,:,1) = -9999 - else - Atm(n)%neststruct%ind_update_h(i,:,1) = (i-ioffset)*refinement + 1 - if ( (i < ioffset + (npx-1)/refinement - upoff) .and. i <= iec_p) Atm(n)%neststruct%ieu = i - end if - !write(mpp_pe()+5000,*) i, ioffset, upoff, Atm(n)%neststruct%ind_update_h(i,jsc_p,1) - enddo - - end if - - - end if - - endif - endif - end do - - ! Initialize restart functions - call fv_restart_init() - + subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) + + type(fv_atmos_type), allocatable, intent(inout), target :: Atm(:) + real, intent(in) :: dt_atmos + integer, intent(OUT) :: this_grid + logical, allocatable, intent(OUT) :: grids_on_this_pe(:) + + integer, intent(INOUT) :: p_split + character(100) :: pe_list_name, errstring + integer :: n, npes, pecounter, i, num_family, ntiles_nest_all + integer, allocatable :: global_pelist(:) + integer, dimension(MAX_NNEST) :: grid_pes = 0 + integer, dimension(MAX_NNEST) :: grid_coarse = -1 + integer, dimension(MAX_NNEST) :: nest_refine = 3 + integer, dimension(MAX_NNEST) :: nest_ioffsets = -999, nest_joffsets = -999 + integer, dimension(MAX_NNEST) :: all_npx = 0 + integer, dimension(MAX_NNEST) :: all_npy = 0 + integer, dimension(MAX_NNEST) :: all_npz = 0 + integer, dimension(MAX_NNEST) :: all_ntiles = 0 + integer, dimension(MAX_NNEST) :: all_twowaynest = 0 ! > 0 implies two-way + !integer, dimension(MAX_NNEST) :: tile_fine = 0 + integer, dimension(MAX_NNEST) :: icount_coarse = 1 + integer, dimension(MAX_NNEST) :: jcount_coarse = 1 + integer, dimension(MAX_NNEST) :: nest_level = 0 + integer, dimension(MAX_NNEST) :: tile_coarse = 0 + integer, dimension(MAX_NTILE) :: npes_nest_tile = 0 + + real :: sdt + integer :: unit, ens_root_pe, tile_id(1) + + !!!!!!!!!! POINTERS FOR READING NAMELISTS !!!!!!!!!! + + !------------------------------------------ + ! Model Domain parameters + ! See fv_arrays.F90 for descriptions + !------------------------------------------ + !CLEANUP module pointers + character(len=80) , pointer :: grid_name + character(len=120), pointer :: grid_file + integer, pointer :: grid_type + integer , pointer :: hord_mt + integer , pointer :: kord_mt + integer , pointer :: kord_wz + integer , pointer :: hord_vt + integer , pointer :: hord_tm + integer , pointer :: hord_dp + integer , pointer :: kord_tm + integer , pointer :: hord_tr + integer , pointer :: kord_tr + real , pointer :: scale_z + real , pointer :: w_max + real , pointer :: z_min + real , pointer :: lim_fac + + integer , pointer :: nord + integer , pointer :: nord_tr + real , pointer :: dddmp + real , pointer :: d2_bg + real , pointer :: d4_bg + real , pointer :: vtdm4 + real , pointer :: trdm2 + real , pointer :: d2_bg_k1 + real , pointer :: d2_bg_k2 + real , pointer :: d2_divg_max_k1 + real , pointer :: d2_divg_max_k2 + real , pointer :: damp_k_k1 + real , pointer :: damp_k_k2 + integer , pointer :: n_zs_filter + integer , pointer :: nord_zs_filter + logical , pointer :: full_zs_filter + + logical , pointer :: RF_fast + logical , pointer :: consv_am + logical , pointer :: do_sat_adj + logical , pointer :: do_f3d + logical , pointer :: no_dycore + logical , pointer :: convert_ke + logical , pointer :: do_vort_damp + logical , pointer :: use_old_omega + ! PG off centering: + real , pointer :: beta + integer , pointer :: n_sponge + real , pointer :: d_ext + integer , pointer :: nwat + logical , pointer :: warm_start + logical , pointer :: inline_q + real , pointer :: shift_fac + logical , pointer :: do_schmidt, do_cube_transform + real(kind=R_GRID) , pointer :: stretch_fac + real(kind=R_GRID) , pointer :: target_lat + real(kind=R_GRID) , pointer :: target_lon + + logical , pointer :: reset_eta + real , pointer :: p_fac + real , pointer :: a_imp + integer , pointer :: n_split + real , pointer :: fac_n_spl + real , pointer :: fhouri + ! Default + integer , pointer :: m_split + integer , pointer :: k_split + logical , pointer :: use_logp + + integer , pointer :: q_split + integer , pointer :: print_freq + logical , pointer :: write_3d_diags + + integer , pointer :: npx + integer , pointer :: npy + integer , pointer :: npz + character(len=24), pointer :: npz_type + integer , pointer :: npz_rst + + integer , pointer :: ncnst + integer , pointer :: pnats + integer , pointer :: dnats + integer , pointer :: dnrts + integer , pointer :: ntiles + integer , pointer :: nf_omega + integer , pointer :: fv_sg_adj + real , pointer :: sg_cutoff + + integer , pointer :: na_init + logical , pointer :: nudge_dz + real , pointer :: p_ref + real , pointer :: dry_mass + integer , pointer :: nt_prog + integer , pointer :: nt_phys + real , pointer :: tau_h2o + + real , pointer :: delt_max + real , pointer :: d_con + real , pointer :: ke_bg + real , pointer :: consv_te + real , pointer :: tau + real , pointer :: rf_cutoff + logical , pointer :: filter_phys + logical , pointer :: dwind_2d + logical , pointer :: breed_vortex_inline + logical , pointer :: range_warn + logical , pointer :: fill + logical , pointer :: fill_dp + logical , pointer :: fill_wz + logical , pointer :: fill_gfs + logical , pointer :: check_negative + logical , pointer :: non_ortho + logical , pointer :: adiabatic + logical , pointer :: moist_phys + logical , pointer :: do_Held_Suarez + logical , pointer :: do_reed_physics + logical , pointer :: reed_cond_only + logical , pointer :: reproduce_sum + logical , pointer :: adjust_dry_mass + logical , pointer :: fv_debug + logical , pointer :: srf_init + logical , pointer :: mountain + logical , pointer :: remap_t + logical , pointer :: z_tracer + + logical , pointer :: old_divg_damp + logical , pointer :: fv_land + logical , pointer :: nudge + logical , pointer :: nudge_ic + logical , pointer :: ncep_ic + logical , pointer :: nggps_ic + logical , pointer :: ecmwf_ic + logical , pointer :: gfs_phil + logical , pointer :: agrid_vel_rst + logical , pointer :: use_new_ncep + logical , pointer :: use_ncep_phy + logical , pointer :: fv_diag_ic + logical , pointer :: external_ic + logical , pointer :: external_eta + logical , pointer :: read_increment + logical , pointer :: hydrostatic + logical , pointer :: phys_hydrostatic + logical , pointer :: use_hydro_pressure + logical , pointer :: do_uni_zfull !miz + logical , pointer :: adj_mass_vmr ! f1p + logical , pointer :: hybrid_z + logical , pointer :: Make_NH + logical , pointer :: make_hybrid_z + logical , pointer :: nudge_qv + real, pointer :: add_noise + logical , pointer :: butterfly_effect + + integer , pointer :: a2b_ord + integer , pointer :: c2l_ord + + integer, pointer :: ndims + + real(kind=R_GRID), pointer :: dx_const + real(kind=R_GRID), pointer :: dy_const + real(kind=R_GRID), pointer :: deglon_start, deglon_stop, & ! boundaries of latlon patch + deglat_start, deglat_stop + real(kind=R_GRID), pointer :: deglat + + logical, pointer :: nested, twowaynest + logical, pointer :: regional + integer, pointer :: bc_update_interval + integer, pointer :: nrows_blend + logical, pointer :: regional_bcs_from_gsi + logical, pointer :: write_restart_with_bcs + integer, pointer :: parent_tile, refinement, nestbctype, nestupdate, nsponge, ioffset, joffset + real, pointer :: s_weight, update_blend + + integer, pointer :: layout(:), io_layout(:) + + !!!!!!!!!! END POINTERS !!!!!!!!!!!!!!!!!!!!!!!!!!!! + + this_grid = -1 ! default + call mp_assign_gid + ens_root_pe = mpp_root_pe() + + ! 1. read nesting namelists + call read_namelist_nest_nml + call read_namelist_fv_nest_nml + + ! 2. Set up Atm and PElists + + ngrids = 1 + do n=2,MAX_NNEST + if (grid_coarse(n) <= 0) then + exit + endif + ngrids = ngrids + 1 + enddo + allocate(Atm(ngrids)) + npes = mpp_npes() ! now on global pelist + + allocate(global_pelist(npes)) + call mpp_get_current_pelist(global_pelist, commID=global_commID) ! for commID + + + allocate(grids_master_procs(ngrids)) + pecounter = 0 + allocate(grids_on_this_pe(ngrids)) + grids_on_this_pe(:) = .false. + + do n=1,ngrids + + if (ngrids == 1 .or. grid_pes(n) == 0) then + grid_pes(n) = npes - sum(grid_pes) + if (grid_pes(n) == 0) then + if ( n > 1 ) then + call mpp_error(FATAL, 'Only one zero entry in grid_pes permitted.') + else + grid_pes(n) = npes + endif + endif + endif + + allocate(Atm(n)%pelist(grid_pes(n))) + grids_master_procs(n) = pecounter + do i=1,grid_pes(n) + if (pecounter >= npes) then + if (mpp_pe() == 0) then + print*, 'ngrids = ', ngrids, ', grid_pes = ', grid_pes(1:ngrids) + endif + call mpp_error(FATAL, 'grid_pes assigns more PEs than are available.') + endif + Atm(n)%pelist(i) = pecounter + ens_root_pe !TODO PELIST set up by mpp_define_nest_domains??? + pecounter = pecounter + 1 + Atm(n)%npes_this_grid = grid_pes(n) + enddo + Atm(n)%grid_number = n + + !TODO: we are required to use PE name for reading INTERNAL namelist + ! and the actual file name for EXTERNAL namelists. Need to clean up this code + if (n == 1) then + pe_list_name = '' + else + write(pe_list_name,'(A4, I2.2)') 'nest', n + endif + call mpp_declare_pelist(Atm(n)%pelist, pe_list_name) + !If nest need to re-initialize internal NML + if (n > 1) then + Atm(n)%nml_filename = 'input_'//trim(pe_list_name)//'.nml' + else + Atm(n)%nml_filename = 'input.nml' + endif + if (.not. file_exist(Atm(n)%nml_filename)) then + call mpp_error(FATAL, "Could not find nested grid namelist "//Atm(n)%nml_filename) + endif + enddo + + do n=1,ngrids + !ONE grid per pe + if (ANY(mpp_pe() == Atm(n)%pelist)) then + if (this_grid > 0) then + print*, mpp_pe(), this_grid, n + call mpp_error(FATAL, " Grid assigned to multiple pes") + endif + call mpp_set_current_pelist(Atm(n)%pelist) + call setup_master(Atm(n)%pelist) + this_grid = n + grids_on_this_pe(n) = .true. + endif + Atm(n)%neststruct%nested = ( grid_coarse(n) > 0 ) + + if (Atm(n)%neststruct%nested) then + if ( grid_coarse(n) > ngrids .or. grid_coarse(n) == n .or. grid_coarse(n) < 1) then + write(errstring,'(2(A,I3))') "Could not find parent grid #", grid_coarse(n), ' for grid #', n + call mpp_error(FATAL, errstring) + endif + Atm(n)%parent_grid => Atm(grid_coarse(n)) + + Atm(n)%neststruct%ioffset = nest_ioffsets(n) + Atm(n)%neststruct%joffset = nest_joffsets(n) + Atm(n)%neststruct%parent_tile = tile_coarse(n) + Atm(n)%neststruct%refinement = nest_refine(n) + + else + + Atm(n)%neststruct%ioffset = -999 + Atm(n)%neststruct%joffset = -999 + Atm(n)%neststruct%parent_tile = -1 + Atm(n)%neststruct%refinement = -1 + + endif + + enddo + + if (pecounter /= npes) then + if (mpp_pe() == 0) then + print*, 'npes = ', npes, ', grid_pes = ', grid_pes(1:ngrids) + call mpp_error(FATAL, 'grid_pes in fv_nest_Nml does not assign all of the available PEs') + endif + endif + + ! 3pre. + call timing_init + call timing_on('TOTAL') + + ! 3. Read namelists, do option processing and I/O + + call set_namelist_pointers(Atm(this_grid)) + call fv_diag_init_gn(Atm(this_grid)) +#ifdef INTERNAL_FILE_NML + if (this_grid .gt. 1) then + write(Atm(this_grid)%nml_filename,'(A4, I2.2)') 'nest', this_grid + if (.not. file_exist('input_'//trim(Atm(this_grid)%nml_filename)//'.nml')) then + call mpp_error(FATAL, "Could not find nested grid namelist "//'input_'//trim(Atm(this_grid)%nml_filename)//'.nml') + endif + else + Atm(this_grid)%nml_filename = '' + endif + call read_input_nml(Atm(this_grid)%nml_filename) !re-reads into internal namelist +#endif + call read_namelist_fv_grid_nml + call read_namelist_fv_core_nml(Atm(this_grid)) ! do options processing here too? +#ifdef MULTI_GASES + call read_namelist_multi_gases_nml(Atm(this_grid)%nml_filename, & + Atm(this_grid)%flagstruct%ncnst, Atm(this_grid)%flagstruct%nwat) +#endif + call read_namelist_test_case_nml(Atm(this_grid)%nml_filename) + call mpp_get_current_pelist(Atm(this_grid)%pelist, commID=commID) ! for commID + call mp_start(commID,halo_update_type) + + ! 4. Set up domains + ! This should make use of new fv_nest_nml namelists + !!!! TODO TEMPORARY location for this code + if (Atm(this_grid)%neststruct%nested) then + + if ( Atm(this_grid)%flagstruct%consv_te > 0.) then + call mpp_error(FATAL, 'The global energy fixer cannot be used on a nested grid. consv_te must be set to 0.') + end if + + if (mod(Atm(this_grid)%flagstruct%npx-1 , Atm(this_grid)%neststruct%refinement) /= 0 .or. & + mod(Atm(this_grid)%flagstruct%npy-1, Atm(this_grid)%neststruct%refinement) /= 0) then + call mpp_error(FATAL, 'npx or npy not an even refinement of its coarse grid.') + endif + + endif + + if (Atm(this_grid)%flagstruct%regional) then + if ( Atm(this_grid)%flagstruct%consv_te > 0.) then + call mpp_error(FATAL, 'The global energy fixer cannot be used on a regional grid. consv_te must be set to 0.') + end if + endif + + !Now only one call to mpp_define_nest_domains for ALL nests + ! set up nest_level, tile_fine, tile_coarse + ! need number of tiles, npx, and npy on each grid + ! need to define a global PElist + + all_ntiles(this_grid) = ntiles + call mpp_max(all_ntiles, ngrids, global_pelist) + + all_npx(this_grid) = npx + call mpp_max(all_npx, ngrids, global_pelist) + + all_npy(this_grid) = npy + call mpp_max(all_npy, ngrids, global_pelist) + + all_npz(this_grid) = npz + call mpp_max(all_npz, ngrids, global_pelist) + + if (Atm(this_grid)%neststruct%twowaynest) all_twowaynest(this_grid) = 1 + call mpp_max(all_twowaynest, ngrids, global_pelist) + ntiles_nest_all = 0 + do n=1,ngrids + if (n/=this_grid) then + Atm(n)%flagstruct%npx = all_npx(n) + Atm(n)%flagstruct%npy = all_npy(n) + Atm(n)%flagstruct%npz = all_npz(n) + Atm(n)%flagstruct%ntiles = all_ntiles(n) + Atm(n)%neststruct%twowaynest = (all_twowaynest(n) > 0) ! disabled + endif + npes_nest_tile(ntiles_nest_all+1:ntiles_nest_all+all_ntiles(n)) = & + Atm(n)%npes_this_grid / all_ntiles(n) + ntiles_nest_all = ntiles_nest_all + all_ntiles(n) + + if (n > 1) then + tile_fine(n) = all_ntiles(n) + tile_fine(n-1) + if (tile_coarse(n) < 1) then !set automatically; only works for single tile parents + tile_coarse(n) = tile_fine(grid_coarse(n)) + endif + icount_coarse(n) = all_npx(n)/nest_refine(n) + jcount_coarse(n) = all_npy(n)/nest_refine(n) + nest_level(n) = nest_level(grid_coarse(n)) + 1 + else + tile_fine(n) = all_ntiles(n) + nest_level(n) = 0 + endif + enddo + + if (mpp_pe() == 0 .and. ngrids > 1) then + print*, ' NESTING TREE' + do n=1,ngrids + write(*,'(12i4)') n, nest_level(n), nest_ioffsets(n), nest_joffsets(n), icount_coarse(n), jcount_coarse(n), tile_fine(n), tile_coarse(n), nest_refine(n), all_ntiles(n), all_npx(n), all_npy(n) + write(*,*) + enddo + print*, npes_nest_tile(1:ntiles_nest_all) + print*, '' + endif + + ! 5. domain_decomp() + call domain_decomp(Atm(this_grid)%flagstruct%npx,Atm(this_grid)%flagstruct%npy,Atm(this_grid)%flagstruct%ntiles,& + Atm(this_grid)%flagstruct%grid_type,Atm(this_grid)%neststruct%nested, & + Atm(this_grid)%layout,Atm(this_grid)%io_layout,Atm(this_grid)%bd,Atm(this_grid)%tile_of_mosaic, & + Atm(this_grid)%gridstruct%square_domain,Atm(this_grid)%npes_per_tile,Atm(this_grid)%domain, & + Atm(this_grid)%domain_for_coupler,Atm(this_grid)%num_contact,Atm(this_grid)%pelist) + call set_domain(Atm(this_grid)%domain) + call broadcast_domains(Atm,Atm(this_grid)%pelist,size(Atm(this_grid)%pelist)) + do n=1,ngrids + tile_id = mpp_get_tile_id(Atm(n)%domain) + Atm(n)%global_tile = tile_id(1) ! only meaningful locally + Atm(n)%npes_per_tile = size(Atm(n)%pelist)/Atm(n)%flagstruct%ntiles ! domain decomp doesn't set this globally + enddo + + ! 6. Set up domain and Atm structure + call tm_register_tracers (MODEL_ATMOS, Atm(this_grid)%flagstruct%ncnst, Atm(this_grid)%flagstruct%nt_prog, & + Atm(this_grid)%flagstruct%pnats, num_family) + if(is_master()) then + write(*,*) 'ncnst=', ncnst,' num_prog=',Atm(this_grid)%flagstruct%nt_prog,' pnats=',Atm(this_grid)%flagstruct%pnats,' dnats=',dnats,& + ' num_family=',num_family + print*, '' + endif + if (dnrts < 0) dnrts = dnats + + do n=1,ngrids + !FIXME still setting up dummy structures for other grids for convenience reasons + !isc, etc. set in domain_decomp + call allocate_fv_atmos_type(Atm(n), & + Atm(n)%bd%isd, Atm(n)%bd%ied, & + Atm(n)%bd%jsd, Atm(n)%bd%jed, & + Atm(n)%bd%isc, Atm(n)%bd%iec, & + Atm(n)%bd%jsc, Atm(n)%bd%jec, & + Atm(n)%flagstruct%npx, Atm(n)%flagstruct%npy, Atm(n)%flagstruct%npz, & + Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ncnst, Atm(n)%flagstruct%ncnst-Atm(n)%flagstruct%pnats, & + n/=this_grid, n==this_grid, ngrids) !TODO don't need both of the last arguments + enddo + if ( (Atm(this_grid)%bd%iec-Atm(this_grid)%bd%isc+1).lt.4 .or. (Atm(this_grid)%bd%jec-Atm(this_grid)%bd%jsc+1).lt.4 ) then + if (is_master()) write(*,'(6I6)') Atm(this_grid)%bd%isc, Atm(this_grid)%bd%iec, Atm(this_grid)%bd%jsc, Atm(this_grid)%bd%jec, this_grid + call mpp_error(FATAL,'Domain Decomposition: Cubed Sphere compute domain has a & + &minium requirement of 4 points in X and Y, respectively') + end if + + + !Tile_coarse is needed to determine which processors are needed to send around their + ! data for computing the interpolation coefficients + if (ngrids > 1) then + !reset to universal pelist + call mpp_set_current_pelist( global_pelist ) + !Except for npes_nest_tile all arrays should be just the nests and should NOT include the top level + call mpp_define_nest_domains(global_nest_domain, Atm(this_grid)%domain, & + ngrids-1, nest_level=nest_level(2:ngrids) , & + istart_coarse=nest_ioffsets(2:ngrids), jstart_coarse=nest_joffsets(2:ngrids), & + icount_coarse=icount_coarse(2:ngrids), jcount_coarse=jcount_coarse(2:ngrids), & + npes_nest_tile=npes_nest_tile(1:ntiles_nest_all), & + tile_fine=tile_fine(2:ngrids), tile_coarse=tile_coarse(2:ngrids), & + x_refine=nest_refine(2:ngrids), y_refine=nest_refine(2:ngrids), name="global_nest_domain") + call mpp_set_current_pelist(Atm(this_grid)%pelist) + + endif + + allocate(Atm(this_grid)%neststruct%child_grids(ngrids)) + do n=1,ngrids + Atm(this_grid)%neststruct%child_grids(n) = (grid_coarse(n) == this_grid) + allocate(Atm(n)%neststruct%do_remap_bc(ngrids)) + Atm(n)%neststruct%do_remap_bc(:) = .false. + enddo + Atm(this_grid)%neststruct%parent_proc = ANY(Atm(this_grid)%neststruct%child_grids) !ANY(tile_coarse == Atm(this_grid)%global_tile) + Atm(this_grid)%neststruct%child_proc = ASSOCIATED(Atm(this_grid)%parent_grid) !this means a nested grid + + if (ngrids > 1) call setup_update_regions + if (Atm(this_grid)%neststruct%nestbctype > 1) then + call mpp_error(FATAL, 'nestbctype > 1 not yet implemented') + Atm(this_grid)%neststruct%upoff = 0 + endif + + if (Atm(this_grid)%gridstruct%bounded_domain .and. is_master()) print*, & + ' Bounded domain: nested = ', Atm(this_grid)%neststruct%nested, ', regional = ', Atm(this_grid)%flagstruct%regional + + ! 7. Init_grid() (including two-way nesting) + call init_grid(Atm(this_grid), Atm(this_grid)%flagstruct%grid_name, Atm(this_grid)%flagstruct%grid_file, & + Atm(this_grid)%flagstruct%npx, Atm(this_grid)%flagstruct%npy, Atm(this_grid)%flagstruct%npz, Atm(this_grid)%flagstruct%ndims, Atm(this_grid)%flagstruct%ntiles, Atm(this_grid)%ng, tile_coarse) + + + ! 8. grid_utils_init() + ! Initialize the SW (2D) part of the model + call grid_utils_init(Atm(this_grid), Atm(this_grid)%flagstruct%npx, Atm(this_grid)%flagstruct%npy, Atm(this_grid)%flagstruct%npz, Atm(this_grid)%flagstruct%non_ortho, Atm(this_grid)%flagstruct%grid_type, Atm(this_grid)%flagstruct%c2l_ord) + + ! Finish up initialization; write damping coefficients dependent upon + + if ( is_master() ) then + sdt = dt_atmos/real(Atm(this_grid)%flagstruct%n_split*Atm(this_grid)%flagstruct%k_split*abs(p_split)) + write(*,*) ' ' + write(*,*) 'Divergence damping Coefficients' + write(*,*) 'For small dt=', sdt + write(*,*) 'External mode del-2 (m**2/s)=', Atm(this_grid)%flagstruct%d_ext*Atm(this_grid)%gridstruct%da_min_c/sdt + write(*,*) 'Internal mode del-2 SMAG dimensionless coeff=', Atm(this_grid)%flagstruct%dddmp + write(*,*) 'Internal mode del-2 background diff=', Atm(this_grid)%flagstruct%d2_bg*Atm(this_grid)%gridstruct%da_min_c/sdt + + if (nord==1) then + write(*,*) 'Internal mode del-4 background diff=', Atm(this_grid)%flagstruct%d4_bg + write(*,*) 'Vorticity del-4 (m**4/s)=', (Atm(this_grid)%flagstruct%vtdm4*Atm(this_grid)%gridstruct%da_min)**2/sdt*1.E-6 + endif + if (Atm(this_grid)%flagstruct%nord==2) write(*,*) 'Internal mode del-6 background diff=', Atm(this_grid)%flagstruct%d4_bg + if (Atm(this_grid)%flagstruct%nord==3) write(*,*) 'Internal mode del-8 background diff=', Atm(this_grid)%flagstruct%d4_bg + write(*,*) 'tracer del-2 diff=', Atm(this_grid)%flagstruct%trdm2 + + write(*,*) 'Vorticity del-4 (m**4/s)=', (Atm(this_grid)%flagstruct%vtdm4*Atm(this_grid)%gridstruct%da_min)**2/sdt*1.E-6 + write(*,*) 'beta=', Atm(this_grid)%flagstruct%beta + write(*,*) ' ' + endif + + +!!$ Atm(this_grid)%ts = 300. +!!$ Atm(this_grid)%phis = too_big +!!$ ! The following statements are to prevent the phantom corner regions from +!!$ ! growing instability +!!$ Atm(this_grid)%u = 0. +!!$ Atm(this_grid)%v = 0. +!!$ Atm(this_grid)%ua = too_big +!!$ Atm(this_grid)%va = too_big +!!$ + + !Initialize restart + call fv_restart_init() ! if ( reset_eta ) then ! do n=1, ntilesMe -! call set_eta(npz, Atm(n)%ks, ptop, Atm(n)%ak, Atm(n)%bk) +! call set_eta(npz, Atm(this_grid)%ks, ptop, Atm(this_grid)%ak, Atm(this_grid)%bk, Atm(this_grid)%flagstruct%npz_type) ! enddo ! if(is_master()) write(*,*) "Hybrid sigma-p coordinate has been reset" ! endif - if (ntilesMe > 1) call switch_current_Atm(Atm(1)) - if (ntilesMe > 1) call setup_pointers(Atm(1)) - end subroutine fv_init -!------------------------------------------------------------------------------- + contains +!>@brief The subroutine 'setup_namelist_pointers' associates the MODULE flag pointers +!! with the ARRAY flag variables for the grid active on THIS pe so the flags +!! can be read in from the namelist. + subroutine set_namelist_pointers(Atm) + type(fv_atmos_type), intent(INOUT), target :: Atm + + !This routine associates the MODULE flag pointers with the ARRAY flag variables for the grid active on THIS pe so the flags can be read in from the namelist. + + grid_type => Atm%flagstruct%grid_type + grid_name => Atm%flagstruct%grid_name + grid_file => Atm%flagstruct%grid_file + hord_mt => Atm%flagstruct%hord_mt + kord_mt => Atm%flagstruct%kord_mt + kord_wz => Atm%flagstruct%kord_wz + hord_vt => Atm%flagstruct%hord_vt + hord_tm => Atm%flagstruct%hord_tm + hord_dp => Atm%flagstruct%hord_dp + kord_tm => Atm%flagstruct%kord_tm + hord_tr => Atm%flagstruct%hord_tr + kord_tr => Atm%flagstruct%kord_tr + scale_z => Atm%flagstruct%scale_z + w_max => Atm%flagstruct%w_max + z_min => Atm%flagstruct%z_min + lim_fac => Atm%flagstruct%lim_fac + nord => Atm%flagstruct%nord + nord_tr => Atm%flagstruct%nord_tr + dddmp => Atm%flagstruct%dddmp + d2_bg => Atm%flagstruct%d2_bg + d4_bg => Atm%flagstruct%d4_bg + vtdm4 => Atm%flagstruct%vtdm4 + trdm2 => Atm%flagstruct%trdm2 + d2_bg_k1 => Atm%flagstruct%d2_bg_k1 + d2_bg_k2 => Atm%flagstruct%d2_bg_k2 + d2_divg_max_k1 => Atm%flagstruct%d2_divg_max_k1 + d2_divg_max_k2 => Atm%flagstruct%d2_divg_max_k2 + damp_k_k1 => Atm%flagstruct%damp_k_k1 + damp_k_k2 => Atm%flagstruct%damp_k_k2 + n_zs_filter => Atm%flagstruct%n_zs_filter + nord_zs_filter => Atm%flagstruct%nord_zs_filter + full_zs_filter => Atm%flagstruct%full_zs_filter + RF_fast => Atm%flagstruct%RF_fast + consv_am => Atm%flagstruct%consv_am + do_sat_adj => Atm%flagstruct%do_sat_adj + do_f3d => Atm%flagstruct%do_f3d + no_dycore => Atm%flagstruct%no_dycore + convert_ke => Atm%flagstruct%convert_ke + do_vort_damp => Atm%flagstruct%do_vort_damp + use_old_omega => Atm%flagstruct%use_old_omega + beta => Atm%flagstruct%beta + n_sponge => Atm%flagstruct%n_sponge + d_ext => Atm%flagstruct%d_ext + nwat => Atm%flagstruct%nwat + use_logp => Atm%flagstruct%use_logp + warm_start => Atm%flagstruct%warm_start + inline_q => Atm%flagstruct%inline_q + shift_fac => Atm%flagstruct%shift_fac + do_schmidt => Atm%flagstruct%do_schmidt + do_cube_transform => Atm%flagstruct%do_cube_transform + stretch_fac => Atm%flagstruct%stretch_fac + target_lat => Atm%flagstruct%target_lat + target_lon => Atm%flagstruct%target_lon + regional => Atm%flagstruct%regional + bc_update_interval => Atm%flagstruct%bc_update_interval + nrows_blend => Atm%flagstruct%nrows_blend + regional_bcs_from_gsi => Atm%flagstruct%regional_bcs_from_gsi + write_restart_with_bcs => Atm%flagstruct%write_restart_with_bcs + reset_eta => Atm%flagstruct%reset_eta + p_fac => Atm%flagstruct%p_fac + a_imp => Atm%flagstruct%a_imp + n_split => Atm%flagstruct%n_split + fac_n_spl => Atm%flagstruct%fac_n_spl + fhouri => Atm%flagstruct%fhouri + m_split => Atm%flagstruct%m_split + k_split => Atm%flagstruct%k_split + use_logp => Atm%flagstruct%use_logp + q_split => Atm%flagstruct%q_split + print_freq => Atm%flagstruct%print_freq + write_3d_diags => Atm%flagstruct%write_3d_diags + npx => Atm%flagstruct%npx + npy => Atm%flagstruct%npy + npz => Atm%flagstruct%npz + npz_type => Atm%flagstruct%npz_type + npz_rst => Atm%flagstruct%npz_rst + ncnst => Atm%flagstruct%ncnst + pnats => Atm%flagstruct%pnats + dnats => Atm%flagstruct%dnats + dnrts => Atm%flagstruct%dnrts + ntiles => Atm%flagstruct%ntiles + nf_omega => Atm%flagstruct%nf_omega + fv_sg_adj => Atm%flagstruct%fv_sg_adj + sg_cutoff => Atm%flagstruct%sg_cutoff + na_init => Atm%flagstruct%na_init + nudge_dz => Atm%flagstruct%nudge_dz + p_ref => Atm%flagstruct%p_ref + dry_mass => Atm%flagstruct%dry_mass + nt_prog => Atm%flagstruct%nt_prog + nt_phys => Atm%flagstruct%nt_phys + tau_h2o => Atm%flagstruct%tau_h2o + delt_max => Atm%flagstruct%delt_max + d_con => Atm%flagstruct%d_con + ke_bg => Atm%flagstruct%ke_bg + consv_te => Atm%flagstruct%consv_te + tau => Atm%flagstruct%tau + rf_cutoff => Atm%flagstruct%rf_cutoff + filter_phys => Atm%flagstruct%filter_phys + dwind_2d => Atm%flagstruct%dwind_2d + breed_vortex_inline => Atm%flagstruct%breed_vortex_inline + range_warn => Atm%flagstruct%range_warn + fill => Atm%flagstruct%fill + fill_dp => Atm%flagstruct%fill_dp + fill_wz => Atm%flagstruct%fill_wz + fill_gfs => Atm%flagstruct%fill_gfs + check_negative => Atm%flagstruct%check_negative + non_ortho => Atm%flagstruct%non_ortho + adiabatic => Atm%flagstruct%adiabatic + moist_phys => Atm%flagstruct%moist_phys + do_Held_Suarez => Atm%flagstruct%do_Held_Suarez + do_reed_physics => Atm%flagstruct%do_reed_physics + reed_cond_only => Atm%flagstruct%reed_cond_only + reproduce_sum => Atm%flagstruct%reproduce_sum + adjust_dry_mass => Atm%flagstruct%adjust_dry_mass + fv_debug => Atm%flagstruct%fv_debug + srf_init => Atm%flagstruct%srf_init + mountain => Atm%flagstruct%mountain + remap_t => Atm%flagstruct%remap_t + z_tracer => Atm%flagstruct%z_tracer + old_divg_damp => Atm%flagstruct%old_divg_damp + fv_land => Atm%flagstruct%fv_land + nudge => Atm%flagstruct%nudge + nudge_ic => Atm%flagstruct%nudge_ic + ncep_ic => Atm%flagstruct%ncep_ic + nggps_ic => Atm%flagstruct%nggps_ic + ecmwf_ic => Atm%flagstruct%ecmwf_ic + gfs_phil => Atm%flagstruct%gfs_phil + agrid_vel_rst => Atm%flagstruct%agrid_vel_rst + use_new_ncep => Atm%flagstruct%use_new_ncep + use_ncep_phy => Atm%flagstruct%use_ncep_phy + fv_diag_ic => Atm%flagstruct%fv_diag_ic + external_ic => Atm%flagstruct%external_ic + external_eta => Atm%flagstruct%external_eta + read_increment => Atm%flagstruct%read_increment + + hydrostatic => Atm%flagstruct%hydrostatic + phys_hydrostatic => Atm%flagstruct%phys_hydrostatic + use_hydro_pressure => Atm%flagstruct%use_hydro_pressure + do_uni_zfull => Atm%flagstruct%do_uni_zfull !miz + adj_mass_vmr => Atm%flagstruct%adj_mass_vmr !f1p + hybrid_z => Atm%flagstruct%hybrid_z + Make_NH => Atm%flagstruct%Make_NH + make_hybrid_z => Atm%flagstruct%make_hybrid_z + nudge_qv => Atm%flagstruct%nudge_qv + add_noise => Atm%flagstruct%add_noise + butterfly_effect => Atm%flagstruct%butterfly_effect + a2b_ord => Atm%flagstruct%a2b_ord + c2l_ord => Atm%flagstruct%c2l_ord + ndims => Atm%flagstruct%ndims + + dx_const => Atm%flagstruct%dx_const + dy_const => Atm%flagstruct%dy_const + deglon_start => Atm%flagstruct%deglon_start + deglon_stop => Atm%flagstruct%deglon_stop + deglat_start => Atm%flagstruct%deglat_start + deglat_stop => Atm%flagstruct%deglat_stop + + deglat => Atm%flagstruct%deglat + + nested => Atm%neststruct%nested + twowaynest => Atm%neststruct%twowaynest + parent_tile => Atm%neststruct%parent_tile + refinement => Atm%neststruct%refinement + nestbctype => Atm%neststruct%nestbctype + nestupdate => Atm%neststruct%nestupdate + nsponge => Atm%neststruct%nsponge + s_weight => Atm%neststruct%s_weight + ioffset => Atm%neststruct%ioffset + joffset => Atm%neststruct%joffset + update_blend => Atm%neststruct%update_blend + + layout => Atm%layout + io_layout => Atm%io_layout + end subroutine set_namelist_pointers + + + subroutine read_namelist_nest_nml + + integer :: f_unit, ios, ierr, dum + namelist /nest_nml/ dum ! ngrids, ntiles, nest_pes, p_split !emptied lmh 7may2019 -!>@brief The subroutine 'fv_end' terminates FV3, deallocates memory, -!! saves restart files, and stops I/O. - subroutine fv_end(Atm, grids_on_this_pe) +#ifdef INTERNAL_FILE_NML + read (input_nml_file,nest_nml,iostat=ios) + ierr = check_nml_error(ios,'nest_nml') +#else + f_unit=open_namelist_file() + rewind (f_unit) + read (f_unit,nest_nml,iostat=ios) + ierr = check_nml_error(ios,'nest_nml') + call close_file(f_unit) +#endif + if (ierr > 0) then + call mpp_error(FATAL, " &nest_nml is depreciated. Please use &fv_nest_nml instead.") + endif - type(fv_atmos_type), intent(inout) :: Atm(:) - logical, intent(INOUT) :: grids_on_this_pe(:) + end subroutine read_namelist_nest_nml - integer :: n + subroutine read_namelist_fv_nest_nml - call timing_off('TOTAL') - call timing_prt( gid ) + integer :: f_unit, ios, ierr + namelist /fv_nest_nml/ grid_pes, grid_coarse, tile_coarse, nest_refine, & + nest_ioffsets, nest_joffsets, p_split - call fv_restart_end(Atm, grids_on_this_pe) - call fv_io_exit() +#ifdef INTERNAL_FILE_NML + read (input_nml_file,fv_nest_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_nest_nml') +#else + f_unit=open_namelist_file() + rewind (f_unit) + read (f_unit,fv_nest_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_nest_nml') + call close_file(f_unit) +#endif - ! Free temporary memory from sw_core routines + end subroutine read_namelist_fv_nest_nml - ! Deallocate - call grid_utils_end + subroutine read_namelist_fv_grid_nml - do n = 1, ntilesMe - call deallocate_fv_atmos_type(Atm(n)) - end do + integer :: f_unit, ios, ierr + ! local version of these variables to allow PGI compiler to compile + character(len=80) :: grid_name = '' + character(len=120) :: grid_file = '' + namelist /fv_grid_nml/ grid_name, grid_file +#ifdef INTERNAL_FILE_NML + ! Read Main namelist + read (input_nml_file,fv_grid_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_grid_nml') +#else + f_unit=open_namelist_file() + rewind (f_unit) + ! Read Main namelist + read (f_unit,fv_grid_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_grid_nml') + call close_file (f_unit) +#endif + call write_version_number ( 'FV_CONTROL_MOD', version ) + unit = stdlog() + write(unit, nml=fv_grid_nml) - end subroutine fv_end -!------------------------------------------------------------------------------- + !Basic option processing + if (len_trim(grid_file) /= 0) Atm(this_grid)%flagstruct%grid_file = grid_file + if (len_trim(grid_name) /= 0) Atm(this_grid)%flagstruct%grid_name = grid_name + + + end subroutine read_namelist_fv_grid_nml + + subroutine read_namelist_fv_core_nml(Atm) + + type(fv_atmos_type), intent(inout) :: Atm + integer :: f_unit, ios, ierr + real :: dim0 = 180. ! base dimension + real :: dt0 = 1800. ! base time step + real :: ns0 = 5. ! base nsplit for base dimension + real :: dimx, dl, dp, dxmin, dymin, d_fac + real :: umax = 350. ! max wave speed for grid_type>3 + + integer :: n0split + + ! local version of these variables to allow PGI compiler to compile + character(len=128) :: res_latlon_dynamics = '' + character(len=128) :: res_latlon_tracers = '' -!>@brief The subroutine 'run_setup' initializes the run from a namelist. - subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) - type(fv_atmos_type), intent(inout), target :: Atm(:) - real, intent(in) :: dt_atmos - logical, intent(INOUT) :: grids_on_this_pe(:) - integer, intent(INOUT) :: p_split - !--- local variables --- - character(len=80) :: tracerName, errString - character(len=32) :: nested_grid_filename - integer :: ios, ierr, f_unit, unit - logical :: exists - - real :: dim0 = 180. !< base dimension - real :: dt0 = 1800. !< base time step - real :: ns0 = 5. !< base nsplit for base dimension - !< For cubed sphere 5 is better - !real :: umax = 350. ! max wave speed for grid_type>3 ! Now defined above - real :: dimx, dl, dp, dxmin, dymin, d_fac - - integer :: n0split - integer :: n, nn, i - - integer :: pe_counter - -! local version of these variables to allow PGI compiler to compile - character(len=128) :: res_latlon_dynamics = '' - character(len=128) :: res_latlon_tracers = '' - character(len=80) :: grid_name = '' - character(len=120) :: grid_file = '' !> \defgroup Parameters_List !! @{ !> ##A.1 Entries in fv\_core\_nml @@ -667,6 +1045,8 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !> \param[in] add\_noise] Real: amplitude of random thermal noise (in K) to add upon startup. Useful for perturbing initial conditions. -1 by default; disabled if 0 or negative. !! +!> \param[in] butterfly\_effect Logical: whether to flip the least-significant-bit of the lowest level temperature. False by default. +!! !> \param[in] adjust\_dry\_mass Logical: whether to adjust the global dry-air mass to the value set by dry\_mass. This is only done in an initialization step, particularly when using an initial condition from an external dataset, interpolated from another resolution (either horizontal or vertical), or when changing the topography, so that the global mass of the atmosphere matches some estimate of observed value. False by default. It is recommended to only set this to True when initializing the model. !! !> \param[in] breed\_vortex\_inline Logical: whether to bogus tropical cyclones into the model, which are specified by an external file. Options are set in fv\_nwp\_nudge\_nml. False by default. @@ -693,6 +1073,8 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !! !> \param[in] npz\_rst Integer: If using a restart file with a different number of vertical levels, set npz\_rst to be the number of levels in your restart file. The model will then remap the restart file data to the vertical coordinates specified by npz. 0 by default; if 0 or equal to npz no remapping is done. !! +!> \param[in] npz\_type Character(24): controls which level setup to use when several vertical level configurations use the same number of levels. These are defined in fv\_eta.F90; check there for details for defaults (ie. empty npz\_type) and alternates. Empty by default. +!! !> \param[in] nudge Logical: whether to use the nudging towards the state in some externally-supplied file (such as from reanalysis or another simulation). Further nudging options are set in fv\_nwp\_nudge\_nml. False by default. !! !> \param[in] nudge\_dz Logical: during the adiabatic initialization (na\_init > 0), if set to .true. delz is nudged back to the value specified in the initial conditions, instead of nudging the temperature back to the initial value. Nudging delz is simpler (faster), doesn't require consideration of the virtual temperature effect, and may be more stable. .false. by default. @@ -739,6 +1121,8 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !! !> \param[in] dnats Integer: The number of tracers which are not to be advected by the dynamical core, but still passed into the dynamical core; the last dnats+pnats tracers in field\_table are not advected. 0 by default. !! +!> \param[in] dnrts Integer: the Number of non-remapped consituents. Only makes sense for dnrts <= dnat. +!! !> \param[in] dwind\_2d Logical: whether to use a simpler \& faster algorithm for interpolating the A-grid (cell-centered) wind tendencies computed from the physics to the D-grid. Typically, the A-grid wind tendencies are first converted in 3D cartesian coordinates and then interpolated before converting back to 2D local coordinates. When this option enabled, a much simpler but less accurate 2D interpolation is used. False by default. !! !> \param[in] fill Logical: Fills in negative tracer values by taking positive tracers from the cells above and below. This option is useful when the physical parameterizations produced negatives. False by default. @@ -775,6 +1159,8 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !! !> \param[in] do\_schmidt Logical: Whether to enable grid stretching and rotation using stretch\_fac, target\_lat, and target\_lon..false. by default. !! +!> \param[in] do\_cube\_transform logical: applies same transform as when do\_schmidt = True but rotates from the north pole instead of the south pole. If both do\_cube\_transform and do\_schmidt are True the model throws a fatal error. False by default. +!! !> \param[in] dx\_const Real: on a doubly-periodic grid (grid\_type = 4) specifies the (uniform) grid-cell-width in the x-direction, in meters. 1000 by default. !! !> \param[in] dy\_const Real: on a doubly-periodic grid (grid\_type = 4) specifies the (uniform) grid-cell-width in the y-direction, in meters. 1000 by default. @@ -799,12 +1185,6 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !! !> \param[in] twowaynest Logical: whether to use two-way nesting, the process by which the nested-grid solution can feed back onto the coarse-grid solution. False by default. !! -!> \param[in] parent\_grid\_num Integer: Number of the parent to this nested grid. The coarsest grid in a simulation is numbered 1; further nested grids are numbered sequentially. Required to be a positive value if nested = True. Unless you are nesting inside of nested grids or running multiple (coarse) grids that themselves do not interact, this should be set to 1. -1 by default, indicating that this grid does not have a parent grid. -!! -!> \param[in] parent\_tile Integer: number of the tile (ie. face) in which this nested grid is found in its parent. Required to be a positive value if nested = true. If the parent grid is not a cubed sphere, or itself is a nested grid, this should be set to 1. If the parent grid has been rotated (using do\_schmidt) with the intent of centering the nested grid at target\_lat and target\_lon, then parent\_tile should be set to 6. 1 by default. -!! -!> \param[in] refinement Integer: refinement ratio of the nested grid. This is the number of times that each coarse-grid cell face will be divided into smaller segments on the nested grid. Required to be a positive integer if nested = true. Nested grids are aligned with the coarse grid, so non-integer refinements are not permitted. 3 by default. -!! !> \param[in] nestupdate Integer: type of nested-grid update to use; details are given in model/fv\_nesting.F90. 0 by default. !! !>###A.1.7 Solver options @@ -829,6 +1209,8 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !! !> \param[in] fv\_sg\_adj Integer: timescale (in seconds) at which to remove two-delta-z instability when the local (between two adjacent levels) Richardson number is less than 1. This is achieved by local mixing, which conserves mass, momentum, and total energy. Values of 0 or smaller disable this feature. If n\_sponge $< 0$ then the mixing is applied only to the top n\_sponge layers of the domain. Set to -1 (inactive) by default. Proper range is 0 to 3600. !! +!> \param[in] sg\_cutoff Real (in Pa): the pressure above which the 2dz filter in fv_sg is applied, similar to the behavior of rf_cutoff. If this value is set to a non-negative value it overrides the value in n\_sponge. -1 by default, which disables this option and uses n_sponge instead. +!! !> \param[in] halo\_update\_type Integer: which scheme to use for halo updates in multiprocessor simulations. If set to 1 non-blocking updates are used, which can improve simulation efficiency on some systems. Otherwise, blocking halo updates are performed. 1 by default. !! !> \param[in] hord\_mt Integer: horizontal advection scheme for momentum fluxes. A complete list of kord options is given in the table below. 9 by default, which uses the third-order piecewise-parabolic method with the monotonicity constraint of Huynh, which is less diffusive than other constraints. For hydrostatic simulation, 8 (the L04 monotonicity constraint) is recommended; for nonhydrostatic simulation, the completely unlimited (``linear'' or non-monotone) PPM scheme is recommended. If no monotonicity constraint is applied, enabling the flux damping (do\_vort\_damp = .true.) is highly recommended to control grid-scale noise. It is also recommended that hord\_mt, hord\_vt, hord\_tm, and hord\_dp use the same value, to ensure consistenttransport of all dynamical fields, unless a positivity constraint on mass advection (hord\_dp) is desired. @@ -974,17 +1356,35 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !! !> \param[in] alpha Real: In certain shallow-water test cases specifies the angle (in fractions of a rotation, so 0.25 is a 45-degree rotation) through which the basic state is rotated. 0 by default. !! -!>##A.7 Entries in nest\_nml +!>##A.7 Entries in fv\_nest\_nml +!! +!> \param[in] grid\_pes Integer(:): Number of processor cores (or MPI ranks) assigned to each grid. The sum of the assigned cores in this array must sum to the number of cores allocated to the model. Up to one of the first ngrids entries may be 0, in which case all remaining cores are assigned to it. 0 by default. +!! +!> \param[in] grid_coarse Integer(:): Grid number of parent grid, if any. The first element is ignored; positive values in any successive element indicates that a new nested grid is to be created; the model continues to create grids until it finds a non-positive element. The total number of grids, ngrids, is determined from this array. -1 by default. +!! +!> \param[in] tile\_coarse Integer(:): Absolute index of the tile (sub-component of a grid) a given grid is nested within. The first element is ignored. This is only useful when the parent grid has multiple tiles, such as for the six-tile cubed-sphere grid, or if the parent is a multi-tile nest. If grid_coarse(n) is a single-tile domain the coarse-grid tile can be determined automatically by setting it to a non-positive value. 0 by default. +!! +!> \param[in] nest\_refine Integer(:): Refinement ratio, relative to the parent, for each nest. The first element is ignored. FV3 supports any integer refinement ratio for nesting, although values larger than 6 may cause stability issues. 3 by default. +!! +!> \param[in] nest\_ioffsets integer(:): Index within a tile or grid of the coarse grid cell closest to the local left-hand boundary with a nested grid cell within it. For example, if you have a coarse grid which is 12 grid cells long, and nest\_ioffset for its child is 3, then the nested grid will have its lower-left corner located in the i=3 grid cell. +!! +!> \param[in] nest\_joffsets Integer(:): as for nest\_ioffsets but in the local y-direction. +!! +!>##A.8 Entries in fv\_diag\_column\_nml +!! +!> \param[in] do\_diag\_sonde Logical: whether to enable sounding output specified by the namelist variables diag_sonde* . The output is intended to match the format of text files produced by the University of Wyoming text soundings, except that output is on uninterpolated model levels. False by default. !! -!> \param[in] ngrids Integer: number of grids in this simulation. 1 by default. (The variable ntiles has the same effect, but its use is not recommended as it can be confused with the six tiles of the cubed sphere, which in this case form only one grid.) +!> \param[in] sound\_freq integer: Frequency, in hours, of diag_sonde column output. 3 by default. !! -!> \param[in] nest\_pes Integer(100): array carrying number of PEs assigned to each grid, in order. Must be set if ngrids > 1. +!> \param[in] runname Character(100): Name of the simulation. This is only to add the runname to the output to enable a user to easily determine the simulation that produced a certain sounding file. !! -!> \param[in] p\_split Integer: number of times to sub-cycle dynamics, performing nested-grid BC interpolation and (if twowaynest ==.true.) two-way updating at the end of each set of dynamics calls. If p\_split > 1 the user should decrease k\_split appropriately so the remapping and dynamics time steps remain the same. 1 by default. +!> \param[in] diag\_sonde\_lon\_in Real (MAX_DIAG_COLUMN): List of longitudes (in degrees) for the desired sounding points. Longitudes may be used as [0, 360] (GFDL style) or [-180,180] (NCAR style). !! -!>##A.8 Entries in nggps\_diag\_nml +!> \param[in] diag\_sonde\_lat\_in Real(MAX_DIAG_COLUMN): As for diag_sonde_lon_in except for latitudes. !! -!> \param[in] fdiag Real(1028): Array listing the diagnostic output times (in hours) for the GFS physics. This can either be a list of times after initialization, or an interval if only the first entry is nonzero. All 0 by default, which will result in no outputs. +!> \param[in] diag\_sonde\_names Character(MAX_DIAG_COLUMN): List of names for each sounding point. +!! +!> \param[in] do\_diag\_debug Logical: analogous to the functionality of do\_diag\_sonde, as well as including similar parameters: diag\_debug\_lon\_in, diag\_debug\_lat\_in, and diag\_debug\_names, but outputs different diagnostics at every dt_atmos more appropriate for debugging problems that are known to occur at a specific point in the model. This functionality is only implemented for the nonhydrostatic solver !! !>##A.9 Entries in atmos\_model\_nml (for UFS) !! @@ -1002,709 +1402,254 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !! !> \param[in] regional Logical: Controls whether this is a regional domain (and thereby needs external BC inputs !! -!> \param[in] bc_update_interval Integer: Default setting for interval (hours) between external regional BC data files. +!> \param[in] bc\_update\_interval Integer: Default setting for interval (hours) between external regional BC data files. +!! +!> \param[in] update\_blend Real: Weights to control how much blending is done during two-way nesting update. Default is 1. +!! +!> \param[in] regional\_bcs\_from\_gsi Logical: whether DA-updated BC files are used. Default is false. +!! +!> \param[in] write\_restart\_with\_bcs Logical: whether to write restart files with BC rows. !! -!> \param[in] read_increment Logical: Read in analysis increment and add to restart following are namelist parameters for Stochastic Energy Baskscatter dissipation estimate. This is useful as part of a data-assimilation cycling system or to use native restarts from the six-tile first guess, after which the analysis increment can be applied. +!> \param[in] nrows\_blend Integer: Number of blending rows in the files. !! -!> \param[in] do_sat_adj Logical: The same as fast_sat_adj = .false. has fast saturation adjustments +!> \param[in] read\_increment Logical: Read in analysis increment and add to restart following are namelist parameters for Stochastic Energy Baskscatter dissipation estimate. This is useful as part of a data-assimilation cycling system or to use native restarts from the six-tile first guess, after which the analysis increment can be applied. +!! +!> \param[in] do\_sat\_adj Logical: The same as fast\_sat\_adj = .false. has fast saturation adjustments !! !! !! !! !> @{ - namelist /fv_grid_nml/ grid_name, grid_file - namelist /fv_core_nml/npx, npy, ntiles, npz, npz_rst, layout, io_layout, ncnst, nwat, & - use_logp, p_fac, a_imp, k_split, n_split, m_split, q_split, print_freq, write_3d_diags, do_schmidt, & - hord_mt, hord_vt, hord_tm, hord_dp, hord_tr, shift_fac, stretch_fac, target_lat, target_lon, & - kord_mt, kord_wz, kord_tm, kord_tr, fv_debug, fv_land, nudge, do_sat_adj, do_f3d, & - external_ic, read_increment, ncep_ic, nggps_ic, ecmwf_ic, use_new_ncep, use_ncep_phy, fv_diag_ic, & - external_eta, res_latlon_dynamics, res_latlon_tracers, scale_z, w_max, z_min, lim_fac, & - dddmp, d2_bg, d4_bg, vtdm4, trdm2, d_ext, delt_max, beta, non_ortho, n_sponge, & - warm_start, adjust_dry_mass, mountain, d_con, ke_bg, nord, nord_tr, convert_ke, use_old_omega, & - dry_mass, grid_type, do_Held_Suarez, do_reed_physics, reed_cond_only, & - consv_te, fill, filter_phys, fill_dp, fill_wz, consv_am, RF_fast, & - range_warn, dwind_2d, inline_q, z_tracer, reproduce_sum, adiabatic, do_vort_damp, no_dycore, & - tau, tau_h2o, rf_cutoff, nf_omega, hydrostatic, fv_sg_adj, breed_vortex_inline, & - na_init, nudge_dz, hybrid_z, Make_NH, n_zs_filter, nord_zs_filter, full_zs_filter, reset_eta, & - pnats, dnats, a2b_ord, remap_t, p_ref, d2_bg_k1, d2_bg_k2, & - c2l_ord, dx_const, dy_const, umax, deglat, & - deglon_start, deglon_stop, deglat_start, deglat_stop, & - phys_hydrostatic, use_hydro_pressure, make_hybrid_z, old_divg_damp, add_noise, & - nested, twowaynest, parent_grid_num, parent_tile, nudge_qv, & - refinement, nestbctype, nestupdate, nsponge, s_weight, & - ioffset, joffset, check_negative, nudge_ic, halo_update_type, gfs_phil, agrid_vel_rst, & - do_uni_zfull, adj_mass_vmr, fac_n_spl, fhouri, regional, bc_update_interval - - namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size -#ifdef MULTI_GASES - namelist /multi_gases_nml/ rilist,cpilist -#endif - - - pe_counter = mpp_root_pe() - -! Make alpha = 0 the default: - alpha = 0. - bubble_do = .false. - test_case = 11 ! (USGS terrain) + namelist /fv_core_nml/npx, npy, ntiles, npz, npz_type, npz_rst, layout, io_layout, ncnst, nwat, & + use_logp, p_fac, a_imp, k_split, n_split, m_split, q_split, print_freq, write_3d_diags, & + do_schmidt, do_cube_transform, & + hord_mt, hord_vt, hord_tm, hord_dp, hord_tr, shift_fac, stretch_fac, target_lat, target_lon, & + kord_mt, kord_wz, kord_tm, kord_tr, fv_debug, fv_land, nudge, do_sat_adj, do_f3d, & + external_ic, read_increment, ncep_ic, nggps_ic, ecmwf_ic, use_new_ncep, use_ncep_phy, fv_diag_ic, & + external_eta, res_latlon_dynamics, res_latlon_tracers, scale_z, w_max, z_min, lim_fac, & + dddmp, d2_bg, d4_bg, vtdm4, trdm2, d_ext, delt_max, beta, non_ortho, n_sponge, & + warm_start, adjust_dry_mass, mountain, d_con, ke_bg, nord, nord_tr, convert_ke, use_old_omega, & + dry_mass, grid_type, do_Held_Suarez, do_reed_physics, reed_cond_only, & + consv_te, fill, filter_phys, fill_dp, fill_wz, fill_gfs, consv_am, RF_fast, & + range_warn, dwind_2d, inline_q, z_tracer, reproduce_sum, adiabatic, do_vort_damp, no_dycore, & + tau, tau_h2o, rf_cutoff, nf_omega, hydrostatic, fv_sg_adj, sg_cutoff, breed_vortex_inline, & + na_init, nudge_dz, hybrid_z, Make_NH, n_zs_filter, nord_zs_filter, full_zs_filter, reset_eta, & + pnats, dnats, dnrts, a2b_ord, remap_t, p_ref, d2_bg_k1, d2_bg_k2, & + c2l_ord, dx_const, dy_const, umax, deglat, & + deglon_start, deglon_stop, deglat_start, deglat_stop, & + phys_hydrostatic, use_hydro_pressure, make_hybrid_z, old_divg_damp, add_noise, butterfly_effect, & + nested, twowaynest, nudge_qv, & + nestbctype, nestupdate, nsponge, s_weight, & + check_negative, nudge_ic, halo_update_type, gfs_phil, agrid_vel_rst, & + do_uni_zfull, adj_mass_vmr, fac_n_spl, fhouri, update_blend, regional, bc_update_interval, & + regional_bcs_from_gsi, write_restart_with_bcs, nrows_blend #ifdef INTERNAL_FILE_NML -! Read Main namelist - read (input_nml_file,fv_grid_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_grid_nml') + ! Read FVCORE namelist + read (input_nml_file,fv_core_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_core_nml') + ! Reset input_file_nml to default behavior (CHECK do we still need this???) + !call read_input_nml #else - f_unit=open_namelist_file() - rewind (f_unit) -! Read Main namelist - read (f_unit,fv_grid_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_grid_nml') - call close_file(f_unit) -#endif + f_unit = open_namelist_file(Atm%nml_filename) + ! Read FVCORE namelist + read (f_unit,fv_core_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_core_nml') + call close_file(f_unit) +#endif + call write_version_number ( 'FV_CONTROL_MOD', version ) + unit = stdlog() + write(unit, nml=fv_core_nml) + + if (len_trim(res_latlon_dynamics) /= 0) Atm%flagstruct%res_latlon_dynamics = res_latlon_dynamics + if (len_trim(res_latlon_tracers) /= 0) Atm%flagstruct%res_latlon_tracers = res_latlon_tracers + + !*** single tile for Cartesian grids + if (grid_type>3) then + ntiles=1 + non_ortho = .false. + nf_omega = 0 + endif + + if (.not. (nested .or. regional)) Atm%neststruct%npx_global = npx + + ! Define n_split if not in namelist + if (ntiles==6) then + dimx = 4.0*(npx-1) + if ( hydrostatic ) then + if ( npx >= 120 ) ns0 = 6 + else + if ( npx <= 45 ) then + ns0 = 6 + elseif ( npx <=90 ) then + ns0 = 7 + else + ns0 = 8 + endif + endif + else + dimx = max ( npx, 2*(npy-1) ) + endif + + if (grid_type < 4) then + n0split = nint ( ns0*abs(dt_atmos)*dimx/(dt0*dim0) + 0.49 ) + elseif (grid_type == 4 .or. grid_type == 7) then + n0split = nint ( 2.*umax*dt_atmos/sqrt(dx_const**2 + dy_const**2) + 0.49 ) + elseif (grid_type == 5 .or. grid_type == 6) then + if (grid_type == 6) then + deglon_start = 0.; deglon_stop = 360. + endif + dl = (deglon_stop-deglon_start)*pi/(180.*(npx-1)) + dp = (deglat_stop-deglat_start)*pi/(180.*(npy-1)) + + dxmin=dl*radius*min(cos(deglat_start*pi/180.-Atm%bd%ng*dp), & + cos(deglat_stop *pi/180.+Atm%bd%ng*dp)) + dymin=dp*radius + n0split = nint ( 2.*umax*dt_atmos/sqrt(dxmin**2 + dymin**2) + 0.49 ) + endif + n0split = max ( 1, n0split ) + + if ( n_split == 0 ) then + n_split = nint( real(n0split)/real(k_split*abs(p_split)) * stretch_fac + 0.5 ) + if(is_master()) write(*,*) 'For k_split (remapping)=', k_split + if(is_master()) write(*,198) 'n_split is set to ', n_split, ' for resolution-dt=',npx,npy,ntiles,dt_atmos + else + if(is_master()) write(*,199) 'Using n_split from the namelist: ', n_split + endif + if (is_master() .and. n == 1 .and. abs(p_split) > 1) then + write(*,199) 'Using p_split = ', p_split + endif + + if (old_divg_damp) then + if (is_master()) write(*,*) " fv_control: using AM2/AM3 damping methods " + d2_bg_k1 = 6. ! factor for d2_bg (k=1) - default(4.) + d2_bg_k2 = 4. ! factor for d2_bg (k=2) - default(2.) + d2_divg_max_k1 = 0.02 ! d2_divg max value (k=1) - default(0.05) + d2_divg_max_k2 = 0.01 ! d2_divg max value (k=2) - default(0.02) + damp_k_k1 = 0. ! damp_k value (k=1) - default(0.05) + damp_k_k2 = 0. ! damp_k value (k=2) - default(0.025) + elseif (n_sponge == 0 ) then + if ( d2_bg_k1 > 1. ) d2_bg_k1 = 0.20 + if ( d2_bg_k2 > 1. ) d2_bg_k2 = 0.015 + endif + + if ( .not.hydrostatic ) then + if ( m_split==0 ) then + m_split = 1. + abs(dt_atmos)/real(k_split*n_split*abs(p_split)) + if (abs(a_imp) < 0.5) then + if(is_master()) write(*,199) 'm_split is set to ', m_split + endif + endif + if(is_master()) then + write(*,*) 'Off center implicit scheme param=', a_imp + write(*,*) ' p_fac=', p_fac + endif + endif + + if(is_master()) then + if (n_sponge >= 0) write(*,199) 'Using n_sponge : ', n_sponge + write(*,197) 'Using non_ortho : ', non_ortho + endif + +197 format(A,l7) +198 format(A,i2.2,A,i4.4,'x',i4.4,'x',i1.1,'-',f9.3) +199 format(A,i3.3) + + !if (.not. (nested .or. regional)) alpha = alpha*pi !TODO for test_case_nml + + !allocate(Atm%neststruct%child_grids(size(Atm))) !TODO want to remove + !Atm(N)%neststruct%child_grids = .false. + + target_lon = target_lon * pi/180. + target_lat = target_lat * pi/180. + + end subroutine read_namelist_fv_core_nml + + subroutine setup_update_regions + + integer :: isu, ieu, jsu, jeu ! update regions + integer :: isc, jsc, iec, jec + integer :: upoff + + isc = Atm(this_grid)%bd%isc + jsc = Atm(this_grid)%bd%jsc + iec = Atm(this_grid)%bd%iec + jec = Atm(this_grid)%bd%jec + + upoff = Atm(this_grid)%neststruct%upoff + + do n=2,ngrids + if (tile_coarse(n) == Atm(this_grid)%global_tile) then + + isu = nest_ioffsets(n) + ieu = isu + icount_coarse(n) - 1 + jsu = nest_joffsets(n) + jeu = jsu + jcount_coarse(n) - 1 + + !update offset adjustment + isu = isu + upoff + ieu = ieu - upoff + jsu = jsu + upoff + jeu = jeu - upoff + + !restriction to current domain +!!$ !!! DEBUG CODE +!!$ if (Atm(this_grid)%flagstruct%fv_debug) then +!!$ write(*,'(I, A, 4I)') mpp_pe(), 'SETUP_UPDATE_REGIONS : ', isu, jsu, ieu, jeu +!!$ write(*,'(I, A, 4I)') mpp_pe(), 'SETUP_UPDATE_REGIONS 2: ', isc, jsc, iec, jsc +!!$ endif +!!$ !!! END DEBUG CODE + if (isu > iec .or. ieu < isc .or. & + jsu > jec .or. jeu < jsc ) then + isu = -999 ; jsu = -999 ; ieu = -1000 ; jeu = -1000 + else + isu = max(isu,isc) ; jsu = max(jsu,jsc) + ieu = min(ieu,iec) ; jeu = min(jeu,jec) + endif +!!$ !!! DEBUG CODE +!!$ if (Atm(this_grid)%flagstruct%fv_debug) & +!!$ write(*,'(I, A, 4I)') mpp_pe(), 'SETUP_UPDATE_REGIONS 3: ', isu, jsu, ieu, jeu +!!$ !!! END DEBUG CODE + + Atm(n)%neststruct%isu = isu + Atm(n)%neststruct%ieu = ieu + Atm(n)%neststruct%jsu = jsu + Atm(n)%neststruct%jeu = jeu + endif + enddo + + end subroutine setup_update_regions + + end subroutine fv_control_init - call write_version_number ( 'FV_CONTROL_MOD', version ) - unit = stdlog() - write(unit, nml=fv_grid_nml) +!------------------------------------------------------------------------------- + + !>@brief The subroutine 'fv_end' terminates FV3, deallocates memory, +!! saves restart files, and stops I/O. + subroutine fv_end(Atm, this_grid, restart_endfcst) - do n=1,size(Atm) + type(fv_atmos_type), intent(inout) :: Atm(:) + integer, intent(IN) :: this_grid + logical, intent(in) :: restart_endfcst - call switch_current_Atm(Atm(n), .false.) - call setup_pointers(Atm(n)) - Atm(n)%grid_number = n - if (grids_on_this_pe(n)) then - call fv_diag_init_gn(Atm(n)) - endif + integer :: n -#ifdef INTERNAL_FILE_NML - ! Set input_file_nml for correct parent/nest initialization - if (n > 1) then - write(nested_grid_filename,'(A4, I2.2)') 'nest', n - call read_input_nml(nested_grid_filename) - endif - ! Read FVCORE namelist - read (input_nml_file,fv_core_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_core_nml') -#ifdef MULTI_GASES - if( is_master() ) print *,' enter multi_gases: ncnst = ',ncnst - allocate (rilist(0:ncnst)) - allocate (cpilist(0:ncnst)) - rilist = 0.0 - cpilist = 0.0 - rilist(0) = rdgas - rilist(1) = rvgas - cpilist(0) = cp_air - cpilist(1) = 4*cp_air - ! Read multi_gases namelist - read (input_nml_file,multi_gases_nml,iostat=ios) - ierr = check_nml_error(ios,'multi_gases_nml') -#endif - ! Read Test_Case namelist - read (input_nml_file,test_case_nml,iostat=ios) - ierr = check_nml_error(ios,'test_case_nml') + call timing_off('TOTAL') + call timing_prt( mpp_pe() ) - ! Reset input_file_nml to default behavior - call read_input_nml -#else - if (size(Atm) == 1) then - f_unit = open_namelist_file() - else if (n == 1) then - f_unit = open_namelist_file('input.nml') - else - write(nested_grid_filename,'(A10, I2.2, A4)') 'input_nest', n, '.nml' - f_unit = open_namelist_file(nested_grid_filename) - endif - - ! Read FVCORE namelist - read (f_unit,fv_core_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_core_nml') + call fv_restart_end(Atm(this_grid), restart_endfcst) + call fv_io_exit() -#ifdef MULTI_GASES - if( is_master() ) print *,' enter multi_gases: ncnst = ',ncnst - allocate (rilist(0:ncnst)) - allocate (cpilist(0:ncnst)) - rilist = 0.0 - cpilist = 0.0 - rilist(0) = rdgas - rilist(1) = rvgas - cpilist(0) = cp_air - cpilist(1) = 4*cp_air - ! Read multi_gases namelist - rewind (f_unit) - read (f_unit,multi_gases_nml,iostat=ios) - ierr = check_nml_error(ios,'multi_gases_nml') -#endif - ! Read Test_Case namelist - rewind (f_unit) - read (f_unit,test_case_nml,iostat=ios) - ierr = check_nml_error(ios,'test_case_nml') - call close_file(f_unit) -#endif - write(unit, nml=fv_core_nml) - write(unit, nml=test_case_nml) -#ifdef MULTI_GASES - write(unit, nml=multi_gases_nml) - call multi_gases_init(ncnst,nwat) -#endif + ! Free temporary memory from sw_core routines + ! Deallocate + call grid_utils_end - if (len_trim(grid_file) /= 0) Atm(n)%flagstruct%grid_file = grid_file - if (len_trim(grid_name) /= 0) Atm(n)%flagstruct%grid_name = grid_name - if (len_trim(res_latlon_dynamics) /= 0) Atm(n)%flagstruct%res_latlon_dynamics = res_latlon_dynamics - if (len_trim(res_latlon_tracers) /= 0) Atm(n)%flagstruct%res_latlon_tracers = res_latlon_tracers - - !*** single tile for Cartesian grids - if (grid_type>3) then - ntiles=1 - non_ortho = .false. - nf_omega = 0 - endif - - if (.not. (nested .or. regional)) Atm(n)%neststruct%npx_global = npx - - ! Define n_split if not in namelist - if (ntiles == 6) then - dimx = 4.0*(npx-1) - if ( hydrostatic ) then - if ( npx >= 120 ) ns0 = 6 - else - if ( npx <= 45 ) then - ns0 = 6 - elseif ( npx <= 90 ) then - ns0 = 7 - else - ns0 = 8 - endif - endif - else - dimx = max ( npx, 2*(npy-1) ) - endif - - if (grid_type < 4) then - n0split = nint ( ns0*abs(dt_atmos)*dimx/(dt0*dim0) + 0.49 ) - elseif (grid_type == 4 .or. grid_type == 7) then - n0split = nint ( 2.*umax*dt_atmos/sqrt(dx_const**2 + dy_const**2) + 0.49 ) - elseif (grid_type == 5 .or. grid_type == 6) then - if (grid_type == 6) then - deglon_start = 0.; deglon_stop = 360. - endif - dl = (deglon_stop-deglon_start)*pi/(180.*(npx-1)) - dp = (deglat_stop-deglat_start)*pi/(180.*(npy-1)) - - dxmin=dl*radius*min(cos(deglat_start*pi/180.-ng*dp), & - cos(deglat_stop *pi/180.+ng*dp)) - dymin=dp*radius - n0split = nint ( 2.*umax*dt_atmos/sqrt(dxmin**2 + dymin**2) + 0.49 ) - endif - n0split = max ( 1, n0split ) - - if ( n_split == 0 ) then - n_split = nint( real(n0split)/real(k_split*abs(p_split)) * stretch_fac + 0.5 ) - if(is_master()) write(*,*) 'For k_split (remapping)=', k_split - if(is_master()) write(*,198) 'n_split is set to ', n_split, ' for resolution-dt=',npx,npy,ntiles,dt_atmos - else - if(is_master()) write(*,199) 'Using n_split from the namelist: ', n_split - endif - if (is_master() .and. n == 1 .and. abs(p_split) > 1) then - write(*,199) 'Using p_split = ', p_split - endif - - if (Atm(n)%neststruct%nested) then - do i=1,n-1 - if (Atm(i)%grid_number == parent_grid_num) then - Atm(n)%parent_grid => Atm(i) - exit - end if - end do - if (.not. associated(Atm(n)%parent_grid)) then - write(errstring,'(2(A,I3))') "Could not find parent grid #", parent_grid_num, ' for grid #', n - call mpp_error(FATAL, errstring) - end if - - !Note that if a gnomonic grid has a parent it is a NESTED gnomonic grid and therefore only has one tile - if ( Atm(n)%parent_grid%flagstruct%grid_type < 3 .and. & - .not. associated(Atm(n)%parent_grid%parent_grid)) then - if (parent_tile > 6 .or. parent_tile < 1) then - call mpp_error(FATAL, 'parent tile must be between 1 and 6 if the parent is a cubed-sphere grid') - end if - else - if (parent_tile /= 1) then - call mpp_error(FATAL, 'parent tile must be 1 if the parent is not a cubed-sphere grid') - end if - end if - - if ( refinement < 1 ) call mpp_error(FATAL, 'grid refinement must be positive') - - if (nestupdate == 1 .or. nestupdate == 2) then - - if (mod(npx-1,refinement) /= 0 .or. mod(npy-1,refinement) /= 0) then - call mpp_error(WARNING, 'npx-1 or npy-1 is not evenly divisible by the refinement ratio; averaging update cannot be mass-conservative.') - end if - - end if - - if ( consv_te > 0.) then - call mpp_error(FATAL, 'The global energy fixer cannot be used on a nested grid. consv_te must be set to 0.') - end if - - Atm(n)%neststruct%refinement_of_global = Atm(n)%neststruct%refinement * Atm(n)%parent_grid%neststruct%refinement_of_global - max_refinement_of_global = max(Atm(n)%neststruct%refinement_of_global,max_refinement_of_global) - Atm(n)%neststruct%npx_global = Atm(n)%neststruct%refinement * Atm(n)%parent_grid%neststruct%npx_global - - else - Atm(n)%neststruct%ioffset = -999 - Atm(n)%neststruct%joffset = -999 - Atm(n)%neststruct%parent_tile = -1 - Atm(n)%neststruct%refinement = -1 - end if - - if (Atm(n)%neststruct%nested) then - if (Atm(n)%flagstruct%grid_type >= 4 .and. Atm(n)%parent_grid%flagstruct%grid_type >= 4) then - Atm(n)%flagstruct%dx_const = Atm(n)%parent_grid%flagstruct%dx_const / real(Atm(n)%neststruct%refinement) - Atm(n)%flagstruct%dy_const = Atm(n)%parent_grid%flagstruct%dy_const / real(Atm(n)%neststruct%refinement) - end if - end if - - -!---------------------------------------- -! Adjust divergence damping coefficients: -!---------------------------------------- -! d_fac = real(n0split)/real(n_split) -! dddmp = dddmp * d_fac -! d2_bg = d2_bg * d_fac -! d4_bg = d4_bg * d_fac -! d_ext = d_ext * d_fac -! vtdm4 = vtdm4 * d_fac - if (old_divg_damp) then - if (is_master()) write(*,*) " fv_control: using original values for divergence damping " - d2_bg_k1 = 6. ! factor for d2_bg (k=1) - default(4.) - d2_bg_k2 = 4. ! factor for d2_bg (k=2) - default(2.) - d2_divg_max_k1 = 0.02 ! d2_divg max value (k=1) - default(0.05) - d2_divg_max_k2 = 0.01 ! d2_divg max value (k=2) - default(0.02) - damp_k_k1 = 0. ! damp_k value (k=1) - default(0.05) - damp_k_k2 = 0. ! damp_k value (k=2) - default(0.025) - elseif (n_sponge == 0 ) then - if ( d2_bg_k1 > 1. ) d2_bg_k1 = 0.20 - if ( d2_bg_k2 > 1. ) d2_bg_k2 = 0.015 - endif - -! if ( beta < 1.e-5 ) beta = 0. ! beta < 0 is used for non-hydrostatic "one_grad_p" - - if ( .not.hydrostatic ) then - if ( m_split==0 ) then - m_split = 1. + abs(dt_atmos)/real(k_split*n_split*abs(p_split)) - if (abs(a_imp) < 0.5) then - if(is_master()) write(*,199) 'm_split is set to ', m_split - endif - endif - if(is_master()) then - write(*,*) 'Off center implicit scheme param=', a_imp - write(*,*) ' p_fac=', p_fac - endif - endif - - if(is_master()) then - if (n_sponge >= 0) write(*,199) 'Using n_sponge : ', n_sponge - write(*,197) 'Using non_ortho : ', non_ortho - endif - - 197 format(A,l7) - 198 format(A,i2.2,A,i4.4,'x',i4.4,'x',i1.1,'-',f9.3) - 199 format(A,i3.3) - - if (.not. (nested .or. regional)) alpha = alpha*pi - - - allocate(Atm(n)%neststruct%child_grids(size(Atm))) - Atm(N)%neststruct%child_grids = .false. - - !Broadcast data - - !Check layout - - enddo - - !Set pelists - do n=1,size(Atm) - if (ANY(Atm(n)%pelist == gid)) then - call mpp_set_current_pelist(Atm(n)%pelist) - call mpp_get_current_pelist(Atm(n)%pelist, commID=commID) - call mp_start(commID,halo_update_type) - endif - - if (Atm(n)%neststruct%nested) then - Atm(n)%neststruct%parent_proc = ANY(Atm(n)%parent_grid%pelist == gid) - Atm(n)%neststruct%child_proc = ANY(Atm(n)%pelist == gid) - endif - enddo - - do n=1,size(Atm) - - call switch_current_Atm(Atm(n),.false.) - call setup_pointers(Atm(n)) - !! CLEANUP: WARNING not sure what changes to domain_decomp may cause - call domain_decomp(npx,npy,ntiles,grid_type,nested,Atm(n),layout,io_layout) - enddo - - !!! CLEANUP: This sets the pelist to ALL, which is also - !!! required for the define_nest_domains step in the next loop. - !!! Later the pelist must be reset to the 'local' pelist. - call broadcast_domains(Atm) - - do n=1,size(Atm) - call switch_current_Atm(Atm(n)) - call setup_pointers(Atm(n)) - - if (nested) then - if (mod(npx-1 , refinement) /= 0 .or. mod(npy-1, refinement) /= 0) & - call mpp_error(FATAL, 'npx or npy not an even refinement of its coarse grid.') - - !Pelist needs to be set to ALL (which should have been done - !in broadcast_domains) to get this to work - call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & - 7, parent_tile, & - 1, npx-1, 1, npy-1, & !Grid cells, not points - ioffset, ioffset + (npx-1)/refinement - 1, & - joffset, joffset + (npy-1)/refinement - 1, & - (/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? - call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & - 7, parent_tile, & - 1, npx-1, 1, npy-1, & !Grid cells, not points - ioffset, ioffset + (npx-1)/refinement - 1, & - joffset, joffset + (npy-1)/refinement - 1, & - (/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? -! (/ (i,i=0,mpp_npes()-1) /), extra_halo = 2, name="nest_domain_for_BC") !What pelist to use? - - Atm(parent_grid_num)%neststruct%child_grids(n) = .true. - - if (Atm(n)%neststruct%nestbctype > 1) then - - call mpp_error(FATAL, 'nestbctype > 1 not yet implemented') - - !This check is due to a bug which has not yet been identified. Beware. -! if (Atm(n)%parent_grid%flagstruct%hord_tr == 7) & -! call mpp_error(FATAL, "Flux-form nested BCs (nestbctype > 1) should not use hord_tr == 7 (on parent grid), since there is no guarantee of tracer mass conservation with this option.") - -!!$ if (Atm(n)%flagstruct%q_split > 0 .and. Atm(n)%parent_grid%flagstruct%q_split > 0) then -!!$ if (mod(Atm(n)%flagstruct%q_split,Atm(n)%parent_grid%flagstruct%q_split) /= 0) call mpp_error(FATAL, & -!!$ "Flux-form nested BCs (nestbctype > 1) require q_split on the nested grid to be evenly divisible by that on the coarse grid.") -!!$ endif -!!$ if (mod((Atm(n)%npx-1),Atm(n)%neststruct%refinement) /= 0 .or. mod((Atm(n)%npy-1),Atm(n)%neststruct%refinement) /= 0) call mpp_error(FATAL, & -!!$ "Flux-form nested BCs (nestbctype > 1) requires npx and npy to be one more than a multiple of the refinement ratio.") -!!$ Atm(n)%parent_grid%neststruct%do_flux_BCs = .true. -!!$ if (Atm(n)%neststruct%nestbctype == 3 .or. Atm(n)%neststruct%nestbctype == 4) Atm(n)%parent_grid%neststruct%do_2way_flux_BCs = .true. - Atm(n)%neststruct%upoff = 0 - endif - - end if - - do nn=1,size(Atm) - if (n == 1) allocate(Atm(nn)%neststruct%nest_domain_all(size(Atm))) - Atm(nn)%neststruct%nest_domain_all(n) = Atm(n)%neststruct%nest_domain - enddo - - end do - - do n=1,size(Atm) - if (ANY(Atm(n)%pelist == gid)) then - call mpp_set_current_pelist(Atm(n)%pelist) - endif - enddo - - end subroutine run_setup - subroutine init_nesting(Atm, grids_on_this_pe, p_split) - - type(fv_atmos_type), intent(inout), allocatable :: Atm(:) - logical, allocatable, intent(INOUT) :: grids_on_this_pe(:) - integer, intent(INOUT) :: p_split - character(100) :: pe_list_name - integer :: nest_pes(100) - integer :: n, npes, ntiles, pecounter, i - integer, allocatable :: pelist(:) - integer :: f_unit, ios, ierr - - !This is an OPTIONAL namelist, that needs to be read before everything else - namelist /nest_nml/ ngrids, ntiles, nest_pes, p_split - - call mp_assign_gid - - nest_pes = 0 - ntiles = -999 + do n = 1, ngrids + call deallocate_fv_atmos_type(Atm(n)) + end do -#ifdef INTERNAL_FILE_NML - read (input_nml_file,nest_nml,iostat=ios) - ierr = check_nml_error(ios,'nest_nml') -#else - f_unit=open_namelist_file() - rewind (f_unit) - read (f_unit,nest_nml,iostat=ios) - ierr = check_nml_error(ios,'nest_nml') - call close_file(f_unit) -#endif - if (ntiles /= -999) ngrids = ntiles - if (ngrids > 10) call mpp_error(FATAL, "More than 10 nested grids not supported") - - allocate(Atm(ngrids)) - - allocate(grids_on_this_pe(ngrids)) - grids_on_this_pe = .false. !initialization - - npes = mpp_npes() - - ! Need to get a global pelist to send data around later? - allocate( pelist_all(npes) ) - pelist_all = (/ (i,i=0,npes-1) /) - pelist_all = pelist_all + mpp_root_pe() - - if (ngrids == 1) then - - !Set up the single pelist - allocate(Atm(1)%pelist(npes)) - Atm(1)%pelist = (/(i, i=0, npes-1)/) - Atm(1)%pelist = Atm(1)%pelist + mpp_root_pe() - call mpp_declare_pelist(Atm(1)%pelist) - call mpp_set_current_pelist(Atm(1)%pelist) - !Now set in domain_decomp - !masterproc = Atm(1)%pelist(1) - call setup_master(Atm(1)%pelist) - grids_on_this_pe(1) = .true. - Atm(1)%npes_this_grid = npes - - else - - pecounter = mpp_root_pe() - do n=1,ngrids - if (n == 1) then - pe_list_name = '' - else - write(pe_list_name,'(A4, I2.2)') 'nest', n - endif - - if (nest_pes(n) == 0) then - if (n < ngrids) call mpp_error(FATAL, 'Only nest_pes(ngrids) in nest_nml can be zero; preceeding values must be nonzero.') - allocate(Atm(n)%pelist(npes-pecounter)) - Atm(n)%pelist = (/(i, i=pecounter, npes-1)/) - if (n > 1) then - call mpp_declare_pelist(Atm(n)%pelist, trim(pe_list_name)) - !Make sure nested-grid input file exists - if (.not. file_exist('input_'//trim(pe_list_name)//'.nml')) then - call mpp_error(FATAL, "Could not find nested grid namelist input_"//trim(pe_list_name)//".nml") - endif - endif - exit - else - allocate(Atm(n)%pelist(nest_pes(n))) - Atm(n)%pelist = (/ (i, i=pecounter, pecounter+nest_pes(n)-1) /) - if (Atm(n)%pelist(nest_pes(n)) >= npes) then - call mpp_error(FATAL, 'PEs assigned by nest_pes in nest_nml exceeds number of available PEs.') - endif - - call mpp_declare_pelist(Atm(n)%pelist, trim(pe_list_name)) - !Make sure nested-grid input file exists - if (n > 1) then - if (.not. file_exist('input_'//trim(pe_list_name)//'.nml')) then - call mpp_error(FATAL, "Could not find nested grid namelist input_"//trim(pe_list_name)//".nml") - endif - endif - pecounter = pecounter+nest_pes(n) - endif - enddo - - !Set pelists - do n=1,ngrids - Atm(n)%npes_this_grid = size(Atm(n)%pelist) - if (ANY(gid == Atm(n)%pelist)) then - call mpp_set_current_pelist(Atm(n)%pelist) - !now set in domain_decomp - !masterproc = Atm(n)%pelist(1) - call setup_master(Atm(n)%pelist) - grids_on_this_pe(n) = .true. - exit - endif - enddo - - if (pecounter /= npes) then - call mpp_error(FATAL, 'nest_pes in nest_nml does not assign all of the available PEs.') - endif - endif - - !Layout is checked later, in fv_control - - end subroutine init_nesting - -!>@brief The subroutine 'setup_pointers' associates the MODULE flag pointers -!! with the ARRAY flag variables for the grid active on THIS pe so the flags -!! can be read in from the namelist. - subroutine setup_pointers(Atm) - - type(fv_atmos_type), intent(INOUT), target :: Atm - - !This routine associates the MODULE flag pointers with the ARRAY flag variables for the grid active on THIS pe so the flags can be read in from the namelist. - - res_latlon_dynamics => Atm%flagstruct%res_latlon_dynamics - res_latlon_tracers => Atm%flagstruct%res_latlon_tracers - - grid_type => Atm%flagstruct%grid_type - grid_name => Atm%flagstruct%grid_name - grid_file => Atm%flagstruct%grid_file - hord_mt => Atm%flagstruct%hord_mt - kord_mt => Atm%flagstruct%kord_mt - kord_wz => Atm%flagstruct%kord_wz - hord_vt => Atm%flagstruct%hord_vt - hord_tm => Atm%flagstruct%hord_tm - hord_dp => Atm%flagstruct%hord_dp - kord_tm => Atm%flagstruct%kord_tm - hord_tr => Atm%flagstruct%hord_tr - kord_tr => Atm%flagstruct%kord_tr - scale_z => Atm%flagstruct%scale_z - w_max => Atm%flagstruct%w_max - z_min => Atm%flagstruct%z_min - lim_fac => Atm%flagstruct%lim_fac - nord => Atm%flagstruct%nord - nord_tr => Atm%flagstruct%nord_tr - dddmp => Atm%flagstruct%dddmp - d2_bg => Atm%flagstruct%d2_bg - d4_bg => Atm%flagstruct%d4_bg - vtdm4 => Atm%flagstruct%vtdm4 - trdm2 => Atm%flagstruct%trdm2 - d2_bg_k1 => Atm%flagstruct%d2_bg_k1 - d2_bg_k2 => Atm%flagstruct%d2_bg_k2 - d2_divg_max_k1 => Atm%flagstruct%d2_divg_max_k1 - d2_divg_max_k2 => Atm%flagstruct%d2_divg_max_k2 - damp_k_k1 => Atm%flagstruct%damp_k_k1 - damp_k_k2 => Atm%flagstruct%damp_k_k2 - n_zs_filter => Atm%flagstruct%n_zs_filter - nord_zs_filter => Atm%flagstruct%nord_zs_filter - full_zs_filter => Atm%flagstruct%full_zs_filter - RF_fast => Atm%flagstruct%RF_fast - consv_am => Atm%flagstruct%consv_am - do_sat_adj => Atm%flagstruct%do_sat_adj - do_f3d => Atm%flagstruct%do_f3d - no_dycore => Atm%flagstruct%no_dycore - convert_ke => Atm%flagstruct%convert_ke - do_vort_damp => Atm%flagstruct%do_vort_damp - use_old_omega => Atm%flagstruct%use_old_omega - beta => Atm%flagstruct%beta - n_sponge => Atm%flagstruct%n_sponge - d_ext => Atm%flagstruct%d_ext - nwat => Atm%flagstruct%nwat - use_logp => Atm%flagstruct%use_logp - warm_start => Atm%flagstruct%warm_start - inline_q => Atm%flagstruct%inline_q - shift_fac => Atm%flagstruct%shift_fac - do_schmidt => Atm%flagstruct%do_schmidt - stretch_fac => Atm%flagstruct%stretch_fac - target_lat => Atm%flagstruct%target_lat - target_lon => Atm%flagstruct%target_lon - regional => Atm%flagstruct%regional - bc_update_interval => Atm%flagstruct%bc_update_interval - reset_eta => Atm%flagstruct%reset_eta - p_fac => Atm%flagstruct%p_fac - a_imp => Atm%flagstruct%a_imp - n_split => Atm%flagstruct%n_split - fac_n_spl => Atm%flagstruct%fac_n_spl - fhouri => Atm%flagstruct%fhouri - m_split => Atm%flagstruct%m_split - k_split => Atm%flagstruct%k_split - use_logp => Atm%flagstruct%use_logp - q_split => Atm%flagstruct%q_split - print_freq => Atm%flagstruct%print_freq - write_3d_diags => Atm%flagstruct%write_3d_diags - npx => Atm%flagstruct%npx - npy => Atm%flagstruct%npy - npz => Atm%flagstruct%npz - npz_rst => Atm%flagstruct%npz_rst - ncnst => Atm%flagstruct%ncnst - pnats => Atm%flagstruct%pnats - dnats => Atm%flagstruct%dnats - ntiles => Atm%flagstruct%ntiles - nf_omega => Atm%flagstruct%nf_omega - fv_sg_adj => Atm%flagstruct%fv_sg_adj - na_init => Atm%flagstruct%na_init - nudge_dz => Atm%flagstruct%nudge_dz - p_ref => Atm%flagstruct%p_ref - dry_mass => Atm%flagstruct%dry_mass - nt_prog => Atm%flagstruct%nt_prog - nt_phys => Atm%flagstruct%nt_phys - tau_h2o => Atm%flagstruct%tau_h2o - delt_max => Atm%flagstruct%delt_max - d_con => Atm%flagstruct%d_con - ke_bg => Atm%flagstruct%ke_bg - consv_te => Atm%flagstruct%consv_te - tau => Atm%flagstruct%tau - rf_cutoff => Atm%flagstruct%rf_cutoff - filter_phys => Atm%flagstruct%filter_phys - dwind_2d => Atm%flagstruct%dwind_2d - breed_vortex_inline => Atm%flagstruct%breed_vortex_inline - range_warn => Atm%flagstruct%range_warn - fill => Atm%flagstruct%fill - fill_dp => Atm%flagstruct%fill_dp - fill_wz => Atm%flagstruct%fill_wz - check_negative => Atm%flagstruct%check_negative - non_ortho => Atm%flagstruct%non_ortho - adiabatic => Atm%flagstruct%adiabatic - moist_phys => Atm%flagstruct%moist_phys - do_Held_Suarez => Atm%flagstruct%do_Held_Suarez - do_reed_physics => Atm%flagstruct%do_reed_physics - reed_cond_only => Atm%flagstruct%reed_cond_only - reproduce_sum => Atm%flagstruct%reproduce_sum - adjust_dry_mass => Atm%flagstruct%adjust_dry_mass - fv_debug => Atm%flagstruct%fv_debug - srf_init => Atm%flagstruct%srf_init - mountain => Atm%flagstruct%mountain - remap_t => Atm%flagstruct%remap_t - z_tracer => Atm%flagstruct%z_tracer - old_divg_damp => Atm%flagstruct%old_divg_damp - fv_land => Atm%flagstruct%fv_land - nudge => Atm%flagstruct%nudge - nudge_ic => Atm%flagstruct%nudge_ic - ncep_ic => Atm%flagstruct%ncep_ic - nggps_ic => Atm%flagstruct%nggps_ic - ecmwf_ic => Atm%flagstruct%ecmwf_ic - gfs_phil => Atm%flagstruct%gfs_phil - agrid_vel_rst => Atm%flagstruct%agrid_vel_rst - use_new_ncep => Atm%flagstruct%use_new_ncep - use_ncep_phy => Atm%flagstruct%use_ncep_phy - fv_diag_ic => Atm%flagstruct%fv_diag_ic - external_ic => Atm%flagstruct%external_ic - external_eta => Atm%flagstruct%external_eta - read_increment => Atm%flagstruct%read_increment - - hydrostatic => Atm%flagstruct%hydrostatic - phys_hydrostatic => Atm%flagstruct%phys_hydrostatic - use_hydro_pressure => Atm%flagstruct%use_hydro_pressure - do_uni_zfull => Atm%flagstruct%do_uni_zfull !miz - adj_mass_vmr => Atm%flagstruct%adj_mass_vmr !f1p - hybrid_z => Atm%flagstruct%hybrid_z - Make_NH => Atm%flagstruct%Make_NH - make_hybrid_z => Atm%flagstruct%make_hybrid_z - nudge_qv => Atm%flagstruct%nudge_qv - add_noise => Atm%flagstruct%add_noise - a2b_ord => Atm%flagstruct%a2b_ord - c2l_ord => Atm%flagstruct%c2l_ord - ndims => Atm%flagstruct%ndims - - dx_const => Atm%flagstruct%dx_const - dy_const => Atm%flagstruct%dy_const - deglon_start => Atm%flagstruct%deglon_start - deglon_stop => Atm%flagstruct%deglon_stop - deglat_start => Atm%flagstruct%deglat_start - deglat_stop => Atm%flagstruct%deglat_stop - - deglat => Atm%flagstruct%deglat - - nested => Atm%neststruct%nested - twowaynest => Atm%neststruct%twowaynest - parent_tile => Atm%neststruct%parent_tile - refinement => Atm%neststruct%refinement - nestbctype => Atm%neststruct%nestbctype - nestupdate => Atm%neststruct%nestupdate - nsponge => Atm%neststruct%nsponge - s_weight => Atm%neststruct%s_weight - ioffset => Atm%neststruct%ioffset - joffset => Atm%neststruct%joffset - - layout => Atm%layout - io_layout => Atm%io_layout - end subroutine setup_pointers - - + end subroutine fv_end +!------------------------------------------------------------------------------- + end module fv_control_mod diff --git a/model/fv_dynamics.F90 b/model/fv_dynamics.F90 index 4a9bab31a..16c0e5753 100644 --- a/model/fv_dynamics.F90 +++ b/model/fv_dynamics.F90 @@ -211,7 +211,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, real, intent(inout) :: pt( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< temperature (K) real, intent(inout) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< pressure thickness (pascal) real, intent(inout) :: q( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) !< specific humidity and constituents - real, intent(inout) :: delz(bd%isd:,bd%jsd:,1:) !< delta-height (m); non-hydrostatic only + real, intent(inout) :: delz(bd%is:,bd%js:,1:) !< delta-height (m); non-hydrostatic only real, intent(inout) :: ze0(bd%is:, bd%js: ,1:) !< height at edges (m); non-hydrostatic real, intent(inout), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed,npz) :: diss_est! diffusion estimate for SKEB ! ze0 no longer used @@ -271,8 +271,8 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, #endif real:: akap, rdg, ph1, ph2, mdt, gam, amdt, u0 real:: recip_k_split,reg_bc_update_time - integer :: kord_tracer(ncnst) - integer :: i,j,k, n, iq, n_map, nq, nwat, k_split + integer:: kord_tracer(ncnst) + integer :: i,j,k, n, iq, n_map, nq, nr, nwat, k_split integer :: sphum, liq_wat = -999, ice_wat = -999 ! GFDL physics integer :: rainwat = -999, snowwat = -999, graupel = -999, cld_amt = -999 integer :: theta_d = -999 @@ -281,7 +281,11 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, #else logical used, last_step, do_omega #endif +#ifdef MULTI_GASES + integer, parameter :: max_packs=13 +#else integer, parameter :: max_packs=12 +#endif type(group_halo_update_type), save :: i_pack(max_packs) integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -315,6 +319,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, recip_k_split=1./real(k_split) nwat = flagstruct%nwat nq = nq_tot - flagstruct%dnats + nr = nq_tot - flagstruct%dnrts rdg = -rdgas * agrav #ifdef CCPP @@ -351,30 +356,18 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, if (gridstruct%nested .or. ANY(neststruct%child_grids)) then call timing_on('NEST_BCs') call setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & - u, v, w, pt, delp, delz, q, uc, vc, pkz, & - neststruct%nested, flagstruct%inline_q, flagstruct%make_nh, ng, & - gridstruct, flagstruct, neststruct, & - neststruct%nest_timestep, neststruct%tracer_nest_timestep, & - domain, bd, nwat) - -#ifndef SW_DYNAMICS - if (gridstruct%nested) then - !Correct halo values have now been set up for BCs; we can go ahead and apply them too... - call nested_grid_BC_apply_intT(pt, & - 0, 0, npx, npy, npz, bd, 1., 1., & - neststruct%pt_BC, bctype=neststruct%nestbctype ) + u, v, w, pt, delp, delz, q, uc, vc, & #ifdef USE_COND - call nested_grid_BC_apply_intT(q_con, & - 0, 0, npx, npy, npz, bd, 1., 1., & - neststruct%q_con_BC, bctype=neststruct%nestbctype ) + q_con, & #ifdef MOIST_CAPPA - call nested_grid_BC_apply_intT(cappa, & - 0, 0, npx, npy, npz, bd, 1., 1., & - neststruct%cappa_BC, bctype=neststruct%nestbctype ) -#endif + cappa, & #endif - endif #endif + neststruct%nested, flagstruct%inline_q, flagstruct%make_nh, ng, & + gridstruct, flagstruct, neststruct, & + neststruct%nest_timestep, neststruct%tracer_nest_timestep, & + domain, parent_grid, bd, nwat, ak, bk) + call timing_off('NEST_BCs') endif @@ -394,7 +387,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, #ifdef MOIST_CAPPA ,cappa & #endif - ,q,u,v,uc,vc, bd, npz, reg_bc_update_time ) + ,q,u,v,uc,vc, bd, npz, reg_bc_update_time ) call timing_off('Regional_BCs') endif @@ -517,13 +510,14 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, endif enddo endif + if ( flagstruct%fv_debug ) then #ifdef MOIST_CAPPA call prt_mxm('cappa', cappa, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) #endif call prt_mxm('PS', ps, is, ie, js, je, ng, 1, 0.01, gridstruct%area_64, domain) call prt_mxm('T_dyn_b', pt, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) - if ( .not. hydrostatic) call prt_mxm('delz', delz, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) + if ( .not. hydrostatic) call prt_mxm('delz', delz, is, ie, js, je, 0, npz, 1., gridstruct%area_64, domain) call prt_mxm('delp_b ', delp, is, ie, js, je, ng, npz, 0.01, gridstruct%area_64, domain) call prt_mxm('pk_b', pk, is, ie, js, je, 0, npz+1, 1.,gridstruct%area_64, domain) call prt_mxm('pkz_b', pkz,is, ie, js, je, 0, npz, 1.,gridstruct%area_64, domain) @@ -532,7 +526,6 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, !--------------------- ! Compute Total Energy !--------------------- - if ( consv_te > 0. .and. (.not.do_adiabatic_init) ) then call compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, npz, & u, v, w, delz, pt, delp, q, dp1, pe, peln, phis, & @@ -560,7 +553,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, ! else call Rayleigh_Super(abs(bdt), npx, npy, npz, ks, pfull, phis, flagstruct%tau, u, v, w, pt, & ua, va, delz, gridstruct%agrid, cp_air, rdgas, ptop, hydrostatic, & - (.not. (neststruct%nested .or. flagstruct%regional)), flagstruct%rf_cutoff, gridstruct, domain, bd) + .not. gridstruct%bounded_domain, flagstruct%rf_cutoff, gridstruct, domain, bd) ! endif else call Rayleigh_Friction(abs(bdt), npx, npy, npz, ks, pfull, flagstruct%tau, u, v, w, pt, & @@ -616,7 +609,6 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, endif #endif - last_step = .false. mdt = bdt / real(k_split) @@ -681,7 +673,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, #endif call timing_on('DYN_CORE') - call dyn_core(npx, npy, npz, ng, sphum, nq, mdt, n_split, zvir, cp_air, akap, cappa, & + call dyn_core(npx, npy, npz, ng, sphum, nq, mdt, n_map, n_split, zvir, cp_air, akap, cappa, & #ifdef MULTI_GASES kapad, & #endif @@ -692,6 +684,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, domain, n_map==1, i_pack, last_step, diss_est,time_total) call timing_off('DYN_CORE') + #ifdef SW_DYNAMICS !!$OMP parallel do default(none) shared(is,ie,js,je,ps,delp,agrav) do j=js,je @@ -706,20 +699,20 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, ! mass fluxes call timing_on('tracer_2d') !!! CLEANUP: merge these two calls? - if (gridstruct%nested .or. flagstruct%regional) then + if (gridstruct%bounded_domain) then call tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, & flagstruct%hord_tr, q_split, mdt, idiag%id_divg, i_pack(10), & flagstruct%nord_tr, flagstruct%trdm2, & - k_split, neststruct, parent_grid, flagstruct%lim_fac,flagstruct%regional) + k_split, neststruct, parent_grid, n_map, flagstruct%lim_fac) else if ( flagstruct%z_tracer ) then call tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, & flagstruct%hord_tr, q_split, mdt, idiag%id_divg, i_pack(10), & - flagstruct%nord_tr, flagstruct%trdm2, flagstruct%lim_fac,flagstruct%regional) + flagstruct%nord_tr, flagstruct%trdm2, flagstruct%lim_fac) else call tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, & flagstruct%hord_tr, q_split, mdt, idiag%id_divg, i_pack(10), & - flagstruct%nord_tr, flagstruct%trdm2, flagstruct%lim_fac,flagstruct%regional) + flagstruct%nord_tr, flagstruct%trdm2, flagstruct%lim_fac) endif endif call timing_off('tracer_2d') @@ -728,15 +721,15 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, if ( flagstruct%hord_tr<8 .and. flagstruct%moist_phys ) then call timing_on('Fill2D') if ( liq_wat > 0 ) & - call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,liq_wat), delp, gridstruct%area, domain, neststruct%nested, gridstruct%regional, npx, npy) + call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,liq_wat), delp, gridstruct%area, domain, gridstruct%bounded_domain, npx, npy) if ( rainwat > 0 ) & - call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,rainwat), delp, gridstruct%area, domain, neststruct%nested, gridstruct%regional, npx, npy) + call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,rainwat), delp, gridstruct%area, domain, gridstruct%bounded_domain, npx, npy) if ( ice_wat > 0 ) & - call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,ice_wat), delp, gridstruct%area, domain, neststruct%nested, gridstruct%regional, npx, npy) + call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,ice_wat), delp, gridstruct%area, domain, gridstruct%bounded_domain, npx, npy) if ( snowwat > 0 ) & - call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,snowwat), delp, gridstruct%area, domain, neststruct%nested, gridstruct%regional, npx, npy) + call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,snowwat), delp, gridstruct%area, domain, gridstruct%bounded_domain, npx, npy) if ( graupel > 0 ) & - call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,graupel), delp, gridstruct%area, domain, neststruct%nested, gridstruct%regional, npx, npy) + call fill2D(is, ie, js, je, ng, npz, q(isd,jsd,1,graupel), delp, gridstruct%area, domain, gridstruct%bounded_domain, npx, npy) call timing_off('Fill2D') endif #endif @@ -755,7 +748,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, ! Eulerian coordinate. !------------------------------------------------------------------------ - do iq=1,nq + do iq=1,nr kord_tracer(iq) = flagstruct%kord_tr if ( iq==cld_amt ) kord_tracer(iq) = 9 ! monotonic enddo @@ -766,16 +759,28 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, call avec_timer_start(6) #endif - call Lagrangian_to_Eulerian(last_step, consv_te, ps, pe, delp, & - pkz, pk, mdt, bdt, npz, is,ie,js,je, isd,ied,jsd,jed, & - nq, nwat, sphum, q_con, u, v, w, delz, pt, q, phis, & + call Lagrangian_to_Eulerian(last_step, consv_te, ps, pe, delp, & + pkz, pk, mdt, bdt, npx, npy, npz, is,ie,js,je, isd,ied,jsd,jed, & + nr, nwat, sphum, q_con, u, v, w, delz, pt, q, phis, & zvir, cp_air, akap, cappa, flagstruct%kord_mt, flagstruct%kord_wz, & - kord_tracer, flagstruct%kord_tm, peln, te_2d, & - ng, ua, va, omga, dp1, ws, fill, reproduce_sum, & + kord_tracer, flagstruct%kord_tm, peln, te_2d, & + ng, ua, va, omga, dp1, ws, fill, reproduce_sum, & idiag%id_mdt>0, dtdt_m, ptop, ak, bk, pfull, gridstruct, domain, & - flagstruct%do_sat_adj, hydrostatic, hybrid_z, do_omega, & - flagstruct%adiabatic, do_adiabatic_init) + flagstruct%do_sat_adj, hydrostatic, hybrid_z, do_omega, & + flagstruct%adiabatic, do_adiabatic_init, & + flagstruct%c2l_ord, bd, flagstruct%fv_debug, & + flagstruct%moist_phys) + if ( flagstruct%fv_debug ) then + if (is_master()) write(*,'(A, I3, A1, I3)') 'finished k_split ', n_map, '/', k_split + call prt_mxm('T_dyn_a3', pt, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) + call prt_mxm('SPHUM_dyn', q(isd,jsd,1,sphum ), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('liq_wat_dyn', q(isd,jsd,1,liq_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('rainwat_dyn', q(isd,jsd,1,rainwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('ice_wat_dyn', q(isd,jsd,1,ice_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('snowwat_dyn', q(isd,jsd,1,snowwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('graupel_dyn', q(isd,jsd,1,graupel), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + endif #ifdef AVEC_TIMERS call avec_timer_stop(6) #endif @@ -786,7 +791,6 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, 0, 0, npx, npy, npz, bd, real(n_map+1), real(k_split), & neststruct%cappa_BC, bctype=neststruct%nestbctype ) endif - if ( flagstruct%regional .and. .not. last_step) then reg_bc_update_time=current_time_in_seconds+(n_map+1)*mdt call regional_boundary_update(cappa, 'cappa', & @@ -828,7 +832,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, do k=1,npz do j=js,je do i=is,ie - dtdt_m(i,j,k) = dtdt_m(i,j,k) *( 86400.0 / bdt) + dtdt_m(i,j,k) = dtdt_m(i,j,k) / bdt * 86400. enddo enddo enddo @@ -964,7 +968,7 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, endif 911 call cubed_to_latlon(u, v, ua, va, gridstruct, & - npx, npy, npz, 1, gridstruct%grid_type, domain, gridstruct%nested, flagstruct%c2l_ord, bd) + npx, npy, npz, 1, gridstruct%grid_type, domain, gridstruct%bounded_domain, flagstruct%c2l_ord, bd) #ifdef MULTI_GASES deallocate(kapad) @@ -983,14 +987,14 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, if ( flagstruct%range_warn ) then call range_check('UA_dyn', ua, is, ie, js, je, ng, npz, gridstruct%agrid, & - -280., 280., bad_range) + -280., 280., bad_range, fv_time) call range_check('VA_dyn', ua, is, ie, js, je, ng, npz, gridstruct%agrid, & - -280., 280., bad_range) + -280., 280., bad_range, fv_time) call range_check('TA_dyn', pt, is, ie, js, je, ng, npz, gridstruct%agrid, & - 150., 335., bad_range) + 150., 335., bad_range, fv_time) if ( .not. hydrostatic ) & call range_check('W_dyn', w, is, ie, js, je, ng, npz, gridstruct%agrid, & - -50., 100., bad_range) + -50., 100., bad_range, fv_time) endif #ifdef CCPP @@ -1211,7 +1215,7 @@ subroutine Rayleigh_Super(dt, npx, npy, npz, ks, pm, phis, tau, u, v, w, pt, & RF_initialized = .true. endif - call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%nested) + call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain) allocate( u2f(isd:ied,jsd:jed,kmax) ) @@ -1357,7 +1361,7 @@ subroutine Rayleigh_Friction(dt, npx, npy, npz, ks, pm, tau, u, v, w, pt, & allocate( u2f(isd:ied,jsd:jed,kmax) ) - call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%nested) + call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain) !$OMP parallel do default(none) shared(is,ie,js,je,kmax,u2f,hydrostatic,ua,va,w) do k=1,kmax @@ -1456,7 +1460,7 @@ subroutine compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, real, dimension(is:ie):: r1, r2, dm integer i, j, k - call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%nested) + call c2l_ord2(u, v, ua, va, gridstruct, npz, gridstruct%grid_type, bd, gridstruct%bounded_domain) !$OMP parallel do default(none) shared(is,ie,js,je,npz,gridstruct,aam,m_fac,ps,ptop,delp,agrav,ua) & !$OMP private(r1, r2, dm) diff --git a/model/fv_fill.F90 b/model/fv_fill.F90 index 98abe7d76..1e11d672e 100644 --- a/model/fv_fill.F90 +++ b/model/fv_fill.F90 @@ -203,11 +203,11 @@ end subroutine fill_gfs !>@brief The subroutine 'fill2D' fills in nonphysical negative values in a single scalar field !! using a two-dimensional diffusive approach which conserves mass. - subroutine fill2D(is, ie, js, je, ng, km, q, delp, area, domain, nested, regional, npx, npy) + subroutine fill2D(is, ie, js, je, ng, km, q, delp, area, domain, bounded_domain, npx, npy) ! This is a diffusive type filling algorithm type(domain2D), intent(INOUT) :: domain integer, intent(in):: is, ie, js, je, ng, km, npx, npy - logical, intent(IN):: nested,regional + logical, intent(IN):: bounded_domain real, intent(in):: area(is-ng:ie+ng, js-ng:je+ng) real, intent(in):: delp(is-ng:ie+ng, js-ng:je+ng, km) real, intent(inout):: q(is-ng:ie+ng, js-ng:je+ng, km) @@ -219,7 +219,7 @@ subroutine fill2D(is, ie, js, je, ng, km, q, delp, area, domain, nested, regiona integer:: i, j, k integer :: is1, ie1, js1, je1 - if (nested .or. regional) then + if (bounded_domain) then if (is == 1) then is1 = is-1 else diff --git a/model/fv_grid_utils.F90 b/model/fv_grid_utils.F90 index 812a208bb..680c50575 100644 --- a/model/fv_grid_utils.F90 +++ b/model/fv_grid_utils.F90 @@ -86,7 +86,7 @@ module fv_grid_utils_mod use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_grid_bounds_type, & R_GRID use fv_eta_mod, only: set_eta - use fv_mp_mod, only: ng, is_master + use fv_mp_mod, only: is_master use fv_mp_mod, only: mp_reduce_sum, mp_reduce_min, mp_reduce_max use fv_mp_mod, only: fill_corners, XDir, YDir use fv_timing_mod, only: timing_on, timing_off @@ -111,12 +111,13 @@ module fv_grid_utils_mod public f_p public ptop_min, big_number !CLEANUP: OK to keep since they are constants? public cos_angle - public latlon2xyz, gnomonic_grids, & + public update_dwinds_phys, update2d_dwinds_phys, latlon2xyz, gnomonic_grids, & global_mx, unit_vect_latlon, & cubed_to_latlon, c2l_ord2, g_sum, global_qsum, great_circle_dist, & v_prod, get_unit_vect2, project_sphere_v public mid_pt_sphere, mid_pt_cart, vect_cross, grid_utils_init, grid_utils_end, & - spherical_angle, cell_center2, get_area, inner_prod, fill_ghost, direct_transform, & + spherical_angle, cell_center2, get_area, inner_prod, fill_ghost, & + direct_transform, cube_transform, & make_eta_level, expand_cell, cart_to_latlon, intp_great_circle, normalize_vect, & dist2side_latlon, spherical_linear_interpolation, get_latlon_vector public symm_grid @@ -227,7 +228,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) ne_corner => Atm%gridstruct%ne_corner nw_corner => Atm%gridstruct%nw_corner - if ( Atm%flagstruct%do_schmidt .and. abs(Atm%flagstruct%stretch_fac-1.) > 1.E-5 ) then + if ( (Atm%flagstruct%do_schmidt .or. Atm%flagstruct%do_cube_transform) .and. abs(Atm%flagstruct%stretch_fac-1.) > 1.E-5 ) then Atm%gridstruct%stretched_grid = .true. symm_grid = .false. else @@ -245,7 +246,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) elseif ( .not. Atm%flagstruct%hybrid_z ) then ! Initialize (ak,bk) for cold start; overwritten with restart file if (.not. Atm%flagstruct%external_eta) then - call set_eta(npz, Atm%ks, Atm%ptop, Atm%ak, Atm%bk) + call set_eta(npz, Atm%ks, Atm%ptop, Atm%ak, Atm%bk, Atm%flagstruct%npz_type) if ( is_master() ) then write(*,*) 'Grid_init', npz, Atm%ks, Atm%ptop tmp1 = Atm%ak(Atm%ks+1) @@ -273,7 +274,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) ne_corner = .false. nw_corner = .false. - if (grid_type < 3 .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (grid_type < 3 .and. .not. Atm%gridstruct%bounded_domain) then if ( is==1 .and. js==1 ) sw_corner = .true. if ( (ie+1)==npx .and. js==1 ) se_corner = .true. if ( (ie+1)==npx .and. (je+1)==npy ) ne_corner = .true. @@ -288,9 +289,9 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) if (grid_type < 3) then !xxx if ( .not. Atm%neststruct%nested ) then - if ( .not. Atm%neststruct%nested .and. .not.Atm%flagstruct%regional ) then - call fill_corners(grid(:,:,1), npx, npy, FILL=XDir, BGRID=.true.) - call fill_corners(grid(:,:,2), npx, npy, FILL=XDir, BGRID=.true.) + if ( .not. Atm%gridstruct%bounded_domain ) then + call fill_corners(grid(:,:,1), npx, npy, FILL=XDir, BGRID=.true.) + call fill_corners(grid(:,:,2), npx, npy, FILL=XDir, BGRID=.true.) end if do j=jsd,jed+1 @@ -303,7 +304,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) call get_center_vect( npx, npy, grid3, ec1, ec2, Atm%bd ) ! Fill arbitrary values in the non-existing corner regions: - if (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (.not. Atm%gridstruct%bounded_domain) then do k=1,3 call fill_ghost(ec1(k,:,:), npx, npy, big_number, Atm%bd) call fill_ghost(ec2(k,:,:), npx, npy, big_number, Atm%bd) @@ -314,14 +315,14 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) do j=jsd,jed do i=isd+1,ied if ( ( (i<1 .and. j<1 ) .or. (i>npx .and. j<1 ) .or. & - (i>npx .and. j>(npy-1)) .or. (i<1 .and. j>(npy-1)) ) .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + (i>npx .and. j>(npy-1)) .or. (i<1 .and. j>(npy-1)) ) .and. .not. Atm%gridstruct%bounded_domain) then ew(1:3,i,j,1:2) = 0. else call mid_pt_cart( grid(i,j,1:2), grid(i,j+1,1:2), pp) - if (i==1 .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (i==1 .and. .not. Atm%gridstruct%bounded_domain) then call latlon2xyz( agrid(i,j,1:2), p1) call vect_cross(p2, pp, p1) - elseif(i==npx .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + elseif(i==npx .and. .not. Atm%gridstruct%bounded_domain) then call latlon2xyz( agrid(i-1,j,1:2), p1) call vect_cross(p2, p1, pp) else @@ -342,14 +343,14 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) do j=jsd+1,jed do i=isd,ied if ( ( (i<1 .and. j<1 ) .or. (i>(npx-1) .and. j<1 ) .or. & - (i>(npx-1) .and. j>npy) .or. (i<1 .and. j>npy) ) .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + (i>(npx-1) .and. j>npy) .or. (i<1 .and. j>npy) ) .and. .not. Atm%gridstruct%bounded_domain) then es(1:3,i,j,1:2) = 0. else call mid_pt_cart(grid(i,j,1:2), grid(i+1,j,1:2), pp) - if (j==1 .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (j==1 .and. .not. Atm%gridstruct%bounded_domain) then call latlon2xyz( agrid(i,j,1:2), p1) call vect_cross(p2, pp, p1) - elseif (j==npy .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + elseif (j==npy .and. .not. Atm%gridstruct%bounded_domain) then call latlon2xyz( agrid(i,j-1,1:2), p1) call vect_cross(p2, p1, pp) else @@ -418,7 +419,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) ! For transport operation ! ------------------------------- !xxx if (.not. Atm%neststruct%nested) then - if (.not. Atm%neststruct%nested .and. .not. Atm%flagstruct%regional) then + if (.not. Atm%gridstruct%bounded_domain) then if ( sw_corner ) then do i=-2,0 sin_sg(0,i,3) = sin_sg(i,1,2) @@ -516,9 +517,9 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) do j=js,je+1 do i=is,ie+1 ! unit vect in X-dir: ee1 - if (i==1 .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (i==1 .and. .not. Atm%gridstruct%bounded_domain) then call vect_cross(pp, grid3(1,i, j), grid3(1,i+1,j)) - elseif(i==npx .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + elseif(i==npx .and. .not. Atm%gridstruct%bounded_domain) then call vect_cross(pp, grid3(1,i-1,j), grid3(1,i, j)) else call vect_cross(pp, grid3(1,i-1,j), grid3(1,i+1,j)) @@ -527,9 +528,9 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) call normalize_vect( ee1(1:3,i,j) ) ! unit vect in Y-dir: ee2 - if (j==1 .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (j==1 .and. .not. Atm%gridstruct%bounded_domain) then call vect_cross(pp, grid3(1:3,i,j ), grid3(1:3,i,j+1)) - elseif(j==npy .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + elseif(j==npy .and. .not. Atm%gridstruct%bounded_domain) then call vect_cross(pp, grid3(1:3,i,j-1), grid3(1:3,i,j )) else call vect_cross(pp, grid3(1:3,i,j-1), grid3(1:3,i,j+1)) @@ -579,7 +580,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) enddo enddo ! Force the model to fail if incorrect corner values are to be used: - if (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (.not. Atm%gridstruct%bounded_domain) then call fill_ghost(cosa_s, npx, npy, big_number, Atm%bd) end if !------------------------------------ @@ -587,8 +588,8 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) !------------------------------------ do j=js,je+1 do i=is,ie+1 - if ( i==npx .and. j==npy .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then - else if ( ( i==1 .or. i==npx .or. j==1 .or. j==npy ) .and. .not. (Atm%neststruct%nested.or.Atm%flagstruct%regional) ) then + if ( i==npx .and. j==npy .and. .not. Atm%gridstruct%bounded_domain) then + else if ( ( i==1 .or. i==npx .or. j==1 .or. j==npy ) .and. .not. Atm%gridstruct%bounded_domain ) then rsina(i,j) = big_number else ! rsina(i,j) = 1. / sina(i,j)**2 @@ -599,7 +600,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) do j=jsd,jed do i=is,ie+1 - if ( (i==1 .or. i==npx) .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional) ) then + if ( (i==1 .or. i==npx) .and. .not. Atm%gridstruct%bounded_domain ) then ! rsin_u(i,j) = 1. / sina_u(i,j) rsin_u(i,j) = 1. / sign(max(tiny_number,abs(sina_u(i,j))), sina_u(i,j)) endif @@ -608,7 +609,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) do j=js,je+1 do i=isd,ied - if ( (j==1 .or. j==npy) .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional) ) then + if ( (j==1 .or. j==npy) .and. .not. Atm%gridstruct%bounded_domain ) then ! rsin_v(i,j) = 1. / sina_v(i,j) rsin_v(i,j) = 1. / sign(max(tiny_number,abs(sina_v(i,j))), sina_v(i,j)) endif @@ -619,12 +620,12 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) !values along the outward-facing edge of a tile in the corners, which is incorrect. !What we will do is call fill_ghost and then fill in the appropriate values - if (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then - do k=1,9 + if (.not. Atm%gridstruct%bounded_domain) then + do k=1,9 call fill_ghost(sin_sg(:,:,k), npx, npy, tiny_number, Atm%bd) ! this will cause NAN if used call fill_ghost(cos_sg(:,:,k), npx, npy, big_number, Atm%bd) - enddo - end if + enddo + end if ! ------------------------------- ! For transport operation @@ -708,7 +709,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) ! Make normal vect at face edges after consines are computed: !------------------------------------------------------------- ! for old d2a2c_vect routines - if (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (.not. Atm%gridstruct%bounded_domain) then do j=js-1,je+1 if ( is==1 ) then i=1 @@ -762,7 +763,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) !!! should we insert .not.regional into the following loops alongside .not.nested ???? !xxxx do j=jsd,jed+1 - if ((j==1 .OR. j==npy) .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if ((j==1 .OR. j==npy) .and. .not. Atm%gridstruct%bounded_domain) then do i=isd,ied divg_u(i,j) = 0.5*(sin_sg(i,j,2)+sin_sg(i,j-1,4))*dyc(i,j)/dx(i,j) del6_u(i,j) = 0.5*(sin_sg(i,j,2)+sin_sg(i,j-1,4))*dx(i,j)/dyc(i,j) @@ -779,11 +780,11 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) divg_v(i,j) = sina_u(i,j)*dxc(i,j)/dy(i,j) del6_v(i,j) = sina_u(i,j)*dy(i,j)/dxc(i,j) enddo - if (is == 1 .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (is == 1 .and. .not. Atm%gridstruct%bounded_domain) then divg_v(is,j) = 0.5*(sin_sg(1,j,1)+sin_sg(0,j,3))*dxc(is,j)/dy(is,j) del6_v(is,j) = 0.5*(sin_sg(1,j,1)+sin_sg(0,j,3))*dy(is,j)/dxc(is,j) endif - if (ie+1 == npx .and. .not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then + if (ie+1 == npx .and. .not. Atm%gridstruct%bounded_domain) then divg_v(ie+1,j) = 0.5*(sin_sg(npx,j,1)+sin_sg(npx-1,j,3))*dxc(ie+1,j)/dy(ie+1,j) del6_v(ie+1,j) = 0.5*(sin_sg(npx,j,1)+sin_sg(npx-1,j,3))*dy(ie+1,j)/dxc(ie+1,j) endif @@ -792,7 +793,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) ! Initialize cubed_sphere to lat-lon transformation: call init_cubed_to_latlon( Atm%gridstruct, Atm%flagstruct%hydrostatic, agrid, grid_type, c2l_order, Atm%bd ) - call global_mx(area, ng, Atm%gridstruct%da_min, Atm%gridstruct%da_max, Atm%bd) + call global_mx(area, Atm%ng, Atm%gridstruct%da_min, Atm%gridstruct%da_max, Atm%bd) if( is_master() ) write(*,*) 'da_max/da_min=', Atm%gridstruct%da_max/Atm%gridstruct%da_min call global_mx_c(area_c(is:ie,js:je), is, ie, js, je, Atm%gridstruct%da_min_c, Atm%gridstruct%da_max_c) @@ -803,7 +804,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) ! Initialization for interpolation at face edges !------------------------------------------------ ! A->B scalar: - if (grid_type < 3 .and. .not. Atm%neststruct%nested .and. .not. Atm%flagstruct%regional ) then + if (grid_type < 3 .and. .not. Atm%gridstruct%bounded_domain ) then call mpp_update_domains(divg_v, divg_u, Atm%domain, flags=SCALAR_PAIR, & gridtype=CGRID_NE_PARAM, complete=.true.) call mpp_update_domains(del6_v, del6_u, Atm%domain, flags=SCALAR_PAIR, & @@ -812,7 +813,7 @@ subroutine grid_utils_init(Atm, npx, npy, npz, non_ortho, grid_type, c2l_order) Atm%gridstruct%edge_e, non_ortho, grid, agrid, npx, npy, Atm%bd) call efactor_a2c_v(Atm%gridstruct%edge_vect_s, Atm%gridstruct%edge_vect_n, & Atm%gridstruct%edge_vect_w, Atm%gridstruct%edge_vect_e, & - non_ortho, grid, agrid, npx, npy, Atm%neststruct%nested, Atm%bd, Atm%flagstruct%regional) + non_ortho, grid, agrid, npx, npy, Atm%gridstruct%bounded_domain, Atm%bd) ! call extend_cube_s(non_ortho, grid, agrid, npx, npy, .false., Atm%neststruct%nested) ! call van2d_init(grid, agrid, npx, npy) else @@ -903,6 +904,7 @@ end subroutine grid_utils_init subroutine grid_utils_end + ! deallocate sst_ncep (if allocated) #ifndef DYCORE_SOLO if (allocated(sst_ncep)) deallocate( sst_ncep ) @@ -969,6 +971,70 @@ subroutine direct_transform(c, i1, i2, j1, j2, lon_p, lat_p, n, lon, lat) end subroutine direct_transform + subroutine cube_transform(c, i1, i2, j1, j2, lon_p, lat_p, n, lon, lat) +! +! This is a direct transformation of the standard (symmetrical) cubic grid +! to a locally enhanced high-res grid on the sphere; it is an application +! of the Schmidt transformation at the **north** pole followed by a +! pole_shift_to_target (rotation) operation +! + real(kind=R_GRID), intent(in):: c ! Stretching factor + real(kind=R_GRID), intent(in):: lon_p, lat_p ! center location of the target face, radian + integer, intent(in):: n ! grid face number + integer, intent(in):: i1, i2, j1, j2 +! 0 <= lon <= 2*pi ; -pi/2 <= lat <= pi/2 + real(kind=R_GRID), intent(inout), dimension(i1:i2,j1:j2):: lon, lat +! + real(f_p):: lat_t, sin_p, cos_p, sin_lat, cos_lat, sin_o, p2, two_pi + real(f_p):: c2p1, c2m1 + integer:: i, j + + p2 = 0.5d0*pi + two_pi = 2.d0*pi + + if( is_master() .and. n==1 ) then + write(*,*) n, 'Cube transformation (revised Schmidt): stretching factor=', c, ' center=', lon_p, lat_p + endif + + c2p1 = 1.d0 + c*c + c2m1 = 1.d0 - c*c + + sin_p = sin(lat_p) + cos_p = cos(lat_p) + + !Try rotating pole around before doing the regular rotation?? + + do j=j1,j2 + do i=i1,i2 + if ( abs(c2m1) > 1.d-7 ) then + sin_lat = sin(lat(i,j)) + lat_t = asin( (c2m1+c2p1*sin_lat)/(c2p1+c2m1*sin_lat) ) + else ! no stretching + lat_t = lat(i,j) + endif + sin_lat = sin(lat_t) + cos_lat = cos(lat_t) + lon(i,j) = lon(i,j) + pi ! rotate around first to get final orientation correct + sin_o = -(sin_p*sin_lat + cos_p*cos_lat*cos(lon(i,j))) + if ( (1.-abs(sin_o)) < 1.d-7 ) then ! poles + lon(i,j) = 0.d0 + lat(i,j) = sign( p2, sin_o ) + else + lat(i,j) = asin( sin_o ) + lon(i,j) = lon_p + atan2( -cos_lat*sin(lon(i,j)), & + -sin_lat*cos_p+cos_lat*sin_p*cos(lon(i,j))) + if ( lon(i,j) < 0.d0 ) then + lon(i,j) = lon(i,j) + two_pi + elseif( lon(i,j) >= two_pi ) then + lon(i,j) = lon(i,j) - two_pi + endif + endif + enddo + enddo + + end subroutine cube_transform + + real function inner_prod(v1, v2) real(kind=R_GRID),intent(in):: v1(3), v2(3) real (f_p) :: vp1(3), vp2(3), prod16 @@ -985,11 +1051,11 @@ end function inner_prod !>@brief The subroutine 'efactor_a2c_v' initializes interpolation factors at face edges !! for interpolating vectors from A to C grid - subroutine efactor_a2c_v(edge_vect_s, edge_vect_n, edge_vect_w, edge_vect_e, non_ortho, grid, agrid, npx, npy, nested, bd, regional) + subroutine efactor_a2c_v(edge_vect_s, edge_vect_n, edge_vect_w, edge_vect_e, non_ortho, grid, agrid, npx, npy, bounded_domain, bd) type(fv_grid_bounds_type), intent(IN) :: bd real(kind=R_GRID), intent(INOUT), dimension(bd%isd:bd%ied) :: edge_vect_s, edge_vect_n real(kind=R_GRID), intent(INOUT), dimension(bd%jsd:bd%jed) :: edge_vect_w, edge_vect_e - logical, intent(in):: non_ortho, nested, regional + logical, intent(in):: non_ortho, bounded_domain real(kind=R_GRID), intent(in):: grid(bd%isd:bd%ied+1,bd%jsd:bd%jed+1,2) real(kind=R_GRID), intent(in):: agrid(bd%isd:bd%ied ,bd%jsd:bd%jed ,2) integer, intent(in):: npx, npy @@ -1024,7 +1090,7 @@ subroutine efactor_a2c_v(edge_vect_s, edge_vect_n, edge_vect_w, edge_vect_e, non edge_vect_w = big_number edge_vect_e = big_number - if ( npx /= npy .and. .not. (nested .or. regional)) call mpp_error(FATAL, 'efactor_a2c_v: npx /= npy') + if ( npx /= npy .and. .not. (bounded_domain)) call mpp_error(FATAL, 'efactor_a2c_v: npx /= npy') if ( (npx/2)*2 == npx ) call mpp_error(FATAL, 'efactor_a2c_v: npx/npy is not an odd number') im2 = (npx-1)/2 @@ -2342,7 +2408,7 @@ subroutine init_cubed_to_latlon( gridstruct, hydrostatic, agrid, grid_type, ord, end subroutine init_cubed_to_latlon - subroutine cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, km, mode, grid_type, domain, nested, c2l_ord, bd) + subroutine cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, km, mode, grid_type, domain, bounded_domain, c2l_ord, bd) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(in) :: km, npx, npy, grid_type, c2l_ord integer, intent(in) :: mode ! update if present @@ -2352,18 +2418,18 @@ subroutine cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, km, mode, grid_ty real, intent(out):: ua(bd%isd:bd%ied, bd%jsd:bd%jed,km) real, intent(out):: va(bd%isd:bd%ied, bd%jsd:bd%jed,km) type(domain2d), intent(INOUT) :: domain - logical, intent(IN) :: nested + logical, intent(IN) :: bounded_domain if ( c2l_ord == 2 ) then call c2l_ord2(u, v, ua, va, gridstruct, km, grid_type, bd, .false.) else - call c2l_ord4(u, v, ua, va, gridstruct, npx, npy, km, grid_type, domain, nested, mode, bd) + call c2l_ord4(u, v, ua, va, gridstruct, npx, npy, km, grid_type, domain, bounded_domain, mode, bd) endif end subroutine cubed_to_latlon - subroutine c2l_ord4(u, v, ua, va, gridstruct, npx, npy, km, grid_type, domain, nested, mode, bd) + subroutine c2l_ord4(u, v, ua, va, gridstruct, npx, npy, km, grid_type, domain, bounded_domain, mode, bd) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(in) :: km, npx, npy, grid_type @@ -2374,7 +2440,7 @@ subroutine c2l_ord4(u, v, ua, va, gridstruct, npx, npy, km, grid_type, domain, n real, intent(out):: ua(bd%isd:bd%ied, bd%jsd:bd%jed,km) real, intent(out):: va(bd%isd:bd%ied, bd%jsd:bd%jed,km) type(domain2d), intent(INOUT) :: domain - logical, intent(IN) :: nested + logical, intent(IN) :: bounded_domain ! Local ! 4-pt Lagrange interpolation real :: a1 = 0.5625 @@ -2401,12 +2467,12 @@ subroutine c2l_ord4(u, v, ua, va, gridstruct, npx, npy, km, grid_type, domain, n call timing_off('COMM_TOTAL') endif -!$OMP parallel do default(none) shared(is,ie,js,je,km,npx,npy,grid_type,nested,c2,c1, & +!$OMP parallel do default(none) shared(is,ie,js,je,km,npx,npy,grid_type,bounded_domain,c2,c1, & !$OMP u,v,gridstruct,ua,va,a1,a2) & !$OMP private(utmp, vtmp, wu, wv) do k=1,km if ( grid_type < 4 ) then - if (nested) then + if (bounded_domain) then do j=max(1,js),min(npy-1,je) do i=max(1,is),min(npx-1,ie) utmp(i,j) = c2*(u(i,j-1,k)+u(i,j+2,k)) + c1*(u(i,j,k)+u(i,j+1,k)) @@ -2482,7 +2548,7 @@ subroutine c2l_ord4(u, v, ua, va, gridstruct, npx, npy, km, grid_type, domain, n enddo endif - endif !nested + endif !bounded_domain !Transform local a-grid winds into latitude-longitude coordinates do j=js,je @@ -3115,12 +3181,13 @@ subroutine make_eta_level(km, pe, area, kks, ak, bk, ptop, domain, bd) real, allocatable:: pem(:,:) real(kind=4) :: p4 integer k, i, j - integer :: is, ie, js, je + integer :: is, ie, js, je, ng is = bd%is ie = bd%ie js = bd%js je = bd%je + ng = bd%ng allocate ( pem(is:ie,js:je) ) @@ -3307,6 +3374,341 @@ subroutine project_sphere_v( np, f, e ) end subroutine project_sphere_v +!>@brief The subroutine 'update_dwinds_phys' transforms the wind tendencies from +!! the A grid to the D grid for the final update. + subroutine update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v, gridstruct, npx, npy, npz, domain) + +! Purpose; Transform wind tendencies on A grid to D grid for the final update + + integer, intent(in):: is, ie, js, je + integer, intent(in):: isd, ied, jsd, jed + integer, intent(IN) :: npx,npy, npz + real, intent(in):: dt + real, intent(inout):: u(isd:ied, jsd:jed+1,npz) + real, intent(inout):: v(isd:ied+1,jsd:jed ,npz) + real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt + type(fv_grid_type), intent(IN), target :: gridstruct + type(domain2d), intent(INOUT) :: domain + +! local: + real v3(is-1:ie+1,js-1:je+1,3) + real ue(is-1:ie+1,js:je+1,3) ! 3D winds at edges + real ve(is:ie+1,js-1:je+1, 3) ! 3D winds at edges + real, dimension(is:ie):: ut1, ut2, ut3 + real, dimension(js:je):: vt1, vt2, vt3 + real dt5, gratio + integer i, j, k, m, im2, jm2 + + real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat + real(kind=R_GRID), pointer, dimension(:,:,:,:) :: es, ew + real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n + + es => gridstruct%es + ew => gridstruct%ew + vlon => gridstruct%vlon + vlat => gridstruct%vlat + + edge_vect_w => gridstruct%edge_vect_w + edge_vect_e => gridstruct%edge_vect_e + edge_vect_s => gridstruct%edge_vect_s + edge_vect_n => gridstruct%edge_vect_n + + dt5 = 0.5 * dt + im2 = (npx-1)/2 + jm2 = (npy-1)/2 + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,gridstruct,u,dt5,u_dt,v,v_dt, & +!$OMP vlon,vlat,jm2,edge_vect_w,npx,edge_vect_e,im2, & +!$OMP edge_vect_s,npy,edge_vect_n,es,ew) & +!$OMP private(ut1, ut2, ut3, vt1, vt2, vt3, ue, ve, v3) + do k=1, npz + + if ( gridstruct%grid_type > 3 ) then ! Local & one tile configurations + + do j=js,je+1 + do i=is,ie + u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k)) + enddo + enddo + do j=js,je + do i=is,ie+1 + v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k)) + enddo + enddo + + else +! Compute 3D wind tendency on A grid + do j=js-1,je+1 + do i=is-1,ie+1 + v3(i,j,1) = u_dt(i,j,k)*vlon(i,j,1) + v_dt(i,j,k)*vlat(i,j,1) + v3(i,j,2) = u_dt(i,j,k)*vlon(i,j,2) + v_dt(i,j,k)*vlat(i,j,2) + v3(i,j,3) = u_dt(i,j,k)*vlon(i,j,3) + v_dt(i,j,k)*vlat(i,j,3) + enddo + enddo + +! Interpolate to cell edges + do j=js,je+1 + do i=is-1,ie+1 + ue(i,j,1) = v3(i,j-1,1) + v3(i,j,1) + ue(i,j,2) = v3(i,j-1,2) + v3(i,j,2) + ue(i,j,3) = v3(i,j-1,3) + v3(i,j,3) + enddo + enddo + + do j=js-1,je+1 + do i=is,ie+1 + ve(i,j,1) = v3(i-1,j,1) + v3(i,j,1) + ve(i,j,2) = v3(i-1,j,2) + v3(i,j,2) + ve(i,j,3) = v3(i-1,j,3) + v3(i,j,3) + enddo + enddo + +! --- E_W edges (for v-wind): + if ( is==1 .and. .not. gridstruct%bounded_domain ) then + i = 1 + do j=js,je + if ( j>jm2 ) then + vt1(j) = edge_vect_w(j)*ve(i,j-1,1)+(1.-edge_vect_w(j))*ve(i,j,1) + vt2(j) = edge_vect_w(j)*ve(i,j-1,2)+(1.-edge_vect_w(j))*ve(i,j,2) + vt3(j) = edge_vect_w(j)*ve(i,j-1,3)+(1.-edge_vect_w(j))*ve(i,j,3) + else + vt1(j) = edge_vect_w(j)*ve(i,j+1,1)+(1.-edge_vect_w(j))*ve(i,j,1) + vt2(j) = edge_vect_w(j)*ve(i,j+1,2)+(1.-edge_vect_w(j))*ve(i,j,2) + vt3(j) = edge_vect_w(j)*ve(i,j+1,3)+(1.-edge_vect_w(j))*ve(i,j,3) + endif + enddo + do j=js,je + ve(i,j,1) = vt1(j) + ve(i,j,2) = vt2(j) + ve(i,j,3) = vt3(j) + enddo + endif + if ( (ie+1)==npx .and. .not. gridstruct%bounded_domain ) then + i = npx + do j=js,je + if ( j>jm2 ) then + vt1(j) = edge_vect_e(j)*ve(i,j-1,1)+(1.-edge_vect_e(j))*ve(i,j,1) + vt2(j) = edge_vect_e(j)*ve(i,j-1,2)+(1.-edge_vect_e(j))*ve(i,j,2) + vt3(j) = edge_vect_e(j)*ve(i,j-1,3)+(1.-edge_vect_e(j))*ve(i,j,3) + else + vt1(j) = edge_vect_e(j)*ve(i,j+1,1)+(1.-edge_vect_e(j))*ve(i,j,1) + vt2(j) = edge_vect_e(j)*ve(i,j+1,2)+(1.-edge_vect_e(j))*ve(i,j,2) + vt3(j) = edge_vect_e(j)*ve(i,j+1,3)+(1.-edge_vect_e(j))*ve(i,j,3) + endif + enddo + do j=js,je + ve(i,j,1) = vt1(j) + ve(i,j,2) = vt2(j) + ve(i,j,3) = vt3(j) + enddo + endif +! N-S edges (for u-wind): + if ( js==1 .and. .not. gridstruct%bounded_domain) then + j = 1 + do i=is,ie + if ( i>im2 ) then + ut1(i) = edge_vect_s(i)*ue(i-1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1) + ut2(i) = edge_vect_s(i)*ue(i-1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2) + ut3(i) = edge_vect_s(i)*ue(i-1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3) + else + ut1(i) = edge_vect_s(i)*ue(i+1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1) + ut2(i) = edge_vect_s(i)*ue(i+1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2) + ut3(i) = edge_vect_s(i)*ue(i+1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3) + endif + enddo + do i=is,ie + ue(i,j,1) = ut1(i) + ue(i,j,2) = ut2(i) + ue(i,j,3) = ut3(i) + enddo + endif + if ( (je+1)==npy .and. .not. gridstruct%bounded_domain) then + j = npy + do i=is,ie + if ( i>im2 ) then + ut1(i) = edge_vect_n(i)*ue(i-1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1) + ut2(i) = edge_vect_n(i)*ue(i-1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2) + ut3(i) = edge_vect_n(i)*ue(i-1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3) + else + ut1(i) = edge_vect_n(i)*ue(i+1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1) + ut2(i) = edge_vect_n(i)*ue(i+1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2) + ut3(i) = edge_vect_n(i)*ue(i+1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3) + endif + enddo + do i=is,ie + ue(i,j,1) = ut1(i) + ue(i,j,2) = ut2(i) + ue(i,j,3) = ut3(i) + enddo + endif + do j=js,je+1 + do i=is,ie + u(i,j,k) = u(i,j,k) + dt5*( ue(i,j,1)*es(1,i,j,1) + & + ue(i,j,2)*es(2,i,j,1) + & + ue(i,j,3)*es(3,i,j,1) ) + enddo + enddo + do j=js,je + do i=is,ie+1 + v(i,j,k) = v(i,j,k) + dt5*( ve(i,j,1)*ew(1,i,j,2) + & + ve(i,j,2)*ew(2,i,j,2) + & + ve(i,j,3)*ew(3,i,j,2) ) + enddo + enddo +! Update: + endif ! end grid_type + + enddo ! k-loop + + end subroutine update_dwinds_phys + +!>@brief The subroutine 'update2d_dwinds_phys' transforms the wind tendencies +!from +!! the A grid to the D grid for the final update. + subroutine update2d_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v, gridstruct, npx, npy, npz, domain) + +! Purpose; Transform wind tendencies on A grid to D grid for the final update + + integer, intent(in):: is, ie, js, je + integer, intent(in):: isd, ied, jsd, jed + real, intent(in):: dt + real, intent(inout):: u(isd:ied, jsd:jed+1,npz) + real, intent(inout):: v(isd:ied+1,jsd:jed ,npz) + real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt + type(fv_grid_type), intent(IN), target :: gridstruct + integer, intent(IN) :: npx,npy, npz + type(domain2d), intent(INOUT) :: domain + +! local: + real ut(isd:ied,jsd:jed) + real:: dt5, gratio + integer i, j, k + + real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat + real(kind=R_GRID), pointer, dimension(:,:,:,:) :: es, ew + real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n + real, pointer, dimension(:,:) :: z11, z12, z21, z22, dya, dxa + + es => gridstruct%es + ew => gridstruct%ew + vlon => gridstruct%vlon + vlat => gridstruct%vlat + + edge_vect_w => gridstruct%edge_vect_w + edge_vect_e => gridstruct%edge_vect_e + edge_vect_s => gridstruct%edge_vect_s + edge_vect_n => gridstruct%edge_vect_n + + z11 => gridstruct%z11 + z21 => gridstruct%z21 + z12 => gridstruct%z12 + z22 => gridstruct%z22 + + dxa => gridstruct%dxa + dya => gridstruct%dya + +! Transform wind tendency on A grid to local "co-variant" components: + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,z11,u_dt,z12,v_dt,z21,z22) & +!$OMP private(ut) + do k=1,npz + do j=js,je + do i=is,ie + ut(i,j) = z11(i,j)*u_dt(i,j,k) + z12(i,j)*v_dt(i,j,k) + v_dt(i,j,k) = z21(i,j)*u_dt(i,j,k) + z22(i,j)*v_dt(i,j,k) + u_dt(i,j,k) = ut(i,j) + enddo + enddo + enddo +! (u_dt,v_dt) are now on local coordinate system + call timing_on('COMM_TOTAL') + call mpp_update_domains(u_dt, v_dt, domain, gridtype=AGRID_PARAM) + call timing_off('COMM_TOTAL') + + dt5 = 0.5 * dt + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,gridstruct,u,dt5,u_dt,v,v_dt, & +!$OMP dya,npy,dxa,npx) & +!$OMP private(gratio) + do k=1, npz + + if ( gridstruct%grid_type > 3 .or. gridstruct%bounded_domain) then ! Local & one tile configurations + + do j=js,je+1 + do i=is,ie + u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k)) + enddo + enddo + do j=js,je + do i=is,ie+1 + v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k)) + enddo + enddo + + else + +!-------- +! u-wind +!-------- +! Edges: + if ( js==1 ) then + do i=is,ie + gratio = dya(i,2) / dya(i,1) + u(i,1,k) = u(i,1,k) + dt5*((2.+gratio)*(u_dt(i,0,k)+u_dt(i,1,k)) & + -(u_dt(i,-1,k)+u_dt(i,2,k)))/(1.+gratio) + enddo + endif + +! Interior + do j=max(2,js),min(npy-1,je+1) + do i=is,ie + u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k)+u_dt(i,j,k)) + enddo + enddo + + if ( (je+1)==npy ) then + do i=is,ie + gratio = dya(i,npy-2) / dya(i,npy-1) + u(i,npy,k) = u(i,npy,k) + dt5*((2.+gratio)*(u_dt(i,npy-1,k)+u_dt(i,npy,k)) & + -(u_dt(i,npy-2,k)+u_dt(i,npy+1,k)))/(1.+gratio) + enddo + endif + +!-------- +! v-wind +!-------- +! West Edges: + if ( is==1 ) then + do j=js,je + gratio = dxa(2,j) / dxa(1,j) + v(1,j,k) = v(1,j,k) + dt5*((2.+gratio)*(v_dt(0,j,k)+v_dt(1,j,k)) & + -(v_dt(-1,j,k)+v_dt(2,j,k)))/(1.+gratio) + enddo + endif + +! Interior + do j=js,je + do i=max(2,is),min(npx-1,ie+1) + v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k)+v_dt(i,j,k)) + enddo + enddo + +! East Edges: + if ( (ie+1)==npx ) then + do j=js,je + gratio = dxa(npx-2,j) / dxa(npx-1,j) + v(npx,j,k) = v(npx,j,k) + dt5*((2.+gratio)*(v_dt(npx-1,j,k)+v_dt(npx,j,k)) & + -(v_dt(npx-2,j,k)+v_dt(npx+1,j,k)))/(1.+gratio) + enddo + endif + + endif ! end grid_type + + enddo ! k-loop + + end subroutine update2d_dwinds_phys + + #ifdef TO_DO_MQ subroutine init_mq(phis, gridstruct, npx, npy, is, ie, js, je, ng) integer, intent(in):: npx, npy, is, ie, js, je, ng diff --git a/model/fv_mapz.F90 b/model/fv_mapz.F90 index 4994538b9..f4c507fa8 100644 --- a/model/fv_mapz.F90 +++ b/model/fv_mapz.F90 @@ -85,27 +85,20 @@ module fv_mapz_mod use constants_mod, only: radius, pi=>pi_8, rvgas, rdgas, grav, hlv, hlf, cp_air, cp_vapor use tracer_manager_mod,only: get_tracer_index use field_manager_mod, only: MODEL_ATMOS - use fv_grid_utils_mod, only: g_sum, ptop_min + use fv_grid_utils_mod, only: g_sum, ptop_min, cubed_to_latlon, update_dwinds_phys use fv_fill_mod, only: fillz use mpp_domains_mod, only: mpp_update_domains, domain2d use mpp_mod, only: NOTE, FATAL, mpp_error, get_unit, mpp_root_pe, mpp_pe - use fv_arrays_mod, only: fv_grid_type + use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, R_GRID use fv_timing_mod, only: timing_on, timing_off - use fv_mp_mod, only: is_master + use fv_mp_mod, only: is_master, mp_reduce_min, mp_reduce_max #ifndef CCPP use fv_cmp_mod, only: qs_init, fv_sat_adj #else -#ifdef STATIC -! For static builds, the ccpp_physics_{init,run,finalize} calls -! are not pointing to code in the CCPP framework, but to auto-generated -! ccpp_suite_cap and ccpp_group_*_cap modules behind a ccpp_static_api - use ccpp_api, only: ccpp_initialized use ccpp_static_api, only: ccpp_physics_run use CCPP_data, only: ccpp_suite -#else - use ccpp_api, only: ccpp_initialized, ccpp_physics_run -#endif - use CCPP_data, only: cdata => cdata_tile, CCPP_interstitial + use CCPP_data, only: cdata => cdata_tile + use CCPP_data, only: CCPP_interstitial #endif #ifdef MULTI_GASES use multi_gases_mod, only: virq, virqd, vicpqd, vicvqd, num_gas @@ -124,27 +117,34 @@ module fv_mapz_mod real, parameter:: cp_vap = cp_vapor !< 1846. real, parameter:: tice = 273.16 + real, parameter :: w_max = 60. + real, parameter :: w_min = -30. + logical, parameter :: w_limiter = .false. ! doesn't work so well?? + real(kind=4) :: E_Flux = 0. private public compute_total_energy, Lagrangian_to_Eulerian, moist_cv, moist_cp, & - rst_remap, mappm, E_Flux + rst_remap, mappm, E_Flux, remap_2d contains - !>@brief The subroutine 'Lagrangian_to_Eulerian' remaps deformed Lagrangian layers back to the reference Eulerian coordinate. !>@details It also includes the entry point for calling fast microphysical processes. This is typically calle on the k_split loop. subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & - mdt, pdt, km, is,ie,js,je, isd,ied,jsd,jed, & + mdt, pdt, npx, npy, km, is,ie,js,je, isd,ied,jsd,jed, & nq, nwat, sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, & akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, & ng, ua, va, omga, te, ws, fill, reproduce_sum, out_dt, dtdt, & ptop, ak, bk, pfull, gridstruct, domain, do_sat_adj, & - hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init) + hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init, & + c2l_ord, bd, fv_debug, & + moist_phys) logical, intent(in):: last_step - real, intent(in):: mdt !< remap time step - real, intent(in):: pdt !< phys time step + logical, intent(in):: fv_debug + real, intent(in):: mdt !< remap time step + real, intent(in):: pdt !< phys time step + integer, intent(in):: npx, npy integer, intent(in):: km integer, intent(in):: nq !< number of tracers (including h2o) integer, intent(in):: nwat @@ -156,7 +156,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & integer, intent(in):: kord_wz !< Mapping order/option for w integer, intent(in):: kord_tr(nq) !< Mapping order for tracers integer, intent(in):: kord_tm !< Mapping order for thermodynamics - + integer, intent(in):: c2l_ord real, intent(in):: consv !< factor for TE conservation real, intent(in):: r_vir real, intent(in):: cp @@ -175,6 +175,7 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & real, intent(in):: pfull(km) type(fv_grid_type), intent(IN), target :: gridstruct type(domain2d), intent(INOUT) :: domain + type(fv_grid_bounds_type), intent(IN) :: bd ! INPUT/OUTPUT real, intent(inout):: pk(is:ie,js:je,km+1) !< pe to the kappa @@ -189,10 +190,12 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & real, intent(inout):: w(isd: ,jsd: ,1:) !< vertical velocity (m/s) real, intent(inout):: pt(isd:ied ,jsd:jed ,km) !< cp*virtual potential temperature !< as input; output: temperature - real, intent(inout), dimension(isd:,jsd:,1:)::delz, q_con, cappa + real, intent(inout), dimension(isd:,jsd:,1:):: q_con, cappa + real, intent(inout), dimension(is:,js:,1:)::delz logical, intent(in):: hydrostatic logical, intent(in):: hybrid_z logical, intent(in):: out_dt + logical, intent(in):: moist_phys real, intent(inout):: ua(isd:ied,jsd:jed,km) !< u-wind (m/s) on physics grid real, intent(inout):: va(isd:ied,jsd:jed,km) !< v-wind (m/s) on physics grid @@ -202,21 +205,26 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & real, intent(out):: pkz(is:ie,js:je,km) !< layer-mean pk for converting t to pt real, intent(out):: te(isd:ied,jsd:jed,km) + ! !DESCRIPTION: ! ! !REVISION HISTORY: ! SJL 03.11.04: Initial version for partial remapping ! !----------------------------------------------------------------------- + real, allocatable, dimension(:,:,:) :: dp0, u0, v0 + real, allocatable, dimension(:,:,:) :: u_dt, v_dt #ifdef CCPP real, dimension(is:ie,js:je):: te_2d, zsum0, zsum1 #else real, dimension(is:ie,js:je):: te_2d, zsum0, zsum1, dpln #endif - real, dimension(is:ie,km) :: q2, dp2 + real, dimension(is:ie,km) :: q2, dp2, t0, w2 real, dimension(is:ie,km+1):: pe1, pe2, pk1, pk2, pn2, phis + real, dimension(isd:ied,jsd:jed,km):: pe4 real, dimension(is:ie+1,km+1):: pe0, pe3 - real, dimension(is:ie):: gz, cvm, qv + real, dimension(is:ie):: gsize, gz, cvm, qv + real rcp, rg, rrg, bkh, dtmp, k1k #ifndef CCPP logical:: fast_mp_consv @@ -224,10 +232,10 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & integer:: i,j,k integer:: kdelz #ifdef CCPP - integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, iq, n, kp, k_next + integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, ccn_cm3, iq, n, kp, k_next integer :: ierr #else - integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, iq, n, kmp, kp, k_next + integer:: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel, ccn_cm3, iq, n, kmp, kp, k_next #endif #ifdef CCPP @@ -246,8 +254,9 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') graupel = get_tracer_index (MODEL_ATMOS, 'graupel') cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt') + ccn_cm3 = get_tracer_index (MODEL_ATMOS, 'ccn_cm3') - if ( do_sat_adj ) then + if ( do_adiabatic_init .or. do_sat_adj ) then fast_mp_consv = (.not.do_adiabatic_init) .and. consv>consv_min #ifndef CCPP do k=1,km @@ -259,16 +268,16 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & endif !$OMP parallel do default(none) shared(is,ie,js,je,km,pe,ptop,kord_tm,hydrostatic, & -!$OMP pt,pk,rg,peln,q,nwat,liq_wat,rainwat,ice_wat,snowwat, & +!$OMP pt,pk,rg,peln,q,nwat,liq_wat,rainwat,ice_wat,snowwat, & !$OMP graupel,q_con,sphum,cappa,r_vir,rcp,k1k,delp, & !$OMP delz,akap,pkz,te,u,v,ps, gridstruct, last_step, & !$OMP ak,bk,nq,isd,ied,jsd,jed,kord_tr,fill, adiabatic, & #ifdef MULTI_GASES !$OMP num_gas, & #endif -!$OMP hs,w,ws,kord_wz,do_omega,omga,rrg,kord_mt,ua) & +!$OMP hs,w,ws,kord_wz,do_omega,omga,rrg,kord_mt,pe4) & !$OMP private(qv,gz,cvm,kp,k_next,bkh,dp2, & -!$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2) +!$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2,w2) do 1000 j=js,je+1 do k=1,km+1 @@ -442,9 +451,9 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & km, pe2, w, & is, ie, j, isd, ied, jsd, jed, -2, kord_wz) ! Remap delz for hybrid sigma-p coordinate - call map1_ppm (km, pe1, delz, gz, & + call map1_ppm (km, pe1, delz, gz, & ! works km, pe2, delz, & - is, ie, j, isd, ied, jsd, jed, 1, abs(kord_tm)) + is, ie, j, is, ie, js, je, 1, abs(kord_tm)) do k=1,km do i=is,ie delz(i,j,k) = -delz(i,j,k)*dp2(i,k) @@ -612,64 +621,65 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & do k=1,km do i=is,ie - ua(i,j,k) = pe2(i,k+1) + pe4(i,j,k) = pe2(i,k+1) enddo enddo 1000 continue #if defined(CCPP) && defined(__GFORTRAN__) -!$OMP parallel default(none) shared(is,ie,js,je,km,ptop,u,v,pe,ua,isd,ied,jsd,jed,kord_mt, & +!$OMP parallel default(none) shared(is,ie,js,je,km,ptop,u,v,pe,ua,va,isd,ied,jsd,jed,kord_mt, & !$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln, adiabatic, & !$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, & !$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, & !$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, & !$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, & !$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, & -!$OMP kord_tm,cdata,CCPP_interstitial) & -#ifdef STATIC +!$OMP kord_tm,pe4, npx,npy,ccn_cm3,u_dt,v_dt, c2l_ord,bd,dp0,ps, & +!$OMP cdata,CCPP_interstitial) & !$OMP shared(ccpp_suite) & -#endif #ifdef MULTI_GASES !$OMP shared(num_gas) & #endif -!$OMP private(pe0,pe1,pe2,pe3,qv,cvm,gz,phis,kdelz,ierr) +!$OMP private(q2,pe0,pe1,pe2,pe3,qv,cvm,gz,gsize,phis,kdelz,dp2,t0, ierr) #elif defined(CCPP) -!$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,isd,ied,jsd,jed,kord_mt, & +!$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,va,isd,ied,jsd,jed,kord_mt, & !$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln, adiabatic, & !$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, & !$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, & !$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, & !$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, & !$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, & -!$OMP fast_mp_consv,kord_tm,cdata, CCPP_interstitial) & -#ifdef STATIC +!$OMP fast_mp_consv,kord_tm, pe4,npx,npy, ccn_cm3, & +!$OMP u_dt,v_dt,c2l_ord,bd,dp0,ps,cdata,CCPP_interstitial) & !$OMP shared(ccpp_suite) & -#endif #ifdef MULTI_GASES !$OMP shared(num_gas) & #endif -!$OMP private(pe0,pe1,pe2,pe3,qv,cvm,gz,phis,kdelz,ierr) + +!$OMP private(q2,pe0,pe1,pe2,pe3,qv,cvm,gz,gsize,phis,kdelz,dp2,t0, ierr) #else -!$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,isd,ied,jsd,jed,kord_mt, & -!$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln, adiabatic, & -!$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, & -!$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, & -!$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, & -!$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, & -!$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, & -!$OMP fast_mp_consv,kord_tm) & +!$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,va,isd,ied,jsd,jed,kord_mt, & +!$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln,adiabatic, & +!$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, & +!$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, & +!$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, & +!$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, & +!$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, & +!$OMP fast_mp_consv,kord_tm,pe4,npx,npy,ccn_cm3, & +!$OMP u_dt,v_dt,c2l_ord,bd,dp0,ps) & + #ifdef MULTI_GASES !$OMP shared(num_gas) & #endif -!$OMP private(pe0,pe1,pe2,pe3,qv,cvm,gz,phis,kdelz,dpln) +!$OMP private(q2,pe0,pe1,pe2,pe3,qv,cvm,gz,gsize,phis,kdelz,dpln,dp2,t0) #endif !$OMP do do k=2,km do j=js,je do i=is,ie - pe(i,k,j) = ua(i,j,k-1) + pe(i,k,j) = pe4(i,j,k-1) enddo enddo enddo @@ -798,25 +808,21 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & dtmp = E_flux*(grav*pdt*4.*pi*radius**2) / & (cv_air*g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%area_64, 0, reproduce=.true.)) endif - !$OMP end single endif ! end consv check endif ! end last_step check ! Note: pt at this stage is T_v ! if ( (.not.do_adiabatic_init) .and. do_sat_adj ) then + if ( do_sat_adj ) then call timing_on('sat_adj2') #ifdef CCPP - if (ccpp_initialized(cdata)) then -#ifdef STATIC + if (cdata%initialized()) then call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), group_name='fast_physics', ierr=ierr) -#else - call ccpp_physics_run(cdata, group_name='fast_physics', ierr=ierr) -#endif if (ierr/=0) call mpp_error(FATAL, "Call to ccpp_physics_run for group 'fast_physics' failed") else - call mpp_error (FATAL, 'Lagrangian_to_Eulerian: can not call CCPP fast physics because cdata not initialized') + call mpp_error (FATAL, 'Lagrangian_to_Eulerian: can not call CCPP fast physics because CCPP not initialized') endif #else !$OMP do @@ -839,10 +845,8 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & q(isd,jsd,k,sphum), q(isd,jsd,k,liq_wat), & q(isd,jsd,k,ice_wat), q(isd,jsd,k,rainwat), & q(isd,jsd,k,snowwat), q(isd,jsd,k,graupel), & - hs ,dpln, delz(isd:,jsd:,kdelz), pt(isd,jsd,k), delp(isd,jsd,k), q_con(isd:,jsd:,k), & - - cappa(isd:,jsd:,k), gridstruct%area_64, dtdt(is,js,k), out_dt, last_step, cld_amt>0, q(isd,jsd,k,cld_amt)) - + hs, dpln, delz(is:ie,js:je,kdelz), pt(isd,jsd,k), delp(isd,jsd,k), q_con(isd:,jsd:,k), & + cappa(isd:,jsd:,k), gridstruct%area_64, dtdt(is,js,k), out_dt, last_step, cld_amt>0, q(isd,jsd,k,cld_amt)) if ( .not. hydrostatic ) then do j=js,je do i=is,ie @@ -875,7 +879,6 @@ subroutine Lagrangian_to_Eulerian(last_step, consv, ps, pe, delp, pkz, pk, & call timing_off('sat_adj2') endif ! do_sat_adj - if ( last_step ) then ! Output temperature if last_step !!! if ( is_master() ) write(*,*) 'dtmp=', dtmp, nwat @@ -967,7 +970,7 @@ subroutine compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, & real, intent(inout):: u(isd:ied, jsd:jed+1,km) real, intent(inout):: v(isd:ied+1,jsd:jed, km) real, intent(in):: w(isd:,jsd:,1:) !< vertical velocity (m/s) - real, intent(in):: delz(isd:,jsd:,1:) + real, intent(in):: delz(is:,js:,1:) real, intent(in):: hs(isd:ied,jsd:jed) !< surface geopotential real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1) !< pressure at layer edges real, intent(in):: peln(is:ie,km+1,js:je) !< log(pe) @@ -3025,7 +3028,7 @@ subroutine rst_remap(km, kn, is,ie,js,je, isd,ied,jsd,jed, nq, ntp, & real, intent(out):: pt(isd:ied ,jsd:jed ,kn) !< Temperature real, intent(out):: q(isd:ied,jsd:jed,kn,1:ntp) real, intent(out):: qdiag(isd:ied,jsd:jed,kn,ntp+1:nq) - real, intent(out):: delz(isd:,jsd:,1:) !< Delta-height (m) + real, intent(out):: delz(is:,js:,1:) !< Delta-height (m) !----------------------------------------------------------------------- real r_vir, rgrav real ps(isd:ied,jsd:jed) !< Surface pressure @@ -3414,7 +3417,12 @@ subroutine moist_cv(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rai ice_wat, snowwat, graupel, q, qd, cvm, t1) integer, intent(in):: is, ie, isd,ied, jsd,jed, km, nwat, j, k integer, intent(in):: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel +#ifdef MULTI_GASES + real, intent(in), dimension(isd:ied,jsd:jed,km,num_gas):: q +#else real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q +#endif + real, intent(out), dimension(is:ie):: cvm, qd real, intent(in), optional:: t1(is:ie) ! @@ -3465,12 +3473,25 @@ subroutine moist_cv(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rai enddo case(4) ! K_warm_rain with fake ice do i=is,ie +#ifndef CCPP qv(i) = q(i,j,k,sphum) qd(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) #ifdef MULTI_GASES cvm(i) = (1.-(qv(i)+qd(i)))*cv_air*vicvqd(q(i,j,k,1:num_gas)) + qv(i)*cv_vap + qd(i)*c_liq #else cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + qd(i)*c_liq +#endif +#else + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + qs(i) = q(i,j,k,ice_wat) + qd(i) = ql(i) + qs(i) +#ifdef MULTI_GASES + cvm(i) = (1.-(qv(i)+qd(i)))*cv_air*vicvqd(q(i,j,k,1:num_gas)) + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice +#else + cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice +#endif + #endif enddo case(5) @@ -3574,12 +3595,26 @@ subroutine moist_cp(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rai enddo case(4) ! K_warm_rain scheme with fake ice do i=is,ie +#ifndef CCPP qv(i) = q(i,j,k,sphum) qd(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) #ifdef MULTI_GASES cpm(i) = (1.-(qv(i)+qd(i)))*cp_air*vicpqd(q(i,j,k,:)) + qv(i)*cp_vapor + qd(i)*c_liq #else cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + qd(i)*c_liq +#endif +#else + qv(i) = q(i,j,k,sphum) + ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) + qs(i) = q(i,j,k,ice_wat) + qd(i) = ql(i) + qs(i) +#ifdef MULTI_GASES + cpm(i) = (1.-(qv(i)+qd(i)))*cp_air*vicpqd(q(i,j,k,:)) + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice +#else + cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice +#endif + + #endif enddo case(5) diff --git a/model/fv_nesting.F90 b/model/fv_nesting.F90 index 83437026c..01748aff7 100644 --- a/model/fv_nesting.F90 +++ b/model/fv_nesting.F90 @@ -108,24 +108,24 @@ module fv_nesting_mod use tracer_manager_mod, only: get_tracer_index use fv_sg_mod, only: neg_adj3 use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain, mpp_get_global_domain - use mpp_domains_mod, only: DGRID_NE, mpp_update_domains, domain2D - use fv_restart_mod, only: d2a_setup, d2c_setup - use mpp_mod, only: mpp_sync_self, mpp_sync, mpp_send, mpp_recv, mpp_error, FATAL + use mpp_domains_mod, only: AGRID, CGRID_NE, DGRID_NE, mpp_update_domains, domain2D + use mpp_mod, only: mpp_sync_self, mpp_sync, mpp_send, mpp_recv, mpp_error, FATAL, mpp_pe, WARNING, NOTE use mpp_domains_mod, only: mpp_global_sum, BITWISE_EFP_SUM, BITWISE_EXACT_SUM use boundary_mod, only: update_coarse_grid use boundary_mod, only: nested_grid_BC_send, nested_grid_BC_recv, nested_grid_BC_save_proc - use fv_mp_mod, only: is, ie, js, je, isd, ied, jsd, jed, isc, iec, jsc, jec + use boundary_mod, only: nested_grid_BC, nested_grid_BC_apply_intT use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_atmos_type, fv_nest_type, fv_diag_type, fv_nest_BC_type_3D - use fv_arrays_mod, only: allocate_fv_nest_BC_type, fv_atmos_type, fv_grid_bounds_type + use fv_arrays_mod, only: allocate_fv_nest_BC_type, fv_atmos_type, fv_grid_bounds_type, deallocate_fv_nest_BC_type use fv_grid_utils_mod, only: ptop_min, g_sum, cubed_to_latlon, f_p use init_hydro_mod, only: p_var use constants_mod, only: grav, pi=>pi_8, radius, hlv, rdgas, cp_air, rvgas, cp_vapor, kappa - use fv_mapz_mod, only: mappm + use fv_mapz_mod, only: mappm, remap_2d use fv_timing_mod, only: timing_on, timing_off use fv_mp_mod, only: is_master - use fv_mp_mod, only: mp_reduce_sum + use fv_mp_mod, only: mp_reduce_sum, global_nest_domain use fv_diagnostics_mod, only: sphum_ll_fix, range_check use sw_core_mod, only: divergence_corner, divergence_corner_nest + use time_manager_mod, only: time_type implicit none logical :: RF_initialized = .false. @@ -138,28 +138,30 @@ module fv_nesting_mod !For nested grid buffers !Individual structures are allocated by nested_grid_BC_recv - type(fv_nest_BC_type_3d) :: u_buf, v_buf, uc_buf, vc_buf, delp_buf, delz_buf, pt_buf, pkz_buf, w_buf, divg_buf + type(fv_nest_BC_type_3d) :: u_buf, v_buf, uc_buf, vc_buf, delp_buf, delz_buf, pt_buf, w_buf, divg_buf, pe_u_buf,pe_v_buf,pe_b_buf type(fv_nest_BC_type_3d), allocatable:: q_buf(:) !#ifdef USE_COND real, dimension(:,:,:), allocatable, target :: dum_West, dum_East, dum_North, dum_South !#endif private -public :: twoway_nesting, setup_nested_grid_BCs +public :: twoway_nesting, setup_nested_grid_BCs, set_physics_BCs contains - -!!!! NOTE: Many of the routines here and in boundary.F90 have a lot of -!!!! redundant code, which could be cleaned up and simplified. - -!>@brief The subroutine 'setup_nested_grid_BCs' fetches data from the coarse grid +!>@brief The subroutine 'setup_nested_grid_BCs' fetches data from the coarse grid !! to set up the nested-grid boundary conditions. subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & - u, v, w, pt, delp, delz,q, uc, vc, pkz, & + u, v, w, pt, delp, delz,q, uc, vc, & +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif nested, inline_q, make_nh, ng, & gridstruct, flagstruct, neststruct, & nest_timestep, tracer_nest_timestep, & - domain, bd, nwat) + domain, parent_grid, bd, nwat, ak, bk) type(fv_grid_bounds_type), intent(IN) :: bd @@ -168,18 +170,25 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & integer, intent(IN) :: npx, npy, npz integer, intent(IN) :: ncnst, ng, nwat logical, intent(IN) :: inline_q, make_nh,nested + real, intent(IN), dimension(npz) :: ak, bk real, intent(inout), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) :: u !< D grid zonal wind (m/s) real, intent(inout), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) :: v !< D grid meridional wind (m/s) real, intent(inout) :: w( bd%isd: ,bd%jsd: ,1:) !< W (m/s) real, intent(inout) :: pt( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< temperature (K) real, intent(inout) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< pressure thickness (pascal) - real, intent(inout) :: delz(bd%isd: ,bd%jsd: ,1:) !< height thickness (m) + real, intent(inout) :: delz(bd%is: ,bd%js: ,1:) !< height thickness (m) real, intent(inout) :: q( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) !< specific humidity and constituents real, intent(inout) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) !< (uc,vc) mostly used as the C grid winds real, intent(inout) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) - real, intent(inout) :: pkz (bd%is:bd%ie,bd%js:bd%je,npz) !< finite-volume mean pk +#ifdef USE_COND + real, intent(inout) :: q_con( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) +#ifdef MOIST_CAPPA + real, intent(inout) :: cappa( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) +#endif +#endif integer, intent(INOUT) :: nest_timestep, tracer_nest_timestep + type(fv_atmos_type), pointer, intent(IN) :: parent_grid type(fv_grid_type), intent(INOUT) :: gridstruct type(fv_flags_type), intent(INOUT) :: flagstruct @@ -188,33 +197,40 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & real :: divg(bd%isd:bd%ied+1,bd%jsd:bd%jed+1, npz) real :: ua(bd%isd:bd%ied,bd%jsd:bd%jed) real :: va(bd%isd:bd%ied,bd%jsd:bd%jed) + real :: pe_ustag(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz+1) + real :: pe_vstag(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz+1) + real :: pe_bstag(bd%isd:bd%ied+1,bd%jsd:bd%jed+1,npz+1) + real, parameter :: a13 = 1./3. - real :: pkz_coarse( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) - integer :: i,j,k,n,p, sphum + integer :: i,j,k,n,p, sphum, npz_coarse, nnest logical :: do_pd - type(fv_nest_BC_type_3d) :: pkz_BC - + type(fv_nest_BC_type_3d) :: delp_lag_BC, lag_BC, pe_lag_BC, pe_eul_BC + type(fv_nest_BC_type_3d) :: lag_u_BC, pe_u_lag_BC, pe_u_eul_BC + type(fv_nest_BC_type_3d) :: lag_v_BC, pe_v_lag_BC, pe_v_eul_BC + type(fv_nest_BC_type_3d) :: lag_b_BC, pe_b_lag_BC, pe_b_eul_BC + !local pointers logical, pointer :: child_grids(:) - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + child_grids => neststruct%child_grids - !IF nested, set up nested grid BCs for time-interpolation - !(actually applying the BCs is done in dyn_core + !(actually applying the BCs is done in dyn_core) + + !For multiple grids: Each grid has ONE parent but potentially MULTIPLE nests nest_timestep = 0 if (.not. inline_q) tracer_nest_timestep = 0 @@ -234,7 +250,8 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & call timing_on('COMM_TOTAL') !!! CLEANUP: could we make this a non-blocking operation? !!! Is this needed? it is on the initialization step. - call mpp_update_domains(u, v, & + call mpp_update_domains(delp, domain) !This is needed to make sure delp is updated for pe calculations + call mpp_update_domains(u, v, & domain, gridtype=DGRID_NE, complete=.true.) call timing_off('COMM_TOTAL') !$OMP parallel do default(none) shared(isd,jsd,ied,jed,is,ie,js,je,npx,npy,npz, & @@ -245,11 +262,11 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & ua, va, & uc(isd,jsd,k), vc(isd,jsd,k), flagstruct%nord>0, & isd,ied,jsd,jed, is,ie,js,je, npx,npy, & - gridstruct%grid_type, gridstruct%nested, & + gridstruct%grid_type, gridstruct%bounded_domain, & gridstruct%se_corner, gridstruct%sw_corner, & gridstruct%ne_corner, gridstruct%nw_corner, & gridstruct%rsin_u, gridstruct%rsin_v, & - gridstruct%cosa_s, gridstruct%rsin2, flagstruct%regional ) + gridstruct%cosa_s, gridstruct%rsin2 ) if (nested) then call divergence_corner_nest(u(isd,jsd,k), v(isd,jsd,k), ua, va, divg(isd,jsd,k), gridstruct, flagstruct, bd) else @@ -258,114 +275,237 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & end do endif -#ifndef SW_DYNAMICS - if (flagstruct%hydrostatic) then -!$OMP parallel do default(none) shared(npz,is,ie,js,je,pkz,pkz_coarse) - do k=1,npz - do j=js,je - do i=is,ie - pkz_coarse(i,j,k) = pkz(i,j,k) - enddo - enddo - enddo - endif -#endif -!! Nested grid: receive from parent grid + nnest = flagstruct%grid_number - 1 + +!! Nested grid: receive from parent grid (Lagrangian coordinate, npz_coarse) if (neststruct%nested) then + + npz_coarse = neststruct%parent_grid%npz + if (.not. allocated(q_buf)) then allocate(q_buf(ncnst)) endif - call nested_grid_BC_recv(neststruct%nest_domain, 0, 0, npz, bd, & - delp_buf) + call nested_grid_BC_recv(global_nest_domain, 0, 0, npz_coarse, bd, & + delp_buf, nnest) do n=1,ncnst - call nested_grid_BC_recv(neststruct%nest_domain, 0, 0, npz, bd, & - q_buf(n)) + call nested_grid_BC_recv(global_nest_domain, 0, 0, npz_coarse, bd, & + q_buf(n), nnest) enddo #ifndef SW_DYNAMICS - call nested_grid_BC_recv(neststruct%nest_domain, 0, 0, npz, bd, & - pt_buf) - - if (flagstruct%hydrostatic) then - call allocate_fv_nest_BC_type(pkz_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz,ng,0,0,0,.false.) - call nested_grid_BC_recv(neststruct%nest_domain, 0, 0, npz, bd, & - pkz_buf) - else - call nested_grid_BC_recv(neststruct%nest_domain, 0, 0, npz, bd, & - w_buf) - call nested_grid_BC_recv(neststruct%nest_domain, 0, 0, npz, bd, & - delz_buf) + call nested_grid_BC_recv(global_nest_domain, 0, 0, npz_coarse, bd, & + pt_buf, nnest) + + if (.not. flagstruct%hydrostatic) then + call nested_grid_BC_recv(global_nest_domain, 0, 0, npz_coarse, bd, & + w_buf, nnest) + call nested_grid_BC_recv(global_nest_domain, 0, 0, npz_coarse, bd, & + delz_buf, nnest) endif #endif - call nested_grid_BC_recv(neststruct%nest_domain, 0, 1, npz, bd, & - u_buf) - call nested_grid_BC_recv(neststruct%nest_domain, 0, 1, npz, bd, & - vc_buf) - call nested_grid_BC_recv(neststruct%nest_domain, 1, 0, npz, bd, & - v_buf) - call nested_grid_BC_recv(neststruct%nest_domain, 1, 0, npz, bd, & - uc_buf) - call nested_grid_BC_recv(neststruct%nest_domain, 1, 1, npz, bd, & - divg_buf) + if (neststruct%do_remap_BC(flagstruct%grid_number)) then + call nested_grid_BC_recv(global_nest_domain, npz_coarse+1, bd, & + pe_u_buf, pe_v_buf, nnest, gridtype=DGRID_NE) + call nested_grid_BC_recv(global_nest_domain, 1, 1, npz_coarse+1, bd, & + pe_b_buf, nnest) + endif + + call nested_grid_BC_recv(global_nest_domain, npz_coarse, bd, & + u_buf, v_buf, nnest, gridtype=DGRID_NE) + call nested_grid_BC_recv(global_nest_domain, npz_coarse, bd, & + uc_buf, vc_buf, nnest, gridtype=CGRID_NE) + call nested_grid_BC_recv(global_nest_domain, 1, 1, npz_coarse, bd, & + divg_buf, nnest) endif -!! Coarse grid: send to child grids +!! Coarse grid: send to child grids (Lagrangian coordinate, npz_coarse) do p=1,size(child_grids) if (child_grids(p)) then - call nested_grid_BC_send(delp, neststruct%nest_domain_all(p), 0, 0) + call nested_grid_BC_send(delp, global_nest_domain, 0, 0, p-1) do n=1,ncnst - call nested_grid_BC_send(q(:,:,:,n), neststruct%nest_domain_all(p), 0, 0) + call nested_grid_BC_send(q(:,:,:,n), global_nest_domain, 0, 0, p-1) enddo #ifndef SW_DYNAMICS - call nested_grid_BC_send(pt, neststruct%nest_domain_all(p), 0, 0) + call nested_grid_BC_send(pt, global_nest_domain, 0, 0, p-1) - if (flagstruct%hydrostatic) then - !Working with PKZ is more complicated since it is only defined on the interior of the grid. - call nested_grid_BC_send(pkz_coarse, neststruct%nest_domain_all(p), 0, 0) - else - call nested_grid_BC_send(w, neststruct%nest_domain_all(p), 0, 0) - call nested_grid_BC_send(delz, neststruct%nest_domain_all(p), 0, 0) + if (.not. flagstruct%hydrostatic) then + call nested_grid_BC_send(w, global_nest_domain, 0, 0, p-1) + call nested_grid_BC_send(delz, global_nest_domain, 0, 0, p-1) endif #endif - call nested_grid_BC_send(u, neststruct%nest_domain_all(p), 0, 1) - call nested_grid_BC_send(vc, neststruct%nest_domain_all(p), 0, 1) - call nested_grid_BC_send(v, neststruct%nest_domain_all(p), 1, 0) - call nested_grid_BC_send(uc, neststruct%nest_domain_all(p), 1, 0) - call nested_grid_BC_send(divg, neststruct%nest_domain_all(p), 1, 1) + + if (neststruct%do_remap_BC(p)) then + + !Compute and send staggered pressure + !u points +!$OMP parallel do default(none) shared(ak,pe_ustag,delp, & +!$OMP is,ie,js,je,npz) + do j=js,je+1 + do i=is,ie + pe_ustag(i,j,1) = ak(1) + enddo + do k=1,npz + do i=is,ie + pe_ustag(i,j,k+1) = pe_ustag(i,j,k) + 0.5*(delp(i,j,k)+delp(i,j-1,k)) + enddo + enddo + enddo + + !v points +!$OMP parallel do default(none) shared(ak,pe_vstag,delp, & +!$OMP is,ie,js,je,npz) + do j=js,je + do i=is,ie+1 + pe_vstag(i,j,1) = ak(1) + enddo + do k=1,npz + do i=is,ie+1 + pe_vstag(i,j,k+1) = pe_vstag(i,j,k) + 0.5*(delp(i,j,k)+delp(i-1,j,k)) + enddo + enddo + enddo + call nested_grid_BC_send(pe_ustag, pe_vstag, global_nest_domain, p-1, gridtype=DGRID_NE) + + !b points +!$OMP parallel do default(none) shared(ak,pe_bstag,delp, & +!$OMP is,ie,js,je,npz) + do j=js,je+1 + do i=is,ie+1 + pe_bstag(i,j,1) = ak(1) + enddo + enddo + !Sets up so 3-point average is automatically done at the corner + if (is == 1 .and. js == 1) then + do k=1,npz + delp(0,0,k) = a13*(delp(1,1,k) + delp(0,1,k) + delp(1,0,k)) + enddo + endif + if (ie == npx-1 .and. js == 1) then + do k=1,npz + delp(npx,0,k) = a13*(delp(npx-1,1,k) + delp(npx,1,k) + delp(npx-1,0,k)) + enddo + endif + if (is == 1 .and. je == npy-1) then + do k=1,npz + delp(0,npy,k) = a13*(delp(1,npy-1,k) + delp(0,npy-1,k) + delp(1,npy,k)) + enddo + endif + if (ie == npx-1 .and. je == npy-1) then + do k=1,npz + delp(npx,npy,k) = a13*(delp(npx-1,npy-1,k) + delp(npx,npy-1,k) + delp(npx-1,npy,k)) + enddo + endif + +!$OMP parallel do default(none) shared(ak,pe_bstag,delp, & +!$OMP is,ie,js,je,npz) + do j=js,je+1 + do k=1,npz + do i=is,ie+1 + pe_bstag(i,j,k+1) = pe_bstag(i,j,k) + & + 0.25*(delp(i,j,k)+delp(i-1,j,k)+delp(i,j-1,k)+delp(i-1,j-1,k)) + enddo + enddo + enddo + call nested_grid_BC_send(pe_bstag, global_nest_domain, 1, 1, p-1) + + endif + + call nested_grid_BC_send(u, v, global_nest_domain, p-1, gridtype=DGRID_NE) + call nested_grid_BC_send(uc, vc, global_nest_domain, p-1, gridtype=CGRID_NE) + call nested_grid_BC_send(divg, global_nest_domain, 1, 1, p-1) endif enddo !Nested grid: do computations + ! Lag: coarse grid, npz_coarse, lagrangian coordinate---receive and use save_proc to copy into lag_BCs + ! Eul: nested grid, npz, Eulerian (reference) coordinate + ! Remapping from Lag to Eul if (nested) then - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz, bd, & - neststruct%delp_BC, delp_buf, pd_in=do_pd) - do n=1,ncnst - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz, bd, & - neststruct%q_BC(n), q_buf(n), pd_in=do_pd) - enddo + + if (neststruct%do_remap_BC(flagstruct%grid_number)) then + + call allocate_fv_nest_BC_type(delp_lag_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse,ng,0,0,0,.false.) + call allocate_fv_nest_BC_type(lag_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse,ng,0,0,0,.false.) + call allocate_fv_nest_BC_type(pe_lag_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse+1,ng,0,0,0,.false.) + call allocate_fv_nest_BC_type(pe_eul_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1,ng,0,0,0,.false.) + + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + delp_lag_BC, delp_buf, pd_in=do_pd) + !The incoming delp is on the coarse grid's lagrangian coordinate. Re-create the reference coordinate + call setup_eul_delp_BC(delp_lag_BC, neststruct%delp_BC, pe_lag_BC, pe_eul_BC, ak, bk, npx, npy, npz, npz_coarse, parent_grid%ptop, bd) + + else + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + neststruct%delp_BC, delp_buf, pd_in=do_pd) + endif + +!!$ do n=1,ncnst +!!$ call nested_grid_BC_save_proc(global_nest_domain, & +!!$ neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & +!!$ lag_BC, q_buf(n), pd_in=do_pd) +!!$ !This remapping appears to have some trouble with rounding error random noise +!!$ call remap_BC(pe_lag_BC, pe_eul_BC, lag_BC, neststruct%q_BC(n), npx, npy, npz, npz_coarse, bd, 0, 0, 0, flagstruct%kord_tr, 'q') +!!$ enddo #ifndef SW_DYNAMICS - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz, bd, & - neststruct%pt_BC, pt_buf) + if (neststruct%do_remap_BC(flagstruct%grid_number)) then + + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + lag_BC, pt_buf) + !NOTE: need to remap using peln, not pe + call remap_BC(pe_lag_BC, pe_eul_BC, lag_BC, neststruct%pt_BC, npx, npy, npz, npz_coarse, bd, 0, 0, 1, abs(flagstruct%kord_tm), 'pt', do_log_pe=.true.) + + else + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + neststruct%pt_BC, pt_buf) + endif + + + !For whatever reason moving the calls for q BC remapping here avoids problems with cross-restart reproducibility. + if (neststruct%do_remap_BC(flagstruct%grid_number)) then + do n=1,ncnst + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + lag_BC, q_buf(n), pd_in=do_pd) + call remap_BC(pe_lag_BC, pe_eul_BC, lag_BC, neststruct%q_BC(n), npx, npy, npz, npz_coarse, bd, 0, 0, 0, flagstruct%kord_tr, 'q2') + enddo + else + do n=1,ncnst + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + neststruct%q_BC(n), q_buf(n), pd_in=do_pd) + enddo + endif sphum = get_tracer_index (MODEL_ATMOS, 'sphum') if (flagstruct%hydrostatic) then - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz, bd, & - pkz_BC, pkz_buf) - call setup_pt_BC(neststruct%pt_BC, pkz_BC, neststruct%q_BC(sphum), npx, npy, npz, zvir, bd) + call setup_pt_BC(neststruct%pt_BC, pe_eul_BC, neststruct%q_BC(sphum), npx, npy, npz, zvir, bd) else - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz, bd, & - neststruct%w_BC, w_buf) - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz, bd, & - neststruct%delz_BC, delz_buf) !Need a negative-definite method? + if (neststruct%do_remap_BC(flagstruct%grid_number)) then + + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + lag_BC, w_buf) + call remap_BC(pe_lag_BC, pe_eul_BC, lag_BC, neststruct%w_BC, npx, npy, npz, npz_coarse, bd, 0, 0, -1, flagstruct%kord_wz, 'w') + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + lag_BC, delz_buf) !Need a negative-definite method? + call remap_delz_BC(pe_lag_BC, pe_eul_BC, delp_lag_BC, lag_BC, neststruct%delp_BC, neststruct%delz_BC, npx, npy, npz, npz_coarse, bd, 0, 0, 1, flagstruct%kord_wz) + else + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + neststruct%w_BC, w_buf) + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & + neststruct%delz_BC, delz_buf) !Need a negative-definite method? + endif + call setup_pt_NH_BC(neststruct%pt_BC, neststruct%delp_BC, neststruct%delz_BC, & neststruct%q_BC(sphum), neststruct%q_BC, ncnst, & #ifdef USE_COND @@ -376,23 +516,148 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & #endif npx, npy, npz, zvir, bd) endif + +#endif + + !!!NOTE: The following require remapping on STAGGERED grids, which requires additional pressure data + + if (neststruct%do_remap_BC(flagstruct%grid_number)) then + + + call allocate_fv_nest_BC_type(pe_u_lag_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse+1,ng,0,0,1,.false.) + call allocate_fv_nest_BC_type(pe_u_eul_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1 ,ng,0,0,1,.false.) + call allocate_fv_nest_BC_type(lag_u_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse ,ng,0,0,1,.false.) + call allocate_fv_nest_BC_type(pe_v_lag_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse+1,ng,0,1,0,.false.) + call allocate_fv_nest_BC_type(pe_v_eul_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1 ,ng,0,1,0,.false.) + call allocate_fv_nest_BC_type(lag_v_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse ,ng,0,1,0,.false.) + call allocate_fv_nest_BC_type(pe_b_lag_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse+1,ng,0,1,1,.false.) + call allocate_fv_nest_BC_type(pe_b_eul_BC,is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1 ,ng,0,1,1,.false.) + call allocate_fv_nest_BC_type(lag_b_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse ,ng,0,1,1,.false.) + + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_u, neststruct%wt_u, 0, 1, npx, npy, npz_coarse+1, bd, & + pe_u_lag_BC, pe_u_buf) + call setup_eul_pe_BC(pe_u_lag_BC, pe_u_eul_BC, ak, bk, npx, npy, npz, npz_coarse, 0, 1, bd) + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_v, neststruct%wt_v, 1, 0, npx, npy, npz_coarse+1, bd, & + pe_v_lag_BC, pe_v_buf) + call setup_eul_pe_BC(pe_v_lag_BC, pe_v_eul_BC, ak, bk, npx, npy, npz, npz_coarse, 1, 0, bd) + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_b, neststruct%wt_b, 1, 1, npx, npy, npz_coarse+1, bd, & + pe_b_lag_BC, pe_b_buf) + call setup_eul_pe_BC(pe_b_lag_BC, pe_b_eul_BC, ak, bk, npx, npy, npz, npz_coarse, 1, 1, bd) + + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_u, neststruct%wt_u, 0, 1, npx, npy, npz_coarse, bd, & + lag_u_BC, u_buf) + call remap_BC(pe_u_lag_BC, pe_u_eul_BC, lag_u_BC, neststruct%u_BC, npx, npy, npz, npz_coarse, bd, 0, 1, -1, flagstruct%kord_mt, 'u') + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_u, neststruct%wt_u, 0, 1, npx, npy, npz_coarse, bd, & + lag_u_BC, vc_buf) + call remap_BC(pe_u_lag_BC, pe_u_eul_BC, lag_u_BC, neststruct%vc_BC, npx, npy, npz, npz_coarse, bd, 0, 1, -1, flagstruct%kord_mt, 'vc') + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_v, neststruct%wt_v, 1, 0, npx, npy, npz_coarse, bd, & + lag_v_BC, v_buf) + call remap_BC(pe_v_lag_BC, pe_v_eul_BC, lag_v_BC, neststruct%v_BC, npx, npy, npz, npz_coarse, bd, 1, 0, -1, flagstruct%kord_mt, 'v') + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_v, neststruct%wt_v, 1, 0, npx, npy, npz_coarse, bd, & + lag_v_BC, uc_buf) + call remap_BC(pe_v_lag_BC, pe_v_eul_BC, lag_v_BC, neststruct%uc_BC, npx, npy, npz, npz_coarse, bd, 1, 0, -1, flagstruct%kord_mt, 'uc') + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_b, neststruct%wt_b, 1, 1, npx, npy, npz_coarse, bd, & + lag_b_BC, divg_buf) + call remap_BC(pe_b_lag_BC, pe_b_eul_BC, lag_b_BC, neststruct%divg_BC, npx, npy, npz, npz_coarse, bd, 1, 1, -1, flagstruct%kord_mt, 'divg') + + call deallocate_fv_nest_BC_type(delp_lag_BC) + call deallocate_fv_nest_BC_type(lag_BC) + call deallocate_fv_nest_BC_type(pe_lag_BC) + call deallocate_fv_nest_BC_type(pe_eul_BC) + + call deallocate_fv_nest_BC_type(pe_u_lag_BC) + call deallocate_fv_nest_BC_type(pe_u_eul_BC) + call deallocate_fv_nest_BC_type(lag_u_BC) + call deallocate_fv_nest_BC_type(pe_v_lag_BC) + call deallocate_fv_nest_BC_type(pe_v_eul_BC) + call deallocate_fv_nest_BC_type(lag_v_BC) + call deallocate_fv_nest_BC_type(pe_b_lag_BC) + call deallocate_fv_nest_BC_type(pe_b_eul_BC) + call deallocate_fv_nest_BC_type(lag_b_BC) + + else + + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_u, neststruct%wt_u, 0, 1, npx, npy, npz_coarse, bd, & + neststruct%u_BC, u_buf) + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_u, neststruct%wt_u, 0, 1, npx, npy, npz_coarse, bd, & + neststruct%vc_BC, vc_buf) + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_v, neststruct%wt_v, 1, 0, npx, npy, npz_coarse, bd, & + neststruct%v_BC, v_buf) + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_v, neststruct%wt_v, 1, 0, npx, npy, npz_coarse, bd, & + neststruct%uc_BC, uc_buf) + call nested_grid_BC_save_proc(global_nest_domain, & + neststruct%ind_b, neststruct%wt_b, 1, 1, npx, npy, npz_coarse, bd, & + neststruct%divg_BC, divg_buf) + + endif + + !Correct halo values have now been set up for BCs; we can go ahead and apply them too + call nested_grid_BC_apply_intT(delp, & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%delp_BC, bctype=neststruct%nestbctype ) + do n=1,ncnst + call nested_grid_BC_apply_intT(q(:,:,:,n), & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%q_BC(n), bctype=neststruct%nestbctype ) + enddo +#ifndef SW_DYNAMICS + call nested_grid_BC_apply_intT(pt, & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%pt_BC, bctype=neststruct%nestbctype ) + if (.not. flagstruct%hydrostatic) then + call nested_grid_BC_apply_intT(w, & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%w_BC, bctype=neststruct%nestbctype ) + !Removed halo from delz --- BCs now directly applied in nh_BC --- lmh june 2018 +!!$ call nested_grid_BC_apply_intT(delz, & +!!$ 0, 0, npx, npy, npz, bd, 1., 1., & +!!$ neststruct%delz_BC, bctype=neststruct%nestbctype ) + endif +#ifdef USE_COND + call nested_grid_BC_apply_intT(q_con, & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%q_con_BC, bctype=neststruct%nestbctype ) +#ifdef MOIST_CAPPA + call nested_grid_BC_apply_intT(cappa, & + 0, 0, npx, npy, npz, bd, 1., 1., & + neststruct%cappa_BC, bctype=neststruct%nestbctype ) +#endif #endif - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_u, neststruct%wt_u, 0, 1, npx, npy, npz, bd, & - neststruct%u_BC, u_buf) - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_u, neststruct%wt_u, 0, 1, npx, npy, npz, bd, & - neststruct%vc_BC, vc_buf) - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_v, neststruct%wt_v, 1, 0, npx, npy, npz, bd, & - neststruct%v_BC, v_buf) - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_v, neststruct%wt_v, 1, 0, npx, npy, npz, bd, & - neststruct%uc_BC, uc_buf) - - call nested_grid_BC_save_proc(neststruct%nest_domain, & - neststruct%ind_b, neststruct%wt_b, 1, 1, npx, npy, npz, bd, & - neststruct%divg_BC, divg_buf) +#endif + call nested_grid_BC_apply_intT(u, & + 0, 1, npx, npy, npz, bd, 1., 1., & + neststruct%u_BC, bctype=neststruct%nestbctype ) + call nested_grid_BC_apply_intT(vc, & + 0, 1, npx, npy, npz, bd, 1., 1., & + neststruct%vc_BC, bctype=neststruct%nestbctype ) + call nested_grid_BC_apply_intT(v, & + 1, 0, npx, npy, npz, bd, 1., 1., & + neststruct%v_BC, bctype=neststruct%nestbctype ) + call nested_grid_BC_apply_intT(uc, & + 1, 0, npx, npy, npz, bd, 1., 1., & + neststruct%uc_BC, bctype=neststruct%nestbctype ) + !!!NOTE: Divg not available here but not needed + !!! until dyn_core anyway. +!!$ call nested_grid_BC_apply_intT(divg, & +!!$ 1, 1, npx, npy, npz, bd, 1., 1., & +!!$ neststruct%divg_BC, bctype=neststruct%nestbctype ) + + !Update domains needed for Rayleigh damping + if (.not. flagstruct%hydrostatic) call mpp_update_domains(w, domain) + call mpp_update_domains(u, v, domain, gridtype=DGRID_NE, complete=.true.) + endif if (neststruct%first_step) then @@ -418,17 +683,110 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & end subroutine setup_nested_grid_BCs - subroutine setup_pt_BC(pt_BC, pkz_BC, sphum_BC, npx, npy, npz, zvir, bd) + subroutine set_physics_BCs(ps, u_dt, v_dt, flagstruct, gridstruct, neststruct, npx, npy, npz, ng, ak, bk, bd) type(fv_grid_bounds_type), intent(IN) :: bd - type(fv_nest_BC_type_3d), intent(IN), target :: pkz_BC, sphum_BC - type(fv_nest_BC_type_3d), intent(INOUT), target :: pt_BC + type(fv_flags_type), intent(IN) :: flagstruct + type(fv_nest_type), intent(INOUT), target :: neststruct + type(fv_grid_type) :: gridstruct + integer, intent(IN) :: npx, npy, npz, ng + real, intent(IN), dimension(npz+1) :: ak, bk + real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: ps + real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz) :: u_dt, v_dt + real, dimension(1,1) :: parent_ps ! dummy variable for nesting + type(fv_nest_BC_type_3d) :: u_dt_buf, v_dt_buf, pe_src_BC, pe_dst_BC!, var_BC + + integer :: n, npz_coarse, nnest + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + real :: dum(1,1,1) + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + nnest = flagstruct%grid_number - 1 + + if (gridstruct%nested) then + + if (neststruct%do_remap_BC(flagstruct%grid_number)) then + + npz_coarse = neststruct%parent_grid%npz + + !Both nested and coarse grids assumed on Eulerian coordinates at this point + !Only need to fetch ps to form pressure levels + !Note also u_dt and v_dt are unstaggered + call nested_grid_BC(ps, parent_ps, global_nest_domain, neststruct%ind_h, neststruct%wt_h, 0, 0, & + npx, npy, bd, 1, npx-1, 1, npy-1) + call nested_grid_BC_recv(global_nest_domain, npz_coarse, bd, u_dt_buf, v_dt_buf, nnest, gridtype=AGRID) + + call allocate_fv_nest_BC_type(pe_src_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse+1,ng,0,0,0,.false.) + call allocate_fv_nest_BC_type(pe_dst_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1,ng,0,0,0,.false.) + + call copy_ps_BC(ps, pe_src_BC, npx, npy, npz_coarse, 0, 0, bd) + call setup_eul_pe_BC(pe_src_BC, pe_dst_BC, ak, bk, npx, npy, npz, npz_coarse, 0, 0, bd, & + make_src_in=.true., ak_src=neststruct%parent_grid%ak, bk_src=neststruct%parent_grid%bk) + + !Note that iv=-1 is used for remapping winds, which sets the lower reconstructed values to 0 if + ! there is a 2dx signal. Is this the best for **tendencies** though?? Probably not---so iv=1 here + call set_BC_direct( pe_src_BC, pe_dst_BC, u_dt_buf, u_dt, neststruct, npx, npy, npz, npz_coarse, ng, bd, 0, 0, 1, flagstruct%kord_mt) + call set_BC_direct( pe_src_BC, pe_dst_BC, v_dt_buf, v_dt, neststruct, npx, npy, npz, npz_coarse, ng, bd, 0, 0, 1, flagstruct%kord_mt) + + call deallocate_fv_nest_BC_type(pe_src_BC) + call deallocate_fv_nest_BC_type(pe_dst_BC) + + else + call nested_grid_BC(u_dt, v_dt, dum, dum, global_nest_domain, neststruct%ind_h, neststruct%ind_h, & + neststruct%wt_h, neststruct%wt_h, 0, 0, 0, 0, npx, npy, npz, bd, 1, npx-1, 1, npy-1, nnest, gridtype=AGRID) + endif + + endif + do n=1,size(neststruct%child_grids) + if (neststruct%child_grids(n)) then + if (neststruct%do_remap_BC(n)) & + call nested_grid_BC(ps, global_nest_domain, 0, 0, n-1) + call nested_grid_BC_send(u_dt, v_dt, global_nest_domain, n-1, gridtype=AGRID) + endif + enddo + + + end subroutine set_physics_BCs + + subroutine set_BC_direct( pe_src_BC, pe_dst_BC, buf, var, neststruct, npx, npy, npz, npz_coarse, ng, bd, istag, jstag, iv, kord) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_type), intent(INOUT) :: neststruct + integer, intent(IN) :: npx, npy, npz, npz_coarse, ng, istag, jstag, iv, kord + real, intent(INOUT), dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,npz) :: var + type(fv_nest_BC_type_3d), intent(INOUT) :: buf, pe_src_BC, pe_dst_BC + type(fv_nest_BC_type_3d) :: var_BC + + + call allocate_fv_nest_BC_type(var_BC,bd%is,bd%ie,bd%js,bd%je,bd%isd,bd%ied,bd%jsd,bd%jed,npx,npy,npz_coarse,ng,0,istag,jstag,.false.) + + call nested_grid_BC_save_proc(global_nest_domain, neststruct%ind_h, neststruct%wt_h, istag, jstag, & + npx, npy, npz_coarse, bd, var_BC, buf) + call remap_BC_direct(pe_src_BC, pe_dst_BC, var_BC, var, npx, npy, npz, npz_coarse, bd, istag, jstag, iv, kord) + + call deallocate_fv_nest_BC_type(var_BC) + + + end subroutine set_BC_direct + + subroutine setup_pt_BC(pt_BC, pe_eul_BC, sphum_BC, npx, npy, npz, zvir, bd) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_BC_type_3d), intent(IN) :: pe_eul_BC, sphum_BC + type(fv_nest_BC_type_3d), intent(INOUT) :: pt_BC integer, intent(IN) :: npx, npy, npz real, intent(IN) :: zvir - real, dimension(:,:,:), pointer :: ptBC, pkzBC, sphumBC - - integer :: i,j,k, istart, iend + integer :: istart, iend integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -443,23 +801,10 @@ subroutine setup_pt_BC(pt_BC, pkz_BC, sphum_BC, npx, npy, npz, zvir, bd) jed = bd%jed if (is == 1) then - ptBC => pt_BC%west_t1 - pkzBC => pkz_BC%west_t1 - sphumBC => sphum_BC%west_t1 -!$OMP parallel do default(none) shared(npz,jsd,jed,isd,ptBC,pkzBC,zvir,sphumBC) - do k=1,npz - do j=jsd,jed - do i=isd,0 - ptBC(i,j,k) = ptBC(i,j,k)/pkzBC(i,j,k)*(1.+zvir*sphumBC(i,j,k)) - end do - end do - end do + call setup_pt_BC_k(pt_BC%west_t1, sphum_BC%west_t1, pe_eul_BC%west_t1, zvir, isd, ied, isd, 0, jsd, jed, npz) end if if (js == 1) then - ptBC => pt_BC%south_t1 - pkzBC => pkz_BC%south_t1 - sphumBC => sphum_BC%south_t1 if (is == 1) then istart = is else @@ -471,37 +816,15 @@ subroutine setup_pt_BC(pt_BC, pkz_BC, sphum_BC, npx, npy, npz, zvir, bd) iend = ied end if -!$OMP parallel do default(none) shared(npz,jsd,istart,iend,ptBC,pkzBC,zvir,sphumBC) - do k=1,npz - do j=jsd,0 - do i=istart,iend - ptBC(i,j,k) = ptBC(i,j,k)/pkzBC(i,j,k) * & - (1.+zvir*sphumBC(i,j,k)) - end do - end do - end do + call setup_pt_BC_k(pt_BC%south_t1, sphum_BC%south_t1, pe_eul_BC%south_t1, zvir, isd, ied, istart, iend, jsd, 0, npz) end if if (ie == npx-1) then - ptBC => pt_BC%east_t1 - pkzBC => pkz_BC%east_t1 - sphumBC => sphum_BC%east_t1 -!$OMP parallel do default(none) shared(npz,jsd,jed,npx,ied,ptBC,pkzBC,zvir,sphumBC) - do k=1,npz - do j=jsd,jed - do i=npx,ied - ptBC(i,j,k) = ptBC(i,j,k)/pkzBC(i,j,k) * & - (1.+zvir*sphumBC(i,j,k)) - end do - end do - end do + call setup_pt_BC_k(pt_BC%east_t1, sphum_BC%east_t1, pe_eul_BC%east_t1, zvir, isd, ied, npx, ied, jsd, jed, npz) end if if (je == npy-1) then - ptBC => pt_BC%north_t1 - pkzBC => pkz_BC%north_t1 - sphumBC => sphum_BC%north_t1 if (is == 1) then istart = is else @@ -513,58 +836,58 @@ subroutine setup_pt_BC(pt_BC, pkz_BC, sphum_BC, npx, npy, npz, zvir, bd) iend = ied end if -!$OMP parallel do default(none) shared(npz,npy,jed,npx,istart,iend,ptBC,pkzBC,zvir,sphumBC) - do k=1,npz - do j=npy,jed - do i=istart,iend - ptBC(i,j,k) = ptBC(i,j,k)/pkzBC(i,j,k) * & - (1.+zvir*sphumBC(i,j,k)) - end do - end do - end do + call setup_pt_BC_k(pt_BC%north_t1, sphum_BC%north_t1, pe_eul_BC%north_t1, zvir, isd, ied, istart, iend, npy, jed, npz) end if end subroutine setup_pt_BC - subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & -#ifdef USE_COND - q_con_BC, & -#ifdef MOIST_CAPPA - cappa_BC, & -#endif -#endif - npx, npy, npz, zvir, bd) - type(fv_grid_bounds_type), intent(IN) :: bd - type(fv_nest_BC_type_3d), intent(IN), target :: delp_BC, delz_BC, sphum_BC - type(fv_nest_BC_type_3d), intent(INOUT), target :: pt_BC - integer, intent(IN) :: nq - type(fv_nest_BC_type_3d), intent(IN), target :: q_BC(nq) -#ifdef USE_COND - type(fv_nest_BC_type_3d), intent(INOUT), target :: q_con_BC -#ifdef MOIST_CAPPA - type(fv_nest_BC_type_3d), intent(INOUT), target :: cappa_BC -#endif -#endif - integer, intent(IN) :: npx, npy, npz - real, intent(IN) :: zvir +!!!! A NOTE ON NOMENCLATURE +!!!! Originally the BC arrays were bounded by isd and ied in the i-direction. +!!!! However these were NOT intended to delineate the dimensions of the data domain +!!!! but instead were of the BC arrays. This is confusing especially in other locations +!!!! where BCs and data arrays are both present. + subroutine setup_pt_BC_k(ptBC, sphumBC, peBC, zvir, isd_BC, ied_BC, istart, iend, jstart, jend, npz) + + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz + real, intent(IN) :: zvir + real, intent(INOUT), dimension(isd_BC:ied_BC,jstart:jend,npz) :: ptBC + real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz) :: sphumBC + real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz+1) :: peBC + + integer :: i,j,k + real :: pealn, pebln, rpkz + +!Assumes dry kappa +!$OMP parallel do default(none) shared(peBC,ptBC,zvir,sphumBC, & +!$OMP istart,iend,jstart,jend,npz) & +!$OMP private(pealn,pebln,rpkz) + do k=1,npz + do j=jstart,jend + do i=istart,iend + pealn = log(peBC(i,j,k)) + pebln = log(peBC(i,j,k+1)) + + rpkz = kappa*(pebln - pealn)/(exp(kappa*pebln)-exp(kappa*pealn) ) + + ptBC(i,j,k) = ptBC(i,j,k)*rpkz * & + (1.+zvir*sphumBC(i,j,k)) + enddo + enddo + enddo - real, parameter:: c_liq = 4185.5 !< heat capacity of water at 0C - real, parameter:: c_ice = 1972. !< heat capacity of ice at 0C: c=c_ice+7.3*(T-Tice) - real, parameter:: cv_vap = cp_vapor - rvgas !< 1384.5 + end subroutine setup_pt_BC_k - real, dimension(:,:,:), pointer :: ptBC, sphumBC, qconBC, delpBC, delzBC, cappaBC - real, dimension(:,:,:), pointer :: liq_watBC_west, ice_watBC_west, rainwatBC_west, snowwatBC_west, graupelBC_west - real, dimension(:,:,:), pointer :: liq_watBC_east, ice_watBC_east, rainwatBC_east, snowwatBC_east, graupelBC_east - real, dimension(:,:,:), pointer :: liq_watBC_north, ice_watBC_north, rainwatBC_north, snowwatBC_north, graupelBC_north - real, dimension(:,:,:), pointer :: liq_watBC_south, ice_watBC_south, rainwatBC_south, snowwatBC_south, graupelBC_south + subroutine setup_eul_delp_BC(delp_lag_BC, delp_eul_BC, pe_lag_BC, pe_eul_BC, ak_dst, bk_dst, npx, npy, npz, npz_coarse, ptop_src, bd) - real :: dp1, q_liq, q_sol, q_con = 0., cvm, pkz, rdg, cv_air + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_BC_type_3d), intent(INOUT), target :: delp_lag_BC + type(fv_nest_BC_type_3d), intent(INOUT), target :: delp_eul_BC, pe_lag_BC, pe_eul_BC + integer, intent(IN) :: npx, npy, npz, npz_coarse + real, intent(IN), dimension(npz+1) :: ak_dst, bk_dst + real, intent(IN) :: ptop_src integer :: i,j,k, istart, iend - integer :: liq_wat, ice_wat, rainwat, snowwat, graupel - real, parameter:: tice = 273.16 !< For GFS Partitioning - real, parameter:: t_i0 = 15. integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -578,63 +901,669 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & jsd = bd%jsd jed = bd%jed - rdg = -rdgas / grav - cv_air = cp_air - rdgas + if (is == 1) then + call setup_eul_delp_BC_k(delp_lag_BC%west_t1, delp_eul_BC%west_t1, pe_lag_BC%west_t1, pe_eul_BC%west_t1, & + ptop_src, ak_dst, bk_dst, isd, 0, isd, 0, jsd, jed, npz, npz_coarse) + end if - liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index (MODEL_ATMOS, 'graupel') + if (ie == npx-1) then + call setup_eul_delp_BC_k(delp_lag_BC%east_t1, delp_eul_BC%east_t1, pe_lag_BC%east_t1, pe_eul_BC%east_t1, & + ptop_src, ak_dst, bk_dst, npx, ied, npx, ied, jsd, jed, npz, npz_coarse) + end if if (is == 1) then - if (.not. allocated(dum_West)) then - allocate(dum_West(isd:0,jsd:jed,npz)) -!$OMP parallel do default(none) shared(npz,isd,jsd,jed,dum_West) - do k=1,npz - do j=jsd,jed - do i=isd,0 - dum_West(i,j,k) = 0. - enddo - enddo - enddo - endif - endif - if (js == 1) then - if (.not. allocated(dum_South)) then - allocate(dum_South(isd:ied,jsd:0,npz)) -!$OMP parallel do default(none) shared(npz,isd,ied,jsd,dum_South) - do k=1,npz - do j=jsd,0 - do i=isd,ied - dum_South(i,j,k) = 0. - enddo - enddo - enddo - endif - endif + istart = is + else + istart = isd + end if if (ie == npx-1) then - if (.not. allocated(dum_East)) then - allocate(dum_East(npx:ied,jsd:jed,npz)) -!$OMP parallel do default(none) shared(npx,npz,ied,jsd,jed,dum_East) - do k=1,npz - do j=jsd,jed - do i=npx,ied - dum_East(i,j,k) = 0. - enddo - enddo - enddo - endif - endif + iend = ie + else + iend = ied + end if + + if (js == 1) then + call setup_eul_delp_BC_k(delp_lag_BC%south_t1, delp_eul_BC%south_t1, pe_lag_BC%south_t1, pe_eul_BC%south_t1, & + ptop_src, ak_dst, bk_dst, isd, ied, istart, iend, jsd, 0, npz, npz_coarse) + end if + if (je == npy-1) then - if (.not. allocated(dum_North)) then - allocate(dum_North(isd:ied,npy:jed,npz)) -!$OMP parallel do default(none) shared(npy,npz,isd,ied,jed,dum_North) - do k=1,npz - do j=npy,jed - do i=isd,ied - dum_North(i,j,k) = 0. - enddo + call setup_eul_delp_BC_k(delp_lag_BC%north_t1, delp_eul_BC%north_t1, pe_lag_BC%north_t1, pe_eul_BC%north_t1, & + ptop_src, ak_dst, bk_dst, isd, ied, istart, iend, npy, jed, npz, npz_coarse) + end if + + end subroutine setup_eul_delp_BC + + subroutine setup_eul_delp_BC_k(delplagBC, delpeulBC, pelagBC, peeulBC, ptop_src, ak_dst, bk_dst, isd_BC, ied_BC, istart, iend, jstart, jend, npz, npz_coarse) + + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz, npz_coarse + real, intent(INOUT) :: delplagBC(isd_BC:ied_BC,jstart:jend,npz_coarse), pelagBC(isd_BC:ied_BC,jstart:jend,npz_coarse+1) + real, intent(INOUT) :: delpeulBC(isd_BC:ied_BC,jstart:jend,npz), peeulBC(isd_BC:ied_BC,jstart:jend,npz+1) + real, intent(IN) :: ptop_src, ak_dst(npz+1), bk_dst(npz+1) + + integer :: i,j,k + + character(len=120) :: errstring + + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,pelagBC,ptop_src) + do j=jstart,jend + do i=istart,iend + pelagBC(i,j,1) = ptop_src + enddo + enddo +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz_coarse,pelagBC,delplagBC) + do j=jstart,jend + do k=1,npz_coarse + do i=istart,iend + pelagBC(i,j,k+1) = pelagBC(i,j,k) + delplagBC(i,j,k) + end do + end do + end do +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,npz_coarse,peeulBC,pelagBC,ak_dst,bk_dst) + do k=1,npz+1 + do j=jstart,jend + do i=istart,iend + peeulBC(i,j,k) = ak_dst(k) + pelagBC(i,j,npz_coarse+1)*bk_dst(k) + enddo + enddo + enddo +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,peeulBC,delpeulBC) + do k=1,npz + do j=jstart,jend + do i=istart,iend + delpeulBC(i,j,k) = peeulBC(i,j,k+1) - peeulBC(i,j,k) + enddo + enddo + enddo + +!!$!!! DEBUG CODE +!!$ !If more than a few percent difference then log the error +!!$ do k=1,npz +!!$ do j=jstart,jend +!!$ do i=istart,iend +!!$ if (delpeulBC(i,j,k) <= 0.) then +!!$ write(errstring,'(3I5, 3(2x, G))'), i, j, k, pelagBC(i,j,k), peeulBC(i,j,k) +!!$ call mpp_error(WARNING, ' Invalid pressure BC at '//errstring) +!!$ else if (abs( peeulBC(i,j,k) - pelagBC(i,j,k)) > 100.0 ) then +!!$ write(errstring,'(3I5, 3(2x, G))'), i, j, k, pelagBC(i,j,k), peeulBC(i,j,k) +!!$ call mpp_error(WARNING, ' Remap BC: pressure deviation at '//errstring) +!!$ endif +!!$ enddo +!!$ enddo +!!$ enddo +!!$!!! END DEBUG CODE + + end subroutine setup_eul_delp_BC_k + + subroutine copy_ps_BC(ps, pe_BC, npx, npy, npz, istag, jstag, bd) + + integer, intent(IN) :: npx, npy, npz, istag, jstag + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(IN) :: ps(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag) + type(fv_nest_BC_type_3d), intent(INOUT) :: pe_BC + + integer :: i,j,k, istart, iend + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (is == 1) then +!$OMP parallel do default(none) shared(isd,jsd,jed,jstag,npz,pe_BC,ps) + do j=jsd,jed+jstag + do i=isd,0 + pe_BC%west_t1(i,j,npz+1) = ps(i,j) + enddo + enddo + end if + + if (ie == npx-1) then +!$OMP parallel do default(none) shared(npx,ied,istag,jsd,jed,jstag,npz,pe_BC,ps) + do j=jsd,jed+jstag + do i=npx+istag,ied+istag + pe_BC%east_t1(i,j,npz+1) = ps(i,j) + enddo + enddo + end if + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then +!$OMP parallel do default(none) shared(isd,ied,istag,jsd,npz,pe_BC,ps) + do j=jsd,0 + do i=isd,ied+istag + pe_BC%south_t1(i,j,npz+1) = ps(i,j) + enddo + enddo + end if + + if (je == npy-1) then +!$OMP parallel do default(none) shared(isd,ied,istag,npy,jed,jstag,npz,pe_BC,ps) + do j=npy+jstag,jed+jstag + do i=isd,ied+istag + pe_BC%north_t1(i,j,npz+1) = ps(i,j) + enddo + enddo + end if + + end subroutine copy_ps_BC + +!In this routine, the pe_*_BC arrays should already have PS filled in on the npz+1 level + subroutine setup_eul_pe_BC(pe_src_BC, pe_eul_BC, ak_dst, bk_dst, npx, npy, npz, npz_src, istag, jstag, bd, make_src_in, ak_src, bk_src) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_src_BC, pe_eul_BC + integer, intent(IN) :: npx, npy, npz, npz_src, istag, jstag + real, intent(IN), dimension(npz+1) :: ak_dst, bk_dst + logical, intent(IN), OPTIONAL :: make_src_in + real, intent(IN), OPTIONAL :: ak_src(npz_src), bk_src(npz_src) + + logical :: make_src + + integer :: i,j,k, istart, iend + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + make_src = .false. + if (present(make_src_in)) make_src = make_src_in + + if (is == 1) then + call setup_eul_pe_BC_k(pe_src_BC%west_t1, pe_eul_BC%west_t1, ak_dst, bk_dst, isd, 0, isd, 0, jsd, jed+jstag, npz, npz_src, & + make_src, ak_src, bk_src) + end if + + if (ie == npx-1) then + call setup_eul_pe_BC_k(pe_src_BC%east_t1, pe_eul_BC%east_t1, ak_dst, bk_dst, npx+istag, ied+istag, npx+istag, ied+istag, jsd, jed+jstag, npz, npz_src, & + make_src, ak_src, bk_src) + end if + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then + call setup_eul_pe_BC_k(pe_src_BC%south_t1, pe_eul_BC%south_t1, ak_dst, bk_dst, isd, ied+istag, istart, iend+istag, jsd, 0, npz, npz_src, & + make_src, ak_src, bk_src) + end if + + if (je == npy-1) then + call setup_eul_pe_BC_k(pe_src_BC%north_t1, pe_eul_BC%north_t1, ak_dst, bk_dst, isd, ied+istag, istart, iend+istag, npy+jstag, jed+jstag, npz, npz_src, & + make_src, ak_src, bk_src) + end if + + end subroutine setup_eul_pe_BC + + subroutine setup_eul_pe_BC_k(pesrcBC, peeulBC, ak_dst, bk_dst, isd_BC, ied_BC, istart, iend, jstart, jend, npz, npz_src, make_src, ak_src, bk_src) + + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz, npz_src + real, intent(INOUT) :: pesrcBC(isd_BC:ied_BC,jstart:jend,npz_src+1) + real, intent(INOUT) :: peeulBC(isd_BC:ied_BC,jstart:jend,npz+1) + real, intent(IN) :: ak_dst(npz+1), bk_dst(npz+1) + logical, intent(IN) :: make_src + real, intent(IN) :: ak_src(npz_src+1), bk_src(npz_src+1) + + integer :: i,j,k + + character(len=120) :: errstring + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,npz_src,peeulBC,ak_dst,pesrcBC,bk_dst) + do k=1,npz+1 + do j=jstart,jend + do i=istart,iend + peeulBC(i,j,k) = ak_dst(k) + pesrcBC(i,j,npz_src+1)*bk_dst(k) + enddo + enddo + enddo + + if (make_src) then +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz_src,pesrcBC,ak_src,bk_src) + do k=1,npz_src+1 + do j=jstart,jend + do i=istart,iend + pesrcBC(i,j,k) = ak_src(k) + pesrcBC(i,j,npz_src+1)*bk_src(k) + enddo + enddo + enddo + endif + + + end subroutine setup_eul_pe_BC_k + + subroutine remap_BC(pe_lag_BC, pe_eul_BC, var_lag_BC, var_eul_BC, npx, npy, npz, npz_coarse, bd, istag, jstag, iv, kord, varname, do_log_pe) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_lag_BC, var_lag_BC + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_eul_BC, var_eul_BC + integer, intent(IN) :: npx, npy, npz, npz_coarse, istag, jstag, iv, kord + character(len=*), intent(IN) :: varname + logical, intent(IN), OPTIONAL :: do_log_pe + + logical :: log_pe = .false. + + integer :: i,j,k, istart, iend + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (present(do_log_pe)) log_pe = do_log_pe + + if (is == 1) then + call remap_BC_k(pe_lag_BC%west_t1, pe_eul_BC%west_t1, var_lag_BC%west_t1, var_eul_BC%west_t1, isd, 0, isd, 0, jsd, jed+jstag, npz, npz_coarse, iv, kord, log_pe) + end if + + if (ie == npx-1) then + call remap_BC_k(pe_lag_BC%east_t1, pe_eul_BC%east_t1, var_lag_BC%east_t1, var_eul_BC%east_t1, npx+istag, ied+istag, npx+istag, ied+istag, jsd, jed+jstag, npz, npz_coarse, iv, kord, log_pe) + end if + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then + call remap_BC_k(pe_lag_BC%south_t1, pe_eul_BC%south_t1, var_lag_BC%south_t1, var_eul_BC%south_t1, isd, ied+istag, istart, iend+istag, jsd, 0, npz, npz_coarse, iv, kord, log_pe) + end if + + if (je == npy-1) then + call remap_BC_k(pe_lag_BC%north_t1, pe_eul_BC%north_t1, var_lag_BC%north_t1, var_eul_BC%north_t1, isd, ied+istag, istart, iend+istag, npy+jstag, jed+jstag, npz, npz_coarse, iv, kord, log_pe) + end if + + end subroutine remap_BC + + subroutine remap_BC_direct(pe_lag_BC, pe_eul_BC, var_lag_BC, var, npx, npy, npz, npz_coarse, bd, istag, jstag, iv, kord, do_log_pe) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npx, npy, npz, npz_coarse, istag, jstag, iv, kord + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_lag_BC, var_lag_BC + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_eul_BC + real, intent(INOUT) :: var(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,npz) + logical, intent(IN), OPTIONAL :: do_log_pe + + logical :: log_pe = .false. + + integer :: i,j,k, istart, iend + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (present(do_log_pe)) log_pe = do_log_pe + + if (is == 1) then + !I was unable how to do pass-by-memory referencing on parts of the 3D var array, + ! so instead I am doing an inefficient copy and copy-back. --- lmh 14jun17 + call remap_BC_k(pe_lag_BC%west_t1, pe_eul_BC%west_t1, var_lag_BC%west_t1, var(isd:0,jsd:jed+jstag,:), isd, 0, isd, 0, jsd, jed+jstag, npz, npz_coarse, iv, kord, log_pe) + end if + + if (ie == npx-1) then + call remap_BC_k(pe_lag_BC%east_t1, pe_eul_BC%east_t1, var_lag_BC%east_t1, var(npx+istag:ied+istag,jsd:jed+jstag,:), npx+istag, ied+istag, npx+istag, ied+istag, jsd, jed+jstag, npz, npz_coarse, iv, kord, log_pe) + end if + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then + call remap_BC_k(pe_lag_BC%south_t1, pe_eul_BC%south_t1, var_lag_BC%south_t1, var(isd:ied+istag,jsd:0,:), isd, ied+istag, istart, iend+istag, jsd, 0, npz, npz_coarse, iv, kord, log_pe) + end if + + if (je == npy-1) then + call remap_BC_k(pe_lag_BC%north_t1, pe_eul_BC%north_t1, var_lag_BC%north_t1, var(isd:ied+istag,npy+jstag:jed+jstag,:), isd, ied+istag, istart, iend+istag, npy+jstag, jed+jstag, npz, npz_coarse, iv, kord, log_pe) + end if + + end subroutine remap_BC_direct + + subroutine remap_BC_k(pe_lagBC, pe_eulBC, var_lagBC, var_eulBC, isd_BC, ied_BC, istart, iend, jstart, jend, npz, npz_coarse, iv, kord, log_pe) + + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz, npz_coarse, iv, kord + logical, intent(IN) :: log_pe + real, intent(INOUT) :: pe_lagBC(isd_BC:ied_BC,jstart:jend,npz_coarse+1), var_lagBC(isd_BC:ied_BC,jstart:jend,npz_coarse) + real, intent(INOUT) :: pe_eulBC(isd_BC:ied_BC,jstart:jend,npz+1), var_eulBC(isd_BC:ied_BC,jstart:jend,npz) + + integer :: i, j, k + real peln_lag(istart:iend,npz_coarse+1) + real peln_eul(istart:iend,npz+1) + character(120) :: errstring + + if (log_pe) then + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,npz_coarse,pe_lagBC,pe_eulBC,var_lagBC,var_eulBC,iv,kord) & +!$OMP private(peln_lag,peln_eul) + do j=jstart,jend + + do k=1,npz_coarse+1 + do i=istart,iend +!!$!!! DEBUG CODE +!!$ if (pe_lagBC(i,j,k) <= 0.) then +!!$ write(errstring,'(3I5, 2x, G)'), i, j, k, pe_lagBC(i,j,k) +!!$ call mpp_error(WARNING, ' Remap BC: invalid pressure at at '//errstring) +!!$ endif +!!$!!! END DEBUG CODE + peln_lag(i,k) = log(pe_lagBC(i,j,k)) + enddo + enddo + + do k=1,npz+1 + do i=istart,iend +!!$!!! DEBUG CODE +!!$ if (pe_lagBC(i,j,k) <= 0.) then +!!$ write(errstring,'(3I5, 2x, G)'), i, j, k, pe_lagBC(i,j,k) +!!$ call mpp_error(WARNING, ' Remap BC: invalid pressure at at '//errstring) +!!$ endif +!!$!!! END DEBUG CODE + peln_eul(i,k) = log(pe_eulBC(i,j,k)) + enddo + enddo + + call mappm(npz_coarse, peln_lag, var_lagBC(istart:iend,j:j,:), & + npz, peln_eul, var_eulBC(istart:iend,j:j,:), & + istart, iend, iv, kord, pe_eulBC(istart,j,1)) + + enddo + + else + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,npz_coarse,pe_lagBC,pe_eulBC,var_lagBC,var_eulBC,iv,kord) + do j=jstart,jend + + call mappm(npz_coarse, pe_lagBC(istart:iend,j:j,:), var_lagBC(istart:iend,j:j,:), & + npz, pe_eulBC(istart:iend,j:j,:), var_eulBC(istart:iend,j:j,:), & + istart, iend, iv, kord, pe_eulBC(istart,j,1)) + !!! NEED A FILLQ/FILLZ CALL HERE?? + + enddo + endif + + end subroutine remap_BC_k + + subroutine remap_delz_BC(pe_lag_BC, pe_eul_BC, delp_lag_BC, delz_lag_BC, delp_eul_BC, delz_eul_BC, npx, npy, npz, npz_coarse, bd, istag, jstag, iv, kord) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_lag_BC, delp_lag_BC, delz_lag_BC + type(fv_nest_BC_type_3d), intent(INOUT), target :: pe_eul_BC, delp_eul_BC, delz_eul_BC + integer, intent(IN) :: npx, npy, npz, npz_coarse, istag, jstag, iv, kord + + integer :: i,j,k, istart, iend + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (is == 1) then + call compute_specific_volume_BC_k(delp_lag_BC%west_t1, delz_lag_BC%west_t1, isd, 0, isd, 0, jsd, jed, npz_coarse) + call remap_BC_k(pe_lag_BC%west_t1, pe_eul_BC%west_t1, delz_lag_BC%west_t1, delz_eul_BC%west_t1, isd, 0, isd, 0, jsd, jed+jstag, & + npz, npz_coarse, iv, kord, log_pe=.false.) + call compute_delz_BC_k(delp_eul_BC%west_t1, delz_eul_BC%west_t1, isd, 0, isd, 0, jsd, jed, npz) + end if + + if (ie == npx-1) then + call compute_specific_volume_BC_k(delp_lag_BC%east_t1, delz_lag_BC%east_t1, npx+istag, ied+istag, npx+istag, ied+istag, jsd, jed+jstag, npz_coarse) + call remap_BC_k(pe_lag_BC%east_t1, pe_eul_BC%east_t1, delz_lag_BC%east_t1, delz_eul_BC%east_t1, npx+istag, ied+istag, npx+istag, ied+istag, jsd, jed+jstag, & + npz, npz_coarse, iv, kord, log_pe=.false.) + call compute_delz_BC_k(delp_eul_BC%east_t1, delz_eul_BC%east_t1, npx+istag, ied+istag, npx+istag, ied+istag, jsd, jed+jstag, npz) + end if + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then + call compute_specific_volume_BC_k(delp_lag_BC%south_t1, delz_lag_BC%south_t1, isd, ied+istag, istart, iend+istag, jsd, 0, npz_coarse) + call remap_BC_k(pe_lag_BC%south_t1, pe_eul_BC%south_t1, delz_lag_BC%south_t1, delz_eul_BC%south_t1, isd, ied+istag, istart, iend+istag, jsd, 0, npz, npz_coarse, & + iv, kord, log_pe=.false.) + call compute_delz_BC_k(delp_eul_BC%south_t1, delz_eul_BC%south_t1, isd, ied+istag, istart, iend+istag, jsd, 0, npz) + end if + + if (je == npy-1) then + call compute_specific_volume_BC_k(delp_lag_BC%north_t1, delz_lag_BC%north_t1, isd, ied+istag, istart, iend+istag, npy+jstag, jed+jstag, npz_coarse) + call remap_BC_k(pe_lag_BC%north_t1, pe_eul_BC%north_t1, delz_lag_BC%north_t1, delz_eul_BC%north_t1, & + isd, ied+istag, istart, iend+istag, npy+jstag, jed+jstag, npz, npz_coarse, iv, kord, log_pe=.false.) + call compute_delz_BC_k(delp_eul_BC%north_t1, delz_eul_BC%north_t1, isd, ied+istag, istart, iend+istag, npy+jstag, jed+jstag, npz) + end if + + end subroutine remap_delz_BC + + subroutine compute_specific_volume_BC_k(delpBC, delzBC, isd_BC, ied_BC, istart, iend, jstart, jend, npz) + + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz + real, intent(IN) :: delpBC(isd_BC:ied_BC,jstart:jend,npz) + real, intent(INOUT) :: delzBC(isd_BC:ied_BC,jstart:jend,npz) + + character(len=120) :: errstring + integer :: i,j,k + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,delzBC,delpBC) + do k=1,npz + do j=jstart,jend + do i=istart,iend + delzBC(i,j,k) = -delzBC(i,j,k)/delpBC(i,j,k) +!!$!!! DEBUG CODE +!!$ if (delzBC(i,j,k) <= 0. ) then +!!$ write(errstring,'(3I5, 2(2x, G))'), i, j, k, delzBC(i,j,k), delpBC(i,j,k) +!!$ call mpp_error(WARNING, ' Remap BC (sfc volume): invalid delz at '//errstring) +!!$ endif +!!$!!! END DEBUG CODE + end do + end do + end do + + end subroutine compute_specific_volume_BC_k + + subroutine compute_delz_BC_k(delpBC, delzBC, isd_BC, ied_BC, istart, iend, jstart, jend, npz) + + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz + real, intent(IN) :: delpBC(isd_BC:ied_BC,jstart:jend,npz) + real, intent(INOUT) :: delzBC(isd_BC:ied_BC,jstart:jend,npz) + + character(len=120) :: errstring + integer :: i,j,k + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,delzBC,delpBC) + do k=1,npz + do j=jstart,jend + do i=istart,iend + delzBC(i,j,k) = -delzBC(i,j,k)*delpBC(i,j,k) +!!$!!! DEBUG CODE +!!$ if (delzBC(i,j,k) >=0. ) then +!!$ write(errstring,'(3I5, 2(2x, G))'), i, j, k, delzBC(i,j,k), delpBC(i,j,k) +!!$ call mpp_error(WARNING, ' Remap BC (compute delz): invalid delz at '//errstring) +!!$ endif +!!$!!! END DEBUG CODE + end do + end do + end do + + end subroutine compute_delz_BC_k + + + subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & +#ifdef USE_COND + q_con_BC, & +#ifdef MOIST_CAPPA + cappa_BC, & +#endif +#endif + npx, npy, npz, zvir, bd) + + type(fv_grid_bounds_type), intent(IN) :: bd + type(fv_nest_BC_type_3d), intent(IN), target :: delp_BC, delz_BC, sphum_BC + type(fv_nest_BC_type_3d), intent(INOUT), target :: pt_BC + integer, intent(IN) :: nq + type(fv_nest_BC_type_3d), intent(IN), target :: q_BC(nq) +#ifdef USE_COND + type(fv_nest_BC_type_3d), intent(INOUT), target :: q_con_BC +#ifdef MOIST_CAPPA + type(fv_nest_BC_type_3d), intent(INOUT), target :: cappa_BC +#endif +#endif + integer, intent(IN) :: npx, npy, npz + real, intent(IN) :: zvir + + real, parameter:: c_liq = 4185.5 !< heat capacity of water at 0C + real, parameter:: c_ice = 1972. !< heat capacity of ice at 0C: c=c_ice+7.3*(T-Tice) + real, parameter:: cv_vap = cp_vapor - rvgas !< 1384.5 + + real, dimension(:,:,:), pointer :: liq_watBC_west, ice_watBC_west, rainwatBC_west, snowwatBC_west, graupelBC_west + real, dimension(:,:,:), pointer :: liq_watBC_east, ice_watBC_east, rainwatBC_east, snowwatBC_east, graupelBC_east + real, dimension(:,:,:), pointer :: liq_watBC_north, ice_watBC_north, rainwatBC_north, snowwatBC_north, graupelBC_north + real, dimension(:,:,:), pointer :: liq_watBC_south, ice_watBC_south, rainwatBC_south, snowwatBC_south, graupelBC_south + + real :: dp1, q_liq, q_sol, q_con = 0., cvm, pkz, rdg, cv_air + + integer :: i,j,k, istart, iend + integer :: liq_wat, ice_wat, rainwat, snowwat, graupel + real, parameter:: tice = 273.16 !< For GFS Partitioning + real, parameter:: t_i0 = 15. + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + rdg = -rdgas / grav + cv_air = cp_air - rdgas + + liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat') + ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat') + rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') + snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') + graupel = get_tracer_index (MODEL_ATMOS, 'graupel') + + if (is == 1) then + if (.not. allocated(dum_West)) then + allocate(dum_West(isd:0,jsd:jed,npz)) +!$OMP parallel do default(none) shared(npz,isd,jsd,jed,dum_West) + do k=1,npz + do j=jsd,jed + do i=isd,0 + dum_West(i,j,k) = 0. + enddo + enddo + enddo + endif + endif + if (js == 1) then + if (.not. allocated(dum_South)) then + allocate(dum_South(isd:ied,jsd:0,npz)) +!$OMP parallel do default(none) shared(npz,isd,ied,jsd,dum_South) + do k=1,npz + do j=jsd,0 + do i=isd,ied + dum_South(i,j,k) = 0. + enddo + enddo + enddo + endif + endif + if (ie == npx-1) then + if (.not. allocated(dum_East)) then + allocate(dum_East(npx:ied,jsd:jed,npz)) +!$OMP parallel do default(none) shared(npx,npz,ied,jsd,jed,dum_East) + do k=1,npz + do j=jsd,jed + do i=npx,ied + dum_East(i,j,k) = 0. + enddo + enddo + enddo + endif + endif + if (je == npy-1) then + if (.not. allocated(dum_North)) then + allocate(dum_North(isd:ied,npy:jed,npz)) +!$OMP parallel do default(none) shared(npy,npz,isd,ied,jed,dum_North) + do k=1,npz + do j=npy,jed + do i=isd,ied + dum_North(i,j,k) = 0. + enddo enddo enddo endif @@ -688,76 +1617,29 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & graupelBC_west => q_BC(graupel)%west_t1 graupelBC_east => q_BC(graupel)%east_t1 graupelBC_north => q_BC(graupel)%north_t1 - graupelBC_south => q_BC(graupel)%south_t1 - else - graupelBC_west => dum_west - graupelBC_east => dum_east - graupelBC_north => dum_north - graupelBC_south => dum_south - endif - - if (is == 1) then - ptBC => pt_BC%west_t1 - sphumBC => sphum_BC%west_t1 -#ifdef USE_COND - qconBC => q_con_BC%west_t1 -#ifdef MOIST_CAPPA - cappaBC => cappa_BC%west_t1 -#endif -#endif - delpBC => delp_BC%west_t1 - delzBC => delz_BC%west_t1 - -!$OMP parallel do default(none) shared(npz,jsd,jed,isd,zvir,sphumBC,liq_watBC_west,rainwatBC_west,ice_watBC_west,snowwatBC_west,graupelBC_west,qconBC,cappaBC, & -!$OMP rdg,cv_air,delpBC,delzBC,ptBC) & -!$OMP private(dp1,q_con,q_liq,q_sol,cvm,pkz) - do k=1,npz - do j=jsd,jed - do i=isd,0 - dp1 = zvir*sphumBC(i,j,k) -#ifdef USE_COND -#ifdef GFS_PHYS - q_con = liq_watBC_west(i,j,k) - q_sol = q_con*max(min((tice-ptBC(i,j,k))/t_i0,1.),0.) - q_liq = q_con - q_sol -#else - q_liq = liq_watBC_west(i,j,k) + rainwatBC_west(i,j,k) - q_sol = ice_watBC_west(i,j,k) + snowwatBC_west(i,j,k) + graupelBC_west(i,j,k) - q_con = q_liq + q_sol -#endif - qconBC(i,j,k) = q_con -#ifdef MOIST_CAPPA - cvm = (1.-(sphumBC(i,j,k)+q_con))*cv_air+sphumBC(i,j,k)*cv_vap+q_liq*c_liq+q_sol*c_ice - cappaBC(i,j,k) = rdgas/(rdgas + cvm/(1.+dp1)) - pkz = exp( cappaBC(i,j,k)*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) -#endif - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)*(1.-q_con)/pkz -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)/delzBC(i,j,k))) - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)/pkz -#endif - end do - end do - end do - end if + graupelBC_south => q_BC(graupel)%south_t1 + else + graupelBC_west => dum_west + graupelBC_east => dum_east + graupelBC_north => dum_north + graupelBC_south => dum_south + endif + if (is == 1) then - if (js == 1) then - ptBC => pt_BC%south_t1 - sphumBC => sphum_BC%south_t1 + call setup_pt_NH_BC_k(pt_BC%west_t1, sphum_BC%west_t1, delp_BC%west_t1, delz_BC%west_t1, & + liq_watBC_west, rainwatBC_west, ice_watBC_west, snowwatBC_west, graupelBC_west, & #ifdef USE_COND - qconBC => q_con_BC%south_t1 + q_con_BC%west_t1, & #ifdef MOIST_CAPPA - cappaBC => cappa_BC%south_t1 + cappa_BC%west_t1, & #endif #endif - delpBC => delp_BC%south_t1 - delzBC => delz_BC%south_t1 + zvir, isd, 0, isd, 0, jsd, jed, npz) + end if + + + if (js == 1) then if (is == 1) then istart = is else @@ -769,108 +1651,32 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & iend = ied end if -!$OMP parallel do default(none) shared(npz,jsd,istart,iend,zvir,sphumBC, & -!$OMP liq_watBC_south,rainwatBC_south,ice_watBC_south,& -!$OMP snowwatBC_south,graupelBC_south,qconBC,cappaBC, & -!$OMP rdg,cv_air,delpBC,delzBC,ptBC) & -!$OMP private(dp1,q_con,q_liq,q_sol,cvm,pkz) - do k=1,npz - do j=jsd,0 - do i=istart,iend - dp1 = zvir*sphumBC(i,j,k) + call setup_pt_NH_BC_k(pt_BC%south_t1, sphum_BC%south_t1, delp_BC%south_t1, delz_BC%south_t1, & + liq_watBC_south, rainwatBC_south, ice_watBC_south, snowwatBC_south, graupelBC_south, & #ifdef USE_COND -#ifdef GFS_PHYS - q_con = liq_watBC_south(i,j,k) - q_sol = q_con*max(min((tice-ptBC(i,j,k))/t_i0,1.),0.) - q_liq = q_con - q_sol -#else - q_liq = liq_watBC_south(i,j,k) + rainwatBC_south(i,j,k) - q_sol = ice_watBC_south(i,j,k) + snowwatBC_south(i,j,k) + graupelBC_south(i,j,k) - q_con = q_liq + q_sol -#endif - qconBC(i,j,k) = q_con + q_con_BC%south_t1, & #ifdef MOIST_CAPPA - cvm = (1.-(sphumBC(i,j,k)+q_con))*cv_air+sphumBC(i,j,k)*cv_vap+q_liq*c_liq+q_sol*c_ice - cappaBC(i,j,k) = rdgas/(rdgas + cvm/(1.+dp1)) - pkz = exp( cappaBC(i,j,k)*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) + cappa_BC%south_t1, & #endif - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)*(1.-q_con)/pkz -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)/delzBC(i,j,k))) - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)/pkz #endif - end do - end do - end do + zvir, isd, ied, istart, iend, jsd, 0, npz) end if if (ie == npx-1) then - ptBC => pt_BC%east_t1 - sphumBC => sphum_BC%east_t1 -#ifdef USE_COND - qconBC => q_con_BC%east_t1 -#ifdef MOIST_CAPPA - cappaBC => cappa_BC%east_t1 -#endif -#endif - delpBC => delp_BC%east_t1 - delzBC => delz_BC%east_t1 -!$OMP parallel do default(none) shared(npz,jsd,jed,npx,ied,zvir,sphumBC, & -!$OMP liq_watBC_east,rainwatBC_east,ice_watBC_east,snowwatBC_east,graupelBC_east,qconBC,cappaBC, & -!$OMP rdg,cv_air,delpBC,delzBC,ptBC) & -!$OMP private(dp1,q_con,q_liq,q_sol,cvm,pkz) - do k=1,npz - do j=jsd,jed - do i=npx,ied - dp1 = zvir*sphumBC(i,j,k) + + call setup_pt_NH_BC_k(pt_BC%east_t1, sphum_BC%east_t1, delp_BC%east_t1, delz_BC%east_t1, & + liq_watBC_east, rainwatBC_east, ice_watBC_east, snowwatBC_east, graupelBC_east, & #ifdef USE_COND -#ifdef GFS_PHYS - q_con = liq_watBC_east(i,j,k) - q_sol = q_con*max(min((tice-ptBC(i,j,k))/t_i0,1.),0.) - q_liq = q_con - q_sol -#else - q_liq = liq_watBC_east(i,j,k) + rainwatBC_east(i,j,k) - q_sol = ice_watBC_east(i,j,k) + snowwatBC_east(i,j,k) + graupelBC_east(i,j,k) - q_con = q_liq + q_sol -#endif - qconBC(i,j,k) = q_con + q_con_BC%east_t1, & #ifdef MOIST_CAPPA - cvm = (1.-(sphumBC(i,j,k)+q_con))*cv_air+sphumBC(i,j,k)*cv_vap+q_liq*c_liq+q_sol*c_ice - cappaBC(i,j,k) = rdgas/(rdgas + cvm/(1.+dp1)) - pkz = exp( cappaBC(i,j,k)*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)*(1.-q_con)/delzBC(i,j,k))) + cappa_BC%east_t1, & #endif - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)*(1.-q_con)/pkz -#else - pkz = exp( kappa*log(rdg*delpBC(i,j,k)*ptBC(i,j,k) * & - (1.+dp1)/delzBC(i,j,k))) - ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)/pkz #endif - end do - end do - end do + zvir, npx, ied, npx, ied, jsd, jed, npz) end if if (je == npy-1) then - ptBC => pt_BC%north_t1 - sphumBC => sphum_BC%north_t1 -#ifdef USE_COND - qconBC => q_con_BC%north_t1 -#ifdef MOIST_CAPPA - cappaBC => cappa_BC%north_t1 -#endif -#endif - delpBC => delp_BC%north_t1 - delzBC => delz_BC%north_t1 if (is == 1) then istart = is else @@ -882,25 +1688,76 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & iend = ied end if -!$OMP parallel do default(none) shared(npz,npy,jed,istart,iend,zvir, & -!$OMP sphumBC,liq_watBC_north,rainwatBC_north,ice_watBC_north,snowwatBC_north,graupelBC_north,qconBC,cappaBC, & -!$OMP rdg,cv_air,delpBC,delzBC,ptBC) & -!$OMP private(dp1,q_con,q_liq,q_sol,cvm,pkz) - do k=1,npz - do j=npy,jed - do i=istart,iend + call setup_pt_NH_BC_k(pt_BC%north_t1, sphum_BC%north_t1, delp_BC%north_t1, delz_BC%north_t1, & + liq_watBC_north, rainwatBC_north, ice_watBC_north, snowwatBC_north, graupelBC_north, & +#ifdef USE_COND + q_con_BC%north_t1, & +#ifdef MOIST_CAPPA + cappa_BC%north_t1, & +#endif +#endif + zvir, isd, ied, istart, iend, npy, jed, npz) + end if + + end subroutine setup_pt_NH_BC + + + subroutine setup_pt_NH_BC_k(ptBC,sphumBC,delpBC,delzBC, & + liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC, & +#ifdef USE_COND + q_conBC, & +#ifdef MOIST_CAPPA + cappaBC, & +#endif +#endif + zvir, isd_BC, ied_BC, istart, iend, jstart, jend, npz) + + integer, intent(IN) :: isd_BC, ied_BC, istart, iend, jstart, jend, npz + real, intent(OUT), dimension(isd_BC:ied_BC,jstart:jend,npz) :: ptBC + real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz) :: sphumBC, delpBC, delzBC + real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz) :: liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC +#ifdef USE_COND + real, intent(OUT), dimension(isd_BC:ied_BC,jstart:jend,npz) :: q_conBC +#ifdef MOIST_CAPPA + real, intent(OUT), dimension(isd_BC:ied_BC,jstart:jend,npz) :: cappaBC +#endif +#endif + real, intent(IN) :: zvir + + integer :: i,j,k + real :: dp1, q_con, q_sol, q_liq, cvm, pkz, rdg, cv_air + + real, parameter:: c_liq = 4185.5 ! heat capacity of water at 0C + real, parameter:: c_ice = 1972. ! heat capacity of ice at 0C: c=c_ice+7.3*(T-Tice) + real, parameter:: cv_vap = cp_vapor - rvgas ! 1384.5 + real, parameter:: tice = 273.16 ! For GFS Partitioning + real, parameter:: t_i0 = 15. + + rdg = -rdgas / grav + cv_air = cp_air - rdgas + +!!$!!! DEBUG CODE +!!$ write(*, '(A, 7I5)') 'setup_pt_NH_BC_k', mpp_pe(), isd, ied, istart, iend, lbound(ptBC,1), ubound(ptBC,1) +!!$!!! END DEBUG CODE + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,zvir,ptBC,sphumBC,delpBC,delzBC,liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC, & +#ifdef USE_COND +!$OMP q_conBC, & +#ifdef MOIST_CAPPA +!$OMP cappaBC, & +#endif +#endif +!$OMP rdg, cv_air) & +!$OMP private(dp1,q_liq,q_sol,q_con,cvm,pkz) + do k=1,npz + do j=jstart,jend + do i=istart,iend dp1 = zvir*sphumBC(i,j,k) #ifdef USE_COND -#ifdef GFS_PHYS - q_con = liq_watBC_north(i,j,k) - q_sol = q_con*max(min((tice-ptBC(i,j,k))/t_i0,1.),0.) - q_liq = q_con - q_sol -#else - q_liq = liq_watBC_north(i,j,k) + rainwatBC_north(i,j,k) - q_sol = ice_watBC_north(i,j,k) + snowwatBC_north(i,j,k) + graupelBC_north(i,j,k) + q_liq = liq_watBC(i,j,k) + rainwatBC(i,j,k) + q_sol = ice_watBC(i,j,k) + snowwatBC(i,j,k) + graupelBC(i,j,k) q_con = q_liq + q_sol -#endif - qconBC(i,j,k) = q_con + q_conBC(i,j,k) = q_con #ifdef MOIST_CAPPA cvm = (1.-(sphumBC(i,j,k)+q_con))*cv_air+sphumBC(i,j,k)*cv_vap+q_liq*c_liq+q_sol*c_ice cappaBC(i,j,k) = rdgas/(rdgas + cvm/(1.+dp1)) @@ -916,15 +1773,11 @@ subroutine setup_pt_NH_BC(pt_BC, delp_BC, delz_BC, sphum_BC, q_BC, nq, & (1.+dp1)/delzBC(i,j,k))) ptBC(i,j,k) = ptBC(i,j,k)*(1.+dp1)/pkz #endif - end do - end do - end do - end if - - - - end subroutine setup_pt_NH_BC + end do + end do + end do + end subroutine setup_pt_NH_BC_k subroutine set_NH_BCs_t0(neststruct) @@ -936,84 +1789,499 @@ subroutine set_NH_BCs_t0(neststruct) neststruct%delz_BC%north_t0 = neststruct%delz_BC%north_t1 neststruct%delz_BC%south_t0 = neststruct%delz_BC%south_t1 - neststruct%w_BC%east_t0 = neststruct%w_BC%east_t1 - neststruct%w_BC%west_t0 = neststruct%w_BC%west_t1 - neststruct%w_BC%north_t0 = neststruct%w_BC%north_t1 - neststruct%w_BC%south_t0 = neststruct%w_BC%south_t1 -#endif + neststruct%w_BC%east_t0 = neststruct%w_BC%east_t1 + neststruct%w_BC%west_t0 = neststruct%w_BC%west_t1 + neststruct%w_BC%north_t0 = neststruct%w_BC%north_t1 + neststruct%w_BC%south_t0 = neststruct%w_BC%south_t1 +#endif + + end subroutine set_NH_BCs_t0 + + subroutine set_BCs_t0(ncnst, hydrostatic, neststruct) + + integer, intent(IN) :: ncnst + logical, intent(IN) :: hydrostatic + type(fv_nest_type), intent(INOUT) :: neststruct + + integer :: n + + neststruct%delp_BC%east_t0 = neststruct%delp_BC%east_t1 + neststruct%delp_BC%west_t0 = neststruct%delp_BC%west_t1 + neststruct%delp_BC%north_t0 = neststruct%delp_BC%north_t1 + neststruct%delp_BC%south_t0 = neststruct%delp_BC%south_t1 + do n=1,ncnst + neststruct%q_BC(n)%east_t0 = neststruct%q_BC(n)%east_t1 + neststruct%q_BC(n)%west_t0 = neststruct%q_BC(n)%west_t1 + neststruct%q_BC(n)%north_t0 = neststruct%q_BC(n)%north_t1 + neststruct%q_BC(n)%south_t0 = neststruct%q_BC(n)%south_t1 + enddo +#ifndef SW_DYNAMICS + neststruct%pt_BC%east_t0 = neststruct%pt_BC%east_t1 + neststruct%pt_BC%west_t0 = neststruct%pt_BC%west_t1 + neststruct%pt_BC%north_t0 = neststruct%pt_BC%north_t1 + neststruct%pt_BC%south_t0 = neststruct%pt_BC%south_t1 + neststruct%pt_BC%east_t0 = neststruct%pt_BC%east_t1 + neststruct%pt_BC%west_t0 = neststruct%pt_BC%west_t1 + neststruct%pt_BC%north_t0 = neststruct%pt_BC%north_t1 + neststruct%pt_BC%south_t0 = neststruct%pt_BC%south_t1 + +#ifdef USE_COND + neststruct%q_con_BC%east_t0 = neststruct%q_con_BC%east_t1 + neststruct%q_con_BC%west_t0 = neststruct%q_con_BC%west_t1 + neststruct%q_con_BC%north_t0 = neststruct%q_con_BC%north_t1 + neststruct%q_con_BC%south_t0 = neststruct%q_con_BC%south_t1 +#ifdef MOIST_CAPPA + neststruct%cappa_BC%east_t0 = neststruct%cappa_BC%east_t1 + neststruct%cappa_BC%west_t0 = neststruct%cappa_BC%west_t1 + neststruct%cappa_BC%north_t0 = neststruct%cappa_BC%north_t1 + neststruct%cappa_BC%south_t0 = neststruct%cappa_BC%south_t1 +#endif +#endif + + if (.not. hydrostatic) then + call set_NH_BCs_t0(neststruct) + endif +#endif + neststruct%u_BC%east_t0 = neststruct%u_BC%east_t1 + neststruct%u_BC%west_t0 = neststruct%u_BC%west_t1 + neststruct%u_BC%north_t0 = neststruct%u_BC%north_t1 + neststruct%u_BC%south_t0 = neststruct%u_BC%south_t1 + neststruct%v_BC%east_t0 = neststruct%v_BC%east_t1 + neststruct%v_BC%west_t0 = neststruct%v_BC%west_t1 + neststruct%v_BC%north_t0 = neststruct%v_BC%north_t1 + neststruct%v_BC%south_t0 = neststruct%v_BC%south_t1 + + + neststruct%vc_BC%east_t0 = neststruct%vc_BC%east_t1 + neststruct%vc_BC%west_t0 = neststruct%vc_BC%west_t1 + neststruct%vc_BC%north_t0 = neststruct%vc_BC%north_t1 + neststruct%vc_BC%south_t0 = neststruct%vc_BC%south_t1 + neststruct%uc_BC%east_t0 = neststruct%uc_BC%east_t1 + neststruct%uc_BC%west_t0 = neststruct%uc_BC%west_t1 + neststruct%uc_BC%north_t0 = neststruct%uc_BC%north_t1 + neststruct%uc_BC%south_t0 = neststruct%uc_BC%south_t1 + + neststruct%divg_BC%east_t0 = neststruct%divg_BC%east_t1 + neststruct%divg_BC%west_t0 = neststruct%divg_BC%west_t1 + neststruct%divg_BC%north_t0 = neststruct%divg_BC%north_t1 + neststruct%divg_BC%south_t0 = neststruct%divg_BC%south_t1 + + end subroutine set_BCs_t0 + + subroutine d2c_setup(u, v, & + ua, va, & + uc, vc, dord4, & + isd,ied,jsd,jed, is,ie,js,je, npx,npy, & + grid_type, bounded_domain, & + se_corner, sw_corner, ne_corner, nw_corner, & + rsin_u,rsin_v,cosa_s,rsin2 ) + + logical, intent(in):: dord4 + real, intent(in) :: u(isd:ied,jsd:jed+1) + real, intent(in) :: v(isd:ied+1,jsd:jed) + real, intent(out), dimension(isd:ied ,jsd:jed ):: ua + real, intent(out), dimension(isd:ied ,jsd:jed ):: va + real, intent(out), dimension(isd:ied+1,jsd:jed ):: uc + real, intent(out), dimension(isd:ied ,jsd:jed+1):: vc + integer, intent(in) :: isd,ied,jsd,jed, is,ie,js,je, npx,npy,grid_type + logical, intent(in) :: bounded_domain, se_corner, sw_corner, ne_corner, nw_corner + real, intent(in) :: rsin_u(isd:ied+1,jsd:jed) + real, intent(in) :: rsin_v(isd:ied,jsd:jed+1) + real, intent(in) :: cosa_s(isd:ied,jsd:jed) + real, intent(in) :: rsin2(isd:ied,jsd:jed) + +! Local + real, dimension(isd:ied,jsd:jed):: utmp, vtmp + real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28. + real, parameter:: a1 = 0.5625 + real, parameter:: a2 = -0.0625 + real, parameter:: c1 = -2./14. + real, parameter:: c2 = 11./14. + real, parameter:: c3 = 5./14. + integer npt, i, j, ifirst, ilast, id + + if ( dord4) then + id = 1 + else + id = 0 + endif + + + if (grid_type < 3 .and. .not. bounded_domain) then + npt = 4 + else + npt = -2 + endif + + if ( bounded_domain) then + + do j=jsd+1,jed-1 + do i=isd,ied + utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) + enddo + enddo + do i=isd,ied + j = jsd + utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) + j = jed + utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) + end do + + do j=jsd,jed + do i=isd+1,ied-1 + vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) + enddo + i = isd + vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) + i = ied + vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) + enddo + + do j=jsd,jed + do i=isd,ied + ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + enddo + enddo + + else + + !---------- + ! Interior: + !---------- + utmp = 0. + vtmp = 0. + + + do j=max(npt,js-1),min(npy-npt,je+1) + do i=max(npt,isd),min(npx-npt,ied) + utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) + enddo + enddo + do j=max(npt,jsd),min(npy-npt,jed) + do i=max(npt,is-1),min(npx-npt,ie+1) + vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) + enddo + enddo + + !---------- + ! edges: + !---------- + if (grid_type < 3) then + + if ( js==1 .or. jsd=(npy-npt)) then + do j=npy-npt+1,jed + do i=isd,ied + utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) + vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) + enddo + enddo + endif + + if ( is==1 .or. isd=(npx-npt)) then + do j=max(npt,jsd),min(npy-npt,jed) + do i=npx-npt+1,ied + utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) + vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) + enddo + enddo + endif + + endif + do j=js-1-id,je+1+id + do i=is-1-id,ie+1+id + ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + enddo + enddo + + end if + +! A -> C +!-------------- +! Fix the edges +!-------------- +! Xdir: + if( sw_corner ) then + do i=-2,0 + utmp(i,0) = -vtmp(0,1-i) + enddo + endif + if( se_corner ) then + do i=0,2 + utmp(npx+i,0) = vtmp(npx,i+1) + enddo + endif + if( ne_corner ) then + do i=0,2 + utmp(npx+i,npy) = -vtmp(npx,je-i) + enddo + endif + if( nw_corner ) then + do i=-2,0 + utmp(i,npy) = vtmp(0,je+i) + enddo + endif + + if (grid_type < 3 .and. .not. bounded_domain) then + ifirst = max(3, is-1) + ilast = min(npx-2,ie+2) + else + ifirst = is-1 + ilast = ie+2 + endif +!--------------------------------------------- +! 4th order interpolation for interior points: +!--------------------------------------------- + do j=js-1,je+1 + do i=ifirst,ilast + uc(i,j) = a1*(utmp(i-1,j)+utmp(i,j))+a2*(utmp(i-2,j)+utmp(i+1,j)) + enddo + enddo + + if (grid_type < 3) then +! Xdir: + if( is==1 .and. .not. bounded_domain ) then + do j=js-1,je+1 + uc(0,j) = c1*utmp(-2,j) + c2*utmp(-1,j) + c3*utmp(0,j) + uc(1,j) = ( t14*(utmp( 0,j)+utmp(1,j)) & + + t12*(utmp(-1,j)+utmp(2,j)) & + + t15*(utmp(-2,j)+utmp(3,j)) )*rsin_u(1,j) + uc(2,j) = c1*utmp(3,j) + c2*utmp(2,j) + c3*utmp(1,j) + enddo + endif + + if( (ie+1)==npx .and. .not. bounded_domain ) then + do j=js-1,je+1 + uc(npx-1,j) = c1*utmp(npx-3,j)+c2*utmp(npx-2,j)+c3*utmp(npx-1,j) + uc(npx,j) = (t14*(utmp(npx-1,j)+utmp(npx,j))+ & + t12*(utmp(npx-2,j)+utmp(npx+1,j)) & + + t15*(utmp(npx-3,j)+utmp(npx+2,j)))*rsin_u(npx,j) + uc(npx+1,j) = c3*utmp(npx,j)+c2*utmp(npx+1,j)+c1*utmp(npx+2,j) + enddo + endif + + endif + +!------ +! Ydir: +!------ + if( sw_corner ) then + do j=-2,0 + vtmp(0,j) = -utmp(1-j,0) + enddo + endif + if( nw_corner ) then + do j=0,2 + vtmp(0,npy+j) = utmp(j+1,npy) + enddo + endif + if( se_corner ) then + do j=-2,0 + vtmp(npx,j) = utmp(ie+j,0) + enddo + endif + if( ne_corner ) then + do j=0,2 + vtmp(npx,npy+j) = -utmp(ie-j,npy) + enddo + endif + + if (grid_type < 3) then + + do j=js-1,je+2 + if ( j==1 .and. .not. bounded_domain) then + do i=is-1,ie+1 + vc(i,1) = (t14*(vtmp(i, 0)+vtmp(i,1)) & + + t12*(vtmp(i,-1)+vtmp(i,2)) & + + t15*(vtmp(i,-2)+vtmp(i,3)))*rsin_v(i,1) + enddo + elseif ( (j==0 .or. j==(npy-1)) .and. .not. bounded_domain) then + do i=is-1,ie+1 + vc(i,j) = c1*vtmp(i,j-2) + c2*vtmp(i,j-1) + c3*vtmp(i,j) + enddo + elseif ( (j==2 .or. j==(npy+1)) .and. .not. bounded_domain) then + do i=is-1,ie+1 + vc(i,j) = c1*vtmp(i,j+1) + c2*vtmp(i,j) + c3*vtmp(i,j-1) + enddo + elseif ( j==npy .and. .not. bounded_domain) then + do i=is-1,ie+1 + vc(i,npy) = (t14*(vtmp(i,npy-1)+vtmp(i,npy)) & + + t12*(vtmp(i,npy-2)+vtmp(i,npy+1)) & + + t15*(vtmp(i,npy-3)+vtmp(i,npy+2)))*rsin_v(i,npy) + enddo + else +! 4th order interpolation for interior points: + do i=is-1,ie+1 + vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j)) + enddo + endif + enddo + else +! 4th order interpolation: + do j=js-1,je+2 + do i=is-1,ie+1 + vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j)) + enddo + enddo + endif + + end subroutine d2c_setup + + subroutine d2a_setup(u, v, ua, va, dord4, & + isd,ied,jsd,jed, is,ie,js,je, npx,npy, & + grid_type, bounded_domain, & + cosa_s,rsin2 ) + + logical, intent(in):: dord4 + real, intent(in) :: u(isd:ied,jsd:jed+1) + real, intent(in) :: v(isd:ied+1,jsd:jed) + real, intent(out), dimension(isd:ied ,jsd:jed ):: ua + real, intent(out), dimension(isd:ied ,jsd:jed ):: va + integer, intent(in) :: isd,ied,jsd,jed, is,ie,js,je, npx,npy,grid_type + real, intent(in) :: cosa_s(isd:ied,jsd:jed) + real, intent(in) :: rsin2(isd:ied,jsd:jed) + logical, intent(in) :: bounded_domain + +! Local + real, dimension(isd:ied,jsd:jed):: utmp, vtmp + real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28. + real, parameter:: a1 = 0.5625 + real, parameter:: a2 = -0.0625 + real, parameter:: c1 = -2./14. + real, parameter:: c2 = 11./14. + real, parameter:: c3 = 5./14. + integer npt, i, j, ifirst, ilast, id + + if ( dord4) then + id = 1 + else + id = 0 + endif + + + if (grid_type < 3 .and. .not. bounded_domain) then + npt = 4 + else + npt = -2 + endif + + if ( bounded_domain) then + + do j=jsd+1,jed-1 + do i=isd,ied + utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) + enddo + enddo + do i=isd,ied + j = jsd + utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) + j = jed + utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) + end do + + do j=jsd,jed + do i=isd+1,ied-1 + vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) + enddo + i = isd + vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) + i = ied + vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) + enddo - end subroutine set_NH_BCs_t0 + else - subroutine set_BCs_t0(ncnst, hydrostatic, neststruct) + !---------- + ! Interior: + !---------- - integer, intent(IN) :: ncnst - logical, intent(IN) :: hydrostatic - type(fv_nest_type), intent(INOUT) :: neststruct + do j=max(npt,js-1),min(npy-npt,je+1) + do i=max(npt,isd),min(npx-npt,ied) + utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) + enddo + enddo + do j=max(npt,jsd),min(npy-npt,jed) + do i=max(npt,is-1),min(npx-npt,ie+1) + vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) + enddo + enddo - integer :: n + !---------- + ! edges: + !---------- + if (grid_type < 3) then + + if ( js==1 .or. jsd=(npy-npt)) then + do j=npy-npt+1,jed + do i=isd,ied + utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) + vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) + enddo + enddo + endif + + if ( is==1 .or. isd=(npx-npt)) then + do j=max(npt,jsd),min(npy-npt,jed) + do i=npx-npt+1,ied + utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) + vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) + enddo + enddo + endif - neststruct%delp_BC%east_t0 = neststruct%delp_BC%east_t1 - neststruct%delp_BC%west_t0 = neststruct%delp_BC%west_t1 - neststruct%delp_BC%north_t0 = neststruct%delp_BC%north_t1 - neststruct%delp_BC%south_t0 = neststruct%delp_BC%south_t1 - do n=1,ncnst - neststruct%q_BC(n)%east_t0 = neststruct%q_BC(n)%east_t1 - neststruct%q_BC(n)%west_t0 = neststruct%q_BC(n)%west_t1 - neststruct%q_BC(n)%north_t0 = neststruct%q_BC(n)%north_t1 - neststruct%q_BC(n)%south_t0 = neststruct%q_BC(n)%south_t1 - enddo -#ifndef SW_DYNAMICS - neststruct%pt_BC%east_t0 = neststruct%pt_BC%east_t1 - neststruct%pt_BC%west_t0 = neststruct%pt_BC%west_t1 - neststruct%pt_BC%north_t0 = neststruct%pt_BC%north_t1 - neststruct%pt_BC%south_t0 = neststruct%pt_BC%south_t1 - neststruct%pt_BC%east_t0 = neststruct%pt_BC%east_t1 - neststruct%pt_BC%west_t0 = neststruct%pt_BC%west_t1 - neststruct%pt_BC%north_t0 = neststruct%pt_BC%north_t1 - neststruct%pt_BC%south_t0 = neststruct%pt_BC%south_t1 + endif -#ifdef USE_COND - neststruct%q_con_BC%east_t0 = neststruct%q_con_BC%east_t1 - neststruct%q_con_BC%west_t0 = neststruct%q_con_BC%west_t1 - neststruct%q_con_BC%north_t0 = neststruct%q_con_BC%north_t1 - neststruct%q_con_BC%south_t0 = neststruct%q_con_BC%south_t1 -#ifdef MOIST_CAPPA - neststruct%cappa_BC%east_t0 = neststruct%cappa_BC%east_t1 - neststruct%cappa_BC%west_t0 = neststruct%cappa_BC%west_t1 - neststruct%cappa_BC%north_t0 = neststruct%cappa_BC%north_t1 - neststruct%cappa_BC%south_t0 = neststruct%cappa_BC%south_t1 -#endif -#endif + end if - if (.not. hydrostatic) then - call set_NH_BCs_t0(neststruct) - endif -#endif - neststruct%u_BC%east_t0 = neststruct%u_BC%east_t1 - neststruct%u_BC%west_t0 = neststruct%u_BC%west_t1 - neststruct%u_BC%north_t0 = neststruct%u_BC%north_t1 - neststruct%u_BC%south_t0 = neststruct%u_BC%south_t1 - neststruct%v_BC%east_t0 = neststruct%v_BC%east_t1 - neststruct%v_BC%west_t0 = neststruct%v_BC%west_t1 - neststruct%v_BC%north_t0 = neststruct%v_BC%north_t1 - neststruct%v_BC%south_t0 = neststruct%v_BC%south_t1 - neststruct%vc_BC%east_t0 = neststruct%vc_BC%east_t1 - neststruct%vc_BC%west_t0 = neststruct%vc_BC%west_t1 - neststruct%vc_BC%north_t0 = neststruct%vc_BC%north_t1 - neststruct%vc_BC%south_t0 = neststruct%vc_BC%south_t1 - neststruct%uc_BC%east_t0 = neststruct%uc_BC%east_t1 - neststruct%uc_BC%west_t0 = neststruct%uc_BC%west_t1 - neststruct%uc_BC%north_t0 = neststruct%uc_BC%north_t1 - neststruct%uc_BC%south_t0 = neststruct%uc_BC%south_t1 + do j=js-1-id,je+1+id + do i=is-1-id,ie+1+id + ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + enddo + enddo + +end subroutine d2a_setup - neststruct%divg_BC%east_t0 = neststruct%divg_BC%east_t1 - neststruct%divg_BC%west_t0 = neststruct%divg_BC%west_t1 - neststruct%divg_BC%north_t0 = neststruct%divg_BC%north_t1 - neststruct%divg_BC%south_t0 = neststruct%divg_BC%south_t1 - end subroutine set_BCs_t0 !! nestupdate types @@ -1037,49 +2305,61 @@ end subroutine set_BCs_t0 !! Note: "conserving updates" do not guarantee global conservation !! unless flux nested grid BCs are specified, or if a quantity is !! not updated at all. This ability has not been implemented. -! + !>@brief The subroutine'twoway_nesting' performs a two-way update !! of nested-grid data onto the parent grid. -subroutine twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir) +subroutine twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir, Time, this_grid) type(fv_atmos_type), intent(INOUT) :: Atm(ngrids) - integer, intent(IN) :: ngrids + integer, intent(IN) :: ngrids, this_grid logical, intent(IN) :: grids_on_this_pe(ngrids) real, intent(IN) :: zvir + type(time_type), intent(IN) :: Time integer :: n, p, sphum if (ngrids > 1) then +! Re-compute pressures on each grid + + call p_var(Atm(this_grid)%npz, Atm(this_grid)%bd%is, Atm(this_grid)%bd%ie, Atm(this_grid)%bd%js, Atm(this_grid)%bd%je, & + Atm(this_grid)%ptop, ptop_min, Atm(this_grid)%delp, Atm(this_grid)%delz, Atm(this_grid)%pt, & + Atm(this_grid)%ps, Atm(this_grid)%pe, Atm(this_grid)%peln, Atm(this_grid)%pk, Atm(this_grid)%pkz, kappa, & + Atm(this_grid)%q, Atm(this_grid)%ng, Atm(this_grid)%flagstruct%ncnst, Atm(this_grid)%gridstruct%area_64, 0., & + .false., .false., & + Atm(this_grid)%flagstruct%moist_phys, Atm(this_grid)%flagstruct%hydrostatic, & + Atm(this_grid)%flagstruct%nwat, Atm(this_grid)%domain, Atm(this_grid)%flagstruct%adiabatic, .false.) + do n=ngrids,2,-1 !loop backwards to allow information to propagate from finest to coarsest grids !two-way updating if (Atm(n)%neststruct%twowaynest ) then - if (grids_on_this_pe(n) .or. grids_on_this_pe(Atm(n)%parent_grid%grid_number)) then + !if (grids_on_this_pe(n) .or. grids_on_this_pe(Atm(n)%parent_grid%grid_number)) then + if (n==this_grid .or. Atm(n)%parent_grid%grid_number==this_grid) then sphum = get_tracer_index (MODEL_ATMOS, 'sphum') call twoway_nest_update(Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, zvir, & - Atm(n)%ncnst, sphum, Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%omga, & - Atm(n)%pt, Atm(n)%delp, Atm(n)%q, Atm(n)%uc, Atm(n)%vc, & - Atm(n)%pkz, Atm(n)%delz, Atm(n)%ps, Atm(n)%ptop, & - Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, Atm(n)%parent_grid, Atm(N)%bd, .false.) + Atm(n)%ncnst, sphum, Atm(n)%u, Atm(n)%v, Atm(n)%w, & + Atm(n)%pt, Atm(n)%delp, Atm(n)%q, & + Atm(n)%pe, Atm(n)%pkz, Atm(n)%delz, Atm(n)%ps, Atm(n)%ptop, Atm(n)%ak, Atm(n)%bk, & + Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, Atm(n)%domain, & + Atm(n)%parent_grid, Atm(N)%bd, n, .false.) endif endif end do !NOTE: these routines need to be used with any grid which has been updated to, not just the coarsest grid. - do n=1,ngrids - if (Atm(n)%neststruct%parent_of_twoway .and. grids_on_this_pe(n)) then - call after_twoway_nest_update( Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%ng, Atm(n)%ncnst, & - Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, & - Atm(n)%pt, Atm(n)%delp, Atm(n)%q, & - Atm(n)%ps, Atm(n)%pe, Atm(n)%pk, Atm(n)%peln, Atm(n)%pkz, & - Atm(n)%phis, Atm(n)%ua, Atm(n)%va, & - Atm(n)%ptop, Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%domain, Atm(n)%bd) - endif - enddo + if (Atm(this_grid)%neststruct%parent_of_twoway .and. grids_on_this_pe(n)) then + call after_twoway_nest_update( Atm(this_grid)%npx, Atm(this_grid)%npy, Atm(this_grid)%npz, & + Atm(this_grid)%ng, Atm(this_grid)%ncnst, & + Atm(this_grid)%u, Atm(this_grid)%v, Atm(this_grid)%w, Atm(this_grid)%delz, & + Atm(this_grid)%pt, Atm(this_grid)%delp, Atm(this_grid)%q, & + Atm(this_grid)%ps, Atm(this_grid)%pe, Atm(this_grid)%pk, Atm(this_grid)%peln, Atm(this_grid)%pkz, & + Atm(this_grid)%phis, Atm(this_grid)%ua, Atm(this_grid)%va, & + Atm(this_grid)%ptop, Atm(this_grid)%gridstruct, Atm(this_grid)%flagstruct, & + Atm(this_grid)%domain, Atm(this_grid)%bd, Time) + endif endif ! ngrids > 1 @@ -1087,29 +2367,32 @@ end subroutine twoway_nesting !!!CLEANUP: this routine assumes that the PARENT GRID has pt = (regular) temperature, !!!not potential temperature; which may cause problems when updating if this is not the case. + +!!! NOTE ALSO: parent_grid%flagstruct is NOT SET UP by default and may be missing much information +!!! Either make sure that parent_grid%flagstruct is filled in fv_control or that proper steps +!!! are taken to make sure null flags are not used subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & - u, v, w, omga, pt, delp, q, & - uc, vc, pkz, delz, ps, ptop, & + u, v, w, pt, delp, q, & + pe, pkz, delz, ps, ptop, ak, bk, & gridstruct, flagstruct, neststruct, & - parent_grid, bd, conv_theta_in) + domain, parent_grid, bd, grid_number, conv_theta_in) - real, intent(IN) :: zvir, ptop + real, intent(IN) :: zvir, ptop, ak(npz+1), bk(npz+1) integer, intent(IN) :: npx, npy, npz - integer, intent(IN) :: ncnst, sphum + integer, intent(IN) :: ncnst, sphum, grid_number logical, intent(IN), OPTIONAL :: conv_theta_in type(fv_grid_bounds_type), intent(IN) :: bd real, intent(inout), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) :: u !< D grid zonal wind (m/s) real, intent(inout), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) :: v !< D grid meridional wind (m/s) real, intent(inout) :: w( bd%isd: ,bd%jsd: ,1: ) !< W (m/s) - real, intent(inout) :: omga(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< Vertical pressure velocity (pa/s) + real, intent(inout) :: pt( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< temperature (K) real, intent(inout) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< pressure thickness (pascal) real, intent(inout) :: q( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) !< specific humidity and constituents - real, intent(inout) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) !< (uc,vc) C grid winds - real, intent(inout) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) - + + real, intent(inout) :: pe (bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1) !< finite-volume interface p ! NOTE TRANSPOSITION NEEDED real, intent(inout) :: pkz (bd%is:bd%ie,bd%js:bd%je,npz) !< finite-volume mean pk real, intent(inout) :: delz(bd%isd: ,bd%jsd: ,1: ) !< delta-height (m); non-hydrostatic only real, intent(inout) :: ps (bd%isd:bd%ied ,bd%jsd:bd%jed) !< Surface pressure (pascal) @@ -1117,8 +2400,9 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & type(fv_grid_type), intent(INOUT) :: gridstruct type(fv_flags_type), intent(INOUT) :: flagstruct type(fv_nest_type), intent(INOUT) :: neststruct + type(domain2d), intent(INOUT) :: domain - type(fv_atmos_type), intent(INOUT) :: parent_grid + type(fv_atmos_type), pointer, intent(IN) :: parent_grid real, allocatable :: t_nest(:,:,:), ps0(:,:) integer :: i,j,k,n @@ -1129,14 +2413,18 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & logical :: used, conv_theta=.true. real :: qdp( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) - real, allocatable :: qdp_coarse(:,:,:) + real, allocatable, dimension(:,:,:) :: qdp_coarse + real, allocatable, dimension(:,:,:) :: var_src + real, allocatable, dimension(:,:,:) :: pt_src, w_src, u_src, v_src real(kind=f_p), allocatable :: q_diff(:,:,:) - real :: L_sum_b(npz), L_sum_a(npz) + real :: L_sum_b(npz), L_sum_a(npz), blend_wt(parent_grid%npz) + real :: pfull, ph1, ph2, rfcut, sgcut integer :: upoff integer :: is, ie, js, je integer :: isd, ied, jsd, jed integer :: isu, ieu, jsu, jeu + logical, SAVE :: first_timestep = .true. is = bd%is ie = bd%ie @@ -1157,162 +2445,59 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & !If pt is actual temperature, set conv_theta to .false. if (present(conv_theta_in)) conv_theta = conv_theta_in - if ((.not. neststruct%parent_proc) .and. (.not. neststruct%child_proc)) return + if ((.not. parent_grid%neststruct%parent_proc) .and. (.not. neststruct%child_proc)) return call mpp_get_data_domain( parent_grid%domain, & isd_p, ied_p, jsd_p, jed_p ) call mpp_get_compute_domain( parent_grid%domain, & isc_p, iec_p, jsc_p, jec_p ) + ph2 = parent_grid%ak(1) + rfcut = max(flagstruct%rf_cutoff, parent_grid%flagstruct%rf_cutoff) + sgcut = ak(flagstruct%n_sponge+1) + bk(flagstruct%n_sponge+1)*flagstruct%p_ref + sgcut = max(sgcut, parent_grid%ak(parent_grid%flagstruct%n_sponge+1) + parent_grid%bk(parent_grid%flagstruct%n_sponge+1)*parent_grid%flagstruct%p_ref) + rfcut = max(rfcut, sgcut) + do k=1,parent_grid%npz + ph1 = ph2 + ph2 = parent_grid%ak(k+1) + parent_grid%bk(k+1)*parent_grid%flagstruct%p_ref + pfull = (ph2 - ph1) / log(ph2/ph1) + !if above nested-grid ptop or top two nested-grid levels do not remap + if ( pfull <= ak(3) .or. k <= 2 ) then + blend_wt(k) = 0. + !Partial blend of nested-grid's Rayleigh damping region + !ALSO do not blend n_sponge areas?? + elseif (pfull <= rfcut) then + blend_wt(k) = 0. + !blend_wt(k) = neststruct%update_blend*cos(0.5*pi*log(rfcut/pfull)/log(rfcut/ptop))**2 + else + blend_wt(k) = neststruct%update_blend + endif + enddo - !delp/ps - - if (neststruct%nestupdate < 3) then - - call update_coarse_grid(parent_grid%delp, delp, neststruct%nest_domain,& - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & - npx, npy, npz, 0, 0, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, & - neststruct%parent_proc, neststruct%child_proc, parent_grid) - - call mpp_sync!self - -#ifdef SW_DYNAMICS - if (neststruct%parent_proc) then - do j=jsd_p,jed_p - do i=isd_p,ied_p - - parent_grid%ps(i,j) = & - parent_grid%delp(i,j,1)/grav - - end do - end do - endif -#endif - - end if - - !if (neststruct%nestupdate /= 3 .and. neststruct%nestbctype /= 3) then - if (neststruct%nestupdate /= 3 .and. neststruct%nestupdate /= 7 .and. neststruct%nestupdate /= 8) then - - allocate(qdp_coarse(isd_p:ied_p,jsd_p:jed_p,npz)) - if (parent_grid%flagstruct%nwat > 0) then - allocate(q_diff(isd_p:ied_p,jsd_p:jed_p,npz)) - q_diff = 0. - endif - - do n=1,parent_grid%flagstruct%nwat - - qdp_coarse = 0. - if (neststruct%child_proc) then - do k=1,npz - do j=jsd,jed - do i=isd,ied - qdp(i,j,k) = q(i,j,k,n)*delp(i,j,k) - enddo - enddo - enddo - else - qdp = 0. - endif - - if (neststruct%parent_proc) then - !Add up ONLY region being replaced by nested grid - do k=1,npz - do j=jsu,jeu - do i=isu,ieu - qdp_coarse(i,j,k) = parent_grid%q(i,j,k,n)*parent_grid%delp(i,j,k) - enddo - enddo - enddo - call level_sum(qdp_coarse, parent_grid%gridstruct%area, parent_grid%domain, & - parent_grid%bd, npz, L_sum_b) - else - qdp_coarse = 0. - endif - if (neststruct%parent_proc) then - if (n <= parent_grid%flagstruct%nwat) then - do k=1,npz - do j=jsu,jeu - do i=isu,ieu - q_diff(i,j,k) = q_diff(i,j,k) - qdp_coarse(i,j,k) - enddo - enddo - enddo - endif - endif - - call update_coarse_grid(qdp_coarse, qdp, neststruct%nest_domain, & - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & - npx, npy, npz, 0, 0, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc, parent_grid) - - call mpp_sync!self - - if (neststruct%parent_proc) then - call level_sum(qdp_coarse, parent_grid%gridstruct%area, parent_grid%domain, & - parent_grid%bd, npz, L_sum_a) - do k=1,npz - if (L_sum_a(k) > 0.) then - fix = L_sum_b(k)/L_sum_a(k) - do j=jsu,jeu - do i=isu,ieu - !Normalization mass fixer - parent_grid%q(i,j,k,n) = qdp_coarse(i,j,k)*fix - enddo - enddo - endif - enddo - if (n == 1) sphum_ll_fix = 1. - fix - endif - if (neststruct%parent_proc) then - if (n <= parent_grid%flagstruct%nwat) then - do k=1,npz - do j=jsu,jeu - do i=isu,ieu - q_diff(i,j,k) = q_diff(i,j,k) + parent_grid%q(i,j,k,n) - enddo - enddo - enddo - endif - endif - - end do - - if (neststruct%parent_proc) then - if (parent_grid%flagstruct%nwat > 0) then - do k=1,npz - do j=jsu,jeu - do i=isu,ieu - parent_grid%delp(i,j,k) = parent_grid%delp(i,j,k) + q_diff(i,j,k) - enddo - enddo - enddo - endif - - do n=1,parent_grid%flagstruct%nwat - do k=1,npz - do j=jsu,jeu - do i=isu,ieu - parent_grid%q(i,j,k,n) = parent_grid%q(i,j,k,n)/parent_grid%delp(i,j,k) - enddo - enddo - enddo - enddo - endif - - deallocate(qdp_coarse) - if (allocated(q_diff)) deallocate(q_diff) - - endif + if (parent_grid%neststruct%parent_proc .and. is_master() .and. first_timestep) then + print*, ' TWO-WAY BLENDING WEIGHTS' + ph2 = parent_grid%ak(1) + do k=1,parent_grid%npz + ph1 = ph2 + ph2 = parent_grid%ak(k+1) + parent_grid%bk(k+1)*parent_grid%flagstruct%p_ref + pfull = (ph2 - ph1) / log(ph2/ph1) + print*, k, pfull, blend_wt(k) + enddo + first_timestep = .false. + endif #ifndef SW_DYNAMICS if (neststruct%nestupdate /= 3 .and. neststruct%nestupdate /= 8) then + if (neststruct%child_proc) then + call mpp_update_domains(ps, domain, complete=.true.) + if (.not. flagstruct%hydrostatic) call mpp_update_domains(w, domain) + ! if (neststruct%child_proc) call mpp_update_domains(delz, domain) + call mpp_update_domains(u, v, domain, gridtype=DGRID_NE) + endif + allocate(pt_src(isd_p:ied_p,jsd_p:jed_p,npz)) + pt_src = -999. + if (conv_theta) then if (neststruct%child_proc) then @@ -1328,69 +2513,78 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & enddo enddo enddo - deallocate(t_nest) + call mpp_update_domains(t_nest, domain, complete=.true.) endif - call update_coarse_grid(parent_grid%pt, & - t_nest, neststruct%nest_domain, & - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & - npx, npy, npz, 0, 0, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc, parent_grid) + call update_coarse_grid(pt_src, & + t_nest, global_nest_domain, & + gridstruct%dx, gridstruct%dy, gridstruct%area, & + bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & + neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & + npx, npy, npz, 0, 0, & + neststruct%refinement, neststruct%nestupdate, upoff, 0, & + parent_grid%neststruct%parent_proc, neststruct%child_proc, parent_grid, grid_number-1) + if (neststruct%child_proc) deallocate(t_nest) else + if (neststruct%child_proc) call mpp_update_domains(pt, domain, complete=.true.) - call update_coarse_grid(parent_grid%pt, & - pt, neststruct%nest_domain, & - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & + call update_coarse_grid(pt_src, & + pt, global_nest_domain, & + gridstruct%dx, gridstruct%dy, gridstruct%area, & + bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & npx, npy, npz, 0, 0, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc, parent_grid) + neststruct%refinement, neststruct%nestupdate, upoff, 0, & + parent_grid%neststruct%parent_proc, neststruct%child_proc, parent_grid, grid_number-1) endif !conv_theta call mpp_sync!self - if (.not. flagstruct%hydrostatic) then - - call update_coarse_grid(parent_grid%w, w, neststruct%nest_domain, & - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & - npx, npy, npz, 0, 0, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc, parent_grid) - !Updating for delz not yet implemented; may be problematic -!!$ call update_coarse_grid(parent_grid%delz, delz, neststruct%nest_domain, & -!!$ neststruct%ind_update_h, & -!!$ isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, npz, 0, 0, & -!!$ neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc) + !We don't currently have a good way to communicate all namelist items between + ! grids (since we cannot assume that we have internal namelists available), so + ! we get the clutzy structure here. + if ( (neststruct%child_proc .and. .not. flagstruct%hydrostatic) .or. & + (parent_grid%neststruct%parent_proc .and. .not. parent_grid%flagstruct%hydrostatic) ) then + allocate(w_src(isd_p:ied_p,jsd_p:jed_p,npz)) + w_src = -999. + call update_coarse_grid(w_src, w, global_nest_domain, & + gridstruct%dx, gridstruct%dy, gridstruct%area, & + bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & + neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & + npx, npy, npz, 0, 0, & + neststruct%refinement, neststruct%nestupdate, upoff, 0, & + parent_grid%neststruct%parent_proc, neststruct%child_proc, parent_grid, grid_number-1) call mpp_sync!self + !Updating for delz not yet implemented; + ! may need to think very carefully how one would do this!!! + ! consider updating specific volume instead? +!!$ call update_coarse_grid(parent_grid%delz, delz, global_nest_domain, & +!!$ bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, npz, 0, 0, & +!!$ neststruct%refinement, neststruct%nestupdate, upoff, 0, parent_grid%neststruct%parent_proc, neststruct%child_proc) + end if end if !Neststruct%nestupdate /= 3 #endif - call update_coarse_grid(parent_grid%u, u, neststruct%nest_domain, & - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & - npx, npy, npz, 0, 1, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc, parent_grid) - - call update_coarse_grid(parent_grid%v, v, neststruct%nest_domain, & - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & - npx, npy, npz, 1, 0, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc, parent_grid) - - call mpp_sync!self + allocate(u_src(isd_p:ied_p, jsd_p:jed_p+1,npz)) + allocate(v_src(isd_p:ied_p+1,jsd_p:jed_p,npz)) + u_src = -999. + v_src = -999. + call update_coarse_grid(u_src, v_src, u, v, global_nest_domain, & + gridstruct%dx, gridstruct%dy, gridstruct%area, & + bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & + neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & + npx, npy, npz, 0, 1, 1, 0, & + neststruct%refinement, neststruct%nestupdate, upoff, 0, & + parent_grid%neststruct%parent_proc, neststruct%child_proc, parent_grid, grid_number-1, gridtype=DGRID_NE) + call mpp_sync() #ifndef SW_DYNAMICS if (neststruct%nestupdate >= 5 .and. npz > 4) then @@ -1401,13 +2595,12 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & !Re-compute nested (AND COARSE) grid ps allocate(ps0(isd_p:ied_p,jsd_p:jed_p)) - if (neststruct%parent_proc) then + if (parent_grid%neststruct%parent_proc) then parent_grid%ps = parent_grid%ptop -!This loop appears to cause problems with OMP -!$OMP parallel do default(none) shared(npz,jsd_p,jed_p,isd_p,ied_p,parent_grid) +!$OMP parallel do default(none) shared(jsd_p,jed_p,isd_p,ied_p,parent_grid) do j=jsd_p,jed_p - do k=1,npz + do k=1,parent_grid%npz do i=isd_p,ied_p parent_grid%ps(i,j) = parent_grid%ps(i,j) + & parent_grid%delp(i,j,k) @@ -1431,36 +2624,35 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & end do endif - call update_coarse_grid(ps0, ps, neststruct%nest_domain, & - neststruct%ind_update_h, gridstruct%dx, gridstruct%dy, gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & + call update_coarse_grid(ps0, ps, global_nest_domain, & + gridstruct%dx, gridstruct%dy, gridstruct%area, & + bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & npx, npy, 0, 0, & - neststruct%refinement, neststruct%nestupdate, upoff, 0, neststruct%parent_proc, neststruct%child_proc, parent_grid) + neststruct%refinement, neststruct%nestupdate, upoff, 0, parent_grid%neststruct%parent_proc, neststruct%child_proc, parent_grid, grid_number-1) !!! The mpp version of update_coarse_grid does not return a consistent value of ps !!! across PEs, as it does not go into the haloes of a given coarse-grid PE. This !!! update_domains call takes care of the problem. - if (neststruct%parent_proc) then - call mpp_update_domains(parent_grid%ps, parent_grid%domain, complete=.false.) - call mpp_update_domains(ps0, parent_grid%domain, complete=.true.) - endif - + if (parent_grid%neststruct%parent_proc) then + call mpp_update_domains(parent_grid%ps, parent_grid%domain, complete=.false.) + call mpp_update_domains(ps0, parent_grid%domain, complete=.true.) + endif call mpp_sync!self - if (parent_grid%tile == neststruct%parent_tile) then + if (parent_grid%global_tile == neststruct%parent_tile) then - if (neststruct%parent_proc) then + if (parent_grid%neststruct%parent_proc) then !comment out if statement to always remap theta instead of t in the remap-update. !(In LtE typically we use remap_t = .true.: remapping t is better (except in !idealized simulations with a background uniform theta) since near the top !boundary theta is exponential, which is hard to accurately interpolate with a spline if (.not. parent_grid%flagstruct%remap_t) then -!$OMP parallel do default(none) shared(npz,jsc_p,jec_p,isc_p,iec_p,parent_grid,zvir,sphum) - do k=1,npz +!$OMP parallel do default(none) shared(jsc_p,jec_p,isc_p,iec_p,parent_grid,zvir,sphum) + do k=1,parent_grid%npz do j=jsc_p,jec_p do i=isc_p,iec_p parent_grid%pt(i,j,k) = & @@ -1470,17 +2662,29 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & end do end do end if - call update_remap_tqw(npz, parent_grid%ak, parent_grid%bk, & - parent_grid%ps, parent_grid%delp, & +!!$!!!! DEBUG CODE +!!$ do k=1,parent_grid%npz +!!$ write(mpp_pe()+3000,*) 'k = ', k, parent_grid%ak(k), parent_grid%bk(k) +!!$ enddo +!!$ write(mpp_pe()+3000,*) +!!$ do k=1,npz +!!$ write(mpp_pe()+3000,*) 'k = ', k, ak(k), bk(k) +!!$ enddo +!!$!!!! END DEBUG CODE + + call update_remap_tqw(parent_grid%npz, parent_grid%ak, parent_grid%bk, & + parent_grid%ps, & parent_grid%pt, parent_grid%q, parent_grid%w, & parent_grid%flagstruct%hydrostatic, & - npz, ps0, zvir, parent_grid%ptop, ncnst, & + npz, ps0, ak, bk, pt_src, w_src, & + zvir, parent_grid%ptop, ncnst, & parent_grid%flagstruct%kord_tm, parent_grid%flagstruct%kord_tr, & parent_grid%flagstruct%kord_wz, & - isc_p, iec_p, jsc_p, jec_p, isd_p, ied_p, jsd_p, jed_p, .false. ) !neststruct%nestupdate < 7) + isc_p, iec_p, jsc_p, jec_p, isd_p, ied_p, jsd_p, jed_p, .false., & + neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, blend_wt) !neststruct%nestupdate < 7) if (.not. parent_grid%flagstruct%remap_t) then -!$OMP parallel do default(none) shared(npz,jsc_p,jec_p,isc_p,iec_p,parent_grid,zvir,sphum) - do k=1,npz +!$OMP parallel do default(none) shared(jsc_p,jec_p,isc_p,iec_p,parent_grid,zvir,sphum) + do k=1,parent_grid%npz do j=jsc_p,jec_p do i=isc_p,iec_p parent_grid%pt(i,j,k) = & @@ -1491,13 +2695,14 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & end do end if - call update_remap_uv(npz, parent_grid%ak, parent_grid%bk, & - parent_grid%ps, & - parent_grid%u, & - parent_grid%v, npz, ps0, parent_grid%flagstruct%kord_mt, & - isc_p, iec_p, jsc_p, jec_p, isd_p, ied_p, jsd_p, jed_p, parent_grid%ptop) + call update_remap_uv(parent_grid%npz, parent_grid%ak, parent_grid%bk, & + parent_grid%ps, parent_grid%u, parent_grid%v, & + npz, ak, bk, ps0, u_src, v_src, & + parent_grid%flagstruct%kord_mt, & + isc_p, iec_p, jsc_p, jec_p, isd_p, ied_p, jsd_p, jed_p, parent_grid%ptop, & + neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, blend_wt) - endif !neststruct%parent_proc + endif !parent_grid%neststruct%parent_proc end if @@ -1507,6 +2712,14 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & #endif + + + deallocate(pt_src) + deallocate(w_src) + deallocate(u_src) + deallocate(v_src) + + end subroutine twoway_nest_update subroutine level_sum(q, area, domain, bd, npz, L_sum) @@ -1537,12 +2750,145 @@ subroutine level_sum(q, area, domain, bd, npz, L_sum) end subroutine level_sum +![ij]start and [ij]end should already take staggering into account +!!! CHECK ARRAY BOUNDS!! +!! Make sure data is in the correct place. + subroutine remap_up_k(ps_src, ps_dst, ak_src, bk_src, ak_dst, bk_dst, var_src, var_dst, & + bd, istart, iend, jstart, jend, istag, jstag, npz_src, npz_dst, iv, kord, blend_wt, log_pe) + + !Note here that pe is TRANSPOSED to make loops faster + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: istart, iend, jstart, jend, npz_dst, npz_src, iv, kord, istag, jstag + logical, intent(IN) :: log_pe + real, intent(INOUT) :: ps_src(bd%isd:bd%ied,bd%jsd:bd%jed), var_src(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,npz_src) + real, intent(INOUT) :: ps_dst(bd%isd:bd%ied,bd%jsd:bd%jed), var_dst(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,npz_dst) + real, intent(IN) :: blend_wt(npz_dst), ak_src(npz_src+1), bk_src(npz_src+1), ak_dst(npz_dst+1), bk_dst(npz_dst+1) + + integer :: i, j, k + real pe_src(istart:iend,npz_src+1) + real pe_dst(istart:iend,npz_dst+1) + real peln_src(istart:iend,npz_src+1) + real peln_dst(istart:iend,npz_dst+1) + character(120) :: errstring + real var_dst_unblend(istart:iend,npz_dst) + real bw1, bw2 + + if (iend < istart) return + if (jend < jstart) return + +!!$!!!! DEBUG CODE +!!$ write(debug_unit,*) bd%isd,bd%ied,bd%jsd,bd%jed +!!$ write(debug_unit,*) istart,iend,jstart,jend,istag,jstag +!!$ write(debug_unit,*) +!!$!!! END DEBUG CODE + + + !Compute Eulerian pressures + !NOTE: assumes that istag + jstag <= 1 + if (istag > 0) then +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz_src,npz_dst,pe_src,ak_src,ps_src,bk_src,pe_dst,ak_dst,ps_dst,bk_dst) + do j=jstart,jend + do k=1,npz_src+1 + do i=istart,iend + pe_src(i,k) = ak_src(k) + 0.5*(ps_src(i,j)+ps_src(i-1,j))*bk_src(k) + enddo + enddo + do k=1,npz_dst+1 + do i=istart,iend + pe_dst(i,k) = ak_dst(k) + 0.5*(ps_dst(i,j)+ps_dst(i-1,j))*bk_dst(k) + enddo + enddo + enddo + elseif (jstag > 0) then +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz_src,npz_dst,pe_src,ak_src,ps_src,bk_src,pe_dst,ak_dst,ps_dst,bk_dst) + do j=jstart,jend + do k=1,npz_src+1 + do i=istart,iend + pe_src(i,k) = ak_src(k) + 0.5*(ps_src(i,j)+ps_src(i,j-1))*bk_src(k) + enddo + enddo + do k=1,npz_dst+1 + do i=istart,iend + pe_dst(i,k) = ak_dst(k) + 0.5*(ps_dst(i,j)+ps_dst(i,j-1))*bk_dst(k) + enddo + enddo + enddo + else +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz_src,npz_dst,pe_src,ak_src,ps_src,bk_src,pe_dst,ak_dst,ps_dst,bk_dst) + do j=jstart,jend + do k=1,npz_src+1 + do i=istart,iend + pe_src(i,k) = ak_src(k) + ps_src(i,j)*bk_src(k) + enddo + enddo + do k=1,npz_dst+1 + do i=istart,iend + pe_dst(i,k) = ak_dst(k) + ps_dst(i,j)*bk_dst(k) + enddo + enddo + enddo + endif + + if (log_pe) then + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz_src,npz_dst,pe_src,pe_dst,var_src,var_dst,iv,kord,blend_wt) & +!$OMP private(peln_src,peln_dst,bw1,bw2,var_dst_unblend) + do j=jstart,jend + + do k=1,npz_src+1 + do i=istart,iend + peln_src(i,k) = log(pe_src(i,k)) + enddo + enddo + + do k=1,npz_dst+1 + do i=istart,iend + peln_dst(i,k) = log(pe_dst(i,k)) + enddo + enddo + + !remap_2d seems to have some bugs when doing logp remapping + call mappm(npz_src, peln_src, var_src(istart:iend,j:j,:), & + npz_dst, peln_dst, var_dst_unblend, & + istart, iend, iv, kord, peln_dst(istart,1)) + + do k=1,npz_dst + bw1 = blend_wt(k) + bw2 = 1. - bw1 + do i=istart,iend + var_dst(i,j,k) = var_dst(i,j,k)*bw2 + var_dst_unblend(i,k)*bw1 + enddo + enddo + enddo + + else + +!$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz_src,npz_dst,pe_src,pe_dst,var_src,var_dst,iv,kord,blend_wt) & +!$OMP private(bw1,bw2,var_dst_unblend) + do j=jstart,jend + + call mappm(npz_src, pe_src, var_src(istart:iend,j:j,:), & + npz_dst, pe_dst, var_dst_unblend, & + istart, iend, iv, kord, pe_dst(istart,1)) + + do k=1,npz_dst + bw1 = blend_wt(k) + bw2 = 1. - bw1 + do i=istart,iend + var_dst(i,j,k) = var_dst(i,j,k)*bw2 + var_dst_unblend(i,k)*bw1 + enddo + enddo + enddo + + endif + + end subroutine remap_up_k subroutine after_twoway_nest_update(npx, npy, npz, ng, ncnst, & u, v, w, delz, pt, delp, q, & ps, pe, pk, peln, pkz, phis, ua, va, & ptop, gridstruct, flagstruct, & - domain, bd) + domain, bd, Time) type(fv_grid_bounds_type), intent(IN) :: bd real, intent(IN) :: ptop @@ -1556,7 +2902,7 @@ subroutine after_twoway_nest_update(npx, npy, npz, ng, ncnst, & real, intent(inout) :: pt( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< temperature (K) real, intent(inout) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) !< pressure thickness (pascal) real, intent(inout) :: q( bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) !< specific humidity and constituents - real, intent(inout) :: delz(bd%isd: ,bd%jsd: ,1: ) !< delta-height (m); non-hydrostatic only + real, intent(inout) :: delz(bd%is: ,bd%js: ,1: ) !< delta-height (m); non-hydrostatic only !----------------------------------------------------------------------- ! Auxilliary pressure arrays: @@ -1578,6 +2924,7 @@ subroutine after_twoway_nest_update(npx, npy, npz, ng, ncnst, & type(fv_grid_type), intent(IN) :: gridstruct type(fv_flags_type), intent(IN) :: flagstruct type(domain2d), intent(INOUT) :: domain + type(time_type), intent(IN) :: Time logical :: bad_range @@ -1596,7 +2943,7 @@ subroutine after_twoway_nest_update(npx, npy, npz, ng, ncnst, & call cubed_to_latlon(u, v, ua, va, & gridstruct, npx, npy, npz, & 1, gridstruct%grid_type, domain, & - gridstruct%nested, flagstruct%c2l_ord, bd) + gridstruct%bounded_domain, flagstruct%c2l_ord, bd) #ifndef SW_DYNAMICS @@ -1613,16 +2960,16 @@ subroutine after_twoway_nest_update(npx, npy, npz, ng, ncnst, & q, ng, flagstruct%ncnst, gridstruct%area_64, 0., & .false., .false., & !mountain argument not used flagstruct%moist_phys, flagstruct%hydrostatic, & - flagstruct%nwat, domain, .false.) + flagstruct%nwat, domain, flagstruct%adiabatic, .false.) #endif if (flagstruct%range_warn) then - call range_check('TA update', pt, is, ie, js, je, ng, npz, gridstruct%agrid, 130., 350., bad_range) - call range_check('UA update', ua, is, ie, js, je, ng, npz, gridstruct%agrid, -220., 250., bad_range) - call range_check('VA update', va, is, ie, js, je, ng, npz, gridstruct%agrid, -220., 220., bad_range) + call range_check('TA update', pt, is, ie, js, je, ng, npz, gridstruct%agrid, 130., 350., bad_range, Time) + call range_check('UA update', ua, is, ie, js, je, ng, npz, gridstruct%agrid, -220., 250., bad_range, Time) + call range_check('VA update', va, is, ie, js, je, ng, npz, gridstruct%agrid, -220., 220., bad_range, Time) if (.not. flagstruct%hydrostatic) then - call range_check('W update', w, is, ie, js, je, ng, npz, gridstruct%agrid, -50., 100., bad_range) + call range_check('W update', w, is, ie, js, je, ng, npz, gridstruct%agrid, -50., 100., bad_range, Time) endif endif @@ -1633,18 +2980,23 @@ end subroutine after_twoway_nest_update !>@brief The subroutine 'update_remap_tqw' remaps (interpolated) nested-grid data !! to the coarse-grid's vertical coordinate. !This does not yet do anything for the tracers - subroutine update_remap_tqw( npz, ak, bk, ps, delp, t, q, w, hydrostatic, & - kmd, ps0, zvir, ptop, nq, kord_tm, kord_tr, kord_wz, & - is, ie, js, je, isd, ied, jsd, jed, do_q) + + subroutine update_remap_tqw( npz, ak_dst, bk_dst, ps_dst, t_dst, q_dst, w_dst, & + hydrostatic, & + kmd, ps_src, ak_src, bk_src, t_src, w_src, & + zvir, ptop, nq, kord_tm, kord_tr, kord_wz, & + is, ie, js, je, isd, ied, jsd, jed, do_q, & + istart, iend, jstart, jend, blend_wt) integer, intent(in):: npz, kmd, nq, kord_tm, kord_tr, kord_wz real, intent(in):: zvir, ptop - real, intent(in):: ak(npz+1), bk(npz+1) - real, intent(in), dimension(isd:ied,jsd:jed):: ps0 - real, intent(in), dimension(isd:ied,jsd:jed):: ps - real, intent(in), dimension(isd:ied,jsd:jed,npz):: delp - real, intent(inout), dimension(isd:ied,jsd:jed,npz):: t, w - real, intent(inout), dimension(isd:ied,jsd:jed,npz,nq):: q - integer, intent(in) :: is, ie, js, je, isd, ied, jsd, jed + real, intent(in):: ak_src(kmd+1), bk_src(kmd+1) + real, intent(in):: ak_dst(npz+1), bk_dst(npz+1), blend_wt(npz) + real, intent(in), dimension(isd:ied,jsd:jed):: ps_src + real, intent(in), dimension(isd:ied,jsd:jed):: ps_dst + real, intent(inout), dimension(isd:ied,jsd:jed,npz):: t_dst, w_dst + real, intent(inout), dimension(isd:ied,jsd:jed,npz,nq):: q_dst + real, intent(in), dimension(isd:ied,jsd:jed,kmd):: t_src, w_src + integer, intent(in) :: is, ie, js, je, isd, ied, jsd, jed, istart, iend, jstart, jend logical, intent(in) :: hydrostatic, do_q ! local: real, dimension(is:ie,kmd):: tp, qp @@ -1652,67 +3004,80 @@ subroutine update_remap_tqw( npz, ak, bk, ps, delp, t, q, w, hydrostatic, & real, dimension(is:ie,npz):: qn1 real, dimension(is:ie,npz+1):: pe1, pn1 integer i,j,k,iq + real :: wt1, wt2 + + if (do_q) call mpp_error(FATAL, ' update_remap_tqw: q remapping not yet supported') -!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak,bk,ps0,q,npz,ptop,do_q,& -!$OMP t,w,ps,nq,hydrostatic,kord_tm,kord_tr,kord_wz) & -!$OMP private(pe0,pn0,pe1,pn1,qp,tp,qn1) - do 5000 j=js,je + !This line to check if the update region is correctly defined or not is + ! IMPORTANT. Sometimes one or the other pair of limits will give a + ! non-empty loop, even though no data was transferred! This is why + ! I was having so much trouble getting the remap-update to work --- lmh 11jul17 + if (istart > iend .or. jstart > jend) return + +!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,q_dst,npz,ptop,do_q,& +!$OMP t_dst,w_dst,t_src,w_src,ak_src,bk_src,ps_src,nq,hydrostatic,kord_tm,kord_tr,kord_wz,istart,iend,jstart,jend,blend_wt) & +!$OMP private(pe0,pn0,pe1,pn1,qp,tp,qn1,wt1,wt2) + do 5000 j=jstart,jend do k=1,kmd+1 - do i=is,ie - pe0(i,k) = ak(k) + bk(k)*ps0(i,j) + do i=istart,iend + pe0(i,k) = ak_src(k) + bk_src(k)*ps_src(i,j) pn0(i,k) = log(pe0(i,k)) enddo enddo - do k=1,kmd+1 - do i=is,ie - pe1(i,k) = ak(k) + bk(k)*ps(i,j) + do k=1,npz+1 + do i=istart,iend + pe1(i,k) = ak_dst(k) + bk_dst(k)*ps_dst(i,j) pn1(i,k) = log(pe1(i,k)) enddo enddo if (do_q) then do iq=1,nq do k=1,kmd - do i=is,ie - qp(i,k) = q(i,j,k,iq) + do i=istart,iend + qp(i,k) = q_dst(i,j,k,iq) enddo enddo - call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_tr, ptop) + call mappm(kmd, pe0, qp, npz, pe1, qn1, is,ie, 0, kord_tr, ptop) !not sure about indices do k=1,npz - do i=is,ie - q(i,j,k,iq) = qn1(i,k) + do i=istart,iend + q_dst(i,j,k,iq) = qn1(i,k) enddo enddo enddo endif do k=1,kmd - do i=is,ie - tp(i,k) = t(i,j,k) + do i=istart,iend + tp(i,k) = t_src(i,j,k) enddo enddo !Remap T using logp - call mappm(kmd, pn0, tp, npz, pn1, qn1, is,ie, 1, abs(kord_tm), ptop) + call mappm(kmd, pn0(istart:iend,:), tp(istart:iend,:), npz, pn1(istart:iend,:), qn1(istart:iend,:), istart,iend, 1, abs(kord_tm), ptop) do k=1,npz - do i=is,ie - t(i,j,k) = qn1(i,k) + wt1 = blend_wt(k) + wt2 = 1. - wt1 + do i=istart,iend + t_dst(i,j,k) = qn1(i,k)*wt1 + t_dst(i,j,k)*wt2 enddo enddo if (.not. hydrostatic) then do k=1,kmd - do i=is,ie - tp(i,k) = w(i,j,k) + do i=istart,iend + tp(i,k) = w_src(i,j,k) enddo enddo !Remap w using p !Using iv == -1 instead of -2 - call mappm(kmd, pe0, tp, npz, pe1, qn1, is,ie, -1, kord_wz, ptop) + call mappm(kmd, pe0(istart:iend,:), tp(istart:iend,:), npz, pe1(istart:iend,:), qn1(istart:iend,:), istart,iend, -1, kord_wz, ptop) do k=1,npz - do i=is,ie - w(i,j,k) = qn1(i,k) + wt1 = blend_wt(k) + wt2 = 1. - wt1 + do i=istart,iend + w_dst(i,j,k) = qn1(i,k)*wt1 + w_dst(i,j,k)*wt2 enddo enddo endif @@ -1722,18 +3087,26 @@ subroutine update_remap_tqw( npz, ak, bk, ps, delp, t, q, w, hydrostatic, & end subroutine update_remap_tqw !remap_uv as-is remaps only a-grid velocities. A new routine has been written to handle staggered grids. - subroutine update_remap_uv(npz, ak, bk, ps, u, v, kmd, ps0, kord_mt, & - is, ie, js, je, isd, ied, jsd, jed, ptop) + subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, & + kmd, ak_src, bk_src, ps_src, u_src, v_src, & + kord_mt, & + is, ie, js, je, isd, ied, jsd, jed, ptop, & + istart, iend, jstart, jend, blend_wt) integer, intent(in):: npz - real, intent(in):: ak(npz+1), bk(npz+1) - real, intent(in):: ps(isd:ied,jsd:jed) - real, intent(inout), dimension(isd:ied,jsd:jed+1,npz):: u - real, intent(inout), dimension(isd:ied+1,jsd:jed,npz):: v + real, intent(in):: ak_dst(npz+1), bk_dst(npz+1), blend_wt(npz) + real, intent(in):: ps_dst(isd:ied,jsd:jed) + real, intent(inout), dimension(isd:ied,jsd:jed+1,npz):: u_dst + real, intent(inout), dimension(isd:ied+1,jsd:jed,npz):: v_dst + integer, intent(in):: kmd + real, intent(in):: ak_src(kmd+1), bk_src(kmd+1) + real, intent(in):: ps_src(isd:ied,jsd:jed) + real, intent(inout), dimension(isd:ied,jsd:jed+1,kmd):: u_src + real, intent(inout), dimension(isd:ied+1,jsd:jed,kmd):: v_src ! - integer, intent(in):: kmd, kord_mt + integer, intent(in):: kord_mt real, intent(IN) :: ptop - real, intent(in):: ps0(isd:ied,jsd:jed) integer, intent(in) :: is, ie, js, je, isd, ied, jsd, jed + integer, intent(IN) :: istart, iend, jstart, jend ! ! local: real, dimension(is:ie+1,kmd+1):: pe0 @@ -1741,27 +3114,33 @@ subroutine update_remap_uv(npz, ak, bk, ps, u, v, kmd, ps0, kord_mt, & real, dimension(is:ie+1,kmd):: qt real, dimension(is:ie+1,npz):: qn1 integer i,j,k + real :: wt1, wt2 + + !This line to check if the update region is correctly defined or not is + ! IMPORTANT. Sometimes one or the other pair of limits will give a + ! non-empty loop, even though no data was transferred! + if (istart > iend .or. jstart > jend) return !------ ! map u !------ -!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak,bk,ps,ps0,npz,u,ptop,kord_mt) & -!$OMP private(pe0,pe1,qt,qn1) - do j=js,je+1 +!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,npz,ak_src,bk_src,ps_src,u_src,v_src,ptop,kord_mt,istart,iend,jstart,jend,blend_wt) & +!$OMP private(pe0,pe1,qt,qn1,wt1,wt2) + do j=jstart,jend+1 !------ ! Data !------ do k=1,kmd+1 - do i=is,ie - pe0(i,k) = ak(k) + bk(k)*0.5*(ps0(i,j)+ps0(i,j-1)) + do i=istart,iend + pe0(i,k) = ak_src(k) + bk_src(k)*0.5*(ps_src(i,j)+ps_src(i,j-1)) enddo enddo !------ ! Model !------ - do k=1,kmd+1 - do i=is,ie - pe1(i,k) = ak(k) + bk(k)*0.5*(ps(i,j)+ps(i,j-1)) + do k=1,npz+1 + do i=istart,iend + pe1(i,k) = ak_dst(k) + bk_dst(k)*0.5*(ps_dst(i,j)+ps_dst(i,j-1)) enddo enddo !------ @@ -1769,15 +3148,17 @@ subroutine update_remap_uv(npz, ak, bk, ps, u, v, kmd, ps0, kord_mt, & !------ qt = 0. do k=1,kmd - do i=is,ie - qt(i,k) = u(i,j,k) + do i=istart,iend + qt(i,k) = u_src(i,j,k) enddo enddo - qn1 = 0. - call mappm(kmd, pe0(is:ie,:), qt(is:ie,:), npz, pe1(is:ie,:), qn1(is:ie,:), is,ie, -1, kord_mt, ptop) + qn1 = 0. + call mappm(kmd, pe0(istart:iend,:), qt(istart:iend,:), npz, pe1(istart:iend,:), qn1(istart:iend,:), istart,iend, -1, kord_mt, ptop) do k=1,npz - do i=is,ie - u(i,j,k) = qn1(i,k) + wt1 = blend_wt(k) + wt2 = 1. - wt1 + do i=istart,iend + u_dst(i,j,k) = qn1(i,k)*wt1 + u_dst(i,j,k)*wt2 enddo enddo @@ -1786,23 +3167,23 @@ subroutine update_remap_uv(npz, ak, bk, ps, u, v, kmd, ps0, kord_mt, & !------ ! map v !------ -!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak,bk,ps,ps0,npz,v,ptop) & -!$OMP private(pe0,pe1,qt,qn1) - do j=js,je +!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,ak_src,bk_src,ps_src,npz,u_src,v_src,ptop,istart,iend,jstart,jend,blend_wt) & +!$OMP private(pe0,pe1,qt,qn1,wt1,wt2) + do j=jstart,jend !------ ! Data !------ do k=1,kmd+1 - do i=is,ie+1 - pe0(i,k) = ak(k) + bk(k)*0.5*(ps0(i,j)+ps0(i-1,j)) + do i=istart,iend+1 + pe0(i,k) = ak_src(k) + bk_src(k)*0.5*(ps_src(i,j)+ps_src(i-1,j)) enddo enddo !------ ! Model !------ - do k=1,kmd+1 - do i=is,ie+1 - pe1(i,k) = ak(k) + bk(k)*0.5*(ps(i,j)+ps(i-1,j)) + do k=1,npz+1 + do i=istart,iend+1 + pe1(i,k) = ak_dst(k) + bk_dst(k)*0.5*(ps_dst(i,j)+ps_dst(i-1,j)) enddo enddo !------ @@ -1810,15 +3191,17 @@ subroutine update_remap_uv(npz, ak, bk, ps, u, v, kmd, ps0, kord_mt, & !------ qt = 0. do k=1,kmd - do i=is,ie+1 - qt(i,k) = v(i,j,k) + do i=istart,iend+1 + qt(i,k) = v_src(i,j,k) enddo enddo qn1 = 0. - call mappm(kmd, pe0(is:ie+1,:), qt(is:ie+1,:), npz, pe1(is:ie+1,:), qn1(is:ie+1,:), is,ie+1, -1, 8, ptop) + call mappm(kmd, pe0(istart:iend+1,:), qt(istart:iend+1,:), npz, pe1(istart:iend+1,:), qn1(istart:iend+1,:), istart,iend+1, -1, 8, ptop) do k=1,npz - do i=is,ie+1 - v(i,j,k) = qn1(i,k) + wt1 = blend_wt(k) + wt2 = 1. - wt1 + do i=istart,iend+1 + v_dst(i,j,k) = qn1(i,k)*wt1 + v_dst(i,j,k)*wt2 !Does this kill OMP??? enddo enddo end do diff --git a/model/fv_regional_bc.F90 b/model/fv_regional_bc.F90 index 8b6d11db8..98285b7a3 100644 --- a/model/fv_regional_bc.F90 +++ b/model/fv_regional_bc.F90 @@ -34,7 +34,7 @@ module fv_regional_mod use mpp_mod, only: FATAL, input_nml_file, & mpp_error ,mpp_pe, mpp_sync, & mpp_npes, mpp_root_pe, mpp_gather, & - mpp_get_current_pelist, NULL_PE + mpp_get_current_pelist, NOTE, NULL_PE use mpp_io_mod use tracer_manager_mod,only: get_tracer_index,get_tracer_names use field_manager_mod, only: MODEL_ATMOS @@ -46,7 +46,10 @@ module fv_regional_mod use fv_arrays_mod, only: fv_atmos_type & ,fv_grid_bounds_type & ,fv_regional_bc_bounds_type & - ,R_GRID + ,R_GRID & + ,fv_nest_BC_type_3D & + ,allocate_fv_nest_BC_type + use fv_diagnostics_mod,only: prt_gb_nh_sh, prt_height use fv_grid_utils_mod, only: g_sum,mid_pt_sphere,get_unit_vect2 & ,get_latlon_vector,inner_prod & @@ -57,6 +60,7 @@ module fv_regional_mod use fv_eta_mod, only: get_eta_level use fms_mod, only: check_nml_error,file_exist use fms_io_mod, only: read_data,get_global_att_value + use boundary_mod, only: fv_nest_BC_type_3D implicit none @@ -64,6 +68,7 @@ module fv_regional_mod public ak_in, bk_in & ,bc_hour & + ,bc_time_interval & ,BC_t0,BC_t1 & ,begin_regional_restart,exch_uv & ,ntimesteps_per_bc_update & @@ -72,22 +77,24 @@ module fv_regional_mod ,regional_bc_t1_to_t0 & ,regional_boundary_update & ,next_time_to_read_bcs & - ,set_regional_BCs & + ,set_regional_BCs & ,setup_regional_BC & ,start_regional_cold_start & ,start_regional_restart & ,dump_field & ,current_time_in_seconds & - ,a_step, p_step, k_step, n_step, get_data_source - - integer,parameter :: nhalo_data =4 & + ,a_step, p_step, k_step, n_step, get_data_source & + ,write_full_fields + integer,parameter :: bc_time_interval=3 & + ,nhalo_data =4 & ,nhalo_model=3 - +! integer, public, parameter :: H_STAGGER = 1 integer, public, parameter :: U_STAGGER = 2 integer, public, parameter :: V_STAGGER = 3 - real, parameter :: stretch_factor = 1.50 + !These parameters are ONLY used for the dump_field debugging routines + real, parameter :: stretch_factor = 1.5 real, parameter :: target_lon = -97.5 real, parameter :: target_lat = 35.5 integer, parameter :: parent_tile = 6 @@ -105,11 +112,41 @@ module fv_regional_mod ! integer, parameter :: iend_nest = 1346 ! integer, parameter :: jend_nest = 1290 + integer,parameter :: nvars_core=7 & !<-- # of prognostic variables in core restart file + ,ndims_core=6 & !<-- # of core restart dimensions + ,ndims_tracers=4 !<-- # of tracer restart dimensions +! + real,parameter :: blend_exp1=0.5,blend_exp2=10. !<-- Define the exponential dropoff of weights + ! for prescribed external values in the + ! blending rows inside the domain boundary. real :: current_time_in_seconds - integer,save :: ncid,next_time_to_read_bcs,npz,ntracers - integer,save :: liq_water_index,sphum_index !<-- Locations of tracer vbls in the tracers array +! + integer,save :: isd_mod,ied_mod,jsd_mod,jed_mod +! + integer,save :: ncid,next_time_to_read_bcs,nfields_tracers & + ,npz,ntracers +! + integer,save :: k_split,n_split +! integer,save :: bc_hour, ntimesteps_per_bc_update - +! + integer,save :: cld_amt_index & !<-- + ,graupel_index & ! + ,ice_water_index & ! Locations of + ,liq_water_index & ! tracer vbls + ,o3mr_index & ! in the tracers + ,rain_water_index & ! array. + ,snow_water_index & ! + ,sphum_index !<-- +! + integer,save :: lbnd_x_tracers,lbnd_y_tracers & !<-- Local lower bounds of x,y for tracer arrays + ,ubnd_x_tracers,ubnd_y_tracers !<-- Local upper bounds of x,y for tracer arrays +! + integer,save :: nrows_blend !<-- # of blending rows in the BC data files. +! + real,save :: dt_atmos & !<-- The physics (large) timestep (sec) + ,dyn_timestep !<-- The dynamics timestep (sec) +! real(kind=R_GRID),dimension(:,:,:),allocatable :: agrid_reg & !<-- Lon/lat of cell centers ,grid_reg !<-- Lon/lat of cell corners @@ -120,6 +157,13 @@ module fv_regional_mod logical,save :: north_bc,south_bc,east_bc,west_bc & ,begin_regional_restart=.true. + logical,dimension(:),allocatable,save :: blend_this_tracer + + character(len=50) :: filename_core='INPUT/fv_core.res.temp.nc' + character(len=50) :: filename_core_new='RESTART/fv_core.res.tile1_new.nc' + character(len=50) :: filename_tracers='INPUT/fv_tracer.res.temp.nc' + character(len=50) :: filename_tracers_new='RESTART/fv_tracer.res.tile1_new.nc' + type fv_regional_BC_variables real,dimension(:,:,:),allocatable :: delp_BC, divgd_BC, u_BC, v_BC, uc_BC, vc_BC real,dimension(:,:,:,:),allocatable :: q_BC @@ -138,6 +182,20 @@ module fv_regional_mod type(fv_regional_BC_variables) :: north, south, east, west end type fv_domain_sides + type single_vbl3D_sides + real,dimension(:,:,:),pointer :: north, south, east, west + end type single_vbl3D_sides + + type vars_2d + real,dimension(:,:),pointer :: ptr + character(len=10) :: name + end type vars_2d + + type vars_3d + real,dimension(:,:,:),pointer :: ptr + character(len=10) :: name + end type vars_3d + type(fv_domain_sides),target,save :: BC_t0, BC_t1 !<-- Boundary values for all BC variables at successive times from the regional BC file type(fv_regional_BC_variables),pointer,save :: bc_north_t0 & @@ -153,6 +211,14 @@ module fv_regional_mod type(fv_regional_bc_bounds_type),pointer,save :: regional_bounds + type(vars_3d),dimension(:),allocatable :: fields_core & + ,fields_tracers + type(fv_nest_BC_type_3D), public :: delz_regBC ! lmh + + type(single_vbl3D_sides) :: delz_auxiliary !<-- Boundary delz that follows integration through forecast time. + + integer :: ns = 0 ! lmh + real,parameter :: tice=273.16 & ,t_i0=15. real, parameter :: c_liq = 4185.5 ! gfdl: heat capacity of liquid at 15 deg c @@ -178,7 +244,7 @@ module fv_regional_mod module procedure dump_field_2d end interface dump_field - integer,save :: bc_update_interval + integer,save :: bc_update_interval, nrows_blend_user integer :: a_step, p_step, k_step, n_step ! @@ -187,7 +253,7 @@ module fv_regional_mod !----------------------------------------------------------------------- ! - subroutine setup_regional_BC(Atm & + subroutine setup_regional_BC(Atm, dt_atmos & ,isd,ied,jsd,jed & ,npx,npy ) ! @@ -204,6 +270,8 @@ subroutine setup_regional_BC(Atm & !--------------------- ! integer,intent(in) :: isd,ied,jsd,jed,npx,npy +! + real,intent(in) :: dt_atmos !<-- The large (physics) timestep (sec) ! type(fv_atmos_type),target,intent(inout) :: Atm !<-- Atm object for the current domain ! @@ -211,9 +279,15 @@ subroutine setup_regional_BC(Atm & !*** Local variables !-------------------- ! - integer :: i,i_start,i_end,j,j_start,j_end,klev_out + integer :: dimid,i,i_start,i_end,j,j_start,j_end,klev_out & + ,nrows_bc_data,nrows_blend_in_data,sec ! real :: ps1 +! + character(len=2) :: char2_1,char2_2 + character(len=3) :: int_to_char + character(len=6) :: fmt='(i3.3)' + character(len=50) :: file_name ! !----------------------------------------------------------------------- !*********************************************************************** @@ -260,6 +334,12 @@ subroutine setup_regional_BC(Atm & east_bc =.false. west_bc =.false. ! +! write(0,*)' enter setup_regional_BC isd=',isd,' ied=',ied,' jsd=',jsd,' jed=',jed + isd_mod=isd + ied_mod=ied + jsd_mod=jsd + jed_mod=jed +! !----------------------------------------------------------------------- !*** Which side(s) of the domain does this task lie on if any? !----------------------------------------------------------------------- @@ -282,31 +362,86 @@ subroutine setup_regional_BC(Atm & ! bc_update_interval=Atm%flagstruct%bc_update_interval ! - if(.not.(north_bc.or.south_bc.or.east_bc.or.west_bc))then - return !<-- This task is not on the domain boundary so exit. + k_split=Atm%flagstruct%k_split + n_split=Atm%flagstruct%n_split +! + dyn_timestep=dt_atmos/real(k_split*n_split) +! +!----------------------------------------------------------------------- +!*** Is blending row data present in the BC file and if so how many +!*** rows of data are there? All blending data that is present will +!*** be read even if the user requests fewer rows be applied. +!*** Construct the name of the regional BC file to be read. +!*** We must know whether this is a standard BC file from chgres +!*** or a new BC file generated from DA-updated data from enlarged +!*** restart files that include the boundary rows. +!----------------------------------------------------------------------- +! + write(int_to_char,fmt) bc_hour + if(.not.Atm%flagstruct%regional_bcs_from_gsi)then + file_name='INPUT/gfs_bndy.tile7.'//int_to_char//'.nc' !<-- The standard BC file from chgres. + else + file_name='INPUT/gfs_bndy.tile7.'//int_to_char//'_gsi.nc' !<-- The DA-updated BC file. + endif +! + if (is_master()) then + write(*,20011)trim(file_name) +20011 format(' regional_bc_data file_name=',a) endif +!----------------------------------------------------------------------- +!*** Open the regional BC file. +!----------------------------------------------------------------------- ! + call check(nf90_open(file_name,nf90_nowrite,ncid)) !<-- Open the BC file; get the file ID. + if (is_master()) then + write(0,*)' opened BC file ',trim(file_name) + endif ! !----------------------------------------------------------------------- +!*** Check if the desired number of blending rows are present in +!*** the boundary files. +!----------------------------------------------------------------------- ! - ntracers=Atm%ncnst - Atm%flagstruct%dnats !<-- # of advected tracers - npz=Atm%npz !<-- # of layers in vertical configuration of integration - klev_out=npz + nrows_blend_user=Atm%flagstruct%nrows_blend !<-- # of blending rows the user wnats to apply. ! - regional_bounds=>Atm%regional_bc_bounds + call check(nf90_inq_dimid(ncid,'halo',dimid)) !<-- ID of the halo dimension. + call check(nf90_inquire_dimension(ncid,dimid,len=nrows_bc_data)) !<-- Total # of rows of BC data (bndry + blending) +! + nrows_blend_in_data=nrows_bc_data-nhalo_data !<-- # of blending rows in the BC files. +! + if(nrows_blend_user>nrows_blend_in_data)then !<-- User wants more blending rows than are in the BC file. + write(char2_1,'(I2.2)')nrows_blend_user + write(char2_2,'(I2.2)')nrows_blend_in_data + call mpp_error(FATAL,'User wants to use '//char2_1//' blending rows but only '//char2_2//' blending rows are in the BC file!') + else + nrows_blend=nrows_blend_in_data !<-- # of blending rows in the BC files. + endif +! + call check(nf90_close(ncid)) !<-- Close the BC file for now. ! !----------------------------------------------------------------------- !*** Compute the index limits within the boundary region on each !*** side of the domain for both scalars and winds. Since the !*** domain does not move then the computations need to be done -!*** only once. Likewise find and save the locations of the -!*** available tracers in the tracers array. +!*** only once. !----------------------------------------------------------------------- ! call compute_regional_bc_indices(Atm%regional_bc_bounds) ! - liq_water_index = get_tracer_index(MODEL_ATMOS, 'liq_wat') - sphum_index = get_tracer_index(MODEL_ATMOS, 'sphum') +!----------------------------------------------------------------------- +! + if(.not.(north_bc.or.south_bc.or.east_bc.or.west_bc))then + return !<-- This task is not on the domain boundary so exit. + endif +! +!----------------------------------------------------------------------- +! +! ntracers=Atm%ncnst - Atm%flagstruct%dnats !<-- # of advected tracers + ntracers=Atm%ncnst !<-- Total # of tracers + npz=Atm%npz !<-- # of layers in vertical configuration of integration + klev_out=npz +! + regional_bounds=>Atm%regional_bc_bounds ! !----------------------------------------------------------------------- !*** Allocate the objects that will hold the boundary variables @@ -338,7 +473,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_north_uvw & ,klev_out & ,ntracers & - ,BC_t1%north ) + ,BC_t1%north & + ,delz_auxiliary%north ) ! call allocate_regional_BC_arrays('north' & ,north_bc,south_bc & @@ -382,7 +518,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_south_uvw & ,klev_out & ,ntracers & - ,BC_t1%south ) + ,BC_t1%south & + ,delz_auxiliary%south ) ! call allocate_regional_BC_arrays('south' & ,north_bc,south_bc & @@ -426,7 +563,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_east_uvw & ,klev_out & ,ntracers & - ,BC_t1%east ) + ,BC_t1%east & + ,delz_auxiliary%east ) ! call allocate_regional_BC_arrays('east ' & ,north_bc,south_bc & @@ -470,7 +608,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_west_uvw & ,klev_out & ,ntracers & - ,BC_t1%west ) + ,BC_t1%west & + ,delz_auxiliary%west ) ! call allocate_regional_BC_arrays('west ' & ,north_bc,south_bc & @@ -495,6 +634,8 @@ subroutine setup_regional_BC(Atm & bc_west_t1=>BC_t1%west ! endif + + call allocate_fv_nest_BC_type(delz_regBC,Atm,ns,0,0,.false.) ! !----------------------------------------------------------------------- !*** We need regional versions of the arrays for surface elevation, @@ -594,6 +735,24 @@ subroutine setup_regional_BC(Atm & enddo enddo endif +! + sphum_index = get_tracer_index(MODEL_ATMOS, 'sphum') + liq_water_index = get_tracer_index(MODEL_ATMOS, 'liq_wat') + ice_water_index = get_tracer_index(MODEL_ATMOS, 'ice_wat') + rain_water_index = get_tracer_index(MODEL_ATMOS, 'rainwat') + snow_water_index = get_tracer_index(MODEL_ATMOS, 'snowwat') + graupel_index = get_tracer_index(MODEL_ATMOS, 'graupel') + cld_amt_index = get_tracer_index(MODEL_ATMOS, 'cld_amt') + o3mr_index = get_tracer_index(MODEL_ATMOS, 'o3mr') +! write(0,*)' setup_regional_bc' +! write(0,*)' sphum_index=',sphum_index +! write(0,*)' liq_water_index=',liq_water_index +! write(0,*)' ice_water_index=',ice_water_index +! write(0,*)' rain_water_index=',rain_water_index +! write(0,*)' snow_water_index=',snow_water_index +! write(0,*)' graupel_index=',graupel_index +! write(0,*)' cld_amt_index=',cld_amt_index +! write(0,*)' o3mr_index=',o3mr_index ! !----------------------------------------------------------------------- !*** When nudging of specific humidity is selected then we need a @@ -704,6 +863,9 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !----------------------------------------------------------------------- !*** These must reach one row beyond nhalo_model since we must !*** surround the wind points on the cell edges with mass points. +! +!*** NOTE: The value of nrows_blend is the total number of +!*** blending rows in the BC files. !----------------------------------------------------------------------- ! halo_diff=nhalo_data-nhalo_model @@ -713,11 +875,11 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !----------- ! if (north_bc) then - regional_bc_bounds%is_north=isd-1 - regional_bc_bounds%ie_north=ied+1 + regional_bc_bounds%is_north=isd-1 + regional_bc_bounds%ie_north=ied+1 ! - regional_bc_bounds%js_north=jsd-1 - regional_bc_bounds%je_north=0 + regional_bc_bounds%js_north=jsd-1 + regional_bc_bounds%je_north=nrows_blend endif ! !----------- @@ -725,11 +887,11 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !----------- ! if (south_bc) then - regional_bc_bounds%is_south=isd-1 - regional_bc_bounds%ie_south=ied+1 + regional_bc_bounds%is_south=isd-1 + regional_bc_bounds%ie_south=ied+1 ! - regional_bc_bounds%js_south=jed-nhalo_model+1 - regional_bc_bounds%je_south=jed+1 + regional_bc_bounds%js_south=jed-nhalo_model-nrows_blend+1 + regional_bc_bounds%je_south=jed+1 endif ! !---------- @@ -737,18 +899,18 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !---------- ! if (east_bc) then - regional_bc_bounds%is_east=isd-1 - regional_bc_bounds%ie_east=0 + regional_bc_bounds%is_east=isd-1 + regional_bc_bounds%ie_east=nrows_blend ! - regional_bc_bounds%js_east=jsd-1 - if(north_bc)then - regional_bc_bounds%js_east=1 - endif + regional_bc_bounds%js_east=jsd-1 + if(north_bc)then + regional_bc_bounds%js_east=1 + endif ! - regional_bc_bounds%je_east=jed+1 - if(south_bc)then - regional_bc_bounds%je_east=jed-nhalo_model - endif + regional_bc_bounds%je_east=jed+1 + if(south_bc)then + regional_bc_bounds%je_east=jed-nhalo_model + endif endif ! !---------- @@ -756,18 +918,18 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !---------- ! if (west_bc) then - regional_bc_bounds%is_west=ied-nhalo_model+1 - regional_bc_bounds%ie_west=ied+1 + regional_bc_bounds%is_west=ied-nhalo_model-nrows_blend+1 + regional_bc_bounds%ie_west=ied+1 ! - regional_bc_bounds%js_west=jsd-1 - if(north_bc)then - regional_bc_bounds%js_west=1 - endif + regional_bc_bounds%js_west=jsd-1 + if(north_bc)then + regional_bc_bounds%js_west=1 + endif ! - regional_bc_bounds%je_west=jed+1 - if(south_bc)then - regional_bc_bounds%je_west=jed-nhalo_model - endif + regional_bc_bounds%je_west=jed+1 + if(south_bc)then + regional_bc_bounds%je_west=jed-nhalo_model + endif endif ! !----------------------------------------------------------------------- @@ -779,19 +941,17 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !----------- ! if (north_bc) then - regional_bc_bounds%is_north_uvs=isd - regional_bc_bounds%ie_north_uvs=ied + regional_bc_bounds%is_north_uvs=isd + regional_bc_bounds%ie_north_uvs=ied ! - regional_bc_bounds%js_north_uvs=jsd -!xxxxxx regional_bc_bounds%je_north_uvs=0 -!xxxxxx regional_bc_bounds%je_north_uvs=1 - regional_bc_bounds%je_north_uvs=1 + regional_bc_bounds%js_north_uvs=jsd + regional_bc_bounds%je_north_uvs=nrows_blend+1 ! - regional_bc_bounds%is_north_uvw=isd - regional_bc_bounds%ie_north_uvw=ied+1 + regional_bc_bounds%is_north_uvw=isd + regional_bc_bounds%ie_north_uvw=ied+1 ! - regional_bc_bounds%js_north_uvw=jsd - regional_bc_bounds%je_north_uvw=0 + regional_bc_bounds%js_north_uvw=jsd + regional_bc_bounds%je_north_uvw=nrows_blend endif ! !----------- @@ -799,18 +959,17 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !----------- ! if (south_bc) then - regional_bc_bounds%is_south_uvs=isd - regional_bc_bounds%ie_south_uvs=ied + regional_bc_bounds%is_south_uvs=isd + regional_bc_bounds%ie_south_uvs=ied ! -!xxxxxregional_bc_bounds%js_south_uvs=jed-nhalo_model+2 - regional_bc_bounds%js_south_uvs=jed-nhalo_model+1 - regional_bc_bounds%je_south_uvs=jed+1 + regional_bc_bounds%js_south_uvs=jed-nhalo_model-nrows_blend+1 + regional_bc_bounds%je_south_uvs=jed+1 ! - regional_bc_bounds%is_south_uvw=isd - regional_bc_bounds%ie_south_uvw=ied+1 + regional_bc_bounds%is_south_uvw=isd + regional_bc_bounds%ie_south_uvw=ied+1 ! - regional_bc_bounds%js_south_uvw=jed-nhalo_model+1 - regional_bc_bounds%je_south_uvw=jed + regional_bc_bounds%js_south_uvw=jed-nhalo_model-nrows_blend+1 + regional_bc_bounds%je_south_uvw=jed endif ! !---------- @@ -818,33 +977,31 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !---------- ! if (east_bc) then - regional_bc_bounds%is_east_uvs=isd - regional_bc_bounds%ie_east_uvs=0 + regional_bc_bounds%is_east_uvs=isd + regional_bc_bounds%ie_east_uvs=nrows_blend ! - regional_bc_bounds%js_east_uvs=jsd - if(north_bc)then -!xxxx regional_bc_bounds%js_east_uvs=2 !<-- north side of cell at j=2 (north bdry contains north side of j=1) - regional_bc_bounds%js_east_uvs=1 !<-- north side of cell at j=1 (north bdry contains north side of j=1) - endif + regional_bc_bounds%js_east_uvs=jsd + if(north_bc)then + regional_bc_bounds%js_east_uvs=1 !<-- north side of cell at j=1 (north bdry contains north side of j=1) + endif ! - regional_bc_bounds%je_east_uvs=jed+1 - if(south_bc)then -!xxxx regional_bc_bounds%je_east_uvs=jed-nhalo_model - regional_bc_bounds%je_east_uvs=jed-nhalo_model+1 - endif + regional_bc_bounds%je_east_uvs=jed+1 + if(south_bc)then + regional_bc_bounds%je_east_uvs=jed-nhalo_model+1 + endif ! -! regional_bc_bounds%is_east_uvw=isd-1 - regional_bc_bounds%is_east_uvw=isd - regional_bc_bounds%ie_east_uvw=0 !<-- east side of cell at i=0 +! regional_bc_bounds%is_east_uvw=isd-1 + regional_bc_bounds%is_east_uvw=isd + regional_bc_bounds%ie_east_uvw=nrows_blend !<-- east side of cell at i=nrows_blend ! - regional_bc_bounds%js_east_uvw=jsd - if(north_bc)then - regional_bc_bounds%js_east_uvw=1 - endif - regional_bc_bounds%je_east_uvw=jed - if(south_bc)then - regional_bc_bounds%je_east_uvw=jed-nhalo_model - endif + regional_bc_bounds%js_east_uvw=jsd + if(north_bc)then + regional_bc_bounds%js_east_uvw=1 + endif + regional_bc_bounds%je_east_uvw=jed + if(south_bc)then + regional_bc_bounds%je_east_uvw=jed-nhalo_model + endif endif ! !---------- @@ -852,33 +1009,31 @@ subroutine compute_regional_bc_indices(regional_bc_bounds) !---------- ! if (west_bc) then - regional_bc_bounds%is_west_uvs=ied-nhalo_model+1 - regional_bc_bounds%ie_west_uvs=ied + regional_bc_bounds%is_west_uvs=ied-nhalo_model-nrows_blend+1 + regional_bc_bounds%ie_west_uvs=ied ! - regional_bc_bounds%js_west_uvs=jsd - if(north_bc)then -!xxxx regional_bc_bounds%js_west_uvs=2 - regional_bc_bounds%js_west_uvs=1 - endif + regional_bc_bounds%js_west_uvs=jsd + if(north_bc)then + regional_bc_bounds%js_west_uvs=1 + endif ! - regional_bc_bounds%je_west_uvs=jed+1 - if(south_bc)then -!xxxx regional_bc_bounds%je_west_uvs=jed-nhalo_model - regional_bc_bounds%je_west_uvs=jed-nhalo_model+1 - endif + regional_bc_bounds%je_west_uvs=jed+1 + if(south_bc)then + regional_bc_bounds%je_west_uvs=jed-nhalo_model+1 + endif ! - regional_bc_bounds%is_west_uvw=ied-nhalo_model+2 - regional_bc_bounds%ie_west_uvw=ied+1 + regional_bc_bounds%is_west_uvw=ied-nhalo_model-nrows_blend+1 + regional_bc_bounds%ie_west_uvw=ied+1 ! - regional_bc_bounds%js_west_uvw=jsd - if(north_bc)then - regional_bc_bounds%js_west_uvw=1 - endif + regional_bc_bounds%js_west_uvw=jsd + if(north_bc)then + regional_bc_bounds%js_west_uvw=1 + endif ! - regional_bc_bounds%je_west_uvw=jed - if(south_bc)then - regional_bc_bounds%je_west_uvw=jed-nhalo_model - endif + regional_bc_bounds%je_west_uvw=jed + if(south_bc)then + regional_bc_bounds%je_west_uvw=jed-nhalo_model + endif endif ! !----------------------------------------------------------------------- @@ -914,14 +1069,15 @@ subroutine read_regional_lon_lat !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- -!*** Open the data file. +!*** Open the grid data file. !----------------------------------------------------------------------- ! filename='INPUT/'//trim(grid_data) ! - call check(nf90_open(filename,nf90_nowrite,ncid_grid)) !<-- Open the netcdf file; get the file ID. + call check(nf90_open(filename,nf90_nowrite,ncid_grid)) !<-- Open the grid data netcdf file; get the file ID. +! + call mpp_error(NOTE,' opened grid file '//trim(filename)) ! -! write(0,*)' opened grid file',trim(filename) !----------------------------------------------------------------------- !*** The longitude and latitude are on the super grid. We need only !*** the points on each corner of the grid cells which is every other @@ -931,8 +1087,6 @@ subroutine read_regional_lon_lat i_start_data=2*(isd+nhalo_model)-1 j_start_data=2*(jsd+nhalo_model)-1 ! -! write(0,11110)i_start_data,j_start_data -11110 format(' i_start_data=',i5,' j_start_data=',i5) !--------------- !*** Longitude !--------------- @@ -1011,14 +1165,15 @@ subroutine read_regional_filtered_topo !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- -!*** Get the name of the working directory. Open the data file. +!*** Get the name of the working directory. Open the topography data +!*** file. !----------------------------------------------------------------------- ! filename='INPUT/'//trim(oro_data) if (is_master()) then - write(*,23421)trim(filename) -23421 format(' topo filename=',a) + write(*,23421)trim(filename) +23421 format(' topo filename=',a) endif ! call check(nf90_open(filename,nf90_nowrite,ncid_oro)) !<-- Open the netcdf file; get the file ID. @@ -1062,7 +1217,7 @@ end subroutine setup_regional_BC !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- ! - subroutine start_regional_cold_start(Atm, ak, bk, levp & + subroutine start_regional_cold_start(Atm, dt_atmos, ak, bk, levp & ,is ,ie ,js ,je & ,isd,ied,jsd,jed ) ! @@ -1082,6 +1237,7 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & ,isd,ied,jsd,jed & !<-- Memory limits of task subdomain ,levp ! + real,intent(in) :: dt_atmos !<-- The large (physics) timestep (sec) real,intent(in) :: ak(1:levp+1), bk(1:levp+1) ! !--------------------- @@ -1094,11 +1250,13 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & !*********************************************************************** !----------------------------------------------------------------------- ! -! get the source of the input data +!----------------------------------------------------------------------- +!*** Get the source of the input data +!----------------------------------------------------------------------- ! call get_data_source(data_source,Atm%flagstruct%regional) ! - call setup_regional_BC(Atm & + call setup_regional_BC(Atm, dt_atmos & ,isd, ied, jsd, jed & ,Atm%npx, Atm%npy ) ! @@ -1108,11 +1266,21 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & ,isd, ied, jsd, jed & ,ak, bk ) call regional_bc_t1_to_t0(BC_t1, BC_t0 & ! - ,Atm%npz & !<-- Move BC t1 data + ,Atm%npz & !<-- Move BC t1 data to t0. ,ntracers & ,Atm%regional_bc_bounds ) ! ! bc_hour=bc_hour+bc_update_interval +! +!----------------------------------------------------------------------- +!*** If this is a DA run and the first BC file was updated by +!*** the GSI then reset the gsi flag so that all subsequent +!*** BC files are read normally. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%regional_bcs_from_gsi)then + Atm%flagstruct%regional_bcs_from_gsi=.false. + endif ! call regional_bc_data(Atm, bc_hour & !<-- Fill time level t1 ,is, ie, js, je & ! from the 2nd time level @@ -1127,6 +1295,17 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & enddo ! !----------------------------------------------------------------------- +!*** If the GSI will need restart files that includes the +!*** fields' boundary rows. Those files were already created. +!*** Prepare the objects that hold their variables' names and +!*** values. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%write_restart_with_bcs)then + call prepare_full_fields(Atm) + endif +! +!----------------------------------------------------------------------- ! end subroutine start_regional_cold_start ! @@ -1134,7 +1313,7 @@ end subroutine start_regional_cold_start !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- ! - subroutine start_regional_restart(Atm & + subroutine start_regional_restart(Atm, dt_atmos & ,isc,iec,jsc,jec & ,isd,ied,jsd,jed ) ! @@ -1149,6 +1328,8 @@ subroutine start_regional_restart(Atm & !------------------------ ! type(fv_atmos_type),intent(inout) :: Atm !<-- Atm object for the current domain +! + real,intent(in) :: dt_atmos !<-- The large (physics) timestep (sec) ! integer ,intent(in) :: isc,iec,jsc,jec & !<-- Integration limits of task subdomain ,isd,ied,jsd,jed !<-- Memory limits of task subdomain @@ -1160,11 +1341,11 @@ subroutine start_regional_restart(Atm & integer :: ierr, ios real, allocatable :: wk2(:,:) ! - logical :: filtered_terrain - logical :: gfs_dwinds - integer :: levp - logical :: checker_tr - integer :: nt_checker + logical :: filtered_terrain = .true. + logical :: gfs_dwinds = .true. + integer :: levp = 64 + logical :: checker_tr = .false. + integer :: nt_checker = 0 namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds & ,checker_tr, nt_checker !----------------------------------------------------------------------- @@ -1183,31 +1364,59 @@ subroutine start_regional_restart(Atm & endif ! !----------------------------------------------------------------------- +!*** Get the source of the input data. +!----------------------------------------------------------------------- +! + call get_data_source(data_source,Atm%flagstruct%regional) +! +!----------------------------------------------------------------------- !*** Preliminary setup for the forecast. !----------------------------------------------------------------------- ! - call setup_regional_BC(Atm & - ,isd, ied, jsd, jed & - ,Atm%npx, Atm%npy ) + call setup_regional_BC(Atm, dt_atmos & + ,isd, ied, jsd, jed & + ,Atm%npx, Atm%npy ) ! - allocate (wk2(levp+1,2)) - allocate (ak_in(levp+1)) !<-- Save the input vertical structure for - allocate (bk_in(levp+1)) ! remapping BC updates during the forecast. - call read_data('INPUT/gfs_ctrl.nc','vcoord',wk2, no_domain=.TRUE.) - ak_in(1:levp+1) = wk2(1:levp+1,1) - ak_in(1) = 1.e-9 - bk_in(1:levp+1) = wk2(1:levp+1,2) - deallocate(wk2) - bc_hour=nint(current_time_in_seconds/3600.) + allocate (wk2(levp+1,2)) + allocate (ak_in(levp+1)) !<-- Save the input vertical structure for + allocate (bk_in(levp+1)) ! remapping BC updates during the forecast. + call read_data('INPUT/gfs_ctrl.nc','vcoord',wk2, no_domain=.TRUE.) + ak_in(1:levp+1) = wk2(1:levp+1,1) + ak_in(1) = 1.e-9 + bk_in(1:levp+1) = wk2(1:levp+1,2) + deallocate(wk2) + bc_hour=nint(current_time_in_seconds/3600.) ! !----------------------------------------------------------------------- !*** Fill time level t1 from the BC file at the restart time. !----------------------------------------------------------------------- ! - call regional_bc_data(Atm, bc_hour & - ,isc, iec, jsc, jec & - ,isd, ied, jsd, jed & - ,ak_in, bk_in ) + call regional_bc_data(Atm, bc_hour & + ,isc, iec, jsc, jec & + ,isd, ied, jsd, jed & + ,ak_in, bk_in ) +! +!----------------------------------------------------------------------- +!*** If this is a DA run and the first BC file was updated by +!*** the GSI then that file was read differently in the preceding +!*** call to subroutine regional_bc_data. Now reset the gsi +!*** flag so that all subsequent BC files are read normally. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%regional_bcs_from_gsi)then + Atm%flagstruct%regional_bcs_from_gsi=.false. + endif +! +!----------------------------------------------------------------------- +!*** If the GSI will need restart files that include the +!*** fields' boundary rows after this forecast or forecast +!*** segment completes then prepare the objects that will +!*** hold their variables' names and values. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%write_restart_with_bcs)then + call prepare_full_fields(Atm) + endif ! !----------------------------------------------------------------------- ! @@ -1253,7 +1462,7 @@ subroutine read_new_bc_data(Atm, Time, Time_step_atmos, p_split & atmos_time = Time - Atm%Time_init atmos_time_step = atmos_time / Time_step_atmos current_time_in_seconds = time_type_to_real( atmos_time ) - if (mpp_pe() == 0) write(*,"('current_time_seconds = ',f9.1)")current_time_in_seconds + if (mpp_pe() == 0 .and. Atm%flagstruct%fv_debug) write(*,"('current_time_seconds = ',f9.1)")current_time_in_seconds ! call get_time (Time_step_atmos, sec) dt_atmos = real(sec) @@ -1348,11 +1557,14 @@ subroutine regional_bc_data(Atm,bc_hour & integer :: is_input,ie_input,js_input,je_input ! integer :: i_start,i_end,j_start,j_end +! + integer :: nside,nt,index ! real,dimension(:,:,:),allocatable :: ud,vd,uc,vc ! real,dimension(:,:),allocatable :: ps_reg - real,dimension(:,:,:),allocatable :: ps_input,t_input & + real,dimension(:,:,:),allocatable :: delp_input,delz_input & + ,ps_input,t_input & ,w_input,zh_input real,dimension(:,:,:),allocatable :: u_s_input,v_s_input & ,u_w_input,v_w_input @@ -1379,9 +1591,10 @@ subroutine regional_bc_data(Atm,bc_hour & character(len=50) :: file_name ! integer,save :: kount1=0,kount2=0 + integer :: istart, iend, jstart, jend + integer :: npx, npy ! character(len=60) :: var_name_root - integer :: nside,nt,index logical :: required ! logical :: call_remap @@ -1397,7 +1610,6 @@ subroutine regional_bc_data(Atm,bc_hour & if(.not.(north_bc.or.south_bc.or.east_bc.or.west_bc))then return endif -!if (data_source == 'FV3GFS GAUSSIAN NEMSIO FILE') ! !----------------------------------------------------------------------- ! @@ -1405,21 +1617,31 @@ subroutine regional_bc_data(Atm,bc_hour & ! !----------------------------------------------------------------------- !*** Construct the name of the regional BC file to be read. +!*** We must know whether this is a standard BC file from chgres +!*** or a new BC file generated from DA-updated data from enlarged +!*** restart files that include the boundary rows. !----------------------------------------------------------------------- ! write(int_to_char,fmt) bc_hour - file_name='INPUT/gfs_bndy.tile7.'//int_to_char//'.nc' + if(.not.Atm%flagstruct%regional_bcs_from_gsi)then + file_name='INPUT/gfs_bndy.tile7.'//int_to_char//'.nc' !<-- The standard BC file from chgres. + else + file_name='INPUT/gfs_bndy.tile7.'//int_to_char//'_gsi.nc' !<-- The DA-updated BC file. + endif ! if (is_master()) then - write(*,22211)trim(file_name) -22211 format(' regional_bc_data file_name=',a) + write(*,22211)trim(file_name) +22211 format(' regional_bc_data file_name=',a) endif !----------------------------------------------------------------------- !*** Open the regional BC file. !*** Find the # of layers (klev_in) in the BC input. !----------------------------------------------------------------------- ! - call check(nf90_open(file_name,nf90_nowrite,ncid)) !<-- Open the netcdf file; get the file ID. + call check(nf90_open(file_name,nf90_nowrite,ncid)) !<-- Open the BC file; get the file ID. + if (is_master()) then + write(0,*)' opened BC file ',trim(file_name) + endif ! call check(nf90_inq_dimid(ncid,'lev',dimid)) !<-- Get the vertical dimension's NetCDF ID. call check(nf90_inquire_dimension(ncid,dimid,len=klev_in)) !<-- Get the vertical dimension's value (klev_in). @@ -1432,15 +1654,23 @@ subroutine regional_bc_data(Atm,bc_hour & ie_input=ie+nhalo_data js_input=js-nhalo_data je_input=je+nhalo_data + npx = Atm%npx + npy = Atm%npy ! allocate( ps_input(is_input:ie_input,js_input:je_input,1)) ; ps_input=real_snan !<-- Sfc pressure allocate( t_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; t_input=real_snan !<-- Sensible temperature allocate( w_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; w_input=real_snan !<-- Vertical velocity - allocate( zh_input(is_input:ie_input,js_input:je_input,1:klev_in+1)) ; zh_input=real_snan !<-- Interface heights allocate(u_s_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; u_s_input=real_snan !<-- D-grid u component allocate(v_s_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; v_s_input=real_snan !<-- C-grid v component allocate(u_w_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; u_w_input=real_snan !<-- C-grid u component allocate(v_w_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; v_w_input=real_snan !<-- D-grid v component +! + if(Atm%flagstruct%regional_bcs_from_gsi)then + allocate(delp_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; delp_input=real_snan !<-- Lyr pressure depth (Pa) + allocate(delz_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; delz_input=real_snan !<-- Lyr geometric depth (m) + else + allocate( zh_input(is_input:ie_input,js_input:je_input,1:klev_in+1)) ; zh_input=real_snan !<-- Lyr interface heights (m) + endif ! allocate(tracers_input(is_input:ie_input,js_input:je_input,klev_in,ntracers)) ; tracers_input=real_snan ! @@ -1479,14 +1709,15 @@ subroutine regional_bc_data(Atm,bc_hour & !*** Interface heights !----------------------- ! - nlev=klev_in+1 - var_name_root='zh' - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,var_name_root & - ,array_3d=zh_input) + if(.not.Atm%flagstruct%regional_bcs_from_gsi)then + nlev=klev_in+1 + var_name_root='zh' + call read_regional_bc_file(is_input,ie_input,js_input,je_input & + ,nlev & + ,ntracers & + ,var_name_root & + ,array_3d=zh_input) + endif ! !-------------------------- !*** Sensible temperature @@ -1554,9 +1785,31 @@ subroutine regional_bc_data(Atm,bc_hour & ! ,Atm%regional_bc_bounds & ,var_name_root & ,array_3d=v_w_input) -!---------------------- -!*** tracers -!----------------------- +! +!----------------------------------------------------------------------- +!*** If this is a DA-updated BC file then also read in the layer +!*** pressure depths. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%regional_bcs_from_gsi)then + nlev=klev_in + var_name_root='delp' + call read_regional_bc_file(is_input,ie_input,js_input,je_input & + ,nlev & + ,ntracers & + ,var_name_root & + ,array_3d=delp_input) + var_name_root='delz' + call read_regional_bc_file(is_input,ie_input,js_input,je_input & + ,nlev & + ,ntracers & + ,var_name_root & + ,array_3d=delz_input) + endif +! +!------------- +!*** Tracers +!------------- nlev=klev_in ! @@ -1585,19 +1838,23 @@ subroutine regional_bc_data(Atm,bc_hour & enddo ! !----------------------------------------------------------------------- -!*** We now have the boundary variables from the BC file on the -!*** levels of the input data. Before remapping the 3-D variables -!*** from the input levels to the model integration levels we will -!*** simply copy the 2-D sfc pressure (ps) into the model array. +!*** For a DA-updated BC file we can simply transfer the data +!*** from the *_input arrays into the model's boundary arrays +!*** since they came out of restart files. Otherwise proceed +!*** with vertical remapping from input layers to model forecast +!*** layers and rotate the winds from geographic lat/lon to the +!*** integration grid. +!----------------------------------------------------------------------- +! + data_to_BC: if(Atm%flagstruct%regional_bcs_from_gsi)then !<-- Fill BC arrays directly from the BC file data +! !----------------------------------------------------------------------- ! -! do j=jsd,jed -! do i=isd,ied -! Atm%ps(i,j)=ps(i,j) -! enddo -! enddo + call fill_BC_for_DA +! +!----------------------------------------------------------------------- ! -! deallocate(ps%north,ps%south,ps%east,ps%west) + else !<-- Rotate winds and vertically remap BC file data ! !----------------------------------------------------------------------- !*** One final array needs to be allocated. It is the sfc pressure @@ -1607,7 +1864,7 @@ subroutine regional_bc_data(Atm,bc_hour & !*** the integration levels. !----------------------------------------------------------------------- ! - allocate(ps_reg(is_input:ie_input,js_input:je_input)) ; ps_reg=-9999999 ! for now don't set to snan until remap dwinds is changed + allocate(ps_reg(is_input:ie_input,js_input:je_input)) ; ps_reg=-9999999 ! for now don't set to snan until remap dwinds is changed ! !----------------------------------------------------------------------- !*** We have the boundary variables from the BC file on the levels @@ -1619,17 +1876,25 @@ subroutine regional_bc_data(Atm,bc_hour & !*** from two different boundary side regions. !----------------------------------------------------------------------- ! +! Definitions in this module greatly differ from those in existing nesting +! code or elsewhere in FMS. North <--> South, East <--> West, and +! North and South always span [isd-1 , ied+1] while East and West do not +! go into the outermost corners (so the they span [1, je], always.) !----------------------------------------------------------------------- - sides_scalars: do nside=1,4 + sides_scalars: do nside=1,4 !----------------------------------------------------------------------- +!----------- +!*** North +!----------- ! - call_remap=.false. + call_remap=.false. ! if(nside==1)then if(north_bc)then call_remap=.true. side='north' bc_side_t1=>BC_t1%north + bc_side_t0=>BC_t0%north endif endif ! @@ -1638,58 +1903,208 @@ subroutine regional_bc_data(Atm,bc_hour & call_remap=.true. side='south' bc_side_t1=>BC_t1%south + bc_side_t0=>BC_t0%south endif endif ! - if(nside==3)then - if(east_bc)then - call_remap=.true. - side='east ' - bc_side_t1=>BC_t1%east + if(nside==3)then + if(east_bc)then + call_remap=.true. + side='east ' + bc_side_t1=>BC_t1%east + bc_side_t0=>BC_t0%east + endif endif - endif ! if(nside==4)then if(west_bc)then call_remap=.true. side='west ' bc_side_t1=>BC_t1%west + bc_side_t0=>BC_t0%west endif endif ! - if(call_remap)then - call remap_scalar_nggps_regional_bc(Atm & - ,side & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,t_input & ! BC vbls - ,tracers_input & ! on input - ,w_input & ! model levels - ,zh_input & !<-- + if(call_remap)then + call remap_scalar_nggps_regional_bc(Atm & + ,side & + + ,isd,ied,jsd,jed & !<-- Atm array indices w/halo + + ,is_input & !<-- + ,ie_input & ! Input array + ,js_input & ! index limits. + ,je_input & !<-- + + ,klev_in, klev_out & + ,ntracers & + ,ak, bk & + + ,ps_input & !<-- + ,t_input & ! BC vbls + ,tracers_input & ! on input + ,w_input & ! model levels + ,zh_input & !<-- + + ,phis_reg & !<-- Filtered topography + + ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region + + ,bc_side_t1 ) !<-- BC vbls on final integration levels +! + call set_delp_and_tracers(bc_side_t1,Atm%npz,Atm%flagstruct%nwat) +! + if(nside==1)then + if(north_bc)then + if (is == 1) then + istart = 1 + else + istart = isd + endif + if (ie == npx-1) then + iend = npx-1 + else + iend = ied + endif + + do k=1,npz + do j=jsd,0 + do i=istart,iend + delz_regBC%south_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%south_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + + ! North, south include all corners + if (is == 1) then + do k=1,npz + do j=jsd,0 + do i=isd,0 + delz_regBC%west_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%west_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + + if (ie == npx-1) then + do k=1,npz + do j=jsd,0 + do i=npx,ied + delz_regBC%east_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%east_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif + endif - ,phis_reg & !<-- Filtered topography + if(nside==2)then + if(south_bc)then + if (is == 1) then + istart = 1 + else + istart = isd + endif + if (ie == npx-1) then + iend = npx-1 + else + iend = ied + endif + + do k=1,npz + do j=npy,jed + do i=istart,iend + delz_regBC%north_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%north_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + + ! North, south include all corners + if (is == 1) then + do k=1,npz + do j=npy,jed + do i=isd,0 + delz_regBC%west_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%west_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + + + if (ie == npx-1) then + do k=1,npz + do j=npy,jed + do i=npx,ied + delz_regBC%east_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%east_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif + endif + +! + + if(nside==3)then + if(east_bc)then + if (js == 1) then + jstart = 1 + else + jstart = jsd + endif + if (je == npy-1) then + jend = je + else + jend = jed + endif + + + do k=1,npz + do j=jstart,jend + do i=isd,0 + delz_regBC%west_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%west_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region + if(nside==4)then + if(west_bc)then + if (js == 1) then + jstart = 1 + else + jstart = jsd + endif + if (je == npy-1) then + jend = je + else + jend = jed + endif + + + do k=1,npz + do j=jstart,jend + do i=npx,ied + delz_regBC%east_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%east_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif - ,bc_side_t1 ) !<-- BC vbls on final integration levels -! - call set_delp_and_tracers(bc_side_t1,Atm%npz,Atm%flagstruct%nwat) -! endif ! !----------------------------------------------------------------------- - enddo sides_scalars + enddo sides_scalars !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- @@ -1699,43 +2114,43 @@ subroutine regional_bc_data(Atm,bc_hour & !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- -!*** Transform the D-grid wind components on the north side of +!*** Transform the D-grid wind components on the four sides of !*** the regional domain then remap them from the input levels !*** to the integration levels. !----------------------------------------------------------------------- ! #ifdef USE_FMS_READ - isc2 = 2*(isd-1+nhalo_data)-1 - iec2 = 2*(ied+2+nhalo_data)-1 - jsc2 = 2*(jsd-1+nhalo_data)-1 - jec2 = 2*(jed+2+nhalo_data)-1 - allocate(tmpx(isc2:iec2, jsc2:jec2)) ; tmpx=dbl_snan - allocate(tmpy(isc2:iec2, jsc2:jec2)) ; tmpy=dbl_snan - start = 1; nread = 1 - start(1) = isc2; nread(1) = iec2 - isc2 + 1 - start(2) = jsc2; nread(2) = jec2 - jsc2 + 1 - call read_data("INPUT/grid.tile7.halo4.nc", 'x', tmpx, start, nread, no_domain=.TRUE.) - call read_data("INPUT/grid.tile7.halo4.nc", 'y', tmpy, start, nread, no_domain=.TRUE.) - - allocate(reg_grid(isd-1:ied+2,jsd-1:jed+2,1:2)) ; reg_grid=dbl_snan - do j = jsd-1, jed+2 - do i = isd-1, ied+2 - reg_grid(i,j,1) = tmpx(2*(i+nhalo_data)-1, 2*(j+nhalo_data)-1)*pi/180. - reg_grid(i,j,2) = tmpy(2*(i+nhalo_data)-1, 2*(j+nhalo_data)-1)*pi/180. - if ( reg_grid(i,j,1) /= grid_reg(i,j,1) ) then - write(0,*)' reg_grid(i,j,1) /= grid_reg(i,j,1) ',i,j, reg_grid(i,j,1),grid_reg(i,j,1) - endif - enddo - enddo + isc2 = 2*(isd-1+nhalo_data)-1 + iec2 = 2*(ied+2+nhalo_data)-1 + jsc2 = 2*(jsd-1+nhalo_data)-1 + jec2 = 2*(jed+2+nhalo_data)-1 + allocate(tmpx(isc2:iec2, jsc2:jec2)) ; tmpx=dbl_snan + allocate(tmpy(isc2:iec2, jsc2:jec2)) ; tmpy=dbl_snan + start = 1; nread = 1 + start(1) = isc2; nread(1) = iec2 - isc2 + 1 + start(2) = jsc2; nread(2) = jec2 - jsc2 + 1 + call read_data("INPUT/grid.tile7.halo4.nc", 'x', tmpx, start, nread, no_domain=.TRUE.) + call read_data("INPUT/grid.tile7.halo4.nc", 'y', tmpy, start, nread, no_domain=.TRUE.) + + allocate(reg_grid(isd-1:ied+2,jsd-1:jed+2,1:2)) ; reg_grid=dbl_snan + do j = jsd-1, jed+2 + do i = isd-1, ied+2 + reg_grid(i,j,1) = tmpx(2*(i+nhalo_data)-1, 2*(j+nhalo_data)-1)*pi/180. + reg_grid(i,j,2) = tmpy(2*(i+nhalo_data)-1, 2*(j+nhalo_data)-1)*pi/180. + if ( reg_grid(i,j,1) /= grid_reg(i,j,1) ) then + write(0,*)' reg_grid(i,j,1) /= grid_reg(i,j,1) ',i,j, reg_grid(i,j,1),grid_reg(i,j,1) + endif + enddo + enddo - allocate(reg_agrid(isd-1:ied+1,jsd-1:jed+1,1:2)) ; reg_agrid=dbl_snan - do j=jsd-1,jed+1 - do i=isd-1,ied+1 - call cell_center2(reg_grid(i,j, 1:2), reg_grid(i+1,j, 1:2), & - reg_grid(i,j+1,1:2), reg_grid(i+1,j+1,1:2), & - reg_agrid(i,j,1:2) ) - enddo - enddo + allocate(reg_agrid(isd-1:ied+1,jsd-1:jed+1,1:2)) ; reg_agrid=dbl_snan + do j=jsd-1,jed+1 + do i=isd-1,ied+1 + call cell_center2(reg_grid(i,j, 1:2), reg_grid(i+1,j, 1:2), & + reg_grid(i,j+1,1:2), reg_grid(i+1,j+1,1:2), & + reg_agrid(i,j,1:2) ) + enddo + enddo #endif ! !----------------------------------------------------------------------- @@ -1743,156 +2158,156 @@ subroutine regional_bc_data(Atm,bc_hour & !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- - sides_winds: do nside=1,4 + sides_winds: do nside=1,4 !----------------------------------------------------------------------- ! - call_remap=.false. + call_remap=.false. - if(nside==1)then - if(north_bc)then - call_remap=.true. - bc_side_t1=>BC_t1%north -! - is_u=Atm%regional_bc_bounds%is_north_uvs - ie_u=Atm%regional_bc_bounds%ie_north_uvs - js_u=Atm%regional_bc_bounds%js_north_uvs - je_u=Atm%regional_bc_bounds%je_north_uvs -! - is_v=Atm%regional_bc_bounds%is_north_uvw - ie_v=Atm%regional_bc_bounds%ie_north_uvw - js_v=Atm%regional_bc_bounds%js_north_uvw - je_v=Atm%regional_bc_bounds%je_north_uvw + if(nside==1)then + if(north_bc)then + call_remap=.true. + bc_side_t1=>BC_t1%north +! + is_u=Atm%regional_bc_bounds%is_north_uvs + ie_u=Atm%regional_bc_bounds%ie_north_uvs + js_u=Atm%regional_bc_bounds%js_north_uvs + je_u=Atm%regional_bc_bounds%je_north_uvs +! + is_v=Atm%regional_bc_bounds%is_north_uvw + ie_v=Atm%regional_bc_bounds%ie_north_uvw + js_v=Atm%regional_bc_bounds%js_north_uvw + je_v=Atm%regional_bc_bounds%je_north_uvw + endif endif - endif -! - if(nside==2)then - if(south_bc)then - call_remap=.true. - bc_side_t1=>BC_t1%south ! - is_u=Atm%regional_bc_bounds%is_south_uvs - ie_u=Atm%regional_bc_bounds%ie_south_uvs - js_u=Atm%regional_bc_bounds%js_south_uvs - je_u=Atm%regional_bc_bounds%je_south_uvs -! - is_v=Atm%regional_bc_bounds%is_south_uvw - ie_v=Atm%regional_bc_bounds%ie_south_uvw - js_v=Atm%regional_bc_bounds%js_south_uvw - je_v=Atm%regional_bc_bounds%je_south_uvw + if(nside==2)then + if(south_bc)then + call_remap=.true. + bc_side_t1=>BC_t1%south +! + is_u=Atm%regional_bc_bounds%is_south_uvs + ie_u=Atm%regional_bc_bounds%ie_south_uvs + js_u=Atm%regional_bc_bounds%js_south_uvs + je_u=Atm%regional_bc_bounds%je_south_uvs +! + is_v=Atm%regional_bc_bounds%is_south_uvw + ie_v=Atm%regional_bc_bounds%ie_south_uvw + js_v=Atm%regional_bc_bounds%js_south_uvw + je_v=Atm%regional_bc_bounds%je_south_uvw + endif endif - endif ! - if(nside==3)then - if(east_bc)then - call_remap=.true. - bc_side_t1=>BC_t1%east + if(nside==3)then + if(east_bc)then + call_remap=.true. + bc_side_t1=>BC_t1%east ! - is_u=Atm%regional_bc_bounds%is_east_uvs - ie_u=Atm%regional_bc_bounds%ie_east_uvs - js_u=Atm%regional_bc_bounds%js_east_uvs - je_u=Atm%regional_bc_bounds%je_east_uvs + is_u=Atm%regional_bc_bounds%is_east_uvs + ie_u=Atm%regional_bc_bounds%ie_east_uvs + js_u=Atm%regional_bc_bounds%js_east_uvs + je_u=Atm%regional_bc_bounds%je_east_uvs ! - is_v=Atm%regional_bc_bounds%is_east_uvw - ie_v=Atm%regional_bc_bounds%ie_east_uvw - js_v=Atm%regional_bc_bounds%js_east_uvw - je_v=Atm%regional_bc_bounds%je_east_uvw + is_v=Atm%regional_bc_bounds%is_east_uvw + ie_v=Atm%regional_bc_bounds%ie_east_uvw + js_v=Atm%regional_bc_bounds%js_east_uvw + je_v=Atm%regional_bc_bounds%je_east_uvw + endif endif - endif ! - if(nside==4)then - if(west_bc)then - call_remap=.true. - bc_side_t1=>BC_t1%west + if(nside==4)then + if(west_bc)then + call_remap=.true. + bc_side_t1=>BC_t1%west ! - is_u=Atm%regional_bc_bounds%is_west_uvs - ie_u=Atm%regional_bc_bounds%ie_west_uvs - js_u=Atm%regional_bc_bounds%js_west_uvs - je_u=Atm%regional_bc_bounds%je_west_uvs + is_u=Atm%regional_bc_bounds%is_west_uvs + ie_u=Atm%regional_bc_bounds%ie_west_uvs + js_u=Atm%regional_bc_bounds%js_west_uvs + je_u=Atm%regional_bc_bounds%je_west_uvs ! - is_v=Atm%regional_bc_bounds%is_west_uvw - ie_v=Atm%regional_bc_bounds%ie_west_uvw - js_v=Atm%regional_bc_bounds%js_west_uvw - je_v=Atm%regional_bc_bounds%je_west_uvw + is_v=Atm%regional_bc_bounds%is_west_uvw + ie_v=Atm%regional_bc_bounds%ie_west_uvw + js_v=Atm%regional_bc_bounds%js_west_uvw + je_v=Atm%regional_bc_bounds%je_west_uvw + endif endif - endif ! - if(call_remap)then + if(call_remap)then ! - allocate(ud(is_u:ie_u,js_u:je_u,1:nlev)) ; ud=real_snan - allocate(vd(is_v:ie_v,js_v:je_v,1:nlev)) ; vd=real_snan - allocate(vc(is_u:ie_u,js_u:je_u,1:nlev)) ; vc=real_snan - allocate(uc(is_v:ie_v,js_v:je_v,1:nlev)) ; uc=real_snan + allocate(ud(is_u:ie_u,js_u:je_u,1:nlev)) ; ud=real_snan + allocate(vd(is_v:ie_v,js_v:je_v,1:nlev)) ; vd=real_snan + allocate(vc(is_u:ie_u,js_u:je_u,1:nlev)) ; vc=real_snan + allocate(uc(is_v:ie_v,js_v:je_v,1:nlev)) ; uc=real_snan ! - do k=1,nlev - do j=js_u,je_u - do i=is_u,ie_u - p1(:) = grid_reg(i, j,1:2) - p2(:) = grid_reg(i+1,j,1:2) - call mid_pt_sphere(p1, p2, p3) - call get_unit_vect2(p1, p2, e1) - call get_latlon_vector(p3, ex, ey) - ud(i,j,k) = u_s_input(i,j,k)*inner_prod(e1,ex)+v_s_input(i,j,k)*inner_prod(e1,ey) - p4(:) = agrid_reg(i,j,1:2) ! cell centroid - call get_unit_vect2(p3, p4, e2) !C-grid V-wind unit vector - vc(i,j,k) = u_s_input(i,j,k)*inner_prod(e2,ex)+v_s_input(i,j,k)*inner_prod(e2,ey) - enddo - enddo -! - do j=js_v,je_v - do i=is_v,ie_v - p1(:) = grid_reg(i,j ,1:2) - p2(:) = grid_reg(i,j+1,1:2) + do k=1,nlev + do j=js_u,je_u + do i=is_u,ie_u + p1(:) = grid_reg(i, j,1:2) + p2(:) = grid_reg(i+1,j,1:2) call mid_pt_sphere(p1, p2, p3) - call get_unit_vect2(p1, p2, e2) + call get_unit_vect2(p1, p2, e1) call get_latlon_vector(p3, ex, ey) - vd(i,j,k) = u_w_input(i,j,k)*inner_prod(e2,ex)+v_w_input(i,j,k)*inner_prod(e2,ey) + ud(i,j,k) = u_s_input(i,j,k)*inner_prod(e1,ex)+v_s_input(i,j,k)*inner_prod(e1,ey) p4(:) = agrid_reg(i,j,1:2) ! cell centroid - call get_unit_vect2(p3, p4, e1) !C-grid U-wind unit vector - uc(i,j,k) = u_w_input(i,j,k)*inner_prod(e1,ex)+v_w_input(i,j,k)*inner_prod(e1,ey) + call get_unit_vect2(p3, p4, e2) !C-grid V-wind unit vector + vc(i,j,k) = u_s_input(i,j,k)*inner_prod(e2,ex)+v_s_input(i,j,k)*inner_prod(e2,ey) + enddo enddo - enddo - enddo ! - call remap_dwinds_regional_bc(Atm & - - ,is_input & !<-- - ,ie_input & ! Index limits for scalars - ,js_input & ! at center of north BC region grid cells. - ,je_input & !<-- + do j=js_v,je_v + do i=is_v,ie_v + p1(:) = grid_reg(i,j ,1:2) + p2(:) = grid_reg(i,j+1,1:2) + call mid_pt_sphere(p1, p2, p3) + call get_unit_vect2(p1, p2, e2) + call get_latlon_vector(p3, ex, ey) + vd(i,j,k) = u_w_input(i,j,k)*inner_prod(e2,ex)+v_w_input(i,j,k)*inner_prod(e2,ey) + p4(:) = agrid_reg(i,j,1:2) ! cell centroid + call get_unit_vect2(p3, p4, e1) !C-grid U-wind unit vector + uc(i,j,k) = u_w_input(i,j,k)*inner_prod(e1,ex)+v_w_input(i,j,k)*inner_prod(e1,ey) + enddo + enddo + enddo +! + call remap_dwinds_regional_bc(Atm & - ,is_u & !<-- - ,ie_u & ! Index limits for u component - ,js_u & ! on north edge of BC region grid cells. - ,je_u & !<-- + ,is_input & !<-- + ,ie_input & ! Index limits for scalars + ,js_input & ! at center of north BC region grid cells. + ,je_input & !<-- - ,is_v & !<-- - ,ie_v & ! Index limits for v component - ,js_v & ! on north edge of BC region grid cells. - ,je_v & !<-- + ,is_u & !<-- + ,ie_u & ! Index limits for u component + ,js_u & ! on north edge of BC region grid cells. + ,je_u & !<-- - ,klev_in, klev_out & !<-- data / model levels - ,ak, bk & + ,is_v & !<-- + ,ie_v & ! Index limits for v component + ,js_v & ! on north edge of BC region grid cells. + ,je_v & !<-- - ,ps_reg & !<-- BC values of sfc pressure - ,ud ,vd & !<-- BC values of D-grid u and v - ,uc ,vc & !<-- BC values of C-grid u and v - ,bc_side_t1 ) !<-- North BC vbls on final integration levels + ,klev_in, klev_out & !<-- data / model levels + ,ak, bk & + ,ps_reg & !<-- BC values of sfc pressure + ,ud ,vd & !<-- BC values of D-grid u and v + ,uc ,vc & !<-- BC values of C-grid u and v + ,bc_side_t1 ) !<-- North BC vbls on final integration levels ! - deallocate(ud,vd,uc,vc) + deallocate(ud,vd,uc,vc) ! - endif + endif ! !----------------------------------------------------------------------- - enddo sides_winds + enddo sides_winds !----------------------------------------------------------------------- +! + endif data_to_BC ! !----------------------------------------------------------------------- !*** Close the boundary file. !----------------------------------------------------------------------- ! call check(nf90_close(ncid)) -! write(0,*)' closed BC netcdf file' ! !----------------------------------------------------------------------- !*** Deallocate working arrays. @@ -1926,6 +2341,12 @@ subroutine regional_bc_data(Atm,bc_hour & if(allocated(v_w_input))then deallocate(v_w_input) endif + if(allocated(delp_input))then + deallocate(delp_input) + endif + if(allocated(delz_input))then + deallocate(delz_input) + endif ! !----------------------------------------------------------------------- !*** Fill the remaining boundary arrays starting with the divergence. @@ -1954,8 +2375,7 @@ subroutine regional_bc_data(Atm,bc_hour & !*** FV3's modified virtual potential temperature. !----------------------------------------------------------------------- ! - call convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & - ,sphum_index,liq_water_index ) + call convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) ! !----------------------------------------------------------------------- !*** If nudging of the specific humidity has been selected then @@ -1971,6 +2391,284 @@ subroutine regional_bc_data(Atm,bc_hour & contains +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + subroutine fill_BC_for_DA +! +!----------------------------------------------------------------------- +!*** Transfer the input boundary data directly into the BC object. +!----------------------------------------------------------------------- +! +!--------------------- +!*** Local variables +!--------------------- +! + integer :: i,j,k,n +! +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +!*** Since corner tasks are on more than one side we cannot +!*** generalize the transfer of data into a given side's +!*** arrays. Do each side separately. +! +!*** Simply obtain the loop limits from the bounds of one of the +!*** BC arrays to be filled. +!----------------------------------------------------------------------- +! +!----------- +!*** North +!----------- +! + if(north_bc)then +! + is_input=lbound(BC_t1%north%delp_BC,1) !<-- + ie_input=ubound(BC_t1%north%delp_BC,1) ! Index limits for + js_input=lbound(BC_t1%north%delp_BC,2) ! mass variables. + je_input=ubound(BC_t1%north%delp_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%north%delp_BC(i,j,k)=delp_input(i,j,k) + BC_t1%north%pt_BC(i,j,k)=t_input(i,j,k) + BC_t1%north%w_BC(i,j,k)=w_input(i,j,k) + BC_t1%north%delz_BC(i,j,k)=delz_input(i,j,k) + enddo + enddo + enddo +! + do n=1,ntracers + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%north%q_BC(i,j,k,n)=tracers_input(i,j,k,n) + enddo + enddo + enddo + enddo +! + is_input=lbound(BC_t1%north%u_BC,1) !<-- + ie_input=ubound(BC_t1%north%u_BC,1) ! Index limits for + js_input=lbound(BC_t1%north%u_BC,2) ! D-grid u and C-grid v. + je_input=ubound(BC_t1%north%u_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%north%u_BC(i,j,k)=u_s_input(i,j,k) + BC_t1%north%vc_BC(i,j,k)=v_s_input(i,j,k) + enddo + enddo + enddo +! + is_input=lbound(BC_t1%north%v_BC,1) !<-- + ie_input=ubound(BC_t1%north%v_BC,1) ! Index limits for + js_input=lbound(BC_t1%north%v_BC,2) ! D-grid v and C-grid u. + je_input=ubound(BC_t1%north%v_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%north%v_BC(i,j,k)=v_w_input(i,j,k) + BC_t1%north%uc_BC(i,j,k)=u_w_input(i,j,k) + enddo + enddo + enddo +! + endif +! +!----------- +!*** South +!----------- +! + if(south_bc)then + is_input=lbound(BC_t1%south%delp_BC,1) !<--- + ie_input=ubound(BC_t1%south%delp_BC,1) ! Index limits for + js_input=lbound(BC_t1%south%delp_BC,2) ! mass variables. + je_input=ubound(BC_t1%south%delp_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%south%delp_BC(i,j,k)=delp_input(i,j,k) + BC_t1%south%pt_BC(i,j,k)=t_input(i,j,k) + BC_t1%south%w_BC(i,j,k)=w_input(i,j,k) + BC_t1%south%delz_BC(i,j,k)=delz_input(i,j,k) + enddo + enddo + enddo +! + do n=1,ntracers + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%south%q_BC(i,j,k,n)=tracers_input(i,j,k,n) + enddo + enddo + enddo + enddo +! + is_input=lbound(BC_t1%south%u_BC,1) !<-- + ie_input=ubound(BC_t1%south%u_BC,1) ! Index limits for + js_input=lbound(BC_t1%south%u_BC,2) ! D-grid u and C-grid v. + je_input=ubound(BC_t1%south%u_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%south%u_BC(i,j,k)=u_s_input(i,j,k) + BC_t1%south%vc_BC(i,j,k)=v_s_input(i,j,k) + enddo + enddo + enddo +! + is_input=lbound(BC_t1%south%v_BC,1) !<-- + ie_input=ubound(BC_t1%south%v_BC,1) ! Index limits for + js_input=lbound(BC_t1%south%v_BC,2) ! D-grid v and C-grid u. + je_input=ubound(BC_t1%south%v_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%south%v_BC(i,j,k)=v_w_input(i,j,k) + BC_t1%south%uc_BC(i,j,k)=u_w_input(i,j,k) + enddo + enddo + enddo +! + endif +! +!---------- +!*** East +!---------- +! + if(east_bc)then + is_input=lbound(BC_t1%east%delp_BC,1) !<-- + ie_input=ubound(BC_t1%east%delp_BC,1) ! Index limits + js_input=lbound(BC_t1%east%delp_BC,2) ! for mass variables. + je_input=ubound(BC_t1%east%delp_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%east%delp_BC(i,j,k)=delp_input(i,j,k) + BC_t1%east%pt_BC(i,j,k)=t_input(i,j,k) + BC_t1%east%w_BC(i,j,k)=w_input(i,j,k) + BC_t1%east%delz_BC(i,j,k)=delz_input(i,j,k) + enddo + enddo + enddo +! + do n=1,ntracers + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%east%q_BC(i,j,k,n)=tracers_input(i,j,k,n) + enddo + enddo + enddo + enddo +! + is_input=lbound(BC_t1%east%u_BC,1) !<-- + ie_input=ubound(BC_t1%east%u_BC,1) ! Index limits for + js_input=lbound(BC_t1%east%u_BC,2) ! D-grid u and C-grid v. + je_input=ubound(BC_t1%east%u_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%east%u_BC(i,j,k)=u_s_input(i,j,k) + BC_t1%east%vc_BC(i,j,k)=v_s_input(i,j,k) + enddo + enddo + enddo +! + is_input=lbound(BC_t1%east%v_BC,1) !<-- + ie_input=ubound(BC_t1%east%v_BC,1) ! Index limits for + js_input=lbound(BC_t1%east%v_BC,2) ! D-grid v and C-grid u. + je_input=ubound(BC_t1%east%v_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%east%v_BC(i,j,k)=v_w_input(i,j,k) + BC_t1%east%uc_BC(i,j,k)=u_w_input(i,j,k) + enddo + enddo + enddo +! + endif +! +!---------- +!*** West +!---------- +! + if(west_bc)then + is_input=lbound(BC_t1%west%delp_BC,1) !<-- + ie_input=ubound(BC_t1%west%delp_BC,1) ! Index limits for + js_input=lbound(BC_t1%west%delp_BC,2) ! mass variables. + je_input=ubound(BC_t1%west%delp_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%west%delp_BC(i,j,k)=delp_input(i,j,k) + BC_t1%west%pt_BC(i,j,k)=t_input(i,j,k) + BC_t1%west%w_BC(i,j,k)=w_input(i,j,k) + BC_t1%west%delz_BC(i,j,k)=delz_input(i,j,k) + enddo + enddo + enddo +! + do n=1,ntracers + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%west%q_BC(i,j,k,n)=tracers_input(i,j,k,n) + enddo + enddo + enddo + enddo +! + is_input=lbound(BC_t1%west%u_BC,1) !<-- + ie_input=ubound(BC_t1%west%u_BC,1) ! Index limits for + js_input=lbound(BC_t1%west%u_BC,2) ! D-grid u and C-grid v. + je_input=ubound(BC_t1%west%u_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%west%u_BC(i,j,k)=u_s_input(i,j,k) + BC_t1%west%vc_BC(i,j,k)=v_s_input(i,j,k) + enddo + enddo + enddo +! + is_input=lbound(BC_t1%west%v_BC,1) !<-- + ie_input=ubound(BC_t1%west%v_BC,1) ! Index limits for + js_input=lbound(BC_t1%west%v_BC,2) ! D-grid v and C-grid u. + je_input=ubound(BC_t1%west%v_BC,2) !<-- +! + do k=1,klev_in + do j=js_input,je_input + do i=is_input,ie_input + BC_t1%west%v_BC(i,j,k)=v_w_input(i,j,k) + BC_t1%west%uc_BC(i,j,k)=u_w_input(i,j,k) + enddo + enddo + enddo +! + endif +! +!----------------------------------------------------------------------- +! + end subroutine fill_BC_for_DA +! !----------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- @@ -2244,17 +2942,14 @@ subroutine compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) implicit none !----------------------------------------------------------------------- ! -!--------------------- -!*** Input variables -!--------------------- +!------------------------ +!*** Argument variables +!------------------------ ! integer,intent(in) :: i1,i2,j1,j2 ! - real,dimension(i1:i2,j1:j2,1:npz) :: cappa,temp,liq_wat,sphum -! -!---------------------- -!*** Output variables -!---------------------- + real,dimension(i1:i2,j1:j2,1:npz),intent(in) :: temp,liq_wat,sphum + real,dimension(i1:i2,j1:j2,1:npz),intent(inout) :: cappa ! !--------------------- !*** Local variables @@ -2287,7 +2982,7 @@ subroutine compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) ql=qd-qs qv=max(0.,sphum(i,j,k)) cvm=(1.-(qv+qd))*cv_air + qv*cv_vap + ql*c_liq + qs*c_ice - ! +! cappa(i,j,k)=rdgas/(rdgas+cvm/(1.+zvir*sphum(i,j,k))) ! enddo @@ -2364,7 +3059,7 @@ subroutine read_regional_bc_file(is_input,ie_input & ! character(len=80) :: var_name !<-- Variable name in the boundary NetCDF file ! - logical :: call_get_var + logical :: call_get_var,is_root_pe logical :: required_local ! !----------------------------------------------------------------------- @@ -2380,6 +3075,8 @@ subroutine read_regional_bc_file(is_input,ie_input & else required_local=.true. endif +! + is_root_pe=(mpp_pe()==mpp_root_pe()) ! !----------------------------------------------------------------------- !*** Loop through the four sides of the domain. @@ -2415,15 +3112,16 @@ subroutine read_regional_bc_file(is_input,ie_input & i_end_array =ie_input j_start_array=js_input if(trim(var_name_root)=='u_s'.or.trim(var_name_root)=='v_s')then - j_end_array=js_input+nhalo_data + j_end_array=js_input+nhalo_data+nrows_blend else - j_end_array=js_input+nhalo_data-1 + j_end_array=js_input+nhalo_data+nrows_blend-1 endif ! i_start_data=i_start_array+nhalo_data i_count=i_end_array-i_start_array+1 j_start_data=1 j_count=j_end_array-j_start_array+1 +! endif endif ! @@ -2439,13 +3137,14 @@ subroutine read_regional_bc_file(is_input,ie_input & ! i_start_array=is_input i_end_array =ie_input - j_start_array=je_input-nhalo_data+1 + j_start_array=je_input-nhalo_data-nrows_blend+1 j_end_array =je_input ! i_start_data=i_start_array+nhalo_data i_count=i_end_array-i_start_array+1 j_start_data=1 j_count=j_end_array-j_start_array+1 +! endif endif ! @@ -2465,9 +3164,9 @@ subroutine read_regional_bc_file(is_input,ie_input & i_start_array=is_input ! if(trim(var_name_root)=='u_w'.or.trim(var_name_root)=='v_w')then - i_end_array=is_input+nhalo_data + i_end_array=is_input+nhalo_data+nrows_blend else - i_end_array=is_input+nhalo_data-1 + i_end_array=is_input+nhalo_data+nrows_blend-1 endif ! if(north_bc)then @@ -2489,6 +3188,7 @@ subroutine read_regional_bc_file(is_input,ie_input & j_start_data=j_start_array endif j_count=j_end_array-j_start_array+1 +! endif endif ! @@ -2505,7 +3205,7 @@ subroutine read_regional_bc_file(is_input,ie_input & j_start_array=js_input j_end_array =je_input ! - i_start_array=ie_input-nhalo_data+1 + i_start_array=ie_input-nhalo_data-nrows_blend+1 i_end_array=ie_input ! if(north_bc)then @@ -2528,25 +3228,32 @@ subroutine read_regional_bc_file(is_input,ie_input & j_start_data=j_start_array endif j_count=j_end_array-j_start_array+1 +! endif endif ! !----------------------------------------------------------------------- !*** Fill this task's subset of boundary data for this 3-D -!*** or 4-D variable. If the variable is a tracer then -!*** check if it is present in the input data. If it is -!*** not then print a warning and set it to zero. +!*** or 4-D variable. This includes the data in the domain's +!*** halo region as well as the blending region that overlaps +!*** the outer nhalo_blend rows of the integration domain. +!*** If the variable is a tracer then check if it is present +!*** in the input data. If it is not then print a warning +!*** and set it to zero. !----------------------------------------------------------------------- ! if(call_get_var)then if (present(array_4d)) then !<-- 4-D variable - status=nf90_inq_varid(ncid,trim(var_name),var_id) + status=nf90_inq_varid(ncid,trim(var_name),var_id) !<-- Get this variable's ID. if (required_local) then call check(status) endif if (status /= nf90_noerr) then - if (east_bc) write(0,*)' WARNING: Tracer ',trim(var_name),' not in input file' + if (east_bc.and.is_master()) write(0,*)' WARNING: Tracer ',trim(var_name),' not in input file' array_4d(:,:,:,tlev)=0. !<-- Tracer not in input so set to zero in boundary. +! + blend_this_tracer(tlev)=.false. !<-- Tracer not in input so do not apply blending. +! else call check(nf90_get_var(ncid,var_id & ,array_4d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. @@ -2554,6 +3261,7 @@ subroutine read_regional_bc_file(is_input,ie_input & ,1:nlev, tlev) & ,start=(/i_start_data,j_start_data,1,tlev/) & !<-- Start reading the data array here. ,count=(/i_count,j_count,nlev,1/))) !<-- Extent of data to read in each dimension. +! endif ! else !<-- 3-D variable @@ -2564,6 +3272,7 @@ subroutine read_regional_bc_file(is_input,ie_input & ,1:nlev) & ,start=(/i_start_data,j_start_data,1/) & !<-- Start reading the data array here. ,count=(/i_count,j_count,nlev/))) !<-- Extent of data to read in each dimension. +! endif endif ! @@ -2582,10 +3291,9 @@ subroutine check(status) ! if(status /= nf90_noerr) then write(0,*)' check netcdf status=',status - write(0,10001)trim(nf90_strerror(status)) -10001 format(' NetCDF error ',a) - stop "Stopped" + call mpp_error(FATAL, ' NetCDF error ' // trim(nf90_strerror(status))) endif +! end subroutine check ! !----------------------------------------------------------------------- @@ -2600,7 +3308,8 @@ subroutine allocate_regional_BC_arrays(side & ,is_we,ie_we,js_we,je_we & ,klev & ,ntracers & - ,BC_side ) + ,BC_side & + ,delz_side ) ! !----------------------------------------------------------------------- implicit none @@ -2621,6 +3330,8 @@ subroutine allocate_regional_BC_arrays(side & logical,intent(in) :: north_bc,south_bc,east_bc,west_bc !<-- Which sides is this task on? ! type(fv_regional_BC_variables),intent(out) :: BC_side +! + real,dimension(:,:,:),pointer,intent(inout),optional :: delz_side !<-- Boundary delz that follows integration through time. ! !--------------------------------------------------------------------- !********************************************************************* @@ -2634,11 +3345,21 @@ subroutine allocate_regional_BC_arrays(side & allocate(BC_side%divgd_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%divgd_BC=real_snan ! allocate(BC_side%q_BC (is_0:ie_0,js_0:je_0,1:klev,1:ntracers)) ; BC_side%q_BC=real_snan +! + if(.not.allocated(blend_this_tracer))then + allocate(blend_this_tracer(1:ntracers)) + blend_this_tracer=.true. !<-- Start with blending all tracers. + endif ! #ifndef SW_DYNAMICS allocate(BC_side%pt_BC (is_0:ie_0,js_0:je_0,klev)) ; BC_side%pt_BC=real_snan allocate(BC_side%w_BC (is_0:ie_0,js_0:je_0,klev)) ; BC_side%w_BC=real_snan allocate(BC_side%delz_BC (is_0:ie_0,js_0:je_0,klev)) ; BC_side%delz_BC=real_snan + if(present(delz_side))then + if(.not.associated(delz_side))then + allocate(delz_side (is_0:ie_0,js_0:je_0,klev)) ; delz_side=real_snan + endif + endif #ifdef USE_COND allocate(BC_side%q_con_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%q_con_BC=real_snan #ifdef MOIST_CAPPA @@ -2691,7 +3412,6 @@ subroutine remap_scalar_nggps_regional_bc(Atm & real, intent(in), dimension(is_bc:ie_bc,js_bc:je_bc,km):: omga real, intent(in), dimension(is_bc:ie_bc,js_bc:je_bc,km,ncnst):: qa real, intent(in), dimension(is_bc:ie_bc,js_bc:je_bc,km+1):: zh -!xreal, intent(in), dimension(isd-1:ied+1,jsd-1:jed+1):: phis_reg !<-- Filtered sfc geopotential from preprocessing. real, intent(inout), dimension(isd-1:ied+1,jsd-1:jed+1):: phis_reg !<-- Filtered sfc geopotential from preprocessing. real, intent(out),dimension(is_bc:ie_bc,js_bc:je_bc) :: ps !<-- sfc p in regional domain boundary region character(len=5),intent(in) :: side @@ -2720,14 +3440,14 @@ subroutine remap_scalar_nggps_regional_bc(Atm & ! !--------------------------------------------------------------------------------- ! - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') - cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') - o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') + sphum = sphum_index + liq_wat = liq_water_index + ice_wat = ice_water_index + rainwat = rain_water_index + snowwat = snow_water_index + graupel = graupel_index + cld_amt = cld_amt_index + o3mr = o3mr_index k2 = max(10, km/2) @@ -2736,6 +3456,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm & print *, 'clwmr = ', liq_wat print *, ' o3mr = ', o3mr print *, 'ncnst = ', ncnst + print *, 'ntracers = ', ntracers endif if ( sphum/=1 ) then @@ -2749,22 +3470,22 @@ subroutine remap_scalar_nggps_regional_bc(Atm & ! is=is_bc if(side=='west')then - is=ie_bc-nhalo_data+1 + is=ie_bc-nhalo_data-nrows_blend+1 endif ! ie=ie_bc if(side=='east')then - ie=is_bc+nhalo_data-1 + ie=is_bc+nhalo_data+nrows_blend-1 endif ! js=js_bc if(side=='south')then - js=je_bc-nhalo_data+1 + js=je_bc-nhalo_data-nrows_blend+1 endif ! je=je_bc if(side=='north')then - je=js_bc+nhalo_data-1 + je=js_bc+nhalo_data+nrows_blend-1 endif ! allocate(pe0(is:ie,km+1)) ; pe0=real_snan @@ -2828,7 +3549,8 @@ subroutine remap_scalar_nggps_regional_bc(Atm & enddo ! !--------------------------------------------------------------------------------- -!*** Now compute over the normal boundary regions with halo=nhalo_model. +!*** Now compute over the normal boundary regions with halo=nhalo_model +!*** extended through nrows_blend rows into the integration domain. !*** Use the dimensions of one of the permanent BC variables in Atm !*** as the loop limits so any side of the domain can be addressed. !--------------------------------------------------------------------------------- @@ -2890,8 +3612,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm & BC_side%q_BC(i,j,k,iq) = qn1(i,k) enddo enddo -!jaa endif ! for remapping only the tracers included in the data that is read in - endif ! skip cld_amt in the remap since it is not included in the input + endif enddo !--------------------------------------------------- @@ -2971,7 +3692,7 @@ subroutine remap_scalar_nggps_regional_bc(Atm & enddo i_loop !----------------------------------------------------------------------- -! seperate cloud water and cloud ice +! separate cloud water and cloud ice ! From Jan-Huey Chen's HiRAM code !----------------------------------------------------------------------- ! @@ -3077,22 +3798,22 @@ subroutine remap_scalar_nggps_regional_bc(Atm & enddo jloop2 ! Add some diagnostics: -!xxxcall p_maxmin('PS_model (mb)', Atm%ps(is:ie,js:je), is, ie, js, je, 1, 0.01) -!xxxcall p_maxmin('PT_model', Atm%pt(is:ie,js:je,1:npz), is, ie, js, je, npz, 1.) +! call p_maxmin('PS_model (mb)', Atm%ps(is:ie,js:je), is, ie, js, je, 1, 0.01) +! call p_maxmin('PT_model', Atm%pt(is:ie,js:je,1:npz), is, ie, js, je, npz, 1.) do j=js,je do i=is,ie wk(i,j) = phis_reg(i,j)/grav - zh(i,j,km+1) enddo enddo -!xxxcall pmaxmn('ZS_diff (m)', wk, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) +! call pmaxmn('ZS_diff (m)', wk, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) do j=js,je do i=is,ie wk(i,j) = ps(i,j) - psc(i,j) enddo enddo -!xxxcall pmaxmn('PS_diff (mb)', wk, is, ie, js, je, 1, 0.01, Atm%gridstruct%area_64, Atm%domain) - deallocate (pe0,qn1,dp2,pe1,qp) +! call pmaxmn('PS_diff (mb)', wk, is, ie, js, je, 1, 0.01, Atm%gridstruct%area_64, Atm%domain) + deallocate (pe0,qn1,dp2,pe1,qp) if (is_master()) write(*,*) 'done remap_scalar_nggps_regional_bc' !--------------------------------------------------------------------- @@ -3230,14 +3951,15 @@ subroutine set_regional_BCs(delp,delz,w,pt & #endif ,q & ,u,v,uc,vc & - ,bd, nlayers & + ,bd, nlayers & ,fcst_time ) ! !--------------------------------------------------------------------- -!*** Select the given variable's boundary data at the two +!*** Select the boundary variables' boundary data at the two !*** bracketing time levels and apply them to the updating -!*** of the variable's boundary region at the appropriate -!*** forecast time. +!*** of the variables' boundary regions at the appropriate +!*** forecast time. This is done at the beginning of every +!*** large timestep in fv_dynamics. !--------------------------------------------------------------------- implicit none !--------------------------------------------------------------------- @@ -3260,7 +3982,8 @@ subroutine set_regional_BCs(delp,delz,w,pt & delp & ,pt ! - real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: delz,w + real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: w + real,dimension(bd%is:,bd%js:,1:),intent(out) :: delz #ifdef USE_COND real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: q_con #endif @@ -3404,6 +4127,8 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & ! integer :: i,ie,j,je,jend,jend_uvs,jend_uvw & ,jstart,jstart_uvs,jstart_uvw,k,nt,nz +! + real,dimension(:,:,:),pointer :: delz_ptr ! !--------------------------------------------------------------------- !********************************************************************* @@ -3425,6 +4150,17 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & jend_uvs=j2_uvs+nhalo_model jend_uvw=j2_uvw+nhalo_model endif +! + select case (trim(side)) + case ('north') + delz_ptr=>delz_auxiliary%north + case ('south') + delz_ptr=>delz_auxiliary%south + case ('east') + delz_ptr=>delz_auxiliary%east + case ('west') + delz_ptr=>delz_auxiliary%west + end select ! do k=1,nlayers do j=jstart,jend @@ -3435,11 +4171,25 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & pt(i,j,k)=side_t0%pt_BC(i,j,k) & +(side_t1%pt_BC(i,j,k)-side_t0%pt_BC(i,j,k)) & *fraction_interval +! delz(i,j,k)=side_t0%delz_BC(i,j,k) & +! +(side_t1%delz_BC(i,j,k)-side_t0%delz_BC(i,j,k)) & +! *fraction_interval + delz_ptr(i,j,k)=side_t0%delz_BC(i,j,k) & + +(side_t1%delz_BC(i,j,k)-side_t0%delz_BC(i,j,k)) & + *fraction_interval #ifdef MOIST_CAPPA cappa(i,j,k)=side_t0%cappa_BC(i,j,k) & +(side_t1%cappa_BC(i,j,k)-side_t0%cappa_BC(i,j,k)) & *fraction_interval #endif +#ifdef USE_COND + q_con(i,j,k)=side_t0%q_con_BC(i,j,k) & + +(side_t1%q_con_BC(i,j,k)-side_t0%q_con_BC(i,j,k)) & + *fraction_interval +#endif + w(i,j,k)=side_t0%w_BC(i,j,k) & + +(side_t1%w_BC(i,j,k)-side_t0%w_BC(i,j,k)) & + *fraction_interval enddo enddo ! @@ -3466,27 +4216,9 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & enddo enddo ! - ie=min(ubound(side_t0%delz_BC,1),ubound(delz,1)) - je=min(ubound(side_t0%delz_BC,2),ubound(delz,2)) - nz=ubound(delz,3) -! - do k=1,nz - do j=jstart,jend - do i=i1,ie - delz(i,j,k)=side_t0%delz_BC(i,j,k) & - +(side_t1%delz_BC(i,j,k)-side_t0%delz_BC(i,j,k)) & - *fraction_interval -#ifdef USE_COND - q_con(i,j,k)=side_t0%q_con_BC(i,j,k) & - +(side_t1%q_con_BC(i,j,k)-side_t0%q_con_BC(i,j,k)) & - *fraction_interval -#endif - w(i,j,k)=side_t0%w_BC(i,j,k) & - +(side_t1%w_BC(i,j,k)-side_t0%w_BC(i,j,k)) & - *fraction_interval - enddo - enddo - enddo + ie=min(ubound(side_t0%w_BC,1),ubound(w,1)) + je=min(ubound(side_t0%w_BC,2),ubound(w,2)) + nz=ubound(w,3) ! do nt=1,ntracers do k=1,nz @@ -3557,13 +4289,15 @@ subroutine regional_boundary_update(array & !--------------------- ! integer :: i1,i2,j1,j2 !<-- Horizontal limits of region updated. + integer :: i_bc,j_bc !<-- Innermost bndry index (anchor point for blending) + integer :: i1_blend,i2_blend,j1_blend,j2_blend !<-- Limits of updated blending region. integer :: lbnd1,ubnd1,lbnd2,ubnd2 !<-- Horizontal limits of BC update arrays. integer :: iq !<-- Tracer index integer :: nside ! real,dimension(:,:,:),pointer :: bc_t0,bc_t1 !<-- Boundary data at the two bracketing times. ! - logical :: call_interp + logical :: blend,call_interp ! !--------------------------------------------------------------------- !********************************************************************* @@ -3573,9 +4307,11 @@ subroutine regional_boundary_update(array & return endif ! + blend=.true. iq=0 if(present(index4))then iq=index4 + blend=blend_this_tracer(iq) endif ! !--------------------------------------------------------------------- @@ -3607,6 +4343,17 @@ subroutine regional_boundary_update(array & ! j1=jsd j2=js-1 +! + i1_blend=is + i2_blend=ie + if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v')then + i2_blend=ie+1 + endif + j1_blend=js + j2_blend=js+nrows_blend_user-1 + i_bc=-9e9 + j_bc=j2 +! endif endif ! @@ -3632,6 +4379,20 @@ subroutine regional_boundary_update(array & j1=je+2 j2=jed+1 endif +! + i1_blend=is + i2_blend=ie + if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v')then + i2_blend=ie+1 + endif + j2_blend=je + if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc')then + j2_blend=je+1 + endif + j1_blend=j2_blend-nrows_blend_user+1 + i_bc=-9e9 + j_bc=j1 +! endif endif ! @@ -3660,6 +4421,23 @@ subroutine regional_boundary_update(array & j2=je+1 endif endif +! + i1_blend=is + i2_blend=is+nrows_blend_user-1 + j1_blend=js + j2_blend=je + if(north_bc)then + j1_blend=js+nrows_blend_user !<-- North BC already handles nrows_blend_user blending rows + endif + if(south_bc)then + j2_blend=je-nrows_blend_user !<-- South BC already handles nrows_blend_user blending rows + endif + if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc')then + j2_blend=j2_blend+1 + endif + i_bc=i2 + j_bc=-9e9 +! endif endif ! @@ -3692,6 +4470,23 @@ subroutine regional_boundary_update(array & j2=je+1 endif endif +! + i1_blend=i1-nrows_blend_user + i2_blend=i1-1 + j1_blend=js + j2_blend=je + if(north_bc)then + j1_blend=js+nrows_blend_user !<-- North BC already handled nrows_blend_user blending rows. + endif + if(south_bc)then + j2_blend=je-nrows_blend_user !<-- South BC already handled nrows_blend_user blending rows. + endif + if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc')then + j2_blend=j2_blend+1 + endif + i_bc=i1 + j_bc=-9e9 +! endif endif ! @@ -3714,16 +4509,19 @@ subroutine regional_boundary_update(array & ,bc_t0,bc_t1 & ,lbnd1,ubnd1,lbnd2,ubnd2 & ,i1,i2,j1,j2 & + ,is,ie,js,je & ,fcst_time & - ,bc_update_interval ) + ,bc_update_interval & + ,i1_blend,i2_blend,j1_blend,j2_blend & + ,i_bc,j_bc,nside,bc_vbl_name,blend ) endif ! !--------------------------------------------------------------------- +! enddo sides -!--------------------------------------------------------------------- ! !--------------------------------------------------------------------- - +! end subroutine regional_boundary_update !--------------------------------------------------------------------- @@ -3795,8 +4593,7 @@ subroutine retrieve_bc_variable_data(bc_vbl_name & #endif case ('q') if(iq<1)then - write(0,101) - 101 format(' iq<1 is not a valid index for q_BC array in retrieve_bc_variable_data') + call mpp_error(FATAL,' iq<1 is not a valid index for q_BC array in retrieve_bc_variable_data') endif lbnd1=lbound(bc_side_t0%q_BC,1) lbnd2=lbound(bc_side_t0%q_BC,2) @@ -3834,16 +4631,19 @@ end subroutine retrieve_bc_variable_data !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- ! - subroutine bc_time_interpolation(array & - ,lbnd_x, ubnd_x & - ,lbnd_y, ubnd_y & - ,ubnd_z & - ,bc_t0, bc_t1 & - ,lbnd1, ubnd1 & - ,lbnd2, ubnd2 & - ,i1,i2,j1,j2 & - ,fcst_time & - ,bc_update_interval ) + subroutine bc_time_interpolation(array & + ,lbnd_x, ubnd_x & + ,lbnd_y, ubnd_y & + ,ubnd_z & + ,bc_t0, bc_t1 & + ,lbnd1, ubnd1 & + ,lbnd2, ubnd2 & + ,i1,i2,j1,j2 & + ,is,ie,js,je & + ,fcst_time & + ,bc_update_interval & + ,i1_blend,i2_blend,j1_blend,j2_blend & + ,i_bc,j_bc,nside,bc_vbl_name,blend ) !--------------------------------------------------------------------- !*** Update the boundary region of the input array at the given @@ -3861,14 +4661,23 @@ subroutine bc_time_interpolation(array & ! integer,intent(in) :: lbnd1,ubnd1,lbnd2,ubnd2 !<-- Index limits of the BC arrays. ! - integer,intent(in) :: i1,i2,j1,j2 !<-- Index limits of the updated region. + integer,intent(in) :: i1,i2,j1,j2 & !<-- Index limits of the updated boundary region. + ,i_bc,j_bc & !<-- Innermost bndry indices (anchor pts for blending) + ,i1_blend,i2_blend,j1_blend,j2_blend & !<-- Index limits of the updated blending region. + ,nside +! + integer,intent(in) :: is,ie,js,je !<-- Min/Max index limits on task's computational subdomain ! integer,intent(in) :: bc_update_interval !<-- Time (hours) between BC data states ! real,intent(in) :: fcst_time !<-- Current forecast time (sec) ! - real,dimension(lbnd1:ubnd1,lbnd2:ubnd2,1:ubnd_z) :: bc_t0 & !<-- Interpolate between these - ,bc_t1 ! two boundary region states. + real,dimension(lbnd1:ubnd1,lbnd2:ubnd2,1:ubnd_z),intent(in) :: bc_t0 & !<-- Interpolate between these + ,bc_t1 ! two boundary region states. +! + character(len=*),intent(in) :: bc_vbl_name +! + logical,intent(in) :: blend !<-- Can blending be applied to this variable? ! !--------------------- !*** Output variables @@ -3883,7 +4692,7 @@ subroutine bc_time_interpolation(array & ! integer :: i,j,k ! - real :: fraction_interval + real :: blend_value,factor_dist,fraction_interval,rdenom ! !--------------------------------------------------------------------- !********************************************************************* @@ -3909,144 +4718,103 @@ subroutine bc_time_interpolation(array & enddo ! !--------------------------------------------------------------------- - - end subroutine bc_time_interpolation -!--------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!*** If this tracer is not in the external BC file then it will not +!*** be blended. !--------------------------------------------------------------------- ! - subroutine bc_time_interpolation_general(is,ie,js,je & - ,is_s,ie_s,js_s,je_s & - ,is_w,ie_w,js_w,je_w & - ,fraction & - ,t0,t1 & - ,Atm ) + if(.not.blend)then + return + endif ! !--------------------------------------------------------------------- -!*** Execute the linear time interpolation between t0 and t1 -!*** generically for any side of the regional domain's boundary -!*** region. +!*** Use specified external data to blend with integration values +!*** across nrows_blend rows immediately within the domain's +!*** boundary rows. The weighting of the external data drops +!*** off exponentially. !--------------------------------------------------------------------- - implicit none -!--------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ ! - integer,intent(in) :: is,ie,js,je & !<-- Index limits for centers of grid cells - ,is_s,ie_s,js_s,je_s & !<-- Index limits for south/north edges of grid cells - ,is_w,ie_w,js_w,je_w !<-- Index limits for west/east edges of grid cells +!----------- +!*** North +!----------- ! - real,intent(in) :: fraction !<-- Current time is this fraction between t0 ad t1. + if(nside==1.and.north_bc)then + rdenom=1./real(j2_blend-j_bc-1) + do k=1,ubnd_z + do j=j1_blend,j2_blend + factor_dist=exp(-(blend_exp1+blend_exp2*(j-j_bc-1)*rdenom)) !<-- Exponential falloff of blending weights. + do i=i1_blend,i2_blend + blend_value=bc_t0(i,j,k) & !<-- Blend data interpolated + +(bc_t1(i,j,k)-bc_t0(i,j,k))*fraction_interval ! between t0 and t1. ! - type(fv_regional_BC_variables),intent(in) :: t0,t1 !<-- BC variables at time levels t0 and t1. + array(i,j,k)=(1.-factor_dist)*array(i,j,k)+factor_dist*blend_value + enddo + enddo + enddo + endif ! - type(fv_atmos_type),intent(inout) :: Atm !<-- The Atm object +!----------- +!*** South +!----------- ! -!--------------------- -!*** Local variables -!--------------------- -! - integer :: i,j,k,n,nlayers!,ntracers -! -!--------------------------------------------------------------------- -!********************************************************************* -!--------------------------------------------------------------------- -! - nlayers =Atm%npz !<-- # of layers in vertical configuration of integration -! ntracers=Atm%ncnst !<-- # of advected tracers -! -!--------------------------------------------------------------------- -! - k_loop: do k=1,nlayers -! -!--------------------------------------------------------------------- -! -!------------- -!*** Scalars -!------------- -! - do j=js,je - do i=is,ie -! - Atm%delp(i,j,k)=t0%delp_BC(i,j,k) & !<-- Update layer pressure thickness. - +(t1%delp_BC(i,j,k)-t0%delp_BC(i,j,k)) & - *fraction -! -#ifndef SW_DYNAMICS - Atm%delz(i,j,k)=t0%delz_BC(i,j,k) & !<-- Update layer height thickness. - +(t1%delz_BC(i,j,k)-t0%delz_BC(i,j,k)) & - *fraction + if(nside==2.and.south_bc)then + rdenom=1./real(j_bc-j1_blend-1) + do k=1,ubnd_z + do j=j1_blend,j2_blend + factor_dist=exp(-(blend_exp1+blend_exp2*(j_bc-j-1)*rdenom)) !<-- Exponential falloff of blending weights. + do i=i1_blend,i2_blend + blend_value=bc_t0(i,j,k) & !<-- Blend data interpolated + +(bc_t1(i,j,k)-bc_t0(i,j,k))*fraction_interval ! between t0 and t1. + array(i,j,k)=(1.-factor_dist)*array(i,j,k)+factor_dist*blend_value + enddo + enddo + enddo + endif ! - Atm%w(i,j,k)=t0%w_BC(i,j,k) & !<-- Update vertical motion. - +(t1%w_BC(i,j,k)-t0%w_BC(i,j,k)) & - *fraction +!---------- +!*** East +!---------- ! - Atm%pt(i,j,k)=t0%pt_BC(i,j,k) & !<-- Update thetav. - +(t1%pt_BC(i,j,k)-t0%pt_BC(i,j,k)) & - *fraction -#ifdef USE_COND - Atm%q_con(i,j,k)=t0%q_con_BC(i,j,k) & !<-- Update water condensate. - +(t1%q_con_BC(i,j,k)-t0%q_con_BC(i,j,k)) & - *fraction -#ifdef MOIST_CAPPA -! Atm%cappa(i,j,k)=t0%pt_BC(i,j,k) & !<-- Update cappa. -! +(t1%cappa_BC(i,j,k)-t0%cappa_BC(i,j,k)) & -! *fraction -#endif -#endif -#endif + if(nside==3.and.east_bc)then + rdenom=1./real(i2_blend-i_bc-1) + do k=1,ubnd_z + do j=j1_blend,j2_blend + do i=i1_blend,i2_blend ! - enddo - enddo + blend_value=bc_t0(i,j,k) & !<-- Blend data interpolated + +(bc_t1(i,j,k)-bc_t0(i,j,k))*fraction_interval ! between t0 and t1. ! - do n=1,ntracers + factor_dist=exp(-(blend_exp1+blend_exp2*(i-i_bc-1)*rdenom)) !<-- Exponential falloff of blending weights. ! - do j=js,je - do i=is,ie - Atm%q(i,j,k,n)=t0%q_BC(i,j,k,n) & !<-- Update tracers. - +(t1%q_BC(i,j,k,n)-t0%q_BC(i,j,k,n)) & - *fraction - enddo + array(i,j,k)=(1.-factor_dist)*array(i,j,k)+factor_dist*blend_value + enddo enddo -! enddo + endif ! -!----------- -!*** Winds -!----------- -! - do j=js_s,je_s - do i=is_s,ie_s - Atm%u(i,j,k)=t0%u_BC(i,j,k) & !<-- Update D-grid u component. - +(t1%u_BC(i,j,k)-t0%u_BC(i,j,k)) & - *fraction - Atm%vc(i,j,k)=t0%vc_BC(i,j,k) & !<-- Update C-grid v component. - +(t1%vc_BC(i,j,k)-t0%vc_BC(i,j,k)) & - *fraction - enddo - enddo +!---------- +!*** West +!---------- ! + if(nside==4.and.west_bc)then + rdenom=1./real(i_bc-i1_blend-1) + do k=1,ubnd_z + do j=j1_blend,j2_blend + do i=i1_blend,i2_blend ! - do j=js_w,je_w - do i=is_w,ie_w - Atm%v(i,j,k)=t0%v_BC(i,j,k) & !<-- Update D-grid v component. - +(t1%v_BC(i,j,k)-t0%v_BC(i,j,k)) & - *fraction - Atm%uc(i,j,k)=t0%uc_BC(i,j,k) & !<-- Update C-grid u component. - +(t1%uc_BC(i,j,k)-t0%uc_BC(i,j,k)) & - *fraction - enddo - enddo + blend_value=bc_t0(i,j,k) & !<-- Blend data interpolated + +(bc_t1(i,j,k)-bc_t0(i,j,k))*fraction_interval ! between t0 and t1. ! -!--------------------------------------------------------------------- + factor_dist=exp(-(blend_exp1+blend_exp2*(i_bc-i-1)*rdenom)) !<-- Exponential falloff of blending weights. ! - enddo k_loop + array(i,j,k)=(1.-factor_dist)*array(i,j,k)+factor_dist*blend_value + enddo + enddo + enddo + endif ! !--------------------------------------------------------------------- ! - end subroutine bc_time_interpolation_general + end subroutine bc_time_interpolation ! !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -4258,8 +5026,7 @@ end subroutine regional_bc_t1_to_t0 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- ! - subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & - ,sphum,liq_wat ) + subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) ! !----------------------------------------------------------------------- !*** Convert the incoming sensible temperature to virtual potential @@ -4268,13 +5035,11 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & implicit none !----------------------------------------------------------------------- ! -!--------------------- -!*** Input arguments -!--------------------- +!------------------------ +!*** Argument variables +!------------------------ ! integer,intent(in) :: isd,ied,jsd,jed,npz -! - integer,intent(in) :: liq_wat,sphum ! !--------------------- !*** Local variables @@ -4404,11 +5169,11 @@ subroutine compute_vpt ! do j=j1,j2 do i=i1,i2 - dp1 = zvir*q(i,j,k,sphum) + dp1 = zvir*q(i,j,k,sphum_index) #ifdef USE_COND #ifdef MOIST_CAPPA - cvm=(1.-q(i,j,k,sphum)+q_con(i,j,k))*cv_air & - +q(i,j,k,sphum)*cv_vap+q(i,j,k,liq_wat)*c_liq + cvm=(1.-q(i,j,k,sphum_index)+q_con(i,j,k))*cv_air & + +q(i,j,k,sphum_index)*cv_vap+q(i,j,k,liq_water_index)*c_liq pkz=exp(cappa(i,j,k)*log(rdg*delp(i,j,k)*pt(i,j,k) & *(1.+dp1)*(1.-q_con(i,j,k))/delz(i,j,k))) #else @@ -4775,6 +5540,14 @@ end subroutine nudge_qv_bc subroutine dump_field_3d (domain, name, field, isd, ied, jsd, jed, nlev, stag) +!----------------------------------------------------------------------- +!*** Subroutines dump_field_2d and dump_field_3d are module +!*** procedures with the generic interface 'dump_field'. +!*** Use these routines to write out NetCDF files containing +!*** FULL fields that include the variables' boundary region. +!*** See the following four examples for guidance on how to +!*** call the routines. +!----------------------------------------------------------------------- ! call dump_field(Atm(1)%domain,"atm_pt", Atm(1)%pt, isd, ied, jsd, jed, Atm(1)%npz, stag=H_STAGGER) ! call dump_field(Atm(1)%domain,"atm_u", Atm(1)%u, isd, ied, jsd, jed+1, Atm(1)%npz, stag=U_STAGGER) ! call dump_field(Atm(1)%domain,"atm_v", Atm(1)%v, isd, ied+1, jsd, jed, Atm(1)%npz, stag=V_STAGGER) @@ -4849,7 +5622,7 @@ subroutine dump_field_3d (domain, name, field, isd, ied, jsd, jed, nlev, stag) call mpp_gather(isection_s,isection_e,jsection_s,jsection_e, nz, & pelist, field(isection_s:isection_e,jsection_s:jsection_e,:), glob_field, is_root_pe, halo, halo) - call mpp_open( unit, trim(fname), action=MPP_WRONLY, form=MPP_NETCDF, threading=MPP_SINGLE) + call mpp_open( unit, trim(fname), action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_SINGLE) call mpp_write_meta( unit, x, 'grid_xt', 'km', 'X distance', 'X', domain=xdom, data=(/(i*1.0,i=1,nxg)/) ) call mpp_write_meta( unit, y, 'grid_yt', 'km', 'Y distance', 'Y', domain=ydom, data=(/(j*1.0,j=1,nyg)/) ) @@ -4901,7 +5674,7 @@ subroutine dump_field_2d (domain, name, field, isd, ied, jsd, jed, stag) integer :: isection_s, isection_e, jsection_s, jsection_e write(fname,"(A,A,A,I1.1,A)") "regional_",name,".tile", 7 , ".nc" -! write(0,*)'dump_field_3d: file name = |', trim(fname) , '|' + write(0,*)'dump_field_3d: file name = |', trim(fname) , '|' call mpp_get_domain_components( domain, xdom, ydom ) call mpp_get_compute_domain( domain, is, ie, js, je ) @@ -4947,7 +5720,7 @@ subroutine dump_field_2d (domain, name, field, isd, ied, jsd, jed, stag) call mpp_gather(isection_s,isection_e,jsection_s,jsection_e, & pelist, field(isection_s:isection_e,jsection_s:jsection_e), glob_field, is_root_pe, halo, halo) - call mpp_open( unit, trim(fname), action=MPP_WRONLY, form=MPP_NETCDF, threading=MPP_SINGLE) + call mpp_open( unit, trim(fname), action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_SINGLE) call mpp_write_meta( unit, x, 'grid_xt', 'km', 'X distance', 'X', domain=xdom, data=(/(i*1.0,i=1,nxg)/) ) call mpp_write_meta( unit, y, 'grid_yt', 'km', 'Y distance', 'Y', domain=ydom, data=(/(j*1.0,j=1,nyg)/) ) @@ -4974,6 +5747,669 @@ subroutine dump_field_2d (domain, name, field, isd, ied, jsd, jed, stag) end subroutine dump_field_2d +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + subroutine prepare_full_fields(Atm) +! +!----------------------------------------------------------------------- +!*** Prepare the objects that will hold the names and values of +!*** the core and tracer fields to be written into the expanded +!*** restart files that include the boundary rows so the GSI +!*** can update both the interior and BCs. +!----------------------------------------------------------------------- +! +!------------------------ +!*** Argument variables +!------------------------ +! + type(fv_atmos_type),target,intent(inout) :: Atm !<-- Atm object for the current domain +! +!--------------------- +!*** Local variables +!--------------------- +! + integer :: index,istat,n & + ,ncid_core_new & + ,ncid_tracers_new & + ,ndims,nkount,nv_core,nv_tracers & + ,var_id +! + integer :: lbnd1,lbnd2,lbnd3,ubnd1,ubnd2,ubnd3 +! + integer,dimension(ndims_core) :: dim_lengths_core +! + integer,dimension(ndims_tracers) :: dim_lengths_tracers +! + integer,dimension(1:4) :: dimids=(/0,0,0,0/) +! + real,dimension(:),allocatable :: dim_values +! + character(len=50) :: att_name,var_name +! + character(len=9),dimension(ndims_core) :: dim_names_core=(/ & + 'xaxis_1' & + ,'xaxis_2' & + ,'yaxis_1' & + ,'yaxis_2' & + ,'zaxis_1' & + ,'Time ' & + /) +! + character(len=9),dimension(ndims_tracers) :: dim_names_tracers=(/ & + 'xaxis_1' & + ,'yaxis_1' & + ,'zaxis_1' & + ,'Time ' & + /) +! +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +!*** The first file to be handled is the core restart file. +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +!*** All tasks are given pointers into the model data that will +!*** be written to the new restart file. The following are the +!*** prognostic variables in the core restart file. Note that +!*** we must add the halo region back into DZ since we need the +!*** domain boundary points for all the fields. +!----------------------------------------------------------------------- +! + allocate(fields_core(1:nvars_core)) +! + fields_core(1)%ptr=>Atm%u + fields_core(1)%name='u' +! + fields_core(2)%ptr=>Atm%v + fields_core(2)%name='v' +! + fields_core(3)%ptr=>Atm%w + fields_core(3)%name='W' +! + lbnd1=lbound(Atm%delz,1) + ubnd1=ubound(Atm%delz,1) + lbnd2=lbound(Atm%delz,2) + ubnd2=ubound(Atm%delz,2) + lbnd3=1 + ubnd3=ubound(Atm%delz,3) + allocate(fields_core(4)%ptr(lbnd1-nhalo_model:ubnd1+nhalo_model & + ,lbnd2-nhalo_model:ubnd2+nhalo_model & + ,lbnd3:ubnd3)) + fields_core(4)%name='DZ' +! + fields_core(5)%ptr=>Atm%pt + fields_core(5)%name='T' +! + fields_core(6)%ptr=>Atm%delp + fields_core(6)%name='delp' +! + allocate(fields_core(7)%ptr(lbound(Atm%phis,1):ubound(Atm%phis,1) & + ,lbound(Atm%phis,2):ubound(Atm%phis,2) & + ,1:1)) + fields_core(7)%ptr(:,:,1)=Atm%phis(:,:) !<-- For generality treat the 2-D phis as 3-D + fields_core(7)%name='phis' +! +!----------------------------------------------------------------------- +!*** We need to point at the tracers in the model's tracer array. +!*** Those tracers depend on the physics that was selected so they +!*** cannot be pre-specified like the variables in the core restart +!*** file were. Read them from the expanded tracer restart file +!*** that was created prior to the start for the forecast. +!----------------------------------------------------------------------- +! + call check(nf90_open(path=filename_tracers_new & !<-- The expanded tracer restart file. + ,mode=nf90_nowrite & !<-- File access. + ,ncid=ncid_tracers_new )) !<-- The expanded tracer restart file's ID +! + call check(nf90_inquire(ncid =ncid_tracers_new & !<-- The expanded tracer restart file's ID. + ,nvariables=nv_tracers )) !<-- The TOTAL number of tracer restart file variables. +! + nfields_tracers=nv_tracers-ndims_tracers !<-- # of 3-D tracer fields + allocate(fields_tracers(1:nfields_tracers),stat=istat) + if(istat/=0)then + call mpp_error(FATAL,' Failed to allocate fields_tracers.') + else + if(is_master())then + write(0,33012)nfields_tracers +33012 format(' Allocated fields_tracers(1:',i3,')') + endif + endif + nkount=0 +! + do n=1,nv_tracers + var_id=n + call check(nf90_inquire_variable(ncid =ncid_tracers_new & !<-- The file's ID. + ,varid=var_id & !<-- The variable's ID. + ,name =var_name )) !<-- The variable's name. +! + if(n>ndims_tracers)then + nkount=nkount+1 + fields_tracers(nkount)%name=trim(var_name) + index=get_tracer_index(MODEL_ATMOS, trim(var_name)) + fields_tracers(nkount)%ptr=>Atm%q(:,:,:, index) + endif +! + enddo +! +!----------------------------------------------------------------------- +! + call check(nf90_close(ncid_tracers_new)) +! +!----------------------------------------------------------------------- +! + end subroutine prepare_full_fields +! +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + subroutine write_full_fields(Atm) +! +!----------------------------------------------------------------------- +!*** Write out full fields of the primary restart variables +!*** INCLUDING BOUNDARY ROWS so the GSI can include BCs in its +!*** update. This is done in a restart look-alike file. +!----------------------------------------------------------------------- +! + type(fv_atmos_type), intent(inout), target :: Atm +! + integer :: count_i,count_j + integer :: iend,istart,jend,jstart,kend,kstart,nz + integer :: iend_ptr,istart_ptr,jend_ptr,jstart_ptr + integer :: iend_g,istart_g,jend_g,jstart_g + integer :: ieg,iext,isg,jeg,jext,jsg,k + integer :: n,ncid_core_new,ncid_tracers_new,nv,var_id + integer :: halo +! + integer,dimension(:),allocatable :: pelist +! + real,dimension(:,:,:),allocatable :: global_field + real,dimension(:,:,:),pointer :: field_3d +! + character(len=10) :: var_name +! + logical :: is_root_pe +! +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! + allocate( pelist(mpp_npes()) ) + call mpp_get_current_pelist(pelist) +! write(0,*)' pelist=',pelist +! + halo=nhalo_model +! + is_root_pe = (mpp_pe()==mpp_root_pe()) + if(is_root_pe)then + call check(nf90_open(filename_core_new,nf90_write,ncid_core_new)) !<-- Open the new netcdf file + write(0,*)' Opened core restart with BCs: ',trim(filename_core_new) + endif +! +!----------------------------------------------------------------------- +!*** Save the global limits of the domain and its vertical extent. +!----------------------------------------------------------------------- +! + call mpp_get_global_domain (Atm%domain, isg, ieg, jsg, jeg, position=CENTER ) +! +!----------------------------------------------------------------------- +!*** Begin with the core restart file. +!*** Loop through that file's prognostic variables. +!----------------------------------------------------------------------- +! + vbls_core: do nv=1,nvars_core +! + var_name=fields_core(nv)%name + if(is_root_pe)then + call check(nf90_inq_varid(ncid_core_new,var_name,var_id)) !<-- Get this variable's ID + endif +! +!----------------------------------------------------------------------- +!*** What is the full domain extent of this variable including +!*** boundary rows? +!----------------------------------------------------------------------- +! + iext=0 + jext=0 + if(var_name=='u'.or.var_name=='vc')then + jext=1 + endif + if(var_name=='v'.or.var_name=='uc')then + iext=1 + endif +! + call mpp_get_global_domain (atm%domain, isg, ieg, jsg, jeg, position=CENTER ) + istart_g=isg-halo + iend_g =ieg+halo+iext + jstart_g=jsg-halo + jend_g =jeg+halo+jext +! + count_i=iend_g-istart_g+1 + count_j=jend_g-jstart_g+1 +! + nz=size(fields_core(nv)%ptr,3) +! + allocate( global_field(istart_g:iend_g, jstart_g:jend_g, 1:nz) ) +! +!----------------------------------------------------------------------- +!*** What is the local extent of the variable on the task subdomain? +!*** We must exclude inner halo data since the data is not updated +!*** there in some of the variables. Of course the outer halo data +!*** around the domain boundary is included. +!----------------------------------------------------------------------- +! + istart=lbound(fields_core(nv)%ptr,1) + if(istart>1)then + istart=istart+halo + endif +! + iend =ubound(fields_core(nv)%ptr,1) + if(iend1)then + jstart=jstart+halo + endif +! + jend =ubound(fields_core(nv)%ptr,2) + if(jend1)then + istart=istart+halo + endif +! + iend =ubnd_x_tracers + if(iend1)then + jstart=jstart+halo + endif +! + jend =ubnd_y_tracers + if(jend Atm%q(:,:,:,sphum_index) rather than as was done +!*** for the core arrays which was ptr => Atm%u . +!----------------------------------------------------------------------- +! + istart_ptr=halo+1 + iend_ptr =ubnd_x_tracers-lbnd_x_tracers+1-halo + jstart_ptr=halo+1 + jend_ptr =ubnd_y_tracers-lbnd_y_tracers+1-halo +! + if(north_bc)then + jstart_ptr=1 + endif + if(south_bc)then + jend_ptr=ubnd_y_tracers-lbnd_y_tracers+1 + endif + if(east_bc)then + istart_ptr=1 + endif + if(west_bc)then + iend_ptr=ubnd_x_tracers-lbnd_x_tracers+1 + endif +! +!----------------------------------------------------------------------- +!*** Loop through that file's prognostic tracers. +!----------------------------------------------------------------------- +! + vbls_tracers: do nv=1,nfields_tracers +! + var_name=fields_tracers(nv)%name + if(is_root_pe)then + call check(nf90_inq_varid(ncid_tracers_new,var_name,var_id)) !<-- Get this variable's ID + endif +! +!----------------------------------------------------------------------- +!*** Gather onto a single task one layer at a time. That task +!*** writes the full data to the new larger restart file. +!----------------------------------------------------------------------- +! + do k=1,nz + call mpp_gather(istart,iend,jstart,jend & + ,pelist, fields_tracers(nv)%ptr(istart_ptr:iend_ptr,jstart_ptr:jend_ptr,k) & + ,global_field(:,:,k), is_root_pe, halo, halo) +! + if(is_root_pe)then + call check(nf90_put_var(ncid_tracers_new,var_id & + ,global_field(:,:,k) & + ,start=(/1,1,k/) & + ,count=(/count_i,count_j,1/))) + endif + enddo +! + enddo vbls_tracers +! + deallocate(global_field) +! + if(is_root_pe)then + call check(nf90_close(ncid_tracers_new)) + endif +! +!--------------------------------------------------------------------- + end subroutine write_full_fields +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +! + subroutine apply_delz_boundary(istart,iend,jstart,jend,nz & + ,Atm & + ,name & + ,field) +! +!--------------------------------------------------------------------- +!*** Use the current boundary values of delz to convert the +!*** boundary potential temperature to sensible temperature +!*** and to fill in the boundary rows of the 3D delz array. +!--------------------------------------------------------------------- +! +!------------------------ +!*** Argument variables +!------------------------ +! + integer,intent(in) :: istart,iend,jstart,jend +! + character(len=*),intent(in) :: name +! + type(fv_atmos_type),intent(inout) :: Atm +! + real,dimension(istart:iend,jstart:jend,1:nz),intent(inout) :: field +! +!--------------------- +!*** Local variables +!--------------------- +! + integer :: i1,i2,j1,j2,nz + integer :: lbnd1,lbnd2,ubnd1,ubnd2,i,j,k +! + real :: rdg +! + real,dimension(:,:,:),pointer :: delz_ptr +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! +!fill interior delz points before dealing with boundaries +! +!--------------------------------------------------------------------- +!*** Fill the interior of the full delz array using Atm%delz +!*** which does not have a boundary. +!--------------------------------------------------------------------- +! + if (trim(name)=='DZ') then + lbnd1=lbound(Atm%delz,1) + ubnd1=ubound(Atm%delz,1) + lbnd2=lbound(Atm%delz,2) + ubnd2=ubound(Atm%delz,2) +! + do k=1,nz + do j=lbnd2,ubnd2 + do i=lbnd1,ubnd1 + field(i,j,k)=Atm%delz(i,j,k) + enddo + enddo + enddo + endif +! + if(.not.(north_bc.or.south_bc.or.east_bc.or.west_bc))then + return !<-- Tasks not on the boundary may exit. + endif +! + rdg=-rdgas/grav +! +!--------------------------------------------------------------------- +! + if(north_bc)then + i1=istart + i2=iend + j1=jstart + j2=jstart+nhalo_model-1 + delz_ptr=>delz_auxiliary%north +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! + if(south_bc)then + i1=istart + i2=iend + j1=jend-nhalo_model+1 + j2=jend + delz_ptr=>delz_auxiliary%south +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! + if(east_bc)then + i1=istart + i2=istart+nhalo_model-1 + j1=jstart + j2=jend + if(north_bc)then + j1=jstart+nhalo_model + elseif(south_bc)then + j2=jend-nhalo_model + endif + delz_ptr=>delz_auxiliary%east +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! + if(west_bc)then + i1=iend-nhalo_model+1 + i2=iend + j1=jstart + j2=jend + if(north_bc)then + j1=jstart+nhalo_model + elseif(south_bc)then + j2=jend-nhalo_model + endif + delz_ptr=>delz_auxiliary%west +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! +!--------------------------------------------------------------------- + contains +!--------------------------------------------------------------------- +! + subroutine compute_halo_t +! +!--------------------------------------------------------------------- +! + integer :: i,j,k +! + real :: cappa,cvm,dp1,part1,part2 +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! + do k=1,nz + do j=j1,j2 + do i=i1,i2 + dp1 = zvir*Atm%q(i,j,k,sphum_index) + cvm=(1.-Atm%q(i,j,k,sphum_index)+Atm%q_con(i,j,k))*cv_air & + +Atm%q(i,j,k,sphum_index)*cv_vap & + +Atm%q(i,j,k,liq_water_index)*c_liq + cappa=rdgas/(rdgas+cvm/(1.+dp1)) +! + part1=(1.+dp1)*(1.-Atm%q_con(i,j,k)) + part2=rdg*Atm%delp(i,j,k)*(1.+dp1)*(1.-Atm%q_con(i,j,k)) & + /delz_ptr(i,j,k) + field(i,j,k)=exp((log(field(i,j,k))-log(part1)+cappa*log(part2)) & + /(1.-cappa)) + enddo + enddo + enddo +! +!--------------------------------------------------------------------- + end subroutine compute_halo_t +!--------------------------------------------------------------------- +! + subroutine fill_delz +! +!--------------------------------------------------------------------- +! + integer :: i,j,k + integer :: lbnd1,lbnd2,ubnd1,ubnd2 +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! +!--------------------------------------------------------------------- +!*** Now fill the boundary rows using data from the BC files. +!--------------------------------------------------------------------- +! + do k=1,nz + do j=j1,j2 + do i=i1,i2 + field(i,j,k)=delz_ptr(i,j,k) + enddo + enddo + enddo +! +!--------------------------------------------------------------------- + end subroutine fill_delz +!--------------------------------------------------------------------- +! + end subroutine apply_delz_boundary +! !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- @@ -4989,8 +6425,7 @@ subroutine exch_uv(domain, bd, npz, u, v) real, intent(inout) :: u (bd%isd:bd%ied ,bd%jsd:bd%jed+1,1:npz) real, intent(inout) :: v (bd%isd:bd%ied+1,bd%jsd:bd%jed ,1:npz) - integer,parameter :: ibufexch=2500000 - real,dimension(ibufexch) :: buf1,buf2,buf3,buf4 + real, dimension(:), allocatable :: buf1,buf2,buf3,buf4 integer :: ihandle1,ihandle2,ihandle3,ihandle4 integer,dimension(MPI_STATUS_SIZE) :: istat integer :: ic, i, j, k, is, ie, js, je @@ -5015,18 +6450,33 @@ subroutine exch_uv(domain, bd, npz, u, v) js=bd%js je=bd%je + ! The size of these buffers must match the number of indices + ! required below to send/receive the data. In particular, + ! buf1 and buf4 must be of the same size (sim. for buf2 and buf3). + ! Changes to the code below should be tested with debug flags + ! enabled (out-of-bounds reads/writes). + allocate(buf1(1:24*npz)) + allocate(buf2(1:36*npz)) + allocate(buf3(1:36*npz)) + allocate(buf4(1:24*npz)) + ! FIXME: MPI_COMM_WORLD +#ifdef OVERLOAD_R4 +#define _DYN_MPI_REAL MPI_REAL +#else +#define _DYN_MPI_REAL MPI_DOUBLE_PRECISION +#endif ! Receive from north if( north_pe /= NULL_PE )then - call MPI_Irecv(buf1,ibufexch,MPI_REAL,north_pe,north_pe & + call MPI_Irecv(buf1,size(buf1),_DYN_MPI_REAL,north_pe,north_pe & ,MPI_COMM_WORLD,ihandle1,irecv) endif ! Receive from south if( south_pe /= NULL_PE )then - call MPI_Irecv(buf2,ibufexch,MPI_REAL,south_pe,south_pe & + call MPI_Irecv(buf2,size(buf2),_DYN_MPI_REAL,south_pe,south_pe & ,MPI_COMM_WORLD,ihandle2,irecv) endif @@ -5056,9 +6506,10 @@ subroutine exch_uv(domain, bd, npz, u, v) buf3(ic)=v(i,j,k) enddo enddo - enddo - call MPI_Issend(buf3,ic,MPI_REAL,north_pe,mype & + if (ic/=size(buf2).or.ic/=size(buf3)) & + call mpp_error(FATAL,'Buffer sizes buf2 and buf3 in routine exch_uv do not match actual message size') + call MPI_Issend(buf3,size(buf3),_DYN_MPI_REAL,north_pe,mype & ,MPI_COMM_WORLD,ihandle3,isend) endif @@ -5090,7 +6541,9 @@ subroutine exch_uv(domain, bd, npz, u, v) enddo enddo - call MPI_Issend(buf4,ic,MPI_REAL,south_pe,mype & + if (ic/=size(buf1).or.ic/=size(buf4)) & + call mpp_error(FATAL,'Buffer sizes buf1 and buf4 in routine exch_uv do not match actual message size') + call MPI_Issend(buf4,size(buf4),_DYN_MPI_REAL,south_pe,mype & ,MPI_COMM_WORLD,ihandle4,isend) endif @@ -5156,8 +6609,17 @@ subroutine exch_uv(domain, bd, npz, u, v) enddo endif + deallocate(buf1) + deallocate(buf2) + deallocate(buf3) + deallocate(buf4) + end subroutine exch_uv +!--------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!--------------------------------------------------------------------- + subroutine get_data_source(source,regional) ! ! This routine extracts the data source information if it is present in the datafile. @@ -5179,6 +6641,10 @@ subroutine get_data_source(source,regional) endif end subroutine get_data_source +!--------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!--------------------------------------------------------------------- + subroutine set_delp_and_tracers(BC_side,npz,nwat) ! ! This routine mimics what is done in external_ic to add mass back to delp diff --git a/model/fv_sg.F90 b/model/fv_sg.F90 index 594e54873..992ad22f9 100644 --- a/model/fv_sg.F90 +++ b/model/fv_sg.F90 @@ -122,7 +122,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1) real, intent(in):: peln(is :ie, km+1,js :je) real, intent(in):: delp(isd:ied,jsd:jed,km) !< Delta p at each model level - real, intent(in):: delz(isd:,jsd:,1:) !< Delta z at each model level + real, intent(in):: delz(is:,js:,1:) !< Delta z at each model level real, intent(in):: pkz(is:ie,js:je,km) logical, intent(in):: hydrostatic integer, intent(in), optional:: k_bot @@ -299,6 +299,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & enddo elseif ( nwat==4 ) then do i=is,ie +#ifndef CCPP q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) #ifdef MULTI_GASES cpm(i) = (1.-(q0(i,k,sphum)+q_liq))*cp_air*vicpqd(q0(i,k,:)) + q0(i,k,sphum)*cp_vapor + q_liq*c_liq @@ -306,6 +307,20 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & #else cpm(i) = (1.-(q0(i,k,sphum)+q_liq))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,k,sphum)+q_liq))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq +#endif + +#else + q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) + q_sol = q0(i,k,ice_wat) +#ifdef MULTI_GASES + cpm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cp_air*vicpqd(q0(i,k,:)) + q0(i,k,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cv_air*vicvqd(q0(i,k,:)) + q0(i,k,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#else + cpm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#endif + + #endif enddo elseif ( nwat==5 ) then @@ -382,7 +397,11 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & elseif ( nwat==4 ) then do k=1,kbot do i=is,ie +#ifndef CCPP qcon(i,k) = q0(i,k,liq_wat) + q0(i,k,rainwat) +#else + qcon(i,k) = q0(i,k,liq_wat) + q0(i,k,rainwat) + q0(i,k,ice_wat) +#endif enddo enddo elseif ( nwat==5 ) then @@ -451,7 +470,12 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & elseif ( nwat==3 ) then ! AM3/AM4 qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) elseif ( nwat==4 ) then ! K_warm_rain scheme with fake ice +#ifndef CCPP qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,rainwat) +#else + qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) + & + q0(i,km1,rainwat) +#endif elseif ( nwat==5 ) then ! K_warm_rain scheme with fake ice qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) + & q0(i,km1,snowwat) + q0(i,km1,rainwat) @@ -572,6 +596,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & enddo elseif ( nwat == 4 ) then do i=is,ie +#ifndef CCPP q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) #ifdef MULTI_GASES cpm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cp_air*vicpqd(q0(i,kk,:)) + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq @@ -579,6 +604,19 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & #else cpm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq +#endif +#else + q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) + q_sol = q0(i,kk,ice_wat) +#ifdef MULTI_GASES + cpm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cp_air*vicpqd(q0(i,kk,:)) + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cv_air*vicvqd(q0(i,kk,:)) + q0(i,kk,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#else + cpm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#endif + + #endif enddo elseif ( nwat == 5 ) then @@ -686,7 +724,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1) real, intent(in):: peln(is :ie, km+1,js :je) real, intent(in):: delp(isd:ied,jsd:jed,km) !< Delta p at each model level - real, intent(in):: delz(isd:,jsd:,1:) !< Delta z at each model level + real, intent(in):: delz(is:,js:,1:) !< Delta z at each model level real, intent(in):: pkz(is:ie,js:je,km) logical, intent(in):: hydrostatic integer, intent(in), optional:: k_bot @@ -850,6 +888,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & enddo elseif ( nwat==4 ) then do i=is,ie +#ifndef CCPP q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) #ifdef MULTI_GASES cpm(i) = (1.-(q0(i,k,sphum)+q_liq))*cp_air*vicpqd(q0(i,k,:)) + q0(i,k,sphum)*cp_vapor + q_liq*c_liq @@ -857,6 +896,18 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & #else cpm(i) = (1.-(q0(i,k,sphum)+q_liq))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,k,sphum)+q_liq))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq +#endif +#else + q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) + q_sol = q0(i,k,ice_wat) +#ifdef MULTI_GASES + cpm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cp_air*vicpqd(q0(i,k,:)) + q0(i,k,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cv_air*vicvqd(q0(i,k,:)) + q0(i,k,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#else + cpm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#endif + #endif enddo elseif ( nwat==5 ) then @@ -933,7 +984,11 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & elseif ( nwat==4 ) then do k=1,kbot do i=is,ie +#ifndef CCPP qcon(i,k) = q0(i,k,liq_wat) + q0(i,k,rainwat) +#else + qcon(i,k) = q0(i,k,liq_wat) + q0(i,k,rainwat) + q0(i,k,ice_wat) +#endif enddo enddo elseif ( nwat==5 ) then @@ -998,7 +1053,11 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & elseif ( nwat==3 ) then ! AM3/AM4 qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) elseif ( nwat==4 ) then ! K_warm_rain scheme with fake ice +#ifndef CCPP qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,rainwat) +#else + qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,rainwat) + q0(i,km1,ice_wat) +#endif elseif ( nwat==5 ) then qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) + & q0(i,km1,snowwat) + q0(i,km1,rainwat) @@ -1118,6 +1177,7 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & enddo elseif ( nwat == 4 ) then do i=is,ie +#ifndef CCPP q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) #ifdef MULTI_GASES cpm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cp_air*vicpqd(q0(i,kk,:)) + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq @@ -1125,6 +1185,18 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & #else cpm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq +#endif +#else + q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) + q_sol = q0(i,kk,ice_wat) +#ifdef MULTI_GASES + cpm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cp_air*vicpqd(q0(i,kk,:)) + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cv_air*vicvqd(q0(i,kk,:)) + q0(i,kk,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#else + cpm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice +#endif + #endif enddo elseif ( nwat == 5 ) then @@ -1479,7 +1551,7 @@ subroutine neg_adj3(is, ie, js, je, ng, kbot, hydrostatic, peln, delz, pt, dp, integer, intent(in):: is, ie, js, je, ng, kbot logical, intent(in):: hydrostatic real, intent(in):: dp(is-ng:ie+ng,js-ng:je+ng,kbot) !< total delp-p - real, intent(in):: delz(is-ng:,js-ng:,1:) + real, intent(in):: delz(is:,js:,1:) real, intent(in):: peln(is:ie,kbot+1,js:je) !< ln(pe) logical, intent(in), OPTIONAL :: check_negative #ifdef MULTI_GASES diff --git a/model/fv_tracer2d.F90 b/model/fv_tracer2d.F90 index f86463717..96c613e1c 100644 --- a/model/fv_tracer2d.F90 +++ b/model/fv_tracer2d.F90 @@ -1,839 +1,822 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'fv_tracer2d.F90' performs sub-cycled tracer advection. -!>@see \cite lin2004vertically - -! Modules Included: -! -! -! -! -! -!
Module NameFunctions Included
-! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -!
boundary_modnested_grid_BC_apply_intT
fv_arrays_modfv_grid_type, fv_nest_type, fv_atmos_type, fv_grid_bounds_type
fv_mp_modmp_reduce_max, ng, mp_gather, is_master, group_halo_update_type, -! start_group_halo_update, complete_group_halo_update
fv_timing_modtiming_on, timing_off
mpp_modmpp_error, FATAL, mpp_broadcast, mpp_send, mpp_recv, mpp_sum, mpp_max
mpp_domains_modmpp_update_domains, CGRID_NE, domain2d
tp_core_modfv_tp_2d, copy_corners
- -module fv_tracer2d_mod - use tp_core_mod, only: fv_tp_2d, copy_corners - use fv_mp_mod, only: mp_reduce_max - use fv_mp_mod, only: ng, mp_gather, is_master - use fv_mp_mod, only: group_halo_update_type - use fv_mp_mod, only: start_group_halo_update, complete_group_halo_update - use mpp_domains_mod, only: mpp_update_domains, CGRID_NE, domain2d - use fv_timing_mod, only: timing_on, timing_off - use boundary_mod, only: nested_grid_BC_apply_intT - use fv_regional_mod, only: regional_boundary_update - use fv_regional_mod, only: current_time_in_seconds - use fv_arrays_mod, only: fv_grid_type, fv_nest_type, fv_atmos_type, fv_grid_bounds_type - use mpp_mod, only: mpp_error, FATAL, mpp_broadcast, mpp_send, mpp_recv, mpp_sum, mpp_max - -implicit none -private - -public :: tracer_2d, tracer_2d_nested, tracer_2d_1L - -real, allocatable, dimension(:,:,:) :: nest_fx_west_accum, nest_fx_east_accum, nest_fx_south_accum, nest_fx_north_accum - -contains - -!>@brief The subroutine 'tracer_2d_1L' performs 2-D horizontal-to-lagrangian transport. -!>@details This subroutine is called if 'z_tracer = .true.' -!! It modifies 'tracer_2d' so that each layer uses a different diagnosed number -!! of split tracer timesteps. This potentially accelerates tracer advection when there -!! is a large difference in layer-maximum wind speeds (cf. polar night jet). -subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & - nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, lim_fac, regional) - - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(IN) :: npx - integer, intent(IN) :: npy - integer, intent(IN) :: npz - integer, intent(IN) :: nq !< number of tracers to be advected - integer, intent(IN) :: hord, nord_tr - integer, intent(IN) :: q_split - integer, intent(IN) :: id_divg - real , intent(IN) :: dt, trdm - real , intent(IN) :: lim_fac - logical, intent(IN) :: regional - type(group_halo_update_type), intent(inout) :: q_pack - real , intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq) !< Tracers - real , intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< DELP before dyn_core - real , intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz) !< Mass Flux X-Dir - real , intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz) !< Mass Flux Y-Dir - real , intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) !< Courant Number X-Dir - real , intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz) !< Courant Number Y-Dir - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - -! Local Arrays - real :: qn2(bd%isd:bd%ied,bd%jsd:bd%jed,nq) !< 3D tracers - real :: dp2(bd%is:bd%ie,bd%js:bd%je) - real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) - real :: fy(bd%is:bd%ie , bd%js:bd%je+1) - real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) - real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) - real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) - real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) - real :: cmax(npz) - real :: frac - integer :: nsplt - integer :: i,j,k,it,iq - - real, pointer, dimension(:,:) :: area, rarea - real, pointer, dimension(:,:,:) :: sin_sg - real, pointer, dimension(:,:) :: dxa, dya, dx, dy - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - area => gridstruct%area - rarea => gridstruct%rarea - - sin_sg => gridstruct%sin_sg - dxa => gridstruct%dxa - dya => gridstruct%dya - dx => gridstruct%dx - dy => gridstruct%dy - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, & -!$OMP sin_sg,cy,yfx,dya,dx,cmax) - do k=1,npz - do j=jsd,jed - do i=is,ie+1 - if (cx(i,j,k) > 0.) then - xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3) - else - xfx(i,j,k) = cx(i,j,k)*dxa(i, j)*dy(i,j)*sin_sg(i, j,1) - endif - enddo - enddo - do j=js,je+1 - do i=isd,ied - if (cy(i,j,k) > 0.) then - yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4) - else - yfx(i,j,k) = cy(i,j,k)*dya(i,j )*dx(i,j)*sin_sg(i,j, 2) - endif - enddo - enddo - - cmax(k) = 0. - if ( k < npz/6 ) then - do j=js,je - do i=is,ie - cmax(k) = max( cmax(k), abs(cx(i,j,k)), abs(cy(i,j,k)) ) - enddo - enddo - else - do j=js,je - do i=is,ie - cmax(k) = max( cmax(k), max(abs(cx(i,j,k)),abs(cy(i,j,k)))+1.-sin_sg(i,j,5) ) - enddo - enddo - endif - enddo ! k-loop - - call mp_reduce_max(cmax,npz) - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx, & -!$OMP cy,yfx,mfx,mfy,cmax) & -!$OMP private(nsplt, frac) - do k=1,npz - - nsplt = int(1. + cmax(k)) - if ( nsplt > 1 ) then - frac = 1. / real(nsplt) - do j=jsd,jed - do i=is,ie+1 - cx(i,j,k) = cx(i,j,k) * frac - xfx(i,j,k) = xfx(i,j,k) * frac - enddo - enddo - do j=js,je - do i=is,ie+1 - mfx(i,j,k) = mfx(i,j,k) * frac - enddo - enddo - do j=js,je+1 - do i=isd,ied - cy(i,j,k) = cy(i,j,k) * frac - yfx(i,j,k) = yfx(i,j,k) * frac - enddo - enddo - do j=js,je+1 - do i=is,ie - mfy(i,j,k) = mfy(i,j,k) * frac - enddo - enddo - endif - - enddo - call timing_on('COMM_TOTAL') - call timing_on('COMM_TRACER') - call complete_group_halo_update(q_pack, domain) - call timing_off('COMM_TRACER') - call timing_off('COMM_TOTAL') - -! Begin k-independent tracer transport; can not be OpenMPed because the mpp_update call. - do k=1,npz - -!$OMP parallel do default(none) shared(k,is,ie,js,je,isd,ied,jsd,jed,xfx,area,yfx,ra_x,ra_y) - do j=jsd,jed - do i=is,ie - ra_x(i,j) = area(i,j) + xfx(i,j,k) - xfx(i+1,j,k) - enddo - if ( j>=js .and. j<=je ) then - do i=isd,ied - ra_y(i,j) = area(i,j) + yfx(i,j,k) - yfx(i,j+1,k) - enddo - endif - enddo - - nsplt = int(1. + cmax(k)) - do it=1,nsplt - -!$OMP parallel do default(none) shared(k,is,ie,js,je,rarea,mfx,mfy,dp1,dp2) - do j=js,je - do i=is,ie - dp2(i,j) = dp1(i,j,k) + (mfx(i,j,k)-mfx(i+1,j,k)+mfy(i,j,k)-mfy(i,j+1,k))*rarea(i,j) - enddo - enddo - -!$OMP parallel do default(none) shared(k,nsplt,it,is,ie,js,je,isd,ied,jsd,jed,npx,npy,cx,xfx,hord,trdm, & -!$OMP nord_tr,nq,gridstruct,bd,cy,yfx,mfx,mfy,qn2,q,ra_x,ra_y,dp1,dp2,rarea,lim_fac,regional) & -!$OMP private(fx,fy) - do iq=1,nq - if ( nsplt /= 1 ) then - if ( it==1 ) then - do j=jsd,jed - do i=isd,ied - qn2(i,j,iq) = q(i,j,k,iq) - enddo - enddo - endif - call fv_tp_2d(qn2(isd,jsd,iq), cx(is,jsd,k), cy(isd,js,k), & - npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & - gridstruct, bd, ra_x, ra_y, lim_fac, regional, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) - if ( it < nsplt ) then ! not last call - do j=js,je - do i=is,ie - qn2(i,j,iq) = (qn2(i,j,iq)*dp1(i,j,k)+(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/dp2(i,j) - enddo - enddo - else - do j=js,je - do i=is,ie - q(i,j,k,iq) = (qn2(i,j,iq)*dp1(i,j,k)+(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/dp2(i,j) - enddo - enddo - endif - else - call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & - npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & - gridstruct, bd, ra_x, ra_y, lim_fac, regional, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) - do j=js,je - do i=is,ie - q(i,j,k,iq) = (q(i,j,k,iq)*dp1(i,j,k)+(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/dp2(i,j) - enddo - enddo - endif - enddo ! tracer-loop - - if ( it < nsplt ) then ! not last call - do j=js,je - do i=is,ie - dp1(i,j,k) = dp2(i,j) - enddo - enddo - call timing_on('COMM_TOTAL') - call timing_on('COMM_TRACER') - call mpp_update_domains(qn2, domain) - call timing_off('COMM_TRACER') - call timing_off('COMM_TOTAL') - endif - enddo ! time-split loop - enddo ! k-loop - -end subroutine tracer_2d_1L - -!>@brief The subroutine 'tracer_2d' is the standard routine for sub-cycled tracer advection. -subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & - nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, lim_fac, regional) - - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(IN) :: npx - integer, intent(IN) :: npy - integer, intent(IN) :: npz - integer, intent(IN) :: nq !< number of tracers to be advected - integer, intent(IN) :: hord, nord_tr - integer, intent(IN) :: q_split - integer, intent(IN) :: id_divg - real , intent(IN) :: dt, trdm - real , intent(IN) :: lim_fac - logical, intent(IN) :: regional - type(group_halo_update_type), intent(inout) :: q_pack - real , intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq) !< Tracers - real , intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< DELP before dyn_core - real , intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz) !< Mass Flux X-Dir - real , intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz) !< Mass Flux Y-Dir - real , intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) !< Courant Number X-Dir - real , intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz) !< Courant Number Y-Dir - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - -! Local Arrays - real :: dp2(bd%is:bd%ie,bd%js:bd%je) - real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) - real :: fy(bd%is:bd%ie , bd%js:bd%je+1) - real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) - real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) - real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) - real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) - real :: cmax(npz) - real :: c_global - real :: frac, rdt - integer :: ksplt(npz) - integer :: nsplt - integer :: i,j,k,it,iq - - real, pointer, dimension(:,:) :: area, rarea - real, pointer, dimension(:,:,:) :: sin_sg - real, pointer, dimension(:,:) :: dxa, dya, dx, dy - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - area => gridstruct%area - rarea => gridstruct%rarea - - sin_sg => gridstruct%sin_sg - dxa => gridstruct%dxa - dya => gridstruct%dya - dx => gridstruct%dx - dy => gridstruct%dy - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, & -!$OMP sin_sg,cy,yfx,dya,dx,cmax,q_split,ksplt) - do k=1,npz - do j=jsd,jed - do i=is,ie+1 - if (cx(i,j,k) > 0.) then - xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3) - else - xfx(i,j,k) = cx(i,j,k)*dxa(i,j)*dy(i,j)*sin_sg(i,j,1) - endif - enddo - enddo - do j=js,je+1 - do i=isd,ied - if (cy(i,j,k) > 0.) then - yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4) - else - yfx(i,j,k) = cy(i,j,k)*dya(i,j)*dx(i,j)*sin_sg(i,j,2) - endif - enddo - enddo - - if ( q_split == 0 ) then - cmax(k) = 0. - if ( k < npz/6 ) then - do j=js,je - do i=is,ie - cmax(k) = max( cmax(k), abs(cx(i,j,k)), abs(cy(i,j,k)) ) - enddo - enddo - else - do j=js,je - do i=is,ie - cmax(k) = max( cmax(k), max(abs(cx(i,j,k)),abs(cy(i,j,k)))+1.-sin_sg(i,j,5) ) - enddo - enddo - endif - endif - ksplt(k) = 1 - - enddo - -!-------------------------------------------------------------------------------- - -! Determine global nsplt: - if ( q_split == 0 ) then - call mp_reduce_max(cmax,npz) -! find global max courant number and define nsplt to scale cx,cy,mfx,mfy - c_global = cmax(1) - if ( npz /= 1 ) then ! if NOT shallow water test case - do k=2,npz - c_global = max(cmax(k), c_global) - enddo - endif - nsplt = int(1. + c_global) - if ( is_master() .and. nsplt > 4 ) write(*,*) 'Tracer_2d_split=', nsplt, c_global - else - nsplt = q_split - endif - -!-------------------------------------------------------------------------------- - - if( nsplt /= 1 ) then -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,mfx,cy,yfx,mfy,cmax,nsplt,ksplt) & -!$OMP private( frac ) - do k=1,npz - -#ifdef GLOBAL_CFL - ksplt(k) = nsplt -#else - ksplt(k) = int(1. + cmax(k)) -#endif - frac = 1. / real(ksplt(k)) - - do j=jsd,jed - do i=is,ie+1 - cx(i,j,k) = cx(i,j,k) * frac - xfx(i,j,k) = xfx(i,j,k) * frac - enddo - enddo - do j=js,je - do i=is,ie+1 - mfx(i,j,k) = mfx(i,j,k) * frac - enddo - enddo - - do j=js,je+1 - do i=isd,ied - cy(i,j,k) = cy(i,j,k) * frac - yfx(i,j,k) = yfx(i,j,k) * frac - enddo - enddo - do j=js,je+1 - do i=is,ie - mfy(i,j,k) = mfy(i,j,k) * frac - enddo - enddo - - enddo - endif - - do it=1,nsplt - call timing_on('COMM_TOTAL') - call timing_on('COMM_TRACER') - call complete_group_halo_update(q_pack, domain) - call timing_off('COMM_TRACER') - call timing_off('COMM_TOTAL') - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq,ksplt,& -!$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm,lim_fac,regional) & -!$OMP private(dp2, ra_x, ra_y, fx, fy) - do k=1,npz - - if ( it .le. ksplt(k) ) then - - do j=js,je - do i=is,ie - dp2(i,j) = dp1(i,j,k) + (mfx(i,j,k)-mfx(i+1,j,k)+mfy(i,j,k)-mfy(i,j+1,k))*rarea(i,j) - enddo - enddo - - do j=jsd,jed - do i=is,ie - ra_x(i,j) = area(i,j) + xfx(i,j,k) - xfx(i+1,j,k) - enddo - enddo - do j=js,je - do i=isd,ied - ra_y(i,j) = area(i,j) + yfx(i,j,k) - yfx(i,j+1,k) - enddo - enddo - - do iq=1,nq - if ( it==1 .and. trdm>1.e-4 ) then - call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & - npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & - gridstruct, bd, ra_x, ra_y, lim_fac, regional, mfx=mfx(is,js,k), mfy=mfy(is,js,k), & - mass=dp1(isd,jsd,k), nord=nord_tr, damp_c=trdm) - else - call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & - npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & - gridstruct, bd, ra_x, ra_y, lim_fac, regional, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) - endif - do j=js,je - do i=is,ie - q(i,j,k,iq) = ( q(i,j,k,iq)*dp1(i,j,k) + & - (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) )/dp2(i,j) - enddo - enddo - enddo - - if ( it /= nsplt ) then - do j=js,je - do i=is,ie - dp1(i,j,k) = dp2(i,j) - enddo - enddo - endif - - endif ! ksplt - - enddo ! npz - - if ( it /= nsplt ) then - call timing_on('COMM_TOTAL') - call timing_on('COMM_TRACER') - call start_group_halo_update(q_pack, q, domain) - call timing_off('COMM_TRACER') - call timing_off('COMM_TOTAL') - endif - - enddo ! nsplt - - -end subroutine tracer_2d - - -subroutine tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & - nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, & - k_split, neststruct, parent_grid, lim_fac, regional) - - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(IN) :: npx - integer, intent(IN) :: npy - integer, intent(IN) :: npz - integer, intent(IN) :: nq !< number of tracers to be advected - integer, intent(IN) :: hord, nord_tr - integer, intent(IN) :: q_split, k_split - integer, intent(IN) :: id_divg - real , intent(IN) :: dt, trdm - real , intent(IN) :: lim_fac - logical, intent(IN) :: regional - type(group_halo_update_type), intent(inout) :: q_pack - real , intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq) !< Tracers - real , intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< DELP before dyn_core - real , intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz) !< Mass Flux X-Dir - real , intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz) !< Mass Flux Y-Dir - real , intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) !< Courant Number X-Dir - real , intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz) !< Courant Number Y-Dir - type(fv_grid_type), intent(IN), target :: gridstruct - type(fv_nest_type), intent(INOUT) :: neststruct - type(fv_atmos_type), pointer, intent(IN) :: parent_grid - type(domain2d), intent(INOUT) :: domain - -! Local Arrays - real :: dp2(bd%is:bd%ie,bd%js:bd%je) - real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) - real :: fy(bd%is:bd%ie , bd%js:bd%je+1) - real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) - real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) - real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) - real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) - real :: cmax(npz) - real :: cmax_t - real :: c_global - real :: frac, rdt - real :: recip_nsplt,reg_bc_update_time - integer :: nsplt, nsplt_parent, msg_split_steps = 1 - integer :: i,j,k,it,iq - - real, pointer, dimension(:,:) :: area, rarea - real, pointer, dimension(:,:,:) :: sin_sg - real, pointer, dimension(:,:) :: dxa, dya, dx, dy - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - area => gridstruct%area - rarea => gridstruct%rarea - - sin_sg => gridstruct%sin_sg - dxa => gridstruct%dxa - dya => gridstruct%dya - dx => gridstruct%dx - dy => gridstruct%dy - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, & -!$OMP sin_sg,cy,yfx,dya,dx) - do k=1,npz - do j=jsd,jed - do i=is,ie+1 - if (cx(i,j,k) > 0.) then - xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3) - else - xfx(i,j,k) = cx(i,j,k)*dxa(i,j)*dy(i,j)*sin_sg(i,j,1) - endif - enddo - enddo - do j=js,je+1 - do i=isd,ied - if (cy(i,j,k) > 0.) then - yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4) - else - yfx(i,j,k) = cy(i,j,k)*dya(i,j)*dx(i,j)*sin_sg(i,j,2) - endif - enddo - enddo - enddo - -!-------------------------------------------------------------------------------- - if ( q_split == 0 ) then -! Determine nsplt - -!$OMP parallel do default(none) shared(is,ie,js,je,npz,cmax,cx,cy,sin_sg) & -!$OMP private(cmax_t ) - do k=1,npz - cmax(k) = 0. - if ( k < 4 ) then -! Top layers: C < max( abs(c_x), abs(c_y) ) - do j=js,je - do i=is,ie - cmax_t = max( abs(cx(i,j,k)), abs(cy(i,j,k)) ) - cmax(k) = max( cmax_t, cmax(k) ) - enddo - enddo - else - do j=js,je - do i=is,ie - cmax_t = max(abs(cx(i,j,k)), abs(cy(i,j,k))) + 1.-sin_sg(i,j,5) - cmax(k) = max( cmax_t, cmax(k) ) - enddo - enddo - endif - enddo - call mp_reduce_max(cmax,npz) - -! find global max courant number and define nsplt to scale cx,cy,mfx,mfy - c_global = cmax(1) - if ( npz /= 1 ) then ! if NOT shallow water test case - do k=2,npz - c_global = max(cmax(k), c_global) - enddo - endif - nsplt = int(1. + c_global) - if ( is_master() .and. nsplt > 3 ) write(*,*) 'Tracer_2d_split=', nsplt, c_global - else - nsplt = q_split - if (gridstruct%nested .and. neststruct%nestbctype > 1) msg_split_steps = max(q_split/parent_grid%flagstruct%q_split,1) - endif - -!-------------------------------------------------------------------------------- - - frac = 1. / real(nsplt) - recip_nsplt = 1. / real(nsplt) - - if( nsplt /= 1 ) then -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,frac,xfx,mfx,cy,yfx,mfy) - do k=1,npz - do j=jsd,jed - do i=is,ie+1 - cx(i,j,k) = cx(i,j,k) * frac - xfx(i,j,k) = xfx(i,j,k) * frac - enddo - enddo - do j=js,je - do i=is,ie+1 - mfx(i,j,k) = mfx(i,j,k) * frac - enddo - enddo - - do j=js,je+1 - do i=isd,ied - cy(i,j,k) = cy(i,j,k) * frac - yfx(i,j,k) = yfx(i,j,k) * frac - enddo - enddo - - do j=js,je+1 - do i=is,ie - mfy(i,j,k) = mfy(i,j,k) * frac - enddo - enddo - enddo - endif - - - do it=1,nsplt - if ( gridstruct%nested ) then - neststruct%tracer_nest_timestep = neststruct%tracer_nest_timestep + 1 - end if - call timing_on('COMM_TOTAL') - call timing_on('COMM_TRACER') - call complete_group_halo_update(q_pack, domain) - call timing_off('COMM_TRACER') - call timing_off('COMM_TOTAL') - - if (gridstruct%nested) then - do iq=1,nq - call nested_grid_BC_apply_intT(q(isd:ied,jsd:jed,:,iq), & - 0, 0, npx, npy, npz, bd, & - real(neststruct%tracer_nest_timestep)+real(nsplt*k_split), real(nsplt*k_split), & - neststruct%q_BC(iq), bctype=neststruct%nestbctype ) - enddo - endif - - if (regional) then - reg_bc_update_time=current_time_in_seconds+(it-1)*recip_nsplt*dt !<-- dt is the k_split timestep length - do iq=1,nq - call regional_boundary_update(q(:,:,:,iq), 'q', & - isd, ied, jsd, jed, npz, & - is, ie, js, je, & - isd, ied, jsd, jed, & - reg_bc_update_time, & - iq ) - enddo - endif - - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq, & -!$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm,lim_fac,regional) & -!$OMP private(dp2, ra_x, ra_y, fx, fy) - do k=1,npz - - do j=js,je - do i=is,ie - dp2(i,j) = dp1(i,j,k) + (mfx(i,j,k)-mfx(i+1,j,k)+mfy(i,j,k)-mfy(i,j+1,k))*rarea(i,j) - enddo - enddo - - do j=jsd,jed - do i=is,ie - ra_x(i,j) = area(i,j) + xfx(i,j,k) - xfx(i+1,j,k) - enddo - enddo - do j=js,je - do i=isd,ied - ra_y(i,j) = area(i,j) + yfx(i,j,k) - yfx(i,j+1,k) - enddo - enddo - - do iq=1,nq - if ( it==1 .and. trdm>1.e-4 ) then - call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & - npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & - gridstruct, bd, ra_x, ra_y, lim_fac, regional, mfx=mfx(is,js,k), mfy=mfy(is,js,k), & - mass=dp1(isd,jsd,k), nord=nord_tr, damp_c=trdm) - else - call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & - npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & - gridstruct, bd, ra_x, ra_y, lim_fac, regional, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) - endif - do j=js,je - do i=is,ie - q(i,j,k,iq) = ( q(i,j,k,iq)*dp1(i,j,k) + & - (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) )/dp2(i,j) - enddo - enddo - enddo - enddo ! npz - - if ( it /= nsplt ) then - call timing_on('COMM_TOTAL') - call timing_on('COMM_TRACER') - call start_group_halo_update(q_pack, q, domain) - call timing_off('COMM_TRACER') - call timing_off('COMM_TOTAL') - endif - !Apply nested-grid BCs - if ( gridstruct%nested ) then - do iq=1,nq - - - call nested_grid_BC_apply_intT(q(isd:ied,jsd:jed,:,iq), & - 0, 0, npx, npy, npz, bd, & - real(neststruct%tracer_nest_timestep), real(nsplt*k_split), & - neststruct%q_BC(iq), bctype=neststruct%nestbctype ) - - end do - end if - -! BCs for q at the current time were applied above for the regional mode. - - enddo ! nsplt - - if ( id_divg > 0 ) then - rdt = 1./(frac*dt) - -!$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,xfx,yfx,rarea,rdt) - do k=1,npz - do j=js,je - do i=is,ie - dp1(i,j,k) = (xfx(i+1,j,k)-xfx(i,j,k) + yfx(i,j+1,k)-yfx(i,j,k))*rarea(i,j)*rdt - enddo - enddo - enddo - endif - - end subroutine tracer_2d_nested - -end module fv_tracer2d_mod +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'fv_tracer2d.F90' performs sub-cycled tracer advection. +!>@see \cite lin2004vertically + +! Modules Included: +! +! +! +! +! +!
Module NameFunctions Included
+! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
boundary_modnested_grid_BC_apply_intT
fv_arrays_modfv_grid_type, fv_nest_type, fv_atmos_type, fv_grid_bounds_type
fv_mp_modmp_reduce_max, ng, mp_gather, is_master, group_halo_update_type, +! start_group_halo_update, complete_group_halo_update
fv_timing_modtiming_on, timing_off
mpp_modmpp_error, FATAL, mpp_broadcast, mpp_send, mpp_recv, mpp_sum, mpp_max
mpp_domains_modmpp_update_domains, CGRID_NE, domain2d
tp_core_modfv_tp_2d, copy_corners
+ +module fv_tracer2d_mod + use tp_core_mod, only: fv_tp_2d, copy_corners + use fv_mp_mod, only: mp_reduce_max + use fv_mp_mod, only: mp_gather, is_master + use fv_mp_mod, only: group_halo_update_type + use fv_mp_mod, only: start_group_halo_update, complete_group_halo_update + use mpp_domains_mod, only: mpp_update_domains, CGRID_NE, domain2d + use fv_timing_mod, only: timing_on, timing_off + use boundary_mod, only: nested_grid_BC_apply_intT + use fv_regional_mod, only: regional_boundary_update + use fv_regional_mod, only: current_time_in_seconds + use fv_arrays_mod, only: fv_grid_type, fv_nest_type, fv_atmos_type, fv_grid_bounds_type + use mpp_mod, only: mpp_error, FATAL, mpp_broadcast, mpp_send, mpp_recv, mpp_sum, mpp_max + +implicit none +private + +public :: tracer_2d, tracer_2d_nested, tracer_2d_1L + +real, allocatable, dimension(:,:,:) :: nest_fx_west_accum, nest_fx_east_accum, nest_fx_south_accum, nest_fx_north_accum + +contains + +!>@brief The subroutine 'tracer_2d_1L' performs 2-D horizontal-to-lagrangian transport. +!>@details This subroutine is called if 'z_tracer = .true.' +!! It modifies 'tracer_2d' so that each layer uses a different diagnosed number +!! of split tracer timesteps. This potentially accelerates tracer advection when there +!! is a large difference in layer-maximum wind speeds (cf. polar night jet). +subroutine tracer_2d_1L(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & + nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, lim_fac) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npx + integer, intent(IN) :: npy + integer, intent(IN) :: npz + integer, intent(IN) :: nq !< number of tracers to be advected + integer, intent(IN) :: hord, nord_tr + integer, intent(IN) :: q_split + integer, intent(IN) :: id_divg + real , intent(IN) :: dt, trdm + real , intent(IN) :: lim_fac + type(group_halo_update_type), intent(inout) :: q_pack + real , intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq) !< Tracers + real , intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< DELP before dyn_core + real , intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz) !< Mass Flux X-Dir + real , intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz) !< Mass Flux Y-Dir + real , intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) !< Courant Number X-Dir + real , intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz) !< Courant Number Y-Dir + type(fv_grid_type), intent(IN), target :: gridstruct + type(domain2d), intent(INOUT) :: domain + +! Local Arrays + real :: qn2(bd%isd:bd%ied,bd%jsd:bd%jed,nq) !< 3D tracers + real :: dp2(bd%is:bd%ie,bd%js:bd%je) + real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) + real :: fy(bd%is:bd%ie , bd%js:bd%je+1) + real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) + real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) + real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) + real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) + real :: cmax(npz) + real :: frac + integer :: nsplt + integer :: i,j,k,it,iq + + real, pointer, dimension(:,:) :: area, rarea + real, pointer, dimension(:,:,:) :: sin_sg + real, pointer, dimension(:,:) :: dxa, dya, dx, dy + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + area => gridstruct%area + rarea => gridstruct%rarea + + sin_sg => gridstruct%sin_sg + dxa => gridstruct%dxa + dya => gridstruct%dya + dx => gridstruct%dx + dy => gridstruct%dy + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, & +!$OMP sin_sg,cy,yfx,dya,dx,cmax) + do k=1,npz + do j=jsd,jed + do i=is,ie+1 + if (cx(i,j,k) > 0.) then + xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3) + else + xfx(i,j,k) = cx(i,j,k)*dxa(i, j)*dy(i,j)*sin_sg(i, j,1) + endif + enddo + enddo + do j=js,je+1 + do i=isd,ied + if (cy(i,j,k) > 0.) then + yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4) + else + yfx(i,j,k) = cy(i,j,k)*dya(i,j )*dx(i,j)*sin_sg(i,j, 2) + endif + enddo + enddo + + cmax(k) = 0. + if ( k < npz/6 ) then + do j=js,je + do i=is,ie + cmax(k) = max( cmax(k), abs(cx(i,j,k)), abs(cy(i,j,k)) ) + enddo + enddo + else + do j=js,je + do i=is,ie + cmax(k) = max( cmax(k), max(abs(cx(i,j,k)),abs(cy(i,j,k)))+1.-sin_sg(i,j,5) ) + enddo + enddo + endif + enddo ! k-loop + + call mp_reduce_max(cmax,npz) + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx, & +!$OMP cy,yfx,mfx,mfy,cmax) & +!$OMP private(nsplt, frac) + do k=1,npz + + nsplt = int(1. + cmax(k)) + if ( nsplt > 1 ) then + frac = 1. / real(nsplt) + do j=jsd,jed + do i=is,ie+1 + cx(i,j,k) = cx(i,j,k) * frac + xfx(i,j,k) = xfx(i,j,k) * frac + enddo + enddo + do j=js,je + do i=is,ie+1 + mfx(i,j,k) = mfx(i,j,k) * frac + enddo + enddo + do j=js,je+1 + do i=isd,ied + cy(i,j,k) = cy(i,j,k) * frac + yfx(i,j,k) = yfx(i,j,k) * frac + enddo + enddo + do j=js,je+1 + do i=is,ie + mfy(i,j,k) = mfy(i,j,k) * frac + enddo + enddo + endif + + enddo + call timing_on('COMM_TOTAL') + call timing_on('COMM_TRACER') + call complete_group_halo_update(q_pack, domain) + call timing_off('COMM_TRACER') + call timing_off('COMM_TOTAL') + +! Begin k-independent tracer transport; can not be OpenMPed because the mpp_update call. + do k=1,npz + +!$OMP parallel do default(none) shared(k,is,ie,js,je,isd,ied,jsd,jed,xfx,area,yfx,ra_x,ra_y) + do j=jsd,jed + do i=is,ie + ra_x(i,j) = area(i,j) + xfx(i,j,k) - xfx(i+1,j,k) + enddo + if ( j>=js .and. j<=je ) then + do i=isd,ied + ra_y(i,j) = area(i,j) + yfx(i,j,k) - yfx(i,j+1,k) + enddo + endif + enddo + + nsplt = int(1. + cmax(k)) + do it=1,nsplt + +!$OMP parallel do default(none) shared(k,is,ie,js,je,rarea,mfx,mfy,dp1,dp2) + do j=js,je + do i=is,ie + dp2(i,j) = dp1(i,j,k) + (mfx(i,j,k)-mfx(i+1,j,k)+mfy(i,j,k)-mfy(i,j+1,k))*rarea(i,j) + enddo + enddo + +!$OMP parallel do default(none) shared(k,nsplt,it,is,ie,js,je,isd,ied,jsd,jed,npx,npy,cx,xfx,hord,trdm, & +!$OMP nord_tr,nq,gridstruct,bd,cy,yfx,mfx,mfy,qn2,q,ra_x,ra_y,dp1,dp2,rarea,lim_fac) & +!$OMP private(fx,fy) + do iq=1,nq + if ( nsplt /= 1 ) then + if ( it==1 ) then + do j=jsd,jed + do i=isd,ied + qn2(i,j,iq) = q(i,j,k,iq) + enddo + enddo + endif + call fv_tp_2d(qn2(isd,jsd,iq), cx(is,jsd,k), cy(isd,js,k), & + npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & + gridstruct, bd, ra_x, ra_y, lim_fac, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) + if ( it < nsplt ) then ! not last call + do j=js,je + do i=is,ie + qn2(i,j,iq) = (qn2(i,j,iq)*dp1(i,j,k)+(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/dp2(i,j) + enddo + enddo + else + do j=js,je + do i=is,ie + q(i,j,k,iq) = (qn2(i,j,iq)*dp1(i,j,k)+(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/dp2(i,j) + enddo + enddo + endif + else + call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & + npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & + gridstruct, bd, ra_x, ra_y, lim_fac, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) + do j=js,je + do i=is,ie + q(i,j,k,iq) = (q(i,j,k,iq)*dp1(i,j,k)+(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j))/dp2(i,j) + enddo + enddo + endif + enddo ! tracer-loop + + if ( it < nsplt ) then ! not last call + do j=js,je + do i=is,ie + dp1(i,j,k) = dp2(i,j) + enddo + enddo + call timing_on('COMM_TOTAL') + call timing_on('COMM_TRACER') + call mpp_update_domains(qn2, domain) + call timing_off('COMM_TRACER') + call timing_off('COMM_TOTAL') + endif + enddo ! time-split loop + enddo ! k-loop + +end subroutine tracer_2d_1L + +!>@brief The subroutine 'tracer_2d' is the standard routine for sub-cycled tracer advection. +subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & + nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, lim_fac) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npx + integer, intent(IN) :: npy + integer, intent(IN) :: npz + integer, intent(IN) :: nq !< number of tracers to be advected + integer, intent(IN) :: hord, nord_tr + integer, intent(IN) :: q_split + integer, intent(IN) :: id_divg + real , intent(IN) :: dt, trdm + real , intent(IN) :: lim_fac + type(group_halo_update_type), intent(inout) :: q_pack + real , intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq) !< Tracers + real , intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< DELP before dyn_core + real , intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz) !< Mass Flux X-Dir + real , intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz) !< Mass Flux Y-Dir + real , intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) !< Courant Number X-Dir + real , intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz) !< Courant Number Y-Dir + type(fv_grid_type), intent(IN), target :: gridstruct + type(domain2d), intent(INOUT) :: domain + +! Local Arrays + real :: dp2(bd%is:bd%ie,bd%js:bd%je) + real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) + real :: fy(bd%is:bd%ie , bd%js:bd%je+1) + real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) + real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) + real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) + real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) + real :: cmax(npz) + real :: c_global + real :: frac, rdt + integer :: ksplt(npz) + integer :: nsplt + integer :: i,j,k,it,iq + + real, pointer, dimension(:,:) :: area, rarea + real, pointer, dimension(:,:,:) :: sin_sg + real, pointer, dimension(:,:) :: dxa, dya, dx, dy + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + area => gridstruct%area + rarea => gridstruct%rarea + + sin_sg => gridstruct%sin_sg + dxa => gridstruct%dxa + dya => gridstruct%dya + dx => gridstruct%dx + dy => gridstruct%dy + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, & +!$OMP sin_sg,cy,yfx,dya,dx,cmax,q_split,ksplt) + do k=1,npz + do j=jsd,jed + do i=is,ie+1 + if (cx(i,j,k) > 0.) then + xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3) + else + xfx(i,j,k) = cx(i,j,k)*dxa(i,j)*dy(i,j)*sin_sg(i,j,1) + endif + enddo + enddo + do j=js,je+1 + do i=isd,ied + if (cy(i,j,k) > 0.) then + yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4) + else + yfx(i,j,k) = cy(i,j,k)*dya(i,j)*dx(i,j)*sin_sg(i,j,2) + endif + enddo + enddo + + if ( q_split == 0 ) then + cmax(k) = 0. + if ( k < npz/6 ) then + do j=js,je + do i=is,ie + cmax(k) = max( cmax(k), abs(cx(i,j,k)), abs(cy(i,j,k)) ) + enddo + enddo + else + do j=js,je + do i=is,ie + cmax(k) = max( cmax(k), max(abs(cx(i,j,k)),abs(cy(i,j,k)))+1.-sin_sg(i,j,5) ) + enddo + enddo + endif + endif + ksplt(k) = 1 + + enddo + +!-------------------------------------------------------------------------------- + +! Determine global nsplt: + if ( q_split == 0 ) then + call mp_reduce_max(cmax,npz) +! find global max courant number and define nsplt to scale cx,cy,mfx,mfy + c_global = cmax(1) + if ( npz /= 1 ) then ! if NOT shallow water test case + do k=2,npz + c_global = max(cmax(k), c_global) + enddo + endif + nsplt = int(1. + c_global) + if ( is_master() .and. nsplt > 4 ) write(*,*) 'Tracer_2d_split=', nsplt, c_global + else + nsplt = q_split + endif + +!-------------------------------------------------------------------------------- + + if( nsplt /= 1 ) then +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,mfx,cy,yfx,mfy,cmax,nsplt,ksplt) & +!$OMP private( frac ) + do k=1,npz + +#ifdef GLOBAL_CFL + ksplt(k) = nsplt +#else + ksplt(k) = int(1. + cmax(k)) +#endif + frac = 1. / real(ksplt(k)) + + do j=jsd,jed + do i=is,ie+1 + cx(i,j,k) = cx(i,j,k) * frac + xfx(i,j,k) = xfx(i,j,k) * frac + enddo + enddo + do j=js,je + do i=is,ie+1 + mfx(i,j,k) = mfx(i,j,k) * frac + enddo + enddo + + do j=js,je+1 + do i=isd,ied + cy(i,j,k) = cy(i,j,k) * frac + yfx(i,j,k) = yfx(i,j,k) * frac + enddo + enddo + do j=js,je+1 + do i=is,ie + mfy(i,j,k) = mfy(i,j,k) * frac + enddo + enddo + + enddo + endif + + do it=1,nsplt + call timing_on('COMM_TOTAL') + call timing_on('COMM_TRACER') + call complete_group_halo_update(q_pack, domain) + call timing_off('COMM_TRACER') + call timing_off('COMM_TOTAL') + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq,ksplt,& +!$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm,lim_fac) & +!$OMP private(dp2, ra_x, ra_y, fx, fy) + do k=1,npz + + if ( it .le. ksplt(k) ) then + + do j=js,je + do i=is,ie + dp2(i,j) = dp1(i,j,k) + (mfx(i,j,k)-mfx(i+1,j,k)+mfy(i,j,k)-mfy(i,j+1,k))*rarea(i,j) + enddo + enddo + + do j=jsd,jed + do i=is,ie + ra_x(i,j) = area(i,j) + xfx(i,j,k) - xfx(i+1,j,k) + enddo + enddo + do j=js,je + do i=isd,ied + ra_y(i,j) = area(i,j) + yfx(i,j,k) - yfx(i,j+1,k) + enddo + enddo + + do iq=1,nq + if ( it==1 .and. trdm>1.e-4 ) then + call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & + npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & + gridstruct, bd, ra_x, ra_y, lim_fac, mfx=mfx(is,js,k), mfy=mfy(is,js,k), & + mass=dp1(isd,jsd,k), nord=nord_tr, damp_c=trdm) + else + call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & + npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & + gridstruct, bd, ra_x, ra_y, lim_fac, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) + endif + do j=js,je + do i=is,ie + q(i,j,k,iq) = ( q(i,j,k,iq)*dp1(i,j,k) + & + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) )/dp2(i,j) + enddo + enddo + enddo + + if ( it /= nsplt ) then + do j=js,je + do i=is,ie + dp1(i,j,k) = dp2(i,j) + enddo + enddo + endif + + endif ! ksplt + + enddo ! npz + + if ( it /= nsplt ) then + call timing_on('COMM_TOTAL') + call timing_on('COMM_TRACER') + call start_group_halo_update(q_pack, q, domain) + call timing_off('COMM_TRACER') + call timing_off('COMM_TOTAL') + endif + + enddo ! nsplt + + +end subroutine tracer_2d + + +subroutine tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, & + nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, & + k_split, neststruct, parent_grid, n_map, lim_fac) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npx + integer, intent(IN) :: npy + integer, intent(IN) :: npz + integer, intent(IN) :: nq !< number of tracers to be advected + integer, intent(IN) :: hord, nord_tr + integer, intent(IN) :: q_split, k_split, n_map + integer, intent(IN) :: id_divg + real , intent(IN) :: dt, trdm + real , intent(IN) :: lim_fac + type(group_halo_update_type), intent(inout) :: q_pack + real , intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq) !< Tracers + real , intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz) !< DELP before dyn_core + real , intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz) !< Mass Flux X-Dir + real , intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz) !< Mass Flux Y-Dir + real , intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) !< Courant Number X-Dir + real , intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz) !< Courant Number Y-Dir + type(fv_grid_type), intent(IN), target :: gridstruct + type(fv_nest_type), intent(INOUT) :: neststruct + type(fv_atmos_type), pointer, intent(IN) :: parent_grid + type(domain2d), intent(INOUT) :: domain + +! Local Arrays + real :: dp2(bd%is:bd%ie,bd%js:bd%je) + real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) + real :: fy(bd%is:bd%ie , bd%js:bd%je+1) + real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) + real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) + real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz) + real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz) + real :: cmax(npz) + real :: cmax_t + real :: c_global + real :: frac, rdt + real :: recip_nsplt, reg_bc_update_time + integer :: nsplt, nsplt_parent, msg_split_steps = 1 + integer :: i,j,k,it,iq + + real, pointer, dimension(:,:) :: area, rarea + real, pointer, dimension(:,:,:) :: sin_sg + real, pointer, dimension(:,:) :: dxa, dya, dx, dy + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + area => gridstruct%area + rarea => gridstruct%rarea + + sin_sg => gridstruct%sin_sg + dxa => gridstruct%dxa + dya => gridstruct%dya + dx => gridstruct%dx + dy => gridstruct%dy + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, & +!$OMP sin_sg,cy,yfx,dya,dx) + do k=1,npz + do j=jsd,jed + do i=is,ie+1 + if (cx(i,j,k) > 0.) then + xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3) + else + xfx(i,j,k) = cx(i,j,k)*dxa(i,j)*dy(i,j)*sin_sg(i,j,1) + endif + enddo + enddo + do j=js,je+1 + do i=isd,ied + if (cy(i,j,k) > 0.) then + yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4) + else + yfx(i,j,k) = cy(i,j,k)*dya(i,j)*dx(i,j)*sin_sg(i,j,2) + endif + enddo + enddo + enddo + +!-------------------------------------------------------------------------------- + if ( q_split == 0 ) then +! Determine nsplt + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,cmax,cx,cy,sin_sg) & +!$OMP private(cmax_t ) + do k=1,npz + cmax(k) = 0. + if ( k < 4 ) then +! Top layers: C < max( abs(c_x), abs(c_y) ) + do j=js,je + do i=is,ie + cmax_t = max( abs(cx(i,j,k)), abs(cy(i,j,k)) ) + cmax(k) = max( cmax_t, cmax(k) ) + enddo + enddo + else + do j=js,je + do i=is,ie + cmax_t = max(abs(cx(i,j,k)), abs(cy(i,j,k))) + 1.-sin_sg(i,j,5) + cmax(k) = max( cmax_t, cmax(k) ) + enddo + enddo + endif + enddo + call mp_reduce_max(cmax,npz) + +! find global max courant number and define nsplt to scale cx,cy,mfx,mfy + c_global = cmax(1) + if ( npz /= 1 ) then ! if NOT shallow water test case + do k=2,npz + c_global = max(cmax(k), c_global) + enddo + endif + nsplt = int(1. + c_global) + if ( is_master() .and. nsplt > 3 ) write(*,*) 'Tracer_2d_split=', nsplt, c_global + else + nsplt = q_split + if (gridstruct%nested .and. neststruct%nestbctype > 1) msg_split_steps = max(q_split/parent_grid%flagstruct%q_split,1) + endif + +!-------------------------------------------------------------------------------- + + frac = 1. / real(nsplt) + recip_nsplt = 1. / real(nsplt) + + if( nsplt /= 1 ) then +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,frac,xfx,mfx,cy,yfx,mfy) + do k=1,npz + do j=jsd,jed + do i=is,ie+1 + cx(i,j,k) = cx(i,j,k) * frac + xfx(i,j,k) = xfx(i,j,k) * frac + enddo + enddo + do j=js,je + do i=is,ie+1 + mfx(i,j,k) = mfx(i,j,k) * frac + enddo + enddo + + do j=js,je+1 + do i=isd,ied + cy(i,j,k) = cy(i,j,k) * frac + yfx(i,j,k) = yfx(i,j,k) * frac + enddo + enddo + + do j=js,je+1 + do i=is,ie + mfy(i,j,k) = mfy(i,j,k) * frac + enddo + enddo + enddo + endif + + + do it=1,nsplt + if ( gridstruct%nested ) then + neststruct%tracer_nest_timestep = neststruct%tracer_nest_timestep + 1 + end if + call timing_on('COMM_TOTAL') + call timing_on('COMM_TRACER') + call complete_group_halo_update(q_pack, domain) + call timing_off('COMM_TRACER') + call timing_off('COMM_TOTAL') + + if (gridstruct%nested) then + do iq=1,nq + call nested_grid_BC_apply_intT(q(isd:ied,jsd:jed,:,iq), & + 0, 0, npx, npy, npz, bd, & + real(neststruct%tracer_nest_timestep)+real(nsplt*k_split), real(nsplt*k_split), & + neststruct%q_BC(iq), bctype=neststruct%nestbctype ) + enddo + endif + + if (gridstruct%regional) then + reg_bc_update_time=current_time_in_seconds+ (real(n_map-1) + real(it-1)*recip_nsplt)*dt !<-- dt is the k_split timestep length + do iq=1,nq + call regional_boundary_update(q(:,:,:,iq), 'q', & + isd, ied, jsd, jed, npz, & + is, ie, js, je, & + isd, ied, jsd, jed, & + reg_bc_update_time, & + iq ) + enddo + endif + + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq, & +!$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm,lim_fac) & +!$OMP private(dp2, ra_x, ra_y, fx, fy) + do k=1,npz + + do j=js,je + do i=is,ie + dp2(i,j) = dp1(i,j,k) + (mfx(i,j,k)-mfx(i+1,j,k)+mfy(i,j,k)-mfy(i,j+1,k))*rarea(i,j) + enddo + enddo + + do j=jsd,jed + do i=is,ie + ra_x(i,j) = area(i,j) + xfx(i,j,k) - xfx(i+1,j,k) + enddo + enddo + do j=js,je + do i=isd,ied + ra_y(i,j) = area(i,j) + yfx(i,j,k) - yfx(i,j+1,k) + enddo + enddo + + do iq=1,nq + if ( it==1 .and. trdm>1.e-4 ) then + call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & + npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & + gridstruct, bd, ra_x, ra_y, lim_fac, mfx=mfx(is,js,k), mfy=mfy(is,js,k), & + mass=dp1(isd,jsd,k), nord=nord_tr, damp_c=trdm) + else + call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), & + npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), & + gridstruct, bd, ra_x, ra_y, lim_fac, mfx=mfx(is,js,k), mfy=mfy(is,js,k)) + endif + do j=js,je + do i=is,ie + q(i,j,k,iq) = ( q(i,j,k,iq)*dp1(i,j,k) + & + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) )/dp2(i,j) + enddo + enddo + enddo + enddo ! npz + + if ( it /= nsplt ) then + call timing_on('COMM_TOTAL') + call timing_on('COMM_TRACER') + call start_group_halo_update(q_pack, q, domain) + call timing_off('COMM_TRACER') + call timing_off('COMM_TOTAL') + endif + + enddo ! nsplt + + if ( id_divg > 0 ) then + rdt = 1./(frac*dt) + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,xfx,yfx,rarea,rdt) + do k=1,npz + do j=js,je + do i=is,ie + dp1(i,j,k) = (xfx(i+1,j,k)-xfx(i,j,k) + yfx(i,j+1,k)-yfx(i,j,k))*rarea(i,j)*rdt + enddo + enddo + enddo + endif + + end subroutine tracer_2d_nested + +end module fv_tracer2d_mod diff --git a/model/fv_update_phys.F90 b/model/fv_update_phys.F90 index d588f6c2e..8b529d8d3 100644 --- a/model/fv_update_phys.F90 +++ b/model/fv_update_phys.F90 @@ -89,22 +89,22 @@ module fv_update_phys_mod ! ! - use constants_mod, only: kappa, rdgas, rvgas, grav, cp_air, cp_vapor, pi=>pi_8, radius + use constants_mod, only: kappa, rdgas, rvgas, grav, cp_air, cp_vapor, pi=>pi_8, radius, TFREEZE use field_manager_mod, only: MODEL_ATMOS use mpp_domains_mod, only: mpp_update_domains, domain2d use mpp_parameter_mod, only: AGRID_PARAM=>AGRID use mpp_mod, only: FATAL, mpp_error - use mpp_mod, only: mpp_error, NOTE, WARNING + use mpp_mod, only: mpp_error, NOTE, WARNING, mpp_pe use time_manager_mod, only: time_type use tracer_manager_mod, only: get_tracer_index, adjust_mass, get_tracer_names use fv_mp_mod, only: start_group_halo_update, complete_group_halo_update use fv_mp_mod, only: group_halo_update_type - use fv_arrays_mod, only: fv_flags_type, fv_nest_type, R_GRID + use fv_arrays_mod, only: fv_flags_type, fv_nest_type, R_GRID, phys_diag_type use boundary_mod, only: nested_grid_BC use boundary_mod, only: extrapolation_BC use fv_eta_mod, only: get_eta_level use fv_timing_mod, only: timing_on, timing_off - use fv_diagnostics_mod, only: prt_maxmin + use fv_diagnostics_mod, only: prt_maxmin, range_check use fv_mapz_mod, only: moist_cv, moist_cp #if defined (ATMOS_NUDGE) use atmos_nudge_mod, only: get_atmos_nudge, do_ps @@ -116,7 +116,9 @@ module fv_update_phys_mod use fv_nwp_nudge_mod, only: fv_nwp_nudge #endif use fv_arrays_mod, only: fv_grid_type, fv_nest_type, fv_grid_bounds_type - use fv_grid_utils_mod, only: cubed_to_latlon + use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys, update2d_dwinds_phys + use fv_nesting_mod, only: set_physics_BCs + use sat_vapor_pres_mod, only: tcmin, tcmax #ifdef MULTI_GASES use multi_gases_mod, only: virq, virqd, vicpqd, vicvqd, num_gas #endif @@ -124,10 +126,6 @@ module fv_update_phys_mod implicit none public :: fv_update_phys, del2_phys -#ifdef ROT3 - public :: update_dwinds_phys -#endif - real,parameter:: con_cp = cp_air contains @@ -137,7 +135,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, ak, bk, phis, u_srf, v_srf, ts, delz, hydrostatic, & u_dt, v_dt, t_dt, moist_phys, Time, nudge, & gridstruct, lona, lata, npx, npy, npz, flagstruct, & - neststruct, bd, domain, ptop, q_dt) + neststruct, bd, domain, ptop, phys_diag, q_dt) real, intent(in) :: dt, ptop integer, intent(in):: is, ie, js, je, ng integer, intent(in):: isd, ied, jsd, jed @@ -151,7 +149,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, real, intent(in), dimension(npz+1):: ak, bk real, intent(in) :: phis(isd:ied,jsd:jed) - real, intent(inout):: delz(isd:,jsd:,1:) + real, intent(inout):: delz(is:,js:,1:) ! optional arguments for atmospheric nudging real, intent(in), dimension(isd:ied,jsd:jed), optional :: & @@ -165,6 +163,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt real, intent(inout):: t_dt(is:ie,js:je,npz) real, intent(inout), optional :: q_dt(is:ie,js:je,npz,nq) + type(phys_diag_type), intent(inout) :: phys_diag ! Saved Bottom winds for GFDL Physics Interface real, intent(out), dimension(is:ie,js:je):: u_srf, v_srf, ts @@ -194,6 +193,8 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, type(fv_grid_type) :: gridstruct type(fv_nest_type) :: neststruct + real :: q_dt_nudge(is:ie,js:je,npz,nq) + integer, intent(IN) :: npx, npy, npz !*********** @@ -220,9 +221,8 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, integer sphum, liq_wat, ice_wat, cld_amt ! GFDL AM physics integer rainwat, snowwat, graupel ! GFDL Cloud Microphysics integer w_diff ! w-tracer for PBL diffusion - real:: qstar, dbk, rdg, zvir, p_fac, cv_air, gama_dt - - real, dimension(1,1,1) :: parent_u_dt, parent_v_dt ! dummy variables for nesting + real:: qstar, dbk, rdg, zvir, p_fac, cv_air, gama_dt, tbad + logical :: bad_range !f1p !account for change in air molecular weight because of H2O change @@ -245,15 +245,15 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, !f1p conv_vmr_mmr(1:nq) = .false. if (flagstruct%adj_mass_vmr) then - do m=1,nq - call get_tracer_names (MODEL_ATMOS, m, name = tracer_name, & - units = tracer_units) - if ( trim(tracer_units) .eq. 'vmr' ) then + do m=1,nq + call get_tracer_names (MODEL_ATMOS, m, name = tracer_name, & + units = tracer_units) + if ( trim(tracer_units) .eq. 'vmr' ) then conv_vmr_mmr(m) = .true. - else + else conv_vmr_mmr(m) = .false. - end if - end do + end if + end do end if sphum = get_tracer_index (MODEL_ATMOS, 'sphum') @@ -290,12 +290,34 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, endif call get_eta_level(npz, 1.0E5, pfull, phalf, ak, bk) - #ifdef MULTI_GASES nm = max( nwat,num_gas) nn = max(flagstruct%nwat,num_gas) #endif + if (size(neststruct%child_grids) > 1) then + call set_physics_BCs(ps, u_dt, v_dt, flagstruct, gridstruct, neststruct, npx, npy, npz, ng, ak, bk, bd) + endif + + if (allocated(phys_diag%phys_t_dt)) phys_diag%phys_t_dt = pt(is:ie,js:je,:) + if (present(q_dt)) then + if (allocated(phys_diag%phys_qv_dt)) phys_diag%phys_qv_dt = q(is:ie,js:je,:,sphum) + if (allocated(phys_diag%phys_ql_dt)) then + if (liq_wat < 0) call mpp_error(FATAL, " phys_ql_dt needs at least one liquid water tracer defined") + phys_diag%phys_ql_dt = q(is:ie,js:je,:,liq_wat) + if (rainwat > 0) phys_diag%phys_ql_dt = q(is:ie,js:je,:,rainwat) + phys_diag%phys_ql_dt + endif + if (allocated(phys_diag%phys_qi_dt)) then + if (ice_wat < 0) then + call mpp_error(WARNING, " phys_qi_dt needs at least one ice water tracer defined") + phys_diag%phys_qi_dt = 0. + endif + phys_diag%phys_qi_dt = q(is:ie,js:je,:,ice_wat) + if (snowwat > 0) phys_diag%phys_qi_dt = q(is:ie,js:je,:,snowwat) + phys_diag%phys_qi_dt + if (graupel > 0) phys_diag%phys_qi_dt = q(is:ie,js:je,:,graupel) + phys_diag%phys_qi_dt + endif + endif + !$OMP parallel do default(none) & !$OMP shared(is,ie,js,je,npz,flagstruct,pfull,q_dt,sphum,q,qdiag, & !$OMP nq,w_diff,dt,nwat,liq_wat,rainwat,ice_wat,snowwat, & @@ -304,8 +326,8 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, #ifdef MULTI_GASES !$OMP nn, nm, & #endif -!$OMP conv_vmr_mmr) & -!$OMP private(cvm, qc, qstar, ps_dt, p_fac) +!$OMP conv_vmr_mmr,pe,ptop,gridstruct,phys_diag) & +!$OMP private(cvm, qc, qstar, ps_dt, p_fac,tbad) do k=1, npz if (present(q_dt)) then @@ -456,7 +478,44 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, enddo #endif - enddo ! k-loop + enddo ! k-loop + + if (allocated(phys_diag%phys_t_dt)) phys_diag%phys_t_dt = (pt(is:ie,js:je,:) - phys_diag%phys_t_dt) / dt + if (present(q_dt)) then + if (allocated(phys_diag%phys_qv_dt)) phys_diag%phys_qv_dt = (q(is:ie,js:je,:,sphum) - phys_diag%phys_qv_dt) / dt + if (allocated(phys_diag%phys_ql_dt)) then + if (liq_wat < 0) call mpp_error(FATAL, " phys_ql_dt needs at least one liquid water tracer defined") + phys_diag%phys_ql_dt = q(is:ie,js:je,:,liq_wat) - phys_diag%phys_qv_dt + if (rainwat > 0) phys_diag%phys_ql_dt = q(is:ie,js:je,:,rainwat) + phys_diag%phys_ql_dt + phys_diag%phys_ql_dt = phys_diag%phys_ql_dt / dt + endif + if (allocated(phys_diag%phys_qi_dt)) then + if (ice_wat < 0) then + call mpp_error(WARNING, " phys_qi_dt needs at least one ice water tracer defined") + phys_diag%phys_qi_dt = 0. + endif + phys_diag%phys_qi_dt = q(is:ie,js:je,:,ice_wat) - phys_diag%phys_qi_dt + if (snowwat > 0) phys_diag%phys_qi_dt = q(is:ie,js:je,:,snowwat) + phys_diag%phys_qi_dt + if (graupel > 0) phys_diag%phys_qi_dt = q(is:ie,js:je,:,graupel) + phys_diag%phys_qi_dt + phys_diag%phys_qi_dt = phys_diag%phys_qi_dt / dt + endif + endif + + if ( flagstruct%range_warn ) then + call range_check('PT UPDATE', pt, is, ie, js, je, ng, npz, gridstruct%agrid, & + tcmin+TFREEZE, tcmax+TFREEZE, bad_range, Time) + if (bad_range) then + do k=1,npz + do j=js,je + do i=is,ie + if (pt(i,j,k) < tcmin+TFREEZE .or. pt(i,j,k) > tcmax+TFREEZE) then + write(*,*) 'PT UPDATE: ', t_dt(i,j,k)*dt, i,j,k, gridstruct%agrid(i,j,:) + endif + enddo + enddo + enddo + endif + endif ! [delp, (ua, va), pt, q] updated. Perform nudging if requested !------- nudging of atmospheric variables toward specified data -------- @@ -472,8 +531,8 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, npz, ng, ps(is:ie,js:je), ua(is:ie, js:je,:), & va(is:ie,js:je,:), pt(is:ie,js:je,:), & q(is:ie,js:je,:,:), ps_dt(is:ie,js:je), u_dt(is:ie,js:je,:), & - v_dt(is:ie,js:je,:), t_dt(is:ie,js:je,:), & - q_dt(is:ie,js:je,:,:) ) + v_dt(is:ie,js:je,:), t_dt(is:ie,js:je,:), & + q_dt_nudge(is:ie,js:je,:,:) ) !-------------- ! Update delp @@ -500,7 +559,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, pt(is:ie,js:je,:), q(is:ie,js:je,:,sphum:sphum), & ps_dt(is:ie,js:je), u_dt(is:ie,js:je,:), & v_dt(is:ie,js:je,:), t_dt(is:ie,js:je,:), & - q_dt(is:ie,js:je,:,sphum:sphum) ) + q_dt_nudge(is:ie,js:je,:,sphum:sphum) ) !-------------- ! Update delp @@ -529,7 +588,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, ps(i,j) = pe(i,npz+1,j) enddo enddo - call fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, & + call fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt_nudge, & zvir, ptop, ak, bk, ts, ps, delp, ua, va, pt, & nwat, q, phis, gridstruct, bd, domain ) #else @@ -545,10 +604,11 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, ps(i,j) = pe(i,npz+1,j) enddo enddo - call fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, & + call fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt_nudge, & zvir, ptop, ak, bk, ts, ps, delp, ua, va, pt, & nwat, q, phis, gridstruct, bd, domain ) #endif + endif ! end nudging if ( .not.flagstruct%dwind_2d ) then @@ -616,21 +676,6 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, call complete_group_halo_update(i_pack(1), domain) - if (size(neststruct%child_grids) > 1) then - if (gridstruct%nested) then - call nested_grid_BC(u_dt, parent_u_dt, neststruct%nest_domain, neststruct%ind_h, neststruct%wt_h, 0, 0, & - npx, npy, npz, bd, 1, npx-1, 1, npy-1) - call nested_grid_BC(v_dt, parent_v_dt, neststruct%nest_domain, neststruct%ind_h, neststruct%wt_h, 0, 0, & - npx, npy, npz, bd, 1, npx-1, 1, npy-1) - endif - do n=1,size(neststruct%child_grids) - if (neststruct%child_grids(n)) then - call nested_grid_BC(u_dt, neststruct%nest_domain_all(n), 0, 0) - call nested_grid_BC(v_dt, neststruct%nest_domain_all(n), 0, 0) - endif - enddo - endif - call timing_off('COMM_TOTAL') ! ! for regional grid need to set values for u_dt and v_dt at the edges. @@ -697,13 +742,32 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, call timing_off(' Update_dwinds') #ifdef GFS_PHYS call cubed_to_latlon(u, v, ua, va, gridstruct, & - npx, npy, npz, 1, gridstruct%grid_type, domain, gridstruct%nested, flagstruct%c2l_ord, bd) + npx, npy, npz, 1, gridstruct%grid_type, domain, gridstruct%bounded_domain, flagstruct%c2l_ord, bd) #endif if ( flagstruct%fv_debug ) then call prt_maxmin('PS_a_update', ps, is, ie, js, je, ng, 1, 0.01) endif + if (allocated(phys_diag%phys_u_dt)) then + do k=1,npz + do j=js,je + do i=is,ie + phys_diag%phys_u_dt(i,j,k) = u_dt(i,j,k) + enddo + enddo + enddo + endif + if (allocated(phys_diag%phys_v_dt)) then + do k=1,npz + do j=js,je + do i=is,ie + phys_diag%phys_v_dt(i,j,k) = v_dt(i,j,k) + enddo + enddo + enddo + endif + end subroutine fv_update_phys !>@brief The subroutine 'del2_phys' is for filtering the physics tendency. @@ -779,15 +843,15 @@ subroutine del2_phys(qdt, delp, gridstruct, cd, npx, npy, km, is, ie, js, je, & (mask(i,j)+mask(i,j+1))*dy(i,j)*sina_u(i,j)* & (q(i-1,j,k)-q(i,j,k))*rdxc(i,j) enddo - if (is == 1 .and. .not. gridstruct%nested) fx(i,j) = & + if (is == 1 .and. .not. gridstruct%bounded_domain) fx(i,j) = & (mask(is,j)+mask(is,j+1))*dy(is,j)*(q(is-1,j,k)-q(is,j,k))*rdxc(is,j)* & 0.5*(sin_sg(1,j,1) + sin_sg(0,j,3)) - if (ie+1==npx .and. .not. gridstruct%nested) fx(i,j) = & + if (ie+1==npx .and. .not. gridstruct%bounded_domain) fx(i,j) = & (mask(ie+1,j)+mask(ie+1,j+1))*dy(ie+1,j)*(q(ie,j,k)-q(ie+1,j,k))*rdxc(ie+1,j)* & 0.5*(sin_sg(npx,j,1) + sin_sg(npx-1,j,3)) enddo do j=js,je+1 - if ((j == 1 .OR. j == npy) .and. .not. gridstruct%nested) then + if ((j == 1 .OR. j == npy) .and. .not. gridstruct%bounded_domain) then do i=is,ie fy(i,j) = (mask(i,j)+mask(i+1,j))*dx(i,j)*& (q(i,j-1,k)-q(i,j,k))*rdyc(i,j) & @@ -809,337 +873,4 @@ subroutine del2_phys(qdt, delp, gridstruct, cd, npx, npy, km, is, ie, js, je, & end subroutine del2_phys -!>@brief The subroutine 'update_dwinds_phys' transforms the wind tendencies from -!! the A grid to the D grid for the final update. - subroutine update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v, gridstruct, npx, npy, npz, domain) - -! Purpose; Transform wind tendencies on A grid to D grid for the final update - - integer, intent(in) :: is, ie, js, je - integer, intent(in) :: isd, ied, jsd, jed - integer, intent(IN) :: npx,npy, npz - real, intent(in) :: dt - real, intent(inout) :: u(isd:ied, jsd:jed+1,npz) - real, intent(inout) :: v(isd:ied+1,jsd:jed ,npz) - real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - -! local: - real v3(is-1:ie+1,js-1:je+1,3) - real ue(is-1:ie+1,js:je+1,3) !< 3D winds at edges - real ve(is:ie+1,js-1:je+1,3) !< 3D winds at edges - real, dimension(is:ie) :: ut1, ut2, ut3 - real, dimension(js:je) :: vt1, vt2, vt3 - real dt5, gratio - integer i, j, k, m, im2, jm2 - - real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat - real(kind=R_GRID), pointer, dimension(:,:,:,:) :: es, ew - real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n - - es => gridstruct%es - ew => gridstruct%ew - vlon => gridstruct%vlon - vlat => gridstruct%vlat - - edge_vect_w => gridstruct%edge_vect_w - edge_vect_e => gridstruct%edge_vect_e - edge_vect_s => gridstruct%edge_vect_s - edge_vect_n => gridstruct%edge_vect_n - - dt5 = 0.5 * dt - im2 = (npx-1)/2 - jm2 = (npy-1)/2 - -!$OMP parallel do default(none) shared(is,ie,js,je,npz,gridstruct,u,dt5,u_dt,v,v_dt, & -!$OMP vlon,vlat,jm2,edge_vect_w,npx,edge_vect_e,im2, & -!$OMP edge_vect_s,npy,edge_vect_n,es,ew) & -!$OMP private(ut1, ut2, ut3, vt1, vt2, vt3, ue, ve, v3) - do k=1, npz - - if ( gridstruct%grid_type > 3 ) then ! Local & one tile configurations - - do j=js,je+1 - do i=is,ie - u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k)) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k)) - enddo - enddo - - else -! Compute 3D wind tendency on A grid - do j=js-1,je+1 - do i=is-1,ie+1 - v3(i,j,1) = u_dt(i,j,k)*vlon(i,j,1) + v_dt(i,j,k)*vlat(i,j,1) - v3(i,j,2) = u_dt(i,j,k)*vlon(i,j,2) + v_dt(i,j,k)*vlat(i,j,2) - v3(i,j,3) = u_dt(i,j,k)*vlon(i,j,3) + v_dt(i,j,k)*vlat(i,j,3) - enddo - enddo - -! Interpolate to cell edges - do j=js,je+1 - do i=is-1,ie+1 - ue(i,j,1) = v3(i,j-1,1) + v3(i,j,1) - ue(i,j,2) = v3(i,j-1,2) + v3(i,j,2) - ue(i,j,3) = v3(i,j-1,3) + v3(i,j,3) - enddo - enddo - - do j=js-1,je+1 - do i=is,ie+1 - ve(i,j,1) = v3(i-1,j,1) + v3(i,j,1) - ve(i,j,2) = v3(i-1,j,2) + v3(i,j,2) - ve(i,j,3) = v3(i-1,j,3) + v3(i,j,3) - enddo - enddo - -! --- E_W edges (for v-wind): - if ( is==1 .and. .not. (gridstruct%nested .or. gridstruct%regional)) then - i = 1 - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_w(j)*ve(i,j-1,1) + (1.-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j-1,2) + (1.-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j-1,3) + (1.-edge_vect_w(j))*ve(i,j,3) - else - vt1(j) = edge_vect_w(j)*ve(i,j+1,1) + (1.-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j+1,2) + (1.-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j+1,3) + (1.-edge_vect_w(j))*ve(i,j,3) - endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif - if ( (ie+1)==npx .and. .not. (gridstruct%nested .or. gridstruct%regional)) then - i = npx - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_e(j)*ve(i,j-1,1) + (1.-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j-1,2) + (1.-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j-1,3) + (1.-edge_vect_e(j))*ve(i,j,3) - else - vt1(j) = edge_vect_e(j)*ve(i,j+1,1) + (1.-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j+1,2) + (1.-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j+1,3) + (1.-edge_vect_e(j))*ve(i,j,3) - endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif -! N-S edges (for u-wind): - if ( js==1 .and. .not. (gridstruct%nested .or. gridstruct%regional)) then - j = 1 - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_s(i)*ue(i-1,j,1) + (1.-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i-1,j,2) + (1.-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i-1,j,3) + (1.-edge_vect_s(i))*ue(i,j,3) - else - ut1(i) = edge_vect_s(i)*ue(i+1,j,1) + (1.-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i+1,j,2) + (1.-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i+1,j,3) + (1.-edge_vect_s(i))*ue(i,j,3) - endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - if ( (je+1)==npy .and. .not. (gridstruct%nested .or. gridstruct%regional)) then - j = npy - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_n(i)*ue(i-1,j,1) + (1.-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i-1,j,2) + (1.-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i-1,j,3) + (1.-edge_vect_n(i))*ue(i,j,3) - else - ut1(i) = edge_vect_n(i)*ue(i+1,j,1) + (1.-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i+1,j,2) + (1.-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i+1,j,3) + (1.-edge_vect_n(i))*ue(i,j,3) - endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - do j=js,je+1 - do i=is,ie - u(i,j,k) = u(i,j,k) + dt5*( ue(i,j,1)*es(1,i,j,1) + & - ue(i,j,2)*es(2,i,j,1) + & - ue(i,j,3)*es(3,i,j,1) ) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j,k) = v(i,j,k) + dt5*( ve(i,j,1)*ew(1,i,j,2) + & - ve(i,j,2)*ew(2,i,j,2) + & - ve(i,j,3)*ew(3,i,j,2) ) - enddo - enddo -! Update: - endif ! end grid_type - - enddo ! k-loop - - end subroutine update_dwinds_phys - -!>@brief The subroutine 'update2d_dwinds_phys' transforms the wind tendencies from -!! the A grid to the D grid for the final update. - subroutine update2d_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v, gridstruct, npx, npy, npz, domain) - -! Purpose; Transform wind tendencies on A grid to D grid for the final update - - integer, intent(in):: is, ie, js, je - integer, intent(in):: isd, ied, jsd, jed - real, intent(in):: dt - real, intent(inout):: u(isd:ied, jsd:jed+1,npz) - real, intent(inout):: v(isd:ied+1,jsd:jed ,npz) - real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt - type(fv_grid_type), intent(IN), target :: gridstruct - integer, intent(IN) :: npx,npy, npz - type(domain2d), intent(INOUT) :: domain - -! local: - real ut(isd:ied,jsd:jed) - real:: dt5, gratio - integer i, j, k - - real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat - real(kind=R_GRID), pointer, dimension(:,:,:,:) :: es, ew - real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n - real, pointer, dimension(:,:) :: z11, z12, z21, z22, dya, dxa - - es => gridstruct%es - ew => gridstruct%ew - vlon => gridstruct%vlon - vlat => gridstruct%vlat - - edge_vect_w => gridstruct%edge_vect_w - edge_vect_e => gridstruct%edge_vect_e - edge_vect_s => gridstruct%edge_vect_s - edge_vect_n => gridstruct%edge_vect_n - - z11 => gridstruct%z11 - z21 => gridstruct%z21 - z12 => gridstruct%z12 - z22 => gridstruct%z22 - - dxa => gridstruct%dxa - dya => gridstruct%dya - -! Transform wind tendency on A grid to local "co-variant" components: - -!$OMP parallel do default(none) shared(is,ie,js,je,npz,z11,u_dt,z12,v_dt,z21,z22) & -!$OMP private(ut) - do k=1,npz - do j=js,je - do i=is,ie - ut(i,j) = z11(i,j)*u_dt(i,j,k) + z12(i,j)*v_dt(i,j,k) - v_dt(i,j,k) = z21(i,j)*u_dt(i,j,k) + z22(i,j)*v_dt(i,j,k) - u_dt(i,j,k) = ut(i,j) - enddo - enddo - enddo -! (u_dt,v_dt) are now on local coordinate system - call timing_on('COMM_TOTAL') - call mpp_update_domains(u_dt, v_dt, domain, gridtype=AGRID_PARAM) - call timing_off('COMM_TOTAL') - - dt5 = 0.5 * dt - -!$OMP parallel do default(none) shared(is,ie,js,je,npz,gridstruct,u,dt5,u_dt,v,v_dt, & -!$OMP dya,npy,dxa,npx) & -!$OMP private(gratio) - do k=1, npz - - if ( gridstruct%grid_type > 3 .or. gridstruct%nested) then ! Local & one tile configurations - - do j=js,je+1 - do i=is,ie - u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k)) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k)) - enddo - enddo - - else - -!-------- -! u-wind -!-------- -! Edges: - if ( js==1 ) then - do i=is,ie - gratio = dya(i,2) / dya(i,1) - u(i,1,k) = u(i,1,k) + dt5*((2.+gratio)*(u_dt(i,0,k)+u_dt(i,1,k)) & - -(u_dt(i,-1,k)+u_dt(i,2,k)))/(1.+gratio) - enddo - endif - -! Interior - do j=max(2,js),min(npy-1,je+1) - do i=is,ie - u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k)+u_dt(i,j,k)) - enddo - enddo - - if ( (je+1)==npy ) then - do i=is,ie - gratio = dya(i,npy-2) / dya(i,npy-1) - u(i,npy,k) = u(i,npy,k) + dt5*((2.+gratio)*(u_dt(i,npy-1,k)+u_dt(i,npy,k)) & - -(u_dt(i,npy-2,k)+u_dt(i,npy+1,k)))/(1.+gratio) - enddo - endif - -!-------- -! v-wind -!-------- -! West Edges: - if ( is==1 ) then - do j=js,je - gratio = dxa(2,j) / dxa(1,j) - v(1,j,k) = v(1,j,k) + dt5*((2.+gratio)*(v_dt(0,j,k)+v_dt(1,j,k)) & - -(v_dt(-1,j,k)+v_dt(2,j,k)))/(1.+gratio) - enddo - endif - -! Interior - do j=js,je - do i=max(2,is),min(npx-1,ie+1) - v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k)+v_dt(i,j,k)) - enddo - enddo - -! East Edges: - if ( (ie+1)==npx ) then - do j=js,je - gratio = dxa(npx-2,j) / dxa(npx-1,j) - v(npx,j,k) = v(npx,j,k) + dt5*((2.+gratio)*(v_dt(npx-1,j,k)+v_dt(npx,j,k)) & - -(v_dt(npx-2,j,k)+v_dt(npx+1,j,k)))/(1.+gratio) - enddo - endif - - endif ! end grid_type - - enddo ! k-loop - - end subroutine update2d_dwinds_phys - end module fv_update_phys_mod diff --git a/model/multi_gases.F90 b/model/multi_gases.F90 index 71d02bbef..9ee0fdd67 100644 --- a/model/multi_gases.F90 +++ b/model/multi_gases.F90 @@ -36,8 +36,10 @@ module multi_gases_mod ! ! - use constants_mod, only: rdgas, cp_air + use constants_mod, only: rdgas, rvgas, cp_air use fv_mp_mod, only: is_master + use mpp_mod, only: stdlog, input_nml_file + use fms_mod, only: check_nml_error, open_namelist_file, close_file implicit none @@ -53,7 +55,7 @@ module multi_gases_mod private num_wat, sphum, sphump1 public vir, vicp, vicv, ind_gas, num_gas - public multi_gases_init + public multi_gases_init, read_namelist_multi_gases_nml public virq public virq_max public virqd @@ -128,6 +130,46 @@ subroutine multi_gases_init(ngas, nwat) return end subroutine multi_gases_init + subroutine read_namelist_multi_gases_nml(nml_filename,ncnst,nwat) + + character(*), intent(IN) :: nml_filename + integer, intent(IN) :: ncnst, nwat + integer :: ierr, f_unit, unit, ios + + namelist /multi_gases_nml/ ri,cpi + + unit = stdlog() + + allocate (ri(0:ncnst)) + allocate (cpi(0:ncnst)) + + ri = 0.0 + cpi = 0.0 + ri(0) = rdgas + ri(1) = rvgas + cpi(0) = cp_air + cpi(1) = 4*cp_air +#ifdef INTERNAL_FILE_NML + + ! Read multi_gases namelist + read (input_nml_file,multi_gases_nml,iostat=ios) + ierr = check_nml_error(ios,'multi_gases_nml') + +#else + ! Read multi_gases namelist + f_unit = open_namelist_file(nml_filename) + + rewind (f_unit) + read (f_unit,multi_gases_nml,iostat=ios) + ierr = check_nml_error(ios,'multi_gases_nml') + call close_file(f_unit) +#endif + write(unit, nml=multi_gases_nml) + call multi_gases_init(ncnst,nwat) + + return + end subroutine read_namelist_multi_gases_nml + ! ---------------------------------------------------------------- diff --git a/model/nh_core.F90 b/model/nh_core.F90 index 5ed69a5b8..39dfe6aae 100644 --- a/model/nh_core.F90 +++ b/model/nh_core.F90 @@ -1,4 +1,3 @@ - !*********************************************************************** !* GNU Lesser General Public License !* @@ -20,7 +19,7 @@ !* If not, see . !*********************************************************************** -!>@brief The module 'nh_core' peforms non-hydrostatic computations. +!>@brief The module 'nh_core' peforms non-hydrostatic computations include moisture effect in pt. !>@author S. J. Lin, NOAA/GFDL module nh_core_mod @@ -48,7 +47,7 @@ module nh_core_mod use constants_mod, only: rdgas, cp_air, grav use tp_core_mod, only: fv_tp_2d - use nh_utils_mod, only: update_dz_c, update_dz_d, nest_halo_nh + use nh_utils_mod, only: update_dz_c, update_dz_d, nh_bc use nh_utils_mod, only: sim_solver, sim1_solver, sim3_solver use nh_utils_mod, only: sim3p0_solver, rim_2d use nh_utils_mod, only: Riem_Solver_c @@ -56,12 +55,11 @@ module nh_core_mod implicit none private - public Riem_Solver3, Riem_Solver_c, update_dz_c, update_dz_d, nest_halo_nh + public Riem_Solver3, Riem_Solver_c, update_dz_c, update_dz_d, nh_bc real, parameter:: r3 = 1./3. CONTAINS - subroutine Riem_Solver3(ms, dt, is, ie, js, je, km, ng, & isd, ied, jsd, jed, akap, cappa, cp, & #ifdef MULTI_GASES @@ -94,7 +92,7 @@ subroutine Riem_Solver3(ms, dt, is, ie, js, je, km, ng, & real, intent(inout):: pe(is-1:ie+1,km+1,js-1:je+1) real, intent(out):: peln(is:ie,km+1,js:je) !< ln(pe) real, intent(out), dimension(isd:ied,jsd:jed,km+1):: ppe - real, intent(out):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(out):: delz(is:ie,js:je,km) real, intent(out):: pk(is:ie,js:je,km+1) real, intent(out):: pk3(isd:ied,jsd:jed,km+1) ! Local: diff --git a/model/nh_utils.F90 b/model/nh_utils.F90 index 369d5a0fc..c6ada26c0 100644 --- a/model/nh_utils.F90 +++ b/model/nh_utils.F90 @@ -1,2461 +1,2218 @@ - -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'nh_utils' peforms non-hydrostatic computations. -!>@author S. J. Lin, NOAA/GFDL - -module nh_utils_mod - -! Modules Included: -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -!
Module NameFunctions Included
constants_modrdgas, cp_air, grav
fv_arrays_modfv_grid_bounds_type, fv_grid_type
sw_core_modfill_4corners, del6_vt_flux
tp_core_modfv_tp_2d
- - use constants_mod, only: rdgas, cp_air, grav - use tp_core_mod, only: fv_tp_2d - use sw_core_mod, only: fill_4corners, del6_vt_flux - use fv_arrays_mod, only: fv_grid_bounds_type, fv_grid_type -#ifdef MULTI_GASES - use multi_gases_mod, only: vicpqd, vicvqd -#endif - - implicit none - private - - public update_dz_c, update_dz_d, nest_halo_nh - public sim_solver, sim1_solver, sim3_solver - public sim3p0_solver, rim_2d - public Riem_Solver_c - - real, parameter:: dz_min = 2. - real, parameter:: r3 = 1./3. - -CONTAINS - - subroutine update_dz_c(is, ie, js, je, km, ng, dt, dp0, zs, area, ut, vt, gz, ws, & - npx, npy, sw_corner, se_corner, ne_corner, nw_corner, bd, grid_type) -! !INPUT PARAMETERS: - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: is, ie, js, je, ng, km, npx, npy, grid_type - logical, intent(IN):: sw_corner, se_corner, ne_corner, nw_corner - real, intent(in):: dt - real, intent(in):: dp0(km) - real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: ut, vt - real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng):: area - real, intent(inout):: gz(is-ng:ie+ng,js-ng:je+ng,km+1) - real, intent(in ):: zs(is-ng:ie+ng, js-ng:je+ng) - real, intent( out):: ws(is-ng:ie+ng, js-ng:je+ng) -! Local Work array: - real:: gz2(is-ng:ie+ng,js-ng:je+ng) - real, dimension(is-1:ie+2,js-1:je+1):: xfx, fx - real, dimension(is-1:ie+1,js-1:je+2):: yfx, fy - real, parameter:: r14 = 1./14. - integer i, j, k - integer:: is1, ie1, js1, je1 - integer:: ie2, je2 - real:: rdt, top_ratio, bot_ratio, int_ratio -!-------------------------------------------------------------------- - - rdt = 1. / dt - - top_ratio = dp0(1 ) / (dp0( 1)+dp0(2 )) - bot_ratio = dp0(km) / (dp0(km-1)+dp0(km)) - - is1 = is - 1 - js1 = js - 1 - - ie1 = ie + 1 - je1 = je + 1 - - ie2 = ie + 2 - je2 = je + 2 - -!$OMP parallel do default(none) shared(js1,je1,is1,ie2,km,je2,ie1,ut,top_ratio,vt, & -!$OMP bot_ratio,dp0,js,je,ng,is,ie,gz,grid_type, & -!$OMP bd,npx,npy,sw_corner,se_corner,ne_corner, & -!$OMP nw_corner,area) & -!$OMP private(gz2, xfx, yfx, fx, fy, int_ratio) - do 6000 k=1,km+1 - - if ( k==1 ) then - do j=js1, je1 - do i=is1, ie2 - xfx(i,j) = ut(i,j,1) + (ut(i,j,1)-ut(i,j,2))*top_ratio - enddo - enddo - do j=js1, je2 - do i=is1, ie1 - yfx(i,j) = vt(i,j,1) + (vt(i,j,1)-vt(i,j,2))*top_ratio - enddo - enddo - elseif ( k==km+1 ) then -! Bottom extrapolation - do j=js1, je1 - do i=is1, ie2 - xfx(i,j) = ut(i,j,km) + (ut(i,j,km)-ut(i,j,km-1))*bot_ratio -! xfx(i,j) = r14*(3.*ut(i,j,km-2)-13.*ut(i,j,km-1)+24.*ut(i,j,km)) -! if ( xfx(i,j)*ut(i,j,km)<0. ) xfx(i,j) = 0. - enddo - enddo - do j=js1, je2 - do i=is1, ie1 - yfx(i,j) = vt(i,j,km) + (vt(i,j,km)-vt(i,j,km-1))*bot_ratio -! yfx(i,j) = r14*(3.*vt(i,j,km-2)-13.*vt(i,j,km-1)+24.*vt(i,j,km)) -! if ( yfx(i,j)*vt(i,j,km)<0. ) yfx(i,j) = 0. - enddo - enddo - else - int_ratio = 1./(dp0(k-1)+dp0(k)) - do j=js1, je1 - do i=is1, ie2 - xfx(i,j) = (dp0(k)*ut(i,j,k-1)+dp0(k-1)*ut(i,j,k))*int_ratio - enddo - enddo - do j=js1, je2 - do i=is1, ie1 - yfx(i,j) = (dp0(k)*vt(i,j,k-1)+dp0(k-1)*vt(i,j,k))*int_ratio - enddo - enddo - endif - - do j=js-ng, je+ng - do i=is-ng, ie+ng - gz2(i,j) = gz(i,j,k) - enddo - enddo - - if (grid_type < 3) call fill_4corners(gz2, 1, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - do j=js1, je1 - do i=is1, ie2 - if( xfx(i,j) > 0. ) then - fx(i,j) = gz2(i-1,j) - else - fx(i,j) = gz2(i ,j) - endif - fx(i,j) = xfx(i,j)*fx(i,j) - enddo - enddo - - if (grid_type < 3) call fill_4corners(gz2, 2, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - do j=js1,je2 - do i=is1,ie1 - if( yfx(i,j) > 0. ) then - fy(i,j) = gz2(i,j-1) - else - fy(i,j) = gz2(i,j) - endif - fy(i,j) = yfx(i,j)*fy(i,j) - enddo - enddo - - do j=js1, je1 - do i=is1,ie1 - gz(i,j,k) = (gz2(i,j)*area(i,j) + fx(i,j)- fx(i+1,j)+ fy(i,j)- fy(i,j+1)) & - / ( area(i,j) + xfx(i,j)-xfx(i+1,j)+yfx(i,j)-yfx(i,j+1)) - enddo - enddo -6000 continue - -! Enforce monotonicity of height to prevent blowup -!$OMP parallel do default(none) shared(is1,ie1,js1,je1,ws,zs,gz,rdt,km) - do j=js1, je1 - do i=is1, ie1 - ws(i,j) = ( zs(i,j) - gz(i,j,km+1) ) * rdt - enddo - do k=km, 1, -1 - do i=is1, ie1 - gz(i,j,k) = max( gz(i,j,k), gz(i,j,k+1) + dz_min ) - enddo - enddo - enddo - - end subroutine update_dz_c - - - subroutine update_dz_d(ndif, damp, hord, is, ie, js, je, km, ng, npx, npy, area, rarea, & - dp0, zs, zh, crx, cry, xfx, yfx, delz, ws, rdt, gridstruct, bd, lim_fac, regional) - - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: is, ie, js, je, ng, km, npx, npy - integer, intent(in):: hord - real, intent(in) :: rdt - real, intent(in) :: dp0(km) - real, intent(in) :: area(is-ng:ie+ng,js-ng:je+ng) - real, intent(in) :: rarea(is-ng:ie+ng,js-ng:je+ng) - real, intent(inout):: damp(km+1) - integer, intent(inout):: ndif(km+1) - real, intent(in ) :: zs(is-ng:ie+ng,js-ng:je+ng) - real, intent(inout) :: zh(is-ng:ie+ng,js-ng:je+ng,km+1) - real, intent( out) ::delz(is-ng:ie+ng,js-ng:je+ng,km) - real, intent(inout), dimension(is:ie+1,js-ng:je+ng,km):: crx, xfx - real, intent(inout), dimension(is-ng:ie+ng,js:je+1,km):: cry, yfx - real, intent(out) :: ws(is:ie,js:je) - type(fv_grid_type), intent(IN), target :: gridstruct - real, intent(in) :: lim_fac - logical,intent(in) :: regional -!----------------------------------------------------- -! Local array: - real, dimension(is: ie+1, js-ng:je+ng,km+1):: crx_adv, xfx_adv - real, dimension(is-ng:ie+ng,js: je+1,km+1 ):: cry_adv, yfx_adv - real, dimension(is:ie+1,js:je ):: fx - real, dimension(is:ie ,js:je+1):: fy - real, dimension(is-ng:ie+ng+1,js-ng:je+ng ):: fx2 - real, dimension(is-ng:ie+ng ,js-ng:je+ng+1):: fy2 - real, dimension(is-ng:ie+ng ,js-ng:je+ng ):: wk2, z2 - real:: ra_x(is:ie,js-ng:je+ng) - real:: ra_y(is-ng:ie+ng,js:je) -!-------------------------------------------------------------------- - integer i, j, k, isd, ied, jsd, jed - logical:: uniform_grid - - uniform_grid = .false. - - damp(km+1) = damp(km) - ndif(km+1) = ndif(km) - - isd = is - ng; ied = ie + ng - jsd = js - ng; jed = je + ng - -!$OMP parallel do default(none) shared(jsd,jed,crx,xfx,crx_adv,xfx_adv,is,ie,isd,ied, & -!$OMP km,dp0,uniform_grid,js,je,cry,yfx,cry_adv,yfx_adv) - do j=jsd,jed - call edge_profile(crx, xfx, crx_adv, xfx_adv, is, ie+1, jsd, jed, j, km, & - dp0, uniform_grid, 0) - if ( j<=je+1 .and. j>=js ) & - call edge_profile(cry, yfx, cry_adv, yfx_adv, isd, ied, js, je+1, j, km, & - dp0, uniform_grid, 0) - enddo - -!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,area,xfx_adv,yfx_adv, & -!$OMP damp,zh,crx_adv,cry_adv,npx,npy,hord,gridstruct,bd, & -!$OMP ndif,rarea,lim_fac,regional) & -!$OMP private(z2, fx2, fy2, ra_x, ra_y, fx, fy,wk2) - do k=1,km+1 - - do j=jsd,jed - do i=is,ie - ra_x(i,j) = area(i,j) + xfx_adv(i,j,k) - xfx_adv(i+1,j,k) - enddo - enddo - do j=js,je - do i=isd,ied - ra_y(i,j) = area(i,j) + yfx_adv(i,j,k) - yfx_adv(i,j+1,k) - enddo - enddo - - if ( damp(k)>1.E-5 ) then - do j=jsd,jed - do i=isd,ied - z2(i,j) = zh(i,j,k) - enddo - enddo - call fv_tp_2d(z2, crx_adv(is,jsd,k), cry_adv(isd,js,k), npx, npy, hord, & - fx, fy, xfx_adv(is,jsd,k), yfx_adv(isd,js,k), gridstruct, bd, ra_x, ra_y, lim_fac, regional) - call del6_vt_flux(ndif(k), npx, npy, damp(k), z2, wk2, fx2, fy2, gridstruct, bd) - do j=js,je - do i=is,ie - zh(i,j,k) = (z2(i,j)*area(i,j)+fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1)) & - / (ra_x(i,j)+ra_y(i,j)-area(i,j)) + (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j) - enddo - enddo - else - call fv_tp_2d(zh(isd,jsd,k), crx_adv(is,jsd,k), cry_adv(isd,js,k), npx, npy, hord, & - fx, fy, xfx_adv(is,jsd,k), yfx_adv(isd,js,k), gridstruct, bd, ra_x, ra_y, lim_fac, regional) - do j=js,je - do i=is,ie - zh(i,j,k) = (zh(i,j,k)*area(i,j)+fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1)) & - / (ra_x(i,j) + ra_y(i,j) - area(i,j)) -! zh(i,j,k) = rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1)) & -! + zh(i,j,k)*(3.-rarea(i,j)*(ra_x(i,j) + ra_y(i,j))) - enddo - enddo - endif - - enddo - -!$OMP parallel do default(none) shared(is,ie,js,je,km,ws,zs,zh,rdt) - do j=js, je - do i=is,ie - ws(i,j) = ( zs(i,j) - zh(i,j,km+1) ) * rdt - enddo - do k=km, 1, -1 - do i=is, ie -! Enforce monotonicity of height to prevent blowup - zh(i,j,k) = max( zh(i,j,k), zh(i,j,k+1) + dz_min ) - enddo - enddo - enddo - - end subroutine update_dz_d - - - subroutine Riem_Solver_c(ms, dt, is, ie, js, je, km, ng, & - akap, cappa, cp, & -#ifdef MULTI_GASES - kapad, & -#endif - ptop, hs, w3, pt, q_con, & - delp, gz, pef, ws, p_fac, a_imp, scale_m) - - integer, intent(in):: is, ie, js, je, ng, km - integer, intent(in):: ms - real, intent(in):: dt, akap, cp, ptop, p_fac, a_imp, scale_m - real, intent(in):: ws(is-ng:ie+ng,js-ng:je+ng) - real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delp - real, intent(in), dimension(is-ng:,js-ng:,1:):: q_con, cappa -#ifdef MULTI_GASES - real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: kapad -#endif - real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng) - real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: w3 -! OUTPUT PARAMETERS - real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: gz - real, intent( out), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: pef -! Local: - real, dimension(is-1:ie+1,km ):: dm, dz2, w2, pm2, gm2, cp2 - real, dimension(is-1:ie+1,km+1):: pem, pe2, peg -#ifdef MULTI_GASES - real, dimension(is-1:ie+1,km ):: kapad2 -#endif - real gama, rgrav - integer i, j, k - integer is1, ie1 - - gama = 1./(1.-akap) - rgrav = 1./grav - - is1 = is - 1 - ie1 = ie + 1 - -!$OMP parallel do default(none) shared(js,je,is1,ie1,km,delp,pef,ptop,gz,rgrav,w3,pt, & -#ifdef MULTI_GASES -!$OMP a_imp,dt,gama,akap,ws,p_fac,scale_m,ms,hs,q_con,cappa,kapad) & -!$OMP private(cp2,gm2, dm, dz2, w2, pm2, pe2, pem, peg, kapad2) -#else -!$OMP a_imp,dt,gama,akap,ws,p_fac,scale_m,ms,hs,q_con,cappa) & -!$OMP private(cp2,gm2, dm, dz2, w2, pm2, pe2, pem, peg) -#endif - do 2000 j=js-1, je+1 - - do k=1,km - do i=is1, ie1 - dm(i,k) = delp(i,j,k) - enddo - enddo - - do i=is1, ie1 - pef(i,j,1) = ptop ! full pressure at top - pem(i,1) = ptop -#ifdef USE_COND - peg(i,1) = ptop -#endif - enddo - - do k=2,km+1 - do i=is1, ie1 - pem(i,k) = pem(i,k-1) + dm(i,k-1) -#ifdef USE_COND -! Excluding contribution from condensates: - peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) -#endif - enddo - enddo - - do k=1,km - do i=is1, ie1 - dz2(i,k) = gz(i,j,k+1) - gz(i,j,k) -#ifdef USE_COND - pm2(i,k) = (peg(i,k+1)-peg(i,k))/log(peg(i,k+1)/peg(i,k)) - -#ifdef MOIST_CAPPA - cp2(i,k) = cappa(i,j,k) - gm2(i,k) = 1. / (1.-cp2(i,k)) -#endif - -#else - pm2(i,k) = dm(i,k)/log(pem(i,k+1)/pem(i,k)) -#endif -#ifdef MULTI_GASES - kapad2(i,k) = kapad(i,j,k) -#endif - dm(i,k) = dm(i,k) * rgrav - w2(i,k) = w3(i,j,k) - enddo - enddo - - - if ( a_imp < -0.01 ) then - call SIM3p0_solver(dt, is1, ie1, km, rdgas, gama, akap, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm, & - pem, w2, dz2, pt(is1:ie1,j,1:km), ws(is1,j), p_fac, scale_m) - elseif ( a_imp <= 0.5 ) then - call RIM_2D(ms, dt, is1, ie1, km, rdgas, gama, gm2, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, & - dm, pm2, w2, dz2, pt(is1:ie1,j,1:km), ws(is1,j), .true.) - else - call SIM1_solver(dt, is1, ie1, km, rdgas, gama, gm2, cp2, akap, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, & - dm, pm2, pem, w2, dz2, pt(is1:ie1,j,1:km), ws(is1,j), p_fac) - endif - - - do k=2,km+1 - do i=is1, ie1 - pef(i,j,k) = pe2(i,k) + pem(i,k) ! add hydrostatic full-component - enddo - enddo - -! Compute Height * grav (for p-gradient computation) - do i=is1, ie1 - gz(i,j,km+1) = hs(i,j) - enddo - - do k=km,1,-1 - do i=is1, ie1 - gz(i,j,k) = gz(i,j,k+1) - dz2(i,k)*grav - enddo - enddo - -2000 continue - - end subroutine Riem_Solver_c - - -!>GFDL - This routine will not give absoulte reproducibility when compiled with -fast-transcendentals. -!! GFDL - It is now inside of nh_core.F90 and being compiled without -fast-transcendentals. - subroutine Riem_Solver3test(ms, dt, is, ie, js, je, km, ng, & - isd, ied, jsd, jed, akap, cappa, cp, & -#ifdef MULTI_GASES - kapad, & -#endif - ptop, zs, q_con, w, delz, pt, & - delp, zh, pe, ppe, pk3, pk, peln, & - ws, scale_m, p_fac, a_imp, & - use_logp, last_call, fp_out) -!-------------------------------------------- -! !OUTPUT PARAMETERS -! Ouput: gz: grav*height at edges -! pe: full hydrostatic pressure -! ppe: non-hydrostatic pressure perturbation -!-------------------------------------------- - integer, intent(in):: ms, is, ie, js, je, km, ng - integer, intent(in):: isd, ied, jsd, jed - real, intent(in):: dt ! the BIG horizontal Lagrangian time step - real, intent(in):: akap, cp, ptop, p_fac, a_imp, scale_m - real, intent(in):: zs(isd:ied,jsd:jed) - logical, intent(in):: last_call, use_logp, fp_out - real, intent(in):: ws(is:ie,js:je) - real, intent(in), dimension(isd:,jsd:,1:):: q_con, cappa - real, intent(in), dimension(isd:ied,jsd:jed,km):: delp, pt -#ifdef MULTI_GASES - real, intent(in), dimension(isd:ied,jsd:jed,km):: kapad -#endif - real, intent(inout), dimension(isd:ied,jsd:jed,km+1):: zh - real, intent(inout), dimension(isd:ied,jsd:jed,km):: w - real, intent(inout):: pe(is-1:ie+1,km+1,js-1:je+1) - real, intent(out):: peln(is:ie,km+1,js:je) ! ln(pe) - real, intent(out), dimension(isd:ied,jsd:jed,km+1):: ppe - real, intent(out):: delz(is-ng:ie+ng,js-ng:je+ng,km) - real, intent(out):: pk(is:ie,js:je,km+1) - real, intent(out):: pk3(isd:ied,jsd:jed,km+1) -! Local: - real, dimension(is:ie,km):: dm, dz2, pm2, w2, gm2, cp2 - real, dimension(is:ie,km+1)::pem, pe2, peln2, peg, pelng -#ifdef MULTI_GASES - real, dimension(is:ie,km):: kapad2 -#endif - real gama, rgrav, ptk, peln1 - integer i, j, k - - gama = 1./(1.-akap) - rgrav = 1./grav - peln1 = log(ptop) - ptk = exp(akap*peln1) - -!$OMP parallel do default(none) shared(is,ie,js,je,km,delp,ptop,peln1,pk3,ptk,akap,rgrav,zh,pt, & -!$OMP w,a_imp,dt,gama,ws,p_fac,scale_m,ms,delz,last_call, & -#ifdef MULTI_GASES -!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con,kapad ) & -!$OMP private(cp2, gm2, dm, dz2, pm2, pem, peg, pelng, pe2, peln2, w2,kapad2) -#else -!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con ) & -!$OMP private(cp2, gm2, dm, dz2, pm2, pem, peg, pelng, pe2, peln2, w2) -#endif - do 2000 j=js, je - - do k=1,km - do i=is, ie - dm(i,k) = delp(i,j,k) -#ifdef MOIST_CAPPA - cp2(i,k) = cappa(i,j,k) -#endif -#ifdef MULTI_GASES - kapad2(i,k) = kapad(i,j,k) -#endif - enddo - enddo - - do i=is,ie - pem(i,1) = ptop - peln2(i,1) = peln1 - pk3(i,j,1) = ptk -#ifdef USE_COND - peg(i,1) = ptop - pelng(i,1) = peln1 -#endif - enddo - do k=2,km+1 - do i=is,ie - pem(i,k) = pem(i,k-1) + dm(i,k-1) - peln2(i,k) = log(pem(i,k)) -#ifdef USE_COND -! Excluding contribution from condensates: -! peln used during remap; pk3 used only for p_grad - peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) - pelng(i,k) = log(peg(i,k)) -#endif - pk3(i,j,k) = exp(akap*peln2(i,k)) - enddo - enddo - - do k=1,km - do i=is, ie -#ifdef USE_COND - pm2(i,k) = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) - -#ifdef MOIST_CAPPA - gm2(i,k) = 1. / (1.-cp2(i,k)) -#endif - -#else - pm2(i,k) = dm(i,k)/(peln2(i,k+1)-peln2(i,k)) -#endif - dm(i,k) = dm(i,k) * rgrav - dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) - w2(i,k) = w(i,j,k) - enddo - enddo - - - if ( a_imp < -0.999 ) then - call SIM3p0_solver(dt, is, ie, km, rdgas, gama, akap, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm, & - pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), p_fac, scale_m ) - elseif ( a_imp < -0.5 ) then - call SIM3_solver(dt, is, ie, km, rdgas, gama, akap, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm, & - pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), abs(a_imp), p_fac, scale_m) - elseif ( a_imp <= 0.5 ) then - call RIM_2D(ms, dt, is, ie, km, rdgas, gama, gm2, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, & - dm, pm2, w2, dz2, pt(is:ie,j,1:km), ws(is,j), .false.) - elseif ( a_imp > 0.999 ) then - call SIM1_solver(dt, is, ie, km, rdgas, gama, gm2, cp2, akap, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm, & - pm2, pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), p_fac) - else - call SIM_solver(dt, is, ie, km, rdgas, gama, gm2, cp2, akap, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm, & - pm2, pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), & - a_imp, p_fac, scale_m) - endif - - - do k=1, km - do i=is, ie - w(i,j,k) = w2(i,k) - delz(i,j,k) = dz2(i,k) - enddo - enddo - - if ( last_call ) then - do k=1,km+1 - do i=is,ie - peln(i,k,j) = peln2(i,k) - pk(i,j,k) = pk3(i,j,k) - pe(i,k,j) = pem(i,k) - enddo - enddo - endif - - if( fp_out ) then - do k=1,km+1 - do i=is, ie - ppe(i,j,k) = pe2(i,k) + pem(i,k) - enddo - enddo - else - do k=1,km+1 - do i=is, ie - ppe(i,j,k) = pe2(i,k) - enddo - enddo - endif - - if ( use_logp ) then - do k=2,km+1 - do i=is, ie - pk3(i,j,k) = peln2(i,k) - enddo - enddo - endif - - do i=is, ie - zh(i,j,km+1) = zs(i,j) - enddo - do k=km,1,-1 - do i=is, ie - zh(i,j,k) = zh(i,j,k+1) - dz2(i,k) - enddo - enddo - -2000 continue - - end subroutine Riem_Solver3test - - subroutine imp_diff_w(j, is, ie, js, je, ng, km, cd, delz, ws, w, w3) - integer, intent(in) :: j, is, ie, js, je, km, ng - real, intent(in) :: cd - real, intent(in) :: delz(is-ng:ie+ng, km) !< delta-height (m) - real, intent(in) :: w(is:ie, km) !< vertical vel. (m/s) - real, intent(in) :: ws(is:ie) - real, intent(out) :: w3(is-ng:ie+ng,js-ng:je+ng,km) -! Local: - real, dimension(is:ie,km):: c, gam, dz, wt - real:: bet(is:ie) - real:: a - integer:: i, k - - do k=2,km - do i=is,ie - dz(i,k) = 0.5*(delz(i,k-1)+delz(i,k)) - enddo - enddo - do k=1,km-1 - do i=is,ie - c(i,k) = -cd/(dz(i,k+1)*delz(i,k)) - enddo - enddo - -! model top: - do i=is,ie - bet(i) = 1. - c(i,1) ! bet(i) = b - wt(i,1) = w(i,1) / bet(i) - enddo - -! Interior: - do k=2,km-1 - do i=is,ie - gam(i,k) = c(i,k-1)/bet(i) - a = cd/(dz(i,k)*delz(i,k)) - bet(i) = (1.+a-c(i,k)) + a*gam(i,k) - wt(i,k) = (w(i,k) + a*wt(i,k-1)) / bet(i) - enddo - enddo - -! Bottom: - do i=is,ie - gam(i,km) = c(i,km-1) / bet(i) - a = cd/(dz(i,km)*delz(i,km)) - wt(i,km) = (w(i,km) + 2.*ws(i)*cd/delz(i,km)**2 & - + a*wt(i,km-1))/(1. + a + (cd+cd)/delz(i,km)**2 + a*gam(i,km)) - enddo - - do k=km-1,1,-1 - do i=is,ie - wt(i,k) = wt(i,k) - gam(i,k+1)*wt(i,k+1) - enddo - enddo - - do k=1,km - do i=is,ie - w3(i,j,k) = wt(i,k) - enddo - enddo - - end subroutine imp_diff_w - - - subroutine RIM_2D(ms, bdt, is, ie, km, rgas, gama, gm2, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm2, pm2, w2, dz2, pt2, ws, c_core ) - - integer, intent(in):: ms, is, ie, km - real, intent(in):: bdt, gama, rgas - real, intent(in), dimension(is:ie,km):: dm2, pm2, gm2 - logical, intent(in):: c_core - real, intent(in ) :: pt2(is:ie,km) - real, intent(in ) :: ws(is:ie) -! IN/OUT: - real, intent(inout):: dz2(is:ie,km) - real, intent(inout):: w2(is:ie,km) - real, intent(out ):: pe2(is:ie,km+1) -#ifdef MULTI_GASES - real, intent(inout), dimension(is:ie,km):: kapad2 -#endif -! Local: - real:: ws2(is:ie) - real, dimension(km+1):: m_bot, m_top, r_bot, r_top, pe1, pbar, wbar - real, dimension(km):: r_hi, r_lo, dz, wm, dm, dts - real, dimension(km):: pf1, wc, cm , pp, pt1 - real:: dt, rdt, grg, z_frac, ptmp1, rden, pf, time_left - real:: m_surf -#ifdef MULTI_GASES - real gamax -#endif - integer:: i, k, n, ke, kt1, ktop - integer:: ks0, ks1 - - grg = gama * rgas - rdt = 1. / bdt - dt = bdt / real(ms) - - pbar(:) = 0. - wbar(:) = 0. - - do i=is,ie - ws2(i) = 2.*ws(i) - enddo - - do 6000 i=is,ie - - do k=1,km - dz(k) = dz2(i,k) - dm(k) = dm2(i,k) - wm(k) = w2(i,k)*dm(k) - pt1(k) = pt2(i,k) - enddo - - pe1(:) = 0. - wbar(km+1) = ws(i) - - ks0 = 1 - if ( ms > 1 .and. ms < 8 ) then -! Continuity of (pbar, wbar) is maintained - do k=1, km - rden = -rgas*dm(k)/dz(k) -#ifdef MOIST_CAPPA - pf1(k) = exp( gm2(i,k)*log(rden*pt1(k)) ) -! dts(k) = -dz(k)/sqrt(gm2(i,k)*rgas*pf1(k)/rden) - dts(k) = -dz(k)/sqrt(grg*pf1(k)/rden) -#else -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,k)) - pf1(k) = exp( gamax*log(rden*pt1(k)) ) -#else - pf1(k) = exp( gama*log(rden*pt1(k)) ) -#endif - dts(k) = -dz(k)/sqrt(grg*pf1(k)/rden) -#endif - if ( bdt > dts(k) ) then - ks0 = k-1 - goto 222 - endif - enddo - ks0 = km -222 if ( ks0==1 ) goto 244 - - do k=1, ks0 - cm(k) = dm(k) / dts(k) - wc(k) = wm(k) / dts(k) - pp(k) = pf1(k) - pm2(i,k) - enddo - - wbar(1) = (wc(1)+pp(1)) / cm(1) - do k=2, ks0 - wbar(k) = (wc(k-1)+wc(k) + pp(k)-pp(k-1)) / (cm(k-1)+cm(k)) - pbar(k) = bdt*(cm(k-1)*wbar(k) - wc(k-1) + pp(k-1)) - pe1(k) = pbar(k) - enddo - - if ( ks0 == km ) then - pbar(km+1) = bdt*(cm(km)*wbar(km+1) - wc(km) + pp(km)) - if ( c_core ) then - do k=1,km - dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) - enddo - else - do k=1,km - dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) - w2(i,k) = (wm(k)+pbar(k+1)-pbar(k))/dm(k) - enddo - endif - pe2(i,1) = 0. - do k=2,km+1 - pe2(i,k) = pbar(k)*rdt - enddo - goto 6000 ! next i - else - if ( c_core ) then - do k=1, ks0-1 - dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) - enddo - else - do k=1, ks0-1 - dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) - w2(i,k) = (wm(k)+pbar(k+1)-pbar(k))/dm(k) - enddo - endif - pbar(ks0) = pbar(ks0) / real(ms) - endif - endif -244 ks1 = ks0 - - do 5000 n=1, ms - - do k=ks1, km - rden = -rgas*dm(k)/dz(k) -#ifdef MOIST_CAPPA - pf = exp( gm2(i,k)*log(rden*pt1(k)) ) -! dts(k) = -dz(k) / sqrt( gm2(i,k)*rgas*pf/rden ) - dts(k) = -dz(k) / sqrt( grg*pf/rden ) -#else -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,k)) - pf = exp( gamax*log(rden*pt1(k)) ) -#else - pf = exp( gama*log(rden*pt1(k)) ) -#endif - dts(k) = -dz(k) / sqrt( grg*pf/rden ) -#endif - ptmp1 = dts(k)*(pf - pm2(i,k)) - r_lo(k) = wm(k) + ptmp1 - r_hi(k) = wm(k) - ptmp1 - enddo - - ktop = ks1 - do k=ks1, km - if( dt > dts(k) ) then - ktop = k-1 - goto 333 - endif - enddo - ktop = km -333 continue - - if ( ktop >= ks1 ) then - do k=ks1, ktop - z_frac = dt/dts(k) - r_bot(k ) = z_frac*r_lo(k) - r_top(k+1) = z_frac*r_hi(k) - m_bot(k ) = z_frac* dm(k) - m_top(k+1) = m_bot(k) - enddo - if ( ktop == km ) goto 666 - endif - - do k=ktop+2, km+1 - m_top(k) = 0. - r_top(k) = 0. - enddo - - kt1 = max(1, ktop) - do 444 ke=km+1, ktop+2, -1 - time_left = dt - do k=ke-1, kt1, -1 - if ( time_left > dts(k) ) then - time_left = time_left - dts(k) - m_top(ke) = m_top(ke) + dm(k) - r_top(ke) = r_top(ke) + r_hi(k) - else - z_frac = time_left/dts(k) - m_top(ke) = m_top(ke) + z_frac*dm(k) - r_top(ke) = r_top(ke) + z_frac*r_hi(k) - go to 444 ! next level - endif - enddo -444 continue - - do k=ktop+1, km - m_bot(k) = 0. - r_bot(k) = 0. - enddo - - do 4000 ke=ktop+1, km - time_left = dt - do k=ke, km - if ( time_left > dts(k) ) then - time_left = time_left - dts(k) - m_bot(ke) = m_bot(ke) + dm(k) - r_bot(ke) = r_bot(ke) + r_lo(k) - else - z_frac = time_left/dts(k) - m_bot(ke) = m_bot(ke) + z_frac* dm(k) - r_bot(ke) = r_bot(ke) + z_frac*r_lo(k) - go to 4000 ! next interface - endif - enddo - m_surf = m_bot(ke) - do k=km, kt1, -1 - if ( time_left > dts(k) ) then - time_left = time_left - dts(k) - m_bot(ke) = m_bot(ke) + dm(k) - r_bot(ke) = r_bot(ke) - r_hi(k) - else - z_frac = time_left/dts(k) - m_bot(ke) = m_bot(ke) + z_frac* dm(k) - r_bot(ke) = r_bot(ke) - z_frac*r_hi(k) + (m_bot(ke)-m_surf)*ws2(i) - go to 4000 ! next interface - endif - enddo -4000 continue - -666 if ( ks1==1 ) wbar(1) = r_bot(1) / m_bot(1) - do k=ks1+1, km - wbar(k) = (r_bot(k)+r_top(k)) / (m_top(k)+m_bot(k)) - enddo -! pbar here is actually dt*pbar - do k=ks1+1, km+1 - pbar(k) = m_top(k)*wbar(k) - r_top(k) - pe1(k) = pe1(k) + pbar(k) - enddo - - if ( n==ms ) then - if ( c_core ) then - do k=ks1, km - dz2(i,k) = dz(k) + dt*(wbar(k+1)-wbar(k)) - enddo - else - do k=ks1, km - dz2(i,k) = dz(k) + dt*(wbar(k+1)-wbar(k)) - w2(i,k) = ( wm(k) + pbar(k+1) - pbar(k) ) / dm(k) - enddo - endif - else - do k=ks1, km - dz(k) = dz(k) + dt*(wbar(k+1)-wbar(k)) - wm(k) = wm(k) + pbar(k+1) - pbar(k) - enddo - endif - -5000 continue - pe2(i,1) = 0. - do k=2,km+1 - pe2(i,k) = pe1(k)*rdt - enddo - -6000 continue ! end i-loop - - end subroutine RIM_2D - - subroutine SIM3_solver(dt, is, ie, km, rgas, gama, kappa, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm, & - pem, w2, dz2, pt2, ws, alpha, p_fac, scale_m) - integer, intent(in):: is, ie, km - real, intent(in):: dt, rgas, gama, kappa, alpha, p_fac, scale_m - real, intent(in ), dimension(is:ie,km):: dm, pt2 - real, intent(in ):: ws(is:ie) - real, intent(in ), dimension(is:ie,km+1):: pem - real, intent(out):: pe2(is:ie,km+1) - real, intent(inout), dimension(is:ie,km):: dz2, w2 -#ifdef MULTI_GASES - real, intent(inout), dimension(is:ie,km):: kapad2 -#endif -! Local - real, dimension(is:ie,km ):: aa, bb, dd, w1, wk, g_rat, gam - real, dimension(is:ie,km+1):: pp - real, dimension(is:ie):: p1, wk1, bet - real beta, t2, t1g, rdt, ra, capa1, r2g, r6g -#ifdef MULTI_GASES - real gamax, capa1x, t1gx -#endif - integer i, k - - beta = 1. - alpha - ra = 1. / alpha - t2 = beta / alpha - t1g = gama * 2.*(alpha*dt)**2 - rdt = 1. / dt - capa1 = kappa - 1. - r2g = grav / 2. - r6g = grav / 6. - - - do k=1,km - do i=is, ie - w1(i,k) = w2(i,k) -! Full pressure at center -#ifdef MULTI_GASES - gamax = 1. / (1.-kapad2(i,k)) - aa(i,k) = exp(gamax*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) -#else - aa(i,k) = exp(gama*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) -#endif - enddo - enddo - - do k=1,km-1 - do i=is, ie - g_rat(i,k) = dm(i,k)/dm(i,k+1) ! for profile reconstruction - bb(i,k) = 2.*(1.+g_rat(i,k)) - dd(i,k) = 3.*(aa(i,k) + g_rat(i,k)*aa(i,k+1)) - enddo - enddo - -! pe2 is full p at edges - do i=is, ie -! Top: - bet(i) = bb(i,1) - pe2(i,1) = pem(i,1) - pe2(i,2) = (dd(i,1)-pem(i,1)) / bet(i) -! Bottom: - bb(i,km) = 2. - dd(i,km) = 3.*aa(i,km) + r2g*dm(i,km) - enddo - - do k=2,km - do i=is, ie - gam(i,k) = g_rat(i,k-1) / bet(i) - bet(i) = bb(i,k) - gam(i,k) - pe2(i,k+1) = (dd(i,k) - pe2(i,k) ) / bet(i) - enddo - enddo - - do k=km, 2, -1 - do i=is, ie - pe2(i,k) = pe2(i,k) - gam(i,k)*pe2(i,k+1) - enddo - enddo -! done reconstruction of full: - -! pp is pert. p at edges - do k=1, km+1 - do i=is, ie - pp(i,k) = pe2(i,k) - pem(i,k) - enddo - enddo - - do k=2, km - do i=is, ie -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,k)) - t1gx = gamax*2.*(alpha*dt)**2 - aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) -#else - aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) -#endif - wk(i,k) = t2*aa(i,k)*(w1(i,k-1)-w1(i,k)) - aa(i,k) = aa(i,k) - scale_m*dm(i,1) - enddo - enddo - do i=is, ie - bet(i) = dm(i,1) - aa(i,2) - w2(i,1) = (dm(i,1)*w1(i,1)+dt*pp(i,2) + wk(i,2)) / bet(i) - enddo - do k=2,km-1 - do i=is, ie - gam(i,k) = aa(i,k) / bet(i) - bet(i) = dm(i,k) - (aa(i,k)+aa(i,k+1) + aa(i,k)*gam(i,k)) - w2(i,k) = (dm(i,k)*w1(i,k)+dt*(pp(i,k+1)-pp(i,k)) + wk(i,k+1)-wk(i,k) & - - aa(i,k)*w2(i,k-1)) / bet(i) - enddo - enddo - do i=is, ie -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,km)) - t1gx = gamax*2.*(alpha*dt)**2 - wk1(i) = t1gx/dz2(i,km)*pe2(i,km+1) -#else - wk1(i) = t1g/dz2(i,km)*pe2(i,km+1) -#endif - gam(i,km) = aa(i,km) / bet(i) - bet(i) = dm(i,km) - (aa(i,km)+wk1(i) + aa(i,km)*gam(i,km)) - w2(i,km) = (dm(i,km)*w1(i,km)+dt*(pp(i,km+1)-pp(i,km))-wk(i,km) + & - wk1(i)*(t2*w1(i,km)-ra*ws(i)) - aa(i,km)*w2(i,km-1)) / bet(i) - enddo - do k=km-1, 1, -1 - do i=is, ie - w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) - enddo - enddo - -! pe2 is updated perturbation p at edges - do i=is, ie - pe2(i,1) = 0. - enddo - do k=1,km - do i=is, ie - pe2(i,k+1) = pe2(i,k) + ( dm(i,k)*(w2(i,k)-w1(i,k))*rdt & - - beta*(pp(i,k+1)-pp(i,k)) )*ra - enddo - enddo - -! Full non-hydro pressure at edges: - do i=is, ie - pe2(i,1) = pem(i,1) - enddo - do k=2,km+1 - do i=is, ie - pe2(i,k) = max(p_fac*pem(i,k), pe2(i,k)+pem(i,k)) - enddo - enddo - - do i=is, ie -! Recover cell-averaged pressure - p1(i) = (pe2(i,km)+ 2.*pe2(i,km+1))*r3 - r6g*dm(i,km) -#ifdef MULTI_GASES - capa1x = kapad2(i,km) - 1. - dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1x*log(p1(i)) ) -#else - dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1*log(p1(i)) ) -#endif - enddo - - do k=km-1, 1, -1 - do i=is, ie - p1(i) = (pe2(i,k)+bb(i,k)*pe2(i,k+1)+g_rat(i,k)*pe2(i,k+2))*r3 - g_rat(i,k)*p1(i) -#ifdef MULTI_GASES - capa1x = kapad2(i,k) - 1. - dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1x*log(p1(i)) ) -#else - dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1*log(p1(i)) ) -#endif - enddo - enddo - - do k=1,km+1 - do i=is, ie - pe2(i,k) = pe2(i,k) - pem(i,k) - pe2(i,k) = pe2(i,k) + beta*(pp(i,k) - pe2(i,k)) - enddo - enddo - - end subroutine SIM3_solver - - subroutine SIM3p0_solver(dt, is, ie, km, rgas, gama, kappa, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm, & - pem, w2, dz2, pt2, ws, p_fac, scale_m) -! Sa SIM3, but for beta==0 - integer, intent(in):: is, ie, km - real, intent(in):: dt, rgas, gama, kappa, p_fac, scale_m - real, intent(in ), dimension(is:ie,km):: dm, pt2 - real, intent(in ):: ws(is:ie) - real, intent(in ):: pem(is:ie,km+1) - real, intent(out):: pe2(is:ie,km+1) - real, intent(inout), dimension(is:ie,km):: dz2, w2 -#ifdef MULTI_GASES - real, intent(inout), dimension(is:ie,km):: kapad2 -#endif -! Local - real, dimension(is:ie,km ):: aa, bb, dd, w1, g_rat, gam - real, dimension(is:ie,km+1):: pp - real, dimension(is:ie):: p1, wk1, bet - real t1g, rdt, capa1, r2g, r6g -#ifdef MULTI_GASES - real gamax, capa1x, t1gx -#endif - integer i, k - - t1g = 2.*gama*dt**2 - rdt = 1. / dt - capa1 = kappa - 1. - r2g = grav / 2. - r6g = grav / 6. - - do k=1,km - do i=is, ie - w1(i,k) = w2(i,k) -! Full pressure at center -#ifdef MULTI_GASES - gamax = 1. / ( 1. - kapad2(i,k) ) - aa(i,k) = exp(gamax*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) -#else - aa(i,k) = exp(gama*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) -#endif - enddo - enddo - - do k=1,km-1 - do i=is, ie - g_rat(i,k) = dm(i,k)/dm(i,k+1) ! for profile reconstruction - bb(i,k) = 2.*(1.+g_rat(i,k)) - dd(i,k) = 3.*(aa(i,k) + g_rat(i,k)*aa(i,k+1)) - enddo - enddo - -! pe2 is full p at edges - do i=is, ie -! Top: - bet(i) = bb(i,1) - pe2(i,1) = pem(i,1) - pe2(i,2) = (dd(i,1)-pem(i,1)) / bet(i) -! Bottom: - bb(i,km) = 2. - dd(i,km) = 3.*aa(i,km) + r2g*dm(i,km) - enddo - - do k=2,km - do i=is, ie - gam(i,k) = g_rat(i,k-1) / bet(i) - bet(i) = bb(i,k) - gam(i,k) - pe2(i,k+1) = (dd(i,k) - pe2(i,k) ) / bet(i) - enddo - enddo - - do k=km, 2, -1 - do i=is, ie - pe2(i,k) = pe2(i,k) - gam(i,k)*pe2(i,k+1) - enddo - enddo -! done reconstruction of full: - -! pp is pert. p at edges - do k=1, km+1 - do i=is, ie - pp(i,k) = pe2(i,k) - pem(i,k) - enddo - enddo - - do k=2, km - do i=is, ie -#ifdef MULTI_GASES - gamax = 1. / (1.-kapad2(i,k)) - t1gx = 2.*gamax*dt**2 - aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) - scale_m*dm(i,1) -#else - aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) - scale_m*dm(i,1) -#endif - enddo - enddo - do i=is, ie - bet(i) = dm(i,1) - aa(i,2) - w2(i,1) = (dm(i,1)*w1(i,1)+dt*pp(i,2)) / bet(i) - enddo - do k=2,km-1 - do i=is, ie - gam(i,k) = aa(i,k) / bet(i) - bet(i) = dm(i,k) - (aa(i,k)+aa(i,k+1) + aa(i,k)*gam(i,k)) - w2(i,k) = (dm(i,k)*w1(i,k)+dt*(pp(i,k+1)-pp(i,k))-aa(i,k)*w2(i,k-1))/bet(i) - enddo - enddo - do i=is, ie -#ifdef MULTI_GASES - gamax = 1. / (1.-kapad2(i,km)) - t1gx = 2.*gamax*dt**2 - wk1(i) = t1gx/dz2(i,km)*pe2(i,km+1) -#else - wk1(i) = t1g/dz2(i,km)*pe2(i,km+1) -#endif - gam(i,km) = aa(i,km) / bet(i) - bet(i) = dm(i,km) - (aa(i,km)+wk1(i) + aa(i,km)*gam(i,km)) - w2(i,km) = (dm(i,km)*w1(i,km)+dt*(pp(i,km+1)-pp(i,km))-wk1(i)*ws(i) - & - aa(i,km)*w2(i,km-1)) / bet(i) - enddo - do k=km-1, 1, -1 - do i=is, ie - w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) - enddo - enddo - -! pe2 is updated perturbation p at edges - do i=is, ie - pe2(i,1) = 0. - enddo - do k=1,km - do i=is, ie - pe2(i,k+1) = pe2(i,k) + dm(i,k)*(w2(i,k)-w1(i,k))*rdt - enddo - enddo - -! Full non-hydro pressure at edges: - do i=is, ie - pe2(i,1) = pem(i,1) - enddo - do k=2,km+1 - do i=is, ie - pe2(i,k) = max(p_fac*pem(i,k), pe2(i,k)+pem(i,k)) - enddo - enddo - - do i=is, ie -! Recover cell-averaged pressure - p1(i) = (pe2(i,km)+ 2.*pe2(i,km+1))*r3 - r6g*dm(i,km) -#ifdef MULTI_GASES - capa1x = kapad2(i,km) - 1. - dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1x*log(p1(i)) ) -#else - dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1*log(p1(i)) ) -#endif - enddo - - do k=km-1, 1, -1 - do i=is, ie - p1(i) = (pe2(i,k)+bb(i,k)*pe2(i,k+1)+g_rat(i,k)*pe2(i,k+2))*r3-g_rat(i,k)*p1(i) -#ifdef MULTI_GASES - capa1x = kapad2(i,k) - 1. - dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1x*log(p1(i)) ) -#else - dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1*log(p1(i)) ) -#endif - enddo - enddo - - do k=1,km+1 - do i=is, ie - pe2(i,k) = pe2(i,k) - pem(i,k) - enddo - enddo - - end subroutine SIM3p0_solver - - - subroutine SIM1_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe, dm2, & - pm2, pem, w2, dz2, pt2, ws, p_fac) - integer, intent(in):: is, ie, km - real, intent(in):: dt, rgas, gama, kappa, p_fac - real, intent(in), dimension(is:ie,km):: dm2, pt2, pm2, gm2, cp2 - real, intent(in ):: ws(is:ie) - real, intent(in ), dimension(is:ie,km+1):: pem - real, intent(out):: pe(is:ie,km+1) - real, intent(inout), dimension(is:ie,km):: dz2, w2 -#ifdef MULTI_GASES - real, intent(inout), dimension(is:ie,km):: kapad2 -#endif -! Local - real, dimension(is:ie,km ):: aa, bb, dd, w1, g_rat, gam - real, dimension(is:ie,km+1):: pp - real, dimension(is:ie):: p1, bet - real t1g, rdt, capa1 -#ifdef MULTI_GASES - real gamax, capa1x, t1gx -#endif - integer i, k - -#ifdef MOIST_CAPPA - t1g = 2.*dt*dt -#else - t1g = gama * 2.*dt*dt -#endif - rdt = 1. / dt - capa1 = kappa - 1. - - do k=1,km - do i=is, ie -#ifdef MOIST_CAPPA - pe(i,k) = exp(gm2(i,k)*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#else -#ifdef MULTI_GASES - gamax = 1. / ( 1. - kapad2(i,k) ) - pe(i,k) = exp(gamax*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#else - pe(i,k) = exp(gama*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#endif -#endif - w1(i,k) = w2(i,k) - enddo - enddo - - do k=1,km-1 - do i=is, ie - g_rat(i,k) = dm2(i,k)/dm2(i,k+1) - bb(i,k) = 2.*(1.+g_rat(i,k)) - dd(i,k) = 3.*(pe(i,k) + g_rat(i,k)*pe(i,k+1)) - enddo - enddo - - do i=is, ie - bet(i) = bb(i,1) - pp(i,1) = 0. - pp(i,2) = dd(i,1) / bet(i) - bb(i,km) = 2. - dd(i,km) = 3.*pe(i,km) - enddo - - do k=2,km - do i=is, ie - gam(i,k) = g_rat(i,k-1) / bet(i) - bet(i) = bb(i,k) - gam(i,k) - pp(i,k+1) = (dd(i,k) - pp(i,k) ) / bet(i) - enddo - enddo - - do k=km, 2, -1 - do i=is, ie - pp(i,k) = pp(i,k) - gam(i,k)*pp(i,k+1) - enddo - enddo - -! Start the w-solver - do k=2, km - do i=is, ie -#ifdef MOIST_CAPPA - aa(i,k) = t1g*0.5*(gm2(i,k-1)+gm2(i,k))/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)+pp(i,k)) -#else -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,k)) - t1gx = gamax * 2.*dt*dt - aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)+pp(i,k)) -#else - aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)+pp(i,k)) -#endif -#endif - enddo - enddo - do i=is, ie - bet(i) = dm2(i,1) - aa(i,2) - w2(i,1) = (dm2(i,1)*w1(i,1) + dt*pp(i,2)) / bet(i) - enddo - do k=2,km-1 - do i=is, ie - gam(i,k) = aa(i,k) / bet(i) - bet(i) = dm2(i,k) - (aa(i,k) + aa(i,k+1) + aa(i,k)*gam(i,k)) - w2(i,k) = (dm2(i,k)*w1(i,k)+dt*(pp(i,k+1)-pp(i,k))-aa(i,k)*w2(i,k-1)) / bet(i) - enddo - enddo - do i=is, ie -#ifdef MOIST_CAPPA - p1(i) = t1g*gm2(i,km)/dz2(i,km)*(pem(i,km+1)+pp(i,km+1)) -#else -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,km)) - t1gx = gamax * 2.*dt*dt - p1(i) = t1gx/dz2(i,km)*(pem(i,km+1)+pp(i,km+1)) -#else - p1(i) = t1g/dz2(i,km)*(pem(i,km+1)+pp(i,km+1)) -#endif -#endif - gam(i,km) = aa(i,km) / bet(i) - bet(i) = dm2(i,km) - (aa(i,km)+p1(i) + aa(i,km)*gam(i,km)) - w2(i,km) = (dm2(i,km)*w1(i,km)+dt*(pp(i,km+1)-pp(i,km))-p1(i)*ws(i)-aa(i,km)*w2(i,km-1))/bet(i) - enddo - do k=km-1, 1, -1 - do i=is, ie - w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) - enddo - enddo - - do i=is, ie - pe(i,1) = 0. - enddo - do k=1,km - do i=is, ie - pe(i,k+1) = pe(i,k) + dm2(i,k)*(w2(i,k)-w1(i,k))*rdt - enddo - enddo - - do i=is, ie - p1(i) = ( pe(i,km) + 2.*pe(i,km+1) )*r3 -#ifdef MOIST_CAPPA - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp((cp2(i,km)-1.)*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#else -#ifdef MULTI_GASES - capa1x = kapad2(i,km)-1. - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1x*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#else - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#endif -#endif - enddo - - do k=km-1, 1, -1 - do i=is, ie - p1(i) = (pe(i,k) + bb(i,k)*pe(i,k+1) + g_rat(i,k)*pe(i,k+2))*r3 - g_rat(i,k)*p1(i) -#ifdef MOIST_CAPPA - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp((cp2(i,k)-1.)*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) - -#else -#ifdef MULTI_GASES - capa1x = kapad2(i,k)-1. - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1x*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#else - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#endif -#endif - enddo - enddo - - end subroutine SIM1_solver - - subroutine SIM_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, & -#ifdef MULTI_GASES - kapad2, & -#endif - pe2, dm2, & - pm2, pem, w2, dz2, pt2, ws, alpha, p_fac, scale_m) - integer, intent(in):: is, ie, km - real, intent(in):: dt, rgas, gama, kappa, p_fac, alpha, scale_m - real, intent(in), dimension(is:ie,km):: dm2, pt2, pm2, gm2, cp2 - real, intent(in ):: ws(is:ie) - real, intent(in ), dimension(is:ie,km+1):: pem - real, intent(out):: pe2(is:ie,km+1) - real, intent(inout), dimension(is:ie,km):: dz2, w2 -#ifdef MULTI_GASES - real, intent(inout), dimension(is:ie,km):: kapad2 -#endif -! Local - real, dimension(is:ie,km ):: aa, bb, dd, w1, wk, g_rat, gam - real, dimension(is:ie,km+1):: pp - real, dimension(is:ie):: p1, wk1, bet - real beta, t2, t1g, rdt, ra, capa1 -#ifdef MULTI_GASES - real gamax, capa1x, t1gx -#endif - integer i, k - - beta = 1. - alpha - ra = 1. / alpha - t2 = beta / alpha -#ifdef MOIST_CAPPA - t1g = 2.*(alpha*dt)**2 -#else - t1g = 2.*gama*(alpha*dt)**2 -#endif - rdt = 1. / dt - capa1 = kappa - 1. - - do k=1,km - do i=is, ie - w1(i,k) = w2(i,k) -! P_g perturbation -#ifdef MOIST_CAPPA - pe2(i,k) = exp(gm2(i,k)*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#else -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,k)) - pe2(i,k) = exp(gamax*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#else - pe2(i,k) = exp(gama*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) -#endif -#endif - enddo - enddo - - do k=1,km-1 - do i=is, ie - g_rat(i,k) = dm2(i,k)/dm2(i,k+1) - bb(i,k) = 2.*(1.+g_rat(i,k)) - dd(i,k) = 3.*(pe2(i,k) + g_rat(i,k)*pe2(i,k+1)) - enddo - enddo - - do i=is, ie - bet(i) = bb(i,1) - pp(i,1) = 0. - pp(i,2) = dd(i,1) / bet(i) - bb(i,km) = 2. - dd(i,km) = 3.*pe2(i,km) - enddo - - do k=2,km - do i=is, ie - gam(i,k) = g_rat(i,k-1) / bet(i) - bet(i) = bb(i,k) - gam(i,k) - pp(i,k+1) = (dd(i,k) - pp(i,k) ) / bet(i) - enddo - enddo - - do k=km, 2, -1 - do i=is, ie - pp(i,k) = pp(i,k) - gam(i,k)*pp(i,k+1) - enddo - enddo - - do k=1, km+1 - do i=is, ie -! pe2 is Full p - pe2(i,k) = pem(i,k) + pp(i,k) - enddo - enddo - - do k=2, km - do i=is, ie -#ifdef MOIST_CAPPA - aa(i,k) = t1g*0.5*(gm2(i,k-1)+gm2(i,k))/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) -#else -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,k)) - t1gx = 2.*gamax*(alpha*dt)**2 - aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) -#else - aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) -#endif -#endif - wk(i,k) = t2*aa(i,k)*(w1(i,k-1)-w1(i,k)) - aa(i,k) = aa(i,k) - scale_m*dm2(i,1) - enddo - enddo -! Top: - do i=is, ie - bet(i) = dm2(i,1) - aa(i,2) - w2(i,1) = (dm2(i,1)*w1(i,1) + dt*pp(i,2) + wk(i,2)) / bet(i) - enddo -! Interior: - do k=2,km-1 - do i=is, ie - gam(i,k) = aa(i,k) / bet(i) - bet(i) = dm2(i,k) - (aa(i,k)+aa(i,k+1) + aa(i,k)*gam(i,k)) - w2(i,k) = (dm2(i,k)*w1(i,k) + dt*(pp(i,k+1)-pp(i,k)) + wk(i,k+1)-wk(i,k) & - - aa(i,k)*w2(i,k-1)) / bet(i) - enddo - enddo -! Bottom: k=km - do i=is, ie -#ifdef MOIST_CAPPA - wk1(i) = t1g*gm2(i,km)/dz2(i,km)*pe2(i,km+1) -#else -#ifdef MULTI_GASES - gamax = 1./(1.-kapad2(i,km)) - t1gx = 2.*gamax*(alpha*dt)**2 - wk1(i) = t1gx/dz2(i,km)*pe2(i,km+1) -#else - wk1(i) = t1g/dz2(i,km)*pe2(i,km+1) -#endif -#endif - gam(i,km) = aa(i,km) / bet(i) - bet(i) = dm2(i,km) - (aa(i,km)+wk1(i) + aa(i,km)*gam(i,km)) - w2(i,km) = (dm2(i,km)*w1(i,km) + dt*(pp(i,km+1)-pp(i,km)) - wk(i,km) + & - wk1(i)*(t2*w1(i,km)-ra*ws(i)) - aa(i,km)*w2(i,km-1)) / bet(i) - enddo - do k=km-1, 1, -1 - do i=is, ie - w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) - enddo - enddo - - do i=is, ie - pe2(i,1) = 0. - enddo - do k=1,km - do i=is, ie - pe2(i,k+1) = pe2(i,k) + ( dm2(i,k)*(w2(i,k)-w1(i,k))*rdt & - - beta*(pp(i,k+1)-pp(i,k)) ) * ra - enddo - enddo - - do i=is, ie - p1(i) = (pe2(i,km)+ 2.*pe2(i,km+1))*r3 -#ifdef MOIST_CAPPA - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp((cp2(i,km)-1.)*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#else -#ifdef MULTI_GASES - capa1x = kapad2(i,km)-1. - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1x*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#else - dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) -#endif -#endif - enddo - - do k=km-1, 1, -1 - do i=is, ie - p1(i) = (pe2(i,k)+bb(i,k)*pe2(i,k+1)+g_rat(i,k)*pe2(i,k+2))*r3 - g_rat(i,k)*p1(i) -! delz = -dm*R*T_m / p_gas -#ifdef MOIST_CAPPA - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp((cp2(i,k)-1.)*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#else -#ifdef MULTI_GASES - capa1x = kapad2(i,k)-1. - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1x*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#else - dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) -#endif -#endif - enddo - enddo - - do k=1, km+1 - do i=is, ie - pe2(i,k) = pe2(i,k) + beta*(pp(i,k)-pe2(i,k)) - enddo - enddo - - end subroutine SIM_solver - - - subroutine edge_scalar(q1, qe, i1, i2, km, id) -! Optimized for wind profile reconstruction: - integer, intent(in):: i1, i2, km - integer, intent(in):: id ! 0: pp 1: wind - real, intent(in ), dimension(i1:i2,km):: q1 - real, intent(out), dimension(i1:i2,km+1):: qe -!----------------------------------------------------------------------- - real, parameter:: r2o3 = 2./3. - real, parameter:: r4o3 = 4./3. - real gak(km) - real bet - integer i, k - -!------------------------------------------------ -! Optimized coding for uniform grid: SJL Apr 2007 -!------------------------------------------------ - - if ( id==1 ) then - do i=i1,i2 - qe(i,1) = r4o3*q1(i,1) + r2o3*q1(i,2) - enddo - else - do i=i1,i2 - qe(i,1) = 1.E30 - enddo - endif - - gak(1) = 7./3. - do k=2,km - gak(k) = 1. / (4. - gak(k-1)) - do i=i1,i2 - qe(i,k) = (3.*(q1(i,k-1) + q1(i,k)) - qe(i,k-1)) * gak(k) - enddo - enddo - - bet = 1. / (1.5 - 3.5*gak(km)) - do i=i1,i2 - qe(i,km+1) = (4.*q1(i,km) + q1(i,km-1) - 3.5*qe(i,km)) * bet - enddo - - do k=km,1,-1 - do i=i1,i2 - qe(i,k) = qe(i,k) - gak(k)*qe(i,k+1) - enddo - enddo - - end subroutine edge_scalar - - - - subroutine edge_profile(q1, q2, q1e, q2e, i1, i2, j1, j2, j, km, dp0, uniform_grid, limiter) -! Optimized for wind profile reconstruction: - integer, intent(in):: i1, i2, j1, j2 - integer, intent(in):: j, km - integer, intent(in):: limiter - logical, intent(in):: uniform_grid - real, intent(in):: dp0(km) - real, intent(in), dimension(i1:i2,j1:j2,km):: q1, q2 - real, intent(out), dimension(i1:i2,j1:j2,km+1):: q1e, q2e -!----------------------------------------------------------------------- - real, dimension(i1:i2,km+1):: qe1, qe2, gam ! edge values - real gak(km) - real bet, r2o3, r4o3 - real g0, gk, xt1, xt2, a_bot - integer i, k - - if ( uniform_grid ) then -!------------------------------------------------ -! Optimized coding for uniform grid: SJL Apr 2007 -!------------------------------------------------ - r2o3 = 2./3. - r4o3 = 4./3. - do i=i1,i2 - qe1(i,1) = r4o3*q1(i,j,1) + r2o3*q1(i,j,2) - qe2(i,1) = r4o3*q2(i,j,1) + r2o3*q2(i,j,2) - enddo - - gak(1) = 7./3. - do k=2,km - gak(k) = 1. / (4. - gak(k-1)) - do i=i1,i2 - qe1(i,k) = (3.*(q1(i,j,k-1) + q1(i,j,k)) - qe1(i,k-1)) * gak(k) - qe2(i,k) = (3.*(q2(i,j,k-1) + q2(i,j,k)) - qe2(i,k-1)) * gak(k) - enddo - enddo - - bet = 1. / (1.5 - 3.5*gak(km)) - do i=i1,i2 - qe1(i,km+1) = (4.*q1(i,j,km) + q1(i,j,km-1) - 3.5*qe1(i,km)) * bet - qe2(i,km+1) = (4.*q2(i,j,km) + q2(i,j,km-1) - 3.5*qe2(i,km)) * bet - enddo - - do k=km,1,-1 - do i=i1,i2 - qe1(i,k) = qe1(i,k) - gak(k)*qe1(i,k+1) - qe2(i,k) = qe2(i,k) - gak(k)*qe2(i,k+1) - enddo - enddo - else -! Assuming grid varying in vertical only - g0 = dp0(2) / dp0(1) - xt1 = 2.*g0*(g0+1. ) - bet = g0*(g0+0.5) - do i=i1,i2 - qe1(i,1) = ( xt1*q1(i,j,1) + q1(i,j,2) ) / bet - qe2(i,1) = ( xt1*q2(i,j,1) + q2(i,j,2) ) / bet - gam(i,1) = ( 1. + g0*(g0+1.5) ) / bet - enddo - - do k=2,km - gk = dp0(k-1) / dp0(k) - do i=i1,i2 - bet = 2. + 2.*gk - gam(i,k-1) - qe1(i,k) = ( 3.*(q1(i,j,k-1)+gk*q1(i,j,k)) - qe1(i,k-1) ) / bet - qe2(i,k) = ( 3.*(q2(i,j,k-1)+gk*q2(i,j,k)) - qe2(i,k-1) ) / bet - gam(i,k) = gk / bet - enddo - enddo - - a_bot = 1. + gk*(gk+1.5) - xt1 = 2.*gk*(gk+1.) - do i=i1,i2 - xt2 = gk*(gk+0.5) - a_bot*gam(i,km) - qe1(i,km+1) = ( xt1*q1(i,j,km) + q1(i,j,km-1) - a_bot*qe1(i,km) ) / xt2 - qe2(i,km+1) = ( xt1*q2(i,j,km) + q2(i,j,km-1) - a_bot*qe2(i,km) ) / xt2 - enddo - - do k=km,1,-1 - do i=i1,i2 - qe1(i,k) = qe1(i,k) - gam(i,k)*qe1(i,k+1) - qe2(i,k) = qe2(i,k) - gam(i,k)*qe2(i,k+1) - enddo - enddo - endif - -!------------------ -! Apply constraints -!------------------ - if ( limiter/=0 ) then ! limit the top & bottom winds - do i=i1,i2 -! Top - if ( q1(i,j,1)*qe1(i,1) < 0. ) qe1(i,1) = 0. - if ( q2(i,j,1)*qe2(i,1) < 0. ) qe2(i,1) = 0. -! Surface: - if ( q1(i,j,km)*qe1(i,km+1) < 0. ) qe1(i,km+1) = 0. - if ( q2(i,j,km)*qe2(i,km+1) < 0. ) qe2(i,km+1) = 0. - enddo - endif - - do k=1,km+1 - do i=i1,i2 - q1e(i,j,k) = qe1(i,k) - q2e(i,j,k) = qe2(i,k) - enddo - enddo - - end subroutine edge_profile - - subroutine nest_halo_nh(ptop, grav, kappa, cp, delp, delz, pt, phis, & -#ifdef MULTI_GASES - q , & -#endif -#ifdef USE_COND - q_con, & -#ifdef MOIST_CAPPA - cappa, & -#endif -#endif - pkc, gz, pk3, & - npx, npy, npz, nested, pkc_pertn, computepk3, fullhalo, bd, regional) - - !INPUT: delp, delz, pt - !OUTPUT: gz, pkc, pk3 (optional) - integer, intent(IN) :: npx, npy, npz - logical, intent(IN) :: pkc_pertn, computepk3, fullhalo, nested, regional - real, intent(IN) :: ptop, kappa, cp, grav - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(IN) :: phis(bd%isd:bd%ied,bd%jsd:bd%jed) - real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: pt, delp, delz -#ifdef MULTI_GASES - real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz,*):: q -#endif -#ifdef USE_COND - real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: q_con -#ifdef MOIST_CAPPA - real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: cappa -#endif -#endif - real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1):: gz, pkc, pk3 - - integer :: i,j,k - real :: gama !'gamma' - real :: ptk, rgrav, rkap, peln1, rdg - - real, dimension(bd%isd:bd%ied, npz+1, bd%jsd:bd%jed ) :: pe, peln -#ifdef USE_COND - real, dimension(bd%isd:bd%ied, npz+1 ) :: peg, pelng -#endif - real, dimension(bd%isd:bd%ied, npz) :: gam, bb, dd, pkz - real, dimension(bd%isd:bd%ied, npz-1) :: g_rat - real, dimension(bd%isd:bd%ied) :: bet - real :: pm -#ifdef MULTI_GASES - real gamax -#endif - - integer :: ifirst, ilast, jfirst, jlast - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - if (.not. (nested .or. regional)) return - ifirst = isd - jfirst = jsd - ilast = ied - jlast = jed - - !Remember we want to compute these in the HALO. Note also this routine - !requires an appropriate - - rgrav = 1./grav - gama = 1./(1.-kappa) - ptk = ptop ** kappa - rkap = 1./kappa - peln1 = log(ptop) - rdg = - rdgas * rgrav - - !NOTE: Compiler does NOT like this sort of nested-grid BC code. Is it trying to do some ugly optimization? - - if (is == 1) then - - do j=jfirst,jlast - - !GZ - do i=ifirst,0 - gz(i,j,npz+1) = phis(i,j) - enddo - do k=npz,1,-1 - do i=ifirst,0 - gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k)*grav - enddo - enddo - - !Hydrostatic interface pressure - do i=ifirst,0 - pe(i,1,j) = ptop - peln(i,1,j) = peln1 -#ifdef USE_COND - peg(i,1) = ptop - pelng(i,1) = peln1 -#endif - enddo - do k=2,npz+1 - do i=ifirst,0 - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) - peln(i,k,j) = log(pe(i,k,j)) -#ifdef USE_COND - peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) - pelng(i,k) = log(peg(i,k)) -#endif - enddo - enddo - - !Perturbation nonhydro layer-mean pressure (NOT to the kappa) - do k=1,npz - do i=ifirst,0 - !Full p -#ifdef MOIST_CAPPA - pkz(i,k) = exp(1./(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#else -#ifdef MULTI_GASES - gamax = gama * (vicpqd(q(i,j,k,:))/vicvqd(q(i,j,k,:))) - pkz(i,k) = exp(gamax*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#else - pkz(i,k) = exp(gama*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#endif -#endif -! !hydro -#ifdef USE_COND - pm = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) -#else - pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) -#endif - !Remove hydro cell-mean pressure - pkz(i,k) = pkz(i,k) - pm - enddo - enddo - - !pressure solver - do k=1,npz-1 - do i=ifirst,0 - g_rat(i,k) = delp(i,j,k)/delp(i,j,k+1) - bb(i,k) = 2.*(1. + g_rat(i,k)) - dd(i,k) = 3.*(pkz(i,k) + g_rat(i,k)*pkz(i,k+1)) - enddo - enddo - - do i=ifirst,0 - bet(i) = bb(i,1) - pkc(i,j,1) = 0. - pkc(i,j,2) = dd(i,1)/bet(i) - bb(i,npz) = 2. - dd(i,npz) = 3.*pkz(i,npz) - enddo - do k=2,npz - do i=ifirst,0 - gam(i,k) = g_rat(i,k-1)/bet(i) - bet(i) = bb(i,k) - gam(i,k) - pkc(i,j,k+1) = (dd(i,k) - pkc(i,j,k))/bet(i) - enddo - enddo - do k=npz,2,-1 - do i=ifirst,0 - pkc(i,j,k) = pkc(i,j,k) - gam(i,k)*pkc(i,j,k+1) -#ifdef NHNEST_DEBUG - if (abs(pkc(i,j,k)) > 1.e5) then - print*, mpp_pe(), i,j,k, 'PKC: ', pkc(i,j,k) - endif -#endif - enddo - enddo - - enddo - - do j=jfirst,jlast - - if (.not. pkc_pertn) then - do k=npz+1,1,-1 - do i=ifirst,0 - pkc(i,j,k) = pkc(i,j,k) + pe(i,k,j) - enddo - enddo - endif - - !pk3 if necessary; doesn't require condenstate loading calculation - if (computepk3) then - do i=ifirst,0 - pk3(i,j,1) = ptk - enddo - do k=2,npz+1 - do i=ifirst,0 - pk3(i,j,k) = exp(kappa*log(pe(i,k,j))) - enddo - enddo - endif - - enddo - - endif - - if (ie == npx-1) then - - do j=jfirst,jlast - - !GZ - do i=npx,ilast - gz(i,j,npz+1) = phis(i,j) - enddo - do k=npz,1,-1 - do i=npx,ilast - gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k)*grav - enddo - enddo - - !Hydrostatic interface pressure - do i=npx,ilast - pe(i,1,j) = ptop - peln(i,1,j) = peln1 -#ifdef USE_COND - peg(i,1) = ptop - pelng(i,1) = peln1 -#endif - enddo - do k=2,npz+1 - do i=npx,ilast - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) - peln(i,k,j) = log(pe(i,k,j)) -#ifdef USE_COND - peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) - pelng(i,k) = log(peg(i,k)) -#endif - enddo - enddo - - !Perturbation nonhydro layer-mean pressure (NOT to the kappa) - do k=1,npz - do i=npx,ilast - !Full p -#ifdef MOIST_CAPPA - pkz(i,k) = exp(1./(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#else -#ifdef MULTI_GASES - gamax = gama * (vicpqd(q(i,j,k,:))/vicvqd(q(i,j,k,:))) - pkz(i,k) = exp(gamax*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#else - pkz(i,k) = exp(gama*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#endif -#endif - !hydro -#ifdef USE_COND - pm = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) -#else - pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) -#endif - !Remove hydro cell-mean pressure - pkz(i,k) = pkz(i,k) - pm - enddo - enddo - - !pressure solver - do k=1,npz-1 - do i=npx,ilast - g_rat(i,k) = delp(i,j,k)/delp(i,j,k+1) - bb(i,k) = 2.*(1. + g_rat(i,k)) - dd(i,k) = 3.*(pkz(i,k) + g_rat(i,k)*pkz(i,k+1)) - enddo - enddo - - do i=npx,ilast - bet(i) = bb(i,1) - pkc(i,j,1) = 0. - pkc(i,j,2) = dd(i,1)/bet(i) - bb(i,npz) = 2. - dd(i,npz) = 3.*pkz(i,npz) - enddo - do k=2,npz - do i=npx,ilast - gam(i,k) = g_rat(i,k-1)/bet(i) - bet(i) = bb(i,k) - gam(i,k) - pkc(i,j,k+1) = (dd(i,k) - pkc(i,j,k))/bet(i) - enddo - enddo - do k=npz,2,-1 - do i=npx,ilast - pkc(i,j,k) = pkc(i,j,k) - gam(i,k)*pkc(i,j,k+1) - enddo - enddo - - - enddo - - do j=jfirst,jlast - - if (.not. pkc_pertn) then - do k=npz+1,1,-1 - do i=npx,ilast - pkc(i,j,k) = pkc(i,j,k) + pe(i,k,j) - enddo - enddo - endif - - !pk3 if necessary - if (computepk3) then - do i=npx,ilast - pk3(i,j,1) = ptk - enddo - do k=2,npz+1 - do i=npx,ilast - pk3(i,j,k) = exp(kappa*log(pe(i,k,j))) - enddo - enddo - endif - - enddo - - endif - - if (js == 1) then - - do j=jfirst,0 - - !GZ - do i=ifirst,ilast - gz(i,j,npz+1) = phis(i,j) - enddo - do k=npz,1,-1 - do i=ifirst,ilast - gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k)*grav - enddo - enddo - - !Hydrostatic interface pressure - do i=ifirst,ilast - pe(i,1,j) = ptop - peln(i,1,j) = peln1 -#ifdef USE_COND - peg(i,1) = ptop - pelng(i,1) = peln1 -#endif - enddo - do k=2,npz+1 - do i=ifirst,ilast - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) - peln(i,k,j) = log(pe(i,k,j)) -#ifdef USE_COND - peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) - pelng(i,k) = log(peg(i,k)) -#endif - enddo - enddo - - !Perturbation nonhydro layer-mean pressure (NOT to the kappa) - do k=1,npz - do i=ifirst,ilast - !Full p -#ifdef MOIST_CAPPA - pkz(i,k) = exp(1./(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#else -#ifdef MULTI_GASES - gamax = gama * (vicpqd(q(i,j,k,:))/vicvqd(q(i,j,k,:))) - pkz(i,k) = exp(gamax*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#else - pkz(i,k) = exp(gama*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#endif -#endif - !hydro -#ifdef USE_COND - pm = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) -#else - pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) -#endif - !hydro - pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - !Remove hydro cell-mean pressure - pkz(i,k) = pkz(i,k) - pm - enddo - enddo - - !pressure solver - do k=1,npz-1 - do i=ifirst,ilast - g_rat(i,k) = delp(i,j,k)/delp(i,j,k+1) - bb(i,k) = 2.*(1. + g_rat(i,k)) - dd(i,k) = 3.*(pkz(i,k) + g_rat(i,k)*pkz(i,k+1)) - enddo - enddo - - do i=ifirst,ilast - bet(i) = bb(i,1) - pkc(i,j,1) = 0. - pkc(i,j,2) = dd(i,1)/bet(i) - bb(i,npz) = 2. - dd(i,npz) = 3.*pkz(i,npz) - enddo - do k=2,npz - do i=ifirst,ilast - gam(i,k) = g_rat(i,k-1)/bet(i) - bet(i) = bb(i,k) - gam(i,k) - pkc(i,j,k+1) = (dd(i,k) - pkc(i,j,k))/bet(i) - enddo - enddo - do k=npz,2,-1 - do i=ifirst,ilast - pkc(i,j,k) = pkc(i,j,k) - gam(i,k)*pkc(i,j,k+1) -#ifdef NHNEST_DEBUG - if (abs(pkc(i,j,k)) > 1.e5) then - print*, mpp_pe(), i,j,k, 'PKC: ', pkc(i,j,k) - endif -#endif - enddo - enddo - - enddo - - do j=jfirst,0 - - if (.not. pkc_pertn) then - do k=npz+1,1,-1 - do i=ifirst,ilast - pkc(i,j,k) = pkc(i,j,k) + pe(i,k,j) - enddo - enddo - endif - - !pk3 if necessary - if (computepk3) then - do i=ifirst,ilast - pk3(i,j,1) = ptk - enddo - do k=2,npz+1 - do i=ifirst,ilast - pk3(i,j,k) = exp(kappa*log(pe(i,k,j))) - enddo - enddo - endif - - enddo - - endif - - if (je == npy-1) then - - do j=npy,jlast - - !GZ - do i=ifirst,ilast - gz(i,j,npz+1) = phis(i,j) - enddo - do k=npz,1,-1 - do i=ifirst,ilast - gz(i,j,k) = gz(i,j,k+1) - delz(i,j,k)*grav - enddo - enddo - - !Hydrostatic interface pressure - do i=ifirst,ilast - pe(i,1,j) = ptop - peln(i,1,j) = peln1 -#ifdef USE_COND - peg(i,1) = ptop - pelng(i,1) = peln1 -#endif - enddo - do k=2,npz+1 - do i=ifirst,ilast - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) - peln(i,k,j) = log(pe(i,k,j)) -#ifdef USE_COND - peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) - pelng(i,k) = log(peg(i,k)) -#endif - enddo - enddo - - !Perturbation nonhydro layer-mean pressure (NOT to the kappa) - do k=1,npz - do i=ifirst,ilast - !Full p -#ifdef MOIST_CAPPA - pkz(i,k) = exp(1./(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#else -#ifdef MULTI_GASES - gamax = gama * (vicpqd(q(i,j,k,:))/vicvqd(q(i,j,k,:))) - pkz(i,k) = exp(gamax*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#else - pkz(i,k) = exp(gama*log(-delp(i,j,k)*rgrav/delz(i,j,k)*rdgas*pt(i,j,k))) -#endif -#endif - !hydro -#ifdef USE_COND - pm = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) -#else - pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) -#endif - !hydro - pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - !Remove hydro cell-mean pressure - pkz(i,k) = pkz(i,k) - pm - enddo - enddo - - !Reversible interpolation on layer NH pressure perturbation - ! to recover lastge NH pressure perturbation - do k=1,npz-1 - do i=ifirst,ilast - g_rat(i,k) = delp(i,j,k)/delp(i,j,k+1) - bb(i,k) = 2.*(1. + g_rat(i,k)) - dd(i,k) = 3.*(pkz(i,k) + g_rat(i,k)*pkz(i,k+1)) - enddo - enddo - - do i=ifirst,ilast - bet(i) = bb(i,1) - pkc(i,j,1) = 0. - pkc(i,j,2) = dd(i,1)/bet(i) - bb(i,npz) = 2. - dd(i,npz) = 3.*pkz(i,npz) - enddo - do k=2,npz - do i=ifirst,ilast - gam(i,k) = g_rat(i,k-1)/bet(i) - bet(i) = bb(i,k) - gam(i,k) - pkc(i,j,k+1) = (dd(i,k) - pkc(i,j,k))/bet(i) - enddo - enddo - do k=npz,2,-1 - do i=ifirst,ilast - pkc(i,j,k) = pkc(i,j,k) - gam(i,k)*pkc(i,j,k+1) - enddo - enddo - - - enddo - - do j=npy,jlast - - if (.not. pkc_pertn) then - do k=npz+1,1,-1 - do i=ifirst,ilast - pkc(i,j,k) = pkc(i,j,k) + pe(i,k,j) - enddo - enddo - endif - - !pk3 if necessary - if (computepk3) then - do i=ifirst,ilast - pk3(i,j,1) = ptk - enddo - do k=2,npz+1 - do i=ifirst,ilast - pk3(i,j,k) = exp(kappa*log(pe(i,k,j))) - enddo - enddo - endif - - enddo - - endif - -end subroutine nest_halo_nh - -end module nh_utils_mod + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'nh_utils' peforms non-hydrostatic computations. +!>@author S. J. Lin, NOAA/GFDL + +module nh_utils_mod + +! Modules Included: +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
Module NameFunctions Included
constants_modrdgas, cp_air, grav
fv_arrays_modfv_grid_bounds_type, fv_grid_type
sw_core_modfill_4corners, del6_vt_flux
tp_core_modfv_tp_2d
+ + use constants_mod, only: rdgas, cp_air, grav + use tp_core_mod, only: fv_tp_2d + use sw_core_mod, only: fill_4corners, del6_vt_flux + use fv_arrays_mod, only: fv_grid_bounds_type, fv_grid_type,fv_nest_BC_type_3d +#ifdef MULTI_GASES + use multi_gases_mod, only: vicpqd, vicvqd +#endif + + implicit none + private + + public update_dz_c, update_dz_d, nh_bc + public sim_solver, sim1_solver, sim3_solver + public sim3p0_solver, rim_2d + public Riem_Solver_c + + real, parameter:: dz_min = 2. + real, parameter:: r3 = 1./3. + +CONTAINS + + subroutine update_dz_c(is, ie, js, je, km, ng, dt, dp0, zs, area, ut, vt, gz, ws, & + npx, npy, sw_corner, se_corner, ne_corner, nw_corner, bd, grid_type) +! !INPUT PARAMETERS: + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: is, ie, js, je, ng, km, npx, npy, grid_type + logical, intent(IN):: sw_corner, se_corner, ne_corner, nw_corner + real, intent(in):: dt + real, intent(in):: dp0(km) + real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: ut, vt + real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng):: area + real, intent(inout):: gz(is-ng:ie+ng,js-ng:je+ng,km+1) + real, intent(in ):: zs(is-ng:ie+ng, js-ng:je+ng) + real, intent( out):: ws(is-ng:ie+ng, js-ng:je+ng) +! Local Work array: + real:: gz2(is-ng:ie+ng,js-ng:je+ng) + real, dimension(is-1:ie+2,js-1:je+1):: xfx, fx + real, dimension(is-1:ie+1,js-1:je+2):: yfx, fy + real, parameter:: r14 = 1./14. + integer i, j, k + integer:: is1, ie1, js1, je1 + integer:: ie2, je2 + real:: rdt, top_ratio, bot_ratio, int_ratio +!-------------------------------------------------------------------- + + rdt = 1. / dt + + top_ratio = dp0(1 ) / (dp0( 1)+dp0(2 )) + bot_ratio = dp0(km) / (dp0(km-1)+dp0(km)) + + is1 = is - 1 + js1 = js - 1 + + ie1 = ie + 1 + je1 = je + 1 + + ie2 = ie + 2 + je2 = je + 2 + +!$OMP parallel do default(none) shared(js1,je1,is1,ie2,km,je2,ie1,ut,top_ratio,vt, & +!$OMP bot_ratio,dp0,js,je,ng,is,ie,gz,grid_type, & +!$OMP bd,npx,npy,sw_corner,se_corner,ne_corner, & +!$OMP nw_corner,area) & +!$OMP private(gz2, xfx, yfx, fx, fy, int_ratio) + do 6000 k=1,km+1 + + if ( k==1 ) then + do j=js1, je1 + do i=is1, ie2 + xfx(i,j) = ut(i,j,1) + (ut(i,j,1)-ut(i,j,2))*top_ratio + enddo + enddo + do j=js1, je2 + do i=is1, ie1 + yfx(i,j) = vt(i,j,1) + (vt(i,j,1)-vt(i,j,2))*top_ratio + enddo + enddo + elseif ( k==km+1 ) then +! Bottom extrapolation + do j=js1, je1 + do i=is1, ie2 + xfx(i,j) = ut(i,j,km) + (ut(i,j,km)-ut(i,j,km-1))*bot_ratio +! xfx(i,j) = r14*(3.*ut(i,j,km-2)-13.*ut(i,j,km-1)+24.*ut(i,j,km)) +! if ( xfx(i,j)*ut(i,j,km)<0. ) xfx(i,j) = 0. + enddo + enddo + do j=js1, je2 + do i=is1, ie1 + yfx(i,j) = vt(i,j,km) + (vt(i,j,km)-vt(i,j,km-1))*bot_ratio +! yfx(i,j) = r14*(3.*vt(i,j,km-2)-13.*vt(i,j,km-1)+24.*vt(i,j,km)) +! if ( yfx(i,j)*vt(i,j,km)<0. ) yfx(i,j) = 0. + enddo + enddo + else + int_ratio = 1./(dp0(k-1)+dp0(k)) + do j=js1, je1 + do i=is1, ie2 + xfx(i,j) = (dp0(k)*ut(i,j,k-1)+dp0(k-1)*ut(i,j,k))*int_ratio + enddo + enddo + do j=js1, je2 + do i=is1, ie1 + yfx(i,j) = (dp0(k)*vt(i,j,k-1)+dp0(k-1)*vt(i,j,k))*int_ratio + enddo + enddo + endif + + do j=js-ng, je+ng + do i=is-ng, ie+ng + gz2(i,j) = gz(i,j,k) + enddo + enddo + + if (grid_type < 3) call fill_4corners(gz2, 1, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + do j=js1, je1 + do i=is1, ie2 + if( xfx(i,j) > 0. ) then + fx(i,j) = gz2(i-1,j) + else + fx(i,j) = gz2(i ,j) + endif + fx(i,j) = xfx(i,j)*fx(i,j) + enddo + enddo + + if (grid_type < 3) call fill_4corners(gz2, 2, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + do j=js1,je2 + do i=is1,ie1 + if( yfx(i,j) > 0. ) then + fy(i,j) = gz2(i,j-1) + else + fy(i,j) = gz2(i,j) + endif + fy(i,j) = yfx(i,j)*fy(i,j) + enddo + enddo + + do j=js1, je1 + do i=is1,ie1 + gz(i,j,k) = (gz2(i,j)*area(i,j) + fx(i,j)- fx(i+1,j)+ fy(i,j)- fy(i,j+1)) & + / ( area(i,j) + xfx(i,j)-xfx(i+1,j)+yfx(i,j)-yfx(i,j+1)) + enddo + enddo +6000 continue + +! Enforce monotonicity of height to prevent blowup +!$OMP parallel do default(none) shared(is1,ie1,js1,je1,ws,zs,gz,rdt,km) + do j=js1, je1 + do i=is1, ie1 + ws(i,j) = ( zs(i,j) - gz(i,j,km+1) ) * rdt + enddo + do k=km, 1, -1 + do i=is1, ie1 + gz(i,j,k) = max( gz(i,j,k), gz(i,j,k+1) + dz_min ) + enddo + enddo + enddo + + end subroutine update_dz_c + + + subroutine update_dz_d(ndif, damp, hord, is, ie, js, je, km, ng, npx, npy, area, rarea, & + dp0, zs, zh, crx, cry, xfx, yfx, ws, rdt, gridstruct, bd, lim_fac) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: is, ie, js, je, ng, km, npx, npy + integer, intent(in):: hord + real, intent(in) :: rdt + real, intent(in) :: dp0(km) + real, intent(in) :: area(is-ng:ie+ng,js-ng:je+ng) + real, intent(in) :: rarea(is-ng:ie+ng,js-ng:je+ng) + real, intent(inout):: damp(km+1) + integer, intent(inout):: ndif(km+1) + real, intent(in ) :: zs(is-ng:ie+ng,js-ng:je+ng) + real, intent(inout) :: zh(is-ng:ie+ng,js-ng:je+ng,km+1) + real, intent(inout), dimension(is:ie+1,js-ng:je+ng,km):: crx, xfx + real, intent(inout), dimension(is-ng:ie+ng,js:je+1,km):: cry, yfx + real, intent(out) :: ws(is:ie,js:je) + type(fv_grid_type), intent(IN), target :: gridstruct + real, intent(in) :: lim_fac +!----------------------------------------------------- +! Local array: + real, dimension(is: ie+1, js-ng:je+ng,km+1):: crx_adv, xfx_adv + real, dimension(is-ng:ie+ng,js: je+1,km+1 ):: cry_adv, yfx_adv + real, dimension(is:ie+1,js:je ):: fx + real, dimension(is:ie ,js:je+1):: fy + real, dimension(is-ng:ie+ng+1,js-ng:je+ng ):: fx2 + real, dimension(is-ng:ie+ng ,js-ng:je+ng+1):: fy2 + real, dimension(is-ng:ie+ng ,js-ng:je+ng ):: wk2, z2 + real:: ra_x(is:ie,js-ng:je+ng) + real:: ra_y(is-ng:ie+ng,js:je) +!-------------------------------------------------------------------- + integer i, j, k, isd, ied, jsd, jed + logical:: uniform_grid + + uniform_grid = .false. + + damp(km+1) = damp(km) + ndif(km+1) = ndif(km) + + isd = is - ng; ied = ie + ng + jsd = js - ng; jed = je + ng + +!$OMP parallel do default(none) shared(jsd,jed,crx,xfx,crx_adv,xfx_adv,is,ie,isd,ied, & +!$OMP km,dp0,uniform_grid,js,je,cry,yfx,cry_adv,yfx_adv) + do j=jsd,jed + call edge_profile(crx, xfx, crx_adv, xfx_adv, is, ie+1, jsd, jed, j, km, & + dp0, uniform_grid, 0) + if ( j<=je+1 .and. j>=js ) & + call edge_profile(cry, yfx, cry_adv, yfx_adv, isd, ied, js, je+1, j, km, & + dp0, uniform_grid, 0) + enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,area,xfx_adv,yfx_adv, & +!$OMP damp,zh,crx_adv,cry_adv,npx,npy,hord,gridstruct,bd, & +!$OMP ndif,rarea,lim_fac) & +!$OMP private(z2, fx2, fy2, ra_x, ra_y, fx, fy,wk2) + do k=1,km+1 + + do j=jsd,jed + do i=is,ie + ra_x(i,j) = area(i,j) + xfx_adv(i,j,k) - xfx_adv(i+1,j,k) + enddo + enddo + do j=js,je + do i=isd,ied + ra_y(i,j) = area(i,j) + yfx_adv(i,j,k) - yfx_adv(i,j+1,k) + enddo + enddo + + if ( damp(k)>1.E-5 ) then + do j=jsd,jed + do i=isd,ied + z2(i,j) = zh(i,j,k) + enddo + enddo + call fv_tp_2d(z2, crx_adv(is,jsd,k), cry_adv(isd,js,k), npx, npy, hord, & + fx, fy, xfx_adv(is,jsd,k), yfx_adv(isd,js,k), gridstruct, bd, ra_x, ra_y, lim_fac) + call del6_vt_flux(ndif(k), npx, npy, damp(k), z2, wk2, fx2, fy2, gridstruct, bd) + do j=js,je + do i=is,ie + zh(i,j,k) = (z2(i,j)*area(i,j)+fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1)) & + / (ra_x(i,j)+ra_y(i,j)-area(i,j)) + (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j) + enddo + enddo + else + call fv_tp_2d(zh(isd,jsd,k), crx_adv(is,jsd,k), cry_adv(isd,js,k), npx, npy, hord, & + fx, fy, xfx_adv(is,jsd,k), yfx_adv(isd,js,k), gridstruct, bd, ra_x, ra_y, lim_fac) + do j=js,je + do i=is,ie + zh(i,j,k) = (zh(i,j,k)*area(i,j)+fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1)) & + / (ra_x(i,j) + ra_y(i,j) - area(i,j)) +! zh(i,j,k) = rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1)) & +! + zh(i,j,k)*(3.-rarea(i,j)*(ra_x(i,j) + ra_y(i,j))) + enddo + enddo + endif + + enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,km,ws,zs,zh,rdt) + do j=js, je + do i=is,ie + ws(i,j) = ( zs(i,j) - zh(i,j,km+1) ) * rdt + enddo + do k=km, 1, -1 + do i=is, ie +! Enforce monotonicity of height to prevent blowup + zh(i,j,k) = max( zh(i,j,k), zh(i,j,k+1) + dz_min ) + enddo + enddo + enddo + + end subroutine update_dz_d + + + subroutine Riem_Solver_c(ms, dt, is, ie, js, je, km, ng, & + akap, cappa, cp, & +#ifdef MULTI_GASES + kapad, & +#endif + ptop, hs, w3, pt, q_con, & + delp, gz, pef, ws, p_fac, a_imp, scale_m) + + integer, intent(in):: is, ie, js, je, ng, km + integer, intent(in):: ms + real, intent(in):: dt, akap, cp, ptop, p_fac, a_imp, scale_m + real, intent(in):: ws(is-ng:ie+ng,js-ng:je+ng) + real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delp + real, intent(in), dimension(is-ng:,js-ng:,1:):: q_con, cappa +#ifdef MULTI_GASES + real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: kapad +#endif + real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng) + real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: w3 +! OUTPUT PARAMETERS + real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: gz + real, intent( out), dimension(is-ng:ie+ng,js-ng:je+ng,km+1):: pef +! Local: + real, dimension(is-1:ie+1,km ):: dm, dz2, w2, pm2, gm2, cp2 + real, dimension(is-1:ie+1,km+1):: pem, pe2, peg +#ifdef MULTI_GASES + real, dimension(is-1:ie+1,km ):: kapad2 +#endif + real gama, rgrav + integer i, j, k + integer is1, ie1 + + gama = 1./(1.-akap) + rgrav = 1./grav + + is1 = is - 1 + ie1 = ie + 1 + +!$OMP parallel do default(none) shared(js,je,is1,ie1,km,delp,pef,ptop,gz,rgrav,w3,pt, & +#ifdef MULTI_GASES +!$OMP a_imp,dt,gama,akap,ws,p_fac,scale_m,ms,hs,q_con,cappa,kapad) & +!$OMP private(cp2,gm2, dm, dz2, w2, pm2, pe2, pem, peg, kapad2) +#else +!$OMP a_imp,dt,gama,akap,ws,p_fac,scale_m,ms,hs,q_con,cappa) & +!$OMP private(cp2,gm2, dm, dz2, w2, pm2, pe2, pem, peg) +#endif + do 2000 j=js-1, je+1 + + do k=1,km + do i=is1, ie1 + dm(i,k) = delp(i,j,k) + enddo + enddo + + do i=is1, ie1 + pef(i,j,1) = ptop ! full pressure at top + pem(i,1) = ptop +#ifdef USE_COND + peg(i,1) = ptop +#endif + enddo + + do k=2,km+1 + do i=is1, ie1 + pem(i,k) = pem(i,k-1) + dm(i,k-1) +#ifdef USE_COND +! Excluding contribution from condensates: + peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) +#endif + enddo + enddo + + do k=1,km + do i=is1, ie1 + dz2(i,k) = gz(i,j,k+1) - gz(i,j,k) +#ifdef USE_COND + pm2(i,k) = (peg(i,k+1)-peg(i,k))/log(peg(i,k+1)/peg(i,k)) + +#ifdef MOIST_CAPPA + cp2(i,k) = cappa(i,j,k) + gm2(i,k) = 1. / (1.-cp2(i,k)) +#endif + +#else + pm2(i,k) = dm(i,k)/log(pem(i,k+1)/pem(i,k)) +#endif +#ifdef MULTI_GASES + kapad2(i,k) = kapad(i,j,k) +#endif + dm(i,k) = dm(i,k) * rgrav + w2(i,k) = w3(i,j,k) + enddo + enddo + + + if ( a_imp < -0.01 ) then + call SIM3p0_solver(dt, is1, ie1, km, rdgas, gama, akap, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm, & + pem, w2, dz2, pt(is1:ie1,j,1:km), ws(is1,j), p_fac, scale_m) + elseif ( a_imp <= 0.5 ) then + call RIM_2D(ms, dt, is1, ie1, km, rdgas, gama, gm2, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, & + dm, pm2, w2, dz2, pt(is1:ie1,j,1:km), ws(is1,j), .true.) + else + call SIM1_solver(dt, is1, ie1, km, rdgas, gama, gm2, cp2, akap, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, & + dm, pm2, pem, w2, dz2, pt(is1:ie1,j,1:km), ws(is1,j), p_fac) + endif + + + do k=2,km+1 + do i=is1, ie1 + pef(i,j,k) = pe2(i,k) + pem(i,k) ! add hydrostatic full-component + enddo + enddo + +! Compute Height * grav (for p-gradient computation) + do i=is1, ie1 + gz(i,j,km+1) = hs(i,j) + enddo + + do k=km,1,-1 + do i=is1, ie1 + gz(i,j,k) = gz(i,j,k+1) - dz2(i,k)*grav + enddo + enddo + +2000 continue + + end subroutine Riem_Solver_c + + +!>GFDL - This routine will not give absoulte reproducibility when compiled with -fast-transcendentals. +!! GFDL - It is now inside of nh_core.F90 and being compiled without -fast-transcendentals. + subroutine Riem_Solver3test(ms, dt, is, ie, js, je, km, ng, & + isd, ied, jsd, jed, akap, cappa, cp, & +#ifdef MULTI_GASES + kapad, & +#endif + ptop, zs, q_con, w, delz, pt, & + delp, zh, pe, ppe, pk3, pk, peln, & + ws, scale_m, p_fac, a_imp, & + use_logp, last_call, fp_out) +!-------------------------------------------- +! !OUTPUT PARAMETERS +! Ouput: gz: grav*height at edges +! pe: full hydrostatic pressure +! ppe: non-hydrostatic pressure perturbation +!-------------------------------------------- + integer, intent(in):: ms, is, ie, js, je, km, ng + integer, intent(in):: isd, ied, jsd, jed + real, intent(in):: dt ! the BIG horizontal Lagrangian time step + real, intent(in):: akap, cp, ptop, p_fac, a_imp, scale_m + real, intent(in):: zs(isd:ied,jsd:jed) + logical, intent(in):: last_call, use_logp, fp_out + real, intent(in):: ws(is:ie,js:je) + real, intent(in), dimension(isd:,jsd:,1:):: q_con, cappa + real, intent(in), dimension(isd:ied,jsd:jed,km):: delp, pt +#ifdef MULTI_GASES + real, intent(in), dimension(isd:ied,jsd:jed,km):: kapad +#endif + real, intent(inout), dimension(isd:ied,jsd:jed,km+1):: zh + real, intent(inout), dimension(isd:ied,jsd:jed,km):: w + real, intent(inout):: pe(is-1:ie+1,km+1,js-1:je+1) + real, intent(out):: peln(is:ie,km+1,js:je) ! ln(pe) + real, intent(out), dimension(isd:ied,jsd:jed,km+1):: ppe + real, intent(out):: delz(is:ie,js:je,km) + real, intent(out):: pk(is:ie,js:je,km+1) + real, intent(out):: pk3(isd:ied,jsd:jed,km+1) +! Local: + real, dimension(is:ie,km):: dm, dz2, pm2, w2, gm2, cp2 + real, dimension(is:ie,km+1)::pem, pe2, peln2, peg, pelng +#ifdef MULTI_GASES + real, dimension(is:ie,km):: kapad2 +#endif + real gama, rgrav, ptk, peln1 + integer i, j, k + + gama = 1./(1.-akap) + rgrav = 1./grav + peln1 = log(ptop) + ptk = exp(akap*peln1) + +!$OMP parallel do default(none) shared(is,ie,js,je,km,delp,ptop,peln1,pk3,ptk,akap,rgrav,zh,pt, & +!$OMP w,a_imp,dt,gama,ws,p_fac,scale_m,ms,delz,last_call, & +#ifdef MULTI_GASES +!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con,kapad ) & +!$OMP private(cp2, gm2, dm, dz2, pm2, pem, peg, pelng, pe2, peln2, w2,kapad2) +#else +!$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con ) & +!$OMP private(cp2, gm2, dm, dz2, pm2, pem, peg, pelng, pe2, peln2, w2) +#endif + do 2000 j=js, je + + do k=1,km + do i=is, ie + dm(i,k) = delp(i,j,k) +#ifdef MOIST_CAPPA + cp2(i,k) = cappa(i,j,k) +#endif +#ifdef MULTI_GASES + kapad2(i,k) = kapad(i,j,k) +#endif + enddo + enddo + + do i=is,ie + pem(i,1) = ptop + peln2(i,1) = peln1 + pk3(i,j,1) = ptk +#ifdef USE_COND + peg(i,1) = ptop + pelng(i,1) = peln1 +#endif + enddo + do k=2,km+1 + do i=is,ie + pem(i,k) = pem(i,k-1) + dm(i,k-1) + peln2(i,k) = log(pem(i,k)) +#ifdef USE_COND +! Excluding contribution from condensates: +! peln used during remap; pk3 used only for p_grad + peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) + pelng(i,k) = log(peg(i,k)) +#endif + pk3(i,j,k) = exp(akap*peln2(i,k)) + enddo + enddo + + do k=1,km + do i=is, ie +#ifdef USE_COND + pm2(i,k) = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) + +#ifdef MOIST_CAPPA + gm2(i,k) = 1. / (1.-cp2(i,k)) +#endif + +#else + pm2(i,k) = dm(i,k)/(peln2(i,k+1)-peln2(i,k)) +#endif + dm(i,k) = dm(i,k) * rgrav + dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) + w2(i,k) = w(i,j,k) + enddo + enddo + + + if ( a_imp < -0.999 ) then + call SIM3p0_solver(dt, is, ie, km, rdgas, gama, akap, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm, & + pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), p_fac, scale_m ) + elseif ( a_imp < -0.5 ) then + call SIM3_solver(dt, is, ie, km, rdgas, gama, akap, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm, & + pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), abs(a_imp), p_fac, scale_m) + elseif ( a_imp <= 0.5 ) then + call RIM_2D(ms, dt, is, ie, km, rdgas, gama, gm2, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, & + dm, pm2, w2, dz2, pt(is:ie,j,1:km), ws(is,j), .false.) + elseif ( a_imp > 0.999 ) then + call SIM1_solver(dt, is, ie, km, rdgas, gama, gm2, cp2, akap, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm, & + pm2, pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), p_fac) + else + call SIM_solver(dt, is, ie, km, rdgas, gama, gm2, cp2, akap, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm, & + pm2, pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), & + a_imp, p_fac, scale_m) + endif + + + do k=1, km + do i=is, ie + w(i,j,k) = w2(i,k) + delz(i,j,k) = dz2(i,k) + enddo + enddo + + if ( last_call ) then + do k=1,km+1 + do i=is,ie + peln(i,k,j) = peln2(i,k) + pk(i,j,k) = pk3(i,j,k) + pe(i,k,j) = pem(i,k) + enddo + enddo + endif + + if( fp_out ) then + do k=1,km+1 + do i=is, ie + ppe(i,j,k) = pe2(i,k) + pem(i,k) + enddo + enddo + else + do k=1,km+1 + do i=is, ie + ppe(i,j,k) = pe2(i,k) + enddo + enddo + endif + + if ( use_logp ) then + do k=2,km+1 + do i=is, ie + pk3(i,j,k) = peln2(i,k) + enddo + enddo + endif + + do i=is, ie + zh(i,j,km+1) = zs(i,j) + enddo + do k=km,1,-1 + do i=is, ie + zh(i,j,k) = zh(i,j,k+1) - dz2(i,k) + enddo + enddo + +2000 continue + + end subroutine Riem_Solver3test + + subroutine imp_diff_w(j, is, ie, js, je, ng, km, cd, delz, ws, w, w3) + integer, intent(in) :: j, is, ie, js, je, km, ng + real, intent(in) :: cd + real, intent(in) :: delz(is:ie, km) !< delta-height (m) + real, intent(in) :: w(is:ie, km) !< vertical vel. (m/s) + real, intent(in) :: ws(is:ie) + real, intent(out) :: w3(is-ng:ie+ng,js-ng:je+ng,km) +! Local: + real, dimension(is:ie,km):: c, gam, dz, wt + real:: bet(is:ie) + real:: a + integer:: i, k + + do k=2,km + do i=is,ie + dz(i,k) = 0.5*(delz(i,k-1)+delz(i,k)) + enddo + enddo + do k=1,km-1 + do i=is,ie + c(i,k) = -cd/(dz(i,k+1)*delz(i,k)) + enddo + enddo + +! model top: + do i=is,ie + bet(i) = 1. - c(i,1) ! bet(i) = b + wt(i,1) = w(i,1) / bet(i) + enddo + +! Interior: + do k=2,km-1 + do i=is,ie + gam(i,k) = c(i,k-1)/bet(i) + a = cd/(dz(i,k)*delz(i,k)) + bet(i) = (1.+a-c(i,k)) + a*gam(i,k) + wt(i,k) = (w(i,k) + a*wt(i,k-1)) / bet(i) + enddo + enddo + +! Bottom: + do i=is,ie + gam(i,km) = c(i,km-1) / bet(i) + a = cd/(dz(i,km)*delz(i,km)) + wt(i,km) = (w(i,km) + 2.*ws(i)*cd/delz(i,km)**2 & + + a*wt(i,km-1))/(1. + a + (cd+cd)/delz(i,km)**2 + a*gam(i,km)) + enddo + + do k=km-1,1,-1 + do i=is,ie + wt(i,k) = wt(i,k) - gam(i,k+1)*wt(i,k+1) + enddo + enddo + + do k=1,km + do i=is,ie + w3(i,j,k) = wt(i,k) + enddo + enddo + + end subroutine imp_diff_w + + + subroutine RIM_2D(ms, bdt, is, ie, km, rgas, gama, gm2, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm2, pm2, w2, dz2, pt2, ws, c_core ) + + integer, intent(in):: ms, is, ie, km + real, intent(in):: bdt, gama, rgas + real, intent(in), dimension(is:ie,km):: dm2, pm2, gm2 + logical, intent(in):: c_core + real, intent(in ) :: pt2(is:ie,km) + real, intent(in ) :: ws(is:ie) +! IN/OUT: + real, intent(inout):: dz2(is:ie,km) + real, intent(inout):: w2(is:ie,km) + real, intent(out ):: pe2(is:ie,km+1) +#ifdef MULTI_GASES + real, intent(inout), dimension(is:ie,km):: kapad2 +#endif +! Local: + real:: ws2(is:ie) + real, dimension(km+1):: m_bot, m_top, r_bot, r_top, pe1, pbar, wbar + real, dimension(km):: r_hi, r_lo, dz, wm, dm, dts + real, dimension(km):: pf1, wc, cm , pp, pt1 + real:: dt, rdt, grg, z_frac, ptmp1, rden, pf, time_left + real:: m_surf +#ifdef MULTI_GASES + real gamax +#endif + integer:: i, k, n, ke, kt1, ktop + integer:: ks0, ks1 + + grg = gama * rgas + rdt = 1. / bdt + dt = bdt / real(ms) + + pbar(:) = 0. + wbar(:) = 0. + + do i=is,ie + ws2(i) = 2.*ws(i) + enddo + + do 6000 i=is,ie + + do k=1,km + dz(k) = dz2(i,k) + dm(k) = dm2(i,k) + wm(k) = w2(i,k)*dm(k) + pt1(k) = pt2(i,k) + enddo + + pe1(:) = 0. + wbar(km+1) = ws(i) + + ks0 = 1 + if ( ms > 1 .and. ms < 8 ) then +! Continuity of (pbar, wbar) is maintained + do k=1, km + rden = -rgas*dm(k)/dz(k) +#ifdef MOIST_CAPPA + pf1(k) = exp( gm2(i,k)*log(rden*pt1(k)) ) +! dts(k) = -dz(k)/sqrt(gm2(i,k)*rgas*pf1(k)/rden) + dts(k) = -dz(k)/sqrt(grg*pf1(k)/rden) +#else +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,k)) + pf1(k) = exp( gamax*log(rden*pt1(k)) ) +#else + pf1(k) = exp( gama*log(rden*pt1(k)) ) +#endif + dts(k) = -dz(k)/sqrt(grg*pf1(k)/rden) +#endif + if ( bdt > dts(k) ) then + ks0 = k-1 + goto 222 + endif + enddo + ks0 = km +222 if ( ks0==1 ) goto 244 + + do k=1, ks0 + cm(k) = dm(k) / dts(k) + wc(k) = wm(k) / dts(k) + pp(k) = pf1(k) - pm2(i,k) + enddo + + wbar(1) = (wc(1)+pp(1)) / cm(1) + do k=2, ks0 + wbar(k) = (wc(k-1)+wc(k) + pp(k)-pp(k-1)) / (cm(k-1)+cm(k)) + pbar(k) = bdt*(cm(k-1)*wbar(k) - wc(k-1) + pp(k-1)) + pe1(k) = pbar(k) + enddo + + if ( ks0 == km ) then + pbar(km+1) = bdt*(cm(km)*wbar(km+1) - wc(km) + pp(km)) + if ( c_core ) then + do k=1,km + dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) + enddo + else + do k=1,km + dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) + w2(i,k) = (wm(k)+pbar(k+1)-pbar(k))/dm(k) + enddo + endif + pe2(i,1) = 0. + do k=2,km+1 + pe2(i,k) = pbar(k)*rdt + enddo + goto 6000 ! next i + else + if ( c_core ) then + do k=1, ks0-1 + dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) + enddo + else + do k=1, ks0-1 + dz2(i,k) = dz(k) + bdt*(wbar(k+1) - wbar(k)) + w2(i,k) = (wm(k)+pbar(k+1)-pbar(k))/dm(k) + enddo + endif + pbar(ks0) = pbar(ks0) / real(ms) + endif + endif +244 ks1 = ks0 + + do 5000 n=1, ms + + do k=ks1, km + rden = -rgas*dm(k)/dz(k) +#ifdef MOIST_CAPPA + pf = exp( gm2(i,k)*log(rden*pt1(k)) ) +! dts(k) = -dz(k) / sqrt( gm2(i,k)*rgas*pf/rden ) + dts(k) = -dz(k) / sqrt( grg*pf/rden ) +#else +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,k)) + pf = exp( gamax*log(rden*pt1(k)) ) +#else + pf = exp( gama*log(rden*pt1(k)) ) +#endif + dts(k) = -dz(k) / sqrt( grg*pf/rden ) +#endif + ptmp1 = dts(k)*(pf - pm2(i,k)) + r_lo(k) = wm(k) + ptmp1 + r_hi(k) = wm(k) - ptmp1 + enddo + + ktop = ks1 + do k=ks1, km + if( dt > dts(k) ) then + ktop = k-1 + goto 333 + endif + enddo + ktop = km +333 continue + + if ( ktop >= ks1 ) then + do k=ks1, ktop + z_frac = dt/dts(k) + r_bot(k ) = z_frac*r_lo(k) + r_top(k+1) = z_frac*r_hi(k) + m_bot(k ) = z_frac* dm(k) + m_top(k+1) = m_bot(k) + enddo + if ( ktop == km ) goto 666 + endif + + do k=ktop+2, km+1 + m_top(k) = 0. + r_top(k) = 0. + enddo + + kt1 = max(1, ktop) + do 444 ke=km+1, ktop+2, -1 + time_left = dt + do k=ke-1, kt1, -1 + if ( time_left > dts(k) ) then + time_left = time_left - dts(k) + m_top(ke) = m_top(ke) + dm(k) + r_top(ke) = r_top(ke) + r_hi(k) + else + z_frac = time_left/dts(k) + m_top(ke) = m_top(ke) + z_frac*dm(k) + r_top(ke) = r_top(ke) + z_frac*r_hi(k) + go to 444 ! next level + endif + enddo +444 continue + + do k=ktop+1, km + m_bot(k) = 0. + r_bot(k) = 0. + enddo + + do 4000 ke=ktop+1, km + time_left = dt + do k=ke, km + if ( time_left > dts(k) ) then + time_left = time_left - dts(k) + m_bot(ke) = m_bot(ke) + dm(k) + r_bot(ke) = r_bot(ke) + r_lo(k) + else + z_frac = time_left/dts(k) + m_bot(ke) = m_bot(ke) + z_frac* dm(k) + r_bot(ke) = r_bot(ke) + z_frac*r_lo(k) + go to 4000 ! next interface + endif + enddo + m_surf = m_bot(ke) + do k=km, kt1, -1 + if ( time_left > dts(k) ) then + time_left = time_left - dts(k) + m_bot(ke) = m_bot(ke) + dm(k) + r_bot(ke) = r_bot(ke) - r_hi(k) + else + z_frac = time_left/dts(k) + m_bot(ke) = m_bot(ke) + z_frac* dm(k) + r_bot(ke) = r_bot(ke) - z_frac*r_hi(k) + (m_bot(ke)-m_surf)*ws2(i) + go to 4000 ! next interface + endif + enddo +4000 continue + +666 if ( ks1==1 ) wbar(1) = r_bot(1) / m_bot(1) + do k=ks1+1, km + wbar(k) = (r_bot(k)+r_top(k)) / (m_top(k)+m_bot(k)) + enddo +! pbar here is actually dt*pbar + do k=ks1+1, km+1 + pbar(k) = m_top(k)*wbar(k) - r_top(k) + pe1(k) = pe1(k) + pbar(k) + enddo + + if ( n==ms ) then + if ( c_core ) then + do k=ks1, km + dz2(i,k) = dz(k) + dt*(wbar(k+1)-wbar(k)) + enddo + else + do k=ks1, km + dz2(i,k) = dz(k) + dt*(wbar(k+1)-wbar(k)) + w2(i,k) = ( wm(k) + pbar(k+1) - pbar(k) ) / dm(k) + enddo + endif + else + do k=ks1, km + dz(k) = dz(k) + dt*(wbar(k+1)-wbar(k)) + wm(k) = wm(k) + pbar(k+1) - pbar(k) + enddo + endif + +5000 continue + pe2(i,1) = 0. + do k=2,km+1 + pe2(i,k) = pe1(k)*rdt + enddo + +6000 continue ! end i-loop + + end subroutine RIM_2D + + subroutine SIM3_solver(dt, is, ie, km, rgas, gama, kappa, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm, & + pem, w2, dz2, pt2, ws, alpha, p_fac, scale_m) + integer, intent(in):: is, ie, km + real, intent(in):: dt, rgas, gama, kappa, alpha, p_fac, scale_m + real, intent(in ), dimension(is:ie,km):: dm, pt2 + real, intent(in ):: ws(is:ie) + real, intent(in ), dimension(is:ie,km+1):: pem + real, intent(out):: pe2(is:ie,km+1) + real, intent(inout), dimension(is:ie,km):: dz2, w2 +#ifdef MULTI_GASES + real, intent(inout), dimension(is:ie,km):: kapad2 +#endif +! Local + real, dimension(is:ie,km ):: aa, bb, dd, w1, wk, g_rat, gam + real, dimension(is:ie,km+1):: pp + real, dimension(is:ie):: p1, wk1, bet + real beta, t2, t1g, rdt, ra, capa1, r2g, r6g +#ifdef MULTI_GASES + real gamax, capa1x, t1gx +#endif + integer i, k + + beta = 1. - alpha + ra = 1. / alpha + t2 = beta / alpha + t1g = gama * 2.*(alpha*dt)**2 + rdt = 1. / dt + capa1 = kappa - 1. + r2g = grav / 2. + r6g = grav / 6. + + + do k=1,km + do i=is, ie + w1(i,k) = w2(i,k) +! Full pressure at center +#ifdef MULTI_GASES + gamax = 1. / (1.-kapad2(i,k)) + aa(i,k) = exp(gamax*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) +#else + aa(i,k) = exp(gama*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) +#endif + enddo + enddo + + do k=1,km-1 + do i=is, ie + g_rat(i,k) = dm(i,k)/dm(i,k+1) ! for profile reconstruction + bb(i,k) = 2.*(1.+g_rat(i,k)) + dd(i,k) = 3.*(aa(i,k) + g_rat(i,k)*aa(i,k+1)) + enddo + enddo + +! pe2 is full p at edges + do i=is, ie +! Top: + bet(i) = bb(i,1) + pe2(i,1) = pem(i,1) + pe2(i,2) = (dd(i,1)-pem(i,1)) / bet(i) +! Bottom: + bb(i,km) = 2. + dd(i,km) = 3.*aa(i,km) + r2g*dm(i,km) + enddo + + do k=2,km + do i=is, ie + gam(i,k) = g_rat(i,k-1) / bet(i) + bet(i) = bb(i,k) - gam(i,k) + pe2(i,k+1) = (dd(i,k) - pe2(i,k) ) / bet(i) + enddo + enddo + + do k=km, 2, -1 + do i=is, ie + pe2(i,k) = pe2(i,k) - gam(i,k)*pe2(i,k+1) + enddo + enddo +! done reconstruction of full: + +! pp is pert. p at edges + do k=1, km+1 + do i=is, ie + pp(i,k) = pe2(i,k) - pem(i,k) + enddo + enddo + + do k=2, km + do i=is, ie +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,k)) + t1gx = gamax*2.*(alpha*dt)**2 + aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) +#else + aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) +#endif + wk(i,k) = t2*aa(i,k)*(w1(i,k-1)-w1(i,k)) + aa(i,k) = aa(i,k) - scale_m*dm(i,1) + enddo + enddo + do i=is, ie + bet(i) = dm(i,1) - aa(i,2) + w2(i,1) = (dm(i,1)*w1(i,1)+dt*pp(i,2) + wk(i,2)) / bet(i) + enddo + do k=2,km-1 + do i=is, ie + gam(i,k) = aa(i,k) / bet(i) + bet(i) = dm(i,k) - (aa(i,k)+aa(i,k+1) + aa(i,k)*gam(i,k)) + w2(i,k) = (dm(i,k)*w1(i,k)+dt*(pp(i,k+1)-pp(i,k)) + wk(i,k+1)-wk(i,k) & + - aa(i,k)*w2(i,k-1)) / bet(i) + enddo + enddo + do i=is, ie +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,km)) + t1gx = gamax*2.*(alpha*dt)**2 + wk1(i) = t1gx/dz2(i,km)*pe2(i,km+1) +#else + wk1(i) = t1g/dz2(i,km)*pe2(i,km+1) +#endif + gam(i,km) = aa(i,km) / bet(i) + bet(i) = dm(i,km) - (aa(i,km)+wk1(i) + aa(i,km)*gam(i,km)) + w2(i,km) = (dm(i,km)*w1(i,km)+dt*(pp(i,km+1)-pp(i,km))-wk(i,km) + & + wk1(i)*(t2*w1(i,km)-ra*ws(i)) - aa(i,km)*w2(i,km-1)) / bet(i) + enddo + do k=km-1, 1, -1 + do i=is, ie + w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) + enddo + enddo + +! pe2 is updated perturbation p at edges + do i=is, ie + pe2(i,1) = 0. + enddo + do k=1,km + do i=is, ie + pe2(i,k+1) = pe2(i,k) + ( dm(i,k)*(w2(i,k)-w1(i,k))*rdt & + - beta*(pp(i,k+1)-pp(i,k)) )*ra + enddo + enddo + +! Full non-hydro pressure at edges: + do i=is, ie + pe2(i,1) = pem(i,1) + enddo + do k=2,km+1 + do i=is, ie + pe2(i,k) = max(p_fac*pem(i,k), pe2(i,k)+pem(i,k)) + enddo + enddo + + do i=is, ie +! Recover cell-averaged pressure + p1(i) = (pe2(i,km)+ 2.*pe2(i,km+1))*r3 - r6g*dm(i,km) +#ifdef MULTI_GASES + capa1x = kapad2(i,km) - 1. + dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1x*log(p1(i)) ) +#else + dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1*log(p1(i)) ) +#endif + enddo + + do k=km-1, 1, -1 + do i=is, ie + p1(i) = (pe2(i,k)+bb(i,k)*pe2(i,k+1)+g_rat(i,k)*pe2(i,k+2))*r3 - g_rat(i,k)*p1(i) +#ifdef MULTI_GASES + capa1x = kapad2(i,k) - 1. + dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1x*log(p1(i)) ) +#else + dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1*log(p1(i)) ) +#endif + enddo + enddo + + do k=1,km+1 + do i=is, ie + pe2(i,k) = pe2(i,k) - pem(i,k) + pe2(i,k) = pe2(i,k) + beta*(pp(i,k) - pe2(i,k)) + enddo + enddo + + end subroutine SIM3_solver + + subroutine SIM3p0_solver(dt, is, ie, km, rgas, gama, kappa, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm, & + pem, w2, dz2, pt2, ws, p_fac, scale_m) +! Sa SIM3, but for beta==0 + integer, intent(in):: is, ie, km + real, intent(in):: dt, rgas, gama, kappa, p_fac, scale_m + real, intent(in ), dimension(is:ie,km):: dm, pt2 + real, intent(in ):: ws(is:ie) + real, intent(in ):: pem(is:ie,km+1) + real, intent(out):: pe2(is:ie,km+1) + real, intent(inout), dimension(is:ie,km):: dz2, w2 +#ifdef MULTI_GASES + real, intent(inout), dimension(is:ie,km):: kapad2 +#endif +! Local + real, dimension(is:ie,km ):: aa, bb, dd, w1, g_rat, gam + real, dimension(is:ie,km+1):: pp + real, dimension(is:ie):: p1, wk1, bet + real t1g, rdt, capa1, r2g, r6g +#ifdef MULTI_GASES + real gamax, capa1x, t1gx +#endif + integer i, k + + t1g = 2.*gama*dt**2 + rdt = 1. / dt + capa1 = kappa - 1. + r2g = grav / 2. + r6g = grav / 6. + + do k=1,km + do i=is, ie + w1(i,k) = w2(i,k) +! Full pressure at center +#ifdef MULTI_GASES + gamax = 1. / ( 1. - kapad2(i,k) ) + aa(i,k) = exp(gamax*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) +#else + aa(i,k) = exp(gama*log(-dm(i,k)/dz2(i,k)*rgas*pt2(i,k))) +#endif + enddo + enddo + + do k=1,km-1 + do i=is, ie + g_rat(i,k) = dm(i,k)/dm(i,k+1) ! for profile reconstruction + bb(i,k) = 2.*(1.+g_rat(i,k)) + dd(i,k) = 3.*(aa(i,k) + g_rat(i,k)*aa(i,k+1)) + enddo + enddo + +! pe2 is full p at edges + do i=is, ie +! Top: + bet(i) = bb(i,1) + pe2(i,1) = pem(i,1) + pe2(i,2) = (dd(i,1)-pem(i,1)) / bet(i) +! Bottom: + bb(i,km) = 2. + dd(i,km) = 3.*aa(i,km) + r2g*dm(i,km) + enddo + + do k=2,km + do i=is, ie + gam(i,k) = g_rat(i,k-1) / bet(i) + bet(i) = bb(i,k) - gam(i,k) + pe2(i,k+1) = (dd(i,k) - pe2(i,k) ) / bet(i) + enddo + enddo + + do k=km, 2, -1 + do i=is, ie + pe2(i,k) = pe2(i,k) - gam(i,k)*pe2(i,k+1) + enddo + enddo +! done reconstruction of full: + +! pp is pert. p at edges + do k=1, km+1 + do i=is, ie + pp(i,k) = pe2(i,k) - pem(i,k) + enddo + enddo + + do k=2, km + do i=is, ie +#ifdef MULTI_GASES + gamax = 1. / (1.-kapad2(i,k)) + t1gx = 2.*gamax*dt**2 + aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) - scale_m*dm(i,1) +#else + aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) - scale_m*dm(i,1) +#endif + enddo + enddo + do i=is, ie + bet(i) = dm(i,1) - aa(i,2) + w2(i,1) = (dm(i,1)*w1(i,1)+dt*pp(i,2)) / bet(i) + enddo + do k=2,km-1 + do i=is, ie + gam(i,k) = aa(i,k) / bet(i) + bet(i) = dm(i,k) - (aa(i,k)+aa(i,k+1) + aa(i,k)*gam(i,k)) + w2(i,k) = (dm(i,k)*w1(i,k)+dt*(pp(i,k+1)-pp(i,k))-aa(i,k)*w2(i,k-1))/bet(i) + enddo + enddo + do i=is, ie +#ifdef MULTI_GASES + gamax = 1. / (1.-kapad2(i,km)) + t1gx = 2.*gamax*dt**2 + wk1(i) = t1gx/dz2(i,km)*pe2(i,km+1) +#else + wk1(i) = t1g/dz2(i,km)*pe2(i,km+1) +#endif + gam(i,km) = aa(i,km) / bet(i) + bet(i) = dm(i,km) - (aa(i,km)+wk1(i) + aa(i,km)*gam(i,km)) + w2(i,km) = (dm(i,km)*w1(i,km)+dt*(pp(i,km+1)-pp(i,km))-wk1(i)*ws(i) - & + aa(i,km)*w2(i,km-1)) / bet(i) + enddo + do k=km-1, 1, -1 + do i=is, ie + w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) + enddo + enddo + +! pe2 is updated perturbation p at edges + do i=is, ie + pe2(i,1) = 0. + enddo + do k=1,km + do i=is, ie + pe2(i,k+1) = pe2(i,k) + dm(i,k)*(w2(i,k)-w1(i,k))*rdt + enddo + enddo + +! Full non-hydro pressure at edges: + do i=is, ie + pe2(i,1) = pem(i,1) + enddo + do k=2,km+1 + do i=is, ie + pe2(i,k) = max(p_fac*pem(i,k), pe2(i,k)+pem(i,k)) + enddo + enddo + + do i=is, ie +! Recover cell-averaged pressure + p1(i) = (pe2(i,km)+ 2.*pe2(i,km+1))*r3 - r6g*dm(i,km) +#ifdef MULTI_GASES + capa1x = kapad2(i,km) - 1. + dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1x*log(p1(i)) ) +#else + dz2(i,km) = -dm(i,km)*rgas*pt2(i,km)*exp( capa1*log(p1(i)) ) +#endif + enddo + + do k=km-1, 1, -1 + do i=is, ie + p1(i) = (pe2(i,k)+bb(i,k)*pe2(i,k+1)+g_rat(i,k)*pe2(i,k+2))*r3-g_rat(i,k)*p1(i) +#ifdef MULTI_GASES + capa1x = kapad2(i,k) - 1. + dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1x*log(p1(i)) ) +#else + dz2(i,k) = -dm(i,k)*rgas*pt2(i,k)*exp( capa1*log(p1(i)) ) +#endif + enddo + enddo + + do k=1,km+1 + do i=is, ie + pe2(i,k) = pe2(i,k) - pem(i,k) + enddo + enddo + + end subroutine SIM3p0_solver + + + subroutine SIM1_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe, dm2, & + pm2, pem, w2, dz2, pt2, ws, p_fac) + integer, intent(in):: is, ie, km + real, intent(in):: dt, rgas, gama, kappa, p_fac + real, intent(in), dimension(is:ie,km):: dm2, pt2, pm2, gm2, cp2 + real, intent(in ):: ws(is:ie) + real, intent(in ), dimension(is:ie,km+1):: pem + real, intent(out):: pe(is:ie,km+1) + real, intent(inout), dimension(is:ie,km):: dz2, w2 +#ifdef MULTI_GASES + real, intent(inout), dimension(is:ie,km):: kapad2 +#endif +! Local + real, dimension(is:ie,km ):: aa, bb, dd, w1, g_rat, gam + real, dimension(is:ie,km+1):: pp + real, dimension(is:ie):: p1, bet + real t1g, rdt, capa1 +#ifdef MULTI_GASES + real gamax, capa1x, t1gx +#endif + integer i, k + +#ifdef MOIST_CAPPA + t1g = 2.*dt*dt +#else + t1g = gama * 2.*dt*dt +#endif + rdt = 1. / dt + capa1 = kappa - 1. + + do k=1,km + do i=is, ie +#ifdef MOIST_CAPPA + pe(i,k) = exp(gm2(i,k)*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) +#else +#ifdef MULTI_GASES + gamax = 1. / ( 1. - kapad2(i,k) ) + pe(i,k) = exp(gamax*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) +#else + pe(i,k) = exp(gama*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) +#endif +#endif + w1(i,k) = w2(i,k) + enddo + enddo + + do k=1,km-1 + do i=is, ie + g_rat(i,k) = dm2(i,k)/dm2(i,k+1) + bb(i,k) = 2.*(1.+g_rat(i,k)) + dd(i,k) = 3.*(pe(i,k) + g_rat(i,k)*pe(i,k+1)) + enddo + enddo + + do i=is, ie + bet(i) = bb(i,1) + pp(i,1) = 0. + pp(i,2) = dd(i,1) / bet(i) + bb(i,km) = 2. + dd(i,km) = 3.*pe(i,km) + enddo + + do k=2,km + do i=is, ie + gam(i,k) = g_rat(i,k-1) / bet(i) + bet(i) = bb(i,k) - gam(i,k) + pp(i,k+1) = (dd(i,k) - pp(i,k) ) / bet(i) + enddo + enddo + + do k=km, 2, -1 + do i=is, ie + pp(i,k) = pp(i,k) - gam(i,k)*pp(i,k+1) + enddo + enddo + +! Start the w-solver + do k=2, km + do i=is, ie +#ifdef MOIST_CAPPA + aa(i,k) = t1g*0.5*(gm2(i,k-1)+gm2(i,k))/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)+pp(i,k)) +#else +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,k)) + t1gx = gamax * 2.*dt*dt + aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)+pp(i,k)) +#else + aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k)) * (pem(i,k)+pp(i,k)) +#endif +#endif + enddo + enddo + do i=is, ie + bet(i) = dm2(i,1) - aa(i,2) + w2(i,1) = (dm2(i,1)*w1(i,1) + dt*pp(i,2)) / bet(i) + enddo + do k=2,km-1 + do i=is, ie + gam(i,k) = aa(i,k) / bet(i) + bet(i) = dm2(i,k) - (aa(i,k) + aa(i,k+1) + aa(i,k)*gam(i,k)) + w2(i,k) = (dm2(i,k)*w1(i,k)+dt*(pp(i,k+1)-pp(i,k))-aa(i,k)*w2(i,k-1)) / bet(i) + enddo + enddo + do i=is, ie +#ifdef MOIST_CAPPA + p1(i) = t1g*gm2(i,km)/dz2(i,km)*(pem(i,km+1)+pp(i,km+1)) +#else +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,km)) + t1gx = gamax * 2.*dt*dt + p1(i) = t1gx/dz2(i,km)*(pem(i,km+1)+pp(i,km+1)) +#else + p1(i) = t1g/dz2(i,km)*(pem(i,km+1)+pp(i,km+1)) +#endif +#endif + gam(i,km) = aa(i,km) / bet(i) + bet(i) = dm2(i,km) - (aa(i,km)+p1(i) + aa(i,km)*gam(i,km)) + w2(i,km) = (dm2(i,km)*w1(i,km)+dt*(pp(i,km+1)-pp(i,km))-p1(i)*ws(i)-aa(i,km)*w2(i,km-1))/bet(i) + enddo + do k=km-1, 1, -1 + do i=is, ie + w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) + enddo + enddo + + do i=is, ie + pe(i,1) = 0. + enddo + do k=1,km + do i=is, ie + pe(i,k+1) = pe(i,k) + dm2(i,k)*(w2(i,k)-w1(i,k))*rdt + enddo + enddo + + do i=is, ie + p1(i) = ( pe(i,km) + 2.*pe(i,km+1) )*r3 +#ifdef MOIST_CAPPA + dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp((cp2(i,km)-1.)*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) +#else +#ifdef MULTI_GASES + capa1x = kapad2(i,km)-1. + dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1x*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) +#else + dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) +#endif +#endif + enddo + + do k=km-1, 1, -1 + do i=is, ie + p1(i) = (pe(i,k) + bb(i,k)*pe(i,k+1) + g_rat(i,k)*pe(i,k+2))*r3 - g_rat(i,k)*p1(i) +#ifdef MOIST_CAPPA + dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp((cp2(i,k)-1.)*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) + +#else +#ifdef MULTI_GASES + capa1x = kapad2(i,k)-1. + dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1x*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) +#else + dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) +#endif +#endif + enddo + enddo + + end subroutine SIM1_solver + + subroutine SIM_solver(dt, is, ie, km, rgas, gama, gm2, cp2, kappa, & +#ifdef MULTI_GASES + kapad2, & +#endif + pe2, dm2, & + pm2, pem, w2, dz2, pt2, ws, alpha, p_fac, scale_m) + integer, intent(in):: is, ie, km + real, intent(in):: dt, rgas, gama, kappa, p_fac, alpha, scale_m + real, intent(in), dimension(is:ie,km):: dm2, pt2, pm2, gm2, cp2 + real, intent(in ):: ws(is:ie) + real, intent(in ), dimension(is:ie,km+1):: pem + real, intent(out):: pe2(is:ie,km+1) + real, intent(inout), dimension(is:ie,km):: dz2, w2 +#ifdef MULTI_GASES + real, intent(inout), dimension(is:ie,km):: kapad2 +#endif +! Local + real, dimension(is:ie,km ):: aa, bb, dd, w1, wk, g_rat, gam + real, dimension(is:ie,km+1):: pp + real, dimension(is:ie):: p1, wk1, bet + real beta, t2, t1g, rdt, ra, capa1 +#ifdef MULTI_GASES + real gamax, capa1x, t1gx +#endif + integer i, k + + beta = 1. - alpha + ra = 1. / alpha + t2 = beta / alpha +#ifdef MOIST_CAPPA + t1g = 2.*(alpha*dt)**2 +#else + t1g = 2.*gama*(alpha*dt)**2 +#endif + rdt = 1. / dt + capa1 = kappa - 1. + + do k=1,km + do i=is, ie + w1(i,k) = w2(i,k) +! P_g perturbation +#ifdef MOIST_CAPPA + pe2(i,k) = exp(gm2(i,k)*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) +#else +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,k)) + pe2(i,k) = exp(gamax*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) +#else + pe2(i,k) = exp(gama*log(-dm2(i,k)/dz2(i,k)*rgas*pt2(i,k))) - pm2(i,k) +#endif +#endif + enddo + enddo + + do k=1,km-1 + do i=is, ie + g_rat(i,k) = dm2(i,k)/dm2(i,k+1) + bb(i,k) = 2.*(1.+g_rat(i,k)) + dd(i,k) = 3.*(pe2(i,k) + g_rat(i,k)*pe2(i,k+1)) + enddo + enddo + + do i=is, ie + bet(i) = bb(i,1) + pp(i,1) = 0. + pp(i,2) = dd(i,1) / bet(i) + bb(i,km) = 2. + dd(i,km) = 3.*pe2(i,km) + enddo + + do k=2,km + do i=is, ie + gam(i,k) = g_rat(i,k-1) / bet(i) + bet(i) = bb(i,k) - gam(i,k) + pp(i,k+1) = (dd(i,k) - pp(i,k) ) / bet(i) + enddo + enddo + + do k=km, 2, -1 + do i=is, ie + pp(i,k) = pp(i,k) - gam(i,k)*pp(i,k+1) + enddo + enddo + + do k=1, km+1 + do i=is, ie +! pe2 is Full p + pe2(i,k) = pem(i,k) + pp(i,k) + enddo + enddo + + do k=2, km + do i=is, ie +#ifdef MOIST_CAPPA + aa(i,k) = t1g*0.5*(gm2(i,k-1)+gm2(i,k))/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) +#else +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,k)) + t1gx = 2.*gamax*(alpha*dt)**2 + aa(i,k) = t1gx/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) +#else + aa(i,k) = t1g/(dz2(i,k-1)+dz2(i,k))*pe2(i,k) +#endif +#endif + wk(i,k) = t2*aa(i,k)*(w1(i,k-1)-w1(i,k)) + aa(i,k) = aa(i,k) - scale_m*dm2(i,1) + enddo + enddo +! Top: + do i=is, ie + bet(i) = dm2(i,1) - aa(i,2) + w2(i,1) = (dm2(i,1)*w1(i,1) + dt*pp(i,2) + wk(i,2)) / bet(i) + enddo +! Interior: + do k=2,km-1 + do i=is, ie + gam(i,k) = aa(i,k) / bet(i) + bet(i) = dm2(i,k) - (aa(i,k)+aa(i,k+1) + aa(i,k)*gam(i,k)) + w2(i,k) = (dm2(i,k)*w1(i,k) + dt*(pp(i,k+1)-pp(i,k)) + wk(i,k+1)-wk(i,k) & + - aa(i,k)*w2(i,k-1)) / bet(i) + enddo + enddo +! Bottom: k=km + do i=is, ie +#ifdef MOIST_CAPPA + wk1(i) = t1g*gm2(i,km)/dz2(i,km)*pe2(i,km+1) +#else +#ifdef MULTI_GASES + gamax = 1./(1.-kapad2(i,km)) + t1gx = 2.*gamax*(alpha*dt)**2 + wk1(i) = t1gx/dz2(i,km)*pe2(i,km+1) +#else + wk1(i) = t1g/dz2(i,km)*pe2(i,km+1) +#endif +#endif + gam(i,km) = aa(i,km) / bet(i) + bet(i) = dm2(i,km) - (aa(i,km)+wk1(i) + aa(i,km)*gam(i,km)) + w2(i,km) = (dm2(i,km)*w1(i,km) + dt*(pp(i,km+1)-pp(i,km)) - wk(i,km) + & + wk1(i)*(t2*w1(i,km)-ra*ws(i)) - aa(i,km)*w2(i,km-1)) / bet(i) + enddo + do k=km-1, 1, -1 + do i=is, ie + w2(i,k) = w2(i,k) - gam(i,k+1)*w2(i,k+1) + enddo + enddo + + do i=is, ie + pe2(i,1) = 0. + enddo + do k=1,km + do i=is, ie + pe2(i,k+1) = pe2(i,k) + ( dm2(i,k)*(w2(i,k)-w1(i,k))*rdt & + - beta*(pp(i,k+1)-pp(i,k)) ) * ra + enddo + enddo + + do i=is, ie + p1(i) = (pe2(i,km)+ 2.*pe2(i,km+1))*r3 +#ifdef MOIST_CAPPA + dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp((cp2(i,km)-1.)*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) +#else +#ifdef MULTI_GASES + capa1x = kapad2(i,km)-1. + dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1x*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) +#else + dz2(i,km) = -dm2(i,km)*rgas*pt2(i,km)*exp(capa1*log(max(p_fac*pm2(i,km),p1(i)+pm2(i,km)))) +#endif +#endif + enddo + + do k=km-1, 1, -1 + do i=is, ie + p1(i) = (pe2(i,k)+bb(i,k)*pe2(i,k+1)+g_rat(i,k)*pe2(i,k+2))*r3 - g_rat(i,k)*p1(i) +! delz = -dm*R*T_m / p_gas +#ifdef MOIST_CAPPA + dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp((cp2(i,k)-1.)*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) +#else +#ifdef MULTI_GASES + capa1x = kapad2(i,k)-1. + dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1x*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) +#else + dz2(i,k) = -dm2(i,k)*rgas*pt2(i,k)*exp(capa1*log(max(p_fac*pm2(i,k),p1(i)+pm2(i,k)))) +#endif +#endif + enddo + enddo + + do k=1, km+1 + do i=is, ie + pe2(i,k) = pe2(i,k) + beta*(pp(i,k)-pe2(i,k)) + enddo + enddo + + end subroutine SIM_solver + + + subroutine edge_scalar(q1, qe, i1, i2, km, id) +! Optimized for wind profile reconstruction: + integer, intent(in):: i1, i2, km + integer, intent(in):: id ! 0: pp 1: wind + real, intent(in ), dimension(i1:i2,km):: q1 + real, intent(out), dimension(i1:i2,km+1):: qe +!----------------------------------------------------------------------- + real, parameter:: r2o3 = 2./3. + real, parameter:: r4o3 = 4./3. + real gak(km) + real bet + integer i, k + +!------------------------------------------------ +! Optimized coding for uniform grid: SJL Apr 2007 +!------------------------------------------------ + + if ( id==1 ) then + do i=i1,i2 + qe(i,1) = r4o3*q1(i,1) + r2o3*q1(i,2) + enddo + else + do i=i1,i2 + qe(i,1) = 1.E30 + enddo + endif + + gak(1) = 7./3. + do k=2,km + gak(k) = 1. / (4. - gak(k-1)) + do i=i1,i2 + qe(i,k) = (3.*(q1(i,k-1) + q1(i,k)) - qe(i,k-1)) * gak(k) + enddo + enddo + + bet = 1. / (1.5 - 3.5*gak(km)) + do i=i1,i2 + qe(i,km+1) = (4.*q1(i,km) + q1(i,km-1) - 3.5*qe(i,km)) * bet + enddo + + do k=km,1,-1 + do i=i1,i2 + qe(i,k) = qe(i,k) - gak(k)*qe(i,k+1) + enddo + enddo + + end subroutine edge_scalar + + + + subroutine edge_profile(q1, q2, q1e, q2e, i1, i2, j1, j2, j, km, dp0, uniform_grid, limiter) +! Optimized for wind profile reconstruction: + integer, intent(in):: i1, i2, j1, j2 + integer, intent(in):: j, km + integer, intent(in):: limiter + logical, intent(in):: uniform_grid + real, intent(in):: dp0(km) + real, intent(in), dimension(i1:i2,j1:j2,km):: q1, q2 + real, intent(out), dimension(i1:i2,j1:j2,km+1):: q1e, q2e +!----------------------------------------------------------------------- + real, dimension(i1:i2,km+1):: qe1, qe2, gam ! edge values + real gak(km) + real bet, r2o3, r4o3 + real g0, gk, xt1, xt2, a_bot + integer i, k + + if ( uniform_grid ) then +!------------------------------------------------ +! Optimized coding for uniform grid: SJL Apr 2007 +!------------------------------------------------ + r2o3 = 2./3. + r4o3 = 4./3. + do i=i1,i2 + qe1(i,1) = r4o3*q1(i,j,1) + r2o3*q1(i,j,2) + qe2(i,1) = r4o3*q2(i,j,1) + r2o3*q2(i,j,2) + enddo + + gak(1) = 7./3. + do k=2,km + gak(k) = 1. / (4. - gak(k-1)) + do i=i1,i2 + qe1(i,k) = (3.*(q1(i,j,k-1) + q1(i,j,k)) - qe1(i,k-1)) * gak(k) + qe2(i,k) = (3.*(q2(i,j,k-1) + q2(i,j,k)) - qe2(i,k-1)) * gak(k) + enddo + enddo + + bet = 1. / (1.5 - 3.5*gak(km)) + do i=i1,i2 + qe1(i,km+1) = (4.*q1(i,j,km) + q1(i,j,km-1) - 3.5*qe1(i,km)) * bet + qe2(i,km+1) = (4.*q2(i,j,km) + q2(i,j,km-1) - 3.5*qe2(i,km)) * bet + enddo + + do k=km,1,-1 + do i=i1,i2 + qe1(i,k) = qe1(i,k) - gak(k)*qe1(i,k+1) + qe2(i,k) = qe2(i,k) - gak(k)*qe2(i,k+1) + enddo + enddo + else +! Assuming grid varying in vertical only + g0 = dp0(2) / dp0(1) + xt1 = 2.*g0*(g0+1. ) + bet = g0*(g0+0.5) + do i=i1,i2 + qe1(i,1) = ( xt1*q1(i,j,1) + q1(i,j,2) ) / bet + qe2(i,1) = ( xt1*q2(i,j,1) + q2(i,j,2) ) / bet + gam(i,1) = ( 1. + g0*(g0+1.5) ) / bet + enddo + + do k=2,km + gk = dp0(k-1) / dp0(k) + do i=i1,i2 + bet = 2. + 2.*gk - gam(i,k-1) + qe1(i,k) = ( 3.*(q1(i,j,k-1)+gk*q1(i,j,k)) - qe1(i,k-1) ) / bet + qe2(i,k) = ( 3.*(q2(i,j,k-1)+gk*q2(i,j,k)) - qe2(i,k-1) ) / bet + gam(i,k) = gk / bet + enddo + enddo + + a_bot = 1. + gk*(gk+1.5) + xt1 = 2.*gk*(gk+1.) + do i=i1,i2 + xt2 = gk*(gk+0.5) - a_bot*gam(i,km) + qe1(i,km+1) = ( xt1*q1(i,j,km) + q1(i,j,km-1) - a_bot*qe1(i,km) ) / xt2 + qe2(i,km+1) = ( xt1*q2(i,j,km) + q2(i,j,km-1) - a_bot*qe2(i,km) ) / xt2 + enddo + + do k=km,1,-1 + do i=i1,i2 + qe1(i,k) = qe1(i,k) - gam(i,k)*qe1(i,k+1) + qe2(i,k) = qe2(i,k) - gam(i,k)*qe2(i,k+1) + enddo + enddo + endif + +!------------------ +! Apply constraints +!------------------ + if ( limiter/=0 ) then ! limit the top & bottom winds + do i=i1,i2 +! Top + if ( q1(i,j,1)*qe1(i,1) < 0. ) qe1(i,1) = 0. + if ( q2(i,j,1)*qe2(i,1) < 0. ) qe2(i,1) = 0. +! Surface: + if ( q1(i,j,km)*qe1(i,km+1) < 0. ) qe1(i,km+1) = 0. + if ( q2(i,j,km)*qe2(i,km+1) < 0. ) qe2(i,km+1) = 0. + enddo + endif + + do k=1,km+1 + do i=i1,i2 + q1e(i,j,k) = qe1(i,k) + q2e(i,j,k) = qe2(i,k) + enddo + enddo + + end subroutine edge_profile + +!TODO LMH 25may18: do not need delz defined on full compute domain; pass appropriate BCs instead + subroutine nh_bc(ptop, grav, kappa, cp, delp, delzBC, pt, phis, & +#ifdef MULTI_GASES + q , & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + BC_step, BC_split, & + npx, npy, npz, bounded_domain, pkc_pertn, computepk3, fullhalo, bd) + + !INPUT: delp, delz (BC), pt + !OUTPUT: gz, pkc, pk3 (optional) + integer, intent(IN) :: npx, npy, npz + logical, intent(IN) :: pkc_pertn, computepk3, fullhalo, bounded_domain + real, intent(IN) :: ptop, kappa, cp, grav, BC_step, BC_split + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(IN) :: phis(bd%isd:bd%ied,bd%jsd:bd%jed) + real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: pt, delp + type(fv_nest_BC_type_3d), intent(IN) :: delzBC +#ifdef MULTI_GASES + real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz,*):: q +#endif +#ifdef USE_COND + real, intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: q_con +#ifdef MOIST_CAPPA + real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: cappa +#endif +#endif + real, intent(INOUT), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1):: gz, pkc, pk3 + + integer :: i,j,k + real :: gama !'gamma' + real :: ptk, rgrav, rkap, peln1, rdg + + integer :: istart, iend + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (.not. bounded_domain) return + + if (is == 1) then + + call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%west_t0, delzBC%west_t1, pt, phis, & +#ifdef MULTI_GASES + q , & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + BC_step, BC_split, & + pkc_pertn, computepk3, isd, ied, isd, 0, isd, 0, jsd, jed, jsd, jed, npz) + + endif + + if (ie == npx-1) then + + call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%east_t0, delzBC%east_t1, pt, phis, & +#ifdef MULTI_GASES + q , & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + BC_step, BC_split, & + pkc_pertn, computepk3, isd, ied, npx, ied, npx, ied, jsd, jed, jsd, jed, npz) + + endif + + if (is == 1) then + istart = is + else + istart = isd + end if + if (ie == npx-1) then + iend = ie + else + iend = ied + end if + + if (js == 1) then + + call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%south_t0, delzBC%south_t1, pt, phis, & +#ifdef MULTI_GASES + q , & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + BC_step, BC_split, & + pkc_pertn, computepk3, isd, ied, isd, ied, istart, iend, jsd, jed, jsd, 0, npz) + + end if + + if (je == npy-1) then + + call nh_BC_k(ptop, grav, kappa, cp, delp, delzBC%north_t0, delzBC%north_t1, pt, phis, & +#ifdef MULTI_GASES + q , & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + BC_step, BC_split, & + pkc_pertn, computepk3, isd, ied, isd, ied, istart, iend, jsd, jed, npy, jed, npz) + endif + +end subroutine nh_bc + +subroutine nh_BC_k(ptop, grav, kappa, cp, delp, delzBC_t0, delzBC_t1, pt, phis, & +#ifdef MULTI_GASES + q , & +#endif +#ifdef USE_COND + q_con, & +#ifdef MOIST_CAPPA + cappa, & +#endif +#endif + pkc, gz, pk3, & + BC_step, BC_split, & + pkc_pertn, computepk3, isd, ied, isd_BC, ied_BC, istart, iend, jsd, jed, jstart, jend, npz) + + integer, intent(IN) :: isd, ied, isd_BC, ied_BC, istart, iend, jsd, jed, jstart, jend, npz + real, intent(IN), dimension(isd_BC:ied_BC,jstart:jend,npz) :: delzBC_t0, delzBC_t1 + real, intent(IN) :: BC_step, BC_split + + logical, intent(IN) :: pkc_pertn, computepk3 + real, intent(IN) :: ptop, kappa, cp, grav + real, intent(IN) :: phis(isd:ied,jsd:jed) + real, intent(IN), dimension(isd:ied,jsd:jed,npz):: pt, delp +#ifdef MULTI_GASES + real, intent(IN), dimension(isd:ied,jsd:jed,npz,*):: q +#endif +#ifdef USE_COND + real, intent(IN), dimension(isd:ied,jsd:jed,npz):: q_con +#ifdef MOIST_CAPPA + real, intent(INOUT), dimension(isd:ied,jsd:jed,npz):: cappa +#endif +#endif + real, intent(INOUT), dimension(isd:ied,jsd:jed,npz+1):: gz, pkc, pk3 + + integer :: i,j,k + real :: gama !'gamma' + real :: ptk, rgrav, rkap, peln1, rdg, denom + + real, dimension(istart:iend, npz+1, jstart:jend ) :: pe, peln +#ifdef USE_COND + real, dimension(istart:iend, npz+1 ) :: peg, pelng +#endif + real, dimension(istart:iend, npz) :: gam, bb, dd, pkz + real, dimension(istart:iend, npz-1) :: g_rat + real, dimension(istart:iend) :: bet + real :: pm, delz_int + + + real :: pealn, pebln, rpkz +#ifdef MULTI_GASES + real gamax +#endif + rgrav = 1./grav + gama = 1./(1.-kappa) + ptk = ptop ** kappa + rkap = 1./kappa + peln1 = log(ptop) + rdg = - rdgas * rgrav + denom = 1./BC_split + + do j=jstart,jend + + !GZ + do i=istart,iend + gz(i,j,npz+1) = phis(i,j) + enddo + do k=npz,1,-1 + do i=istart,iend + delz_int = (delzBC_t0(i,j,k)*(BC_split-BC_step) + BC_step*delzBC_t1(i,j,k))*denom + gz(i,j,k) = gz(i,j,k+1) - delz_int*grav + enddo + enddo + + !Hydrostatic interface pressure + do i=istart,iend + pe(i,1,j) = ptop + peln(i,1,j) = peln1 +#ifdef USE_COND + peg(i,1) = ptop + pelng(i,1) = peln1 +#endif + enddo + do k=2,npz+1 + do i=istart,iend + pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + peln(i,k,j) = log(pe(i,k,j)) +#ifdef USE_COND + peg(i,k) = peg(i,k-1) + delp(i,j,k-1)*(1.-q_con(i,j,k-1)) + pelng(i,k) = log(peg(i,k)) +#endif + enddo + enddo + + !Perturbation nonhydro layer-mean pressure (NOT to the kappa) + do k=1,npz + do i=istart,iend + delz_int = (delzBC_t0(i,j,k)*(BC_split-BC_step) + BC_step*delzBC_t1(i,j,k))*denom + + !Full p +#ifdef MOIST_CAPPA + pkz(i,k) = exp(1./(1.-cappa(i,j,k))*log(rdg*delp(i,j,k)/delz_int*pt(i,j,k))) +#else +#ifdef MULTI_GASES + gamax = gama * (vicpqd(q(i,j,k,:))/vicvqd(q(i,j,k,:))) + pkz(i,k) = exp(gamax*log(-delp(i,j,k)*rgrav/delz_int*rdgas*pt(i,j,k))) +#else + pkz(i,k) = exp(gama*log(-delp(i,j,k)*rgrav/delz_int*rdgas*pt(i,j,k))) +#endif +#endif + !hydro +#ifdef USE_COND + pm = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) +#else + pm = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) +#endif + !Remove hydro cell-mean pressure + pkz(i,k) = pkz(i,k) - pm + enddo + enddo + + !pressure solver + do k=1,npz-1 + do i=istart,iend + g_rat(i,k) = delp(i,j,k)/delp(i,j,k+1) + bb(i,k) = 2.*(1. + g_rat(i,k)) + dd(i,k) = 3.*(pkz(i,k) + g_rat(i,k)*pkz(i,k+1)) + enddo + enddo + + do i=istart,iend + bet(i) = bb(i,1) + pkc(i,j,1) = 0. + pkc(i,j,2) = dd(i,1)/bet(i) + bb(i,npz) = 2. + dd(i,npz) = 3.*pkz(i,npz) + enddo + do k=2,npz + do i=istart,iend + gam(i,k) = g_rat(i,k-1)/bet(i) + bet(i) = bb(i,k) - gam(i,k) + pkc(i,j,k+1) = (dd(i,k) - pkc(i,j,k))/bet(i) + enddo + enddo + do k=npz,2,-1 + do i=istart,iend + pkc(i,j,k) = pkc(i,j,k) - gam(i,k)*pkc(i,j,k+1) +#ifdef NHNEST_DEBUG + if (abs(pkc(i,j,k)) > 1.e5) then + print*, mpp_pe(), i,j,k, 'PKC: ', pkc(i,j,k) + endif +#endif + enddo + enddo + + + enddo + + do j=jstart,jend + + if (.not. pkc_pertn) then + do k=npz+1,1,-1 + do i=istart,iend + pkc(i,j,k) = pkc(i,j,k) + pe(i,k,j) + enddo + enddo + endif + + !pk3 if necessary; doesn't require condenstate loading calculation + if (computepk3) then + do i=istart,iend + pk3(i,j,1) = ptk + enddo + do k=2,npz+1 + do i=istart,iend + pk3(i,j,k) = exp(kappa*log(pe(i,k,j))) + enddo + enddo + endif + + enddo + +end subroutine nh_BC_k + + +end module nh_utils_mod diff --git a/model/sw_core.F90 b/model/sw_core.F90 index 24c58ca99..e16c04e3a 100644 --- a/model/sw_core.F90 +++ b/model/sw_core.F90 @@ -1,3379 +1,3372 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'sw_core' advances the forward step of the Lagrangian dynamics -!! as described by \cite lin1997explicit, \cite lin2004vertically, and \cite harris2013two. -!>@details The step is applied to the cubed sphere. - - module sw_core_mod - -! Modules Included: -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -!
Module NameFunctions Included
a2b_edge_moda2b_ord4
fv_arrays_modffv_grid_type, fv_grid_bounds_type, fv_flags_type
fv_mp_modng,fill_corners, XDir, YDir
- - use fv_mp_mod, only: ng - use tp_core_mod, only: fv_tp_2d, pert_ppm, copy_corners - use fv_mp_mod, only: fill_corners, XDir, YDir - use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, fv_flags_type - use a2b_edge_mod, only: a2b_ord4 - -#ifdef SW_DYNAMICS - use test_cases_mod, only: test_case -#endif - - implicit none - - real, parameter:: r3 = 1./3. - real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28. - real, parameter:: s11=11./14., s13=-13./14., s14=4./7., s15=3./14. - real, parameter:: near_zero = 1.E-9 !< for KE limiter -#ifdef OVERLOAD_R4 - real, parameter:: big_number = 1.E8 -#else - real, parameter:: big_number = 1.E30 -#endif -!---------------------- -! PPM volume mean form: -!---------------------- - real, parameter:: p1 = 7./12. !< 0.58333333 - real, parameter:: p2 = -1./12. -!---------------------------- -! 4-pt Lagrange interpolation -!---------------------------- - real, parameter:: a1 = 0.5625 - real, parameter:: a2 = -0.0625 -!---------------------------------------------- -! volume-conserving cubic with 2nd drv=0 at end point: - real, parameter:: c1 = -2./14. - real, parameter:: c2 = 11./14. - real, parameter:: c3 = 5./14. -! 3-pt off-center intp formular: -! real, parameter:: c1 = -0.125 -! real, parameter:: c2 = 0.75 -! real, parameter:: c3 = 0.375 -!---------------------------------------------- -! scheme 2.1: perturbation form - real, parameter:: b1 = 1./30. - real, parameter:: b2 = -13./60. - real, parameter:: b3 = -13./60. - real, parameter:: b4 = 0.45 - real, parameter:: b5 = -0.05 - - - private - public :: c_sw, d_sw, fill_4corners, del6_vt_flux, divergence_corner, divergence_corner_nest - - contains - -!>@brief The subroutine 'c_sw' performs a half-timestep advance of the C-grid winds. - subroutine c_sw(delpc, delp, ptc, pt, u,v, w, uc,vc, ua,va, wc, & - ut, vt, divg_d, nord, dt2, hydrostatic, dord4, & - bd, gridstruct, flagstruct) - - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(INOUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u, vc - real, intent(INOUT), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ) :: v, uc - real, intent(INOUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed ) :: delp, pt, ua, va, ut, vt - real, intent(INOUT), dimension(bd%isd: , bd%jsd: ) :: w - real, intent(OUT ), dimension(bd%isd:bd%ied, bd%jsd:bd%jed ) :: delpc, ptc, wc - real, intent(OUT ), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) :: divg_d - integer, intent(IN) :: nord - real, intent(IN) :: dt2 - logical, intent(IN) :: hydrostatic - logical, intent(IN) :: dord4 - type(fv_grid_type), intent(IN), target :: gridstruct - type(fv_flags_type), intent(IN), target :: flagstruct - -! Local: - logical:: sw_corner, se_corner, ne_corner, nw_corner - real, dimension(bd%is-1:bd%ie+1,bd%js-1:bd%je+1):: vort, ke - real, dimension(bd%is-1:bd%ie+2,bd%js-1:bd%je+1):: fx, fx1, fx2 - real, dimension(bd%is-1:bd%ie+1,bd%js-1:bd%je+2):: fy, fy1, fy2 - real :: dt4 - integer :: i,j, is2, ie1 - integer iep1, jep1 - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: npx, npy - logical :: nested,regional - - real, pointer, dimension(:,:,:) :: sin_sg, cos_sg - real, pointer, dimension(:,:) :: cosa_u, cosa_v - real, pointer, dimension(:,:) :: sina_u, sina_v - - real, pointer, dimension(:,:) :: dx, dy, dxc, dyc - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - npx = flagstruct%npx - npy = flagstruct%npy - nested = gridstruct%nested - regional = gridstruct%regional - - sin_sg => gridstruct%sin_sg - cos_sg => gridstruct%cos_sg - cosa_u => gridstruct%cosa_u - cosa_v => gridstruct%cosa_v - sina_u => gridstruct%sina_u - sina_v => gridstruct%sina_v - dx => gridstruct%dx - dy => gridstruct%dy - dxc => gridstruct%dxc - dyc => gridstruct%dyc - - sw_corner = gridstruct%sw_corner - se_corner = gridstruct%se_corner - nw_corner = gridstruct%nw_corner - ne_corner = gridstruct%ne_corner - - iep1 = ie+1; jep1 = je+1 - - call d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, bd, & - npx, npy, nested, flagstruct%grid_type, regional ) - - if( nord > 0 ) then - if (nested .or. regional) then - call divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) - else - call divergence_corner(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) - endif - endif - - do j=js-1,jep1 - do i=is-1,iep1+1 - if (ut(i,j) > 0.) then - ut(i,j) = dt2*ut(i,j)*dy(i,j)*sin_sg(i-1,j,3) - else - ut(i,j) = dt2*ut(i,j)*dy(i,j)*sin_sg(i,j,1) - end if - enddo - enddo - do j=js-1,je+2 - do i=is-1,iep1 - if (vt(i,j) > 0.) then - vt(i,j) = dt2*vt(i,j)*dx(i,j)*sin_sg(i,j-1,4) - else - vt(i,j) = dt2*vt(i,j)*dx(i,j)*sin_sg(i,j, 2) - end if - enddo - enddo - -!---------------- -! Transport delp: -!---------------- -! Xdir: - if (flagstruct%grid_type < 3 .and. .not. (nested .or. regional)) & - call fill2_4corners(delp, pt, 1, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - - if ( hydrostatic ) then -#ifdef SW_DYNAMICS - do j=js-1,jep1 - do i=is-1,ie+2 - if ( ut(i,j) > 0. ) then - fx1(i,j) = delp(i-1,j) - else - fx1(i,j) = delp(i,j) - endif - fx1(i,j) = ut(i,j)*fx1(i,j) - enddo - enddo -#else - do j=js-1,jep1 - do i=is-1,ie+2 - if ( ut(i,j) > 0. ) then - fx1(i,j) = delp(i-1,j) - fx(i,j) = pt(i-1,j) - else - fx1(i,j) = delp(i,j) - fx(i,j) = pt(i,j) - endif - fx1(i,j) = ut(i,j)*fx1(i,j) - fx(i,j) = fx1(i,j)* fx(i,j) - enddo - enddo -#endif - else - if (flagstruct%grid_type < 3) & - call fill_4corners(w, 1, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - do j=js-1,je+1 - do i=is-1,ie+2 - if ( ut(i,j) > 0. ) then - fx1(i,j) = delp(i-1,j) - fx(i,j) = pt(i-1,j) - fx2(i,j) = w(i-1,j) - else - fx1(i,j) = delp(i,j) - fx(i,j) = pt(i,j) - fx2(i,j) = w(i,j) - endif - fx1(i,j) = ut(i,j)*fx1(i,j) - fx(i,j) = fx1(i,j)* fx(i,j) - fx2(i,j) = fx1(i,j)*fx2(i,j) - enddo - enddo - endif - -! Ydir: - if (flagstruct%grid_type < 3 .and. .not. (nested .or. regional)) & - call fill2_4corners(delp, pt, 2, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - - if ( hydrostatic ) then - do j=js-1,jep1+1 - do i=is-1,iep1 - if ( vt(i,j) > 0. ) then - fy1(i,j) = delp(i,j-1) - fy(i,j) = pt(i,j-1) - else - fy1(i,j) = delp(i,j) - fy(i,j) = pt(i,j) - endif - fy1(i,j) = vt(i,j)*fy1(i,j) - fy(i,j) = fy1(i,j)* fy(i,j) - enddo - enddo - do j=js-1,jep1 - do i=is-1,iep1 - delpc(i,j) = delp(i,j) + (fx1(i,j)-fx1(i+1,j)+fy1(i,j)-fy1(i,j+1))*gridstruct%rarea(i,j) -#ifdef SW_DYNAMICS - ptc(i,j) = pt(i,j) -#else - ptc(i,j) = (pt(i,j)*delp(i,j) + & - (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*gridstruct%rarea(i,j))/delpc(i,j) -#endif - enddo - enddo - else - if (flagstruct%grid_type < 3) call fill_4corners(w, 2, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - do j=js-1,je+2 - do i=is-1,ie+1 - if ( vt(i,j) > 0. ) then - fy1(i,j) = delp(i,j-1) - fy(i,j) = pt(i,j-1) - fy2(i,j) = w(i,j-1) - else - fy1(i,j) = delp(i,j) - fy(i,j) = pt(i,j) - fy2(i,j) = w(i,j) - endif - fy1(i,j) = vt(i,j)*fy1(i,j) - fy(i,j) = fy1(i,j)* fy(i,j) - fy2(i,j) = fy1(i,j)*fy2(i,j) - enddo - enddo - do j=js-1,je+1 - do i=is-1,ie+1 - delpc(i,j) = delp(i,j) + (fx1(i,j)-fx1(i+1,j)+fy1(i,j)-fy1(i,j+1))*gridstruct%rarea(i,j) - ptc(i,j) = (pt(i,j)*delp(i,j) + & - (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*gridstruct%rarea(i,j))/delpc(i,j) - wc(i,j) = (w(i,j)*delp(i,j) + (fx2(i,j)-fx2(i+1,j) + & - fy2(i,j)-fy2(i,j+1))*gridstruct%rarea(i,j))/delpc(i,j) - enddo - enddo - endif - -!------------ -! Compute KE: -!------------ - -!Since uc = u*, i.e. the covariant wind perpendicular to the face edge, if we want to compute kinetic energy we will need the true coordinate-parallel covariant wind, computed through u = uc*sina + v*cosa. -!Use the alpha for the cell KE is being computed in. -!!! TO DO: -!!! Need separate versions for nesting/single-tile -!!! and for cubed-sphere - if (nested .or. regional .or. flagstruct%grid_type >=3 ) then - do j=js-1,jep1 - do i=is-1,iep1 - if ( ua(i,j) > 0. ) then - ke(i,j) = uc(i,j) - else - ke(i,j) = uc(i+1,j) - endif - enddo - enddo - do j=js-1,jep1 - do i=is-1,iep1 - if ( va(i,j) > 0. ) then - vort(i,j) = vc(i,j) - else - vort(i,j) = vc(i,j+1) - endif - enddo - enddo - else - do j=js-1,jep1 - do i=is-1,iep1 - if ( ua(i,j) > 0. ) then - if ( i==1 ) then - ke(1,j) = uc(1, j)*sin_sg(1,j,1)+v(1,j)*cos_sg(1,j,1) - elseif ( i==npx ) then - ke(i,j) = uc(npx,j)*sin_sg(npx,j,1)+v(npx,j)*cos_sg(npx,j,1) - else - ke(i,j) = uc(i,j) - endif - else - if ( i==0 ) then - ke(0,j) = uc(1, j)*sin_sg(0,j,3)+v(1,j)*cos_sg(0,j,3) - elseif ( i==(npx-1) ) then - ke(i,j) = uc(npx,j)*sin_sg(npx-1,j,3)+v(npx,j)*cos_sg(npx-1,j,3) - else - ke(i,j) = uc(i+1,j) - endif - endif - enddo - enddo - do j=js-1,jep1 - do i=is-1,iep1 - if ( va(i,j) > 0. ) then - if ( j==1 ) then - vort(i,1) = vc(i, 1)*sin_sg(i,1,2)+u(i, 1)*cos_sg(i,1,2) - elseif ( j==npy ) then - vort(i,j) = vc(i,npy)*sin_sg(i,npy,2)+u(i,npy)*cos_sg(i,npy,2) - else - vort(i,j) = vc(i,j) - endif - else - if ( j==0 ) then - vort(i,0) = vc(i, 1)*sin_sg(i,0,4)+u(i, 1)*cos_sg(i,0,4) - elseif ( j==(npy-1) ) then - vort(i,j) = vc(i,npy)*sin_sg(i,npy-1,4)+u(i,npy)*cos_sg(i,npy-1,4) - else - vort(i,j) = vc(i,j+1) - endif - endif - enddo - enddo - endif - - dt4 = 0.5*dt2 - do j=js-1,jep1 - do i=is-1,iep1 - ke(i,j) = dt4*(ua(i,j)*ke(i,j) + va(i,j)*vort(i,j)) - enddo - enddo - -!------------------------------ -! Compute circulation on C grid -!------------------------------ -! To consider using true co-variant winds at face edges? - do j=js-1,je+1 - do i=is,ie+1 - fx(i,j) = uc(i,j) * dxc(i,j) - enddo - enddo - - do j=js,je+1 - do i=is-1,ie+1 - fy(i,j) = vc(i,j) * dyc(i,j) - enddo - enddo - - do j=js,je+1 - do i=is,ie+1 - vort(i,j) = fx(i,j-1) - fx(i,j) - fy(i-1,j) + fy(i,j) - enddo - enddo - -! Remove the extra term at the corners: - if ( sw_corner ) vort(1, 1) = vort(1, 1) + fy(0, 1) - if ( se_corner ) vort(npx ,1) = vort(npx, 1) - fy(npx, 1) - if ( ne_corner ) vort(npx,npy) = vort(npx,npy) - fy(npx,npy) - if ( nw_corner ) vort(1, npy) = vort(1, npy) + fy(0, npy) - -!---------------------------- -! Compute absolute vorticity -!---------------------------- - do j=js,je+1 - do i=is,ie+1 - vort(i,j) = gridstruct%fC(i,j) + gridstruct%rarea_c(i,j) * vort(i,j) - enddo - enddo - -!---------------------------------- -! Transport absolute vorticity: -!---------------------------------- -!To go from v to contravariant v at the edges, we divide by sin_sg; -! but we then must multiply by sin_sg to get the proper flux. -! These cancel, leaving us with fy1 = dt2*v at the edges. -! (For the same reason we only divide by sin instead of sin**2 in the interior) - -!! TO DO: separate versions for nesting/single-tile and cubed-sphere - if (nested .or. regional .or. flagstruct%grid_type >= 3) then - do j=js,je - do i=is,iep1 - fy1(i,j) = dt2*(v(i,j)-uc(i,j)*cosa_u(i,j))/sina_u(i,j) - if ( fy1(i,j) > 0. ) then - fy(i,j) = vort(i,j) - else - fy(i,j) = vort(i,j+1) - endif - enddo - enddo - do j=js,jep1 - do i=is,ie - fx1(i,j) = dt2*(u(i,j)-vc(i,j)*cosa_v(i,j))/sina_v(i,j) - if ( fx1(i,j) > 0. ) then - fx(i,j) = vort(i,j) - else - fx(i,j) = vort(i+1,j) - endif - enddo - enddo - else - do j=js,je -!DEC$ VECTOR ALWAYS - do i=is,iep1 - if ( ( i==1 .or. i==npx ) ) then - fy1(i,j) = dt2*v(i,j) - else - fy1(i,j) = dt2*(v(i,j)-uc(i,j)*cosa_u(i,j))/sina_u(i,j) - endif - if ( fy1(i,j) > 0. ) then - fy(i,j) = vort(i,j) - else - fy(i,j) = vort(i,j+1) - endif - enddo - enddo - do j=js,jep1 - if ( ( j==1 .or. j==npy ) ) then -!DEC$ VECTOR ALWAYS - do i=is,ie - fx1(i,j) = dt2*u(i,j) - if ( fx1(i,j) > 0. ) then - fx(i,j) = vort(i,j) - else - fx(i,j) = vort(i+1,j) - endif - enddo - else -!DEC$ VECTOR ALWAYS - do i=is,ie - fx1(i,j) = dt2*(u(i,j)-vc(i,j)*cosa_v(i,j))/sina_v(i,j) - if ( fx1(i,j) > 0. ) then - fx(i,j) = vort(i,j) - else - fx(i,j) = vort(i+1,j) - endif - enddo - endif - enddo - endif - -! Update time-centered winds on the C-Grid - do j=js,je - do i=is,iep1 - uc(i,j) = uc(i,j) + fy1(i,j)*fy(i,j) + gridstruct%rdxc(i,j)*(ke(i-1,j)-ke(i,j)) - enddo - enddo - do j=js,jep1 - do i=is,ie - vc(i,j) = vc(i,j) - fx1(i,j)*fx(i,j) + gridstruct%rdyc(i,j)*(ke(i,j-1)-ke(i,j)) - enddo - enddo - - end subroutine c_sw - - - -! d_sw :: D-Grid Shallow Water Routine - -!>@brief The subroutine 'd_sw' peforms a full-timestep advance of the D-grid winds -!! and other prognostic varaiables. - subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & - ua, va, divg_d, xflux, yflux, cx, cy, & - crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source,diss_est, & - zvir, sphum, nq, q, k, km, inline_q, & - dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, & - nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, & - damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd) - - integer, intent(IN):: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp - integer, intent(IN):: nord !< nord=1 divergence damping; (del-4) or 3 (del-8) - integer, intent(IN):: nord_v !< vorticity damping - integer, intent(IN):: nord_w !< vertical velocity - integer, intent(IN):: nord_t !< pt - integer, intent(IN):: sphum, nq, k, km - real , intent(IN):: dt, dddmp, d2_bg, d4_bg, d_con - real , intent(IN):: zvir - real, intent(in):: damp_v, damp_w, damp_t, kgb - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(inout):: divg_d(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) !< divergence - real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed):: z_rat - real, intent(INOUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed):: delp, pt, ua, va - real, intent(INOUT), dimension(bd%isd: , bd%jsd: ):: w, q_con - real, intent(INOUT), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed+1):: u, vc - real, intent(INOUT), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: v, uc - real, intent(INOUT):: q(bd%isd:bd%ied,bd%jsd:bd%jed,km,nq) - real, intent(OUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc, ptc - real, intent(OUT), dimension(bd%is:bd%ie,bd%js:bd%je):: heat_source - real, intent(OUT), dimension(bd%is:bd%ie,bd%js:bd%je):: diss_est -! The flux capacitors: - real, intent(INOUT):: xflux(bd%is:bd%ie+1,bd%js:bd%je ) - real, intent(INOUT):: yflux(bd%is:bd%ie ,bd%js:bd%je+1) -!------------------------ - real, intent(INOUT):: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ) - real, intent(INOUT):: cy(bd%isd:bd%ied,bd%js:bd%je+1) - logical, intent(IN):: hydrostatic - logical, intent(IN):: inline_q - real, intent(OUT), dimension(bd%is:bd%ie+1,bd%jsd:bd%jed):: crx_adv, xfx_adv - real, intent(OUT), dimension(bd%isd:bd%ied,bd%js:bd%je+1):: cry_adv, yfx_adv - type(fv_grid_type), intent(IN), target :: gridstruct - type(fv_flags_type), intent(IN), target :: flagstruct -! Local: - logical:: sw_corner, se_corner, ne_corner, nw_corner - real :: ut(bd%isd:bd%ied+1,bd%jsd:bd%jed) - real :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1) -!--- - real :: fx2(bd%isd:bd%ied+1,bd%jsd:bd%jed) - real :: fy2(bd%isd:bd%ied, bd%jsd:bd%jed+1) - real :: dw(bd%is:bd%ie,bd%js:bd%je) !< work array -!--- - real, dimension(bd%is:bd%ie+1,bd%js:bd%je+1):: ub, vb - real :: wk(bd%isd:bd%ied,bd%jsd:bd%jed) !< work array - real :: ke(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) !< needed for corner_comm - real :: vort(bd%isd:bd%ied,bd%jsd:bd%jed) !< Vorticity - real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) !< 1-D X-direction Fluxes - real :: fy(bd%is:bd%ie ,bd%js:bd%je+1) !< 1-D Y-direction Fluxes - real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) - real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) - real :: gx(bd%is:bd%ie+1,bd%js:bd%je ) - real :: gy(bd%is:bd%ie ,bd%js:bd%je+1) !< work Y-dir flux array - logical :: fill_c - - real :: dt2, dt4, dt5, dt6 - real :: damp, damp2, damp4, dd8, u2, v2, du2, dv2 - real :: u_lon - integer :: i,j, is2, ie1, js2, je1, n, nt, n2, iq - - real, pointer, dimension(:,:) :: area, area_c, rarea - - real, pointer, dimension(:,:,:) :: sin_sg - real, pointer, dimension(:,:) :: cosa_u, cosa_v, cosa_s - real, pointer, dimension(:,:) :: sina_u, sina_v - real, pointer, dimension(:,:) :: rsin_u, rsin_v, rsina - real, pointer, dimension(:,:) :: f0, rsin2, divg_u, divg_v - - real, pointer, dimension(:,:) :: cosa, dx, dy, dxc, dyc, rdxa, rdya, rdx, rdy - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: npx, npy - logical :: nested,regional - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - npx = flagstruct%npx - npy = flagstruct%npy - nested = gridstruct%nested - regional = gridstruct%regional - - area => gridstruct%area - rarea => gridstruct%rarea - sin_sg => gridstruct%sin_sg - cosa_u => gridstruct%cosa_u - cosa_v => gridstruct%cosa_v - cosa_s => gridstruct%cosa_s - sina_u => gridstruct%sina_u - sina_v => gridstruct%sina_v - rsin_u => gridstruct%rsin_u - rsin_v => gridstruct%rsin_v - rsina => gridstruct%rsina - f0 => gridstruct%f0 - rsin2 => gridstruct%rsin2 - divg_u => gridstruct%divg_u - divg_v => gridstruct%divg_v - cosa => gridstruct%cosa - dx => gridstruct%dx - dy => gridstruct%dy - dxc => gridstruct%dxc - dyc => gridstruct%dyc - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - rdx => gridstruct%rdx - rdy => gridstruct%rdy - - sw_corner = gridstruct%sw_corner - se_corner = gridstruct%se_corner - nw_corner = gridstruct%nw_corner - ne_corner = gridstruct%ne_corner - -#ifdef SW_DYNAMICS - if ( test_case == 1 ) then - do j=jsd,jed - do i=is,ie+1 - xfx_adv(i,j) = dt * uc(i,j) / sina_u(i,j) - if (xfx_adv(i,j) > 0.) then - crx_adv(i,j) = xfx_adv(i,j) * rdxa(i-1,j) - else - crx_adv(i,j) = xfx_adv(i,j) * rdxa(i,j) - endif - xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sina_u(i,j) - enddo - enddo - - do j=js,je+1 - do i=isd,ied - yfx_adv(i,j) = dt * vc(i,j) / sina_v(i,j) - if (yfx_adv(i,j) > 0.) then - cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j-1) - else - cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j) - endif - yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sina_v(i,j) - enddo - enddo - else -#endif - if ( flagstruct%grid_type < 3 ) then - -!!! TO DO: separate versions for nesting and for cubed-sphere - if (nested .or. regional) then - do j=jsd,jed - do i=is-1,ie+2 - ut(i,j) = ( uc(i,j) - 0.25 * cosa_u(i,j) * & - (vc(i-1,j)+vc(i,j)+vc(i-1,j+1)+vc(i,j+1)))*rsin_u(i,j) - enddo - enddo - do j=js-1,je+2 - do i=isd,ied - vt(i,j) = ( vc(i,j) - 0.25 * cosa_v(i,j) * & - (uc(i,j-1)+uc(i+1,j-1)+uc(i,j)+uc(i+1,j)))*rsin_v(i,j) - enddo - enddo - else - do j=jsd,jed - if( j/=0 .and. j/=1 .and. j/=(npy-1) .and. j/=npy) then - do i=is-1,ie+2 - ut(i,j) = ( uc(i,j) - 0.25 * cosa_u(i,j) * & - (vc(i-1,j)+vc(i,j)+vc(i-1,j+1)+vc(i,j+1)))*rsin_u(i,j) - enddo - endif - enddo - do j=js-1,je+2 - - if( j/=1 .and. j/=npy ) then - - do i=isd,ied - vt(i,j) = ( vc(i,j) - 0.25 * cosa_v(i,j) * & - (uc(i,j-1)+uc(i+1,j-1)+uc(i,j)+uc(i+1,j)))*rsin_v(i,j) - enddo - endif - enddo - endif - - if (.not. (nested .or. regional)) then -! West edge: - if ( is==1 ) then - do j=jsd,jed - if ( uc(1,j)*dt > 0. ) then - ut(1,j) = uc(1,j) / sin_sg(0,j,3) - else - ut(1,j) = uc(1,j) / sin_sg(1,j,1) - endif - enddo - do j=max(3,js), min(npy-2,je+1) - vt(0,j) = vc(0,j) - 0.25*cosa_v(0,j)* & - (ut(0,j-1)+ut(1,j-1)+ut(0,j)+ut(1,j)) - vt(1,j) = vc(1,j) - 0.25*cosa_v(1,j)* & - (ut(1,j-1)+ut(2,j-1)+ut(1,j)+ut(2,j)) - enddo - endif ! West face - -! East edge: - if ( (ie+1)==npx ) then - do j=jsd,jed - if ( uc(npx,j)*dt > 0. ) then - ut(npx,j) = uc(npx,j) / sin_sg(npx-1,j,3) - else - ut(npx,j) = uc(npx,j) / sin_sg(npx,j,1) - endif - enddo - - do j=max(3,js), min(npy-2,je+1) - vt(npx-1,j) = vc(npx-1,j) - 0.25*cosa_v(npx-1,j)* & - (ut(npx-1,j-1)+ut(npx,j-1)+ut(npx-1,j)+ut(npx,j)) - vt(npx,j) = vc(npx,j) - 0.25*cosa_v(npx,j)* & - (ut(npx,j-1)+ut(npx+1,j-1)+ut(npx,j)+ut(npx+1,j)) - enddo - endif - -! South (Bottom) edge: - if ( js==1 ) then - - do i=isd,ied - if ( vc(i,1)*dt > 0. ) then - vt(i,1) = vc(i,1) / sin_sg(i,0,4) - else - vt(i,1) = vc(i,1) / sin_sg(i,1,2) - endif - enddo - - do i=max(3,is),min(npx-2,ie+1) - ut(i,0) = uc(i,0) - 0.25*cosa_u(i,0)* & - (vt(i-1,0)+vt(i,0)+vt(i-1,1)+vt(i,1)) - ut(i,1) = uc(i,1) - 0.25*cosa_u(i,1)* & - (vt(i-1,1)+vt(i,1)+vt(i-1,2)+vt(i,2)) - enddo - endif - -! North edge: - if ( (je+1)==npy ) then - do i=isd,ied - if ( vc(i,npy)*dt > 0. ) then - vt(i,npy) = vc(i,npy) / sin_sg(i,npy-1,4) - else - vt(i,npy) = vc(i,npy) / sin_sg(i,npy,2) - endif - enddo - do i=max(3,is),min(npx-2,ie+1) - ut(i,npy-1) = uc(i,npy-1) - 0.25*cosa_u(i,npy-1)* & - (vt(i-1,npy-1)+vt(i,npy-1)+vt(i-1,npy)+vt(i,npy)) - ut(i,npy) = uc(i,npy) - 0.25*cosa_u(i,npy)* & - (vt(i-1,npy)+vt(i,npy)+vt(i-1,npy+1)+vt(i,npy+1)) - enddo - endif - -! The following code solves a 2x2 system to get the interior parallel-to-edge uc,vc values -! near the corners (ex: for the sw corner ut(2,1) and vt(1,2) are solved for simultaneously). -! It then computes the halo uc, vc values so as to be consistent with the computations on -! the facing panel. - - !The system solved is: - ! ut(2,1) = uc(2,1) - avg(vt)*cosa_u(2,1) - ! vt(1,2) = vc(1,2) - avg(ut)*cosa_v(1,2) - ! in which avg(vt) includes vt(1,2) and avg(ut) includes ut(2,1) - - if( sw_corner ) then - damp = 1. / (1.-0.0625*cosa_u(2,0)*cosa_v(1,0)) - ut(2,0) = (uc(2,0)-0.25*cosa_u(2,0)*(vt(1,1)+vt(2,1)+vt(2,0) +vc(1,0) - & - 0.25*cosa_v(1,0)*(ut(1,0)+ut(1,-1)+ut(2,-1))) ) * damp - damp = 1. / (1.-0.0625*cosa_u(0,1)*cosa_v(0,2)) - vt(0,2) = (vc(0,2)-0.25*cosa_v(0,2)*(ut(1,1)+ut(1,2)+ut(0,2)+uc(0,1) - & - 0.25*cosa_u(0,1)*(vt(0,1)+vt(-1,1)+vt(-1,2))) ) * damp - - damp = 1. / (1.-0.0625*cosa_u(2,1)*cosa_v(1,2)) - ut(2,1) = (uc(2,1)-0.25*cosa_u(2,1)*(vt(1,1)+vt(2,1)+vt(2,2)+vc(1,2) - & - 0.25*cosa_v(1,2)*(ut(1,1)+ut(1,2)+ut(2,2))) ) * damp - - vt(1,2) = (vc(1,2)-0.25*cosa_v(1,2)*(ut(1,1)+ut(1,2)+ut(2,2)+uc(2,1) - & - 0.25*cosa_u(2,1)*(vt(1,1)+vt(2,1)+vt(2,2))) ) * damp - endif - - if( se_corner ) then - damp = 1. / (1. - 0.0625*cosa_u(npx-1,0)*cosa_v(npx-1,0)) - ut(npx-1,0) = ( uc(npx-1,0)-0.25*cosa_u(npx-1,0)*( & - vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,0)+vc(npx-1,0) - & - 0.25*cosa_v(npx-1,0)*(ut(npx,0)+ut(npx,-1)+ut(npx-1,-1))) ) * damp - damp = 1. / (1. - 0.0625*cosa_u(npx+1,1)*cosa_v(npx,2)) - vt(npx, 2) = ( vc(npx,2)-0.25*cosa_v(npx,2)*( & - ut(npx,1)+ut(npx,2)+ut(npx+1,2)+uc(npx+1,1) - & - 0.25*cosa_u(npx+1,1)*(vt(npx,1)+vt(npx+1,1)+vt(npx+1,2))) ) * damp - - damp = 1. / (1. - 0.0625*cosa_u(npx-1,1)*cosa_v(npx-1,2)) - ut(npx-1,1) = ( uc(npx-1,1)-0.25*cosa_u(npx-1,1)*( & - vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,2)+vc(npx-1,2) - & - 0.25*cosa_v(npx-1,2)*(ut(npx,1)+ut(npx,2)+ut(npx-1,2))) ) * damp - vt(npx-1,2) = ( vc(npx-1,2)-0.25*cosa_v(npx-1,2)*( & - ut(npx,1)+ut(npx,2)+ut(npx-1,2)+uc(npx-1,1) - & - 0.25*cosa_u(npx-1,1)*(vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,2))) ) * damp - endif - - if( ne_corner ) then - damp = 1. / (1. - 0.0625*cosa_u(npx-1,npy)*cosa_v(npx-1,npy+1)) - ut(npx-1,npy) = ( uc(npx-1,npy)-0.25*cosa_u(npx-1,npy)*( & - vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy+1)+vc(npx-1,npy+1) - & - 0.25*cosa_v(npx-1,npy+1)*(ut(npx,npy)+ut(npx,npy+1)+ut(npx-1,npy+1))) ) * damp - damp = 1. / (1. - 0.0625*cosa_u(npx+1,npy-1)*cosa_v(npx,npy-1)) - vt(npx, npy-1) = ( vc(npx,npy-1)-0.25*cosa_v(npx,npy-1)*( & - ut(npx,npy-1)+ut(npx,npy-2)+ut(npx+1,npy-2)+uc(npx+1,npy-1) - & - 0.25*cosa_u(npx+1,npy-1)*(vt(npx,npy)+vt(npx+1,npy)+vt(npx+1,npy-1))) ) * damp - - damp = 1. / (1. - 0.0625*cosa_u(npx-1,npy-1)*cosa_v(npx-1,npy-1)) - ut(npx-1,npy-1) = ( uc(npx-1,npy-1)-0.25*cosa_u(npx-1,npy-1)*( & - vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy-1)+vc(npx-1,npy-1) - & - 0.25*cosa_v(npx-1,npy-1)*(ut(npx,npy-1)+ut(npx,npy-2)+ut(npx-1,npy-2))) ) * damp - vt(npx-1,npy-1) = ( vc(npx-1,npy-1)-0.25*cosa_v(npx-1,npy-1)*( & - ut(npx,npy-1)+ut(npx,npy-2)+ut(npx-1,npy-2)+uc(npx-1,npy-1) - & - 0.25*cosa_u(npx-1,npy-1)*(vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy-1))) ) * damp - endif - - if( nw_corner ) then - damp = 1. / (1. - 0.0625*cosa_u(2,npy)*cosa_v(1,npy+1)) - ut(2,npy) = ( uc(2,npy)-0.25*cosa_u(2,npy)*( & - vt(1,npy)+vt(2,npy)+vt(2,npy+1)+vc(1,npy+1) - & - 0.25*cosa_v(1,npy+1)*(ut(1,npy)+ut(1,npy+1)+ut(2,npy+1))) ) * damp - damp = 1. / (1. - 0.0625*cosa_u(0,npy-1)*cosa_v(0,npy-1)) - vt(0,npy-1) = ( vc(0,npy-1)-0.25*cosa_v(0,npy-1)*( & - ut(1,npy-1)+ut(1,npy-2)+ut(0,npy-2)+uc(0,npy-1) - & - 0.25*cosa_u(0,npy-1)*(vt(0,npy)+vt(-1,npy)+vt(-1,npy-1))) ) * damp - - damp = 1. / (1. - 0.0625*cosa_u(2,npy-1)*cosa_v(1,npy-1)) - ut(2,npy-1) = ( uc(2,npy-1)-0.25*cosa_u(2,npy-1)*( & - vt(1,npy)+vt(2,npy)+vt(2,npy-1)+vc(1,npy-1) - & - 0.25*cosa_v(1,npy-1)*(ut(1,npy-1)+ut(1,npy-2)+ut(2,npy-2))) ) * damp - - vt(1,npy-1) = ( vc(1,npy-1)-0.25*cosa_v(1,npy-1)*( & - ut(1,npy-1)+ut(1,npy-2)+ut(2,npy-2)+uc(2,npy-1) - & - 0.25*cosa_u(2,npy-1)*(vt(1,npy)+vt(2,npy)+vt(2,npy-1))) ) * damp - endif - - end if !.not. (nested .or. regional) - - else -! flagstruct%grid_type >= 3 - do j=jsd,jed - do i=is,ie+1 - ut(i,j) = uc(i,j) - enddo - enddo - - do j=js,je+1 - do i=isd,ied - vt(i,j) = vc(i,j) - enddo - enddo - endif ! end grid_type choices - - do j=jsd,jed - do i=is,ie+1 - xfx_adv(i,j) = dt*ut(i,j) - enddo - enddo - - do j=js,je+1 - do i=isd,ied - yfx_adv(i,j) = dt*vt(i,j) - enddo - enddo - -! Explanation of the following code: -! xfx_adv = dt*ut*dy -! crx_adv = dt*ut/dx - - do j=jsd,jed -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if ( xfx_adv(i,j) > 0. ) then - crx_adv(i,j) = xfx_adv(i,j) * rdxa(i-1,j) - xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sin_sg(i-1,j,3) - else - crx_adv(i,j) = xfx_adv(i,j) * rdxa(i,j) - xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sin_sg(i,j,1) - end if - enddo - enddo - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=isd,ied - if ( yfx_adv(i,j) > 0. ) then - cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j-1) - yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sin_sg(i,j-1,4) - else - cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j) - yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sin_sg(i,j,2) - endif - enddo - enddo - -#ifdef SW_DYNAMICS - endif -#endif - - do j=jsd,jed - do i=is,ie - ra_x(i,j) = area(i,j) + xfx_adv(i,j) - xfx_adv(i+1,j) - enddo - enddo - do j=js,je - do i=isd,ied - ra_y(i,j) = area(i,j) + yfx_adv(i,j) - yfx_adv(i,j+1) - enddo - enddo - - - call fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, fy, & - xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & - regional,nord=nord_v, damp_c=damp_v) - -! <<< Save the mass fluxes to the "Flux Capacitor" for tracer transport >>> - do j=jsd,jed - do i=is,ie+1 - cx(i,j) = cx(i,j) + crx_adv(i,j) - enddo - enddo - do j=js,je - do i=is,ie+1 - xflux(i,j) = xflux(i,j) + fx(i,j) - enddo - enddo - do j=js,je+1 - do i=isd,ied - cy(i,j) = cy(i,j) + cry_adv(i,j) - enddo - do i=is,ie - yflux(i,j) = yflux(i,j) + fy(i,j) - enddo - enddo - -#ifndef SW_DYNAMICS - do j=js,je - do i=is,ie - heat_source(i,j) = 0. - diss_est(i,j) = 0. - enddo - enddo - - if ( .not. hydrostatic ) then - if ( damp_w>1.E-5 ) then - dd8 = kgb*abs(dt) - damp4 = (damp_w*gridstruct%da_min_c)**(nord_w+1) - call del6_vt_flux(nord_w, npx, npy, damp4, w, wk, fx2, fy2, gridstruct, bd) - do j=js,je - do i=is,ie - dw(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j) -! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw -! heat_source(i,j) = -d_con*dw(i,j)*(w(i,j)+0.5*dw(i,j)) - heat_source(i,j) = dd8 - dw(i,j)*(w(i,j)+0.5*dw(i,j)) - diss_est(i,j) = heat_source(i,j) - enddo - enddo - endif - call fv_tp_2d(w, crx_adv,cry_adv, npx, npy, hord_vt, gx, gy, xfx_adv, yfx_adv, & - gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & - regional,mfx=fx, mfy=fy) - do j=js,je - do i=is,ie - w(i,j) = delp(i,j)*w(i,j) + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) - enddo - enddo - endif - -#ifdef USE_COND - call fv_tp_2d(q_con, crx_adv,cry_adv, npx, npy, hord_dp, gx, gy, & - xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac,& - regional, mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t) - do j=js,je - do i=is,ie - q_con(i,j) = delp(i,j)*q_con(i,j) + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) - enddo - enddo -#endif - -! if ( inline_q .and. zvir>0.01 ) then -! do j=jsd,jed -! do i=isd,ied -! pt(i,j) = pt(i,j)/(1.+zvir*q(i,j,k,sphum)) -! enddo -! enddo -! endif - call fv_tp_2d(pt, crx_adv,cry_adv, npx, npy, hord_tm, gx, gy, & - xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & - regional,mfx=fx, mfy=fy, mass=delp, nord=nord_v, damp_c=damp_v) -! mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t) -#endif - - if ( inline_q ) then - do j=js,je - do i=is,ie - wk(i,j) = delp(i,j) - delp(i,j) = wk(i,j) + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) -#ifdef SW_DYNAMICS - ptc(i,j) = pt(i,j) -#else - pt(i,j) = (pt(i,j)*wk(i,j) + & - (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j))/delp(i,j) -#endif - enddo - enddo - do iq=1,nq - call fv_tp_2d(q(isd,jsd,k,iq), crx_adv,cry_adv, npx, npy, hord_tr, gx, gy, & - xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & - regional,mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t) - do j=js,je - do i=is,ie - q(i,j,k,iq) = (q(i,j,k,iq)*wk(i,j) + & - (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j))/delp(i,j) - enddo - enddo - enddo -! if ( zvir>0.01 ) then -! do j=js,je -! do i=is,ie -! pt(i,j) = pt(i,j)*(1.+zvir*q(i,j,k,sphum)) -! enddo -! enddo -! endif - - else - do j=js,je - do i=is,ie -#ifndef SW_DYNAMICS - pt(i,j) = pt(i,j)*delp(i,j) + & - (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) -#endif - delp(i,j) = delp(i,j) + & - (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) -#ifndef SW_DYNAMICS - pt(i,j) = pt(i,j) / delp(i,j) - -#endif - enddo - enddo - endif - -#ifdef SW_DYNAMICS - if (test_case > 1) then -#endif - -!---------------------- -! Kinetic Energy Fluxes -!---------------------- -! Compute B grid contra-variant components for KE: - - dt5 = 0.5 *dt - dt4 = 0.25*dt - - if (nested .or. regional) then - is2 = is; ie1 = ie+1 - js2 = js; je1 = je+1 - else - is2 = max(2,is); ie1 = min(npx-1,ie+1) - js2 = max(2,js); je1 = min(npy-1,je+1) - end if - -!!! TO DO: separate versions for nested and for cubed-sphere - if (flagstruct%grid_type < 3) then - - if (nested .or. regional) then - do j=js2,je1 - do i=is2,ie1 - vb(i,j) = dt5*(vc(i-1,j)+vc(i,j)-(uc(i,j-1)+uc(i,j))*cosa(i,j))*rsina(i,j) - enddo - enddo - else - if ( js==1 ) then - do i=is,ie+1 - vb(i,1) = dt5*(vt(i-1,1)+vt(i,1)) ! corner values are incorrect - enddo - endif - - do j=js2,je1 - do i=is2,ie1 - vb(i,j) = dt5*(vc(i-1,j)+vc(i,j)-(uc(i,j-1)+uc(i,j))*cosa(i,j))*rsina(i,j) - enddo - - if ( is==1 ) then - ! 2-pt extrapolation from both sides: - vb(1,j) = dt4*(-vt(-1,j) + 3.*(vt(0,j)+vt(1,j)) - vt(2,j)) - endif - if ( (ie+1)==npx ) then - ! 2-pt extrapolation from both sides: - vb(npx,j) = dt4*(-vt(npx-2,j) + 3.*(vt(npx-1,j)+vt(npx,j)) - vt(npx+1,j)) - endif - enddo - - if ( (je+1)==npy ) then - do i=is,ie+1 - vb(i,npy) = dt5*(vt(i-1,npy)+vt(i,npy)) ! corner values are incorrect - enddo - endif - endif - - else - do j=js,je+1 - do i=is,ie+1 - vb(i,j) = dt5*(vc(i-1,j)+vc(i,j)) - enddo - enddo - endif - - call ytp_v(is,ie,js,je,isd,ied,jsd,jed, vb, u, v, ub, hord_mt, gridstruct%dy, gridstruct%rdy, & - npx, npy, flagstruct%grid_type, nested, flagstruct%lim_fac, regional) - - do j=js,je+1 - do i=is,ie+1 - ke(i,j) = vb(i,j)*ub(i,j) - enddo - enddo - - if (flagstruct%grid_type < 3) then - - if (nested .or. regional) then - - do j=js,je+1 - - do i=is2,ie1 - ub(i,j) = dt5*(uc(i,j-1)+uc(i,j)-(vc(i-1,j)+vc(i,j))*cosa(i,j))*rsina(i,j) - enddo - - enddo - - - else - if ( is==1 ) then - do j=js,je+1 - ub(1,j) = dt5*(ut(1,j-1)+ut(1,j)) ! corner values are incorrect - enddo - endif - - do j=js,je+1 - if ( (j==1 .or. j==npy) ) then - do i=is2,ie1 - ! 2-pt extrapolation from both sides: - ub(i,j) = dt4*(-ut(i,j-2) + 3.*(ut(i,j-1)+ut(i,j)) - ut(i,j+1)) - enddo - else - do i=is2,ie1 - ub(i,j) = dt5*(uc(i,j-1)+uc(i,j)-(vc(i-1,j)+vc(i,j))*cosa(i,j))*rsina(i,j) - enddo - endif - enddo - - if ( (ie+1)==npx ) then - do j=js,je+1 - ub(npx,j) = dt5*(ut(npx,j-1)+ut(npx,j)) ! corner values are incorrect - enddo - endif - endif - - else - do j=js,je+1 - do i=is,ie+1 - ub(i,j) = dt5*(uc(i,j-1)+uc(i,j)) - enddo - enddo - endif - - call xtp_u(is,ie,js,je, isd,ied,jsd,jed, ub, u, v, vb, hord_mt, gridstruct%dx, gridstruct%rdx, & - npx, npy, flagstruct%grid_type, nested, flagstruct%lim_fac, regional) - - do j=js,je+1 - do i=is,ie+1 - ke(i,j) = 0.5*(ke(i,j) + ub(i,j)*vb(i,j)) - enddo - enddo - -!----------------------------------------- -! Fix KE at the 4 corners of the face: -!----------------------------------------- - if (.not. (nested .or. regional)) then - dt6 = dt / 6. - if ( sw_corner ) then - ke(1,1) = dt6*( (ut(1,1) + ut(1,0)) * u(1,1) + & - (vt(1,1) + vt(0,1)) * v(1,1) + & - (ut(1,1) + vt(1,1)) * u(0,1) ) - endif - if ( se_corner ) then - i = npx - ke(i,1) = dt6*( (ut(i,1) + ut(i, 0)) * u(i-1,1) + & - (vt(i,1) + vt(i-1,1)) * v(i, 1) + & - (ut(i,1) - vt(i-1,1)) * u(i, 1) ) - endif - if ( ne_corner ) then - i = npx; j = npy - ke(i,j) = dt6*( (ut(i,j ) + ut(i,j-1)) * u(i-1,j) + & - (vt(i,j ) + vt(i-1,j)) * v(i,j-1) + & - (ut(i,j-1) + vt(i-1,j)) * u(i,j ) ) - endif - if ( nw_corner ) then - j = npy - ke(1,j) = dt6*( (ut(1, j) + ut(1,j-1)) * u(1,j ) + & - (vt(1, j) + vt(0, j)) * v(1,j-1) + & - (ut(1,j-1) - vt(1, j)) * u(0,j ) ) - endif - end if - -! Compute vorticity: - do j=jsd,jed+1 - do i=isd,ied - vt(i,j) = u(i,j)*dx(i,j) - enddo - enddo - do j=jsd,jed - do i=isd,ied+1 - ut(i,j) = v(i,j)*dy(i,j) - enddo - enddo - -! wk is "volume-mean" relative vorticity - do j=jsd,jed - do i=isd,ied - wk(i,j) = rarea(i,j)*(vt(i,j)-vt(i,j+1)-ut(i,j)+ut(i+1,j)) - enddo - enddo - - if ( .not. hydrostatic ) then - if( flagstruct%do_f3d ) then -#ifdef ROT3 - dt2 = 2.*dt - do j=js,je - do i=is,ie - w(i,j) = w(i,j)/delp(i,j) + dt2*gridstruct%w00(i,j) * & - ( gridstruct%a11(i,j)*(u(i,j)+u(i,j+1)) + & - gridstruct%a12(i,j)*(v(i,j)+v(i+1,j)) ) - enddo - enddo -#endif - else - do j=js,je - do i=is,ie - w(i,j) = w(i,j)/delp(i,j) - enddo - enddo - endif - if ( damp_w>1.E-5 ) then - do j=js,je - do i=is,ie - w(i,j) = w(i,j) + dw(i,j) - enddo - enddo - endif - - endif -#ifdef USE_COND - do j=js,je - do i=is,ie - q_con(i,j) = q_con(i,j)/delp(i,j) - enddo - enddo -#endif - -!----------------------------- -! Compute divergence damping -!----------------------------- -! damp = dddmp * da_min_c - - if ( nord==0 ) then -! area ~ dxb*dyb*sin(alpha) - - if (nested .or. regional) then - - do j=js,je+1 - do i=is-1,ie+1 - ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) & - *dyc(i,j)*sina_v(i,j) - enddo - enddo - - do j=js-1,je+1 - do i=is2,ie1 - vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) & - *dxc(i,j)*sina_u(i,j) - enddo - enddo - - else - do j=js,je+1 - - if ( (j==1 .or. j==npy) ) then - do i=is-1,ie+1 - if (vc(i,j) > 0) then - ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j-1,4) - else - ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j,2) - end if - enddo - else - do i=is-1,ie+1 - ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) & - *dyc(i,j)*sina_v(i,j) - enddo - endif - enddo - - do j=js-1,je+1 - do i=is2,ie1 - vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) & - *dxc(i,j)*sina_u(i,j) - enddo - if ( is == 1 ) then - if (uc(1,j) > 0) then - vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0,j,3) - else - vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1,j,1) - end if - end if - if ( (ie+1)==npx ) then - if (uc(npx,j) > 0) then - vort(npx,j) = v(npx,j)*dxc(npx,j)* & - sin_sg(npx-1,j,3) - else - vort(npx,j) = v(npx,j)*dxc(npx,j)* & - sin_sg(npx,j,1) - end if - end if - enddo - endif - - do j=js,je+1 - do i=is,ie+1 - delpc(i,j) = vort(i,j-1) - vort(i,j) + ptc(i-1,j) - ptc(i,j) - enddo - enddo - -! Remove the extra term at the corners: - if (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0) - if (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0) - if (ne_corner) delpc(npx,npy) = delpc(npx,npy) + vort(npx,npy) - if (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy) - - do j=js,je+1 - do i=is,ie+1 - delpc(i,j) = gridstruct%rarea_c(i,j)*delpc(i,j) - damp = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*abs(delpc(i,j)*dt))) - vort(i,j) = damp*delpc(i,j) - ke(i,j) = ke(i,j) + vort(i,j) - enddo - enddo - else -!-------------------------- -! Higher order divg damping -!-------------------------- - do j=js,je+1 - do i=is,ie+1 -! Save divergence for external mode filter - delpc(i,j) = divg_d(i,j) - enddo - enddo - - n2 = nord + 1 ! N > 1 - do n=1,nord - nt = nord-n - - fill_c = (nt/=0) .and. (flagstruct%grid_type<3) .and. & - ( sw_corner .or. se_corner .or. ne_corner .or. nw_corner ) & - .and. .not. (nested .or. regional) - - if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=XDir, BGRID=.true.) - do j=js-nt,je+1+nt - do i=is-1-nt,ie+1+nt - vc(i,j) = (divg_d(i+1,j)-divg_d(i,j))*divg_u(i,j) - enddo - enddo - - if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=YDir, BGRID=.true.) - do j=js-1-nt,je+1+nt - do i=is-nt,ie+1+nt - uc(i,j) = (divg_d(i,j+1)-divg_d(i,j))*divg_v(i,j) - enddo - enddo - - if ( fill_c ) call fill_corners(vc, uc, npx, npy, VECTOR=.true., DGRID=.true.) - do j=js-nt,je+1+nt - do i=is-nt,ie+1+nt - divg_d(i,j) = uc(i,j-1) - uc(i,j) + vc(i-1,j) - vc(i,j) - enddo - enddo - -! Remove the extra term at the corners: - if (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0) - if (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0) - if (ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + uc(npx,npy) - if (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy) - - if ( .not. gridstruct%stretched_grid ) then - do j=js-nt,je+1+nt - do i=is-nt,ie+1+nt - divg_d(i,j) = divg_d(i,j)*gridstruct%rarea_c(i,j) - enddo - enddo - endif - - enddo ! n-loop - - if ( dddmp<1.E-5) then - vort(:,:) = 0. - else - if ( flagstruct%grid_type < 3 ) then -! Interpolate relative vort to cell corners - call a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng, .false.) - do j=js,je+1 - do i=is,ie+1 -! The following is an approxi form of Smagorinsky diffusion - vort(i,j) = abs(dt)*sqrt(delpc(i,j)**2 + vort(i,j)**2) - enddo - enddo - else ! Correct form: works only for doubly preiodic domain - call smag_corner(abs(dt), u, v, ua, va, vort, bd, npx, npy, gridstruct, ng) - endif - endif - - if (gridstruct%stretched_grid ) then -! Stretched grid with variable damping ~ area - dd8 = gridstruct%da_min * d4_bg**n2 - else - dd8 = ( gridstruct%da_min_c*d4_bg )**n2 - endif - - do j=js,je+1 - do i=is,ie+1 - damp2 = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*vort(i,j))) ! del-2 - vort(i,j) = damp2*delpc(i,j) + dd8*divg_d(i,j) - ke(i,j) = ke(i,j) + vort(i,j) - enddo - enddo - - endif - - if ( d_con > 1.e-5 ) then - do j=js,je+1 - do i=is,ie - ub(i,j) = vort(i,j) - vort(i+1,j) - enddo - enddo - do j=js,je - do i=is,ie+1 - vb(i,j) = vort(i,j) - vort(i,j+1) - enddo - enddo - endif - -! Vorticity transport - if ( hydrostatic ) then - do j=jsd,jed - do i=isd,ied - vort(i,j) = wk(i,j) + f0(i,j) - enddo - enddo - else - if ( flagstruct%do_f3d ) then - do j=jsd,jed - do i=isd,ied - vort(i,j) = wk(i,j) + f0(i,j)*z_rat(i,j) - enddo - enddo - else - do j=jsd,jed - do i=isd,ied - vort(i,j) = wk(i,j) + f0(i,j) - enddo - enddo - endif - endif - - call fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, fy, & - xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac,regional) - do j=js,je+1 - do i=is,ie - u(i,j) = vt(i,j) + ke(i,j) - ke(i+1,j) + fy(i,j) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j) = ut(i,j) + ke(i,j) - ke(i,j+1) - fx(i,j) - enddo - enddo - -!-------------------------------------------------------- -! damping applied to relative vorticity (wk): - if ( damp_v>1.E-5 ) then - damp4 = (damp_v*gridstruct%da_min_c)**(nord_v+1) - call del6_vt_flux(nord_v, npx, npy, damp4, wk, vort, ut, vt, gridstruct, bd) - endif - - if ( d_con > 1.e-5 .or. flagstruct%do_skeb ) then - do j=js,je+1 - do i=is,ie - ub(i,j) = (ub(i,j) + vt(i,j))*rdx(i,j) - fy(i,j) = u(i,j)*rdx(i,j) - gy(i,j) = fy(i,j)*ub(i,j) - enddo - enddo - do j=js,je - do i=is,ie+1 - vb(i,j) = (vb(i,j) - ut(i,j))*rdy(i,j) - fx(i,j) = v(i,j)*rdy(i,j) - gx(i,j) = fx(i,j)*vb(i,j) - enddo - enddo -!---------------------------------- -! Heating due to damping: -!---------------------------------- - damp = 0.25*d_con - do j=js,je - do i=is,ie - u2 = fy(i,j) + fy(i,j+1) - du2 = ub(i,j) + ub(i,j+1) - v2 = fx(i,j) + fx(i+1,j) - dv2 = vb(i,j) + vb(i+1,j) -! Total energy conserving: -! Convert lost KE due to divergence damping to "heat" - heat_source(i,j) = delp(i,j)*(heat_source(i,j) - damp*rsin2(i,j)*( & - (ub(i,j)**2 + ub(i,j+1)**2 + vb(i,j)**2 + vb(i+1,j)**2) & - + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j)) & - - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)) ) - if (flagstruct%do_skeb) then - diss_est(i,j) = diss_est(i,j)-rsin2(i,j)*( & - (ub(i,j)**2 + ub(i,j+1)**2 + vb(i,j)**2 + vb(i+1,j)**2) & - + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j)) & - - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)) - endif - enddo - enddo - endif - -! Add diffusive fluxes to the momentum equation: - if ( damp_v>1.E-5 ) then - do j=js,je+1 - do i=is,ie - u(i,j) = u(i,j) + vt(i,j) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j) = v(i,j) - ut(i,j) - enddo - enddo - endif - -#ifdef SW_DYNAMICS - endif ! test_case -#endif - - end subroutine d_sw - -!>@brief The subroutine 'del6_vt_flux' applies 2nd, 4th, or 6th-order damping -!! to fluxes ("vorticity damping") - subroutine del6_vt_flux(nord, npx, npy, damp, q, d2, fx2, fy2, gridstruct, bd) -! Del-nord damping for the relative vorticity -! nord must be <= 2 -!------------------ -! nord = 0: del-2 -! nord = 1: del-4 -! nord = 2: del-6 -!------------------ - integer, intent(in):: nord, npx, npy - real, intent(in):: damp - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(inout):: q(bd%isd:bd%ied, bd%jsd:bd%jed) ! rel. vorticity ghosted on input - type(fv_grid_type), intent(IN), target :: gridstruct -! Work arrays: - real, intent(out):: d2(bd%isd:bd%ied, bd%jsd:bd%jed) - real, intent(out):: fx2(bd%isd:bd%ied+1,bd%jsd:bd%jed), fy2(bd%isd:bd%ied,bd%jsd:bd%jed+1) - integer i,j, nt, n, i1, i2, j1, j2 - - logical :: nested, regional - -#ifdef USE_SG - real, pointer, dimension(:,:,:) :: sin_sg - real, pointer, dimension(:,:) :: rdxc, rdyc, dx,dy -#endif - - integer :: is, ie, js, je - -#ifdef USE_SG - sin_sg => gridstruct%sin_sg - rdxc => gridstruct%rdxc - rdyc => gridstruct%rdyc - dx => gridstruct%dx - dy => gridstruct%dy -#endif - nested = gridstruct%nested - regional = gridstruct%regional - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - - i1 = is-1-nord; i2 = ie+1+nord - j1 = js-1-nord; j2 = je+1+nord - - do j=j1, j2 - do i=i1, i2 - d2(i,j) = damp*q(i,j) - enddo - enddo - - if( nord>0 .and. (.not. (regional))) call copy_corners(d2, npx, npy, 1, nested, bd, gridstruct%sw_corner, & - gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - do j=js-nord,je+nord - do i=is-nord,ie+nord+1 -#ifdef USE_SG - fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i-1,j)-d2(i,j))*rdxc(i,j) -#else - fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i-1,j)-d2(i,j)) -#endif - enddo - enddo - - if( nord>0 .and. (.not. (regional))) call copy_corners(d2, npx, npy, 2, nested, bd, gridstruct%sw_corner, & - gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - do j=js-nord,je+nord+1 - do i=is-nord,ie+nord -#ifdef USE_SG - fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j-1)-d2(i,j))*rdyc(i,j) -#else - fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j-1)-d2(i,j)) -#endif - enddo - enddo - - if ( nord>0 ) then - do n=1, nord - nt = nord-n - do j=js-nt-1,je+nt+1 - do i=is-nt-1,ie+nt+1 - d2(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*gridstruct%rarea(i,j) - enddo - enddo - - if (.not. (regional)) call copy_corners(d2, npx, npy, 1, nested, bd, gridstruct%sw_corner, & - gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - - do j=js-nt,je+nt - do i=is-nt,ie+nt+1 -#ifdef USE_SG - fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i,j)-d2(i-1,j))*rdxc(i,j) -#else - fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i,j)-d2(i-1,j)) -#endif - enddo - enddo - - if (.not. (regional))call copy_corners(d2, npx, npy, 2, nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - - do j=js-nt,je+nt+1 - do i=is-nt,ie+nt -#ifdef USE_SG - fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j)-d2(i,j-1))*rdyc(i,j) -#else - fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j)-d2(i,j-1)) -#endif - enddo - enddo - enddo - endif - - end subroutine del6_vt_flux - -!>@brief The subroutine 'divergence_corner' computes the cell-mean divergence on the -!! "dual grid", the native-grid positioning of the divergence. - subroutine divergence_corner(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(in), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1):: u - real, intent(in), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: v - real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: ua, va - real, intent(out), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed+1):: divg_d - type(fv_grid_type), intent(IN), target :: gridstruct - type(fv_flags_type), intent(IN), target :: flagstruct -! local - real uf(bd%is-2:bd%ie+2,bd%js-1:bd%je+2) - real vf(bd%is-1:bd%ie+2,bd%js-2:bd%je+2) - integer i,j - integer is2, ie1 - - real, pointer, dimension(:,:,:) :: sin_sg, cos_sg - real, pointer, dimension(:,:) :: dxc,dyc - - integer :: is, ie, js, je - integer :: npx, npy - logical :: nested, regional - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - - npx = flagstruct%npx - npy = flagstruct%npy - nested = gridstruct%nested - regional = gridstruct%regional - - sin_sg => gridstruct%sin_sg - cos_sg => gridstruct%cos_sg - dxc => gridstruct%dxc - dyc => gridstruct%dyc - - if (nested .or. regional) then - is2 = is; ie1 = ie+1 - else - is2 = max(2,is); ie1 = min(npx-1,ie+1) - end if - - if (flagstruct%grid_type==4) then - do j=js-1,je+2 - do i=is-2,ie+2 - uf(i,j) = u(i,j)*dyc(i,j) - enddo - enddo - do j=js-2,je+2 - do i=is-1,ie+2 - vf(i,j) = v(i,j)*dxc(i,j) - enddo - enddo - do j=js-1,je+2 - do i=is-1,ie+2 - divg_d(i,j) = gridstruct%rarea_c(i,j)*(vf(i,j-1)-vf(i,j)+uf(i-1,j)-uf(i,j)) - enddo - enddo - else -! 9---4---8 -! | | -! 1 5 3 -! | | -! 6---2---7 - do j=js,je+1 - if ( j==1 .or. j==npy ) then - do i=is-1,ie+1 - uf(i,j) = u(i,j)*dyc(i,j)*0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2)) - enddo - else - do i=is-1,ie+1 - uf(i,j) = (u(i,j)-0.25*(va(i,j-1)+va(i,j))*(cos_sg(i,j-1,4)+cos_sg(i,j,2))) & - * dyc(i,j)*0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2)) - enddo - endif - enddo - - do j=js-1,je+1 - do i=is2,ie1 - vf(i,j) = (v(i,j) - 0.25*(ua(i-1,j)+ua(i,j))*(cos_sg(i-1,j,3)+cos_sg(i,j,1))) & - *dxc(i,j)*0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1)) - enddo - if ( is == 1 ) vf(1, j) = v(1, j)*dxc(1, j)*0.5*(sin_sg(0,j,3)+sin_sg(1,j,1)) - if ( (ie+1)==npx ) vf(npx,j) = v(npx,j)*dxc(npx,j)*0.5*(sin_sg(npx-1,j,3)+sin_sg(npx,j,1)) - enddo - - do j=js,je+1 - do i=is,ie+1 - divg_d(i,j) = vf(i,j-1) - vf(i,j) + uf(i-1,j) - uf(i,j) - enddo - enddo - -! Remove the extra term at the corners: - if (gridstruct%sw_corner) divg_d(1, 1) = divg_d(1, 1) - vf(1, 0) - if (gridstruct%se_corner) divg_d(npx, 1) = divg_d(npx, 1) - vf(npx, 0) - if (gridstruct%ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + vf(npx,npy) - if (gridstruct%nw_corner) divg_d(1, npy) = divg_d(1, npy) + vf(1, npy) - - do j=js,je+1 - do i=is,ie+1 - divg_d(i,j) = gridstruct%rarea_c(i,j)*divg_d(i,j) - enddo - enddo - - endif - - end subroutine divergence_corner - - subroutine divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(in), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1):: u - real, intent(in), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed):: v - real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: ua, va - real, intent(out), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed+1):: divg_d - type(fv_grid_type), intent(IN), target :: gridstruct - type(fv_flags_type), intent(IN), target :: flagstruct - -! local - real uf(bd%isd:bd%ied,bd%jsd:bd%jed+1) - real vf(bd%isd:bd%ied+1,bd%jsd:bd%jed) - integer i,j - - - real, pointer, dimension(:,:) :: rarea_c - - real, pointer, dimension(:,:,:) :: sin_sg, cos_sg - real, pointer, dimension(:,:) :: cosa_u, cosa_v - real, pointer, dimension(:,:) :: sina_u, sina_v - real, pointer, dimension(:,:) :: dxc,dyc - - integer :: isd, ied, jsd, jed - integer :: npx, npy - logical :: nested, regional - - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - npx = flagstruct%npx - npy = flagstruct%npy - nested = gridstruct%nested - regional = gridstruct%regional - - rarea_c => gridstruct%rarea_c - sin_sg => gridstruct%sin_sg - cos_sg => gridstruct%cos_sg - cosa_u => gridstruct%cosa_u - cosa_v => gridstruct%cosa_v - sina_u => gridstruct%sina_u - sina_v => gridstruct%sina_v - dxc => gridstruct%dxc - dyc => gridstruct%dyc - - divg_d = 1.e25 - - if (flagstruct%grid_type==4) then - do j=jsd,jed - do i=isd,ied - uf(i,j) = u(i,j)*dyc(i,j) - enddo - enddo - do j=jsd,jed - do i=isd,ied - vf(i,j) = v(i,j)*dxc(i,j) - enddo - enddo - do j=jsd+1,jed - do i=isd+1,ied - divg_d(i,j) = rarea_c(i,j)*(vf(i,j-1)-vf(i,j)+uf(i-1,j)-uf(i,j)) - enddo - enddo - else - - do j=jsd+1,jed - do i=isd,ied - uf(i,j) = (u(i,j)-0.25*(va(i,j-1)+va(i,j))*(cos_sg(i,j-1,4)+cos_sg(i,j,2))) & - * dyc(i,j)*0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2)) - enddo - enddo - - do j=jsd,jed - do i=isd+1,ied - vf(i,j) = (v(i,j) - 0.25*(ua(i-1,j)+ua(i,j))*(cos_sg(i-1,j,3)+cos_sg(i,j,1))) & - *dxc(i,j)*0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1)) - enddo - enddo - - do j=jsd+1,jed - do i=isd+1,ied - divg_d(i,j) = (vf(i,j-1) - vf(i,j) + uf(i-1,j) - uf(i,j))*rarea_c(i,j) - enddo - enddo - -!!$ !Edges -!!$ -!!$ !West, East -!!$ do j=jsd+1,jed -!!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j) -!!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j) -!!$ end do -!!$ -!!$ !North, South -!!$ do i=isd+1,ied -!!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd) -!!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed) -!!$ end do -!!$ -!!$ !Corners (just use next corner value) -!!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1) -!!$ divg_d(isd,jed+1) = divg_d(isd+1,jed) -!!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1) -!!$ divg_d(ied+1,jed+1) = divg_d(ied,jed) - - endif - - -end subroutine divergence_corner_nest - -!>@brief The subroutine 'smag_corner' computes Smagorinsky damping. - subroutine smag_corner(dt, u, v, ua, va, smag_c, bd, npx, npy, gridstruct, ng) - !> Compute the Tension_Shear strain at cell corners for Smagorinsky diffusion - !! work only if (grid_type==4) - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(in):: dt - integer, intent(IN) :: npx, npy, ng - real, intent(in), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1):: u - real, intent(in), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: v - real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: ua, va - real, intent(out), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: smag_c - type(fv_grid_type), intent(IN), target :: gridstruct -! local - real:: ut(bd%isd:bd%ied+1,bd%jsd:bd%jed) - real:: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1) - real:: wk(bd%isd:bd%ied,bd%jsd:bd%jed) !< work array - real:: sh(bd%isd:bd%ied,bd%jsd:bd%jed) - integer i,j - integer is2, ie1 - - real, pointer, dimension(:,:) :: dxc, dyc, dx, dy, rarea, rarea_c - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - dxc => gridstruct%dxc - dyc => gridstruct%dyc - dx => gridstruct%dx - dy => gridstruct%dy - rarea => gridstruct%rarea - rarea_c => gridstruct%rarea_c - - is2 = max(2,is); ie1 = min(npx-1,ie+1) - -! Smag = sqrt [ T**2 + S**2 ]: unit = 1/s -! where T = du/dx - dv/dy; S = du/dy + dv/dx -! Compute tension strain at corners: - do j=js,je+1 - do i=is-1,ie+1 - ut(i,j) = u(i,j)*dyc(i,j) - enddo - enddo - do j=js-1,je+1 - do i=is,ie+1 - vt(i,j) = v(i,j)*dxc(i,j) - enddo - enddo - do j=js,je+1 - do i=is,ie+1 - smag_c(i,j) = rarea_c(i,j)*(vt(i,j-1)-vt(i,j)-ut(i-1,j)+ut(i,j)) - enddo - enddo -! Fix the corners?? if grid_type /= 4 - -! Compute shear strain: - do j=jsd,jed+1 - do i=isd,ied - vt(i,j) = u(i,j)*dx(i,j) - enddo - enddo - do j=jsd,jed - do i=isd,ied+1 - ut(i,j) = v(i,j)*dy(i,j) - enddo - enddo - - do j=jsd,jed - do i=isd,ied - wk(i,j) = rarea(i,j)*(vt(i,j)-vt(i,j+1)+ut(i,j)-ut(i+1,j)) - enddo - enddo - call a2b_ord4(wk, sh, gridstruct, npx, npy, is, ie, js, je, ng, .false.) - do j=js,je+1 - do i=is,ie+1 - smag_c(i,j) = dt*sqrt( sh(i,j)**2 + smag_c(i,j)**2 ) - enddo - enddo - - end subroutine smag_corner - - - subroutine xtp_u(is,ie,js,je,isd,ied,jsd,jed,c, u, v, flux, iord, dx, rdx, npx, npy, grid_type, nested, lim_fac, regional) - - integer, intent(in):: is,ie,js,je, isd,ied,jsd,jed - real, INTENT(IN):: u(isd:ied,jsd:jed+1) - real, INTENT(IN):: v(isd:ied+1,jsd:jed) - real, INTENT(IN):: c(is:ie+1,js:je+1) - real, INTENT(out):: flux(is:ie+1,js:je+1) - real, INTENT(IN) :: dx(isd:ied, jsd:jed+1) - real, INTENT(IN) :: rdx(isd:ied, jsd:jed+1) - integer, INTENT(IN) :: iord, npx, npy, grid_type - logical, INTENT(IN) :: nested,regional - real, INTENT(IN) :: lim_fac -! Local - real, dimension(is-1:ie+1):: bl, br, b0 - logical, dimension(is-1:ie+1):: smt5, smt6 - logical, dimension(is:ie+1):: hi5, hi6 - real:: fx0(is:ie+1) - real al(is-1:ie+2), dm(is-2:ie+2) - real dq(is-3:ie+2) - real dl, dr, xt, pmp, lac, cfl - real pmp_1, lac_1, pmp_2, lac_2 - real x0, x1, x0L, x0R - integer i, j - integer is3, ie3 - integer is2, ie2 - - if ( nested .or. regional .or. grid_type>3 ) then - is3 = is-1 ; ie3 = ie+1 - else - is3 = max(3,is-1) ; ie3 = min(npx-3,ie+1) - end if - - - if ( iord < 8 ) then -! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 - - do j=js,je+1 - - do i=is3,ie3+1 - al(i) = p1*(u(i-1,j)+u(i,j)) + p2*(u(i-2,j)+u(i+1,j)) - enddo - do i=is3,ie3 - bl(i) = al(i ) - u(i,j) - br(i) = al(i+1) - u(i,j) - enddo - - if ( (.not. (nested .or. regional)) .and. grid_type < 3) then - if ( is==1 ) then - xt = c3*u(1,j) + c2*u(2,j) + c1*u(3,j) - br(1) = xt - u(1,j) - bl(2) = xt - u(2,j) - br(2) = al(3) - u(2,j) - if( j==1 .or. j==npy ) then - bl(0) = 0. ! out - br(0) = 0. ! edge - bl(1) = 0. ! edge - br(1) = 0. ! in - else - bl(0) = c1*u(-2,j) + c2*u(-1,j) + c3*u(0,j) - u(0,j) - xt = 0.5*( ((2.*dx(0,j)+dx(-1,j))*(u(0,j))-dx(0,j)*u(-1,j))/(dx(0,j)+dx(-1,j)) & - + ((2.*dx(1,j)+dx( 2,j))*(u(1,j))-dx(1,j)*u( 2,j))/(dx(1,j)+dx( 2,j)) ) - br(0) = xt - u(0,j) - bl(1) = xt - u(1,j) - endif -! call pert_ppm(1, u(2,j), bl(2), br(2), -1) - endif - if ( (ie+1)==npx ) then - bl(npx-2) = al(npx-2) - u(npx-2,j) - xt = c1*u(npx-3,j) + c2*u(npx-2,j) + c3*u(npx-1,j) - br(npx-2) = xt - u(npx-2,j) - bl(npx-1) = xt - u(npx-1,j) - if( j==1 .or. j==npy ) then - bl(npx-1) = 0. ! in - br(npx-1) = 0. ! edge - bl(npx ) = 0. ! edge - br(npx ) = 0. ! out - else - xt = 0.5*( ( (2.*dx(npx-1,j)+dx(npx-2,j))*u(npx-1,j)-dx(npx-1,j)*u(npx-2,j))/(dx(npx-1,j)+dx(npx-2,j)) & - + ( (2.*dx(npx ,j)+dx(npx+1,j))*u(npx ,j)-dx(npx ,j)*u(npx+1,j))/(dx(npx ,j)+dx(npx+1,j)) ) - br(npx-1) = xt - u(npx-1,j) - bl(npx ) = xt - u(npx ,j) - br(npx) = c3*u(npx,j) + c2*u(npx+1,j) + c1*u(npx+2,j) - u(npx,j) - endif -! call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1) - endif - endif - - do i=is-1,ie+1 - b0(i) = bl(i) + br(i) - enddo - - if ( iord==1 ) then - - do i=is-1, ie+1 - smt5(i) = abs(lim_fac*b0(i)) < abs(bl(i)-br(i)) - enddo -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdx(i-1,j) - fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1)) - flux(i,j) = u(i-1,j) - else - cfl = c(i,j)*rdx(i,j) - fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i)) - flux(i,j) = u(i,j) - endif - if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx0(i) - enddo - - elseif ( iord==2 ) then ! Perfectly linear - -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdx(i-1,j) - flux(i,j) = u(i-1,j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1)) - else - cfl = c(i,j)*rdx(i,j) - flux(i,j) = u(i,j) + (1.+cfl)*(bl(i)+cfl*b0(i)) - endif - enddo - - elseif ( iord==3 ) then - - do i=is-1, ie+1 - x0 = abs(b0(i)) - x1 = abs(bl(i)-br(i)) - smt5(i) = x0 < x1 - smt6(i) = 3.*x0 < x1 - enddo - do i=is, ie+1 - fx0(i) = 0. - hi5(i) = smt5(i-1) .and. smt5(i) - hi6(i) = smt6(i-1) .or. smt6(i) - enddo - do i=is, ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdx(i-1,j) - if ( hi6(i) ) then - fx0(i) = br(i-1) - cfl*b0(i-1) - elseif( hi5(i) ) then - fx0(i) = sign(min(abs(bl(i-1)),abs(br(i-1))), br(i-1)) - endif - flux(i,j) = u(i-1,j) + (1.-cfl)*fx0(i) - else - cfl = c(i,j)*rdx(i,j) - if ( hi6(i) ) then - fx0(i) = bl(i) + cfl*b0(i) - elseif( hi5(i) ) then - fx0(i) = sign(min(abs(bl(i)),abs(br(i))), bl(i)) - endif - flux(i,j) = u(i,j) + (1.+cfl)*fx0(i) - endif - enddo - - elseif ( iord==4 ) then - - do i=is-1, ie+1 - x0 = abs(b0(i)) - x1 = abs(bl(i)-br(i)) - smt5(i) = x0 < x1 - smt6(i) = 3.*x0 < x1 - enddo - do i=is, ie+1 - hi5(i) = smt5(i-1) .and. smt5(i) - hi6(i) = smt6(i-1) .or. smt6(i) - hi5(i) = hi5(i) .or. hi6(i) - enddo -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdx(i-1,j) - fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1)) - flux(i,j) = u(i-1,j) - else - cfl = c(i,j)*rdx(i,j) - fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i)) - flux(i,j) = u(i,j) - endif - if ( hi5(i) ) flux(i,j) = flux(i,j) + fx0(i) - enddo - - else ! iord=5,6,7 - - if ( iord==5 ) then - do i=is-1, ie+1 - smt5(i) = bl(i)*br(i) < 0. - enddo - else - do i=is-1, ie+1 - smt5(i) = 3.*abs(b0(i)) < abs(bl(i)-br(i)) - enddo - endif - -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdx(i-1,j) - fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1)) - flux(i,j) = u(i-1,j) - else - cfl = c(i,j)*rdx(i,j) - fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i)) - flux(i,j) = u(i,j) - endif - if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx0(i) - enddo - - endif - enddo - - else - ! iord = 8, 9, 10, 11 - - do j=js,je+1 - do i=is-2,ie+2 - xt = 0.25*(u(i+1,j) - u(i-1,j)) - dm(i) = sign(min(abs(xt), max(u(i-1,j), u(i,j), u(i+1,j)) - u(i,j), & - u(i,j) - min(u(i-1,j), u(i,j), u(i+1,j))), xt) - enddo - do i=is-3,ie+2 - dq(i) = u(i+1,j) - u(i,j) - enddo - - if (grid_type < 3) then - - do i=is3,ie3+1 - al(i) = 0.5*(u(i-1,j)+u(i,j)) + r3*(dm(i-1) - dm(i)) - enddo - -! Perturbation form: - if( iord==8 ) then - do i=is3,ie3 - xt = 2.*dm(i) - bl(i) = -sign(min(abs(xt), abs(al(i )-u(i,j))), xt) - br(i) = sign(min(abs(xt), abs(al(i+1)-u(i,j))), xt) - enddo - elseif( iord==9 ) then - do i=is3,ie3 - pmp_1 = -2.*dq(i) - lac_1 = pmp_1 + 1.5*dq(i+1) - bl(i) = min(max(0., pmp_1, lac_1), max(al(i )-u(i,j), min(0., pmp_1, lac_1))) - pmp_2 = 2.*dq(i-1) - lac_2 = pmp_2 - 1.5*dq(i-2) - br(i) = min(max(0., pmp_2, lac_2), max(al(i+1)-u(i,j), min(0., pmp_2, lac_2))) - enddo - elseif( iord==10 ) then - do i=is3,ie3 - bl(i) = al(i ) - u(i,j) - br(i) = al(i+1) - u(i,j) -! if ( abs(dm(i-1))+abs(dm(i))+abs(dm(i+1)) < near_zero ) then - if ( abs(dm(i)) < near_zero ) then - if ( abs(dm(i-1))+abs(dm(i+1)) < near_zero ) then -! 2-delta-x structure detected within 3 cells - bl(i) = 0. - br(i) = 0. - endif - elseif( abs(3.*(bl(i)+br(i))) > abs(bl(i)-br(i)) ) then - pmp_1 = -2.*dq(i) - lac_1 = pmp_1 + 1.5*dq(i+1) - bl(i) = min(max(0., pmp_1, lac_1), max(bl(i), min(0., pmp_1, lac_1))) - pmp_2 = 2.*dq(i-1) - lac_2 = pmp_2 - 1.5*dq(i-2) - br(i) = min(max(0., pmp_2, lac_2), max(br(i), min(0., pmp_2, lac_2))) - endif - enddo - else -! un-limited: 11 - do i=is3,ie3 - bl(i) = al(i ) - u(i,j) - br(i) = al(i+1) - u(i,j) - enddo - endif - -!-------------- -! fix the edges -!-------------- -!!! TO DO: separate versions for nested and for cubed-sphere - if ( is==1 .and. .not. (nested .or. regional)) then - br(2) = al(3) - u(2,j) - xt = s15*u(1,j) + s11*u(2,j) - s14*dm(2) - bl(2) = xt - u(2,j) - br(1) = xt - u(1,j) - if( j==1 .or. j==npy ) then - bl(0) = 0. ! out - br(0) = 0. ! edge - bl(1) = 0. ! edge - br(1) = 0. ! in - else - bl(0) = s14*dm(-1) - s11*dq(-1) - x0L = 0.5*((2.*dx(0,j)+dx(-1,j))*(u(0,j)) & - - dx(0,j)*(u(-1,j)))/(dx(0,j)+dx(-1,j)) - x0R = 0.5*((2.*dx(1,j)+dx(2,j))*(u(1,j)) & - - dx(1,j)*(u(2,j)))/(dx(1,j)+dx(2,j)) - xt = x0L + x0R - br(0) = xt - u(0,j) - bl(1) = xt - u(1,j) - endif - call pert_ppm(1, u(2,j), bl(2), br(2), -1) - endif - - if ( (ie+1)==npx .and. .not. (nested .or. regional)) then - bl(npx-2) = al(npx-2) - u(npx-2,j) - xt = s15*u(npx-1,j) + s11*u(npx-2,j) + s14*dm(npx-2) - br(npx-2) = xt - u(npx-2,j) - bl(npx-1) = xt - u(npx-1,j) - if( j==1 .or. j==npy ) then - bl(npx-1) = 0. ! in - br(npx-1) = 0. ! edge - bl(npx ) = 0. ! edge - br(npx ) = 0. ! out - else - br(npx) = s11*dq(npx) - s14*dm(npx+1) - x0L = 0.5*( (2.*dx(npx-1,j)+dx(npx-2,j))*(u(npx-1,j)) & - - dx(npx-1,j)*(u(npx-2,j)))/(dx(npx-1,j)+dx(npx-2,j)) - x0R = 0.5*( (2.*dx(npx,j)+dx(npx+1,j))*(u(npx,j)) & - - dx(npx,j)*(u(npx+1,j)))/(dx(npx,j)+dx(npx+1,j)) - xt = x0L + x0R - br(npx-1) = xt - u(npx-1,j) - bl(npx ) = xt - u(npx ,j) - endif - call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1) - endif - - else -! Other grids: - do i=is-1,ie+2 - al(i) = 0.5*(u(i-1,j)+u(i,j)) + r3*(dm(i-1) - dm(i)) - enddo - - do i=is-1,ie+1 - pmp = -2.*dq(i) - lac = pmp + 1.5*dq(i+1) - bl(i) = min(max(0., pmp, lac), max(al(i )-u(i,j), min(0.,pmp, lac))) - pmp = 2.*dq(i-1) - lac = pmp - 1.5*dq(i-2) - br(i) = min(max(0., pmp, lac), max(al(i+1)-u(i,j), min(0.,pmp, lac))) - enddo - endif - - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdx(i-1,j) - flux(i,j) = u(i-1,j) + (1.-cfl)*(br(i-1)-cfl*(bl(i-1)+br(i-1))) - else - cfl = c(i,j)*rdx(i,j) - flux(i,j) = u(i, j) + (1.+cfl)*(bl(i )+cfl*(bl(i )+br(i ))) - endif - enddo - enddo - - endif - - end subroutine xtp_u - - - subroutine ytp_v(is,ie,js,je,isd,ied,jsd,jed, c, u, v, flux, jord, dy, rdy, npx, npy, grid_type, nested, lim_fac, regional) - integer, intent(in):: is,ie,js,je, isd,ied,jsd,jed - integer, intent(IN):: jord - real, INTENT(IN) :: u(isd:ied,jsd:jed+1) - real, INTENT(IN) :: v(isd:ied+1,jsd:jed) - real, INTENT(IN) :: c(is:ie+1,js:je+1) !< Courant N (like FLUX) - real, INTENT(OUT):: flux(is:ie+1,js:je+1) - real, INTENT(IN) :: dy(isd:ied+1,jsd:jed) - real, INTENT(IN) :: rdy(isd:ied+1,jsd:jed) - integer, INTENT(IN) :: npx, npy, grid_type - logical, INTENT(IN) :: nested,regional - real, INTENT(IN) :: lim_fac -! Local: - logical, dimension(is:ie+1,js-1:je+1):: smt5, smt6 - logical, dimension(is:ie+1):: hi5, hi6 - real:: fx0(is:ie+1) - real dm(is:ie+1,js-2:je+2) - real al(is:ie+1,js-1:je+2) - real, dimension(is:ie+1,js-1:je+1):: bl, br, b0 - real dq(is:ie+1,js-3:je+2) - real xt, dl, dr, pmp, lac, cfl - real pmp_1, lac_1, pmp_2, lac_2 - real x0, x1, x0R, x0L - integer i, j, is1, ie1, js3, je3 - - if ( nested .or. regional .or. grid_type>3 ) then - js3 = js-1; je3 = je+1 - else - js3 = max(3,js-1); je3 = min(npy-3,je+1) - end if - - if ( jord<8 ) then -! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 - - do j=js3,je3+1 - do i=is,ie+1 - al(i,j) = p1*(v(i,j-1)+v(i,j)) + p2*(v(i,j-2)+v(i,j+1)) - enddo - enddo - do j=js3,je3 - do i=is,ie+1 - bl(i,j) = al(i,j ) - v(i,j) - br(i,j) = al(i,j+1) - v(i,j) - enddo - enddo - - if ( (.not. (nested .or. regional)) .and. grid_type < 3) then - if( js==1 ) then - do i=is,ie+1 - bl(i,0) = c1*v(i,-2) + c2*v(i,-1) + c3*v(i,0) - v(i,0) - xt = 0.5*( ((2.*dy(i,0)+dy(i,-1))*v(i,0)-dy(i,0)*v(i,-1))/(dy(i,0)+dy(i,-1)) & - + ((2.*dy(i,1)+dy(i, 2))*v(i,1)-dy(i,1)*v(i, 2))/(dy(i,1)+dy(i, 2)) ) - br(i,0) = xt - v(i,0) - bl(i,1) = xt - v(i,1) - xt = c3*v(i,1) + c2*v(i,2) + c1*v(i,3) - br(i,1) = xt - v(i,1) - bl(i,2) = xt - v(i,2) - br(i,2) = al(i,3) - v(i,2) - enddo - if ( is==1 ) then - bl(1,0) = 0. ! out - br(1,0) = 0. ! edge - bl(1,1) = 0. ! edge - br(1,1) = 0. ! in - endif - if ( (ie+1)==npx ) then - bl(npx,0) = 0. ! out - br(npx,0) = 0. ! edge - bl(npx,1) = 0. ! edge - br(npx,1) = 0. ! in - endif -! j=2 -! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) - endif - if( (je+1)==npy ) then - do i=is,ie+1 - bl(i,npy-2) = al(i,npy-2) - v(i,npy-2) - xt = c1*v(i,npy-3) + c2*v(i,npy-2) + c3*v(i,npy-1) - br(i,npy-2) = xt - v(i,npy-2) - bl(i,npy-1) = xt - v(i,npy-1) - xt = 0.5*( ((2.*dy(i,npy-1)+dy(i,npy-2))*v(i,npy-1)-dy(i,npy-1)*v(i,npy-2))/(dy(i,npy-1)+dy(i,npy-2)) & - + ((2.*dy(i,npy )+dy(i,npy+1))*v(i,npy )-dy(i,npy )*v(i,npy+1))/(dy(i,npy )+dy(i,npy+1)) ) - br(i,npy-1) = xt - v(i,npy-1) - bl(i,npy ) = xt - v(i,npy) - br(i,npy) = c3*v(i,npy)+ c2*v(i,npy+1) + c1*v(i,npy+2) - v(i,npy) - enddo - if ( is==1 ) then - bl(1,npy-1) = 0. ! in - br(1,npy-1) = 0. ! edge - bl(1,npy ) = 0. ! edge - br(1,npy ) = 0. ! out - endif - if ( (ie+1)==npx ) then - bl(npx,npy-1) = 0. ! in - br(npx,npy-1) = 0. ! edge - bl(npx,npy ) = 0. ! edge - br(npx,npy ) = 0. ! out - endif -! j=npy-2 -! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) - endif - endif - - do j=js-1,je+1 - do i=is,ie+1 - b0(i,j) = bl(i,j) + br(i,j) - enddo - enddo - - if ( jord==1 ) then ! Perfectly linear - - do j=js-1,je+1 - do i=is,ie+1 - smt5(i,j) = abs(lim_fac*b0(i,j)) < abs(bl(i,j)-br(i,j)) - enddo - enddo - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdy(i,j-1) - fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) - flux(i,j) = v(i,j-1) - else - cfl = c(i,j)*rdy(i,j) - fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) - flux(i,j) = v(i,j) - endif - if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx0(i) - enddo - enddo - - elseif ( jord==2 ) then ! Perfectly linear - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdy(i,j-1) - flux(i,j) = v(i,j-1) + (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) - else - cfl = c(i,j)*rdy(i,j) - flux(i,j) = v(i,j) + (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) - endif - enddo - enddo - - elseif ( jord==3 ) then - - do j=js-1,je+1 - do i=is,ie+1 - x0 = abs(b0(i,j)) - x1 = abs(bl(i,j)-br(i,j)) - smt5(i,j) = x0 < x1 - smt6(i,j) = 3.*x0 < x1 - enddo - enddo - do j=js,je+1 - do i=is,ie+1 - fx0(i) = 0. - hi5(i) = smt5(i,j-1) .and. smt5(i,j) - hi6(i) = smt6(i,j-1) .or. smt6(i,j) - enddo - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdy(i,j-1) - if ( hi6(i) ) then - fx0(i) = br(i,j-1) - cfl*b0(i,j-1) - elseif ( hi5(i) ) then ! piece-wise linear - fx0(i) = sign(min(abs(bl(i,j-1)),abs(br(i,j-1))), br(i,j-1)) - endif - flux(i,j) = v(i,j-1) + (1.-cfl)*fx0(i) - else - cfl = c(i,j)*rdy(i,j) - if ( hi6(i) ) then - fx0(i) = bl(i,j) + cfl*b0(i,j) - elseif ( hi5(i) ) then ! piece-wise linear - fx0(i) = sign(min(abs(bl(i,j)),abs(br(i,j))), bl(i,j)) - endif - flux(i,j) = v(i,j) + (1.+cfl)*fx0(i) - endif - enddo - enddo - - elseif ( jord==4 ) then - - do j=js-1,je+1 - do i=is,ie+1 - x0 = abs(b0(i,j)) - x1 = abs(bl(i,j)-br(i,j)) - smt5(i,j) = x0 < x1 - smt6(i,j) = 3.*x0 < x1 - enddo - enddo - do j=js,je+1 - do i=is,ie+1 - fx0(i) = 0. - hi5(i) = smt5(i,j-1) .and. smt5(i,j) - hi6(i) = smt6(i,j-1) .or. smt6(i,j) - hi5(i) = hi5(i) .or. hi6(i) - enddo -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdy(i,j-1) - fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) - flux(i,j) = v(i,j-1) - else - cfl = c(i,j)*rdy(i,j) - fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) - flux(i,j) = v(i,j) - endif - if ( hi5(i) ) flux(i,j) = flux(i,j) + fx0(i) - enddo - enddo - - else ! jord = 5,6,7 - if ( jord==5 ) then - - do j=js-1,je+1 - do i=is,ie+1 - smt5(i,j) = bl(i,j)*br(i,j) < 0. - enddo - enddo - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdy(i,j-1) - fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) - flux(i,j) = v(i,j-1) - else - cfl = c(i,j)*rdy(i,j) - fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) - flux(i,j) = v(i,j) - endif - if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx0(i) - enddo - enddo - else -! hord=6 - do j=js-1,je+1 - do i=is,ie+1 - smt6(i,j) = 3.*abs(b0(i,j)) < abs(bl(i,j)-br(i,j)) - enddo - enddo - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if( c(i,j)>0. ) then - cfl = c(i,j)*rdy(i,j-1) - fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) - flux(i,j) = v(i,j-1) - else - cfl = c(i,j)*rdy(i,j) - fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) - flux(i,j) = v(i,j) - endif - if (smt6(i,j-1).or.smt6(i,j)) flux(i,j) = flux(i,j) + fx0(i) - enddo - enddo - endif - - endif - - else -! jord= 8, 9, 10 - - do j=js-2,je+2 - do i=is,ie+1 - xt = 0.25*(v(i,j+1) - v(i,j-1)) - dm(i,j) = sign(min(abs(xt), max(v(i,j-1), v(i,j), v(i,j+1)) - v(i,j), & - v(i,j) - min(v(i,j-1), v(i,j), v(i,j+1))), xt) - enddo - enddo - - do j=js-3,je+2 - do i=is,ie+1 - dq(i,j) = v(i,j+1) - v(i,j) - enddo - enddo - - if (grid_type < 3) then - do j=js3,je3+1 - do i=is,ie+1 - al(i,j) = 0.5*(v(i,j-1)+v(i,j)) + r3*(dm(i,j-1)-dm(i,j)) - enddo - enddo - - if ( jord==8 ) then - do j=js3,je3 - do i=is,ie+1 - xt = 2.*dm(i,j) - bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-v(i,j))), xt) - br(i,j) = sign(min(abs(xt), abs(al(i,j+1)-v(i,j))), xt) - enddo - enddo - elseif ( jord==9 ) then - do j=js3,je3 - do i=is,ie+1 - pmp_1 = -2.*dq(i,j) - lac_1 = pmp_1 + 1.5*dq(i,j+1) - bl(i,j) = min(max(0., pmp_1, lac_1), max(al(i,j)-v(i,j), min(0., pmp_1, lac_1))) - pmp_2 = 2.*dq(i,j-1) - lac_2 = pmp_2 - 1.5*dq(i,j-2) - br(i,j) = min(max(0., pmp_2, lac_2), max(al(i,j+1)-v(i,j), min(0., pmp_2, lac_2))) - enddo - enddo - elseif ( jord==10 ) then - do j=js3,je3 - do i=is,ie+1 - bl(i,j) = al(i,j ) - v(i,j) - br(i,j) = al(i,j+1) - v(i,j) -! if ( abs(dm(i,j-1))+abs(dm(i,j))+abs(dm(i,j+1)) < near_zero ) then - if ( abs(dm(i,j)) < near_zero ) then - if ( abs(dm(i,j-1))+abs(dm(i,j+1)) < near_zero ) then - bl(i,j) = 0. - br(i,j) = 0. - endif - elseif( abs(3.*(bl(i,j)+br(i,j))) > abs(bl(i,j)-br(i,j)) ) then - pmp_1 = -2.*dq(i,j) - lac_1 = pmp_1 + 1.5*dq(i,j+1) - bl(i,j) = min(max(0., pmp_1, lac_1), max(bl(i,j), min(0., pmp_1, lac_1))) - pmp_2 = 2.*dq(i,j-1) - lac_2 = pmp_2 - 1.5*dq(i,j-2) - br(i,j) = min(max(0., pmp_2, lac_2), max(br(i,j), min(0., pmp_2, lac_2))) - endif - enddo - enddo - else -! Unlimited: - do j=js3,je3 - do i=is,ie+1 - bl(i,j) = al(i,j ) - v(i,j) - br(i,j) = al(i,j+1) - v(i,j) - enddo - enddo - endif - -!-------------- -! fix the edges -!-------------- - if( js==1 .and. .not. (nested .or. regional)) then - do i=is,ie+1 - br(i,2) = al(i,3) - v(i,2) - xt = s15*v(i,1) + s11*v(i,2) - s14*dm(i,2) - br(i,1) = xt - v(i,1) - bl(i,2) = xt - v(i,2) - - bl(i,0) = s14*dm(i,-1) - s11*dq(i,-1) - -#ifdef ONE_SIDE - xt = t14*v(i,1) + t12*v(i,2) + t15*v(i,3) - bl(i,1) = 2.*xt - v(i,1) - xt = t14*v(i,0) + t12*v(i,-1) + t15*v(i,-2) - br(i,0) = 2.*xt - v(i,0) -#else - x0L = 0.5*( (2.*dy(i,0)+dy(i,-1))*(v(i,0)) & - - dy(i,0)*(v(i,-1)))/(dy(i,0)+dy(i,-1)) - x0R = 0.5*( (2.*dy(i,1)+dy(i,2))*(v(i,1)) & - - dy(i,1)*(v(i,2)))/(dy(i,1)+dy(i,2)) - xt = x0L + x0R - - bl(i,1) = xt - v(i,1) - br(i,0) = xt - v(i,0) -#endif - enddo - if ( is==1 ) then - bl(1,0) = 0. ! out - br(1,0) = 0. ! edge - bl(1,1) = 0. ! edge - br(1,1) = 0. ! in - endif - if ( (ie+1)==npx ) then - bl(npx,0) = 0. ! out - br(npx,0) = 0. ! edge - bl(npx,1) = 0. ! edge - br(npx,1) = 0. ! in - endif - j=2 - call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) - endif - if( (je+1)==npy .and. .not. (nested .or. regional)) then - do i=is,ie+1 - bl(i,npy-2) = al(i,npy-2) - v(i,npy-2) - xt = s15*v(i,npy-1) + s11*v(i,npy-2) + s14*dm(i,npy-2) - br(i,npy-2) = xt - v(i,npy-2) - bl(i,npy-1) = xt - v(i,npy-1) - br(i,npy) = s11*dq(i,npy) - s14*dm(i,npy+1) -#ifdef ONE_SIDE - xt = t14*v(i,npy-1) + t12*v(i,npy-2) + t15*v(i,npy-3) - br(i,npy-1) = 2.*xt - v(i,npy-1) - xt = t14*v(i,npy) + t12*v(i,npy+1) + t15*v(i,npy+2) - bl(i,npy ) = 2.*xt - v(i,npy) -#else - x0L= 0.5*((2.*dy(i,npy-1)+dy(i,npy-2))*(v(i,npy-1)) - & - dy(i,npy-1)*(v(i,npy-2)))/(dy(i,npy-1)+dy(i,npy-2)) - x0R= 0.5*((2.*dy(i,npy)+dy(i,npy+1))*(v(i,npy)) - & - dy(i,npy)*(v(i,npy+1)))/(dy(i,npy)+dy(i,npy+1)) - xt = x0L + x0R - - br(i,npy-1) = xt - v(i,npy-1) - bl(i,npy ) = xt - v(i,npy) -#endif - enddo - if ( is==1 ) then - bl(1,npy-1) = 0. ! in - br(1,npy-1) = 0. ! edge - bl(1,npy ) = 0. ! edge - br(1,npy ) = 0. ! out - endif - if ( (ie+1)==npx ) then - bl(npx,npy-1) = 0. ! in - br(npx,npy-1) = 0. ! edge - bl(npx,npy ) = 0. ! edge - br(npx,npy ) = 0. ! out - endif - j=npy-2 - call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) - endif - - else - - do j=js-1,je+2 - do i=is,ie+1 - al(i,j) = 0.5*(v(i,j-1)+v(i,j)) + r3*(dm(i,j-1)-dm(i,j)) - enddo - enddo - - do j=js-1,je+1 - do i=is,ie+1 - pmp = 2.*dq(i,j-1) - lac = pmp - 1.5*dq(i,j-2) - br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-v(i,j), min(0.,pmp,lac))) - pmp = -2.*dq(i,j) - lac = pmp + 1.5*dq(i,j+1) - bl(i,j) = min(max(0.,pmp,lac), max(al(i,j)-v(i,j), min(0.,pmp,lac))) - enddo - enddo - - endif - - do j=js,je+1 - do i=is,ie+1 - if(c(i,j)>0.) then - cfl = c(i,j)*rdy(i,j-1) - flux(i,j) = v(i,j-1) + (1.-cfl)*(br(i,j-1)-cfl*(bl(i,j-1)+br(i,j-1))) - else - cfl = c(i,j)*rdy(i,j) - flux(i,j) = v(i,j ) + (1.+cfl)*(bl(i,j )+cfl*(bl(i,j )+br(i,j ))) - endif - enddo - enddo - - endif - -end subroutine ytp_v - - -!There is a limit to how far this routine can fill uc and vc in the -! halo, and so either mpp_update_domains or some sort of boundary -! routine (extrapolation, outflow, interpolation from a nested grid) -! is needed after c_sw is completed if these variables are needed -! in the halo - subroutine d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, & - bd, npx, npy, nested, grid_type, regional ) - type(fv_grid_bounds_type), intent(IN) :: bd - logical, intent(in):: dord4 - real, intent(in) :: u(bd%isd:bd%ied,bd%jsd:bd%jed+1) - real, intent(in) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed) - real, intent(out), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: uc - real, intent(out), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed+1):: vc - real, intent(out), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed ):: ua, va, ut, vt - integer, intent(IN) :: npx, npy, grid_type - logical, intent(IN) :: nested,regional - type(fv_grid_type), intent(IN), target :: gridstruct -! Local - real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: utmp, vtmp - integer npt, i, j, ifirst, ilast, id - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - real, pointer, dimension(:,:,:) :: sin_sg - real, pointer, dimension(:,:) :: cosa_u, cosa_v, cosa_s - real, pointer, dimension(:,:) :: rsin_u, rsin_v, rsin2 - real, pointer, dimension(:,:) :: dxa,dya - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - sin_sg => gridstruct%sin_sg - cosa_u => gridstruct%cosa_u - cosa_v => gridstruct%cosa_v - cosa_s => gridstruct%cosa_s - rsin_u => gridstruct%rsin_u - rsin_v => gridstruct%rsin_v - rsin2 => gridstruct%rsin2 - dxa => gridstruct%dxa - dya => gridstruct%dya - - if ( dord4 ) then - id = 1 - else - id = 0 - endif - - if (grid_type < 3 .and. .not. (nested .or. regional)) then - npt = 4 - else - npt = -2 - endif - -! Initialize the non-existing corner regions - utmp(:,:) = big_number - vtmp(:,:) = big_number - - if ( nested .or. regional) then - - do j=jsd+1,jed-1 - do i=isd,ied - utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) - enddo - enddo - do i=isd,ied - j = jsd - utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) - j = jed - utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) - end do - - do j=jsd,jed - do i=isd+1,ied-1 - vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) - enddo - i = isd - vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) - i = ied - vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) - enddo - - do j=jsd,jed - do i=isd,ied - ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - enddo - enddo - - else - !---------- - ! Interior: - !---------- - do j=max(npt,js-1),min(npy-npt,je+1) - do i=max(npt,isd),min(npx-npt,ied) - utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) - enddo - enddo - do j=max(npt,jsd),min(npy-npt,jed) - do i=max(npt,is-1),min(npx-npt,ie+1) - vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) - enddo - enddo - - !---------- - ! edges: - !---------- - if (grid_type < 3) then - - if ( js==1 .or. jsd=(npy-npt)) then - do j=npy-npt+1,jed - do i=isd,ied - utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) - vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) - enddo - enddo - endif - - if ( is==1 .or. isd=(npx-npt)) then - do j=max(npt,jsd),min(npy-npt,jed) - do i=npx-npt+1,ied - utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) - vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) - enddo - enddo - endif - - endif - -! Contra-variant components at cell center: - do j=js-1-id,je+1+id - do i=is-1-id,ie+1+id - ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - enddo - enddo - - end if - -! A -> C -!-------------- -! Fix the edges -!-------------- -! Xdir: - if( gridstruct%sw_corner ) then - do i=-2,0 - utmp(i,0) = -vtmp(0,1-i) - enddo - endif - if( gridstruct%se_corner ) then - do i=0,2 - utmp(npx+i,0) = vtmp(npx,i+1) - enddo - endif - if( gridstruct%ne_corner ) then - do i=0,2 - utmp(npx+i,npy) = -vtmp(npx,je-i) - enddo - endif - if( gridstruct%nw_corner ) then - do i=-2,0 - utmp(i,npy) = vtmp(0,je+i) - enddo - endif - - if (grid_type < 3 .and. .not. (nested .or. regional)) then - ifirst = max(3, is-1) - ilast = min(npx-2,ie+2) - else - ifirst = is-1 - ilast = ie+2 - endif -!--------------------------------------------- -! 4th order interpolation for interior points: -!--------------------------------------------- - do j=js-1,je+1 - do i=ifirst,ilast - uc(i,j) = a2*(utmp(i-2,j)+utmp(i+1,j)) + a1*(utmp(i-1,j)+utmp(i,j)) - ut(i,j) = (uc(i,j) - v(i,j)*cosa_u(i,j))*rsin_u(i,j) - enddo - enddo - - if (grid_type < 3) then -! Xdir: - if( gridstruct%sw_corner ) then - ua(-1,0) = -va(0,2) - ua( 0,0) = -va(0,1) - endif - if( gridstruct%se_corner ) then - ua(npx, 0) = va(npx,1) - ua(npx+1,0) = va(npx,2) - endif - if( gridstruct%ne_corner ) then - ua(npx, npy) = -va(npx,npy-1) - ua(npx+1,npy) = -va(npx,npy-2) - endif - if( gridstruct%nw_corner ) then - ua(-1,npy) = va(0,npy-2) - ua( 0,npy) = va(0,npy-1) - endif - - if( is==1 .and. .not. (nested .or. regional) ) then - do j=js-1,je+1 - uc(0,j) = c1*utmp(-2,j) + c2*utmp(-1,j) + c3*utmp(0,j) - ut(1,j) = edge_interpolate4(ua(-1:2,j), dxa(-1:2,j)) - !Want to use the UPSTREAM value - if (ut(1,j) > 0.) then - uc(1,j) = ut(1,j)*sin_sg(0,j,3) - else - uc(1,j) = ut(1,j)*sin_sg(1,j,1) - end if - uc(2,j) = c1*utmp(3,j) + c2*utmp(2,j) + c3*utmp(1,j) - ut(0,j) = (uc(0,j) - v(0,j)*cosa_u(0,j))*rsin_u(0,j) - ut(2,j) = (uc(2,j) - v(2,j)*cosa_u(2,j))*rsin_u(2,j) - enddo - endif - - if( (ie+1)==npx .and. .not. (nested .or. regional) ) then - do j=js-1,je+1 - uc(npx-1,j) = c1*utmp(npx-3,j)+c2*utmp(npx-2,j)+c3*utmp(npx-1,j) - ut(npx, j) = edge_interpolate4(ua(npx-2:npx+1,j), dxa(npx-2:npx+1,j)) - if (ut(npx,j) > 0.) then - uc(npx,j) = ut(npx,j)*sin_sg(npx-1,j,3) - else - uc(npx,j) = ut(npx,j)*sin_sg(npx,j,1) - end if - uc(npx+1,j) = c3*utmp(npx,j) + c2*utmp(npx+1,j) + c1*utmp(npx+2,j) - ut(npx-1,j) = (uc(npx-1,j)-v(npx-1,j)*cosa_u(npx-1,j))*rsin_u(npx-1,j) - ut(npx+1,j) = (uc(npx+1,j)-v(npx+1,j)*cosa_u(npx+1,j))*rsin_u(npx+1,j) - enddo - endif - - endif - -!------ -! Ydir: -!------ - if( gridstruct%sw_corner ) then - do j=-2,0 - vtmp(0,j) = -utmp(1-j,0) - enddo - endif - if( gridstruct%nw_corner ) then - do j=0,2 - vtmp(0,npy+j) = utmp(j+1,npy) - enddo - endif - if( gridstruct%se_corner ) then - do j=-2,0 - vtmp(npx,j) = utmp(ie+j,0) - enddo - endif - if( gridstruct%ne_corner ) then - do j=0,2 - vtmp(npx,npy+j) = -utmp(ie-j,npy) - enddo - endif - if( gridstruct%sw_corner ) then - va(0,-1) = -ua(2,0) - va(0, 0) = -ua(1,0) - endif - if( gridstruct%se_corner ) then - va(npx, 0) = ua(npx-1,0) - va(npx,-1) = ua(npx-2,0) - endif - if( gridstruct%ne_corner ) then - va(npx,npy ) = -ua(npx-1,npy) - va(npx,npy+1) = -ua(npx-2,npy) - endif - if( gridstruct%nw_corner ) then - va(0,npy) = ua(1,npy) - va(0,npy+1) = ua(2,npy) - endif - - if (grid_type < 3) then - - do j=js-1,je+2 - if ( j==1 .and. .not. (nested .or. regional) ) then - do i=is-1,ie+1 - vt(i,j) = edge_interpolate4(va(i,-1:2), dya(i,-1:2)) - if (vt(i,j) > 0.) then - vc(i,j) = vt(i,j)*sin_sg(i,j-1,4) - else - vc(i,j) = vt(i,j)*sin_sg(i,j,2) - end if - enddo - elseif ( j==0 .or. j==(npy-1) .and. .not. (nested .or. regional) ) then - do i=is-1,ie+1 - vc(i,j) = c1*vtmp(i,j-2) + c2*vtmp(i,j-1) + c3*vtmp(i,j) - vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j) - enddo - elseif ( j==2 .or. j==(npy+1) .and. .not. (nested.or. regional) ) then - do i=is-1,ie+1 - vc(i,j) = c1*vtmp(i,j+1) + c2*vtmp(i,j) + c3*vtmp(i,j-1) - vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j) - enddo - elseif ( j==npy .and. .not. (nested .or. regional) ) then - do i=is-1,ie+1 - vt(i,j) = edge_interpolate4(va(i,j-2:j+1), dya(i,j-2:j+1)) - if (vt(i,j) > 0.) then - vc(i,j) = vt(i,j)*sin_sg(i,j-1,4) - else - vc(i,j) = vt(i,j)*sin_sg(i,j,2) - end if - enddo - else -! 4th order interpolation for interior points: - do i=is-1,ie+1 - vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1)) + a1*(vtmp(i,j-1)+vtmp(i,j)) - vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j) - enddo - endif - enddo - else -! 4th order interpolation: - do j=js-1,je+2 - do i=is-1,ie+1 - vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1)) + a1*(vtmp(i,j-1)+vtmp(i,j)) - vt(i,j) = vc(i,j) - enddo - enddo - endif - - end subroutine d2a2c_vect - - - real function edge_interpolate4(ua, dxa) - - real, intent(in) :: ua(4) - real, intent(in) :: dxa(4) - real:: t1, t2 - - t1 = dxa(1) + dxa(2) - t2 = dxa(3) + dxa(4) - edge_interpolate4 = 0.5*( ((t1+dxa(2))*ua(2)-dxa(2)*ua(1)) / t1 + & - ((t2+dxa(3))*ua(3)-dxa(3)*ua(4)) / t2 ) - - end function edge_interpolate4 - -!>@brief The subroutine 'fill3_4corners' fills the 4 corners of the scalar fileds only as needed by 'c_core'. - subroutine fill3_4corners(q1, q2, q3, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: dir !< 1: x-dir; 2: y-dir - real, intent(inout):: q1(bd%isd:bd%ied,bd%jsd:bd%jed) - real, intent(inout):: q2(bd%isd:bd%ied,bd%jsd:bd%jed) - real, intent(inout):: q3(bd%isd:bd%ied,bd%jsd:bd%jed) - logical, intent(IN) :: sw_corner, se_corner, ne_corner, nw_corner - integer, intent(IN) :: npx, npy - integer i,j - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - select case(dir) - case(1) - if ( sw_corner ) then - q1(-1,0) = q1(0,2); q1(0,0) = q1(0,1); q1(0,-1) = q1(-1,1) - q2(-1,0) = q2(0,2); q2(0,0) = q2(0,1); q2(0,-1) = q2(-1,1) - q3(-1,0) = q3(0,2); q3(0,0) = q3(0,1); q3(0,-1) = q3(-1,1) - endif - if ( se_corner ) then - q1(npx+1,0) = q1(npx,2); q1(npx,0) = q1(npx,1); q1(npx,-1) = q1(npx+1,1) - q2(npx+1,0) = q2(npx,2); q2(npx,0) = q2(npx,1); q2(npx,-1) = q2(npx+1,1) - q3(npx+1,0) = q3(npx,2); q3(npx,0) = q3(npx,1); q3(npx,-1) = q3(npx+1,1) - endif - if ( ne_corner ) then - q1(npx,npy) = q1(npx,npy-1); q1(npx+1,npy) = q1(npx,npy-2); q1(npx,npy+1) = q1(npx+1,npy-1) - q2(npx,npy) = q2(npx,npy-1); q2(npx+1,npy) = q2(npx,npy-2); q2(npx,npy+1) = q2(npx+1,npy-1) - q3(npx,npy) = q3(npx,npy-1); q3(npx+1,npy) = q3(npx,npy-2); q3(npx,npy+1) = q3(npx+1,npy-1) - endif - if ( nw_corner ) then - q1(0,npy) = q1(0,npy-1); q1(-1,npy) = q1(0,npy-2); q1(0,npy+1) = q1(-1,npy-1) - q2(0,npy) = q2(0,npy-1); q2(-1,npy) = q2(0,npy-2); q2(0,npy+1) = q2(-1,npy-1) - q3(0,npy) = q3(0,npy-1); q3(-1,npy) = q3(0,npy-2); q3(0,npy+1) = q3(-1,npy-1) - endif - - case(2) - if ( sw_corner ) then - q1(0,0) = q1(1,0); q1(0,-1) = q1(2,0); q1(-1,0) = q1(1,-1) - q2(0,0) = q2(1,0); q2(0,-1) = q2(2,0); q2(-1,0) = q2(1,-1) - q3(0,0) = q3(1,0); q3(0,-1) = q3(2,0); q3(-1,0) = q3(1,-1) - endif - if ( se_corner ) then - q1(npx,0) = q1(npx-1,0); q1(npx,-1) = q1(npx-2,0); q1(npx+1,0) = q1(npx-1,-1) - q2(npx,0) = q2(npx-1,0); q2(npx,-1) = q2(npx-2,0); q2(npx+1,0) = q2(npx-1,-1) - q3(npx,0) = q3(npx-1,0); q3(npx,-1) = q3(npx-2,0); q3(npx+1,0) = q3(npx-1,-1) - endif - if ( ne_corner ) then - q1(npx,npy) = q1(npx-1,npy); q1(npx,npy+1) = q1(npx-2,npy); q1(npx+1,npy) = q1(npx-1,npy+1) - q2(npx,npy) = q2(npx-1,npy); q2(npx,npy+1) = q2(npx-2,npy); q2(npx+1,npy) = q2(npx-1,npy+1) - q3(npx,npy) = q3(npx-1,npy); q3(npx,npy+1) = q3(npx-2,npy); q3(npx+1,npy) = q3(npx-1,npy+1) - endif - if ( nw_corner ) then - q1(0,npy) = q1(1,npy); q1(0,npy+1) = q1(2,npy); q1(-1,npy) = q1(1,npy+1) - q2(0,npy) = q2(1,npy); q2(0,npy+1) = q2(2,npy); q2(-1,npy) = q2(1,npy+1) - q3(0,npy) = q3(1,npy); q3(0,npy+1) = q3(2,npy); q3(-1,npy) = q3(1,npy+1) - endif - - end select - end subroutine fill3_4corners - -!>@brief The subroutine ' fill2_4corners' fills the 4 corners of the scalar fileds only as needed by 'c_core'. - subroutine fill2_4corners(q1, q2, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: dir !< 1: x-dir; 2: y-dir - real, intent(inout):: q1(bd%isd:bd%ied,bd%jsd:bd%jed) - real, intent(inout):: q2(bd%isd:bd%ied,bd%jsd:bd%jed) - logical, intent(IN) :: sw_corner, se_corner, ne_corner, nw_corner - integer, intent(IN) :: npx, npy - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - select case(dir) - case(1) - if ( sw_corner ) then - q1(-1,0) = q1(0,2); q1(0,0) = q1(0,1) - q2(-1,0) = q2(0,2); q2(0,0) = q2(0,1) - endif - if ( se_corner ) then - q1(npx+1,0) = q1(npx,2); q1(npx,0) = q1(npx,1) - q2(npx+1,0) = q2(npx,2); q2(npx,0) = q2(npx,1) - endif - if ( nw_corner ) then - q1(0,npy) = q1(0,npy-1); q1(-1,npy) = q1(0,npy-2) - q2(0,npy) = q2(0,npy-1); q2(-1,npy) = q2(0,npy-2) - endif - if ( ne_corner ) then - q1(npx,npy) = q1(npx,npy-1); q1(npx+1,npy) = q1(npx,npy-2) - q2(npx,npy) = q2(npx,npy-1); q2(npx+1,npy) = q2(npx,npy-2) - endif - - case(2) - if ( sw_corner ) then - q1(0,0) = q1(1,0); q1(0,-1) = q1(2,0) - q2(0,0) = q2(1,0); q2(0,-1) = q2(2,0) - endif - if ( se_corner ) then - q1(npx,0) = q1(npx-1,0); q1(npx,-1) = q1(npx-2,0) - q2(npx,0) = q2(npx-1,0); q2(npx,-1) = q2(npx-2,0) - endif - if ( nw_corner ) then - q1(0,npy) = q1(1,npy); q1(0,npy+1) = q1(2,npy) - q2(0,npy) = q2(1,npy); q2(0,npy+1) = q2(2,npy) - endif - if ( ne_corner ) then - q1(npx,npy) = q1(npx-1,npy); q1(npx,npy+1) = q1(npx-2,npy) - q2(npx,npy) = q2(npx-1,npy); q2(npx,npy+1) = q2(npx-2,npy) - endif - - end select - - end subroutine fill2_4corners - -!>@brief The subroutine 'fill_4corners' fills the 4 corners of the scalar fields only as needed by c_core. - subroutine fill_4corners(q, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: dir ! 1: x-dir; 2: y-dir - real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed) - logical, intent(IN) :: sw_corner, se_corner, ne_corner, nw_corner - integer, intent(IN) :: npx, npy - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - select case(dir) - case(1) - if ( sw_corner ) then - q(-1,0) = q(0,2) - q( 0,0) = q(0,1) - endif - if ( se_corner ) then - q(npx+1,0) = q(npx,2) - q(npx, 0) = q(npx,1) - endif - if ( nw_corner ) then - q( 0,npy) = q(0,npy-1) - q(-1,npy) = q(0,npy-2) - endif - if ( ne_corner ) then - q(npx, npy) = q(npx,npy-1) - q(npx+1,npy) = q(npx,npy-2) - endif - - case(2) - if ( sw_corner ) then - q(0, 0) = q(1,0) - q(0,-1) = q(2,0) - endif - if ( se_corner ) then - q(npx, 0) = q(npx-1,0) - q(npx,-1) = q(npx-2,0) - endif - if ( nw_corner ) then - q(0,npy ) = q(1,npy) - q(0,npy+1) = q(2,npy) - endif - if ( ne_corner ) then - q(npx,npy ) = q(npx-1,npy) - q(npx,npy+1) = q(npx-2,npy) - endif - - end select - - end subroutine fill_4corners - - end module sw_core_mod +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'sw_core' advances the forward step of the Lagrangian dynamics +!! as described by \cite lin1997explicit, \cite lin2004vertically, and \cite harris2013two. +!>@details The step is applied to the cubed sphere. + + module sw_core_mod + +! Modules Included: +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
Module NameFunctions Included
a2b_edge_moda2b_ord4
fv_arrays_modffv_grid_type, fv_grid_bounds_type, fv_flags_type
fv_mp_modng,fill_corners, XDir, YDir
+ + use fv_mp_mod, only: ng + use tp_core_mod, only: fv_tp_2d, pert_ppm, copy_corners + use fv_mp_mod, only: fill_corners, XDir, YDir + use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, fv_flags_type + use a2b_edge_mod, only: a2b_ord4 + +#ifdef SW_DYNAMICS + use test_cases_mod, only: test_case +#endif + + implicit none + + real, parameter:: r3 = 1./3. + real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28. + real, parameter:: s11=11./14., s13=-13./14., s14=4./7., s15=3./14. + real, parameter:: near_zero = 1.E-9 !< for KE limiter +#ifdef OVERLOAD_R4 + real, parameter:: big_number = 1.E8 +#else + real, parameter:: big_number = 1.E30 +#endif +!---------------------- +! PPM volume mean form: +!---------------------- + real, parameter:: p1 = 7./12. !< 0.58333333 + real, parameter:: p2 = -1./12. +!---------------------------- +! 4-pt Lagrange interpolation +!---------------------------- + real, parameter:: a1 = 0.5625 + real, parameter:: a2 = -0.0625 +!---------------------------------------------- +! volume-conserving cubic with 2nd drv=0 at end point: + real, parameter:: c1 = -2./14. + real, parameter:: c2 = 11./14. + real, parameter:: c3 = 5./14. +! 3-pt off-center intp formular: +! real, parameter:: c1 = -0.125 +! real, parameter:: c2 = 0.75 +! real, parameter:: c3 = 0.375 +!---------------------------------------------- +! scheme 2.1: perturbation form + real, parameter:: b1 = 1./30. + real, parameter:: b2 = -13./60. + real, parameter:: b3 = -13./60. + real, parameter:: b4 = 0.45 + real, parameter:: b5 = -0.05 + + + private + public :: c_sw, d_sw, fill_4corners, del6_vt_flux, divergence_corner, divergence_corner_nest + + contains + +!>@brief The subroutine 'c_sw' performs a half-timestep advance of the C-grid winds. + subroutine c_sw(delpc, delp, ptc, pt, u,v, w, uc,vc, ua,va, wc, & + ut, vt, divg_d, nord, dt2, hydrostatic, dord4, & + bd, gridstruct, flagstruct) + + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(INOUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u, vc + real, intent(INOUT), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ) :: v, uc + real, intent(INOUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed ) :: delp, pt, ua, va, ut, vt + real, intent(INOUT), dimension(bd%isd: , bd%jsd: ) :: w + real, intent(OUT ), dimension(bd%isd:bd%ied, bd%jsd:bd%jed ) :: delpc, ptc, wc + real, intent(OUT ), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) :: divg_d + integer, intent(IN) :: nord + real, intent(IN) :: dt2 + logical, intent(IN) :: hydrostatic + logical, intent(IN) :: dord4 + type(fv_grid_type), intent(IN), target :: gridstruct + type(fv_flags_type), intent(IN), target :: flagstruct + +! Local: + logical:: sw_corner, se_corner, ne_corner, nw_corner + real, dimension(bd%is-1:bd%ie+1,bd%js-1:bd%je+1):: vort, ke + real, dimension(bd%is-1:bd%ie+2,bd%js-1:bd%je+1):: fx, fx1, fx2 + real, dimension(bd%is-1:bd%ie+1,bd%js-1:bd%je+2):: fy, fy1, fy2 + real :: dt4 + integer :: i,j, is2, ie1 + integer iep1, jep1 + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: npx, npy + logical :: bounded_domain + + real, pointer, dimension(:,:,:) :: sin_sg, cos_sg + real, pointer, dimension(:,:) :: cosa_u, cosa_v + real, pointer, dimension(:,:) :: sina_u, sina_v + + real, pointer, dimension(:,:) :: dx, dy, dxc, dyc + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + npx = flagstruct%npx + npy = flagstruct%npy + bounded_domain = gridstruct%bounded_domain + + sin_sg => gridstruct%sin_sg + cos_sg => gridstruct%cos_sg + cosa_u => gridstruct%cosa_u + cosa_v => gridstruct%cosa_v + sina_u => gridstruct%sina_u + sina_v => gridstruct%sina_v + dx => gridstruct%dx + dy => gridstruct%dy + dxc => gridstruct%dxc + dyc => gridstruct%dyc + + sw_corner = gridstruct%sw_corner + se_corner = gridstruct%se_corner + nw_corner = gridstruct%nw_corner + ne_corner = gridstruct%ne_corner + + iep1 = ie+1; jep1 = je+1 + + call d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, bd, & + npx, npy, bounded_domain, flagstruct%grid_type) + + if( nord > 0 ) then + if (bounded_domain) then + call divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) + else + call divergence_corner(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) + endif + endif + + do j=js-1,jep1 + do i=is-1,iep1+1 + if (ut(i,j) > 0.) then + ut(i,j) = dt2*ut(i,j)*dy(i,j)*sin_sg(i-1,j,3) + else + ut(i,j) = dt2*ut(i,j)*dy(i,j)*sin_sg(i,j,1) + end if + enddo + enddo + do j=js-1,je+2 + do i=is-1,iep1 + if (vt(i,j) > 0.) then + vt(i,j) = dt2*vt(i,j)*dx(i,j)*sin_sg(i,j-1,4) + else + vt(i,j) = dt2*vt(i,j)*dx(i,j)*sin_sg(i,j, 2) + end if + enddo + enddo + +!---------------- +! Transport delp: +!---------------- +! Xdir: + if (flagstruct%grid_type < 3 .and. .not. bounded_domain) call fill2_4corners(delp, pt, 1, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + + if ( hydrostatic ) then +#ifdef SW_DYNAMICS + do j=js-1,jep1 + do i=is-1,ie+2 + if ( ut(i,j) > 0. ) then + fx1(i,j) = delp(i-1,j) + else + fx1(i,j) = delp(i,j) + endif + fx1(i,j) = ut(i,j)*fx1(i,j) + enddo + enddo +#else + do j=js-1,jep1 + do i=is-1,ie+2 + if ( ut(i,j) > 0. ) then + fx1(i,j) = delp(i-1,j) + fx(i,j) = pt(i-1,j) + else + fx1(i,j) = delp(i,j) + fx(i,j) = pt(i,j) + endif + fx1(i,j) = ut(i,j)*fx1(i,j) + fx(i,j) = fx1(i,j)* fx(i,j) + enddo + enddo +#endif + else + if (flagstruct%grid_type < 3) & + call fill_4corners(w, 1, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + do j=js-1,je+1 + do i=is-1,ie+2 + if ( ut(i,j) > 0. ) then + fx1(i,j) = delp(i-1,j) + fx(i,j) = pt(i-1,j) + fx2(i,j) = w(i-1,j) + else + fx1(i,j) = delp(i,j) + fx(i,j) = pt(i,j) + fx2(i,j) = w(i,j) + endif + fx1(i,j) = ut(i,j)*fx1(i,j) + fx(i,j) = fx1(i,j)* fx(i,j) + fx2(i,j) = fx1(i,j)*fx2(i,j) + enddo + enddo + endif + +! Ydir: + if (flagstruct%grid_type < 3 .and. .not. bounded_domain) call fill2_4corners(delp, pt, 2, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + if ( hydrostatic ) then + do j=js-1,jep1+1 + do i=is-1,iep1 + if ( vt(i,j) > 0. ) then + fy1(i,j) = delp(i,j-1) + fy(i,j) = pt(i,j-1) + else + fy1(i,j) = delp(i,j) + fy(i,j) = pt(i,j) + endif + fy1(i,j) = vt(i,j)*fy1(i,j) + fy(i,j) = fy1(i,j)* fy(i,j) + enddo + enddo + do j=js-1,jep1 + do i=is-1,iep1 + delpc(i,j) = delp(i,j) + (fx1(i,j)-fx1(i+1,j)+fy1(i,j)-fy1(i,j+1))*gridstruct%rarea(i,j) +#ifdef SW_DYNAMICS + ptc(i,j) = pt(i,j) +#else + ptc(i,j) = (pt(i,j)*delp(i,j) + & + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*gridstruct%rarea(i,j))/delpc(i,j) +#endif + enddo + enddo + else + if (flagstruct%grid_type < 3) call fill_4corners(w, 2, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + do j=js-1,je+2 + do i=is-1,ie+1 + if ( vt(i,j) > 0. ) then + fy1(i,j) = delp(i,j-1) + fy(i,j) = pt(i,j-1) + fy2(i,j) = w(i,j-1) + else + fy1(i,j) = delp(i,j) + fy(i,j) = pt(i,j) + fy2(i,j) = w(i,j) + endif + fy1(i,j) = vt(i,j)*fy1(i,j) + fy(i,j) = fy1(i,j)* fy(i,j) + fy2(i,j) = fy1(i,j)*fy2(i,j) + enddo + enddo + do j=js-1,je+1 + do i=is-1,ie+1 + delpc(i,j) = delp(i,j) + (fx1(i,j)-fx1(i+1,j)+fy1(i,j)-fy1(i,j+1))*gridstruct%rarea(i,j) + ptc(i,j) = (pt(i,j)*delp(i,j) + & + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*gridstruct%rarea(i,j))/delpc(i,j) + wc(i,j) = (w(i,j)*delp(i,j) + (fx2(i,j)-fx2(i+1,j) + & + fy2(i,j)-fy2(i,j+1))*gridstruct%rarea(i,j))/delpc(i,j) + enddo + enddo + endif + +!------------ +! Compute KE: +!------------ + +!Since uc = u*, i.e. the covariant wind perpendicular to the face edge, if we want to compute kinetic energy we will need the true coordinate-parallel covariant wind, computed through u = uc*sina + v*cosa. +!Use the alpha for the cell KE is being computed in. +!!! TO DO: +!!! Need separate versions for nesting/single-tile +!!! and for cubed-sphere + if (bounded_domain .or. flagstruct%grid_type >=3 ) then + do j=js-1,jep1 + do i=is-1,iep1 + if ( ua(i,j) > 0. ) then + ke(i,j) = uc(i,j) + else + ke(i,j) = uc(i+1,j) + endif + enddo + enddo + do j=js-1,jep1 + do i=is-1,iep1 + if ( va(i,j) > 0. ) then + vort(i,j) = vc(i,j) + else + vort(i,j) = vc(i,j+1) + endif + enddo + enddo + else + do j=js-1,jep1 + do i=is-1,iep1 + if ( ua(i,j) > 0. ) then + if ( i==1 ) then + ke(1,j) = uc(1, j)*sin_sg(1,j,1)+v(1,j)*cos_sg(1,j,1) + elseif ( i==npx ) then + ke(i,j) = uc(npx,j)*sin_sg(npx,j,1)+v(npx,j)*cos_sg(npx,j,1) + else + ke(i,j) = uc(i,j) + endif + else + if ( i==0 ) then + ke(0,j) = uc(1, j)*sin_sg(0,j,3)+v(1,j)*cos_sg(0,j,3) + elseif ( i==(npx-1) ) then + ke(i,j) = uc(npx,j)*sin_sg(npx-1,j,3)+v(npx,j)*cos_sg(npx-1,j,3) + else + ke(i,j) = uc(i+1,j) + endif + endif + enddo + enddo + do j=js-1,jep1 + do i=is-1,iep1 + if ( va(i,j) > 0. ) then + if ( j==1 ) then + vort(i,1) = vc(i, 1)*sin_sg(i,1,2)+u(i, 1)*cos_sg(i,1,2) + elseif ( j==npy ) then + vort(i,j) = vc(i,npy)*sin_sg(i,npy,2)+u(i,npy)*cos_sg(i,npy,2) + else + vort(i,j) = vc(i,j) + endif + else + if ( j==0 ) then + vort(i,0) = vc(i, 1)*sin_sg(i,0,4)+u(i, 1)*cos_sg(i,0,4) + elseif ( j==(npy-1) ) then + vort(i,j) = vc(i,npy)*sin_sg(i,npy-1,4)+u(i,npy)*cos_sg(i,npy-1,4) + else + vort(i,j) = vc(i,j+1) + endif + endif + enddo + enddo + endif + + dt4 = 0.5*dt2 + do j=js-1,jep1 + do i=is-1,iep1 + ke(i,j) = dt4*(ua(i,j)*ke(i,j) + va(i,j)*vort(i,j)) + enddo + enddo + +!------------------------------ +! Compute circulation on C grid +!------------------------------ +! To consider using true co-variant winds at face edges? + do j=js-1,je+1 + do i=is,ie+1 + fx(i,j) = uc(i,j) * dxc(i,j) + enddo + enddo + + do j=js,je+1 + do i=is-1,ie+1 + fy(i,j) = vc(i,j) * dyc(i,j) + enddo + enddo + + do j=js,je+1 + do i=is,ie+1 + vort(i,j) = fx(i,j-1) - fx(i,j) - fy(i-1,j) + fy(i,j) + enddo + enddo + +! Remove the extra term at the corners: + if ( sw_corner ) vort(1, 1) = vort(1, 1) + fy(0, 1) + if ( se_corner ) vort(npx ,1) = vort(npx, 1) - fy(npx, 1) + if ( ne_corner ) vort(npx,npy) = vort(npx,npy) - fy(npx,npy) + if ( nw_corner ) vort(1, npy) = vort(1, npy) + fy(0, npy) + +!---------------------------- +! Compute absolute vorticity +!---------------------------- + do j=js,je+1 + do i=is,ie+1 + vort(i,j) = gridstruct%fC(i,j) + gridstruct%rarea_c(i,j) * vort(i,j) + enddo + enddo + +!---------------------------------- +! Transport absolute vorticity: +!---------------------------------- +!To go from v to contravariant v at the edges, we divide by sin_sg; +! but we then must multiply by sin_sg to get the proper flux. +! These cancel, leaving us with fy1 = dt2*v at the edges. +! (For the same reason we only divide by sin instead of sin**2 in the interior) + +!! TO DO: separate versions for nesting/single-tile and cubed-sphere + if (bounded_domain .or. flagstruct%grid_type >= 3) then + do j=js,je + do i=is,iep1 + fy1(i,j) = dt2*(v(i,j)-uc(i,j)*cosa_u(i,j))/sina_u(i,j) + if ( fy1(i,j) > 0. ) then + fy(i,j) = vort(i,j) + else + fy(i,j) = vort(i,j+1) + endif + enddo + enddo + do j=js,jep1 + do i=is,ie + fx1(i,j) = dt2*(u(i,j)-vc(i,j)*cosa_v(i,j))/sina_v(i,j) + if ( fx1(i,j) > 0. ) then + fx(i,j) = vort(i,j) + else + fx(i,j) = vort(i+1,j) + endif + enddo + enddo + else + do j=js,je +!DEC$ VECTOR ALWAYS + do i=is,iep1 + if ( ( i==1 .or. i==npx ) ) then + fy1(i,j) = dt2*v(i,j) + else + fy1(i,j) = dt2*(v(i,j)-uc(i,j)*cosa_u(i,j))/sina_u(i,j) + endif + if ( fy1(i,j) > 0. ) then + fy(i,j) = vort(i,j) + else + fy(i,j) = vort(i,j+1) + endif + enddo + enddo + do j=js,jep1 + if ( ( j==1 .or. j==npy ) ) then +!DEC$ VECTOR ALWAYS + do i=is,ie + fx1(i,j) = dt2*u(i,j) + if ( fx1(i,j) > 0. ) then + fx(i,j) = vort(i,j) + else + fx(i,j) = vort(i+1,j) + endif + enddo + else +!DEC$ VECTOR ALWAYS + do i=is,ie + fx1(i,j) = dt2*(u(i,j)-vc(i,j)*cosa_v(i,j))/sina_v(i,j) + if ( fx1(i,j) > 0. ) then + fx(i,j) = vort(i,j) + else + fx(i,j) = vort(i+1,j) + endif + enddo + endif + enddo + endif + +! Update time-centered winds on the C-Grid + do j=js,je + do i=is,iep1 + uc(i,j) = uc(i,j) + fy1(i,j)*fy(i,j) + gridstruct%rdxc(i,j)*(ke(i-1,j)-ke(i,j)) + enddo + enddo + do j=js,jep1 + do i=is,ie + vc(i,j) = vc(i,j) - fx1(i,j)*fx(i,j) + gridstruct%rdyc(i,j)*(ke(i,j-1)-ke(i,j)) + enddo + enddo + + end subroutine c_sw + + + +! d_sw :: D-Grid Shallow Water Routine + +!>@brief The subroutine 'd_sw' peforms a full-timestep advance of the D-grid winds +!! and other prognostic varaiables. + subroutine d_sw(delpc, delp, ptc, pt, u, v, w, uc,vc, & + ua, va, divg_d, xflux, yflux, cx, cy, & + crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source,diss_est, & + zvir, sphum, nq, q, k, km, inline_q, & + dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, & + nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, & + damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd) + + integer, intent(IN):: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp + integer, intent(IN):: nord !< nord=1 divergence damping; (del-4) or 3 (del-8) + integer, intent(IN):: nord_v !< vorticity damping + integer, intent(IN):: nord_w !< vertical velocity + integer, intent(IN):: nord_t !< pt + integer, intent(IN):: sphum, nq, k, km + real , intent(IN):: dt, dddmp, d2_bg, d4_bg, d_con + real , intent(IN):: zvir + real, intent(in):: damp_v, damp_w, damp_t, kgb + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(inout):: divg_d(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) !< divergence + real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed):: z_rat + real, intent(INOUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed):: delp, pt, ua, va + real, intent(INOUT), dimension(bd%isd: , bd%jsd: ):: w, q_con + real, intent(INOUT), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed+1):: u, vc + real, intent(INOUT), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: v, uc + real, intent(INOUT):: q(bd%isd:bd%ied,bd%jsd:bd%jed,km,nq) + real, intent(OUT), dimension(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc, ptc + real, intent(OUT), dimension(bd%is:bd%ie,bd%js:bd%je):: heat_source + real, intent(OUT), dimension(bd%is:bd%ie,bd%js:bd%je):: diss_est +! The flux capacitors: + real, intent(INOUT):: xflux(bd%is:bd%ie+1,bd%js:bd%je ) + real, intent(INOUT):: yflux(bd%is:bd%ie ,bd%js:bd%je+1) +!------------------------ + real, intent(INOUT):: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ) + real, intent(INOUT):: cy(bd%isd:bd%ied,bd%js:bd%je+1) + logical, intent(IN):: hydrostatic + logical, intent(IN):: inline_q + real, intent(OUT), dimension(bd%is:bd%ie+1,bd%jsd:bd%jed):: crx_adv, xfx_adv + real, intent(OUT), dimension(bd%isd:bd%ied,bd%js:bd%je+1):: cry_adv, yfx_adv + type(fv_grid_type), intent(IN), target :: gridstruct + type(fv_flags_type), intent(IN), target :: flagstruct +! Local: + logical:: sw_corner, se_corner, ne_corner, nw_corner + real :: ut(bd%isd:bd%ied+1,bd%jsd:bd%jed) + real :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1) +!--- + real :: fx2(bd%isd:bd%ied+1,bd%jsd:bd%jed) + real :: fy2(bd%isd:bd%ied, bd%jsd:bd%jed+1) + real :: dw(bd%is:bd%ie,bd%js:bd%je) !< work array +!--- + real, dimension(bd%is:bd%ie+1,bd%js:bd%je+1):: ub, vb + real :: wk(bd%isd:bd%ied,bd%jsd:bd%jed) !< work array + real :: ke(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) !< needed for corner_comm + real :: vort(bd%isd:bd%ied,bd%jsd:bd%jed) !< Vorticity + real :: fx(bd%is:bd%ie+1,bd%js:bd%je ) !< 1-D X-direction Fluxes + real :: fy(bd%is:bd%ie ,bd%js:bd%je+1) !< 1-D Y-direction Fluxes + real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) + real :: ra_y(bd%isd:bd%ied,bd%js:bd%je) + real :: gx(bd%is:bd%ie+1,bd%js:bd%je ) + real :: gy(bd%is:bd%ie ,bd%js:bd%je+1) !< work Y-dir flux array + logical :: fill_c + + real :: dt2, dt4, dt5, dt6 + real :: damp, damp2, damp4, dd8, u2, v2, du2, dv2 + real :: u_lon + integer :: i,j, is2, ie1, js2, je1, n, nt, n2, iq + + real, pointer, dimension(:,:) :: area, area_c, rarea + + real, pointer, dimension(:,:,:) :: sin_sg + real, pointer, dimension(:,:) :: cosa_u, cosa_v, cosa_s + real, pointer, dimension(:,:) :: sina_u, sina_v + real, pointer, dimension(:,:) :: rsin_u, rsin_v, rsina + real, pointer, dimension(:,:) :: f0, rsin2, divg_u, divg_v + + real, pointer, dimension(:,:) :: cosa, dx, dy, dxc, dyc, rdxa, rdya, rdx, rdy + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: npx, npy, ng + logical :: bounded_domain + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + ng = bd%ng + + npx = flagstruct%npx + npy = flagstruct%npy + bounded_domain = gridstruct%bounded_domain + + area => gridstruct%area + rarea => gridstruct%rarea + sin_sg => gridstruct%sin_sg + cosa_u => gridstruct%cosa_u + cosa_v => gridstruct%cosa_v + cosa_s => gridstruct%cosa_s + sina_u => gridstruct%sina_u + sina_v => gridstruct%sina_v + rsin_u => gridstruct%rsin_u + rsin_v => gridstruct%rsin_v + rsina => gridstruct%rsina + f0 => gridstruct%f0 + rsin2 => gridstruct%rsin2 + divg_u => gridstruct%divg_u + divg_v => gridstruct%divg_v + cosa => gridstruct%cosa + dx => gridstruct%dx + dy => gridstruct%dy + dxc => gridstruct%dxc + dyc => gridstruct%dyc + rdxa => gridstruct%rdxa + rdya => gridstruct%rdya + rdx => gridstruct%rdx + rdy => gridstruct%rdy + + sw_corner = gridstruct%sw_corner + se_corner = gridstruct%se_corner + nw_corner = gridstruct%nw_corner + ne_corner = gridstruct%ne_corner + +#ifdef SW_DYNAMICS + if ( test_case == 1 ) then + do j=jsd,jed + do i=is,ie+1 + xfx_adv(i,j) = dt * uc(i,j) / sina_u(i,j) + if (xfx_adv(i,j) > 0.) then + crx_adv(i,j) = xfx_adv(i,j) * rdxa(i-1,j) + else + crx_adv(i,j) = xfx_adv(i,j) * rdxa(i,j) + endif + xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sina_u(i,j) + enddo + enddo + + do j=js,je+1 + do i=isd,ied + yfx_adv(i,j) = dt * vc(i,j) / sina_v(i,j) + if (yfx_adv(i,j) > 0.) then + cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j-1) + else + cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j) + endif + yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sina_v(i,j) + enddo + enddo + else +#endif + if ( flagstruct%grid_type < 3 ) then + +!!! TO DO: separate versions for nesting and for cubed-sphere + if (bounded_domain) then + do j=jsd,jed + do i=is-1,ie+2 + ut(i,j) = ( uc(i,j) - 0.25 * cosa_u(i,j) * & + (vc(i-1,j)+vc(i,j)+vc(i-1,j+1)+vc(i,j+1)))*rsin_u(i,j) + enddo + enddo + do j=js-1,je+2 + do i=isd,ied + vt(i,j) = ( vc(i,j) - 0.25 * cosa_v(i,j) * & + (uc(i,j-1)+uc(i+1,j-1)+uc(i,j)+uc(i+1,j)))*rsin_v(i,j) + enddo + enddo + else + do j=jsd,jed + if( j/=0 .and. j/=1 .and. j/=(npy-1) .and. j/=npy) then + do i=is-1,ie+2 + ut(i,j) = ( uc(i,j) - 0.25 * cosa_u(i,j) * & + (vc(i-1,j)+vc(i,j)+vc(i-1,j+1)+vc(i,j+1)))*rsin_u(i,j) + enddo + endif + enddo + do j=js-1,je+2 + + if( j/=1 .and. j/=npy ) then + + do i=isd,ied + vt(i,j) = ( vc(i,j) - 0.25 * cosa_v(i,j) * & + (uc(i,j-1)+uc(i+1,j-1)+uc(i,j)+uc(i+1,j)))*rsin_v(i,j) + enddo + endif + enddo + endif + + if (.not. bounded_domain) then +! West edge: + if ( is==1 ) then + do j=jsd,jed + if ( uc(1,j)*dt > 0. ) then + ut(1,j) = uc(1,j) / sin_sg(0,j,3) + else + ut(1,j) = uc(1,j) / sin_sg(1,j,1) + endif + enddo + do j=max(3,js), min(npy-2,je+1) + vt(0,j) = vc(0,j) - 0.25*cosa_v(0,j)* & + (ut(0,j-1)+ut(1,j-1)+ut(0,j)+ut(1,j)) + vt(1,j) = vc(1,j) - 0.25*cosa_v(1,j)* & + (ut(1,j-1)+ut(2,j-1)+ut(1,j)+ut(2,j)) + enddo + endif ! West face + +! East edge: + if ( (ie+1)==npx ) then + do j=jsd,jed + if ( uc(npx,j)*dt > 0. ) then + ut(npx,j) = uc(npx,j) / sin_sg(npx-1,j,3) + else + ut(npx,j) = uc(npx,j) / sin_sg(npx,j,1) + endif + enddo + + do j=max(3,js), min(npy-2,je+1) + vt(npx-1,j) = vc(npx-1,j) - 0.25*cosa_v(npx-1,j)* & + (ut(npx-1,j-1)+ut(npx,j-1)+ut(npx-1,j)+ut(npx,j)) + vt(npx,j) = vc(npx,j) - 0.25*cosa_v(npx,j)* & + (ut(npx,j-1)+ut(npx+1,j-1)+ut(npx,j)+ut(npx+1,j)) + enddo + endif + +! South (Bottom) edge: + if ( js==1 ) then + + do i=isd,ied + if ( vc(i,1)*dt > 0. ) then + vt(i,1) = vc(i,1) / sin_sg(i,0,4) + else + vt(i,1) = vc(i,1) / sin_sg(i,1,2) + endif + enddo + + do i=max(3,is),min(npx-2,ie+1) + ut(i,0) = uc(i,0) - 0.25*cosa_u(i,0)* & + (vt(i-1,0)+vt(i,0)+vt(i-1,1)+vt(i,1)) + ut(i,1) = uc(i,1) - 0.25*cosa_u(i,1)* & + (vt(i-1,1)+vt(i,1)+vt(i-1,2)+vt(i,2)) + enddo + endif + +! North edge: + if ( (je+1)==npy ) then + do i=isd,ied + if ( vc(i,npy)*dt > 0. ) then + vt(i,npy) = vc(i,npy) / sin_sg(i,npy-1,4) + else + vt(i,npy) = vc(i,npy) / sin_sg(i,npy,2) + endif + enddo + do i=max(3,is),min(npx-2,ie+1) + ut(i,npy-1) = uc(i,npy-1) - 0.25*cosa_u(i,npy-1)* & + (vt(i-1,npy-1)+vt(i,npy-1)+vt(i-1,npy)+vt(i,npy)) + ut(i,npy) = uc(i,npy) - 0.25*cosa_u(i,npy)* & + (vt(i-1,npy)+vt(i,npy)+vt(i-1,npy+1)+vt(i,npy+1)) + enddo + endif + +! The following code solves a 2x2 system to get the interior parallel-to-edge uc,vc values +! near the corners (ex: for the sw corner ut(2,1) and vt(1,2) are solved for simultaneously). +! It then computes the halo uc, vc values so as to be consistent with the computations on +! the facing panel. + + !The system solved is: + ! ut(2,1) = uc(2,1) - avg(vt)*cosa_u(2,1) + ! vt(1,2) = vc(1,2) - avg(ut)*cosa_v(1,2) + ! in which avg(vt) includes vt(1,2) and avg(ut) includes ut(2,1) + + if( sw_corner ) then + damp = 1. / (1.-0.0625*cosa_u(2,0)*cosa_v(1,0)) + ut(2,0) = (uc(2,0)-0.25*cosa_u(2,0)*(vt(1,1)+vt(2,1)+vt(2,0) +vc(1,0) - & + 0.25*cosa_v(1,0)*(ut(1,0)+ut(1,-1)+ut(2,-1))) ) * damp + damp = 1. / (1.-0.0625*cosa_u(0,1)*cosa_v(0,2)) + vt(0,2) = (vc(0,2)-0.25*cosa_v(0,2)*(ut(1,1)+ut(1,2)+ut(0,2)+uc(0,1) - & + 0.25*cosa_u(0,1)*(vt(0,1)+vt(-1,1)+vt(-1,2))) ) * damp + + damp = 1. / (1.-0.0625*cosa_u(2,1)*cosa_v(1,2)) + ut(2,1) = (uc(2,1)-0.25*cosa_u(2,1)*(vt(1,1)+vt(2,1)+vt(2,2)+vc(1,2) - & + 0.25*cosa_v(1,2)*(ut(1,1)+ut(1,2)+ut(2,2))) ) * damp + + vt(1,2) = (vc(1,2)-0.25*cosa_v(1,2)*(ut(1,1)+ut(1,2)+ut(2,2)+uc(2,1) - & + 0.25*cosa_u(2,1)*(vt(1,1)+vt(2,1)+vt(2,2))) ) * damp + endif + + if( se_corner ) then + damp = 1. / (1. - 0.0625*cosa_u(npx-1,0)*cosa_v(npx-1,0)) + ut(npx-1,0) = ( uc(npx-1,0)-0.25*cosa_u(npx-1,0)*( & + vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,0)+vc(npx-1,0) - & + 0.25*cosa_v(npx-1,0)*(ut(npx,0)+ut(npx,-1)+ut(npx-1,-1))) ) * damp + damp = 1. / (1. - 0.0625*cosa_u(npx+1,1)*cosa_v(npx,2)) + vt(npx, 2) = ( vc(npx,2)-0.25*cosa_v(npx,2)*( & + ut(npx,1)+ut(npx,2)+ut(npx+1,2)+uc(npx+1,1) - & + 0.25*cosa_u(npx+1,1)*(vt(npx,1)+vt(npx+1,1)+vt(npx+1,2))) ) * damp + + damp = 1. / (1. - 0.0625*cosa_u(npx-1,1)*cosa_v(npx-1,2)) + ut(npx-1,1) = ( uc(npx-1,1)-0.25*cosa_u(npx-1,1)*( & + vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,2)+vc(npx-1,2) - & + 0.25*cosa_v(npx-1,2)*(ut(npx,1)+ut(npx,2)+ut(npx-1,2))) ) * damp + vt(npx-1,2) = ( vc(npx-1,2)-0.25*cosa_v(npx-1,2)*( & + ut(npx,1)+ut(npx,2)+ut(npx-1,2)+uc(npx-1,1) - & + 0.25*cosa_u(npx-1,1)*(vt(npx-1,1)+vt(npx-2,1)+vt(npx-2,2))) ) * damp + endif + + if( ne_corner ) then + damp = 1. / (1. - 0.0625*cosa_u(npx-1,npy)*cosa_v(npx-1,npy+1)) + ut(npx-1,npy) = ( uc(npx-1,npy)-0.25*cosa_u(npx-1,npy)*( & + vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy+1)+vc(npx-1,npy+1) - & + 0.25*cosa_v(npx-1,npy+1)*(ut(npx,npy)+ut(npx,npy+1)+ut(npx-1,npy+1))) ) * damp + damp = 1. / (1. - 0.0625*cosa_u(npx+1,npy-1)*cosa_v(npx,npy-1)) + vt(npx, npy-1) = ( vc(npx,npy-1)-0.25*cosa_v(npx,npy-1)*( & + ut(npx,npy-1)+ut(npx,npy-2)+ut(npx+1,npy-2)+uc(npx+1,npy-1) - & + 0.25*cosa_u(npx+1,npy-1)*(vt(npx,npy)+vt(npx+1,npy)+vt(npx+1,npy-1))) ) * damp + + damp = 1. / (1. - 0.0625*cosa_u(npx-1,npy-1)*cosa_v(npx-1,npy-1)) + ut(npx-1,npy-1) = ( uc(npx-1,npy-1)-0.25*cosa_u(npx-1,npy-1)*( & + vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy-1)+vc(npx-1,npy-1) - & + 0.25*cosa_v(npx-1,npy-1)*(ut(npx,npy-1)+ut(npx,npy-2)+ut(npx-1,npy-2))) ) * damp + vt(npx-1,npy-1) = ( vc(npx-1,npy-1)-0.25*cosa_v(npx-1,npy-1)*( & + ut(npx,npy-1)+ut(npx,npy-2)+ut(npx-1,npy-2)+uc(npx-1,npy-1) - & + 0.25*cosa_u(npx-1,npy-1)*(vt(npx-1,npy)+vt(npx-2,npy)+vt(npx-2,npy-1))) ) * damp + endif + + if( nw_corner ) then + damp = 1. / (1. - 0.0625*cosa_u(2,npy)*cosa_v(1,npy+1)) + ut(2,npy) = ( uc(2,npy)-0.25*cosa_u(2,npy)*( & + vt(1,npy)+vt(2,npy)+vt(2,npy+1)+vc(1,npy+1) - & + 0.25*cosa_v(1,npy+1)*(ut(1,npy)+ut(1,npy+1)+ut(2,npy+1))) ) * damp + damp = 1. / (1. - 0.0625*cosa_u(0,npy-1)*cosa_v(0,npy-1)) + vt(0,npy-1) = ( vc(0,npy-1)-0.25*cosa_v(0,npy-1)*( & + ut(1,npy-1)+ut(1,npy-2)+ut(0,npy-2)+uc(0,npy-1) - & + 0.25*cosa_u(0,npy-1)*(vt(0,npy)+vt(-1,npy)+vt(-1,npy-1))) ) * damp + + damp = 1. / (1. - 0.0625*cosa_u(2,npy-1)*cosa_v(1,npy-1)) + ut(2,npy-1) = ( uc(2,npy-1)-0.25*cosa_u(2,npy-1)*( & + vt(1,npy)+vt(2,npy)+vt(2,npy-1)+vc(1,npy-1) - & + 0.25*cosa_v(1,npy-1)*(ut(1,npy-1)+ut(1,npy-2)+ut(2,npy-2))) ) * damp + + vt(1,npy-1) = ( vc(1,npy-1)-0.25*cosa_v(1,npy-1)*( & + ut(1,npy-1)+ut(1,npy-2)+ut(2,npy-2)+uc(2,npy-1) - & + 0.25*cosa_u(2,npy-1)*(vt(1,npy)+vt(2,npy)+vt(2,npy-1))) ) * damp + endif + + end if !.not. bounded_domain + + else +! flagstruct%grid_type >= 3 + do j=jsd,jed + do i=is,ie+1 + ut(i,j) = uc(i,j) + enddo + enddo + + do j=js,je+1 + do i=isd,ied + vt(i,j) = vc(i,j) + enddo + enddo + endif ! end grid_type choices + + do j=jsd,jed + do i=is,ie+1 + xfx_adv(i,j) = dt*ut(i,j) + enddo + enddo + + do j=js,je+1 + do i=isd,ied + yfx_adv(i,j) = dt*vt(i,j) + enddo + enddo + +! Explanation of the following code: +! xfx_adv = dt*ut*dy +! crx_adv = dt*ut/dx + + do j=jsd,jed +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if ( xfx_adv(i,j) > 0. ) then + crx_adv(i,j) = xfx_adv(i,j) * rdxa(i-1,j) + xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sin_sg(i-1,j,3) + else + crx_adv(i,j) = xfx_adv(i,j) * rdxa(i,j) + xfx_adv(i,j) = dy(i,j)*xfx_adv(i,j)*sin_sg(i,j,1) + end if + enddo + enddo + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=isd,ied + if ( yfx_adv(i,j) > 0. ) then + cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j-1) + yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sin_sg(i,j-1,4) + else + cry_adv(i,j) = yfx_adv(i,j) * rdya(i,j) + yfx_adv(i,j) = dx(i,j)*yfx_adv(i,j)*sin_sg(i,j,2) + endif + enddo + enddo + +#ifdef SW_DYNAMICS + endif +#endif + + do j=jsd,jed + do i=is,ie + ra_x(i,j) = area(i,j) + xfx_adv(i,j) - xfx_adv(i+1,j) + enddo + enddo + do j=js,je + do i=isd,ied + ra_y(i,j) = area(i,j) + yfx_adv(i,j) - yfx_adv(i,j+1) + enddo + enddo + + + call fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, fy, & + xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & + nord=nord_v, damp_c=damp_v) + +! <<< Save the mass fluxes to the "Flux Capacitor" for tracer transport >>> + do j=jsd,jed + do i=is,ie+1 + cx(i,j) = cx(i,j) + crx_adv(i,j) + enddo + enddo + do j=js,je + do i=is,ie+1 + xflux(i,j) = xflux(i,j) + fx(i,j) + enddo + enddo + do j=js,je+1 + do i=isd,ied + cy(i,j) = cy(i,j) + cry_adv(i,j) + enddo + do i=is,ie + yflux(i,j) = yflux(i,j) + fy(i,j) + enddo + enddo + +#ifndef SW_DYNAMICS + do j=js,je + do i=is,ie + heat_source(i,j) = 0. + diss_est(i,j) = 0. + enddo + enddo + + if ( .not. hydrostatic ) then + if ( damp_w>1.E-5 ) then + dd8 = kgb*abs(dt) + damp4 = (damp_w*gridstruct%da_min_c)**(nord_w+1) + call del6_vt_flux(nord_w, npx, npy, damp4, w, wk, fx2, fy2, gridstruct, bd) + do j=js,je + do i=is,ie + dw(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*rarea(i,j) +! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw +! heat_source(i,j) = -d_con*dw(i,j)*(w(i,j)+0.5*dw(i,j)) + heat_source(i,j) = dd8 - dw(i,j)*(w(i,j)+0.5*dw(i,j)) + diss_est(i,j) = heat_source(i,j) + enddo + enddo + endif + call fv_tp_2d(w, crx_adv,cry_adv, npx, npy, hord_vt, gx, gy, xfx_adv, yfx_adv, & + gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & + mfx=fx, mfy=fy) + do j=js,je + do i=is,ie + w(i,j) = delp(i,j)*w(i,j) + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) + enddo + enddo + endif + +#ifdef USE_COND + call fv_tp_2d(q_con, crx_adv,cry_adv, npx, npy, hord_dp, gx, gy, & + xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac,& + mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t) + do j=js,je + do i=is,ie + q_con(i,j) = delp(i,j)*q_con(i,j) + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) + enddo + enddo +#endif + +! if ( inline_q .and. zvir>0.01 ) then +! do j=jsd,jed +! do i=isd,ied +! pt(i,j) = pt(i,j)/(1.+zvir*q(i,j,k,sphum)) +! enddo +! enddo +! endif + call fv_tp_2d(pt, crx_adv,cry_adv, npx, npy, hord_tm, gx, gy, & + xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & + mfx=fx, mfy=fy, mass=delp, nord=nord_v, damp_c=damp_v) +! mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t) +#endif + + if ( inline_q ) then + do j=js,je + do i=is,ie + wk(i,j) = delp(i,j) + delp(i,j) = wk(i,j) + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) +#ifdef SW_DYNAMICS + ptc(i,j) = pt(i,j) +#else + pt(i,j) = (pt(i,j)*wk(i,j) + & + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j))/delp(i,j) +#endif + enddo + enddo + do iq=1,nq + call fv_tp_2d(q(isd,jsd,k,iq), crx_adv,cry_adv, npx, npy, hord_tr, gx, gy, & + xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac, & + mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t) + do j=js,je + do i=is,ie + q(i,j,k,iq) = (q(i,j,k,iq)*wk(i,j) + & + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j))/delp(i,j) + enddo + enddo + enddo +! if ( zvir>0.01 ) then +! do j=js,je +! do i=is,ie +! pt(i,j) = pt(i,j)*(1.+zvir*q(i,j,k,sphum)) +! enddo +! enddo +! endif + + else + do j=js,je + do i=is,ie +#ifndef SW_DYNAMICS + pt(i,j) = pt(i,j)*delp(i,j) + & + (gx(i,j)-gx(i+1,j)+gy(i,j)-gy(i,j+1))*rarea(i,j) +#endif + delp(i,j) = delp(i,j) + & + (fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))*rarea(i,j) +#ifndef SW_DYNAMICS + pt(i,j) = pt(i,j) / delp(i,j) + +#endif + enddo + enddo + endif + +#ifdef SW_DYNAMICS + if (test_case > 1) then +#endif + +!---------------------- +! Kinetic Energy Fluxes +!---------------------- +! Compute B grid contra-variant components for KE: + + dt5 = 0.5 *dt + dt4 = 0.25*dt + + if (bounded_domain) then + is2 = is; ie1 = ie+1 + js2 = js; je1 = je+1 + else + is2 = max(2,is); ie1 = min(npx-1,ie+1) + js2 = max(2,js); je1 = min(npy-1,je+1) + end if + + if (flagstruct%grid_type < 3) then + + if (bounded_domain) then + do j=js2,je1 + do i=is2,ie1 + vb(i,j) = dt5*(vc(i-1,j)+vc(i,j)-(uc(i,j-1)+uc(i,j))*cosa(i,j))*rsina(i,j) + enddo + enddo + else + if ( js==1 ) then + do i=is,ie+1 + vb(i,1) = dt5*(vt(i-1,1)+vt(i,1)) ! corner values are incorrect + enddo + endif + + do j=js2,je1 + do i=is2,ie1 + vb(i,j) = dt5*(vc(i-1,j)+vc(i,j)-(uc(i,j-1)+uc(i,j))*cosa(i,j))*rsina(i,j) + enddo + + if ( is==1 ) then + ! 2-pt extrapolation from both sides: + vb(1,j) = dt4*(-vt(-1,j) + 3.*(vt(0,j)+vt(1,j)) - vt(2,j)) + endif + if ( (ie+1)==npx ) then + ! 2-pt extrapolation from both sides: + vb(npx,j) = dt4*(-vt(npx-2,j) + 3.*(vt(npx-1,j)+vt(npx,j)) - vt(npx+1,j)) + endif + enddo + + if ( (je+1)==npy ) then + do i=is,ie+1 + vb(i,npy) = dt5*(vt(i-1,npy)+vt(i,npy)) ! corner values are incorrect + enddo + endif + endif + + else + do j=js,je+1 + do i=is,ie+1 + vb(i,j) = dt5*(vc(i-1,j)+vc(i,j)) + enddo + enddo + endif + + call ytp_v(is,ie,js,je,isd,ied,jsd,jed, vb, u, v, ub, hord_mt, gridstruct%dy, gridstruct%rdy, & + npx, npy, flagstruct%grid_type, flagstruct%lim_fac, bounded_domain) + + do j=js,je+1 + do i=is,ie+1 + ke(i,j) = vb(i,j)*ub(i,j) + enddo + enddo + + if (flagstruct%grid_type < 3) then + + if (bounded_domain) then + + do j=js,je+1 + + do i=is2,ie1 + ub(i,j) = dt5*(uc(i,j-1)+uc(i,j)-(vc(i-1,j)+vc(i,j))*cosa(i,j))*rsina(i,j) + enddo + + enddo + + + else + if ( is==1 ) then + do j=js,je+1 + ub(1,j) = dt5*(ut(1,j-1)+ut(1,j)) ! corner values are incorrect + enddo + endif + + do j=js,je+1 + if ( (j==1 .or. j==npy) ) then + do i=is2,ie1 + ! 2-pt extrapolation from both sides: + ub(i,j) = dt4*(-ut(i,j-2) + 3.*(ut(i,j-1)+ut(i,j)) - ut(i,j+1)) + enddo + else + do i=is2,ie1 + ub(i,j) = dt5*(uc(i,j-1)+uc(i,j)-(vc(i-1,j)+vc(i,j))*cosa(i,j))*rsina(i,j) + enddo + endif + enddo + + if ( (ie+1)==npx ) then + do j=js,je+1 + ub(npx,j) = dt5*(ut(npx,j-1)+ut(npx,j)) ! corner values are incorrect + enddo + endif + endif + + else + do j=js,je+1 + do i=is,ie+1 + ub(i,j) = dt5*(uc(i,j-1)+uc(i,j)) + enddo + enddo + endif + + call xtp_u(is,ie,js,je, isd,ied,jsd,jed, ub, u, v, vb, hord_mt, gridstruct%dx, gridstruct%rdx, & + npx, npy, flagstruct%grid_type, flagstruct%lim_fac, bounded_domain) + + do j=js,je+1 + do i=is,ie+1 + ke(i,j) = 0.5*(ke(i,j) + ub(i,j)*vb(i,j)) + enddo + enddo + +!----------------------------------------- +! Fix KE at the 4 corners of the face: +!----------------------------------------- + if (.not. bounded_domain) then + dt6 = dt / 6. + if ( sw_corner ) then + ke(1,1) = dt6*( (ut(1,1) + ut(1,0)) * u(1,1) + & + (vt(1,1) + vt(0,1)) * v(1,1) + & + (ut(1,1) + vt(1,1)) * u(0,1) ) + endif + if ( se_corner ) then + i = npx + ke(i,1) = dt6*( (ut(i,1) + ut(i, 0)) * u(i-1,1) + & + (vt(i,1) + vt(i-1,1)) * v(i, 1) + & + (ut(i,1) - vt(i-1,1)) * u(i, 1) ) + endif + if ( ne_corner ) then + i = npx; j = npy + ke(i,j) = dt6*( (ut(i,j ) + ut(i,j-1)) * u(i-1,j) + & + (vt(i,j ) + vt(i-1,j)) * v(i,j-1) + & + (ut(i,j-1) + vt(i-1,j)) * u(i,j ) ) + endif + if ( nw_corner ) then + j = npy + ke(1,j) = dt6*( (ut(1, j) + ut(1,j-1)) * u(1,j ) + & + (vt(1, j) + vt(0, j)) * v(1,j-1) + & + (ut(1,j-1) - vt(1, j)) * u(0,j ) ) + endif + end if + +! Compute vorticity: + do j=jsd,jed+1 + do i=isd,ied + vt(i,j) = u(i,j)*dx(i,j) + enddo + enddo + do j=jsd,jed + do i=isd,ied+1 + ut(i,j) = v(i,j)*dy(i,j) + enddo + enddo + +! wk is "volume-mean" relative vorticity + do j=jsd,jed + do i=isd,ied + wk(i,j) = rarea(i,j)*(vt(i,j)-vt(i,j+1)-ut(i,j)+ut(i+1,j)) + enddo + enddo + + if ( .not. hydrostatic ) then + if( flagstruct%do_f3d ) then +#ifdef ROT3 + dt2 = 2.*dt + do j=js,je + do i=is,ie + w(i,j) = w(i,j)/delp(i,j) + dt2*gridstruct%w00(i,j) * & + ( gridstruct%a11(i,j)*(u(i,j)+u(i,j+1)) + & + gridstruct%a12(i,j)*(v(i,j)+v(i+1,j)) ) + enddo + enddo +#endif + else + do j=js,je + do i=is,ie + w(i,j) = w(i,j)/delp(i,j) + enddo + enddo + endif + if ( damp_w>1.E-5 ) then + do j=js,je + do i=is,ie + w(i,j) = w(i,j) + dw(i,j) + enddo + enddo + endif + + endif +#ifdef USE_COND + do j=js,je + do i=is,ie + q_con(i,j) = q_con(i,j)/delp(i,j) + enddo + enddo +#endif + +!----------------------------- +! Compute divergence damping +!----------------------------- +! damp = dddmp * da_min_c + + if ( nord==0 ) then +! area ~ dxb*dyb*sin(alpha) + + if (bounded_domain) then + + do j=js,je+1 + do i=is-1,ie+1 + ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) & + *dyc(i,j)*sina_v(i,j) + enddo + enddo + + do j=js-1,je+1 + do i=is2,ie1 + vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) & + *dxc(i,j)*sina_u(i,j) + enddo + enddo + + else + do j=js,je+1 + + if ( (j==1 .or. j==npy) ) then + do i=is-1,ie+1 + if (vc(i,j) > 0) then + ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j-1,4) + else + ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j,2) + end if + enddo + else + do i=is-1,ie+1 + ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) & + *dyc(i,j)*sina_v(i,j) + enddo + endif + enddo + + do j=js-1,je+1 + do i=is2,ie1 + vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) & + *dxc(i,j)*sina_u(i,j) + enddo + if ( is == 1 ) then + if (uc(1,j) > 0) then + vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0,j,3) + else + vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1,j,1) + end if + end if + if ( (ie+1)==npx ) then + if (uc(npx,j) > 0) then + vort(npx,j) = v(npx,j)*dxc(npx,j)* & + sin_sg(npx-1,j,3) + else + vort(npx,j) = v(npx,j)*dxc(npx,j)* & + sin_sg(npx,j,1) + end if + end if + enddo + endif + + do j=js,je+1 + do i=is,ie+1 + delpc(i,j) = vort(i,j-1) - vort(i,j) + ptc(i-1,j) - ptc(i,j) + enddo + enddo + +! Remove the extra term at the corners: + if (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0) + if (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0) + if (ne_corner) delpc(npx,npy) = delpc(npx,npy) + vort(npx,npy) + if (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy) + + do j=js,je+1 + do i=is,ie+1 + delpc(i,j) = gridstruct%rarea_c(i,j)*delpc(i,j) + damp = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*abs(delpc(i,j)*dt))) + vort(i,j) = damp*delpc(i,j) + ke(i,j) = ke(i,j) + vort(i,j) + enddo + enddo + else +!-------------------------- +! Higher order divg damping +!-------------------------- + do j=js,je+1 + do i=is,ie+1 +! Save divergence for external mode filter + delpc(i,j) = divg_d(i,j) + enddo + enddo + + n2 = nord + 1 ! N > 1 + do n=1,nord + nt = nord-n + + fill_c = (nt/=0) .and. (flagstruct%grid_type<3) .and. & + ( sw_corner .or. se_corner .or. ne_corner .or. nw_corner ) & + .and. .not. bounded_domain + + if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=XDir, BGRID=.true.) + do j=js-nt,je+1+nt + do i=is-1-nt,ie+1+nt + vc(i,j) = (divg_d(i+1,j)-divg_d(i,j))*divg_u(i,j) + enddo + enddo + + if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=YDir, BGRID=.true.) + do j=js-1-nt,je+1+nt + do i=is-nt,ie+1+nt + uc(i,j) = (divg_d(i,j+1)-divg_d(i,j))*divg_v(i,j) + enddo + enddo + + if ( fill_c ) call fill_corners(vc, uc, npx, npy, VECTOR=.true., DGRID=.true.) + do j=js-nt,je+1+nt + do i=is-nt,ie+1+nt + divg_d(i,j) = uc(i,j-1) - uc(i,j) + vc(i-1,j) - vc(i,j) + enddo + enddo + +! Remove the extra term at the corners: + if (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0) + if (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0) + if (ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + uc(npx,npy) + if (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy) + + if ( .not. gridstruct%stretched_grid ) then + do j=js-nt,je+1+nt + do i=is-nt,ie+1+nt + divg_d(i,j) = divg_d(i,j)*gridstruct%rarea_c(i,j) + enddo + enddo + endif + + enddo ! n-loop + + if ( dddmp<1.E-5) then + vort(:,:) = 0. + else + if ( flagstruct%grid_type < 3 ) then +! Interpolate relative vort to cell corners + call a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng, .false.) + do j=js,je+1 + do i=is,ie+1 +! The following is an approxi form of Smagorinsky diffusion + vort(i,j) = abs(dt)*sqrt(delpc(i,j)**2 + vort(i,j)**2) + enddo + enddo + else ! Correct form: works only for doubly preiodic domain + call smag_corner(abs(dt), u, v, ua, va, vort, bd, npx, npy, gridstruct, ng) + endif + endif + + if (gridstruct%stretched_grid ) then +! Stretched grid with variable damping ~ area + dd8 = gridstruct%da_min * d4_bg**n2 + else + dd8 = ( gridstruct%da_min_c*d4_bg )**n2 + endif + + do j=js,je+1 + do i=is,ie+1 + damp2 = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*vort(i,j))) ! del-2 + vort(i,j) = damp2*delpc(i,j) + dd8*divg_d(i,j) + ke(i,j) = ke(i,j) + vort(i,j) + enddo + enddo + + endif + + if ( d_con > 1.e-5 ) then + do j=js,je+1 + do i=is,ie + ub(i,j) = vort(i,j) - vort(i+1,j) + enddo + enddo + do j=js,je + do i=is,ie+1 + vb(i,j) = vort(i,j) - vort(i,j+1) + enddo + enddo + endif + +! Vorticity transport + if ( hydrostatic ) then + do j=jsd,jed + do i=isd,ied + vort(i,j) = wk(i,j) + f0(i,j) + enddo + enddo + else + if ( flagstruct%do_f3d ) then + do j=jsd,jed + do i=isd,ied + vort(i,j) = wk(i,j) + f0(i,j)*z_rat(i,j) + enddo + enddo + else + do j=jsd,jed + do i=isd,ied + vort(i,j) = wk(i,j) + f0(i,j) + enddo + enddo + endif + endif + + call fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, fy, & + xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, flagstruct%lim_fac) + do j=js,je+1 + do i=is,ie + u(i,j) = vt(i,j) + ke(i,j) - ke(i+1,j) + fy(i,j) + enddo + enddo + do j=js,je + do i=is,ie+1 + v(i,j) = ut(i,j) + ke(i,j) - ke(i,j+1) - fx(i,j) + enddo + enddo + +!-------------------------------------------------------- +! damping applied to relative vorticity (wk): + if ( damp_v>1.E-5 ) then + damp4 = (damp_v*gridstruct%da_min_c)**(nord_v+1) + call del6_vt_flux(nord_v, npx, npy, damp4, wk, vort, ut, vt, gridstruct, bd) + endif + + if ( d_con > 1.e-5 .or. flagstruct%do_skeb ) then + do j=js,je+1 + do i=is,ie + ub(i,j) = (ub(i,j) + vt(i,j))*rdx(i,j) + fy(i,j) = u(i,j)*rdx(i,j) + gy(i,j) = fy(i,j)*ub(i,j) + enddo + enddo + do j=js,je + do i=is,ie+1 + vb(i,j) = (vb(i,j) - ut(i,j))*rdy(i,j) + fx(i,j) = v(i,j)*rdy(i,j) + gx(i,j) = fx(i,j)*vb(i,j) + enddo + enddo +!---------------------------------- +! Heating due to damping: +!---------------------------------- + damp = 0.25*d_con + do j=js,je + do i=is,ie + u2 = fy(i,j) + fy(i,j+1) + du2 = ub(i,j) + ub(i,j+1) + v2 = fx(i,j) + fx(i+1,j) + dv2 = vb(i,j) + vb(i+1,j) +! Total energy conserving: +! Convert lost KE due to divergence damping to "heat" + heat_source(i,j) = delp(i,j)*(heat_source(i,j) - damp*rsin2(i,j)*( & + (ub(i,j)**2 + ub(i,j+1)**2 + vb(i,j)**2 + vb(i+1,j)**2) & + + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j)) & + - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)) ) + if (flagstruct%do_skeb) then + diss_est(i,j) = diss_est(i,j)-rsin2(i,j)*( & + (ub(i,j)**2 + ub(i,j+1)**2 + vb(i,j)**2 + vb(i+1,j)**2) & + + 2.*(gy(i,j)+gy(i,j+1)+gx(i,j)+gx(i+1,j)) & + - cosa_s(i,j)*(u2*dv2 + v2*du2 + du2*dv2)) + endif + enddo + enddo + endif + +! Add diffusive fluxes to the momentum equation: + if ( damp_v>1.E-5 ) then + do j=js,je+1 + do i=is,ie + u(i,j) = u(i,j) + vt(i,j) + enddo + enddo + do j=js,je + do i=is,ie+1 + v(i,j) = v(i,j) - ut(i,j) + enddo + enddo + endif + +#ifdef SW_DYNAMICS + endif ! test_case +#endif + + end subroutine d_sw + +!>@brief The subroutine 'del6_vt_flux' applies 2nd, 4th, or 6th-order damping +!! to fluxes ("vorticity damping") + subroutine del6_vt_flux(nord, npx, npy, damp, q, d2, fx2, fy2, gridstruct, bd) +! Del-nord damping for the relative vorticity +! nord must be <= 2 +!------------------ +! nord = 0: del-2 +! nord = 1: del-4 +! nord = 2: del-6 +!------------------ + integer, intent(in):: nord, npx, npy + real, intent(in):: damp + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(inout):: q(bd%isd:bd%ied, bd%jsd:bd%jed) ! rel. vorticity ghosted on input + type(fv_grid_type), intent(IN), target :: gridstruct +! Work arrays: + real, intent(out):: d2(bd%isd:bd%ied, bd%jsd:bd%jed) + real, intent(out):: fx2(bd%isd:bd%ied+1,bd%jsd:bd%jed), fy2(bd%isd:bd%ied,bd%jsd:bd%jed+1) + integer i,j, nt, n, i1, i2, j1, j2 + + logical :: bounded_domain + +#ifdef USE_SG + real, pointer, dimension(:,:,:) :: sin_sg + real, pointer, dimension(:,:) :: rdxc, rdyc, dx,dy +#endif + + integer :: is, ie, js, je + +#ifdef USE_SG + sin_sg => gridstruct%sin_sg + rdxc => gridstruct%rdxc + rdyc => gridstruct%rdyc + dx => gridstruct%dx + dy => gridstruct%dy +#endif + bounded_domain = gridstruct%bounded_domain + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + + i1 = is-1-nord; i2 = ie+1+nord + j1 = js-1-nord; j2 = je+1+nord + + do j=j1, j2 + do i=i1, i2 + d2(i,j) = damp*q(i,j) + enddo + enddo + + if( nord>0 .and. .not. bounded_domain) call copy_corners(d2, npx, npy, 1, bounded_domain, bd, gridstruct%sw_corner, & + gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + do j=js-nord,je+nord + do i=is-nord,ie+nord+1 +#ifdef USE_SG + fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i-1,j)-d2(i,j))*rdxc(i,j) +#else + fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i-1,j)-d2(i,j)) +#endif + enddo + enddo + + if( nord>0 .and. .not. bounded_domain) call copy_corners(d2, npx, npy, 2, bounded_domain, bd, gridstruct%sw_corner, & + gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + do j=js-nord,je+nord+1 + do i=is-nord,ie+nord +#ifdef USE_SG + fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j-1)-d2(i,j))*rdyc(i,j) +#else + fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j-1)-d2(i,j)) +#endif + enddo + enddo + + if ( nord>0 ) then + do n=1, nord + nt = nord-n + do j=js-nt-1,je+nt+1 + do i=is-nt-1,ie+nt+1 + d2(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*gridstruct%rarea(i,j) + enddo + enddo + + if (.not. bounded_domain) call copy_corners(d2, npx, npy, 1, bounded_domain, bd, gridstruct%sw_corner, & + gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + + do j=js-nt,je+nt + do i=is-nt,ie+nt+1 +#ifdef USE_SG + fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i,j)-d2(i-1,j))*rdxc(i,j) +#else + fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i,j)-d2(i-1,j)) +#endif + enddo + enddo + + if (.not. bounded_domain) call copy_corners(d2, npx, npy, 2, bounded_domain, bd, & + gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + + do j=js-nt,je+nt+1 + do i=is-nt,ie+nt +#ifdef USE_SG + fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j)-d2(i,j-1))*rdyc(i,j) +#else + fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j)-d2(i,j-1)) +#endif + enddo + enddo + enddo + endif + + end subroutine del6_vt_flux + +!>@brief The subroutine 'divergence_corner' computes the cell-mean divergence on the +!! "dual grid", the native-grid positioning of the divergence. + subroutine divergence_corner(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(in), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1):: u + real, intent(in), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: v + real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: ua, va + real, intent(out), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed+1):: divg_d + type(fv_grid_type), intent(IN), target :: gridstruct + type(fv_flags_type), intent(IN), target :: flagstruct +! local + real uf(bd%is-2:bd%ie+2,bd%js-1:bd%je+2) + real vf(bd%is-1:bd%ie+2,bd%js-2:bd%je+2) + integer i,j + integer is2, ie1 + + real, pointer, dimension(:,:,:) :: sin_sg, cos_sg + real, pointer, dimension(:,:) :: dxc,dyc + + integer :: is, ie, js, je + integer :: npx, npy + logical :: bounded_domain + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + + npx = flagstruct%npx + npy = flagstruct%npy + bounded_domain = gridstruct%bounded_domain + + sin_sg => gridstruct%sin_sg + cos_sg => gridstruct%cos_sg + dxc => gridstruct%dxc + dyc => gridstruct%dyc + + if (bounded_domain) then + is2 = is; ie1 = ie+1 + else + is2 = max(2,is); ie1 = min(npx-1,ie+1) + end if + + if (flagstruct%grid_type==4) then + do j=js-1,je+2 + do i=is-2,ie+2 + uf(i,j) = u(i,j)*dyc(i,j) + enddo + enddo + do j=js-2,je+2 + do i=is-1,ie+2 + vf(i,j) = v(i,j)*dxc(i,j) + enddo + enddo + do j=js-1,je+2 + do i=is-1,ie+2 + divg_d(i,j) = gridstruct%rarea_c(i,j)*(vf(i,j-1)-vf(i,j)+uf(i-1,j)-uf(i,j)) + enddo + enddo + else +! 9---4---8 +! | | +! 1 5 3 +! | | +! 6---2---7 + do j=js,je+1 + if ( j==1 .or. j==npy ) then + do i=is-1,ie+1 + uf(i,j) = u(i,j)*dyc(i,j)*0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2)) + enddo + else + do i=is-1,ie+1 + uf(i,j) = (u(i,j)-0.25*(va(i,j-1)+va(i,j))*(cos_sg(i,j-1,4)+cos_sg(i,j,2))) & + * dyc(i,j)*0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2)) + enddo + endif + enddo + + do j=js-1,je+1 + do i=is2,ie1 + vf(i,j) = (v(i,j) - 0.25*(ua(i-1,j)+ua(i,j))*(cos_sg(i-1,j,3)+cos_sg(i,j,1))) & + *dxc(i,j)*0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1)) + enddo + if ( is == 1 ) vf(1, j) = v(1, j)*dxc(1, j)*0.5*(sin_sg(0,j,3)+sin_sg(1,j,1)) + if ( (ie+1)==npx ) vf(npx,j) = v(npx,j)*dxc(npx,j)*0.5*(sin_sg(npx-1,j,3)+sin_sg(npx,j,1)) + enddo + + do j=js,je+1 + do i=is,ie+1 + divg_d(i,j) = vf(i,j-1) - vf(i,j) + uf(i-1,j) - uf(i,j) + enddo + enddo + +! Remove the extra term at the corners: + if (gridstruct%sw_corner) divg_d(1, 1) = divg_d(1, 1) - vf(1, 0) + if (gridstruct%se_corner) divg_d(npx, 1) = divg_d(npx, 1) - vf(npx, 0) + if (gridstruct%ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + vf(npx,npy) + if (gridstruct%nw_corner) divg_d(1, npy) = divg_d(1, npy) + vf(1, npy) + + do j=js,je+1 + do i=is,ie+1 + divg_d(i,j) = gridstruct%rarea_c(i,j)*divg_d(i,j) + enddo + enddo + + endif + + end subroutine divergence_corner + + subroutine divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, flagstruct, bd) + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(in), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1):: u + real, intent(in), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed):: v + real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: ua, va + real, intent(out), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed+1):: divg_d + type(fv_grid_type), intent(IN), target :: gridstruct + type(fv_flags_type), intent(IN), target :: flagstruct + +! local + real uf(bd%isd:bd%ied,bd%jsd:bd%jed+1) + real vf(bd%isd:bd%ied+1,bd%jsd:bd%jed) + integer i,j + + + real, pointer, dimension(:,:) :: rarea_c + + real, pointer, dimension(:,:,:) :: sin_sg, cos_sg + real, pointer, dimension(:,:) :: cosa_u, cosa_v + real, pointer, dimension(:,:) :: sina_u, sina_v + real, pointer, dimension(:,:) :: dxc,dyc + + integer :: isd, ied, jsd, jed + integer :: npx, npy + + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + npx = flagstruct%npx + npy = flagstruct%npy + + rarea_c => gridstruct%rarea_c + sin_sg => gridstruct%sin_sg + cos_sg => gridstruct%cos_sg + cosa_u => gridstruct%cosa_u + cosa_v => gridstruct%cosa_v + sina_u => gridstruct%sina_u + sina_v => gridstruct%sina_v + dxc => gridstruct%dxc + dyc => gridstruct%dyc + + divg_d = 1.e25 + + if (flagstruct%grid_type==4) then + do j=jsd,jed + do i=isd,ied + uf(i,j) = u(i,j)*dyc(i,j) + enddo + enddo + do j=jsd,jed + do i=isd,ied + vf(i,j) = v(i,j)*dxc(i,j) + enddo + enddo + do j=jsd+1,jed + do i=isd+1,ied + divg_d(i,j) = rarea_c(i,j)*(vf(i,j-1)-vf(i,j)+uf(i-1,j)-uf(i,j)) + enddo + enddo + else + + do j=jsd+1,jed + do i=isd,ied + uf(i,j) = (u(i,j)-0.25*(va(i,j-1)+va(i,j))*(cos_sg(i,j-1,4)+cos_sg(i,j,2))) & + * dyc(i,j)*0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2)) + enddo + enddo + + do j=jsd,jed + do i=isd+1,ied + vf(i,j) = (v(i,j) - 0.25*(ua(i-1,j)+ua(i,j))*(cos_sg(i-1,j,3)+cos_sg(i,j,1))) & + *dxc(i,j)*0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1)) + enddo + enddo + + do j=jsd+1,jed + do i=isd+1,ied + divg_d(i,j) = (vf(i,j-1) - vf(i,j) + uf(i-1,j) - uf(i,j))*rarea_c(i,j) + enddo + enddo + +!!$ !Edges +!!$ +!!$ !West, East +!!$ do j=jsd+1,jed +!!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j) +!!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j) +!!$ end do +!!$ +!!$ !North, South +!!$ do i=isd+1,ied +!!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd) +!!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed) +!!$ end do +!!$ +!!$ !Corners (just use next corner value) +!!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1) +!!$ divg_d(isd,jed+1) = divg_d(isd+1,jed) +!!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1) +!!$ divg_d(ied+1,jed+1) = divg_d(ied,jed) + + endif + + +end subroutine divergence_corner_nest + +!>@brief The subroutine 'smag_corner' computes Smagorinsky damping. + subroutine smag_corner(dt, u, v, ua, va, smag_c, bd, npx, npy, gridstruct, ng) + !> Compute the Tension_Shear strain at cell corners for Smagorinsky diffusion + !! work only if (grid_type==4) + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(in):: dt + integer, intent(IN) :: npx, npy, ng + real, intent(in), dimension(bd%isd:bd%ied, bd%jsd:bd%jed+1):: u + real, intent(in), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: v + real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: ua, va + real, intent(out), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: smag_c + type(fv_grid_type), intent(IN), target :: gridstruct +! local + real:: ut(bd%isd:bd%ied+1,bd%jsd:bd%jed) + real:: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1) + real:: wk(bd%isd:bd%ied,bd%jsd:bd%jed) !< work array + real:: sh(bd%isd:bd%ied,bd%jsd:bd%jed) + integer i,j + integer is2, ie1 + + real, pointer, dimension(:,:) :: dxc, dyc, dx, dy, rarea, rarea_c + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + dxc => gridstruct%dxc + dyc => gridstruct%dyc + dx => gridstruct%dx + dy => gridstruct%dy + rarea => gridstruct%rarea + rarea_c => gridstruct%rarea_c + + is2 = max(2,is); ie1 = min(npx-1,ie+1) + +! Smag = sqrt [ T**2 + S**2 ]: unit = 1/s +! where T = du/dx - dv/dy; S = du/dy + dv/dx +! Compute tension strain at corners: + do j=js,je+1 + do i=is-1,ie+1 + ut(i,j) = u(i,j)*dyc(i,j) + enddo + enddo + do j=js-1,je+1 + do i=is,ie+1 + vt(i,j) = v(i,j)*dxc(i,j) + enddo + enddo + do j=js,je+1 + do i=is,ie+1 + smag_c(i,j) = rarea_c(i,j)*(vt(i,j-1)-vt(i,j)-ut(i-1,j)+ut(i,j)) + enddo + enddo +! Fix the corners?? if grid_type /= 4 + +! Compute shear strain: + do j=jsd,jed+1 + do i=isd,ied + vt(i,j) = u(i,j)*dx(i,j) + enddo + enddo + do j=jsd,jed + do i=isd,ied+1 + ut(i,j) = v(i,j)*dy(i,j) + enddo + enddo + + do j=jsd,jed + do i=isd,ied + wk(i,j) = rarea(i,j)*(vt(i,j)-vt(i,j+1)+ut(i,j)-ut(i+1,j)) + enddo + enddo + call a2b_ord4(wk, sh, gridstruct, npx, npy, is, ie, js, je, ng, .false.) + do j=js,je+1 + do i=is,ie+1 + smag_c(i,j) = dt*sqrt( sh(i,j)**2 + smag_c(i,j)**2 ) + enddo + enddo + + end subroutine smag_corner + + + subroutine xtp_u(is,ie,js,je,isd,ied,jsd,jed,c, u, v, flux, iord, dx, rdx, npx, npy, grid_type, lim_fac,bounded_domain) + + integer, intent(in):: is,ie,js,je, isd,ied,jsd,jed + real, INTENT(IN):: u(isd:ied,jsd:jed+1) + real, INTENT(IN):: v(isd:ied+1,jsd:jed) + real, INTENT(IN):: c(is:ie+1,js:je+1) + real, INTENT(out):: flux(is:ie+1,js:je+1) + real, INTENT(IN) :: dx(isd:ied, jsd:jed+1) + real, INTENT(IN) :: rdx(isd:ied, jsd:jed+1) + integer, INTENT(IN) :: iord, npx, npy, grid_type + logical, INTENT(IN) :: bounded_domain + real, INTENT(IN) :: lim_fac +! Local + real, dimension(is-1:ie+1):: bl, br, b0 + logical, dimension(is-1:ie+1):: smt5, smt6 + logical, dimension(is:ie+1):: hi5, hi6 + real:: fx0(is:ie+1) + real al(is-1:ie+2), dm(is-2:ie+2) + real dq(is-3:ie+2) + real dl, dr, xt, pmp, lac, cfl + real pmp_1, lac_1, pmp_2, lac_2 + real x0, x1, x0L, x0R + integer i, j + integer is3, ie3 + integer is2, ie2 + + if ( bounded_domain .or. grid_type>3 ) then + is3 = is-1 ; ie3 = ie+1 + else + is3 = max(3,is-1) ; ie3 = min(npx-3,ie+1) + end if + + + if ( iord < 8 ) then +! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 + + do j=js,je+1 + + do i=is3,ie3+1 + al(i) = p1*(u(i-1,j)+u(i,j)) + p2*(u(i-2,j)+u(i+1,j)) + enddo + do i=is3,ie3 + bl(i) = al(i ) - u(i,j) + br(i) = al(i+1) - u(i,j) + enddo + + if ( (.not.bounded_domain) .and. grid_type < 3) then + if ( is==1 ) then + xt = c3*u(1,j) + c2*u(2,j) + c1*u(3,j) + br(1) = xt - u(1,j) + bl(2) = xt - u(2,j) + br(2) = al(3) - u(2,j) + if( j==1 .or. j==npy ) then + bl(0) = 0. ! out + br(0) = 0. ! edge + bl(1) = 0. ! edge + br(1) = 0. ! in + else + bl(0) = c1*u(-2,j) + c2*u(-1,j) + c3*u(0,j) - u(0,j) + xt = 0.5*( ((2.*dx(0,j)+dx(-1,j))*(u(0,j))-dx(0,j)*u(-1,j))/(dx(0,j)+dx(-1,j)) & + + ((2.*dx(1,j)+dx( 2,j))*(u(1,j))-dx(1,j)*u( 2,j))/(dx(1,j)+dx( 2,j)) ) + br(0) = xt - u(0,j) + bl(1) = xt - u(1,j) + endif +! call pert_ppm(1, u(2,j), bl(2), br(2), -1) + endif + if ( (ie+1)==npx ) then + bl(npx-2) = al(npx-2) - u(npx-2,j) + xt = c1*u(npx-3,j) + c2*u(npx-2,j) + c3*u(npx-1,j) + br(npx-2) = xt - u(npx-2,j) + bl(npx-1) = xt - u(npx-1,j) + if( j==1 .or. j==npy ) then + bl(npx-1) = 0. ! in + br(npx-1) = 0. ! edge + bl(npx ) = 0. ! edge + br(npx ) = 0. ! out + else + xt = 0.5*( ( (2.*dx(npx-1,j)+dx(npx-2,j))*u(npx-1,j)-dx(npx-1,j)*u(npx-2,j))/(dx(npx-1,j)+dx(npx-2,j)) & + + ( (2.*dx(npx ,j)+dx(npx+1,j))*u(npx ,j)-dx(npx ,j)*u(npx+1,j))/(dx(npx ,j)+dx(npx+1,j)) ) + br(npx-1) = xt - u(npx-1,j) + bl(npx ) = xt - u(npx ,j) + br(npx) = c3*u(npx,j) + c2*u(npx+1,j) + c1*u(npx+2,j) - u(npx,j) + endif +! call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1) + endif + endif + + do i=is-1,ie+1 + b0(i) = bl(i) + br(i) + enddo + + if ( iord==1 ) then + + do i=is-1, ie+1 + smt5(i) = abs(lim_fac*b0(i)) < abs(bl(i)-br(i)) + enddo +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdx(i-1,j) + fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1)) + flux(i,j) = u(i-1,j) + else + cfl = c(i,j)*rdx(i,j) + fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i)) + flux(i,j) = u(i,j) + endif + if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx0(i) + enddo + + elseif ( iord==2 ) then ! Perfectly linear + +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdx(i-1,j) + flux(i,j) = u(i-1,j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1)) + else + cfl = c(i,j)*rdx(i,j) + flux(i,j) = u(i,j) + (1.+cfl)*(bl(i)+cfl*b0(i)) + endif + enddo + + elseif ( iord==3 ) then + + do i=is-1, ie+1 + x0 = abs(b0(i)) + x1 = abs(bl(i)-br(i)) + smt5(i) = x0 < x1 + smt6(i) = 3.*x0 < x1 + enddo + do i=is, ie+1 + fx0(i) = 0. + hi5(i) = smt5(i-1) .and. smt5(i) + hi6(i) = smt6(i-1) .or. smt6(i) + enddo + do i=is, ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdx(i-1,j) + if ( hi6(i) ) then + fx0(i) = br(i-1) - cfl*b0(i-1) + elseif( hi5(i) ) then + fx0(i) = sign(min(abs(bl(i-1)),abs(br(i-1))), br(i-1)) + endif + flux(i,j) = u(i-1,j) + (1.-cfl)*fx0(i) + else + cfl = c(i,j)*rdx(i,j) + if ( hi6(i) ) then + fx0(i) = bl(i) + cfl*b0(i) + elseif( hi5(i) ) then + fx0(i) = sign(min(abs(bl(i)),abs(br(i))), bl(i)) + endif + flux(i,j) = u(i,j) + (1.+cfl)*fx0(i) + endif + enddo + + elseif ( iord==4 ) then + + do i=is-1, ie+1 + x0 = abs(b0(i)) + x1 = abs(bl(i)-br(i)) + smt5(i) = x0 < x1 + smt6(i) = 3.*x0 < x1 + enddo + do i=is, ie+1 + hi5(i) = smt5(i-1) .and. smt5(i) + hi6(i) = smt6(i-1) .or. smt6(i) + hi5(i) = hi5(i) .or. hi6(i) + enddo +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdx(i-1,j) + fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1)) + flux(i,j) = u(i-1,j) + else + cfl = c(i,j)*rdx(i,j) + fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i)) + flux(i,j) = u(i,j) + endif + if ( hi5(i) ) flux(i,j) = flux(i,j) + fx0(i) + + enddo + + else ! iord=5,6,7 + + if ( iord==5 ) then + do i=is-1, ie+1 + smt5(i) = bl(i)*br(i) < 0. + enddo + else + do i=is-1, ie+1 + smt5(i) = 3.*abs(b0(i)) < abs(bl(i)-br(i)) + enddo + endif + +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdx(i-1,j) + fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1)) + flux(i,j) = u(i-1,j) + else + cfl = c(i,j)*rdx(i,j) + fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i)) + flux(i,j) = u(i,j) + endif + if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx0(i) + enddo + + endif + enddo + + else + ! iord = 8, 9, 10, 11 + + do j=js,je+1 + do i=is-2,ie+2 + xt = 0.25*(u(i+1,j) - u(i-1,j)) + dm(i) = sign(min(abs(xt), max(u(i-1,j), u(i,j), u(i+1,j)) - u(i,j), & + u(i,j) - min(u(i-1,j), u(i,j), u(i+1,j))), xt) + enddo + do i=is-3,ie+2 + dq(i) = u(i+1,j) - u(i,j) + enddo + + if (grid_type < 3) then + + do i=is3,ie3+1 + al(i) = 0.5*(u(i-1,j)+u(i,j)) + r3*(dm(i-1) - dm(i)) + enddo + +! Perturbation form: + if( iord==8 ) then + do i=is3,ie3 + xt = 2.*dm(i) + bl(i) = -sign(min(abs(xt), abs(al(i )-u(i,j))), xt) + br(i) = sign(min(abs(xt), abs(al(i+1)-u(i,j))), xt) + enddo + elseif( iord==9 ) then + do i=is3,ie3 + pmp_1 = -2.*dq(i) + lac_1 = pmp_1 + 1.5*dq(i+1) + bl(i) = min(max(0., pmp_1, lac_1), max(al(i )-u(i,j), min(0., pmp_1, lac_1))) + pmp_2 = 2.*dq(i-1) + lac_2 = pmp_2 - 1.5*dq(i-2) + br(i) = min(max(0., pmp_2, lac_2), max(al(i+1)-u(i,j), min(0., pmp_2, lac_2))) + enddo + elseif( iord==10 ) then + do i=is3,ie3 + bl(i) = al(i ) - u(i,j) + br(i) = al(i+1) - u(i,j) +! if ( abs(dm(i-1))+abs(dm(i))+abs(dm(i+1)) < near_zero ) then + if ( abs(dm(i)) < near_zero ) then + if ( abs(dm(i-1))+abs(dm(i+1)) < near_zero ) then +! 2-delta-x structure detected within 3 cells + bl(i) = 0. + br(i) = 0. + endif + elseif( abs(3.*(bl(i)+br(i))) > abs(bl(i)-br(i)) ) then + pmp_1 = -2.*dq(i) + lac_1 = pmp_1 + 1.5*dq(i+1) + bl(i) = min(max(0., pmp_1, lac_1), max(bl(i), min(0., pmp_1, lac_1))) + pmp_2 = 2.*dq(i-1) + lac_2 = pmp_2 - 1.5*dq(i-2) + br(i) = min(max(0., pmp_2, lac_2), max(br(i), min(0., pmp_2, lac_2))) + endif + enddo + else +! un-limited: 11 + do i=is3,ie3 + bl(i) = al(i ) - u(i,j) + br(i) = al(i+1) - u(i,j) + enddo + endif + +!-------------- +! fix the edges +!-------------- +!!! TO DO: separate versions for bounded_domain and for cubed-sphere + if ( is==1 .and. .not. bounded_domain) then + br(2) = al(3) - u(2,j) + xt = s15*u(1,j) + s11*u(2,j) - s14*dm(2) + bl(2) = xt - u(2,j) + br(1) = xt - u(1,j) + if( j==1 .or. j==npy ) then + bl(0) = 0. ! out + br(0) = 0. ! edge + bl(1) = 0. ! edge + br(1) = 0. ! in + else + bl(0) = s14*dm(-1) - s11*dq(-1) + x0L = 0.5*((2.*dx(0,j)+dx(-1,j))*(u(0,j)) & + - dx(0,j)*(u(-1,j)))/(dx(0,j)+dx(-1,j)) + x0R = 0.5*((2.*dx(1,j)+dx(2,j))*(u(1,j)) & + - dx(1,j)*(u(2,j)))/(dx(1,j)+dx(2,j)) + xt = x0L + x0R + br(0) = xt - u(0,j) + bl(1) = xt - u(1,j) + endif + call pert_ppm(1, u(2,j), bl(2), br(2), -1) + endif + + if ( (ie+1)==npx .and. .not. bounded_domain) then + bl(npx-2) = al(npx-2) - u(npx-2,j) + xt = s15*u(npx-1,j) + s11*u(npx-2,j) + s14*dm(npx-2) + br(npx-2) = xt - u(npx-2,j) + bl(npx-1) = xt - u(npx-1,j) + if( j==1 .or. j==npy ) then + bl(npx-1) = 0. ! in + br(npx-1) = 0. ! edge + bl(npx ) = 0. ! edge + br(npx ) = 0. ! out + else + br(npx) = s11*dq(npx) - s14*dm(npx+1) + x0L = 0.5*( (2.*dx(npx-1,j)+dx(npx-2,j))*(u(npx-1,j)) & + - dx(npx-1,j)*(u(npx-2,j)))/(dx(npx-1,j)+dx(npx-2,j)) + x0R = 0.5*( (2.*dx(npx,j)+dx(npx+1,j))*(u(npx,j)) & + - dx(npx,j)*(u(npx+1,j)))/(dx(npx,j)+dx(npx+1,j)) + xt = x0L + x0R + br(npx-1) = xt - u(npx-1,j) + bl(npx ) = xt - u(npx ,j) + endif + call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1) + endif + + else +! Other grids: + do i=is-1,ie+2 + al(i) = 0.5*(u(i-1,j)+u(i,j)) + r3*(dm(i-1) - dm(i)) + enddo + + do i=is-1,ie+1 + pmp = -2.*dq(i) + lac = pmp + 1.5*dq(i+1) + bl(i) = min(max(0., pmp, lac), max(al(i )-u(i,j), min(0.,pmp, lac))) + pmp = 2.*dq(i-1) + lac = pmp - 1.5*dq(i-2) + br(i) = min(max(0., pmp, lac), max(al(i+1)-u(i,j), min(0.,pmp, lac))) + enddo + endif + + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdx(i-1,j) + flux(i,j) = u(i-1,j) + (1.-cfl)*(br(i-1)-cfl*(bl(i-1)+br(i-1))) + else + cfl = c(i,j)*rdx(i,j) + flux(i,j) = u(i, j) + (1.+cfl)*(bl(i )+cfl*(bl(i )+br(i ))) + endif + enddo + enddo + + endif + + end subroutine xtp_u + + + subroutine ytp_v(is,ie,js,je,isd,ied,jsd,jed, c, u, v, flux, jord, dy, rdy, npx, npy, grid_type, lim_fac, bounded_domain) + integer, intent(in):: is,ie,js,je, isd,ied,jsd,jed + integer, intent(IN):: jord + real, INTENT(IN) :: u(isd:ied,jsd:jed+1) + real, INTENT(IN) :: v(isd:ied+1,jsd:jed) + real, INTENT(IN) :: c(is:ie+1,js:je+1) !< Courant N (like FLUX) + real, INTENT(OUT):: flux(is:ie+1,js:je+1) + real, INTENT(IN) :: dy(isd:ied+1,jsd:jed) + real, INTENT(IN) :: rdy(isd:ied+1,jsd:jed) + integer, INTENT(IN) :: npx, npy, grid_type + logical, INTENT(IN) :: bounded_domain + real, INTENT(IN) :: lim_fac +! Local: + logical, dimension(is:ie+1,js-1:je+1):: smt5, smt6 + logical, dimension(is:ie+1):: hi5, hi6 + real:: fx0(is:ie+1) + real dm(is:ie+1,js-2:je+2) + real al(is:ie+1,js-1:je+2) + real, dimension(is:ie+1,js-1:je+1):: bl, br, b0 + real dq(is:ie+1,js-3:je+2) + real xt, dl, dr, pmp, lac, cfl + real pmp_1, lac_1, pmp_2, lac_2 + real x0, x1, x0R, x0L + integer i, j, is1, ie1, js3, je3 + + if ( bounded_domain .or. grid_type>3 ) then + js3 = js-1; je3 = je+1 + else + js3 = max(3,js-1); je3 = min(npy-3,je+1) + end if + + if ( jord<8 ) then +! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 + + do j=js3,je3+1 + do i=is,ie+1 + al(i,j) = p1*(v(i,j-1)+v(i,j)) + p2*(v(i,j-2)+v(i,j+1)) + enddo + enddo + do j=js3,je3 + do i=is,ie+1 + bl(i,j) = al(i,j ) - v(i,j) + br(i,j) = al(i,j+1) - v(i,j) + enddo + enddo + + if ( (.not.bounded_domain) .and. grid_type < 3) then + if( js==1 ) then + do i=is,ie+1 + bl(i,0) = c1*v(i,-2) + c2*v(i,-1) + c3*v(i,0) - v(i,0) + xt = 0.5*( ((2.*dy(i,0)+dy(i,-1))*v(i,0)-dy(i,0)*v(i,-1))/(dy(i,0)+dy(i,-1)) & + + ((2.*dy(i,1)+dy(i, 2))*v(i,1)-dy(i,1)*v(i, 2))/(dy(i,1)+dy(i, 2)) ) + br(i,0) = xt - v(i,0) + bl(i,1) = xt - v(i,1) + xt = c3*v(i,1) + c2*v(i,2) + c1*v(i,3) + br(i,1) = xt - v(i,1) + bl(i,2) = xt - v(i,2) + br(i,2) = al(i,3) - v(i,2) + enddo + if ( is==1 ) then + bl(1,0) = 0. ! out + br(1,0) = 0. ! edge + bl(1,1) = 0. ! edge + br(1,1) = 0. ! in + endif + if ( (ie+1)==npx ) then + bl(npx,0) = 0. ! out + br(npx,0) = 0. ! edge + bl(npx,1) = 0. ! edge + br(npx,1) = 0. ! in + endif +! j=2 +! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) + endif + if( (je+1)==npy ) then + do i=is,ie+1 + bl(i,npy-2) = al(i,npy-2) - v(i,npy-2) + xt = c1*v(i,npy-3) + c2*v(i,npy-2) + c3*v(i,npy-1) + br(i,npy-2) = xt - v(i,npy-2) + bl(i,npy-1) = xt - v(i,npy-1) + xt = 0.5*( ((2.*dy(i,npy-1)+dy(i,npy-2))*v(i,npy-1)-dy(i,npy-1)*v(i,npy-2))/(dy(i,npy-1)+dy(i,npy-2)) & + + ((2.*dy(i,npy )+dy(i,npy+1))*v(i,npy )-dy(i,npy )*v(i,npy+1))/(dy(i,npy )+dy(i,npy+1)) ) + br(i,npy-1) = xt - v(i,npy-1) + bl(i,npy ) = xt - v(i,npy) + br(i,npy) = c3*v(i,npy)+ c2*v(i,npy+1) + c1*v(i,npy+2) - v(i,npy) + enddo + if ( is==1 ) then + bl(1,npy-1) = 0. ! in + br(1,npy-1) = 0. ! edge + bl(1,npy ) = 0. ! edge + br(1,npy ) = 0. ! out + endif + if ( (ie+1)==npx ) then + bl(npx,npy-1) = 0. ! in + br(npx,npy-1) = 0. ! edge + bl(npx,npy ) = 0. ! edge + br(npx,npy ) = 0. ! out + endif +! j=npy-2 +! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) + endif + endif + + do j=js-1,je+1 + do i=is,ie+1 + b0(i,j) = bl(i,j) + br(i,j) + enddo + enddo + + + if ( jord==1 ) then ! Perfectly linear + + do j=js-1,je+1 + do i=is,ie+1 + smt5(i,j) = abs(lim_fac*b0(i,j)) < abs(bl(i,j)-br(i,j)) + enddo + enddo + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdy(i,j-1) + fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) + flux(i,j) = v(i,j-1) + else + cfl = c(i,j)*rdy(i,j) + fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) + flux(i,j) = v(i,j) + endif + if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx0(i) + enddo + enddo + + elseif ( jord==2 ) then ! Perfectly linear + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdy(i,j-1) + flux(i,j) = v(i,j-1) + (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) + else + cfl = c(i,j)*rdy(i,j) + flux(i,j) = v(i,j) + (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) + endif + enddo + enddo + + elseif ( jord==3 ) then + + do j=js-1,je+1 + do i=is,ie+1 + x0 = abs(b0(i,j)) + x1 = abs(bl(i,j)-br(i,j)) + smt5(i,j) = x0 < x1 + smt6(i,j) = 3.*x0 < x1 + enddo + enddo + do j=js,je+1 + do i=is,ie+1 + fx0(i) = 0. + hi5(i) = smt5(i,j-1) .and. smt5(i,j) + hi6(i) = smt6(i,j-1) .or. smt6(i,j) + enddo + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdy(i,j-1) + if ( hi6(i) ) then + fx0(i) = br(i,j-1) - cfl*b0(i,j-1) + elseif ( hi5(i) ) then ! piece-wise linear + fx0(i) = sign(min(abs(bl(i,j-1)),abs(br(i,j-1))), br(i,j-1)) + endif + flux(i,j) = v(i,j-1) + (1.-cfl)*fx0(i) + else + cfl = c(i,j)*rdy(i,j) + if ( hi6(i) ) then + fx0(i) = bl(i,j) + cfl*b0(i,j) + elseif ( hi5(i) ) then ! piece-wise linear + fx0(i) = sign(min(abs(bl(i,j)),abs(br(i,j))), bl(i,j)) + endif + flux(i,j) = v(i,j) + (1.+cfl)*fx0(i) + endif + enddo + enddo + + elseif ( jord==4 ) then + + do j=js-1,je+1 + do i=is,ie+1 + x0 = abs(b0(i,j)) + x1 = abs(bl(i,j)-br(i,j)) + smt5(i,j) = x0 < x1 + smt6(i,j) = 3.*x0 < x1 + enddo + enddo + do j=js,je+1 + do i=is,ie+1 + fx0(i) = 0. + hi5(i) = smt5(i,j-1) .and. smt5(i,j) + hi6(i) = smt6(i,j-1) .or. smt6(i,j) + hi5(i) = hi5(i) .or. hi6(i) + enddo +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdy(i,j-1) + fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) + flux(i,j) = v(i,j-1) + else + cfl = c(i,j)*rdy(i,j) + fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) + flux(i,j) = v(i,j) + endif + if ( hi5(i) ) flux(i,j) = flux(i,j) + fx0(i) + enddo + enddo + + else ! jord = 5,6,7 + if ( jord==5 ) then + do j=js-1,je+1 + do i=is,ie+1 + smt5(i,j) = bl(i,j)*br(i,j) < 0. + enddo + enddo + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdy(i,j-1) + fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) + flux(i,j) = v(i,j-1) + else + cfl = c(i,j)*rdy(i,j) + fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) + flux(i,j) = v(i,j) + endif + if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx0(i) + enddo + enddo + else +! hord=6 + do j=js-1,je+1 + do i=is,ie+1 + smt6(i,j) = 3.*abs(b0(i,j)) < abs(bl(i,j)-br(i,j)) + enddo + enddo + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if( c(i,j)>0. ) then + cfl = c(i,j)*rdy(i,j-1) + fx0(i) = (1.-cfl)*(br(i,j-1)-cfl*b0(i,j-1)) + flux(i,j) = v(i,j-1) + else + cfl = c(i,j)*rdy(i,j) + fx0(i) = (1.+cfl)*(bl(i,j)+cfl*b0(i,j)) + flux(i,j) = v(i,j) + endif + if (smt6(i,j-1).or.smt6(i,j)) flux(i,j) = flux(i,j) + fx0(i) + enddo + enddo + endif + + endif + + else +! jord= 8, 9, 10 + + do j=js-2,je+2 + do i=is,ie+1 + xt = 0.25*(v(i,j+1) - v(i,j-1)) + dm(i,j) = sign(min(abs(xt), max(v(i,j-1), v(i,j), v(i,j+1)) - v(i,j), & + v(i,j) - min(v(i,j-1), v(i,j), v(i,j+1))), xt) + enddo + enddo + + do j=js-3,je+2 + do i=is,ie+1 + dq(i,j) = v(i,j+1) - v(i,j) + enddo + enddo + + if (grid_type < 3) then + do j=js3,je3+1 + do i=is,ie+1 + al(i,j) = 0.5*(v(i,j-1)+v(i,j)) + r3*(dm(i,j-1)-dm(i,j)) + enddo + enddo + + if ( jord==8 ) then + do j=js3,je3 + do i=is,ie+1 + xt = 2.*dm(i,j) + bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-v(i,j))), xt) + br(i,j) = sign(min(abs(xt), abs(al(i,j+1)-v(i,j))), xt) + enddo + enddo + elseif ( jord==9 ) then + do j=js3,je3 + do i=is,ie+1 + pmp_1 = -2.*dq(i,j) + lac_1 = pmp_1 + 1.5*dq(i,j+1) + bl(i,j) = min(max(0., pmp_1, lac_1), max(al(i,j)-v(i,j), min(0., pmp_1, lac_1))) + pmp_2 = 2.*dq(i,j-1) + lac_2 = pmp_2 - 1.5*dq(i,j-2) + br(i,j) = min(max(0., pmp_2, lac_2), max(al(i,j+1)-v(i,j), min(0., pmp_2, lac_2))) + enddo + enddo + elseif ( jord==10 ) then + do j=js3,je3 + do i=is,ie+1 + bl(i,j) = al(i,j ) - v(i,j) + br(i,j) = al(i,j+1) - v(i,j) +! if ( abs(dm(i,j-1))+abs(dm(i,j))+abs(dm(i,j+1)) < near_zero ) then + if ( abs(dm(i,j)) < near_zero ) then + if ( abs(dm(i,j-1))+abs(dm(i,j+1)) < near_zero ) then + bl(i,j) = 0. + br(i,j) = 0. + endif + elseif( abs(3.*(bl(i,j)+br(i,j))) > abs(bl(i,j)-br(i,j)) ) then + pmp_1 = -2.*dq(i,j) + lac_1 = pmp_1 + 1.5*dq(i,j+1) + bl(i,j) = min(max(0., pmp_1, lac_1), max(bl(i,j), min(0., pmp_1, lac_1))) + pmp_2 = 2.*dq(i,j-1) + lac_2 = pmp_2 - 1.5*dq(i,j-2) + br(i,j) = min(max(0., pmp_2, lac_2), max(br(i,j), min(0., pmp_2, lac_2))) + endif + enddo + enddo + else +! Unlimited: + do j=js3,je3 + do i=is,ie+1 + bl(i,j) = al(i,j ) - v(i,j) + br(i,j) = al(i,j+1) - v(i,j) + enddo + enddo + endif + +!-------------- +! fix the edges +!-------------- + if( js==1 .and. .not. bounded_domain) then + do i=is,ie+1 + br(i,2) = al(i,3) - v(i,2) + xt = s15*v(i,1) + s11*v(i,2) - s14*dm(i,2) + br(i,1) = xt - v(i,1) + bl(i,2) = xt - v(i,2) + + bl(i,0) = s14*dm(i,-1) - s11*dq(i,-1) + +#ifdef ONE_SIDE + xt = t14*v(i,1) + t12*v(i,2) + t15*v(i,3) + bl(i,1) = 2.*xt - v(i,1) + xt = t14*v(i,0) + t12*v(i,-1) + t15*v(i,-2) + br(i,0) = 2.*xt - v(i,0) +#else + x0L = 0.5*( (2.*dy(i,0)+dy(i,-1))*(v(i,0)) & + - dy(i,0)*(v(i,-1)))/(dy(i,0)+dy(i,-1)) + x0R = 0.5*( (2.*dy(i,1)+dy(i,2))*(v(i,1)) & + - dy(i,1)*(v(i,2)))/(dy(i,1)+dy(i,2)) + xt = x0L + x0R + + bl(i,1) = xt - v(i,1) + br(i,0) = xt - v(i,0) +#endif + enddo + if ( is==1 ) then + bl(1,0) = 0. ! out + br(1,0) = 0. ! edge + bl(1,1) = 0. ! edge + br(1,1) = 0. ! in + endif + if ( (ie+1)==npx ) then + bl(npx,0) = 0. ! out + br(npx,0) = 0. ! edge + bl(npx,1) = 0. ! edge + br(npx,1) = 0. ! in + endif + j=2 + call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) + endif + if( (je+1)==npy .and. .not. bounded_domain) then + do i=is,ie+1 + bl(i,npy-2) = al(i,npy-2) - v(i,npy-2) + xt = s15*v(i,npy-1) + s11*v(i,npy-2) + s14*dm(i,npy-2) + br(i,npy-2) = xt - v(i,npy-2) + bl(i,npy-1) = xt - v(i,npy-1) + br(i,npy) = s11*dq(i,npy) - s14*dm(i,npy+1) +#ifdef ONE_SIDE + xt = t14*v(i,npy-1) + t12*v(i,npy-2) + t15*v(i,npy-3) + br(i,npy-1) = 2.*xt - v(i,npy-1) + xt = t14*v(i,npy) + t12*v(i,npy+1) + t15*v(i,npy+2) + bl(i,npy ) = 2.*xt - v(i,npy) +#else + x0L= 0.5*((2.*dy(i,npy-1)+dy(i,npy-2))*(v(i,npy-1)) - & + dy(i,npy-1)*(v(i,npy-2)))/(dy(i,npy-1)+dy(i,npy-2)) + x0R= 0.5*((2.*dy(i,npy)+dy(i,npy+1))*(v(i,npy)) - & + dy(i,npy)*(v(i,npy+1)))/(dy(i,npy)+dy(i,npy+1)) + xt = x0L + x0R + + br(i,npy-1) = xt - v(i,npy-1) + bl(i,npy ) = xt - v(i,npy) +#endif + enddo + if ( is==1 ) then + bl(1,npy-1) = 0. ! in + br(1,npy-1) = 0. ! edge + bl(1,npy ) = 0. ! edge + br(1,npy ) = 0. ! out + endif + if ( (ie+1)==npx ) then + bl(npx,npy-1) = 0. ! in + br(npx,npy-1) = 0. ! edge + bl(npx,npy ) = 0. ! edge + br(npx,npy ) = 0. ! out + endif + j=npy-2 + call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1) + endif + + else + + do j=js-1,je+2 + do i=is,ie+1 + al(i,j) = 0.5*(v(i,j-1)+v(i,j)) + r3*(dm(i,j-1)-dm(i,j)) + enddo + enddo + + do j=js-1,je+1 + do i=is,ie+1 + pmp = 2.*dq(i,j-1) + lac = pmp - 1.5*dq(i,j-2) + br(i,j) = min(max(0.,pmp,lac), max(al(i,j+1)-v(i,j), min(0.,pmp,lac))) + pmp = -2.*dq(i,j) + lac = pmp + 1.5*dq(i,j+1) + bl(i,j) = min(max(0.,pmp,lac), max(al(i,j)-v(i,j), min(0.,pmp,lac))) + enddo + enddo + + endif + + do j=js,je+1 + do i=is,ie+1 + if(c(i,j)>0.) then + cfl = c(i,j)*rdy(i,j-1) + flux(i,j) = v(i,j-1) + (1.-cfl)*(br(i,j-1)-cfl*(bl(i,j-1)+br(i,j-1))) + else + cfl = c(i,j)*rdy(i,j) + flux(i,j) = v(i,j ) + (1.+cfl)*(bl(i,j )+cfl*(bl(i,j )+br(i,j ))) + endif + enddo + enddo + + endif + +end subroutine ytp_v + + +!There is a limit to how far this routine can fill uc and vc in the +! halo, and so either mpp_update_domains or some sort of boundary +! routine (extrapolation, outflow, interpolation from a bounded_domain grid) + +! is needed after c_sw is completed if these variables are needed +! in the halo + subroutine d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, & + bd, npx, npy, bounded_domain, grid_type) + type(fv_grid_bounds_type), intent(IN) :: bd + logical, intent(in):: dord4 + real, intent(in) :: u(bd%isd:bd%ied,bd%jsd:bd%jed+1) + real, intent(in) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed) + real, intent(out), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed ):: uc + real, intent(out), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed+1):: vc + real, intent(out), dimension(bd%isd:bd%ied ,bd%jsd:bd%jed ):: ua, va, ut, vt + integer, intent(IN) :: npx, npy, grid_type + logical, intent(IN) :: bounded_domain + type(fv_grid_type), intent(IN), target :: gridstruct +! Local + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: utmp, vtmp + integer npt, i, j, ifirst, ilast, id + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + real, pointer, dimension(:,:,:) :: sin_sg + real, pointer, dimension(:,:) :: cosa_u, cosa_v, cosa_s + real, pointer, dimension(:,:) :: rsin_u, rsin_v, rsin2 + real, pointer, dimension(:,:) :: dxa,dya + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + sin_sg => gridstruct%sin_sg + cosa_u => gridstruct%cosa_u + cosa_v => gridstruct%cosa_v + cosa_s => gridstruct%cosa_s + rsin_u => gridstruct%rsin_u + rsin_v => gridstruct%rsin_v + rsin2 => gridstruct%rsin2 + dxa => gridstruct%dxa + dya => gridstruct%dya + + if ( dord4 ) then + id = 1 + else + id = 0 + endif + + if (grid_type < 3 .and. .not. bounded_domain) then + npt = 4 + else + npt = -2 + endif + +! Initialize the non-existing corner regions + utmp(:,:) = big_number + vtmp(:,:) = big_number + + if ( bounded_domain ) then + + do j=jsd+1,jed-1 + do i=isd,ied + utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) + enddo + enddo + do i=isd,ied + j = jsd + utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) + j = jed + utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) + end do + + do j=jsd,jed + do i=isd+1,ied-1 + vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) + enddo + i = isd + vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) + i = ied + vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) + enddo + + do j=jsd,jed + do i=isd,ied + ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + enddo + enddo + + else + !---------- + ! Interior: + !---------- + do j=max(npt,js-1),min(npy-npt,je+1) + do i=max(npt,isd),min(npx-npt,ied) + utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) + enddo + enddo + do j=max(npt,jsd),min(npy-npt,jed) + do i=max(npt,is-1),min(npx-npt,ie+1) + vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) + enddo + enddo + + !---------- + ! edges: + !---------- + if (grid_type < 3) then + + if ( js==1 .or. jsd=(npy-npt)) then + do j=npy-npt+1,jed + do i=isd,ied + utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) + vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) + enddo + enddo + endif + + if ( is==1 .or. isd=(npx-npt)) then + do j=max(npt,jsd),min(npy-npt,jed) + do i=npx-npt+1,ied + utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) + vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) + enddo + enddo + endif + + endif + +! Contra-variant components at cell center: + do j=js-1-id,je+1+id + do i=is-1-id,ie+1+id + ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) + enddo + enddo + + end if + +! A -> C +!-------------- +! Fix the edges +!-------------- +! Xdir: + if( gridstruct%sw_corner ) then + do i=-2,0 + utmp(i,0) = -vtmp(0,1-i) + enddo + endif + if( gridstruct%se_corner ) then + do i=0,2 + utmp(npx+i,0) = vtmp(npx,i+1) + enddo + endif + if( gridstruct%ne_corner ) then + do i=0,2 + utmp(npx+i,npy) = -vtmp(npx,je-i) + enddo + endif + if( gridstruct%nw_corner ) then + do i=-2,0 + utmp(i,npy) = vtmp(0,je+i) + enddo + endif + + if (grid_type < 3 .and. .not. bounded_domain) then + ifirst = max(3, is-1) + ilast = min(npx-2,ie+2) + else + ifirst = is-1 + ilast = ie+2 + endif +!--------------------------------------------- +! 4th order interpolation for interior points: +!--------------------------------------------- + do j=js-1,je+1 + do i=ifirst,ilast + uc(i,j) = a2*(utmp(i-2,j)+utmp(i+1,j)) + a1*(utmp(i-1,j)+utmp(i,j)) + ut(i,j) = (uc(i,j) - v(i,j)*cosa_u(i,j))*rsin_u(i,j) + enddo + enddo + + if (grid_type < 3) then +! Xdir: + if( gridstruct%sw_corner ) then + ua(-1,0) = -va(0,2) + ua( 0,0) = -va(0,1) + endif + if( gridstruct%se_corner ) then + ua(npx, 0) = va(npx,1) + ua(npx+1,0) = va(npx,2) + endif + if( gridstruct%ne_corner ) then + ua(npx, npy) = -va(npx,npy-1) + ua(npx+1,npy) = -va(npx,npy-2) + endif + if( gridstruct%nw_corner ) then + ua(-1,npy) = va(0,npy-2) + ua( 0,npy) = va(0,npy-1) + endif + + if( is==1 .and. .not. bounded_domain ) then + do j=js-1,je+1 + uc(0,j) = c1*utmp(-2,j) + c2*utmp(-1,j) + c3*utmp(0,j) + ut(1,j) = edge_interpolate4(ua(-1:2,j), dxa(-1:2,j)) + !Want to use the UPSTREAM value + if (ut(1,j) > 0.) then + uc(1,j) = ut(1,j)*sin_sg(0,j,3) + else + uc(1,j) = ut(1,j)*sin_sg(1,j,1) + end if + uc(2,j) = c1*utmp(3,j) + c2*utmp(2,j) + c3*utmp(1,j) + ut(0,j) = (uc(0,j) - v(0,j)*cosa_u(0,j))*rsin_u(0,j) + ut(2,j) = (uc(2,j) - v(2,j)*cosa_u(2,j))*rsin_u(2,j) + enddo + endif + + if( (ie+1)==npx .and. .not. bounded_domain ) then + do j=js-1,je+1 + uc(npx-1,j) = c1*utmp(npx-3,j)+c2*utmp(npx-2,j)+c3*utmp(npx-1,j) + ut(npx, j) = edge_interpolate4(ua(npx-2:npx+1,j), dxa(npx-2:npx+1,j)) + if (ut(npx,j) > 0.) then + uc(npx,j) = ut(npx,j)*sin_sg(npx-1,j,3) + else + uc(npx,j) = ut(npx,j)*sin_sg(npx,j,1) + end if + uc(npx+1,j) = c3*utmp(npx,j) + c2*utmp(npx+1,j) + c1*utmp(npx+2,j) + ut(npx-1,j) = (uc(npx-1,j)-v(npx-1,j)*cosa_u(npx-1,j))*rsin_u(npx-1,j) + ut(npx+1,j) = (uc(npx+1,j)-v(npx+1,j)*cosa_u(npx+1,j))*rsin_u(npx+1,j) + enddo + endif + + endif + +!------ +! Ydir: +!------ + if( gridstruct%sw_corner ) then + do j=-2,0 + vtmp(0,j) = -utmp(1-j,0) + enddo + endif + if( gridstruct%nw_corner ) then + do j=0,2 + vtmp(0,npy+j) = utmp(j+1,npy) + enddo + endif + if( gridstruct%se_corner ) then + do j=-2,0 + vtmp(npx,j) = utmp(ie+j,0) + enddo + endif + if( gridstruct%ne_corner ) then + do j=0,2 + vtmp(npx,npy+j) = -utmp(ie-j,npy) + enddo + endif + if( gridstruct%sw_corner ) then + va(0,-1) = -ua(2,0) + va(0, 0) = -ua(1,0) + endif + if( gridstruct%se_corner ) then + va(npx, 0) = ua(npx-1,0) + va(npx,-1) = ua(npx-2,0) + endif + if( gridstruct%ne_corner ) then + va(npx,npy ) = -ua(npx-1,npy) + va(npx,npy+1) = -ua(npx-2,npy) + endif + if( gridstruct%nw_corner ) then + va(0,npy) = ua(1,npy) + va(0,npy+1) = ua(2,npy) + endif + + if (grid_type < 3) then + + do j=js-1,je+2 + if ( j==1 .and. .not. bounded_domain ) then + do i=is-1,ie+1 + vt(i,j) = edge_interpolate4(va(i,-1:2), dya(i,-1:2)) + if (vt(i,j) > 0.) then + vc(i,j) = vt(i,j)*sin_sg(i,j-1,4) + else + vc(i,j) = vt(i,j)*sin_sg(i,j,2) + end if + enddo + elseif ( j==0 .or. j==(npy-1) .and. .not. bounded_domain ) then + do i=is-1,ie+1 + vc(i,j) = c1*vtmp(i,j-2) + c2*vtmp(i,j-1) + c3*vtmp(i,j) + vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j) + enddo + elseif ( j==2 .or. j==(npy+1) .and. .not. bounded_domain ) then + do i=is-1,ie+1 + vc(i,j) = c1*vtmp(i,j+1) + c2*vtmp(i,j) + c3*vtmp(i,j-1) + vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j) + enddo + elseif ( j==npy .and. .not. bounded_domain ) then + do i=is-1,ie+1 + vt(i,j) = edge_interpolate4(va(i,j-2:j+1), dya(i,j-2:j+1)) + if (vt(i,j) > 0.) then + vc(i,j) = vt(i,j)*sin_sg(i,j-1,4) + else + vc(i,j) = vt(i,j)*sin_sg(i,j,2) + end if + enddo + else +! 4th order interpolation for interior points: + do i=is-1,ie+1 + vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1)) + a1*(vtmp(i,j-1)+vtmp(i,j)) + vt(i,j) = (vc(i,j) - u(i,j)*cosa_v(i,j))*rsin_v(i,j) + enddo + endif + enddo + else +! 4th order interpolation: + do j=js-1,je+2 + do i=is-1,ie+1 + vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1)) + a1*(vtmp(i,j-1)+vtmp(i,j)) + vt(i,j) = vc(i,j) + enddo + enddo + endif + + end subroutine d2a2c_vect + + + real function edge_interpolate4(ua, dxa) + + real, intent(in) :: ua(4) + real, intent(in) :: dxa(4) + real:: t1, t2 + + t1 = dxa(1) + dxa(2) + t2 = dxa(3) + dxa(4) + edge_interpolate4 = 0.5*( ((t1+dxa(2))*ua(2)-dxa(2)*ua(1)) / t1 + & + ((t2+dxa(3))*ua(3)-dxa(3)*ua(4)) / t2 ) + + end function edge_interpolate4 + +!>@brief The subroutine 'fill3_4corners' fills the 4 corners of the scalar fileds only as needed by 'c_core'. + subroutine fill3_4corners(q1, q2, q3, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: dir !< 1: x-dir; 2: y-dir + real, intent(inout):: q1(bd%isd:bd%ied,bd%jsd:bd%jed) + real, intent(inout):: q2(bd%isd:bd%ied,bd%jsd:bd%jed) + real, intent(inout):: q3(bd%isd:bd%ied,bd%jsd:bd%jed) + logical, intent(IN) :: sw_corner, se_corner, ne_corner, nw_corner + integer, intent(IN) :: npx, npy + integer i,j + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + select case(dir) + case(1) + if ( sw_corner ) then + q1(-1,0) = q1(0,2); q1(0,0) = q1(0,1); q1(0,-1) = q1(-1,1) + q2(-1,0) = q2(0,2); q2(0,0) = q2(0,1); q2(0,-1) = q2(-1,1) + q3(-1,0) = q3(0,2); q3(0,0) = q3(0,1); q3(0,-1) = q3(-1,1) + endif + if ( se_corner ) then + q1(npx+1,0) = q1(npx,2); q1(npx,0) = q1(npx,1); q1(npx,-1) = q1(npx+1,1) + q2(npx+1,0) = q2(npx,2); q2(npx,0) = q2(npx,1); q2(npx,-1) = q2(npx+1,1) + q3(npx+1,0) = q3(npx,2); q3(npx,0) = q3(npx,1); q3(npx,-1) = q3(npx+1,1) + endif + if ( ne_corner ) then + q1(npx,npy) = q1(npx,npy-1); q1(npx+1,npy) = q1(npx,npy-2); q1(npx,npy+1) = q1(npx+1,npy-1) + q2(npx,npy) = q2(npx,npy-1); q2(npx+1,npy) = q2(npx,npy-2); q2(npx,npy+1) = q2(npx+1,npy-1) + q3(npx,npy) = q3(npx,npy-1); q3(npx+1,npy) = q3(npx,npy-2); q3(npx,npy+1) = q3(npx+1,npy-1) + endif + if ( nw_corner ) then + q1(0,npy) = q1(0,npy-1); q1(-1,npy) = q1(0,npy-2); q1(0,npy+1) = q1(-1,npy-1) + q2(0,npy) = q2(0,npy-1); q2(-1,npy) = q2(0,npy-2); q2(0,npy+1) = q2(-1,npy-1) + q3(0,npy) = q3(0,npy-1); q3(-1,npy) = q3(0,npy-2); q3(0,npy+1) = q3(-1,npy-1) + endif + + case(2) + if ( sw_corner ) then + q1(0,0) = q1(1,0); q1(0,-1) = q1(2,0); q1(-1,0) = q1(1,-1) + q2(0,0) = q2(1,0); q2(0,-1) = q2(2,0); q2(-1,0) = q2(1,-1) + q3(0,0) = q3(1,0); q3(0,-1) = q3(2,0); q3(-1,0) = q3(1,-1) + endif + if ( se_corner ) then + q1(npx,0) = q1(npx-1,0); q1(npx,-1) = q1(npx-2,0); q1(npx+1,0) = q1(npx-1,-1) + q2(npx,0) = q2(npx-1,0); q2(npx,-1) = q2(npx-2,0); q2(npx+1,0) = q2(npx-1,-1) + q3(npx,0) = q3(npx-1,0); q3(npx,-1) = q3(npx-2,0); q3(npx+1,0) = q3(npx-1,-1) + endif + if ( ne_corner ) then + q1(npx,npy) = q1(npx-1,npy); q1(npx,npy+1) = q1(npx-2,npy); q1(npx+1,npy) = q1(npx-1,npy+1) + q2(npx,npy) = q2(npx-1,npy); q2(npx,npy+1) = q2(npx-2,npy); q2(npx+1,npy) = q2(npx-1,npy+1) + q3(npx,npy) = q3(npx-1,npy); q3(npx,npy+1) = q3(npx-2,npy); q3(npx+1,npy) = q3(npx-1,npy+1) + endif + if ( nw_corner ) then + q1(0,npy) = q1(1,npy); q1(0,npy+1) = q1(2,npy); q1(-1,npy) = q1(1,npy+1) + q2(0,npy) = q2(1,npy); q2(0,npy+1) = q2(2,npy); q2(-1,npy) = q2(1,npy+1) + q3(0,npy) = q3(1,npy); q3(0,npy+1) = q3(2,npy); q3(-1,npy) = q3(1,npy+1) + endif + + end select + end subroutine fill3_4corners + +!>@brief The subroutine ' fill2_4corners' fills the 4 corners of the scalar fileds only as needed by 'c_core'. + subroutine fill2_4corners(q1, q2, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: dir !< 1: x-dir; 2: y-dir + real, intent(inout):: q1(bd%isd:bd%ied,bd%jsd:bd%jed) + real, intent(inout):: q2(bd%isd:bd%ied,bd%jsd:bd%jed) + logical, intent(IN) :: sw_corner, se_corner, ne_corner, nw_corner + integer, intent(IN) :: npx, npy + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + select case(dir) + case(1) + if ( sw_corner ) then + q1(-1,0) = q1(0,2); q1(0,0) = q1(0,1) + q2(-1,0) = q2(0,2); q2(0,0) = q2(0,1) + endif + if ( se_corner ) then + q1(npx+1,0) = q1(npx,2); q1(npx,0) = q1(npx,1) + q2(npx+1,0) = q2(npx,2); q2(npx,0) = q2(npx,1) + endif + if ( nw_corner ) then + q1(0,npy) = q1(0,npy-1); q1(-1,npy) = q1(0,npy-2) + q2(0,npy) = q2(0,npy-1); q2(-1,npy) = q2(0,npy-2) + endif + if ( ne_corner ) then + q1(npx,npy) = q1(npx,npy-1); q1(npx+1,npy) = q1(npx,npy-2) + q2(npx,npy) = q2(npx,npy-1); q2(npx+1,npy) = q2(npx,npy-2) + endif + + case(2) + if ( sw_corner ) then + q1(0,0) = q1(1,0); q1(0,-1) = q1(2,0) + q2(0,0) = q2(1,0); q2(0,-1) = q2(2,0) + endif + if ( se_corner ) then + q1(npx,0) = q1(npx-1,0); q1(npx,-1) = q1(npx-2,0) + q2(npx,0) = q2(npx-1,0); q2(npx,-1) = q2(npx-2,0) + endif + if ( nw_corner ) then + q1(0,npy) = q1(1,npy); q1(0,npy+1) = q1(2,npy) + q2(0,npy) = q2(1,npy); q2(0,npy+1) = q2(2,npy) + endif + if ( ne_corner ) then + q1(npx,npy) = q1(npx-1,npy); q1(npx,npy+1) = q1(npx-2,npy) + q2(npx,npy) = q2(npx-1,npy); q2(npx,npy+1) = q2(npx-2,npy) + endif + + end select + + end subroutine fill2_4corners + +!>@brief The subroutine 'fill_4corners' fills the 4 corners of the scalar fields only as needed by c_core. + subroutine fill_4corners(q, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner) + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: dir ! 1: x-dir; 2: y-dir + real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed) + logical, intent(IN) :: sw_corner, se_corner, ne_corner, nw_corner + integer, intent(IN) :: npx, npy + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + select case(dir) + case(1) + if ( sw_corner ) then + q(-1,0) = q(0,2) + q( 0,0) = q(0,1) + endif + if ( se_corner ) then + q(npx+1,0) = q(npx,2) + q(npx, 0) = q(npx,1) + endif + if ( nw_corner ) then + q( 0,npy) = q(0,npy-1) + q(-1,npy) = q(0,npy-2) + endif + if ( ne_corner ) then + q(npx, npy) = q(npx,npy-1) + q(npx+1,npy) = q(npx,npy-2) + endif + + case(2) + if ( sw_corner ) then + q(0, 0) = q(1,0) + q(0,-1) = q(2,0) + endif + if ( se_corner ) then + q(npx, 0) = q(npx-1,0) + q(npx,-1) = q(npx-2,0) + endif + if ( nw_corner ) then + q(0,npy ) = q(1,npy) + q(0,npy+1) = q(2,npy) + endif + if ( ne_corner ) then + q(npx,npy ) = q(npx-1,npy) + q(npx,npy+1) = q(npx-2,npy) + endif + + end select + + end subroutine fill_4corners + + end module sw_core_mod diff --git a/model/tp_core.F90 b/model/tp_core.F90 index ec18217ed..c5cc3b29e 100644 --- a/model/tp_core.F90 +++ b/model/tp_core.F90 @@ -1,1241 +1,1242 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'tp_core' is a collection of routines to support FV transport. -!>@details The module contains the scalar advection scheme and PPM operators. -module tp_core_mod - -! Modules Included: -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -!
Module NameFunctions Included
fv_mp_modng
fv_grid_utils_modbig_number
fv_arrays_modfv_grid_type, fv_grid_bounds_type
field_manager_modfm_path_name_len, fm_string_len, fm_exists, fm_get_index, fm_new_list, fm_get_current_list, -! fm_change_list, fm_field_name_len, fm_type_name_len, fm_dump_list, fm_loop_over_list
- - use fv_mp_mod, only: ng - use fv_grid_utils_mod, only: big_number - use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type - - implicit none - - private - public fv_tp_2d, pert_ppm, copy_corners - - real, parameter:: ppm_fac = 1.5 !< nonlinear scheme limiter: between 1 and 2 - real, parameter:: r3 = 1./3. - real, parameter:: near_zero = 1.E-25 - real, parameter:: ppm_limiter = 2.0 - -#ifdef WAVE_FORM -! Suresh & Huynh scheme 2.2 (purtabation form) -! The wave-form is more diffusive than scheme 2.1 - real, parameter:: b1 = 0.0375 - real, parameter:: b2 = -7./30. - real, parameter:: b3 = -23./120. - real, parameter:: b4 = 13./30. - real, parameter:: b5 = -11./240. -#else -! scheme 2.1: perturbation form - real, parameter:: b1 = 1./30. - real, parameter:: b2 = -13./60. - real, parameter:: b3 = -13./60. - real, parameter:: b4 = 0.45 - real, parameter:: b5 = -0.05 -#endif - real, parameter:: t11 = 27./28., t12 = -13./28., t13=3./7. - real, parameter:: s11 = 11./14., s14 = 4./7., s15=3./14. -!---------------------------------------------------- -! volume-conserving cubic with 2nd drv=0 at end point: -!---------------------------------------------------- -! Non-monotonic - real, parameter:: c1 = -2./14. - real, parameter:: c2 = 11./14. - real, parameter:: c3 = 5./14. -!---------------------- -! PPM volume mean form: -!---------------------- - real, parameter:: p1 = 7./12. ! 0.58333333 - real, parameter:: p2 = -1./12. -! q(i+0.5) = p1*(q(i-1)+q(i)) + p2*(q(i-2)+q(i+1)) -! integer:: is, ie, js, je, isd, ied, jsd, jed - -! -!EOP -!----------------------------------------------------------------------- - -contains - -!>@brief The subroutine 'fv_tp_2d' contains the FV advection scheme -!! \cite putman2007finite \cite lin1996multiflux. -!>@details It performs 1 time step of the forward advection. - subroutine fv_tp_2d(q, crx, cry, npx, npy, hord, fx, fy, xfx, yfx, & - gridstruct, bd, ra_x, ra_y, lim_fac, regional, mfx, mfy, mass, nord, damp_c) - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: npx, npy - integer, intent(in)::hord - - real, intent(in):: crx(bd%is:bd%ie+1,bd%jsd:bd%jed) - real, intent(in):: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed) - real, intent(in):: cry(bd%isd:bd%ied,bd%js:bd%je+1 ) - real, intent(in):: yfx(bd%isd:bd%ied,bd%js:bd%je+1 ) - real, intent(in):: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) - real, intent(in):: ra_y(bd%isd:bd%ied,bd%js:bd%je) - real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed) !< transported scalar - real, intent(out)::fx(bd%is:bd%ie+1 ,bd%js:bd%je) !< Flux in x ( E ) - real, intent(out)::fy(bd%is:bd%ie, bd%js:bd%je+1 ) !< Flux in y ( N ) - - type(fv_grid_type), intent(IN), target :: gridstruct - - real, intent(in):: lim_fac - logical, intent(in):: regional -! optional Arguments: - real, OPTIONAL, intent(in):: mfx(bd%is:bd%ie+1,bd%js:bd%je ) !< Mass Flux X-Dir - real, OPTIONAL, intent(in):: mfy(bd%is:bd%ie ,bd%js:bd%je+1) !< Mass Flux Y-Dir - real, OPTIONAL, intent(in):: mass(bd%isd:bd%ied,bd%jsd:bd%jed) - real, OPTIONAL, intent(in):: damp_c - integer, OPTIONAL, intent(in):: nord !< order of divergence damping -! Local: - integer ord_ou, ord_in - real q_i(bd%isd:bd%ied,bd%js:bd%je) - real q_j(bd%is:bd%ie,bd%jsd:bd%jed) - real fx2(bd%is:bd%ie+1,bd%jsd:bd%jed) - real fy2(bd%isd:bd%ied,bd%js:bd%je+1) - real fyy(bd%isd:bd%ied,bd%js:bd%je+1) - real fx1(bd%is:bd%ie+1) - real damp - integer i, j - - integer:: is, ie, js, je, isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - if ( hord == 10 ) then - ord_in = 8 - else - ord_in = hord - endif - ord_ou = hord - - if (.not. (regional)) call copy_corners(q, npx, npy, 2, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - - call yppm(fy2, q, cry, ord_in, isd,ied,isd,ied, js,je,jsd,jed, npx,npy, gridstruct%dya, gridstruct%nested, gridstruct%grid_type, lim_fac,regional) - - do j=js,je+1 - do i=isd,ied - fyy(i,j) = yfx(i,j) * fy2(i,j) - enddo - enddo - do j=js,je - do i=isd,ied - q_i(i,j) = (q(i,j)*gridstruct%area(i,j) + fyy(i,j)-fyy(i,j+1))/ra_y(i,j) - enddo - enddo - - call xppm(fx, q_i, crx(is,js), ord_ou, is,ie,isd,ied, js,je,jsd,jed, npx,npy, gridstruct%dxa, gridstruct%nested, gridstruct%grid_type, lim_fac,regional) - - if (.not. (regional)) call copy_corners(q, npx, npy, 1, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - - call xppm(fx2, q, crx, ord_in, is,ie,isd,ied, jsd,jed,jsd,jed, npx,npy, gridstruct%dxa, gridstruct%nested, gridstruct%grid_type, lim_fac,regional) - - do j=jsd,jed - do i=is,ie+1 - fx1(i) = xfx(i,j) * fx2(i,j) - enddo - do i=is,ie - q_j(i,j) = (q(i,j)*gridstruct%area(i,j) + fx1(i)-fx1(i+1))/ra_x(i,j) - enddo - enddo - - call yppm(fy, q_j, cry, ord_ou, is,ie,isd,ied, js,je,jsd,jed, npx, npy, gridstruct%dya, gridstruct%nested, gridstruct%grid_type, lim_fac,regional) - -!---------------- -! Flux averaging: -!---------------- - - if ( present(mfx) .and. present(mfy) ) then -!--------------------------------- -! For transport of pt and tracers -!--------------------------------- - do j=js,je - do i=is,ie+1 - fx(i,j) = 0.5*(fx(i,j) + fx2(i,j)) * mfx(i,j) - enddo - enddo - do j=js,je+1 - do i=is,ie - fy(i,j) = 0.5*(fy(i,j) + fy2(i,j)) * mfy(i,j) - enddo - enddo - if ( present(nord) .and. present(damp_c) .and. present(mass) ) then - if ( damp_c > 1.e-4 ) then - damp = (damp_c * gridstruct%da_min)**(nord+1) - call deln_flux(nord, is,ie,js,je, npx, npy, damp, q, fx, fy, gridstruct,regional, bd, mass) - endif - endif - else -!--------------------------------- -! For transport of delp, vorticity -!--------------------------------- - do j=js,je - do i=is,ie+1 - fx(i,j) = 0.5*(fx(i,j) + fx2(i,j)) * xfx(i,j) - enddo - enddo - do j=js,je+1 - do i=is,ie - fy(i,j) = 0.5*(fy(i,j) + fy2(i,j)) * yfx(i,j) - enddo - enddo - if ( present(nord) .and. present(damp_c) ) then - if ( damp_c > 1.E-4 ) then - damp = (damp_c * gridstruct%da_min)**(nord+1) - call deln_flux(nord, is,ie,js,je, npx, npy, damp, q, fx, fy, gridstruct, regional, bd) - endif - endif - endif - end subroutine fv_tp_2d - - !Weird arguments are because this routine is called in a lot of - !places outside of tp_core, sometimes very deeply nested in the call tree. - subroutine copy_corners(q, npx, npy, dir, nested, bd, & - sw_corner, se_corner, nw_corner, ne_corner) - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: npx, npy, dir - real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed) - logical, intent(IN) :: nested, sw_corner, se_corner, nw_corner, ne_corner - integer i,j - - if (nested) return - - if ( dir == 1 ) then -! XDir: - if ( sw_corner ) then - do j=1-ng,0 - do i=1-ng,0 - q(i,j) = q(j,1-i) - enddo - enddo - endif - if ( se_corner ) then - do j=1-ng,0 - do i=npx,npx+ng-1 - q(i,j) = q(npy-j,i-npx+1) - enddo - enddo - endif - if ( ne_corner ) then - do j=npy,npy+ng-1 - do i=npx,npx+ng-1 - q(i,j) = q(j,2*npx-1-i) - enddo - enddo - endif - if ( nw_corner ) then - do j=npy,npy+ng-1 - do i=1-ng,0 - q(i,j) = q(npy-j,i-1+npx) - enddo - enddo - endif - - elseif ( dir == 2 ) then -! YDir: - - if ( sw_corner ) then - do j=1-ng,0 - do i=1-ng,0 - q(i,j) = q(1-j,i) - enddo - enddo - endif - if ( se_corner ) then - do j=1-ng,0 - do i=npx,npx+ng-1 - q(i,j) = q(npy+j-1,npx-i) - enddo - enddo - endif - if ( ne_corner ) then - do j=npy,npy+ng-1 - do i=npx,npx+ng-1 - q(i,j) = q(2*npy-1-j,i) - enddo - enddo - endif - if ( nw_corner ) then - do j=npy,npy+ng-1 - do i=1-ng,0 - q(i,j) = q(j+1-npx,npy-i) - enddo - enddo - endif - - endif - - end subroutine copy_corners - - subroutine xppm(flux, q, c, iord, is,ie,isd,ied, jfirst,jlast,jsd,jed, npx, npy, dxa, nested, grid_type, lim_fac,regional) - integer, INTENT(IN) :: is, ie, isd, ied, jsd, jed - integer, INTENT(IN) :: jfirst, jlast !< compute domain - integer, INTENT(IN) :: iord - integer, INTENT(IN) :: npx, npy - real , INTENT(IN) :: q(isd:ied,jfirst:jlast) - real , INTENT(IN) :: c(is:ie+1,jfirst:jlast) !< Courant N (like FLUX) - real , intent(IN) :: dxa(isd:ied,jsd:jed) - logical, intent(IN) :: nested,regional - integer, intent(IN) :: grid_type - real , intent(IN) :: lim_fac -!OUTPUT PARAMETERS: - real , INTENT(OUT) :: flux(is:ie+1,jfirst:jlast) !< Flux -! Local - real, dimension(is-1:ie+1):: bl, br, b0 - real:: q1(isd:ied) - real, dimension(is:ie+1):: fx0, fx1, xt1 - logical, dimension(is-1:ie+1):: smt5, smt6 - logical, dimension(is:ie+1):: hi5, hi6 - real al(is-1:ie+2) - real dm(is-2:ie+2) - real dq(is-3:ie+2) - integer:: i, j, ie3, is1, ie1, mord - real:: x0, x1, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2 - - if ( .not. (nested .or. regional) .and. grid_type<3 ) then - is1 = max(3,is-1); ie3 = min(npx-2,ie+2) - ie1 = min(npx-3,ie+1) - else - is1 = is-1; ie3 = ie+2 - ie1 = ie+1 - end if - mord = abs(iord) - - do 666 j=jfirst,jlast - - do i=isd, ied - q1(i) = q(i,j) - enddo - - if ( iord < 8 ) then -! ord = 2: perfectly linear ppm scheme -! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 - - do i=is1, ie3 - al(i) = p1*(q1(i-1)+q1(i)) + p2*(q1(i-2)+q1(i+1)) - enddo - - if ( .not. (nested .or. regional) .and. grid_type<3 ) then - if ( is==1 ) then - al(0) = c1*q1(-2) + c2*q1(-1) + c3*q1(0) - al(1) = 0.5*(((2.*dxa(0,j)+dxa(-1,j))*q1(0)-dxa(0,j)*q1(-1))/(dxa(-1,j)+dxa(0,j)) & - + ((2.*dxa(1,j)+dxa( 2,j))*q1(1)-dxa(1,j)*q1( 2))/(dxa(1, j)+dxa(2,j))) - al(2) = c3*q1(1) + c2*q1(2) +c1*q1(3) - endif - if ( (ie+1)==npx ) then - al(npx-1) = c1*q1(npx-3) + c2*q1(npx-2) + c3*q1(npx-1) - al(npx) = 0.5*(((2.*dxa(npx-1,j)+dxa(npx-2,j))*q1(npx-1)-dxa(npx-1,j)*q1(npx-2))/(dxa(npx-2,j)+dxa(npx-1,j)) & - + ((2.*dxa(npx, j)+dxa(npx+1,j))*q1(npx )-dxa(npx, j)*q1(npx+1))/(dxa(npx, j)+dxa(npx+1,j))) - al(npx+1) = c3*q1(npx) + c2*q1(npx+1) + c1*q1(npx+2) - endif - endif - - if ( iord<0 ) then - do i=is-1, ie+2 - al(i) = max(0., al(i)) - enddo - endif - - if ( mord==1 ) then ! perfectly linear scheme - do i=is-1,ie+1 - bl(i) = al(i) - q1(i) - br(i) = al(i+1) - q1(i) - b0(i) = bl(i) + br(i) - smt5(i) = abs(lim_fac*b0(i)) < abs(bl(i)-br(i)) - enddo -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if ( c(i,j) > 0. ) then - fx1(i) = (1.-c(i,j))*(br(i-1) - c(i,j)*b0(i-1)) - flux(i,j) = q1(i-1) - else - fx1(i) = (1.+c(i,j))*(bl(i) + c(i,j)*b0(i)) - flux(i,j) = q1(i) - endif - if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx1(i) - enddo - - elseif ( mord==2 ) then ! perfectly linear scheme - -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - xt = c(i,j) - if ( xt > 0. ) then - qtmp = q1(i-1) - flux(i,j) = qtmp + (1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-(qtmp+qtmp))) - else - qtmp = q1(i) - flux(i,j) = qtmp + (1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-(qtmp+qtmp))) - endif -! x0 = sign(dim(xt, 0.), 1.) -! x1 = sign(dim(0., xt), 1.) -! flux(i,j) = x0*(q1(i-1)+(1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-(qtmp+qtmp)))) & -! + x1*(q1(i) +(1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-(qtmp+qtmp)))) - enddo - - elseif ( mord==3 ) then - - do i=is-1,ie+1 - bl(i) = al(i) - q1(i) - br(i) = al(i+1) - q1(i) - b0(i) = bl(i) + br(i) - x0 = abs(b0(i)) - xt = abs(bl(i)-br(i)) - smt5(i) = x0 < xt - smt6(i) = 3.*x0 < xt - enddo - do i=is,ie+1 - fx1(i) = 0. - xt1(i) = c(i,j) - hi5(i) = smt5(i-1) .and. smt5(i) ! more diffusive - hi6(i) = smt6(i-1) .or. smt6(i) - enddo - do i=is,ie+1 - if ( xt1(i) > 0. ) then - if ( hi6(i) ) then - fx1(i) = br(i-1) - xt1(i)*b0(i-1) - elseif ( hi5(i) ) then ! 2nd order, piece-wise linear - fx1(i) = sign(min(abs(bl(i-1)),abs(br(i-1))), br(i-1)) - endif - flux(i,j) = q1(i-1) + (1.-xt1(i))*fx1(i) - else - if ( hi6(i) ) then - fx1(i) = bl(i) + xt1(i)*b0(i) - elseif ( hi5(i) ) then ! 2nd order, piece-wise linear - fx1(i) = sign(min(abs(bl(i)), abs(br(i))), bl(i)) - endif - flux(i,j) = q1(i) + (1.+xt1(i))*fx1(i) - endif - enddo - - elseif ( mord==4 ) then - - do i=is-1,ie+1 - bl(i) = al(i) - q1(i) - br(i) = al(i+1) - q1(i) - b0(i) = bl(i) + br(i) - x0 = abs(b0(i)) - xt = abs(bl(i)-br(i)) - smt5(i) = x0 < xt - smt6(i) = 3.*x0 < xt - enddo - do i=is,ie+1 - xt1(i) = c(i,j) - hi5(i) = smt5(i-1) .and. smt5(i) ! more diffusive - hi6(i) = smt6(i-1) .or. smt6(i) - hi5(i) = hi5(i) .or. hi6(i) - enddo -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if ( xt1(i) > 0. ) then - fx1(i) = (1.-xt1(i))*(br(i-1) - xt1(i)*b0(i-1)) - flux(i,j) = q1(i-1) - else - fx1(i) = (1.+xt1(i))*(bl(i) + xt1(i)*b0(i)) - flux(i,j) = q1(i) - endif - if ( hi5(i) ) flux(i,j) = flux(i,j) + fx1(i) - enddo - - else - - if ( mord==5 ) then - do i=is-1,ie+1 - bl(i) = al(i) - q1(i) - br(i) = al(i+1) - q1(i) - b0(i) = bl(i) + br(i) - smt5(i) = bl(i)*br(i) < 0. - enddo - else - do i=is-1,ie+1 - bl(i) = al(i) - q1(i) - br(i) = al(i+1) - q1(i) - b0(i) = bl(i) + br(i) - smt5(i) = 3.*abs(b0(i)) < abs(bl(i)-br(i)) - enddo - endif - -!DEC$ VECTOR ALWAYS - do i=is,ie+1 - if ( c(i,j) > 0. ) then - fx1(i) = (1.-c(i,j))*(br(i-1) - c(i,j)*b0(i-1)) - flux(i,j) = q1(i-1) - else - fx1(i) = (1.+c(i,j))*(bl(i) + c(i,j)*b0(i)) - flux(i,j) = q1(i) - endif - if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx1(i) - enddo - - endif - goto 666 - - else - -! Monotonic constraints: -! ord = 8: PPM with Lin's PPM fast monotone constraint -! ord = 10: PPM with Lin's modification of Huynh 2nd constraint -! ord = 13: 10 plus positive definite constraint - - do i=is-2,ie+2 - xt = 0.25*(q1(i+1) - q1(i-1)) - dm(i) = sign(min(abs(xt), max(q1(i-1), q1(i), q1(i+1)) - q1(i), & - q1(i) - min(q1(i-1), q1(i), q1(i+1))), xt) - enddo - do i=is1,ie1+1 - al(i) = 0.5*(q1(i-1)+q1(i)) + r3*(dm(i-1)-dm(i)) - enddo - - if ( iord==8 ) then - do i=is1, ie1 - xt = 2.*dm(i) - bl(i) = -sign(min(abs(xt), abs(al(i )-q1(i))), xt) - br(i) = sign(min(abs(xt), abs(al(i+1)-q1(i))), xt) - enddo - elseif ( iord==11 ) then -! This is emulation of 2nd van Leer scheme using PPM codes - do i=is1, ie1 - xt = ppm_fac*dm(i) - bl(i) = -sign(min(abs(xt), abs(al(i )-q1(i))), xt) - br(i) = sign(min(abs(xt), abs(al(i+1)-q1(i))), xt) - enddo - else - do i=is1-2, ie1+1 - dq(i) = 2.*(q1(i+1) - q1(i)) - enddo - do i=is1, ie1 - bl(i) = al(i ) - q1(i) - br(i) = al(i+1) - q1(i) - if ( abs(dm(i-1))+abs(dm(i))+abs(dm(i+1)) < near_zero ) then - bl(i) = 0. - br(i) = 0. - elseif( abs(3.*(bl(i)+br(i))) > abs(bl(i)-br(i)) ) then - pmp_2 = dq(i-1) - lac_2 = pmp_2 - 0.75*dq(i-2) - br(i) = min( max(0., pmp_2, lac_2), max(br(i), min(0., pmp_2, lac_2)) ) - pmp_1 = -dq(i) - lac_1 = pmp_1 + 0.75*dq(i+1) - bl(i) = min( max(0., pmp_1, lac_1), max(bl(i), min(0., pmp_1, lac_1)) ) - endif - enddo - endif -! Positive definite constraint: - if(iord==9 .or. iord==13) call pert_ppm(ie1-is1+1, q1(is1), bl(is1), br(is1), 0) - - if (.not. (nested .or. regional) .and. grid_type<3) then - if ( is==1 ) then - bl(0) = s14*dm(-1) + s11*(q1(-1)-q1(0)) - - xt = 0.5*(((2.*dxa(0,j)+dxa(-1,j))*q1(0)-dxa(0,j)*q1(-1))/(dxa(-1,j)+dxa(0,j)) & - + ((2.*dxa(1,j)+dxa( 2,j))*q1(1)-dxa(1,j)*q1( 2))/(dxa(1, j)+dxa(2,j))) -! if ( iord==8 .or. iord==10 ) then - xt = max(xt, min(q1(-1),q1(0),q1(1),q1(2))) - xt = min(xt, max(q1(-1),q1(0),q1(1),q1(2))) -! endif - br(0) = xt - q1(0) - bl(1) = xt - q1(1) - xt = s15*q1(1) + s11*q1(2) - s14*dm(2) - br(1) = xt - q1(1) - bl(2) = xt - q1(2) - - br(2) = al(3) - q1(2) - call pert_ppm(3, q1(0), bl(0), br(0), 1) - endif - if ( (ie+1)==npx ) then - bl(npx-2) = al(npx-2) - q1(npx-2) - - xt = s15*q1(npx-1) + s11*q1(npx-2) + s14*dm(npx-2) - br(npx-2) = xt - q1(npx-2) - bl(npx-1) = xt - q1(npx-1) - - xt = 0.5*(((2.*dxa(npx-1,j)+dxa(npx-2,j))*q1(npx-1)-dxa(npx-1,j)*q1(npx-2))/(dxa(npx-2,j)+dxa(npx-1,j)) & - + ((2.*dxa(npx, j)+dxa(npx+1,j))*q1(npx )-dxa(npx, j)*q1(npx+1))/(dxa(npx, j)+dxa(npx+1,j))) -! if ( iord==8 .or. iord==10 ) then - xt = max(xt, min(q1(npx-2),q1(npx-1),q1(npx),q1(npx+1))) - xt = min(xt, max(q1(npx-2),q1(npx-1),q1(npx),q1(npx+1))) -! endif - br(npx-1) = xt - q1(npx-1) - bl(npx ) = xt - q1(npx ) - - br(npx) = s11*(q1(npx+1)-q1(npx)) - s14*dm(npx+1) - call pert_ppm(3, q1(npx-2), bl(npx-2), br(npx-2), 1) - endif - endif - - endif - - do i=is,ie+1 - if( c(i,j)>0. ) then - flux(i,j) = q1(i-1) + (1.-c(i,j))*(br(i-1)-c(i,j)*(bl(i-1)+br(i-1))) - else - flux(i,j) = q1(i ) + (1.+c(i,j))*(bl(i )+c(i,j)*(bl(i)+br(i))) - endif - enddo - -666 continue - end subroutine xppm - - - subroutine yppm(flux, q, c, jord, ifirst,ilast, isd,ied, js,je,jsd,jed, npx, npy, dya, nested, grid_type, lim_fac,regional) - integer, INTENT(IN) :: ifirst,ilast !< Compute domain - integer, INTENT(IN) :: isd,ied, js,je,jsd,jed - integer, INTENT(IN) :: jord - integer, INTENT(IN) :: npx, npy - real , INTENT(IN) :: q(ifirst:ilast,jsd:jed) - real , intent(in) :: c(isd:ied,js:je+1 ) !< Courant number - real , INTENT(OUT):: flux(ifirst:ilast,js:je+1) !< Flux - real , intent(IN) :: dya(isd:ied,jsd:jed) - logical, intent(IN) :: nested,regional - integer, intent(IN) :: grid_type - real , intent(IN) :: lim_fac -! Local: - real:: dm(ifirst:ilast,js-2:je+2) - real:: al(ifirst:ilast,js-1:je+2) - real, dimension(ifirst:ilast,js-1:je+1):: bl, br, b0 - real:: dq(ifirst:ilast,js-3:je+2) - real, dimension(ifirst:ilast):: fx0, fx1, xt1 - logical, dimension(ifirst:ilast,js-1:je+1):: smt5, smt6 - logical, dimension(ifirst:ilast):: hi5, hi6 - real:: x0, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2, r1 - integer:: i, j, js1, je3, je1, mord - - if ( .not. (nested .or. regional) .and. grid_type < 3 ) then -! Cubed-sphere: - js1 = max(3,js-1); je3 = min(npy-2,je+2) - je1 = min(npy-3,je+1) - else -! Nested grid OR Doubly periodic domain: - js1 = js-1; je3 = je+2 - je1 = je+1 - endif - - mord = abs(jord) - -if ( jord < 8 ) then - - do j=js1, je3 - do i=ifirst,ilast - al(i,j) = p1*(q(i,j-1)+q(i,j)) + p2*(q(i,j-2)+q(i,j+1)) - enddo - enddo - - if ( .not. (nested .or. regional) .and. grid_type<3 ) then - if( js==1 ) then - do i=ifirst,ilast - al(i,0) = c1*q(i,-2) + c2*q(i,-1) + c3*q(i,0) - al(i,1) = 0.5*(((2.*dya(i,0)+dya(i,-1))*q(i,0)-dya(i,0)*q(i,-1))/(dya(i,-1)+dya(i,0)) & - + ((2.*dya(i,1)+dya(i,2))*q(i,1)-dya(i,1)*q(i,2))/(dya(i,1)+dya(i,2))) - al(i,2) = c3*q(i,1) + c2*q(i,2) + c1*q(i,3) - enddo - endif - if( (je+1)==npy ) then - do i=ifirst,ilast - al(i,npy-1) = c1*q(i,npy-3) + c2*q(i,npy-2) + c3*q(i,npy-1) - al(i,npy) = 0.5*(((2.*dya(i,npy-1)+dya(i,npy-2))*q(i,npy-1)-dya(i,npy-1)*q(i,npy-2))/(dya(i,npy-2)+dya(i,npy-1)) & - + ((2.*dya(i,npy)+dya(i,npy+1))*q(i,npy)-dya(i,npy)*q(i,npy+1))/(dya(i,npy)+dya(i,npy+1))) - al(i,npy+1) = c3*q(i,npy) + c2*q(i,npy+1) + c1*q(i,npy+2) - enddo - endif - endif - - if ( jord<0 ) then - do j=js-1, je+2 - do i=ifirst,ilast - al(i,j) = max(0., al(i,j)) - enddo - enddo - endif - - if ( mord==1 ) then - do j=js-1,je+1 - do i=ifirst,ilast - bl(i,j) = al(i,j ) - q(i,j) - br(i,j) = al(i,j+1) - q(i,j) - b0(i,j) = bl(i,j) + br(i,j) - smt5(i,j) = abs(lim_fac*b0(i,j)) < abs(bl(i,j)-br(i,j)) - enddo - enddo - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=ifirst,ilast - if ( c(i,j) > 0. ) then - fx1(i) = (1.-c(i,j))*(br(i,j-1) - c(i,j)*b0(i,j-1)) - flux(i,j) = q(i,j-1) - else - fx1(i) = (1.+c(i,j))*(bl(i,j) + c(i,j)*b0(i,j)) - flux(i,j) = q(i,j) - endif - if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx1(i) - enddo - enddo - - elseif ( mord==2 ) then ! Perfectly linear scheme -! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7 - - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=ifirst,ilast - xt = c(i,j) - if ( xt > 0. ) then - qtmp = q(i,j-1) - flux(i,j) = qtmp + (1.-xt)*(al(i,j)-qtmp-xt*(al(i,j-1)+al(i,j)-(qtmp+qtmp))) - else - qtmp = q(i,j) - flux(i,j) = qtmp + (1.+xt)*(al(i,j)-qtmp+xt*(al(i,j)+al(i,j+1)-(qtmp+qtmp))) - endif - enddo - enddo - - elseif ( mord==3 ) then - - do j=js-1,je+1 - do i=ifirst,ilast - bl(i,j) = al(i,j ) - q(i,j) - br(i,j) = al(i,j+1) - q(i,j) - b0(i,j) = bl(i,j) + br(i,j) - x0 = abs(b0(i,j)) - xt = abs(bl(i,j)-br(i,j)) - smt5(i,j) = x0 < xt - smt6(i,j) = 3.*x0 < xt - enddo - enddo - do j=js,je+1 - do i=ifirst,ilast - fx1(i) = 0. - xt1(i) = c(i,j) - hi5(i) = smt5(i,j-1) .and. smt5(i,j) - hi6(i) = smt6(i,j-1) .or. smt6(i,j) - enddo - do i=ifirst,ilast - if ( xt1(i) > 0. ) then - if( hi6(i) ) then - fx1(i) = br(i,j-1) - xt1(i)*b0(i,j-1) - elseif ( hi5(i) ) then ! both up-downwind sides are noisy; 2nd order, piece-wise linear - fx1(i) = sign(min(abs(bl(i,j-1)),abs(br(i,j-1))),br(i,j-1)) - endif - flux(i,j) = q(i,j-1) + (1.-xt1(i))*fx1(i) - else - if( hi6(i) ) then - fx1(i) = bl(i,j) + xt1(i)*b0(i,j) - elseif ( hi5(i) ) then ! both up-downwind sides are noisy; 2nd order, piece-wise linear - fx1(i) = sign(min(abs(bl(i,j)),abs(br(i,j))), bl(i,j)) - endif - flux(i,j) = q(i,j) + (1.+xt1(i))*fx1(i) - endif - enddo - enddo - - elseif ( mord==4 ) then - - do j=js-1,je+1 - do i=ifirst,ilast - bl(i,j) = al(i,j ) - q(i,j) - br(i,j) = al(i,j+1) - q(i,j) - b0(i,j) = bl(i,j) + br(i,j) - x0 = abs(b0(i,j)) - xt = abs(bl(i,j)-br(i,j)) - smt5(i,j) = x0 < xt - smt6(i,j) = 3.*x0 < xt - enddo - enddo - do j=js,je+1 - do i=ifirst,ilast - xt1(i) = c(i,j) - hi5(i) = smt5(i,j-1) .and. smt5(i,j) - hi6(i) = smt6(i,j-1) .or. smt6(i,j) - hi5(i) = hi5(i) .or. hi6(i) - enddo -!DEC$ VECTOR ALWAYS - do i=ifirst,ilast - if ( xt1(i) > 0. ) then - fx1(i) = (1.-xt1(i))*(br(i,j-1) - xt1(i)*b0(i,j-1)) - flux(i,j) = q(i,j-1) - else - fx1(i) = (1.+xt1(i))*(bl(i,j) + xt1(i)*b0(i,j)) - flux(i,j) = q(i,j) - endif - if ( hi5(i) ) flux(i,j) = flux(i,j) + fx1(i) - enddo - enddo - - else ! mord=5,6,7 - if ( mord==5 ) then - do j=js-1,je+1 - do i=ifirst,ilast - bl(i,j) = al(i,j ) - q(i,j) - br(i,j) = al(i,j+1) - q(i,j) - b0(i,j) = bl(i,j) + br(i,j) - smt5(i,j) = bl(i,j)*br(i,j) < 0. - enddo - enddo - else - do j=js-1,je+1 - do i=ifirst,ilast - bl(i,j) = al(i,j ) - q(i,j) - br(i,j) = al(i,j+1) - q(i,j) - b0(i,j) = bl(i,j) + br(i,j) - smt5(i,j) = 3.*abs(b0(i,j)) < abs(bl(i,j)-br(i,j)) - enddo - enddo - endif - - do j=js,je+1 -!DEC$ VECTOR ALWAYS - do i=ifirst,ilast - if ( c(i,j) > 0. ) then - fx1(i) = (1.-c(i,j))*(br(i,j-1) - c(i,j)*b0(i,j-1)) - flux(i,j) = q(i,j-1) - else - fx1(i) = (1.+c(i,j))*(bl(i,j) + c(i,j)*b0(i,j)) - flux(i,j) = q(i,j) - endif - if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx1(i) - enddo - enddo - - endif - return - -else -! Monotonic constraints: -! ord = 8: PPM with Lin's PPM fast monotone constraint -! ord > 8: PPM with Lin's modification of Huynh 2nd constraint - - do j=js-2,je+2 - do i=ifirst,ilast - xt = 0.25*(q(i,j+1) - q(i,j-1)) - dm(i,j) = sign(min(abs(xt), max(q(i,j-1), q(i,j), q(i,j+1)) - q(i,j), & - q(i,j) - min(q(i,j-1), q(i,j), q(i,j+1))), xt) - enddo - enddo - do j=js1,je1+1 - do i=ifirst,ilast - al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j)) - enddo - enddo - - if ( jord==8 ) then - do j=js1,je1 - do i=ifirst,ilast - xt = 2.*dm(i,j) - bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-q(i,j))), xt) - br(i,j) = sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt) - enddo - enddo - elseif ( jord==11 ) then - do j=js1,je1 - do i=ifirst,ilast - xt = ppm_fac*dm(i,j) - bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-q(i,j))), xt) - br(i,j) = sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt) - enddo - enddo - else - do j=js1-2,je1+1 - do i=ifirst,ilast - dq(i,j) = 2.*(q(i,j+1) - q(i,j)) - enddo - enddo - do j=js1,je1 - do i=ifirst,ilast - bl(i,j) = al(i,j ) - q(i,j) - br(i,j) = al(i,j+1) - q(i,j) - if ( abs(dm(i,j-1))+abs(dm(i,j))+abs(dm(i,j+1)) < near_zero ) then - bl(i,j) = 0. - br(i,j) = 0. - elseif( abs(3.*(bl(i,j)+br(i,j))) > abs(bl(i,j)-br(i,j)) ) then - pmp_2 = dq(i,j-1) - lac_2 = pmp_2 - 0.75*dq(i,j-2) - br(i,j) = min(max(0.,pmp_2,lac_2), max(br(i,j), min(0.,pmp_2,lac_2))) - pmp_1 = -dq(i,j) - lac_1 = pmp_1 + 0.75*dq(i,j+1) - bl(i,j) = min(max(0.,pmp_1,lac_1), max(bl(i,j), min(0.,pmp_1,lac_1))) - endif - enddo - enddo - endif - if ( jord==9 .or. jord==13 ) then -! Positive definite constraint: - do j=js1,je1 - call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 0) - enddo - endif - - if (.not. (nested .or. regional) .and. grid_type<3) then - if( js==1 ) then - do i=ifirst,ilast - bl(i,0) = s14*dm(i,-1) + s11*(q(i,-1)-q(i,0)) - - xt = 0.5*(((2.*dya(i,0)+dya(i,-1))*q(i,0)-dya(i,0)*q(i,-1))/(dya(i,-1)+dya(i,0)) & - + ((2.*dya(i,1)+dya(i,2))*q(i,1)-dya(i,1)*q(i,2))/(dya(i,1)+dya(i,2))) -! if ( jord==8 .or. jord==10 ) then - xt = max(xt, min(q(i,-1),q(i,0),q(i,1),q(i,2))) - xt = min(xt, max(q(i,-1),q(i,0),q(i,1),q(i,2))) -! endif - br(i,0) = xt - q(i,0) - bl(i,1) = xt - q(i,1) - - xt = s15*q(i,1) + s11*q(i,2) - s14*dm(i,2) - br(i,1) = xt - q(i,1) - bl(i,2) = xt - q(i,2) - - br(i,2) = al(i,3) - q(i,2) - enddo - call pert_ppm(3*(ilast-ifirst+1), q(ifirst,0), bl(ifirst,0), br(ifirst,0), 1) - endif - if( (je+1)==npy ) then - do i=ifirst,ilast - bl(i,npy-2) = al(i,npy-2) - q(i,npy-2) - - xt = s15*q(i,npy-1) + s11*q(i,npy-2) + s14*dm(i,npy-2) - br(i,npy-2) = xt - q(i,npy-2) - bl(i,npy-1) = xt - q(i,npy-1) - - xt = 0.5*(((2.*dya(i,npy-1)+dya(i,npy-2))*q(i,npy-1)-dya(i,npy-1)*q(i,npy-2))/(dya(i,npy-2)+dya(i,npy-1)) & - + ((2.*dya(i,npy)+dya(i,npy+1))*q(i,npy)-dya(i,npy)*q(i,npy+1))/(dya(i,npy)+dya(i,npy+1))) -! if ( jord==8 .or. jord==10 ) then - xt = max(xt, min(q(i,npy-2),q(i,npy-1),q(i,npy),q(i,npy+1))) - xt = min(xt, max(q(i,npy-2),q(i,npy-1),q(i,npy),q(i,npy+1))) -! endif - br(i,npy-1) = xt - q(i,npy-1) - bl(i,npy ) = xt - q(i,npy) - - br(i,npy) = s11*(q(i,npy+1)-q(i,npy)) - s14*dm(i,npy+1) - enddo - call pert_ppm(3*(ilast-ifirst+1), q(ifirst,npy-2), bl(ifirst,npy-2), br(ifirst,npy-2), 1) - endif - end if - -endif - - do j=js,je+1 - do i=ifirst,ilast - if( c(i,j)>0. ) then - flux(i,j) = q(i,j-1) + (1.-c(i,j))*(br(i,j-1)-c(i,j)*(bl(i,j-1)+br(i,j-1))) - else - flux(i,j) = q(i,j ) + (1.+c(i,j))*(bl(i,j )+c(i,j)*(bl(i,j)+br(i,j))) - endif - enddo - enddo - end subroutine yppm - - - - subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, & - kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q) -! -! !INPUT PARAMETERS: - integer, intent(in):: im, jm, km, nq - integer, intent(in):: ifirst, ilast - integer, intent(in):: jfirst, jlast - integer, intent(in):: kfirst, klast - integer, intent(in):: ng_e !< eastern zones to ghost - integer, intent(in):: ng_w !< western zones to ghost - integer, intent(in):: ng_s !< southern zones to ghost - integer, intent(in):: ng_n !< northern zones to ghost - real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq) - real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq) -! -! !DESCRIPTION: -! -! Ghost 4d east/west -! -! !REVISION HISTORY: -! 2005.08.22 Putman -! -!EOP -!------------------------------------------------------------------------------ -!BOC - integer :: i,j,k,n - - if (present(q)) then - q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = & - q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) - endif - -! Assume Periodicity in X-dir and not overlapping - do n=1,nq - do k=kfirst,klast - do j=jfirst-ng_s,jlast+ng_n - do i=1, ng_w - q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n) - enddo - do i=1, ng_e - q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n) - enddo - enddo - enddo - enddo - - end subroutine mp_ghost_ew - - - - subroutine pert_ppm(im, a0, al, ar, iv) - integer, intent(in):: im - integer, intent(in):: iv - real, intent(in) :: a0(im) - real, intent(inout):: al(im), ar(im) -! Local: - real a4, da1, da2, a6da, fmin - integer i - real, parameter:: r12 = 1./12. - -!----------------------------------- -! Optimized PPM in perturbation form: -!----------------------------------- - - if ( iv==0 ) then -! Positive definite constraint - do i=1,im - if ( a0(i) <= 0. ) then - al(i) = 0. - ar(i) = 0. - else - a4 = -3.*(ar(i) + al(i)) - da1 = ar(i) - al(i) - if( abs(da1) < -a4 ) then - fmin = a0(i) + 0.25/a4*da1**2 + a4*r12 - if( fmin < 0. ) then - if( ar(i)>0. .and. al(i)>0. ) then - ar(i) = 0. - al(i) = 0. - elseif( da1 > 0. ) then - ar(i) = -2.*al(i) - else - al(i) = -2.*ar(i) - endif - endif - endif - endif - enddo - else -! Standard PPM constraint - do i=1,im - if ( al(i)*ar(i) < 0. ) then - da1 = al(i) - ar(i) - da2 = da1**2 - a6da = 3.*(al(i)+ar(i))*da1 -! abs(a6da) > da2 --> 3.*abs(al+ar) > abs(al-ar) - if( a6da < -da2 ) then - ar(i) = -2.*al(i) - elseif( a6da > da2 ) then - al(i) = -2.*ar(i) - endif - else -! effect of dm=0 included here - al(i) = 0. - ar(i) = 0. - endif - enddo - endif - - end subroutine pert_ppm - - - subroutine deln_flux(nord,is,ie,js,je, npx, npy, damp, q, fx, fy, gridstruct,regional, bd, mass ) -!> Del-n damping for the cell-mean values (A grid) -!------------------ -!> nord = 0: del-2 -!> nord = 1: del-4 -!> nord = 2: del-6 -!> nord = 3: del-8 --> requires more ghosting than current -!------------------ - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: nord !< del-n - integer, intent(in):: is,ie,js,je, npx, npy - real, intent(in):: damp - real, intent(in):: q(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng) ! q ghosted on input - type(fv_grid_type), intent(IN), target :: gridstruct - logical, intent(in):: regional - real, optional, intent(in):: mass(bd%isd:bd%ied, bd%jsd:bd%jed) ! q ghosted on input -! diffusive fluxes: - real, intent(inout):: fx(bd%is:bd%ie+1,bd%js:bd%je), fy(bd%is:bd%ie,bd%js:bd%je+1) -! local: - real fx2(bd%isd:bd%ied+1,bd%jsd:bd%jed), fy2(bd%isd:bd%ied,bd%jsd:bd%jed+1) - real d2(bd%isd:bd%ied,bd%jsd:bd%jed) - real damp2 - integer i,j, n, nt, i1, i2, j1, j2 - -#ifdef USE_SG - real, pointer, dimension(:,:) :: dx, dy, rdxc, rdyc - real, pointer, dimension(:,:,:) :: sin_sg - dx => gridstruct%dx - dy => gridstruct%dy - rdxc => gridstruct%rdxc - rdyc => gridstruct%rdyc - sin_sg => gridstruct%sin_sg -#endif - - i1 = is-1-nord; i2 = ie+1+nord - j1 = js-1-nord; j2 = je+1+nord - - if ( .not. present(mass) ) then - do j=j1, j2 - do i=i1,i2 - d2(i,j) = damp*q(i,j) - enddo - enddo - else - do j=j1, j2 - do i=i1,i2 - d2(i,j) = q(i,j) - enddo - enddo - endif - - if( nord>0 .and. (.not. (regional))) call copy_corners(d2, npx, npy, 1, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - - do j=js-nord,je+nord - do i=is-nord,ie+nord+1 -#ifdef USE_SG - fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i-1,j)-d2(i,j))*rdxc(i,j) -#else - fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i-1,j)-d2(i,j)) -#endif - enddo - enddo - - if( nord>0 .and. (.not. (regional))) call copy_corners(d2, npx, npy, 2, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - do j=js-nord,je+nord+1 - do i=is-nord,ie+nord -#ifdef USE_SG - fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j-1)-d2(i,j))*rdyc(i,j) -#else - fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j-1)-d2(i,j)) -#endif - enddo - enddo - - if ( nord>0 ) then - -!---------- -! high-order -!---------- - - do n=1, nord - - nt = nord-n - - do j=js-nt-1,je+nt+1 - do i=is-nt-1,ie+nt+1 - d2(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*gridstruct%rarea(i,j) - enddo - enddo - - if (.not.(regional))call copy_corners(d2, npx, npy, 1, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - do j=js-nt,je+nt - do i=is-nt,ie+nt+1 -#ifdef USE_SG - fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i,j)-d2(i-1,j))*rdxc(i,j) -#else - fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i,j)-d2(i-1,j)) -#endif - enddo - enddo - - if (.not.(regional)) call copy_corners(d2, npx, npy, 2, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - do j=js-nt,je+nt+1 - do i=is-nt,ie+nt -#ifdef USE_SG - fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j)-d2(i,j-1))*rdyc(i,j) -#else - fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j)-d2(i,j-1)) -#endif - enddo - enddo - enddo - - endif - -!--------------------------------------------- -! Add the diffusive fluxes to the flux arrays: -!--------------------------------------------- - - if ( present(mass) ) then -! Apply mass weighting to diffusive fluxes: - damp2 = 0.5*damp - do j=js,je - do i=is,ie+1 - fx(i,j) = fx(i,j) + damp2*(mass(i-1,j)+mass(i,j))*fx2(i,j) - enddo - enddo - do j=js,je+1 - do i=is,ie - fy(i,j) = fy(i,j) + damp2*(mass(i,j-1)+mass(i,j))*fy2(i,j) - enddo - enddo - else - do j=js,je - do i=is,ie+1 - fx(i,j) = fx(i,j) + fx2(i,j) - enddo - enddo - do j=js,je+1 - do i=is,ie - fy(i,j) = fy(i,j) + fy2(i,j) - enddo - enddo - endif - - end subroutine deln_flux - - -end module tp_core_mod +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'tp_core' is a collection of routines to support FV transport. +!>@details The module contains the scalar advection scheme and PPM operators. +module tp_core_mod + +! Modules Included: +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
Module NameFunctions Included
fv_mp_modng
fv_grid_utils_modbig_number
fv_arrays_modfv_grid_type, fv_grid_bounds_type
field_manager_modfm_path_name_len, fm_string_len, fm_exists, fm_get_index, fm_new_list, fm_get_current_list, +! fm_change_list, fm_field_name_len, fm_type_name_len, fm_dump_list, fm_loop_over_list
+ + use fv_grid_utils_mod, only: big_number + use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type + + implicit none + + private + public fv_tp_2d, pert_ppm, copy_corners + + real, parameter:: ppm_fac = 1.5 !< nonlinear scheme limiter: between 1 and 2 + real, parameter:: r3 = 1./3. + real, parameter:: near_zero = 1.E-25 + real, parameter:: ppm_limiter = 2.0 + +#ifdef WAVE_FORM +! Suresh & Huynh scheme 2.2 (purtabation form) +! The wave-form is more diffusive than scheme 2.1 + real, parameter:: b1 = 0.0375 + real, parameter:: b2 = -7./30. + real, parameter:: b3 = -23./120. + real, parameter:: b4 = 13./30. + real, parameter:: b5 = -11./240. +#else +! scheme 2.1: perturbation form + real, parameter:: b1 = 1./30. + real, parameter:: b2 = -13./60. + real, parameter:: b3 = -13./60. + real, parameter:: b4 = 0.45 + real, parameter:: b5 = -0.05 +#endif + real, parameter:: t11 = 27./28., t12 = -13./28., t13=3./7. + real, parameter:: s11 = 11./14., s14 = 4./7., s15=3./14. +!---------------------------------------------------- +! volume-conserving cubic with 2nd drv=0 at end point: +!---------------------------------------------------- +! Non-monotonic + real, parameter:: c1 = -2./14. + real, parameter:: c2 = 11./14. + real, parameter:: c3 = 5./14. +!---------------------- +! PPM volume mean form: +!---------------------- + real, parameter:: p1 = 7./12. ! 0.58333333 + real, parameter:: p2 = -1./12. +! q(i+0.5) = p1*(q(i-1)+q(i)) + p2*(q(i-2)+q(i+1)) +! integer:: is, ie, js, je, isd, ied, jsd, jed + +! +!EOP +!----------------------------------------------------------------------- + +contains + +!>@brief The subroutine 'fv_tp_2d' contains the FV advection scheme +!! \cite putman2007finite \cite lin1996multiflux. +!>@details It performs 1 time step of the forward advection. + subroutine fv_tp_2d(q, crx, cry, npx, npy, hord, fx, fy, xfx, yfx, & + gridstruct, bd, ra_x, ra_y, lim_fac, mfx, mfy, mass, nord, damp_c) + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: npx, npy + integer, intent(in)::hord + + real, intent(in):: crx(bd%is:bd%ie+1,bd%jsd:bd%jed) + real, intent(in):: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed) + real, intent(in):: cry(bd%isd:bd%ied,bd%js:bd%je+1 ) + real, intent(in):: yfx(bd%isd:bd%ied,bd%js:bd%je+1 ) + real, intent(in):: ra_x(bd%is:bd%ie,bd%jsd:bd%jed) + real, intent(in):: ra_y(bd%isd:bd%ied,bd%js:bd%je) + real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed) !< transported scalar + real, intent(out)::fx(bd%is:bd%ie+1 ,bd%js:bd%je) !< Flux in x ( E ) + real, intent(out)::fy(bd%is:bd%ie, bd%js:bd%je+1 ) !< Flux in y ( N ) + + type(fv_grid_type), intent(IN), target :: gridstruct + + real, intent(in):: lim_fac +! optional Arguments: + real, OPTIONAL, intent(in):: mfx(bd%is:bd%ie+1,bd%js:bd%je ) !< Mass Flux X-Dir + real, OPTIONAL, intent(in):: mfy(bd%is:bd%ie ,bd%js:bd%je+1) !< Mass Flux Y-Dir + real, OPTIONAL, intent(in):: mass(bd%isd:bd%ied,bd%jsd:bd%jed) + real, OPTIONAL, intent(in):: damp_c + integer, OPTIONAL, intent(in):: nord !< order of divergence damping +! Local: + integer ord_ou, ord_in + real q_i(bd%isd:bd%ied,bd%js:bd%je) + real q_j(bd%is:bd%ie,bd%jsd:bd%jed) + real fx2(bd%is:bd%ie+1,bd%jsd:bd%jed) + real fy2(bd%isd:bd%ied,bd%js:bd%je+1) + real fyy(bd%isd:bd%ied,bd%js:bd%je+1) + real fx1(bd%is:bd%ie+1) + real damp + integer i, j + + integer:: is, ie, js, je, isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if ( hord == 10 ) then + ord_in = 8 + else + ord_in = hord + endif + ord_ou = hord + + if (.not. gridstruct%bounded_domain) & + call copy_corners(q, npx, npy, 2, gridstruct%bounded_domain, bd, & + gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + + call yppm(fy2, q, cry, ord_in, isd,ied,isd,ied, js,je,jsd,jed, npx,npy, gridstruct%dya, gridstruct%bounded_domain, gridstruct%grid_type, lim_fac) + + do j=js,je+1 + do i=isd,ied + fyy(i,j) = yfx(i,j) * fy2(i,j) + enddo + enddo + do j=js,je + do i=isd,ied + q_i(i,j) = (q(i,j)*gridstruct%area(i,j) + fyy(i,j)-fyy(i,j+1))/ra_y(i,j) + enddo + enddo + + call xppm(fx, q_i, crx(is,js), ord_ou, is,ie,isd,ied, js,je,jsd,jed, npx,npy, gridstruct%dxa, gridstruct%bounded_domain, gridstruct%grid_type, lim_fac) + + if (.not. gridstruct%bounded_domain) & + call copy_corners(q, npx, npy, 1, gridstruct%bounded_domain, bd, & + gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + + call xppm(fx2, q, crx, ord_in, is,ie,isd,ied, jsd,jed,jsd,jed, npx,npy, gridstruct%dxa, gridstruct%bounded_domain, gridstruct%grid_type, lim_fac) + + do j=jsd,jed + do i=is,ie+1 + fx1(i) = xfx(i,j) * fx2(i,j) + enddo + do i=is,ie + q_j(i,j) = (q(i,j)*gridstruct%area(i,j) + fx1(i)-fx1(i+1))/ra_x(i,j) + enddo + enddo + + call yppm(fy, q_j, cry, ord_ou, is,ie,isd,ied, js,je,jsd,jed, npx, npy, gridstruct%dya, gridstruct%bounded_domain, gridstruct%grid_type, lim_fac) + +!---------------- +! Flux averaging: +!---------------- + + if ( present(mfx) .and. present(mfy) ) then +!--------------------------------- +! For transport of pt and tracers +!--------------------------------- + do j=js,je + do i=is,ie+1 + fx(i,j) = 0.5*(fx(i,j) + fx2(i,j)) * mfx(i,j) + enddo + enddo + do j=js,je+1 + do i=is,ie + fy(i,j) = 0.5*(fy(i,j) + fy2(i,j)) * mfy(i,j) + enddo + enddo + if ( present(nord) .and. present(damp_c) .and. present(mass) ) then + if ( damp_c > 1.e-4 ) then + damp = (damp_c * gridstruct%da_min)**(nord+1) + call deln_flux(nord, is,ie,js,je, npx, npy, damp, q, fx, fy, gridstruct, bd, mass ) + endif + endif + else +!--------------------------------- +! For transport of delp, vorticity +!--------------------------------- + do j=js,je + do i=is,ie+1 + fx(i,j) = 0.5*(fx(i,j) + fx2(i,j)) * xfx(i,j) + enddo + enddo + do j=js,je+1 + do i=is,ie + fy(i,j) = 0.5*(fy(i,j) + fy2(i,j)) * yfx(i,j) + enddo + enddo + if ( present(nord) .and. present(damp_c) ) then + if ( damp_c > 1.E-4 ) then + damp = (damp_c * gridstruct%da_min)**(nord+1) + call deln_flux(nord, is,ie,js,je, npx, npy, damp, q, fx, fy, gridstruct, bd) + endif + endif + endif + end subroutine fv_tp_2d + + !Weird arguments are because this routine is called in a lot of + !places outside of tp_core, sometimes very deeply nested in the call tree. + subroutine copy_corners(q, npx, npy, dir, bounded_domain, bd, & + sw_corner, se_corner, nw_corner, ne_corner) + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: npx, npy, dir + real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed) + logical, intent(IN) :: bounded_domain, sw_corner, se_corner, nw_corner, ne_corner + integer i,j, ng + + ng = bd%ng + + if (bounded_domain) return + + if ( dir == 1 ) then +! XDir: + if ( sw_corner ) then + do j=1-ng,0 + do i=1-ng,0 + q(i,j) = q(j,1-i) + enddo + enddo + endif + if ( se_corner ) then + do j=1-ng,0 + do i=npx,npx+ng-1 + q(i,j) = q(npy-j,i-npx+1) + enddo + enddo + endif + if ( ne_corner ) then + do j=npy,npy+ng-1 + do i=npx,npx+ng-1 + q(i,j) = q(j,2*npx-1-i) + enddo + enddo + endif + if ( nw_corner ) then + do j=npy,npy+ng-1 + do i=1-ng,0 + q(i,j) = q(npy-j,i-1+npx) + enddo + enddo + endif + + elseif ( dir == 2 ) then +! YDir: + + if ( sw_corner ) then + do j=1-ng,0 + do i=1-ng,0 + q(i,j) = q(1-j,i) + enddo + enddo + endif + if ( se_corner ) then + do j=1-ng,0 + do i=npx,npx+ng-1 + q(i,j) = q(npy+j-1,npx-i) + enddo + enddo + endif + if ( ne_corner ) then + do j=npy,npy+ng-1 + do i=npx,npx+ng-1 + q(i,j) = q(2*npy-1-j,i) + enddo + enddo + endif + if ( nw_corner ) then + do j=npy,npy+ng-1 + do i=1-ng,0 + q(i,j) = q(j+1-npx,npy-i) + enddo + enddo + endif + + endif + + end subroutine copy_corners + + subroutine xppm(flux, q, c, iord, is,ie,isd,ied, jfirst,jlast,jsd,jed, npx, npy, dxa, bounded_domain, grid_type, lim_fac) + integer, INTENT(IN) :: is, ie, isd, ied, jsd, jed + integer, INTENT(IN) :: jfirst, jlast !< compute domain + integer, INTENT(IN) :: iord + integer, INTENT(IN) :: npx, npy + real , INTENT(IN) :: q(isd:ied,jfirst:jlast) + real , INTENT(IN) :: c(is:ie+1,jfirst:jlast) !< Courant N (like FLUX) + real , intent(IN) :: dxa(isd:ied,jsd:jed) + logical, intent(IN) :: bounded_domain + integer, intent(IN) :: grid_type + real , intent(IN) :: lim_fac +!OUTPUT PARAMETERS: + real , INTENT(OUT) :: flux(is:ie+1,jfirst:jlast) !< Flux +! Local + real, dimension(is-1:ie+1):: bl, br, b0 + real:: q1(isd:ied) + real, dimension(is:ie+1):: fx0, fx1, xt1 + logical, dimension(is-1:ie+1):: smt5, smt6 + logical, dimension(is:ie+1):: hi5, hi6 + real al(is-1:ie+2) + real dm(is-2:ie+2) + real dq(is-3:ie+2) + integer:: i, j, ie3, is1, ie1, mord + real:: x0, x1, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2 + + if ( .not. bounded_domain .and. grid_type<3 ) then + is1 = max(3,is-1); ie3 = min(npx-2,ie+2) + ie1 = min(npx-3,ie+1) + else + is1 = is-1; ie3 = ie+2 + ie1 = ie+1 + end if + mord = abs(iord) + + do 666 j=jfirst,jlast + + do i=isd, ied + q1(i) = q(i,j) + enddo + + if ( iord < 8 ) then +! ord = 2: perfectly linear ppm scheme +! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 + + do i=is1, ie3 + al(i) = p1*(q1(i-1)+q1(i)) + p2*(q1(i-2)+q1(i+1)) + enddo + + if ( .not. bounded_domain .and. grid_type<3 ) then + if ( is==1 ) then + al(0) = c1*q1(-2) + c2*q1(-1) + c3*q1(0) + al(1) = 0.5*(((2.*dxa(0,j)+dxa(-1,j))*q1(0)-dxa(0,j)*q1(-1))/(dxa(-1,j)+dxa(0,j)) & + + ((2.*dxa(1,j)+dxa( 2,j))*q1(1)-dxa(1,j)*q1( 2))/(dxa(1, j)+dxa(2,j))) + al(2) = c3*q1(1) + c2*q1(2) +c1*q1(3) + endif + if ( (ie+1)==npx ) then + al(npx-1) = c1*q1(npx-3) + c2*q1(npx-2) + c3*q1(npx-1) + al(npx) = 0.5*(((2.*dxa(npx-1,j)+dxa(npx-2,j))*q1(npx-1)-dxa(npx-1,j)*q1(npx-2))/(dxa(npx-2,j)+dxa(npx-1,j)) & + + ((2.*dxa(npx, j)+dxa(npx+1,j))*q1(npx )-dxa(npx, j)*q1(npx+1))/(dxa(npx, j)+dxa(npx+1,j))) + al(npx+1) = c3*q1(npx) + c2*q1(npx+1) + c1*q1(npx+2) + endif + endif + + if ( iord<0 ) then + do i=is-1, ie+2 + al(i) = max(0., al(i)) + enddo + endif + + if ( mord==1 ) then ! perfectly linear scheme + do i=is-1,ie+1 + bl(i) = al(i) - q1(i) + br(i) = al(i+1) - q1(i) + b0(i) = bl(i) + br(i) + smt5(i) = abs(lim_fac*b0(i)) < abs(bl(i)-br(i)) + enddo +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if ( c(i,j) > 0. ) then + fx1(i) = (1.-c(i,j))*(br(i-1) - c(i,j)*b0(i-1)) + flux(i,j) = q1(i-1) + else + fx1(i) = (1.+c(i,j))*(bl(i) + c(i,j)*b0(i)) + flux(i,j) = q1(i) + endif + if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx1(i) + enddo + + elseif ( mord==2 ) then ! perfectly linear scheme + +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + xt = c(i,j) + if ( xt > 0. ) then + qtmp = q1(i-1) + flux(i,j) = qtmp + (1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-(qtmp+qtmp))) + else + qtmp = q1(i) + flux(i,j) = qtmp + (1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-(qtmp+qtmp))) + endif +! x0 = sign(dim(xt, 0.), 1.) +! x1 = sign(dim(0., xt), 1.) +! flux(i,j) = x0*(q1(i-1)+(1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-(qtmp+qtmp)))) & +! + x1*(q1(i) +(1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-(qtmp+qtmp)))) + enddo + + elseif ( mord==3 ) then + + do i=is-1,ie+1 + bl(i) = al(i) - q1(i) + br(i) = al(i+1) - q1(i) + b0(i) = bl(i) + br(i) + x0 = abs(b0(i)) + xt = abs(bl(i)-br(i)) + smt5(i) = x0 < xt + smt6(i) = 3.*x0 < xt + enddo + do i=is,ie+1 + fx1(i) = 0. + xt1(i) = c(i,j) + hi5(i) = smt5(i-1) .and. smt5(i) ! more diffusive + hi6(i) = smt6(i-1) .or. smt6(i) + enddo + do i=is,ie+1 + if ( xt1(i) > 0. ) then + if ( hi6(i) ) then + fx1(i) = br(i-1) - xt1(i)*b0(i-1) + elseif ( hi5(i) ) then ! 2nd order, piece-wise linear + fx1(i) = sign(min(abs(bl(i-1)),abs(br(i-1))), br(i-1)) + endif + flux(i,j) = q1(i-1) + (1.-xt1(i))*fx1(i) + else + if ( hi6(i) ) then + fx1(i) = bl(i) + xt1(i)*b0(i) + elseif ( hi5(i) ) then ! 2nd order, piece-wise linear + fx1(i) = sign(min(abs(bl(i)), abs(br(i))), bl(i)) + endif + flux(i,j) = q1(i) + (1.+xt1(i))*fx1(i) + endif + enddo + + elseif ( mord==4 ) then + + do i=is-1,ie+1 + bl(i) = al(i) - q1(i) + br(i) = al(i+1) - q1(i) + b0(i) = bl(i) + br(i) + x0 = abs(b0(i)) + xt = abs(bl(i)-br(i)) + smt5(i) = x0 < xt + smt6(i) = 3.*x0 < xt + enddo + do i=is,ie+1 + xt1(i) = c(i,j) + hi5(i) = smt5(i-1) .and. smt5(i) ! more diffusive + hi6(i) = smt6(i-1) .or. smt6(i) + hi5(i) = hi5(i) .or. hi6(i) + enddo +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if ( xt1(i) > 0. ) then + fx1(i) = (1.-xt1(i))*(br(i-1) - xt1(i)*b0(i-1)) + flux(i,j) = q1(i-1) + else + fx1(i) = (1.+xt1(i))*(bl(i) + xt1(i)*b0(i)) + flux(i,j) = q1(i) + endif + if ( hi5(i) ) flux(i,j) = flux(i,j) + fx1(i) + enddo + + else + + if ( mord==5 ) then + do i=is-1,ie+1 + bl(i) = al(i) - q1(i) + br(i) = al(i+1) - q1(i) + b0(i) = bl(i) + br(i) + smt5(i) = bl(i)*br(i) < 0. + enddo + else + do i=is-1,ie+1 + bl(i) = al(i) - q1(i) + br(i) = al(i+1) - q1(i) + b0(i) = bl(i) + br(i) + smt5(i) = 3.*abs(b0(i)) < abs(bl(i)-br(i)) + enddo + endif + +!DEC$ VECTOR ALWAYS + do i=is,ie+1 + if ( c(i,j) > 0. ) then + fx1(i) = (1.-c(i,j))*(br(i-1) - c(i,j)*b0(i-1)) + flux(i,j) = q1(i-1) + else + fx1(i) = (1.+c(i,j))*(bl(i) + c(i,j)*b0(i)) + flux(i,j) = q1(i) + endif + if (smt5(i-1).or.smt5(i)) flux(i,j) = flux(i,j) + fx1(i) + enddo + + endif + goto 666 + + else + +! Monotonic constraints: +! ord = 8: PPM with Lin's PPM fast monotone constraint +! ord = 10: PPM with Lin's modification of Huynh 2nd constraint +! ord = 13: 10 plus positive definite constraint + + do i=is-2,ie+2 + xt = 0.25*(q1(i+1) - q1(i-1)) + dm(i) = sign(min(abs(xt), max(q1(i-1), q1(i), q1(i+1)) - q1(i), & + q1(i) - min(q1(i-1), q1(i), q1(i+1))), xt) + enddo + do i=is1,ie1+1 + al(i) = 0.5*(q1(i-1)+q1(i)) + r3*(dm(i-1)-dm(i)) + enddo + + if ( iord==8 ) then + do i=is1, ie1 + xt = 2.*dm(i) + bl(i) = -sign(min(abs(xt), abs(al(i )-q1(i))), xt) + br(i) = sign(min(abs(xt), abs(al(i+1)-q1(i))), xt) + enddo + elseif ( iord==11 ) then +! This is emulation of 2nd van Leer scheme using PPM codes + do i=is1, ie1 + xt = ppm_fac*dm(i) + bl(i) = -sign(min(abs(xt), abs(al(i )-q1(i))), xt) + br(i) = sign(min(abs(xt), abs(al(i+1)-q1(i))), xt) + enddo + else + do i=is1-2, ie1+1 + dq(i) = 2.*(q1(i+1) - q1(i)) + enddo + do i=is1, ie1 + bl(i) = al(i ) - q1(i) + br(i) = al(i+1) - q1(i) + if ( abs(dm(i-1))+abs(dm(i))+abs(dm(i+1)) < near_zero ) then + bl(i) = 0. + br(i) = 0. + elseif( abs(3.*(bl(i)+br(i))) > abs(bl(i)-br(i)) ) then + pmp_2 = dq(i-1) + lac_2 = pmp_2 - 0.75*dq(i-2) + br(i) = min( max(0., pmp_2, lac_2), max(br(i), min(0., pmp_2, lac_2)) ) + pmp_1 = -dq(i) + lac_1 = pmp_1 + 0.75*dq(i+1) + bl(i) = min( max(0., pmp_1, lac_1), max(bl(i), min(0., pmp_1, lac_1)) ) + endif + enddo + endif +! Positive definite constraint: + if(iord==9 .or. iord==13) call pert_ppm(ie1-is1+1, q1(is1), bl(is1), br(is1), 0) + + if (.not. bounded_domain .and. grid_type<3) then + if ( is==1 ) then + bl(0) = s14*dm(-1) + s11*(q1(-1)-q1(0)) + + xt = 0.5*(((2.*dxa(0,j)+dxa(-1,j))*q1(0)-dxa(0,j)*q1(-1))/(dxa(-1,j)+dxa(0,j)) & + + ((2.*dxa(1,j)+dxa( 2,j))*q1(1)-dxa(1,j)*q1( 2))/(dxa(1, j)+dxa(2,j))) +! if ( iord==8 .or. iord==10 ) then + xt = max(xt, min(q1(-1),q1(0),q1(1),q1(2))) + xt = min(xt, max(q1(-1),q1(0),q1(1),q1(2))) +! endif + br(0) = xt - q1(0) + bl(1) = xt - q1(1) + xt = s15*q1(1) + s11*q1(2) - s14*dm(2) + br(1) = xt - q1(1) + bl(2) = xt - q1(2) + + br(2) = al(3) - q1(2) + call pert_ppm(3, q1(0), bl(0), br(0), 1) + endif + if ( (ie+1)==npx ) then + bl(npx-2) = al(npx-2) - q1(npx-2) + + xt = s15*q1(npx-1) + s11*q1(npx-2) + s14*dm(npx-2) + br(npx-2) = xt - q1(npx-2) + bl(npx-1) = xt - q1(npx-1) + + xt = 0.5*(((2.*dxa(npx-1,j)+dxa(npx-2,j))*q1(npx-1)-dxa(npx-1,j)*q1(npx-2))/(dxa(npx-2,j)+dxa(npx-1,j)) & + + ((2.*dxa(npx, j)+dxa(npx+1,j))*q1(npx )-dxa(npx, j)*q1(npx+1))/(dxa(npx, j)+dxa(npx+1,j))) +! if ( iord==8 .or. iord==10 ) then + xt = max(xt, min(q1(npx-2),q1(npx-1),q1(npx),q1(npx+1))) + xt = min(xt, max(q1(npx-2),q1(npx-1),q1(npx),q1(npx+1))) +! endif + br(npx-1) = xt - q1(npx-1) + bl(npx ) = xt - q1(npx ) + + br(npx) = s11*(q1(npx+1)-q1(npx)) - s14*dm(npx+1) + call pert_ppm(3, q1(npx-2), bl(npx-2), br(npx-2), 1) + endif + endif + + endif + + do i=is,ie+1 + if( c(i,j)>0. ) then + flux(i,j) = q1(i-1) + (1.-c(i,j))*(br(i-1)-c(i,j)*(bl(i-1)+br(i-1))) + else + flux(i,j) = q1(i ) + (1.+c(i,j))*(bl(i )+c(i,j)*(bl(i)+br(i))) + endif + enddo + +666 continue + end subroutine xppm + + + subroutine yppm(flux, q, c, jord, ifirst,ilast, isd,ied, js,je,jsd,jed, npx, npy, dya, bounded_domain, grid_type, lim_fac) + integer, INTENT(IN) :: ifirst,ilast !< Compute domain + integer, INTENT(IN) :: isd,ied, js,je,jsd,jed + integer, INTENT(IN) :: jord + integer, INTENT(IN) :: npx, npy + real , INTENT(IN) :: q(ifirst:ilast,jsd:jed) + real , intent(in) :: c(isd:ied,js:je+1 ) !< Courant number + real , INTENT(OUT):: flux(ifirst:ilast,js:je+1) !< Flux + real , intent(IN) :: dya(isd:ied,jsd:jed) + logical, intent(IN) :: bounded_domain + integer, intent(IN) :: grid_type + real , intent(IN) :: lim_fac +! Local: + real:: dm(ifirst:ilast,js-2:je+2) + real:: al(ifirst:ilast,js-1:je+2) + real, dimension(ifirst:ilast,js-1:je+1):: bl, br, b0 + real:: dq(ifirst:ilast,js-3:je+2) + real, dimension(ifirst:ilast):: fx0, fx1, xt1 + logical, dimension(ifirst:ilast,js-1:je+1):: smt5, smt6 + logical, dimension(ifirst:ilast):: hi5, hi6 + real:: x0, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2, r1 + integer:: i, j, js1, je3, je1, mord + + if ( .not.bounded_domain .and. grid_type < 3 ) then +! Cubed-sphere: + js1 = max(3,js-1); je3 = min(npy-2,je+2) + je1 = min(npy-3,je+1) + else +! Bounded_domain grid OR Doubly periodic domain: + js1 = js-1; je3 = je+2 + je1 = je+1 + endif + + mord = abs(jord) + +if ( jord < 8 ) then + + do j=js1, je3 + do i=ifirst,ilast + al(i,j) = p1*(q(i,j-1)+q(i,j)) + p2*(q(i,j-2)+q(i,j+1)) + enddo + enddo + + if ( .not. bounded_domain .and. grid_type<3 ) then + if( js==1 ) then + do i=ifirst,ilast + al(i,0) = c1*q(i,-2) + c2*q(i,-1) + c3*q(i,0) + al(i,1) = 0.5*(((2.*dya(i,0)+dya(i,-1))*q(i,0)-dya(i,0)*q(i,-1))/(dya(i,-1)+dya(i,0)) & + + ((2.*dya(i,1)+dya(i,2))*q(i,1)-dya(i,1)*q(i,2))/(dya(i,1)+dya(i,2))) + al(i,2) = c3*q(i,1) + c2*q(i,2) + c1*q(i,3) + enddo + endif + if( (je+1)==npy ) then + do i=ifirst,ilast + al(i,npy-1) = c1*q(i,npy-3) + c2*q(i,npy-2) + c3*q(i,npy-1) + al(i,npy) = 0.5*(((2.*dya(i,npy-1)+dya(i,npy-2))*q(i,npy-1)-dya(i,npy-1)*q(i,npy-2))/(dya(i,npy-2)+dya(i,npy-1)) & + + ((2.*dya(i,npy)+dya(i,npy+1))*q(i,npy)-dya(i,npy)*q(i,npy+1))/(dya(i,npy)+dya(i,npy+1))) + al(i,npy+1) = c3*q(i,npy) + c2*q(i,npy+1) + c1*q(i,npy+2) + enddo + endif + endif + + if ( jord<0 ) then + do j=js-1, je+2 + do i=ifirst,ilast + al(i,j) = max(0., al(i,j)) + enddo + enddo + endif + + if ( mord==1 ) then + do j=js-1,je+1 + do i=ifirst,ilast + bl(i,j) = al(i,j ) - q(i,j) + br(i,j) = al(i,j+1) - q(i,j) + b0(i,j) = bl(i,j) + br(i,j) + smt5(i,j) = abs(lim_fac*b0(i,j)) < abs(bl(i,j)-br(i,j)) + enddo + enddo + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=ifirst,ilast + if ( c(i,j) > 0. ) then + fx1(i) = (1.-c(i,j))*(br(i,j-1) - c(i,j)*b0(i,j-1)) + flux(i,j) = q(i,j-1) + else + fx1(i) = (1.+c(i,j))*(bl(i,j) + c(i,j)*b0(i,j)) + flux(i,j) = q(i,j) + endif + if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx1(i) + enddo + enddo + + elseif ( mord==2 ) then ! Perfectly linear scheme +! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7 + + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=ifirst,ilast + xt = c(i,j) + if ( xt > 0. ) then + qtmp = q(i,j-1) + flux(i,j) = qtmp + (1.-xt)*(al(i,j)-qtmp-xt*(al(i,j-1)+al(i,j)-(qtmp+qtmp))) + else + qtmp = q(i,j) + flux(i,j) = qtmp + (1.+xt)*(al(i,j)-qtmp+xt*(al(i,j)+al(i,j+1)-(qtmp+qtmp))) + endif + enddo + enddo + + elseif ( mord==3 ) then + + do j=js-1,je+1 + do i=ifirst,ilast + bl(i,j) = al(i,j ) - q(i,j) + br(i,j) = al(i,j+1) - q(i,j) + b0(i,j) = bl(i,j) + br(i,j) + x0 = abs(b0(i,j)) + xt = abs(bl(i,j)-br(i,j)) + smt5(i,j) = x0 < xt + smt6(i,j) = 3.*x0 < xt + enddo + enddo + do j=js,je+1 + do i=ifirst,ilast + fx1(i) = 0. + xt1(i) = c(i,j) + hi5(i) = smt5(i,j-1) .and. smt5(i,j) + hi6(i) = smt6(i,j-1) .or. smt6(i,j) + enddo + do i=ifirst,ilast + if ( xt1(i) > 0. ) then + if( hi6(i) ) then + fx1(i) = br(i,j-1) - xt1(i)*b0(i,j-1) + elseif ( hi5(i) ) then ! both up-downwind sides are noisy; 2nd order, piece-wise linear + fx1(i) = sign(min(abs(bl(i,j-1)),abs(br(i,j-1))),br(i,j-1)) + endif + flux(i,j) = q(i,j-1) + (1.-xt1(i))*fx1(i) + else + if( hi6(i) ) then + fx1(i) = bl(i,j) + xt1(i)*b0(i,j) + elseif ( hi5(i) ) then ! both up-downwind sides are noisy; 2nd order, piece-wise linear + fx1(i) = sign(min(abs(bl(i,j)),abs(br(i,j))), bl(i,j)) + endif + flux(i,j) = q(i,j) + (1.+xt1(i))*fx1(i) + endif + enddo + enddo + + elseif ( mord==4 ) then + + do j=js-1,je+1 + do i=ifirst,ilast + bl(i,j) = al(i,j ) - q(i,j) + br(i,j) = al(i,j+1) - q(i,j) + b0(i,j) = bl(i,j) + br(i,j) + x0 = abs(b0(i,j)) + xt = abs(bl(i,j)-br(i,j)) + smt5(i,j) = x0 < xt + smt6(i,j) = 3.*x0 < xt + enddo + enddo + do j=js,je+1 + do i=ifirst,ilast + xt1(i) = c(i,j) + hi5(i) = smt5(i,j-1) .and. smt5(i,j) + hi6(i) = smt6(i,j-1) .or. smt6(i,j) + hi5(i) = hi5(i) .or. hi6(i) + enddo +!DEC$ VECTOR ALWAYS + do i=ifirst,ilast + if ( xt1(i) > 0. ) then + fx1(i) = (1.-xt1(i))*(br(i,j-1) - xt1(i)*b0(i,j-1)) + flux(i,j) = q(i,j-1) + else + fx1(i) = (1.+xt1(i))*(bl(i,j) + xt1(i)*b0(i,j)) + flux(i,j) = q(i,j) + endif + if ( hi5(i) ) flux(i,j) = flux(i,j) + fx1(i) + enddo + enddo + + else ! mord=5,6,7 + if ( mord==5 ) then + do j=js-1,je+1 + do i=ifirst,ilast + bl(i,j) = al(i,j ) - q(i,j) + br(i,j) = al(i,j+1) - q(i,j) + b0(i,j) = bl(i,j) + br(i,j) + smt5(i,j) = bl(i,j)*br(i,j) < 0. + enddo + enddo + else + do j=js-1,je+1 + do i=ifirst,ilast + bl(i,j) = al(i,j ) - q(i,j) + br(i,j) = al(i,j+1) - q(i,j) + b0(i,j) = bl(i,j) + br(i,j) + smt5(i,j) = 3.*abs(b0(i,j)) < abs(bl(i,j)-br(i,j)) + enddo + enddo + endif + + do j=js,je+1 +!DEC$ VECTOR ALWAYS + do i=ifirst,ilast + if ( c(i,j) > 0. ) then + fx1(i) = (1.-c(i,j))*(br(i,j-1) - c(i,j)*b0(i,j-1)) + flux(i,j) = q(i,j-1) + else + fx1(i) = (1.+c(i,j))*(bl(i,j) + c(i,j)*b0(i,j)) + flux(i,j) = q(i,j) + endif + if (smt5(i,j-1).or.smt5(i,j)) flux(i,j) = flux(i,j) + fx1(i) + enddo + enddo + + endif + return + +else +! Monotonic constraints: +! ord = 8: PPM with Lin's PPM fast monotone constraint +! ord > 8: PPM with Lin's modification of Huynh 2nd constraint + + do j=js-2,je+2 + do i=ifirst,ilast + xt = 0.25*(q(i,j+1) - q(i,j-1)) + dm(i,j) = sign(min(abs(xt), max(q(i,j-1), q(i,j), q(i,j+1)) - q(i,j), & + q(i,j) - min(q(i,j-1), q(i,j), q(i,j+1))), xt) + enddo + enddo + do j=js1,je1+1 + do i=ifirst,ilast + al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j)) + enddo + enddo + + if ( jord==8 ) then + do j=js1,je1 + do i=ifirst,ilast + xt = 2.*dm(i,j) + bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-q(i,j))), xt) + br(i,j) = sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt) + enddo + enddo + elseif ( jord==11 ) then + do j=js1,je1 + do i=ifirst,ilast + xt = ppm_fac*dm(i,j) + bl(i,j) = -sign(min(abs(xt), abs(al(i,j)-q(i,j))), xt) + br(i,j) = sign(min(abs(xt), abs(al(i,j+1)-q(i,j))), xt) + enddo + enddo + else + do j=js1-2,je1+1 + do i=ifirst,ilast + dq(i,j) = 2.*(q(i,j+1) - q(i,j)) + enddo + enddo + do j=js1,je1 + do i=ifirst,ilast + bl(i,j) = al(i,j ) - q(i,j) + br(i,j) = al(i,j+1) - q(i,j) + if ( abs(dm(i,j-1))+abs(dm(i,j))+abs(dm(i,j+1)) < near_zero ) then + bl(i,j) = 0. + br(i,j) = 0. + elseif( abs(3.*(bl(i,j)+br(i,j))) > abs(bl(i,j)-br(i,j)) ) then + pmp_2 = dq(i,j-1) + lac_2 = pmp_2 - 0.75*dq(i,j-2) + br(i,j) = min(max(0.,pmp_2,lac_2), max(br(i,j), min(0.,pmp_2,lac_2))) + pmp_1 = -dq(i,j) + lac_1 = pmp_1 + 0.75*dq(i,j+1) + bl(i,j) = min(max(0.,pmp_1,lac_1), max(bl(i,j), min(0.,pmp_1,lac_1))) + endif + enddo + enddo + endif + if ( jord==9 .or. jord==13 ) then +! Positive definite constraint: + do j=js1,je1 + call pert_ppm(ilast-ifirst+1, q(ifirst,j), bl(ifirst,j), br(ifirst,j), 0) + enddo + endif + + if (.not. bounded_domain .and. grid_type<3) then + if( js==1 ) then + do i=ifirst,ilast + bl(i,0) = s14*dm(i,-1) + s11*(q(i,-1)-q(i,0)) + + xt = 0.5*(((2.*dya(i,0)+dya(i,-1))*q(i,0)-dya(i,0)*q(i,-1))/(dya(i,-1)+dya(i,0)) & + + ((2.*dya(i,1)+dya(i,2))*q(i,1)-dya(i,1)*q(i,2))/(dya(i,1)+dya(i,2))) +! if ( jord==8 .or. jord==10 ) then + xt = max(xt, min(q(i,-1),q(i,0),q(i,1),q(i,2))) + xt = min(xt, max(q(i,-1),q(i,0),q(i,1),q(i,2))) +! endif + br(i,0) = xt - q(i,0) + bl(i,1) = xt - q(i,1) + + xt = s15*q(i,1) + s11*q(i,2) - s14*dm(i,2) + br(i,1) = xt - q(i,1) + bl(i,2) = xt - q(i,2) + + br(i,2) = al(i,3) - q(i,2) + enddo + call pert_ppm(3*(ilast-ifirst+1), q(ifirst,0), bl(ifirst,0), br(ifirst,0), 1) + endif + if( (je+1)==npy ) then + do i=ifirst,ilast + bl(i,npy-2) = al(i,npy-2) - q(i,npy-2) + + xt = s15*q(i,npy-1) + s11*q(i,npy-2) + s14*dm(i,npy-2) + br(i,npy-2) = xt - q(i,npy-2) + bl(i,npy-1) = xt - q(i,npy-1) + + xt = 0.5*(((2.*dya(i,npy-1)+dya(i,npy-2))*q(i,npy-1)-dya(i,npy-1)*q(i,npy-2))/(dya(i,npy-2)+dya(i,npy-1)) & + + ((2.*dya(i,npy)+dya(i,npy+1))*q(i,npy)-dya(i,npy)*q(i,npy+1))/(dya(i,npy)+dya(i,npy+1))) +! if ( jord==8 .or. jord==10 ) then + xt = max(xt, min(q(i,npy-2),q(i,npy-1),q(i,npy),q(i,npy+1))) + xt = min(xt, max(q(i,npy-2),q(i,npy-1),q(i,npy),q(i,npy+1))) +! endif + br(i,npy-1) = xt - q(i,npy-1) + bl(i,npy ) = xt - q(i,npy) + + br(i,npy) = s11*(q(i,npy+1)-q(i,npy)) - s14*dm(i,npy+1) + enddo + call pert_ppm(3*(ilast-ifirst+1), q(ifirst,npy-2), bl(ifirst,npy-2), br(ifirst,npy-2), 1) + endif + end if + +endif + + do j=js,je+1 + do i=ifirst,ilast + if( c(i,j)>0. ) then + flux(i,j) = q(i,j-1) + (1.-c(i,j))*(br(i,j-1)-c(i,j)*(bl(i,j-1)+br(i,j-1))) + else + flux(i,j) = q(i,j ) + (1.+c(i,j))*(bl(i,j )+c(i,j)*(bl(i,j)+br(i,j))) + endif + enddo + enddo + end subroutine yppm + + + + subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, & + kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q) +! +! !INPUT PARAMETERS: + integer, intent(in):: im, jm, km, nq + integer, intent(in):: ifirst, ilast + integer, intent(in):: jfirst, jlast + integer, intent(in):: kfirst, klast + integer, intent(in):: ng_e !< eastern zones to ghost + integer, intent(in):: ng_w !< western zones to ghost + integer, intent(in):: ng_s !< southern zones to ghost + integer, intent(in):: ng_n !< northern zones to ghost + real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq) + real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq) +! +! !DESCRIPTION: +! +! Ghost 4d east/west +! +! !REVISION HISTORY: +! 2005.08.22 Putman +! +!EOP +!------------------------------------------------------------------------------ +!BOC + integer :: i,j,k,n + + if (present(q)) then + q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = & + q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) + endif + +! Assume Periodicity in X-dir and not overlapping + do n=1,nq + do k=kfirst,klast + do j=jfirst-ng_s,jlast+ng_n + do i=1, ng_w + q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n) + enddo + do i=1, ng_e + q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n) + enddo + enddo + enddo + enddo + + end subroutine mp_ghost_ew + + + + subroutine pert_ppm(im, a0, al, ar, iv) + integer, intent(in):: im + integer, intent(in):: iv + real, intent(in) :: a0(im) + real, intent(inout):: al(im), ar(im) +! Local: + real a4, da1, da2, a6da, fmin + integer i + real, parameter:: r12 = 1./12. + +!----------------------------------- +! Optimized PPM in perturbation form: +!----------------------------------- + + if ( iv==0 ) then +! Positive definite constraint + do i=1,im + if ( a0(i) <= 0. ) then + al(i) = 0. + ar(i) = 0. + else + a4 = -3.*(ar(i) + al(i)) + da1 = ar(i) - al(i) + if( abs(da1) < -a4 ) then + fmin = a0(i) + 0.25/a4*da1**2 + a4*r12 + if( fmin < 0. ) then + if( ar(i)>0. .and. al(i)>0. ) then + ar(i) = 0. + al(i) = 0. + elseif( da1 > 0. ) then + ar(i) = -2.*al(i) + else + al(i) = -2.*ar(i) + endif + endif + endif + endif + enddo + else +! Standard PPM constraint + do i=1,im + if ( al(i)*ar(i) < 0. ) then + da1 = al(i) - ar(i) + da2 = da1**2 + a6da = 3.*(al(i)+ar(i))*da1 +! abs(a6da) > da2 --> 3.*abs(al+ar) > abs(al-ar) + if( a6da < -da2 ) then + ar(i) = -2.*al(i) + elseif( a6da > da2 ) then + al(i) = -2.*ar(i) + endif + else +! effect of dm=0 included here + al(i) = 0. + ar(i) = 0. + endif + enddo + endif + + end subroutine pert_ppm + + + subroutine deln_flux(nord,is,ie,js,je, npx, npy, damp, q, fx, fy, gridstruct, bd, mass ) +! Del-n damping for the cell-mean values (A grid) +!------------------ +!> nord = 0: del-2 +!> nord = 1: del-4 +!> nord = 2: del-6 +!> nord = 3: del-8 --> requires more ghosting than current +!------------------ + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: nord !< del-n + integer, intent(in):: is,ie,js,je, npx, npy + real, intent(in):: damp + real, intent(in):: q(bd%isd:bd%ied, bd%jsd:bd%jed) ! q ghosted on input + type(fv_grid_type), intent(IN), target :: gridstruct + real, optional, intent(in):: mass(bd%isd:bd%ied, bd%jsd:bd%jed) ! q ghosted on input +! diffusive fluxes: + real, intent(inout):: fx(bd%is:bd%ie+1,bd%js:bd%je), fy(bd%is:bd%ie,bd%js:bd%je+1) +! local: + real fx2(bd%isd:bd%ied+1,bd%jsd:bd%jed), fy2(bd%isd:bd%ied,bd%jsd:bd%jed+1) + real d2(bd%isd:bd%ied,bd%jsd:bd%jed) + real damp2 + integer i,j, n, nt, i1, i2, j1, j2 + +#ifdef USE_SG + real, pointer, dimension(:,:) :: dx, dy, rdxc, rdyc + real, pointer, dimension(:,:,:) :: sin_sg + dx => gridstruct%dx + dy => gridstruct%dy + rdxc => gridstruct%rdxc + rdyc => gridstruct%rdyc + sin_sg => gridstruct%sin_sg +#endif + + i1 = is-1-nord; i2 = ie+1+nord + j1 = js-1-nord; j2 = je+1+nord + + if ( .not. present(mass) ) then + do j=j1, j2 + do i=i1,i2 + d2(i,j) = damp*q(i,j) + enddo + enddo + else + do j=j1, j2 + do i=i1,i2 + d2(i,j) = q(i,j) + enddo + enddo + endif + + if( nord>0 ) call copy_corners(d2, npx, npy, 1, gridstruct%bounded_domain, bd, & + gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + + do j=js-nord,je+nord + do i=is-nord,ie+nord+1 +#ifdef USE_SG + fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i-1,j)-d2(i,j))*rdxc(i,j) +#else + fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i-1,j)-d2(i,j)) +#endif + enddo + enddo + + if( nord>0 ) call copy_corners(d2, npx, npy, 2, gridstruct%bounded_domain, bd, & + gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + do j=js-nord,je+nord+1 + do i=is-nord,ie+nord +#ifdef USE_SG + fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j-1)-d2(i,j))*rdyc(i,j) +#else + fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j-1)-d2(i,j)) +#endif + enddo + enddo + + if ( nord>0 ) then + +!---------- +! high-order +!---------- + + do n=1, nord + + nt = nord-n + + do j=js-nt-1,je+nt+1 + do i=is-nt-1,ie+nt+1 + d2(i,j) = (fx2(i,j)-fx2(i+1,j)+fy2(i,j)-fy2(i,j+1))*gridstruct%rarea(i,j) + enddo + enddo + + call copy_corners(d2, npx, npy, 1, gridstruct%bounded_domain, bd, & + gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + do j=js-nt,je+nt + do i=is-nt,ie+nt+1 +#ifdef USE_SG + fx2(i,j) = 0.5*(sin_sg(i-1,j,3)+sin_sg(i,j,1))*dy(i,j)*(d2(i,j)-d2(i-1,j))*rdxc(i,j) +#else + fx2(i,j) = gridstruct%del6_v(i,j)*(d2(i,j)-d2(i-1,j)) +#endif + enddo + enddo + + call copy_corners(d2, npx, npy, 2, gridstruct%bounded_domain, bd, & + gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) + do j=js-nt,je+nt+1 + do i=is-nt,ie+nt +#ifdef USE_SG + fy2(i,j) = 0.5*(sin_sg(i,j-1,4)+sin_sg(i,j,2))*dx(i,j)*(d2(i,j)-d2(i,j-1))*rdyc(i,j) +#else + fy2(i,j) = gridstruct%del6_u(i,j)*(d2(i,j)-d2(i,j-1)) +#endif + enddo + enddo + enddo + + endif + +!--------------------------------------------- +! Add the diffusive fluxes to the flux arrays: +!--------------------------------------------- + + if ( present(mass) ) then +! Apply mass weighting to diffusive fluxes: + damp2 = 0.5*damp + do j=js,je + do i=is,ie+1 + fx(i,j) = fx(i,j) + damp2*(mass(i-1,j)+mass(i,j))*fx2(i,j) + enddo + enddo + do j=js,je+1 + do i=is,ie + fy(i,j) = fy(i,j) + damp2*(mass(i,j-1)+mass(i,j))*fy2(i,j) + enddo + enddo + else + do j=js,je + do i=is,ie+1 + fx(i,j) = fx(i,j) + fx2(i,j) + enddo + enddo + do j=js,je+1 + do i=is,ie + fy(i,j) = fy(i,j) + fy2(i,j) + enddo + enddo + endif + + end subroutine deln_flux + + +end module tp_core_mod diff --git a/tools/external_ic.F90 b/tools/external_ic.F90 index 66157aa5e..432703501 100644 --- a/tools/external_ic.F90 +++ b/tools/external_ic.F90 @@ -1,4285 +1,3889 @@ - -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . -!*********************************************************************** - -#ifdef OVERLOAD_R4 -#define _GET_VAR1 get_var1_real -#else -#define _GET_VAR1 get_var1_double -#endif - -!>@brief The module 'external_ic_mod' contains routines that read in and -!! remap initial conditions. - -module external_ic_mod - -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -!
Module NameFunctions Included
constants_modpi=>pi_8, omega, grav, kappa, rdgas, rvgas, cp_air
external_sst_modi_sst, j_sst, sst_ncep
field_manager_modMODEL_ATMOS
fms_modfile_exist, read_data, field_exist, write_version_number, -! open_namelist_file, check_nml_error, close_file, -! get_mosaic_tile_file, read_data, error_mesg
fms_io_modget_tile_string, field_size, free_restart_type, -! restart_file_type, register_restart_field, -! save_restart, restore_state
fv_arrays_modfv_atmos_type, fv_grid_type, fv_grid_bounds_type, R_GRID
fv_control_modfv_init, fv_end, ngrids
fv_diagnostics_modprt_maxmin, prt_gb_nh_sh, prt_height
fv_eta_modset_eta, set_external_eta
fv_fill_modfillz
fv_grid_utils_modptop_min, g_sum,mid_pt_sphere,get_unit_vect2, -! get_latlon_vector,inner_prod
fv_io_modfv_io_read_tracers
fv_mp_modng, is_master, fill_corners, YDir, mp_reduce_min, mp_reduce_max
fv_mapz_modmappm
fv_nwp_nudge_modT_is_Tv
fv_surf_map_modsurfdrv, FV3_zs_filter,sgh_g, oro_g,del2_cubed_sphere, del4_cubed_sphere
fv_timing_modtiming_on, timing_off
fv_update_phys_modfv_update_phys
init_hydro_modp_var
mpp_modmpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe,stdlog, input_nml_file
mpp_domains_modmpp_get_tile_id, domain2d, mpp_update_domains, NORTH, EAST
mpp_parameter_modAGRID_PARAM=>AGRID
sim_nc_modopen_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_real, -! get_var3_r4, get_var2_r4, get_var1_real, get_var_att_double
tracer_manager_modget_tracer_names, get_number_tracers, get_tracer_index, set_tracer_profile
test_cases_modchecker_tracers
- - use netcdf - use external_sst_mod, only: i_sst, j_sst, sst_ncep - use fms_mod, only: file_exist, read_data, field_exist, write_version_number - use fms_mod, only: open_namelist_file, check_nml_error, close_file - use fms_mod, only: get_mosaic_tile_file, read_data, error_mesg - use fms_io_mod, only: get_tile_string, field_size, free_restart_type - use fms_io_mod, only: restart_file_type, register_restart_field - use fms_io_mod, only: save_restart, restore_state - use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe - use mpp_mod, only: stdlog, input_nml_file - use mpp_parameter_mod, only: AGRID_PARAM=>AGRID - use mpp_domains_mod, only: mpp_get_tile_id, domain2d, mpp_update_domains, NORTH, EAST - use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index - use tracer_manager_mod, only: set_tracer_profile - use field_manager_mod, only: MODEL_ATMOS - - use constants_mod, only: pi=>pi_8, omega, grav, kappa, rdgas, rvgas, cp_air - use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_grid_bounds_type, R_GRID - use fv_diagnostics_mod,only: prt_maxmin, prt_gb_nh_sh, prt_height - use fv_grid_utils_mod, only: ptop_min, g_sum,mid_pt_sphere,get_unit_vect2,get_latlon_vector,inner_prod - use fv_io_mod, only: fv_io_read_tracers - use fv_mapz_mod, only: mappm - - use fv_regional_mod, only: dump_field, H_STAGGER, U_STAGGER, V_STAGGER, get_data_source - use fv_mp_mod, only: ng, is_master, fill_corners, YDir, mp_reduce_min, mp_reduce_max - use fv_regional_mod, only: start_regional_cold_start - use fv_surf_map_mod, only: surfdrv, FV3_zs_filter - use fv_surf_map_mod, only: sgh_g, oro_g - use fv_surf_map_mod, only: del2_cubed_sphere, del4_cubed_sphere - use fv_timing_mod, only: timing_on, timing_off - use init_hydro_mod, only: p_var - use fv_fill_mod, only: fillz - use fv_eta_mod, only: set_eta, set_external_eta - use sim_nc_mod, only: open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_real, & - get_var3_r4, get_var2_r4, get_var1_real, get_var_att_double - use fv_nwp_nudge_mod, only: T_is_Tv - use test_cases_mod, only: checker_tracers - -! The "T" field in NCEP analysis is actually virtual temperature (Larry H. post processing) -! BEFORE 20051201 - - use boundary_mod, only: nested_grid_BC, extrapolation_BC - use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_global_domain, mpp_get_compute_domain - -#ifdef MULTI_GASES - use multi_gases_mod, only: virq, virqd, vicpqd -#endif - - implicit none - private - - real, parameter:: zvir = rvgas/rdgas - 1. - real(kind=R_GRID), parameter :: cnst_0p20=0.20d0 - real :: deg2rad - character (len = 80) :: source ! This tells what the input source was for the data - public get_external_ic, get_cubed_sphere_terrain - -! version number of this module -! Include variable "version" to be written to log file. -#include - -contains - - subroutine get_external_ic( Atm, fv_domain, cold_start ) - - type(fv_atmos_type), intent(inout), target :: Atm(:) - type(domain2d), intent(inout) :: fv_domain - logical, intent(IN) :: cold_start - real:: alpha = 0. - real rdg - integer i,j,k,nq - - real, pointer, dimension(:,:,:) :: grid, agrid - real, pointer, dimension(:,:) :: fC, f0 - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel -#ifdef CCPP - integer :: liq_aero, ice_aero -#endif -#ifdef MULTI_GASES - integer :: spfo, spfo2, spfo3 -#else - integer :: o3mr -#endif - - is = Atm(1)%bd%is - ie = Atm(1)%bd%ie - js = Atm(1)%bd%js - je = Atm(1)%bd%je - isd = Atm(1)%bd%isd - ied = Atm(1)%bd%ied - jsd = Atm(1)%bd%jsd - jed = Atm(1)%bd%jed - - grid => Atm(1)%gridstruct%grid - agrid => Atm(1)%gridstruct%agrid - - fC => Atm(1)%gridstruct%fC - f0 => Atm(1)%gridstruct%f0 - -! * Initialize coriolis param: - - do j=jsd,jed+1 - do i=isd,ied+1 - fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + & - sin(grid(i,j,2))*cos(alpha) ) - enddo - enddo - - do j=jsd,jed - do i=isd,ied - f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + & - sin(agrid(i,j,2))*cos(alpha) ) - enddo - enddo - - call mpp_update_domains( f0, fv_domain ) - if ( Atm(1)%gridstruct%cubed_sphere .and. (.not. (Atm(1)%neststruct%nested .or. Atm(1)%flagstruct%regional)))then - call fill_corners(f0, Atm(1)%npx, Atm(1)%npy, YDir) - endif - -! Read in cubed_sphere terrain - if ( Atm(1)%flagstruct%mountain ) then - call get_cubed_sphere_terrain(Atm, fv_domain) - else - if (.not. Atm(1)%neststruct%nested) Atm(1)%phis = 0. - endif - -! Read in the specified external dataset and do all the needed transformation - if ( Atm(1)%flagstruct%ncep_ic ) then - nq = 1 - call timing_on('NCEP_IC') - call get_ncep_ic( Atm, fv_domain, nq ) - call timing_off('NCEP_IC') -#ifdef FV_TRACERS - if (.not. cold_start) then - call fv_io_read_tracers( fv_domain, Atm ) - if(is_master()) write(*,*) 'All tracers except sphum replaced by FV IC' - endif -#endif - elseif ( Atm(1)%flagstruct%nggps_ic ) then - call timing_on('NGGPS_IC') - call get_nggps_ic( Atm, fv_domain ) - call timing_off('NGGPS_IC') - elseif ( Atm(1)%flagstruct%ecmwf_ic ) then - if( is_master() ) write(*,*) 'Calling get_ecmwf_ic' - call timing_on('ECMWF_IC') - call get_ecmwf_ic( Atm, fv_domain ) - call timing_off('ECMWF_IC') - else -! The following is to read in legacy lat-lon FV core restart file -! is Atm%q defined in all cases? - nq = size(Atm(1)%q,4) - call get_fv_ic( Atm, fv_domain, nq ) - endif - - call prt_maxmin('PS', Atm(1)%ps, is, ie, js, je, ng, 1, 0.01) - call prt_maxmin('T', Atm(1)%pt, is, ie, js, je, ng, Atm(1)%npz, 1.) - if (.not.Atm(1)%flagstruct%hydrostatic) call prt_maxmin('W', Atm(1)%w, is, ie, js, je, ng, Atm(1)%npz, 1.) - call prt_maxmin('SPHUM', Atm(1)%q(:,:,:,1), is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( Atm(1)%flagstruct%nggps_ic ) then - call prt_maxmin('TS', Atm(1)%ts, is, ie, js, je, 0, 1, 1.) - endif - if ( Atm(1)%flagstruct%nggps_ic .or. Atm(1)%flagstruct%ecmwf_ic ) then - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') -#ifdef MULTI_GASES - spfo = get_tracer_index(MODEL_ATMOS, 'spfo') - spfo2 = get_tracer_index(MODEL_ATMOS, 'spfo2') - spfo3 = get_tracer_index(MODEL_ATMOS, 'spfo3') -#else - o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') -#endif -#ifdef CCPP - liq_aero = get_tracer_index(MODEL_ATMOS, 'liq_aero') - ice_aero = get_tracer_index(MODEL_ATMOS, 'ice_aero') -#endif - - if ( liq_wat > 0 ) & - call prt_maxmin('liq_wat', Atm(1)%q(:,:,:,liq_wat), is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( ice_wat > 0 ) & - call prt_maxmin('ice_wat', Atm(1)%q(:,:,:,ice_wat), is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( rainwat > 0 ) & - call prt_maxmin('rainwat', Atm(1)%q(:,:,:,rainwat), is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( snowwat > 0 ) & - call prt_maxmin('snowwat', Atm(1)%q(:,:,:,snowwat), is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( graupel > 0 ) & - call prt_maxmin('graupel', Atm(1)%q(:,:,:,graupel), is, ie, js, je, ng, Atm(1)%npz, 1.) -#ifdef MULTI_GASES - if ( spfo > 0 ) & - call prt_maxmin('SPFO', Atm(1)%q(:,:,:,spfo), is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( spfo2 > 0 ) & - call prt_maxmin('SPFO2', Atm(1)%q(:,:,:,spfo2), is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( spfo3 > 0 ) & - call prt_maxmin('SPFO3', Atm(1)%q(:,:,:,spfo3), is, ie, js, je, ng, Atm(1)%npz, 1.) -#else - if ( o3mr > 0 ) & - call prt_maxmin('O3MR', Atm(1)%q(:,:,:,o3mr), is, ie, js, je, ng, Atm(1)%npz, 1.) -#endif -#ifdef CCPP - if ( liq_aero > 0) & - call prt_maxmin('liq_aero',Atm(1)%q(:,:,:,liq_aero),is, ie, js, je, ng, Atm(1)%npz, 1.) - if ( ice_aero > 0) & - call prt_maxmin('ice_aero',Atm(1)%q(:,:,:,ice_aero),is, ie, js, je, ng, Atm(1)%npz, 1.) -#endif - endif - - call p_var(Atm(1)%npz, is, ie, js, je, Atm(1)%ak(1), ptop_min, & - Atm(1)%delp, Atm(1)%delz, Atm(1)%pt, Atm(1)%ps, & - Atm(1)%pe, Atm(1)%peln, Atm(1)%pk, Atm(1)%pkz, & - kappa, Atm(1)%q, ng, Atm(1)%ncnst, Atm(1)%gridstruct%area_64, Atm(1)%flagstruct%dry_mass, & - Atm(1)%flagstruct%adjust_dry_mass, Atm(1)%flagstruct%mountain, Atm(1)%flagstruct%moist_phys, & - Atm(1)%flagstruct%hydrostatic, Atm(1)%flagstruct%nwat, Atm(1)%domain, Atm(1)%flagstruct%make_nh) - - end subroutine get_external_ic - - -!------------------------------------------------------------------ - subroutine get_cubed_sphere_terrain( Atm, fv_domain ) - type(fv_atmos_type), intent(inout), target :: Atm(:) - type(domain2d), intent(inout) :: fv_domain - integer :: ntileMe - integer, allocatable :: tile_id(:) - character(len=64) :: fname - character(len=7) :: gn - integer :: n - integer :: jbeg, jend - real ftop - real, allocatable :: g_dat2(:,:,:) - real, allocatable :: pt_coarse(:,:,:) - integer isc_p, iec_p, jsc_p, jec_p, isg, ieg, jsg,jeg - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = Atm(1)%bd%is - ie = Atm(1)%bd%ie - js = Atm(1)%bd%js - je = Atm(1)%bd%je - isd = Atm(1)%bd%isd - ied = Atm(1)%bd%ied - jsd = Atm(1)%bd%jsd - jed = Atm(1)%bd%jed - - if (Atm(1)%grid_number > 1) then - !write(gn,'(A2, I1)') ".g", Atm(1)%grid_number - write(gn,'(A5, I2.2)') ".nest", Atm(1)%grid_number - else - gn = '' - end if - - ntileMe = size(Atm(:)) ! This will have to be modified for mult tiles per PE - ! ASSUMED always one at this point - - allocate( tile_id(ntileMe) ) - tile_id = mpp_get_tile_id( fv_domain ) - do n=1,ntileMe - - call get_tile_string(fname, 'INPUT/fv_core.res'//trim(gn)//'.tile', tile_id(n), '.nc' ) - if (mpp_pe() == mpp_root_pe()) print*, 'external_ic: looking for ', fname - - - if( file_exist(fname) ) then - call read_data(fname, 'phis', Atm(n)%phis(is:ie,js:je), & - domain=fv_domain, tile_count=n) - else - call surfdrv( Atm(n)%npx, Atm(n)%npy, Atm(n)%gridstruct%grid_64, Atm(n)%gridstruct%agrid_64, & - Atm(n)%gridstruct%area_64, Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, & - Atm(n)%gridstruct%dxa, Atm(n)%gridstruct%dya, & - Atm(n)%gridstruct%dxc, Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%sin_sg, & - Atm(n)%phis, Atm(n)%flagstruct%stretch_fac, & - Atm(n)%neststruct%nested, Atm(n)%neststruct%npx_global, Atm(N)%domain, & - Atm(n)%flagstruct%grid_number, Atm(n)%bd, Atm(n)%flagstruct%regional ) - call mpp_error(NOTE,'terrain datasets generated using USGS data') - endif - - end do - -! Needed for reproducibility. DON'T REMOVE THIS!! - call mpp_update_domains( Atm(1)%phis, Atm(1)%domain ) - ftop = g_sum(Atm(1)%domain, Atm(1)%phis(is:ie,js:je), is, ie, js, je, ng, Atm(1)%gridstruct%area_64, 1) - - call prt_maxmin('ZS', Atm(1)%phis, is, ie, js, je, ng, 1, 1./grav) - if(is_master()) write(*,*) 'mean terrain height (m)=', ftop/grav - - deallocate( tile_id ) - - end subroutine get_cubed_sphere_terrain - -!>@brief The subroutine 'get_nggps_ic' reads in data after it has been preprocessed with -!! NCEP/EMC orography maker and 'global_chgres', and has been horiztontally -!! interpolated to the current cubed-sphere grid - subroutine get_nggps_ic (Atm, fv_domain) - -!>variables read in from 'gfs_ctrl.nc' -!> VCOORD - level information -!> maps to 'ak & bk' -!> variables read in from 'sfc_data.nc' -!> land_frac - land-sea-ice mask (L:0 / S:1) -!> maps to 'oro' -!> TSEA - surface skin temperature (k) -!> maps to 'ts' -!> variables read in from 'gfs_data.nc' -!> ZH - GFS grid height at edges (m) -!> PS - surface pressure (Pa) -!> U_W - D-grid west face tangential wind component (m/s) -!> V_W - D-grid west face normal wind component (m/s) -!> U_S - D-grid south face tangential wind component (m/s) -!> V_S - D-grid south face normal wind component (m/s) -!> OMGA- vertical velocity 'omega' (Pa/s) -!> Q - prognostic tracer fields -!> Namelist variables -!> filtered_terrain - use orography maker filtered terrain mapping -#ifdef __PGI - use GFS_restart, only : GFS_restart_type - - implicit none -#endif - - type(fv_atmos_type), intent(inout) :: Atm(:) - type(domain2d), intent(inout) :: fv_domain -! local: - real, dimension(:), allocatable:: ak, bk - real, dimension(:,:), allocatable:: wk2, ps, oro_g - real, dimension(:,:,:), allocatable:: ud, vd, u_w, v_w, u_s, v_s, omga, temp - real, dimension(:,:,:), allocatable:: zh(:,:,:) ! 3D height at 65 edges - real, dimension(:,:,:,:), allocatable:: q - real, dimension(:,:), allocatable :: phis_coarse ! lmh - real rdg, wt, qt, m_fac - integer:: n, npx, npy, npz, itoa, nt, ntprog, ntdiag, ntracers, ntrac, iq - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: ios, ierr, unit, id_res - type (restart_file_type) :: ORO_restart, SFC_restart, GFS_restart - character(len=6) :: gn, stile_name - character(len=64) :: tracer_name - character(len=64) :: fn_gfs_ctl = 'gfs_ctrl.nc' - character(len=64) :: fn_gfs_ics = 'gfs_data.nc' - character(len=64) :: fn_sfc_ics = 'sfc_data.nc' - character(len=64) :: fn_oro_ics = 'oro_data.nc' - ! DH* character(len=64) :: fn_aero_ics = 'aero_data.nc' *DH - logical :: remap - logical :: filtered_terrain = .true. - logical :: gfs_dwinds = .true. - integer :: levp = 64 - logical :: checker_tr = .false. - integer :: nt_checker = 0 - real(kind=R_GRID), dimension(2):: p1, p2, p3 - real(kind=R_GRID), dimension(3):: e1, e2, ex, ey - integer:: i,j,k,nts, ks - integer:: liq_wat, ice_wat, rainwat, snowwat, graupel, ntclamt - namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds, & - checker_tr, nt_checker -#ifdef GFSL64 - real, dimension(65):: ak_sj, bk_sj - data ak_sj/20.00000, 68.00000, 137.79000, & - 221.95800, 318.26600, 428.43400, & - 554.42400, 698.45700, 863.05803, & - 1051.07995, 1265.75194, 1510.71101, & - 1790.05098, 2108.36604, 2470.78817, & - 2883.03811, 3351.46002, 3883.05187, & - 4485.49315, 5167.14603, 5937.04991, & - 6804.87379, 7780.84698, 8875.64338, & - 9921.40745, 10760.99844, 11417.88354, & - 11911.61193, 12258.61668, 12472.89642, & - 12566.58298, 12550.43517, 12434.26075, & - 12227.27484, 11938.39468, 11576.46910, & - 11150.43640, 10669.41063, 10142.69482, & - 9579.72458, 8989.94947, 8382.67090, & - 7766.85063, 7150.91171, 6542.55077, & - 5948.57894, 5374.81094, 4825.99383, & - 4305.79754, 3816.84622, 3360.78848, & - 2938.39801, 2549.69756, 2194.08449, & - 1870.45732, 1577.34218, 1313.00028, & - 1075.52114, 862.90778, 673.13815, & - 504.22118, 354.22752, 221.32110, & - 103.78014, 0./ - data bk_sj/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00179, 0.00705, 0.01564, & - 0.02749, 0.04251, 0.06064, & - 0.08182, 0.10595, 0.13294, & - 0.16266, 0.19492, 0.22950, & - 0.26615, 0.30455, 0.34435, & - 0.38516, 0.42656, 0.46815, & - 0.50949, 0.55020, 0.58989, & - 0.62825, 0.66498, 0.69987, & - 0.73275, 0.76351, 0.79208, & - 0.81845, 0.84264, 0.86472, & - 0.88478, 0.90290, 0.91923, & - 0.93388, 0.94697, 0.95865, & - 0.96904, 0.97826, 0.98642, & - 0.99363, 1./ -#else -! The following L63 setting is the same as NCEP GFS's L64 except the top layer - real, dimension(64):: ak_sj, bk_sj - data ak_sj/64.247, 137.790, 221.958, & - 318.266, 428.434, 554.424, & - 698.457, 863.05803, 1051.07995, & - 1265.75194, 1510.71101, 1790.05098, & - 2108.36604, 2470.78817, 2883.03811, & - 3351.46002, 3883.05187, 4485.49315, & - 5167.14603, 5937.04991, 6804.87379, & - 7780.84698, 8875.64338, 10100.20534, & - 11264.35673, 12190.64366, 12905.42546, & - 13430.87867, 13785.88765, 13986.77987, & - 14047.96335, 13982.46770, 13802.40331, & - 13519.33841, 13144.59486, 12689.45608, & - 12165.28766, 11583.57006, 10955.84778, & - 10293.60402, 9608.08306, 8910.07678, & - 8209.70131, 7516.18560, 6837.69250, & - 6181.19473, 5552.39653, 4955.72632, & - 4394.37629, 3870.38682, 3384.76586, & - 2937.63489, 2528.37666, 2155.78385, & - 1818.20722, 1513.68173, 1240.03585, & - 994.99144, 776.23591, 581.48797, & - 408.53400, 255.26520, 119.70243, 0. / - - data bk_sj/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00201, 0.00792, 0.01755, & - 0.03079, 0.04751, 0.06761, & - 0.09097, 0.11746, 0.14690, & - 0.17911, 0.21382, 0.25076, & - 0.28960, 0.32994, 0.37140, & - 0.41353, 0.45589, 0.49806, & - 0.53961, 0.58015, 0.61935, & - 0.65692, 0.69261, 0.72625, & - 0.75773, 0.78698, 0.81398, & - 0.83876, 0.86138, 0.88192, & - 0.90050, 0.91722, 0.93223, & - 0.94565, 0.95762, 0.96827, & - 0.97771, 0.98608, 0.99347, 1./ -#endif - -#ifdef TEMP_GFSPLV - real, dimension(64):: ak_sj, bk_sj - data ak_sj/64.247, 137.79, 221.958, & - 318.266, 428.434, 554.424, & - 698.457, 863.058, 1051.08, & - 1265.752, 1510.711, 1790.051, & - 2108.366, 2470.788, 2883.038, & - 3351.46, 3883.052, 4485.493, & - 5167.146, 5937.05, 6804.874, & - 7777.15, 8832.537, 9936.614, & - 11054.85, 12152.94, 13197.07, & - 14154.32, 14993.07, 15683.49, & - 16197.97, 16511.74, 16611.6, & - 16503.14, 16197.32, 15708.89, & - 15056.34, 14261.43, 13348.67, & - 12344.49, 11276.35, 10171.71, & - 9057.051, 7956.908, 6893.117, & - 5884.206, 4945.029, 4086.614, & - 3316.217, 2637.553, 2051.15, & - 1554.789, 1143.988, 812.489, & - 552.72, 356.223, 214.015, & - 116.899, 55.712, 21.516, & - 5.741, 0.575, 0., 0. / - - data bk_sj/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00003697, 0.00043106, 0.00163591, & - 0.00410671, 0.00829402, 0.01463712, & - 0.02355588, 0.03544162, 0.05064684, & - 0.06947458, 0.09216691, 0.1188122, & - 0.1492688, 0.1832962, 0.2205702, & - 0.2606854, 0.3031641, 0.3474685, & - 0.3930182, 0.4392108, 0.4854433, & - 0.5311348, 0.5757467, 0.6187996, & - 0.659887, 0.6986829, 0.7349452, & - 0.7685147, 0.7993097, 0.8273188, & - 0.8525907, 0.8752236, 0.895355, & - 0.913151, 0.9287973, 0.9424911, & - 0.9544341, 0.9648276, 0.9738676, & - 0.9817423, 0.9886266, 0.9946712, 1./ -#endif - - call mpp_error(NOTE,'Using external_IC::get_nggps_ic which is valid only for data which has been & - &horizontally interpolated to the current cubed-sphere grid') -#ifdef INTERNAL_FILE_NML - read (input_nml_file,external_ic_nml,iostat=ios) - ierr = check_nml_error(ios,'external_ic_nml') -#else - unit=open_namelist_file() - read (unit,external_ic_nml,iostat=ios) - ierr = check_nml_error(ios,'external_ic_nml') - call close_file(unit) -#endif - - unit = stdlog() - call write_version_number ( 'EXTERNAL_IC_mod::get_nggps_ic', version ) - write(unit, nml=external_ic_nml) - - remap = .true. - if (Atm(1)%flagstruct%external_eta) then - if (filtered_terrain) then - call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, filtered terrain & - &and NCEP pressure levels (no vertical remapping)') - else if (.not. filtered_terrain) then - call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, raw terrain & - &and NCEP pressure levels (no vertical remapping)') - endif - else ! (.not.external_eta) - if (filtered_terrain) then - call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, filtered terrain & - &and FV3 pressure levels (vertical remapping)') - else if (.not. filtered_terrain) then - call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, raw terrain & - &and FV3 pressure levels (vertical remapping)') - endif - endif - - is = Atm(1)%bd%is - ie = Atm(1)%bd%ie - js = Atm(1)%bd%js - je = Atm(1)%bd%je - isd = Atm(1)%bd%isd - ied = Atm(1)%bd%ied - jsd = Atm(1)%bd%jsd - jed = Atm(1)%bd%jed - npz = Atm(1)%npz - write(*,22001)is,ie,js,je,isd,ied,jsd,jed -22001 format(' enter get_nggps_ic is=',i4,' ie=',i4,' js=',i4,' je=',i4,' isd=',i4,' ied=',i4,' jsd=',i4,' jed=',i4) - call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers, num_prog=ntprog) - ntdiag = ntracers-ntprog - -!--- test for existence of the GFS control file - if (.not. file_exist('INPUT/'//trim(fn_gfs_ctl), no_domain=.TRUE.)) then - call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: file '//trim(fn_gfs_ctl)//' for NGGPS IC does not exist') - endif - call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using control file '//trim(fn_gfs_ctl)//' for NGGPS IC') - -!--- read in the number of tracers in the NCEP NGGPS ICs - call read_data ('INPUT/'//trim(fn_gfs_ctl), 'ntrac', ntrac, no_domain=.TRUE.) - if (ntrac > ntracers) call mpp_error(FATAL,'==> External_ic::get_nggps_ic: more NGGPS tracers & - &than defined in field_table '//trim(fn_gfs_ctl)//' for NGGPS IC') - -!--- read in ak and bk from the gfs control file using fms_io read_data --- - allocate (wk2(levp+1,2)) - allocate (ak(levp+1)) - allocate (bk(levp+1)) - call read_data('INPUT/'//trim(fn_gfs_ctl),'vcoord',wk2, no_domain=.TRUE.) - ak(1:levp+1) = wk2(1:levp+1,1) - bk(1:levp+1) = wk2(1:levp+1,2) - deallocate (wk2) - - if (.not. file_exist('INPUT/'//trim(fn_oro_ics), domain=Atm(1)%domain)) then - call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_oro_ics)//' for NGGPS IC does not exist') - endif - call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_oro_ics)//' for NGGPS IC') - - if (.not. file_exist('INPUT/'//trim(fn_sfc_ics), domain=Atm(1)%domain)) then - call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_sfc_ics)//' for NGGPS IC does not exist') - endif - call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_sfc_ics)//' for NGGPS IC') - - if (.not. file_exist('INPUT/'//trim(fn_gfs_ics), domain=Atm(1)%domain)) then - call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_gfs_ics)//' for NGGPS IC does not exist') - endif - call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_gfs_ics)//' for NGGPS IC') -! - call get_data_source(source,Atm(1)%flagstruct%regional) -! - allocate (zh(is:ie,js:je,levp+1)) ! SJL - allocate (ps(is:ie,js:je)) - allocate (omga(is:ie,js:je,levp)) - allocate (q (is:ie,js:je,levp,ntracers)) - allocate ( u_w(is:ie+1, js:je, 1:levp) ) - allocate ( v_w(is:ie+1, js:je, 1:levp) ) - allocate ( u_s(is:ie, js:je+1, 1:levp) ) - allocate ( v_s(is:ie, js:je+1, 1:levp) ) - allocate (temp(is:ie,js:je,levp)) - - do n = 1,size(Atm(:)) - - !!! If a nested grid, save the filled coarse-grid topography for blending - if (Atm(n)%neststruct%nested) then - allocate(phis_coarse(isd:ied,jsd:jed)) - do j=jsd,jed - do i=isd,ied - phis_coarse(i,j) = Atm(n)%phis(i,j) - enddo - enddo - endif - -!--- read in surface temperature (k) and land-frac - ! surface skin temperature - id_res = register_restart_field (SFC_restart, fn_sfc_ics, 'tsea', Atm(n)%ts, domain=Atm(n)%domain) - - ! terrain surface height -- (needs to be transformed into phis = zs*grav) - if (filtered_terrain) then - id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_filt', Atm(n)%phis, domain=Atm(n)%domain) - elseif (.not. filtered_terrain) then - id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_raw', Atm(n)%phis, domain=Atm(n)%domain) - endif - - if ( Atm(n)%flagstruct%full_zs_filter) then - allocate (oro_g(isd:ied,jsd:jed)) - oro_g = 0. - ! land-frac - id_res = register_restart_field (ORO_restart, fn_oro_ics, 'land_frac', oro_g, domain=Atm(n)%domain) - call mpp_update_domains(oro_g, Atm(n)%domain) - if (Atm(n)%neststruct%nested) then - call extrapolation_BC(oro_g, 0, 0, Atm(n)%npx, Atm(n)%npy, Atm(n)%bd, .true.) - endif - endif - - if ( Atm(n)%flagstruct%fv_land ) then - ! stddev - id_res = register_restart_field (ORO_restart, fn_oro_ics, 'stddev', Atm(n)%sgh, domain=Atm(n)%domain) - ! land-frac - id_res = register_restart_field (ORO_restart, fn_oro_ics, 'land_frac', Atm(n)%oro, domain=Atm(n)%domain) - endif - - ! surface pressure (Pa) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ps', ps, domain=Atm(n)%domain) - - ! D-grid west face tangential wind component (m/s) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'u_w', u_w, domain=Atm(n)%domain,position=EAST) - ! D-grid west face normal wind component (m/s) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'v_w', v_w, domain=Atm(n)%domain,position=EAST) - ! D-grid south face tangential wind component (m/s) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'u_s', u_s, domain=Atm(n)%domain,position=NORTH) - ! D-grid south face normal wind component (m/s) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'v_s', v_s, domain=Atm(n)%domain,position=NORTH) - - ! vertical velocity 'omega' (Pa/s) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'w', omga, domain=Atm(n)%domain) - ! GFS grid height at edges (including surface height) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ZH', zh, domain=Atm(n)%domain) - ! real temperature (K) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 't', temp, mandatory=.false., & - domain=Atm(n)%domain) - ! prognostic tracers - do nt = 1, ntracers - call get_tracer_names(MODEL_ATMOS, nt, tracer_name) - ! DH* if aerosols are in separate file, need to test for indices liq_aero and ice_aero and change fn_gfs_ics to fn_aero_ics *DH - id_res = register_restart_field (GFS_restart, fn_gfs_ics, trim(tracer_name), q(:,:,:,nt), & - mandatory=.false.,domain=Atm(n)%domain) - enddo - - ! initialize all tracers to default values prior to being input - do nt = 1, ntprog - call get_tracer_names(MODEL_ATMOS, nt, tracer_name) - ! set all tracers to an initial profile value - call set_tracer_profile (MODEL_ATMOS, nt, Atm(n)%q(:,:,:,nt) ) - enddo - do nt = ntprog+1, ntracers - call get_tracer_names(MODEL_ATMOS, nt, tracer_name) - ! set all tracers to an initial profile value - call set_tracer_profile (MODEL_ATMOS, nt, Atm(n)%qdiag(:,:,:,nt) ) - enddo - - ! read in the restart - call restore_state (ORO_restart) - call restore_state (SFC_restart) - call restore_state (GFS_restart) - - ! free the restart type to be re-used by the nest - call free_restart_type(ORO_restart) - call free_restart_type(SFC_restart) - call free_restart_type(GFS_restart) - - ! multiply NCEP ICs terrain 'phis' by gravity to be true geopotential - Atm(n)%phis = Atm(n)%phis*grav - - ! set the pressure levels and ptop to be used - if (Atm(1)%flagstruct%external_eta) then - itoa = levp - npz + 1 - Atm(n)%ptop = ak(itoa) - Atm(n)%ak(1:npz+1) = ak(itoa:levp+1) - Atm(n)%bk(1:npz+1) = bk(itoa:levp+1) - call set_external_eta (Atm(n)%ak, Atm(n)%bk, Atm(n)%ptop, Atm(n)%ks) - else - if ( npz <= 64 ) then - Atm(n)%ak(:) = ak_sj(:) - Atm(n)%bk(:) = bk_sj(:) - Atm(n)%ptop = Atm(n)%ak(1) - else - call set_eta(npz, ks, Atm(n)%ptop, Atm(n)%ak, Atm(n)%bk) - endif - endif - ! call vertical remapping algorithms - if(is_master()) write(*,*) 'GFS ak =', ak,' FV3 ak=',Atm(n)%ak - ak(1) = max(1.e-9, ak(1)) - -!*** For regional runs read in each of the BC variables from the NetCDF boundary file -!*** and remap in the vertical from the input levels to the model integration levels. -!*** Here in the initialization we begn by allocating the regional domain's boundary -!*** objects. Then we need to read the first two regional BC files so the integration -!*** can begin interpolating between those two times as the forecast proceeds. - - if (n==1.and.Atm(1)%flagstruct%regional) then !<-- Select the parent regional domain. - - call start_regional_cold_start(Atm(1), ak, bk, levp, & - is, ie, js, je, & - isd, ied, jsd, jed ) - endif - -! -!*** Remap the variables in the compute domain. -! - call remap_scalar_nggps(Atm(n), levp, npz, ntracers, ak, bk, ps, temp, q, omga, zh) - - allocate ( ud(is:ie, js:je+1, 1:levp) ) - allocate ( vd(is:ie+1,js:je, 1:levp) ) - -!$OMP parallel do default(none) shared(is,ie,js,je,levp,Atm,ud,vd,u_s,v_s,u_w,v_w) & -!$OMP private(p1,p2,p3,e1,e2,ex,ey) - do k=1,levp - do j=js,je+1 - do i=is,ie - p1(:) = Atm(1)%gridstruct%grid(i, j,1:2) - p2(:) = Atm(1)%gridstruct%grid(i+1,j,1:2) - call mid_pt_sphere(p1, p2, p3) - call get_unit_vect2(p1, p2, e1) - call get_latlon_vector(p3, ex, ey) - ud(i,j,k) = u_s(i,j,k)*inner_prod(e1,ex) + v_s(i,j,k)*inner_prod(e1,ey) - enddo - enddo - do j=js,je - do i=is,ie+1 - p1(:) = Atm(1)%gridstruct%grid(i,j ,1:2) - p2(:) = Atm(1)%gridstruct%grid(i,j+1,1:2) - call mid_pt_sphere(p1, p2, p3) - call get_unit_vect2(p1, p2, e2) - call get_latlon_vector(p3, ex, ey) - vd(i,j,k) = u_w(i,j,k)*inner_prod(e2,ex) + v_w(i,j,k)*inner_prod(e2,ey) - enddo - enddo - enddo - deallocate ( u_w ) - deallocate ( v_w ) - deallocate ( u_s ) - deallocate ( v_s ) - - call remap_dwinds(levp, npz, ak, bk, ps, ud, vd, Atm(n)) - - deallocate ( ud ) - deallocate ( vd ) - - if (Atm(n)%neststruct%nested) then - if (is_master()) write(*,*) 'Blending nested and coarse grid topography' - npx = Atm(n)%npx - npy = Atm(n)%npy - do j=jsd,jed - do i=isd,ied - wt = max(0.,min(1.,real(5 - min(i,j,npx-i,npy-j,5))/5. )) - Atm(n)%phis(i,j) = (1.-wt)*Atm(n)%phis(i,j) + wt*phis_coarse(i,j) - enddo - enddo - endif - - - !!! Perform terrain smoothing, if desired - if ( Atm(n)%flagstruct%full_zs_filter ) then - - call mpp_update_domains(Atm(n)%phis, Atm(n)%domain) - - call FV3_zs_filter( Atm(n)%bd, isd, ied, jsd, jed, npx, npy, Atm(n)%neststruct%npx_global, & - Atm(n)%flagstruct%stretch_fac, Atm(n)%neststruct%nested, Atm(n)%domain, & - Atm(n)%gridstruct%area_64, Atm(n)%gridstruct%dxa, Atm(n)%gridstruct%dya, & - Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, Atm(n)%gridstruct%dxc, & - Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%grid_64, Atm(n)%gridstruct%agrid_64, & - Atm(n)%gridstruct%sin_sg, Atm(n)%phis, oro_g, Atm(n)%flagstruct%regional) - deallocate(oro_g) - endif - - - if ( Atm(n)%flagstruct%n_zs_filter > 0 ) then - - if ( Atm(n)%flagstruct%nord_zs_filter == 2 ) then - call del2_cubed_sphere(Atm(n)%npx, Atm(n)%npy, Atm(n)%phis, & - Atm(n)%gridstruct%area_64, Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, & - Atm(n)%gridstruct%dxc, Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%sin_sg, & - Atm(n)%flagstruct%n_zs_filter, cnst_0p20*Atm(n)%gridstruct%da_min, & - .false., oro_g, Atm(n)%neststruct%nested, Atm(n)%domain, Atm(n)%bd, Atm(n)%flagstruct%regional) - if ( is_master() ) write(*,*) 'Warning !!! del-2 terrain filter has been applied ', & - Atm(n)%flagstruct%n_zs_filter, ' times' - else if( Atm(n)%flagstruct%nord_zs_filter == 4 ) then - call del4_cubed_sphere(Atm(n)%npx, Atm(n)%npy, Atm(n)%phis, Atm(n)%gridstruct%area_64, & - Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, & - Atm(n)%gridstruct%dxc, Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%sin_sg, & - Atm(n)%flagstruct%n_zs_filter, .false., oro_g, Atm(n)%neststruct%nested, & - Atm(n)%domain, Atm(n)%bd, Atm(n)%flagstruct%regional) - if ( is_master() ) write(*,*) 'Warning !!! del-4 terrain filter has been applied ', & - Atm(n)%flagstruct%n_zs_filter, ' times' - endif - - endif - - if ( Atm(n)%neststruct%nested .and. ( Atm(n)%flagstruct%n_zs_filter > 0 .or. Atm(n)%flagstruct%full_zs_filter ) ) then - npx = Atm(n)%npx - npy = Atm(n)%npy - do j=jsd,jed - do i=isd,ied - wt = max(0.,min(1.,real(5 - min(i,j,npx-i,npy-j,5))/5. )) - Atm(n)%phis(i,j) = (1.-wt)*Atm(n)%phis(i,j) + wt*phis_coarse(i,j) - enddo - enddo - deallocate(phis_coarse) - endif - - call mpp_update_domains( Atm(n)%phis, Atm(n)%domain, complete=.true. ) - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') - ntclamt = get_tracer_index(MODEL_ATMOS, 'cld_amt') - if (trim(source) == 'FV3GFS GAUSSIAN NEMSIO FILE') then - do k=1,npz - do j=js,je - do i=is,ie - wt = Atm(n)%delp(i,j,k) - if ( Atm(n)%flagstruct%nwat == 6 ) then - qt = wt*(1. + Atm(n)%q(i,j,k,liq_wat) + & - Atm(n)%q(i,j,k,ice_wat) + & - Atm(n)%q(i,j,k,rainwat) + & - Atm(n)%q(i,j,k,snowwat) + & - Atm(n)%q(i,j,k,graupel)) - else ! all other values of nwat - qt = wt*(1. + sum(Atm(n)%q(i,j,k,2:Atm(n)%flagstruct%nwat))) - endif - Atm(n)%delp(i,j,k) = qt - if (ntclamt > 0) Atm(n)%q(i,j,k,ntclamt) = 0.0 ! Moorthi - enddo - enddo - enddo - else -!--- Add cloud condensate from GFS to total MASS -! 20160928: Adjust the mixing ratios consistently... - do k=1,npz - do j=js,je - do i=is,ie - wt = Atm(n)%delp(i,j,k) - if ( Atm(n)%flagstruct%nwat == 6 ) then - qt = wt*(1. + Atm(n)%q(i,j,k,liq_wat) + & - Atm(n)%q(i,j,k,ice_wat) + & - Atm(n)%q(i,j,k,rainwat) + & - Atm(n)%q(i,j,k,snowwat) + & - Atm(n)%q(i,j,k,graupel)) - else ! all other values of nwat - qt = wt*(1. + sum(Atm(n)%q(i,j,k,2:Atm(n)%flagstruct%nwat))) - endif - m_fac = wt / qt - do iq=1,ntracers - Atm(n)%q(i,j,k,iq) = m_fac * Atm(n)%q(i,j,k,iq) - enddo - Atm(n)%delp(i,j,k) = qt - if (ntclamt > 0) Atm(n)%q(i,j,k,ntclamt) = 0.0 ! Moorthi - enddo - enddo - enddo - endif !end trim(source) test - -!--- reset the tracers beyond condensate to a checkerboard pattern - if (checker_tr) then - nts = ntracers - nt_checker+1 - call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, nt_checker, & - npz, Atm(n)%q(:,:,:,nts:ntracers), & - Atm(n)%gridstruct%agrid_64(is:ie,js:je,1), & - Atm(n)%gridstruct%agrid_64(is:ie,js:je,2), 9., 9.) - endif - enddo ! n-loop - - Atm(1)%flagstruct%make_nh = .false. - - deallocate (ak) - deallocate (bk) - deallocate (ps) - deallocate (q ) - deallocate (temp) - deallocate (omga) - - end subroutine get_nggps_ic -!------------------------------------------------------------------ -!------------------------------------------------------------------ -!>@brief The subroutine 'get_ncep_ic' reads in the specified NCEP analysis or reanalysis dataset - subroutine get_ncep_ic( Atm, fv_domain, nq ) - type(fv_atmos_type), intent(inout) :: Atm(:) - type(domain2d), intent(inout) :: fv_domain - integer, intent(in):: nq -! local: -#ifdef HIWPP_ETA - real :: ak_HIWPP(65), bk_HIWPP(65) - data ak_HIWPP/ & - 0, 0.00064247, 0.0013779, 0.00221958, 0.00318266, 0.00428434, & - 0.00554424, 0.00698457, 0.00863058, 0.0105108, 0.01265752, 0.01510711, & - 0.01790051, 0.02108366, 0.02470788, 0.02883038, 0.0335146, 0.03883052, & - 0.04485493, 0.05167146, 0.0593705, 0.06804874, 0.0777715, 0.08832537, & - 0.09936614, 0.1105485, 0.1215294, 0.1319707, 0.1415432, 0.1499307, & - 0.1568349, 0.1619797, 0.1651174, 0.166116, 0.1650314, 0.1619731, & - 0.1570889, 0.1505634, 0.1426143, 0.1334867, 0.1234449, 0.1127635, & - 0.1017171, 0.09057051, 0.07956908, 0.06893117, 0.05884206, 0.04945029, & - 0.04086614, 0.03316217, 0.02637553, 0.0205115, 0.01554789, 0.01143988, & - 0.00812489, 0.0055272, 0.00356223, 0.00214015, 0.00116899, 0.00055712, & - 0.00021516, 5.741e-05, 5.75e-06, 0, 0 / - - data bk_HIWPP/ & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 3.697e-05, 0.00043106, 0.00163591, 0.00410671, 0.00829402, 0.01463712, & - 0.02355588, 0.03544162, 0.05064684, 0.06947458, 0.09216691, 0.1188122, & - 0.1492688, 0.1832962, 0.2205702, 0.2606854, 0.3031641, 0.3474685, & - 0.3930182, 0.4392108, 0.4854433, 0.5311348, 0.5757467, 0.6187996, & - 0.659887, 0.6986829, 0.7349452, 0.7685147, 0.7993097, 0.8273188, & - 0.8525907, 0.8752236, 0.895355, 0.913151, 0.9287973, 0.9424911, & - 0.9544341, 0.9648276, 0.9738676, 0.9817423, 0.9886266, 0.9946712, 1 / -#endif - character(len=128) :: fname - real(kind=4), allocatable:: wk1(:), wk2(:,:), wk3(:,:,:) - real, allocatable:: tp(:,:,:), qp(:,:,:) - real, allocatable:: ua(:,:,:), va(:,:,:) - real, allocatable:: lat(:), lon(:), ak0(:), bk0(:) - real:: s2c(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je,4) - integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je):: id1, id2, jdc - real psc(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je) - real gzc(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je) - real tmean - integer:: i, j, k, im, jm, km, npz, npt - integer:: i1, i2, j1, ncid - integer:: jbeg, jend - integer tsize(3) - logical:: read_ts = .true. - logical:: land_ts = .false. - logical:: found - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = Atm(1)%bd%is - ie = Atm(1)%bd%ie - js = Atm(1)%bd%js - je = Atm(1)%bd%je - isd = Atm(1)%bd%isd - ied = Atm(1)%bd%ied - jsd = Atm(1)%bd%jsd - jed = Atm(1)%bd%jed - - deg2rad = pi/180. - - npz = Atm(1)%npz - -! Zero out all initial tracer fields: -! SJL: 20110716 -! Atm(1)%q = 0. - - fname = Atm(1)%flagstruct%res_latlon_dynamics - - if( file_exist(fname) ) then - call open_ncfile( fname, ncid ) ! open the file - call get_ncdim1( ncid, 'lon', tsize(1) ) - call get_ncdim1( ncid, 'lat', tsize(2) ) - call get_ncdim1( ncid, 'lev', tsize(3) ) - - im = tsize(1); jm = tsize(2); km = tsize(3) - - if(is_master()) write(*,*) fname - if(is_master()) write(*,*) ' NCEP IC dimensions:', tsize - - allocate ( lon(im) ) - allocate ( lat(jm) ) - - call _GET_VAR1(ncid, 'lon', im, lon ) - call _GET_VAR1(ncid, 'lat', jm, lat ) - -! Convert to radian - do i=1,im - lon(i) = lon(i) * deg2rad ! lon(1) = 0. - enddo - do j=1,jm - lat(j) = lat(j) * deg2rad - enddo - - allocate ( ak0(km+1) ) - allocate ( bk0(km+1) ) - -#ifdef HIWPP_ETA -! The HIWPP data from Jeff does not contain (ak,bk) - do k=1, km+1 - ak0(k) = ak_HIWPP (k) - bk0(k) = bk_HIWPP (k) - enddo -#else - call _GET_VAR1(ncid, 'hyai', km+1, ak0, found ) - if ( .not. found ) ak0(:) = 0. - - call _GET_VAR1(ncid, 'hybi', km+1, bk0 ) -#endif - if( is_master() ) then - do k=1,km+1 - write(*,*) k, ak0(k), bk0(k) - enddo - endif - -! Note: definition of NCEP hybrid is p(k) = a(k)*1.E5 + b(k)*ps - ak0(:) = ak0(:) * 1.E5 - -! Limiter to prevent NAN at top during remapping - if ( bk0(1) < 1.E-9 ) ak0(1) = max(1.e-9, ak0(1)) - - else - call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for NCEP IC does not exist') - endif - -! Initialize lat-lon to Cubed bi-linear interpolation coeff: - call remap_coef( is, ie, js, je, isd, ied, jsd, jed, & - im, jm, lon, lat, id1, id2, jdc, s2c , Atm(1)%gridstruct%agrid) - -! Find bounding latitudes: - jbeg = jm-1; jend = 2 - do j=js,je - do i=is,ie - j1 = jdc(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) - enddo - enddo - -! remap surface pressure and height: - - allocate ( wk2(im,jbeg:jend) ) - call get_var3_r4( ncid, 'PS', 1,im, jbeg,jend, 1,1, wk2 ) - - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - psc(i,j) = s2c(i,j,1)*wk2(i1,j1 ) + s2c(i,j,2)*wk2(i2,j1 ) + & - s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1) - enddo - enddo - - call get_var3_r4( ncid, 'PHIS', 1,im, jbeg,jend, 1,1, wk2 ) - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - gzc(i,j) = s2c(i,j,1)*wk2(i1,j1 ) + s2c(i,j,2)*wk2(i2,j1 ) + & - s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1) - enddo - enddo - - deallocate ( wk2 ) - allocate ( wk2(im,jm) ) - - if ( read_ts ) then ! read skin temperature; could be used for SST - - call get_var2_real( ncid, 'TS', im, jm, wk2 ) - - if ( .not. land_ts ) then - allocate ( wk1(im) ) - - do j=1,jm -! Read NCEP ORO (1; land; 0: ocean; 2: sea_ice) - call get_var3_r4( ncid, 'ORO', 1,im, j,j, 1,1, wk1 ) - tmean = 0. - npt = 0 - do i=1,im - if( abs(wk1(i)-1.) > 0.99 ) then ! ocean or sea ice - tmean = tmean + wk2(i,j) - npt = npt + 1 - endif - enddo -!------------------------------------------------------ -! Replace TS over interior land with zonal mean SST/Ice -!------------------------------------------------------ - if ( npt /= 0 ) then - tmean= tmean / real(npt) - do i=1,im - if( abs(wk1(i)-1.) <= 0.99 ) then ! Land points - if ( i==1 ) then - i1 = im; i2 = 2 - elseif ( i==im ) then - i1 = im-1; i2 = 1 - else - i1 = i-1; i2 = i+1 - endif - if ( abs(wk1(i2)-1.)>0.99 ) then ! east side has priority - wk2(i,j) = wk2(i2,j) - elseif ( abs(wk1(i1)-1.)>0.99 ) then ! west side - wk2(i,j) = wk2(i1,j) - else - wk2(i,j) = tmean - endif - endif - enddo - endif - enddo ! j-loop - deallocate ( wk1 ) - endif !(.not.land_ts) - - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - Atm(1)%ts(i,j) = s2c(i,j,1)*wk2(i1,j1 ) + s2c(i,j,2)*wk2(i2,j1 ) + & - s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1) - enddo - enddo - call prt_maxmin('SST_model', Atm(1)%ts, is, ie, js, je, 0, 1, 1.) - -! Perform interp to FMS SST format/grid -#ifndef DYCORE_SOLO - call ncep2fms(im, jm, lon, lat, wk2) - if( is_master() ) then - write(*,*) 'External_ic_mod: i_sst=', i_sst, ' j_sst=', j_sst - call pmaxmin( 'SST_ncep_fms', sst_ncep, i_sst, j_sst, 1.) - endif -#endif - endif !(read_ts) - - deallocate ( wk2 ) - -! Read in temperature: - allocate ( wk3(1:im,jbeg:jend, 1:km) ) - call get_var3_r4( ncid, 'T', 1,im, jbeg,jend, 1,km, wk3 ) - - allocate ( tp(is:ie,js:je,km) ) - do k=1,km - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - tp(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k) + & - s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) - enddo - enddo - enddo - -! Read in tracers: only sphum at this point - call get_var3_r4( ncid, 'Q', 1,im, jbeg,jend, 1,km, wk3 ) - - allocate ( qp(is:ie,js:je,km) ) - do k=1,km - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - qp(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k) + & - s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) - enddo - enddo - enddo - - call remap_scalar(im, jm, km, npz, nq, nq, ak0, bk0, psc, gzc, tp, qp, Atm(1)) - deallocate ( tp ) - deallocate ( qp ) - -! Winds: - call get_var3_r4( ncid, 'U', 1,im, jbeg,jend, 1,km, wk3 ) - - allocate ( ua(is:ie,js:je,km) ) - do k=1,km - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - ua(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k) + & - s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) - enddo - enddo - enddo - - call get_var3_r4( ncid, 'V', 1,im, jbeg,jend, 1,km, wk3 ) - call close_ncfile ( ncid ) - - allocate ( va(is:ie,js:je,km) ) - do k=1,km - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - va(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k) + & - s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) - enddo - enddo - enddo - deallocate ( wk3 ) - call remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm(1)) - - deallocate ( ua ) - deallocate ( va ) - - deallocate ( ak0 ) - deallocate ( bk0 ) - deallocate ( lat ) - deallocate ( lon ) - - end subroutine get_ncep_ic - -!>@brief The subroutine 'get_ecmwf_ic' reads in initial conditions from ECMWF analyses -!! (EXPERIMENTAL: contact Jan-Huey Chen jan-huey.chen@noaa.gov for support) -!>@authors Jan-Huey Chen, Xi Chen, Shian-Jiann Lin - subroutine get_ecmwf_ic( Atm, fv_domain ) - -#ifdef __PGI - use GFS_restart, only : GFS_restart_type - - implicit none -#endif - - type(fv_atmos_type), intent(inout) :: Atm(:) - type(domain2d), intent(inout) :: fv_domain -! local: - real :: ak_ec(138), bk_ec(138) - data ak_ec/ 0.000000, 2.000365, 3.102241, 4.666084, 6.827977, 9.746966, & - 13.605424, 18.608931, 24.985718, 32.985710, 42.879242, 54.955463, & - 69.520576, 86.895882, 107.415741, 131.425507, 159.279404, 191.338562, & - 227.968948, 269.539581, 316.420746, 368.982361, 427.592499, 492.616028, & - 564.413452, 643.339905, 729.744141, 823.967834, 926.344910, 1037.201172, & - 1156.853638, 1285.610352, 1423.770142, 1571.622925, 1729.448975, 1897.519287, & - 2076.095947, 2265.431641, 2465.770508, 2677.348145, 2900.391357, 3135.119385, & - 3381.743652, 3640.468262, 3911.490479, 4194.930664, 4490.817383, 4799.149414, & - 5119.895020, 5452.990723, 5798.344727, 6156.074219, 6526.946777, 6911.870605, & - 7311.869141, 7727.412109, 8159.354004, 8608.525391, 9076.400391, 9562.682617, & - 10065.978516, 10584.631836, 11116.662109, 11660.067383, 12211.547852, 12766.873047, & - 13324.668945, 13881.331055, 14432.139648, 14975.615234, 15508.256836, 16026.115234, & - 16527.322266, 17008.789063, 17467.613281, 17901.621094, 18308.433594, 18685.718750, & - 19031.289063, 19343.511719, 19620.042969, 19859.390625, 20059.931641, 20219.664063, & - 20337.863281, 20412.308594, 20442.078125, 20425.718750, 20361.816406, 20249.511719, & - 20087.085938, 19874.025391, 19608.572266, 19290.226563, 18917.460938, 18489.707031, & - 18006.925781, 17471.839844, 16888.687500, 16262.046875, 15596.695313, 14898.453125, & - 14173.324219, 13427.769531, 12668.257813, 11901.339844, 11133.304688, 10370.175781, & - 9617.515625, 8880.453125, 8163.375000, 7470.343750, 6804.421875, 6168.531250, & - 5564.382813, 4993.796875, 4457.375000, 3955.960938, 3489.234375, 3057.265625, & - 2659.140625, 2294.242188, 1961.500000, 1659.476563, 1387.546875, 1143.250000, & - 926.507813, 734.992188, 568.062500, 424.414063, 302.476563, 202.484375, & - 122.101563, 62.781250, 22.835938, 3.757813, 0.000000, 0.000000 / - - data bk_ec/ 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000007, 0.000024, 0.000059, 0.000112, 0.000199, & - 0.000340, 0.000562, 0.000890, 0.001353, 0.001992, 0.002857, & - 0.003971, 0.005378, 0.007133, 0.009261, 0.011806, 0.014816, & - 0.018318, 0.022355, 0.026964, 0.032176, 0.038026, 0.044548, & - 0.051773, 0.059728, 0.068448, 0.077958, 0.088286, 0.099462, & - 0.111505, 0.124448, 0.138313, 0.153125, 0.168910, 0.185689, & - 0.203491, 0.222333, 0.242244, 0.263242, 0.285354, 0.308598, & - 0.332939, 0.358254, 0.384363, 0.411125, 0.438391, 0.466003, & - 0.493800, 0.521619, 0.549301, 0.576692, 0.603648, 0.630036, & - 0.655736, 0.680643, 0.704669, 0.727739, 0.749797, 0.770798, & - 0.790717, 0.809536, 0.827256, 0.843881, 0.859432, 0.873929, & - 0.887408, 0.899900, 0.911448, 0.922096, 0.931881, 0.940860, & - 0.949064, 0.956550, 0.963352, 0.969513, 0.975078, 0.980072, & - 0.984542, 0.988500, 0.991984, 0.995003, 0.997630, 1.000000 / - -! The following L63 will be used in the model -! The setting is the same as NCEP GFS's L64 except the top layer - real, dimension(64):: ak_sj, bk_sj - data ak_sj/64.247, 137.790, 221.958, & - 318.266, 428.434, 554.424, & - 698.457, 863.05803, 1051.07995, & - 1265.75194, 1510.71101, 1790.05098, & - 2108.36604, 2470.78817, 2883.03811, & - 3351.46002, 3883.05187, 4485.49315, & - 5167.14603, 5937.04991, 6804.87379, & - 7780.84698, 8875.64338, 10100.20534, & - 11264.35673, 12190.64366, 12905.42546, & - 13430.87867, 13785.88765, 13986.77987, & - 14047.96335, 13982.46770, 13802.40331, & - 13519.33841, 13144.59486, 12689.45608, & - 12165.28766, 11583.57006, 10955.84778, & - 10293.60402, 9608.08306, 8910.07678, & - 8209.70131, 7516.18560, 6837.69250, & - 6181.19473, 5552.39653, 4955.72632, & - 4394.37629, 3870.38682, 3384.76586, & - 2937.63489, 2528.37666, 2155.78385, & - 1818.20722, 1513.68173, 1240.03585, & - 994.99144, 776.23591, 581.48797, & - 408.53400, 255.26520, 119.70243, 0. / - - data bk_sj/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00201, 0.00792, 0.01755, & - 0.03079, 0.04751, 0.06761, & - 0.09097, 0.11746, 0.14690, & - 0.17911, 0.21382, 0.25076, & - 0.28960, 0.32994, 0.37140, & - 0.41353, 0.45589, 0.49806, & - 0.53961, 0.58015, 0.61935, & - 0.65692, 0.69261, 0.72625, & - 0.75773, 0.78698, 0.81398, & - 0.83876, 0.86138, 0.88192, & - 0.90050, 0.91722, 0.93223, & - 0.94565, 0.95762, 0.96827, & - 0.97771, 0.98608, 0.99347, 1./ - - character(len=128) :: fname - real, allocatable:: wk2(:,:) - real(kind=4), allocatable:: wk2_r4(:,:) - real, dimension(:,:,:), allocatable:: ud, vd - real, allocatable:: wc(:,:,:) - real(kind=4), allocatable:: uec(:,:,:), vec(:,:,:), tec(:,:,:), wec(:,:,:) - real(kind=4), allocatable:: psec(:,:), zsec(:,:), zhec(:,:,:), qec(:,:,:,:) - real(kind=4), allocatable:: psc(:,:) - real(kind=4), allocatable:: sphumec(:,:,:) - real, allocatable:: psc_r8(:,:), zhc(:,:,:), qc(:,:,:,:) - real, allocatable:: lat(:), lon(:), ak0(:), bk0(:) - real, allocatable:: pt_c(:,:,:), pt_d(:,:,:) - real:: s2c(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je,4) - real:: s2c_c(Atm(1)%bd%is:Atm(1)%bd%ie+1,Atm(1)%bd%js:Atm(1)%bd%je,4) - real:: s2c_d(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je+1,4) - integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je):: & - id1, id2, jdc - integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie+1,Atm(1)%bd%js:Atm(1)%bd%je):: & - id1_c, id2_c, jdc_c - integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je+1):: & - id1_d, id2_d, jdc_d - real:: utmp, vtmp - integer:: i, j, k, n, im, jm, km, npz, npt - integer:: i1, i2, j1, ncid - integer:: jbeg, jend, jn - integer tsize(3) - logical:: read_ts = .true. - logical:: land_ts = .false. - logical:: found - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel -#ifdef MULTI_GASES - integer :: spfo, spfo2, spfo3 -#else - integer :: o3mr -#endif - real:: wt, qt, m_fac - real(kind=8) :: scale_value, offset, ptmp - real(kind=R_GRID), dimension(2):: p1, p2, p3 - real(kind=R_GRID), dimension(3):: e1, e2, ex, ey - real, allocatable:: ps_gfs(:,:), zh_gfs(:,:,:) -#ifdef MULTI_GASES - real, allocatable:: spfo_gfs(:,:,:), spfo2_gfs(:,:,:), spfo3_gfs(:,:,:) -#else - real, allocatable:: o3mr_gfs(:,:,:) -#endif - real, allocatable:: ak_gfs(:), bk_gfs(:) - integer :: id_res, ntprog, ntracers, ks, iq, nt - character(len=64) :: tracer_name - integer :: levp_gfs = 64 - type (restart_file_type) :: ORO_restart, GFS_restart - character(len=64) :: fn_oro_ics = 'oro_data.nc' - character(len=64) :: fn_gfs_ics = 'gfs_data.nc' - character(len=64) :: fn_gfs_ctl = 'gfs_ctrl.nc' - logical :: filtered_terrain = .true. - namelist /external_ic_nml/ filtered_terrain - - is = Atm(1)%bd%is - ie = Atm(1)%bd%ie - js = Atm(1)%bd%js - je = Atm(1)%bd%je - isd = Atm(1)%bd%isd - ied = Atm(1)%bd%ied - jsd = Atm(1)%bd%jsd - jed = Atm(1)%bd%jed - - deg2rad = pi/180. - - npz = Atm(1)%npz - call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers, num_prog=ntprog) - if(is_master()) write(*,*) 'ntracers = ', ntracers, 'ntprog = ',ntprog - - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') -#ifdef MULTI_GASES - spfo = get_tracer_index(MODEL_ATMOS, 'spfo') - spfo2 = get_tracer_index(MODEL_ATMOS, 'spfo2') - spfo3 = get_tracer_index(MODEL_ATMOS, 'spfo3') -#else - o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') -#endif - - if (is_master()) then - print *, 'sphum = ', sphum - print *, 'liq_wat = ', liq_wat - if ( Atm(1)%flagstruct%nwat .eq. 6 ) then - print *, 'rainwat = ', rainwat - print *, 'iec_wat = ', ice_wat - print *, 'snowwat = ', snowwat - print *, 'graupel = ', graupel - endif -#ifdef MULTI_GASES - print *, ' spfo3 = ', spfo3 - print *, ' spfo = ', spfo - print *, ' spfo2 = ', spfo2 -#else - print *, ' o3mr = ', o3mr -#endif - endif - - -! Set up model's ak and bk - if ( npz <= 64 ) then - Atm(1)%ak(:) = ak_sj(:) - Atm(1)%bk(:) = bk_sj(:) - Atm(1)%ptop = Atm(1)%ak(1) - else - call set_eta(npz, ks, Atm(1)%ptop, Atm(1)%ak, Atm(1)%bk) - endif - -!! Read in model terrain from oro_data.tile?.nc - if (filtered_terrain) then - id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_filt', Atm(1)%phis, domain=Atm(1)%domain) - elseif (.not. filtered_terrain) then - id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_raw', Atm(1)%phis, domain=Atm(1)%domain) - endif - call restore_state (ORO_restart) - call free_restart_type(ORO_restart) - Atm(1)%phis = Atm(1)%phis*grav - if(is_master()) write(*,*) 'done reading model terrain from oro_data.nc' - call mpp_update_domains( Atm(1)%phis, Atm(1)%domain ) - -!! Read in o3mr, ps and zh from GFS_data.tile?.nc -#ifdef MULTI_GASES - allocate (spfo3_gfs(is:ie,js:je,levp_gfs)) - allocate ( spfo_gfs(is:ie,js:je,levp_gfs)) - allocate (spfo2_gfs(is:ie,js:je,levp_gfs)) -#else - allocate (o3mr_gfs(is:ie,js:je,levp_gfs)) -#endif - allocate (ps_gfs(is:ie,js:je)) - allocate (zh_gfs(is:ie,js:je,levp_gfs+1)) - -#ifdef MULTI_GASES - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'spfo3', spfo3_gfs, & - mandatory=.false.,domain=Atm(1)%domain) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'spfo', spfo_gfs, & - mandatory=.false.,domain=Atm(1)%domain) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'spfo2', spfo2_gfs, & - mandatory=.false.,domain=Atm(1)%domain) -#else - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'o3mr', o3mr_gfs, & - mandatory=.false.,domain=Atm(1)%domain) -#endif - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ps', ps_gfs, domain=Atm(1)%domain) - id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ZH', zh_gfs, domain=Atm(1)%domain) - call restore_state (GFS_restart) - call free_restart_type(GFS_restart) - - - ! Get GFS ak, bk for o3mr vertical interpolation - allocate (wk2(levp_gfs+1,2)) - allocate (ak_gfs(levp_gfs+1)) - allocate (bk_gfs(levp_gfs+1)) - call read_data('INPUT/'//trim(fn_gfs_ctl),'vcoord',wk2, no_domain=.TRUE.) - ak_gfs(1:levp_gfs+1) = wk2(1:levp_gfs+1,1) - bk_gfs(1:levp_gfs+1) = wk2(1:levp_gfs+1,2) - deallocate (wk2) - - if ( bk_gfs(1) < 1.E-9 ) ak_gfs(1) = max(1.e-9, ak_gfs(1)) - -#ifdef MULTI_GASES - iq = spfo3 - if(is_master()) write(*,*) 'Reading spfo3 from GFS_data.nc:' - if(is_master()) write(*,*) 'spfo3 =', iq - call remap_scalar_single(Atm(1), levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, spfo3_gfs, zh_gfs, iq) - iq = spfo - if(is_master()) write(*,*) 'Reading spfo from GFS_data.nc:' - if(is_master()) write(*,*) 'spfo =', iq - call remap_scalar_single(Atm(1), levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, spfo_gfs, zh_gfs, iq) - iq = spfo2 - if(is_master()) write(*,*) 'Reading spfo2 from GFS_data.nc:' - if(is_master()) write(*,*) 'spfo2 =', iq - call remap_scalar_single(Atm(1), levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, spfo2_gfs, zh_gfs, iq) -#else - iq = o3mr - if(is_master()) write(*,*) 'Reading o3mr from GFS_data.nc:' - if(is_master()) write(*,*) 'o3mr =', iq - call remap_scalar_single(Atm(1), levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, o3mr_gfs, zh_gfs, iq) -#endif - - deallocate (ak_gfs, bk_gfs) - deallocate (ps_gfs, zh_gfs) -#ifdef MULTI_GASES - deallocate (spfo3_gfs) - deallocate ( spfo_gfs) - deallocate (spfo2_gfs) -#else - deallocate (o3mr_gfs) -#endif - -!! Start to read EC data - fname = Atm(1)%flagstruct%res_latlon_dynamics - - if( file_exist(fname) ) then - call open_ncfile( fname, ncid ) ! open the file - - call get_ncdim1( ncid, 'longitude', tsize(1) ) - call get_ncdim1( ncid, 'latitude', tsize(2) ) - call get_ncdim1( ncid, 'level', tsize(3) ) - - im = tsize(1); jm = tsize(2); km = tsize(3) - - if(is_master()) write(*,*) fname - if(is_master()) write(*,*) ' ECMWF IC dimensions:', tsize - - allocate ( lon(im) ) - allocate ( lat(jm) ) - - call _GET_VAR1(ncid, 'longitude', im, lon ) - call _GET_VAR1(ncid, 'latitude', jm, lat ) - -!! Convert to radian - do i = 1, im - lon(i) = lon(i) * deg2rad ! lon(1) = 0. - enddo - do j = 1, jm - lat(j) = lat(j) * deg2rad - enddo - - allocate ( ak0(km+1) ) - allocate ( bk0(km+1) ) - -! The ECMWF data from does not contain (ak,bk) - do k=1, km+1 - ak0(k) = ak_ec(k) - bk0(k) = bk_ec(k) - enddo - - if( is_master() ) then - do k=1,km+1 - write(*,*) k, ak0(k), bk0(k) - enddo - endif - -! Limiter to prevent NAN at top during remapping - if ( bk0(1) < 1.E-9 ) ak0(1) = max(1.e-9, ak0(1)) - - else - call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for NCEP IC does not exist') - endif - -! Initialize lat-lon to Cubed bi-linear interpolation coeff: - call remap_coef( is, ie, js, je, isd, ied, jsd, jed, & - im, jm, lon, lat, id1, id2, jdc, s2c , Atm(1)%gridstruct%agrid ) - -! Find bounding latitudes: - jbeg = jm-1; jend = 2 - do j=js,je - do i=is,ie - j1 = jdc(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) - enddo - enddo - - if(is_master()) write(*,*) 'jbeg, jend = ', jbeg, jend -! read in surface pressure and height: - allocate ( psec(im,jbeg:jend) ) - allocate ( zsec(im,jbeg:jend) ) - allocate ( wk2_r4(im,jbeg:jend) ) - - call get_var2_r4( ncid, 'lnsp', 1,im, jbeg,jend, wk2_r4 ) - call get_var_att_double ( ncid, 'lnsp', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'lnsp', 'add_offset', offset ) - psec(:,:) = exp(wk2_r4(:,:)*scale_value + offset) - if(is_master()) write(*,*) 'done reading psec' - - call get_var2_r4( ncid, 'z', 1,im, jbeg,jend, wk2_r4 ) - call get_var_att_double ( ncid, 'z', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'z', 'add_offset', offset ) - zsec(:,:) = (wk2_r4(:,:)*scale_value + offset)/grav - if(is_master()) write(*,*) 'done reading zsec' - - deallocate ( wk2_r4 ) - -! Read in temperature: - allocate ( tec(1:im,jbeg:jend, 1:km) ) - - call get_var3_r4( ncid, 't', 1,im, jbeg,jend, 1,km, tec ) - call get_var_att_double ( ncid, 't', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 't', 'add_offset', offset ) - tec(:,:,:) = tec(:,:,:)*scale_value + offset - if(is_master()) write(*,*) 'done reading tec' - -! read in specific humidity: - allocate ( sphumec(1:im,jbeg:jend, 1:km) ) - - call get_var3_r4( ncid, 'q', 1,im, jbeg,jend, 1,km, sphumec(:,:,:) ) - call get_var_att_double ( ncid, 'q', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'q', 'add_offset', offset ) - sphumec(:,:,:) = sphumec(:,:,:)*scale_value + offset - if(is_master()) write(*,*) 'done reading sphum ec' - -! Read in other tracers from EC data and remap them into cubic sphere grid: - allocate ( qec(1:im,jbeg:jend,1:km,5) ) - - do n = 1, 5 - if (n == sphum) then - qec(:,:,:,sphum) = sphumec(:,:,:) - deallocate ( sphumec ) - else if (n == liq_wat) then - call get_var3_r4( ncid, 'clwc', 1,im, jbeg,jend, 1,km, qec(:,:,:,liq_wat) ) - call get_var_att_double ( ncid, 'clwc', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'clwc', 'add_offset', offset ) - qec(:,:,:,liq_wat) = qec(:,:,:,liq_wat)*scale_value + offset - if(is_master()) write(*,*) 'done reading clwc ec' - else if (n == rainwat) then - call get_var3_r4( ncid, 'crwc', 1,im, jbeg,jend, 1,km, qec(:,:,:,rainwat) ) - call get_var_att_double ( ncid, 'crwc', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'crwc', 'add_offset', offset ) - qec(:,:,:,rainwat) = qec(:,:,:,rainwat)*scale_value + offset - if(is_master()) write(*,*) 'done reading crwc ec' - else if (n == ice_wat) then - call get_var3_r4( ncid, 'ciwc', 1,im, jbeg,jend, 1,km, qec(:,:,:,ice_wat) ) - call get_var_att_double ( ncid, 'ciwc', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'ciwc', 'add_offset', offset ) - qec(:,:,:,ice_wat) = qec(:,:,:,ice_wat)*scale_value + offset - if(is_master()) write(*,*) 'done reading ciwc ec' - else if (n == snowwat) then - call get_var3_r4( ncid, 'cswc', 1,im, jbeg,jend, 1,km, qec(:,:,:,snowwat) ) - call get_var_att_double ( ncid, 'cswc', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'cswc', 'add_offset', offset ) - qec(:,:,:,snowwat) = qec(:,:,:,snowwat)*scale_value + offset - if(is_master()) write(*,*) 'done reading cswc ec' - else - if(is_master()) write(*,*) 'nq is more then 5!' - endif - - enddo - - -!!!! Compute height on edges, zhec [ use psec, zsec, tec, sphum] - allocate ( zhec(1:im,jbeg:jend, km+1) ) - jn = jend - jbeg + 1 - - call compute_zh(im, jn, km, ak0, bk0, psec, zsec, tec, qec, 5, zhec ) - if(is_master()) write(*,*) 'done compute zhec' - -! convert zhec, psec, zsec from EC grid to cubic grid - allocate (psc(is:ie,js:je)) - allocate (psc_r8(is:ie,js:je)) - -#ifdef LOGP_INTP - do j=jbeg,jend - do i=1,im - psec(i,j) = log(psec(i,j)) - enddo - enddo -#endif - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) -#ifdef LOGP_INTP - ptmp = s2c(i,j,1)*psec(i1,j1 ) + s2c(i,j,2)*psec(i2,j1 ) + & - s2c(i,j,3)*psec(i2,j1+1) + s2c(i,j,4)*psec(i1,j1+1) - psc(i,j) = exp(ptmp) -#else - psc(i,j) = s2c(i,j,1)*psec(i1,j1 ) + s2c(i,j,2)*psec(i2,j1 ) + & - s2c(i,j,3)*psec(i2,j1+1) + s2c(i,j,4)*psec(i1,j1+1) -#endif - enddo - enddo - deallocate ( psec ) - deallocate ( zsec ) - - allocate (zhc(is:ie,js:je,km+1)) -!$OMP parallel do default(none) shared(is,ie,js,je,km,s2c,id1,id2,jdc,zhc,zhec) & -!$OMP private(i1,i2,j1) - do k=1,km+1 - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - zhc(i,j,k) = s2c(i,j,1)*zhec(i1,j1 ,k) + s2c(i,j,2)*zhec(i2,j1 ,k) + & - s2c(i,j,3)*zhec(i2,j1+1,k) + s2c(i,j,4)*zhec(i1,j1+1,k) - enddo - enddo - enddo - deallocate ( zhec ) - - if(is_master()) write(*,*) 'done interpolate psec/zsec/zhec into cubic grid psc/zhc!' - -! Read in other tracers from EC data and remap them into cubic sphere grid: - allocate ( qc(is:ie,js:je,km,6) ) - - do n = 1, 5 -!$OMP parallel do default(none) shared(n,is,ie,js,je,km,s2c,id1,id2,jdc,qc,qec) & -!$OMP private(i1,i2,j1) - do k=1,km - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - qc(i,j,k,n) = s2c(i,j,1)*qec(i1,j1 ,k,n) + s2c(i,j,2)*qec(i2,j1 ,k,n) + & - s2c(i,j,3)*qec(i2,j1+1,k,n) + s2c(i,j,4)*qec(i1,j1+1,k,n) - enddo - enddo - enddo - enddo - - qc(:,:,:,graupel) = 0. ! note Graupel must be tracer #6 - - deallocate ( qec ) - if(is_master()) write(*,*) 'done interpolate tracers (qec) into cubic (qc)' - -! Read in vertical wind from EC data and remap them into cubic sphere grid: - allocate ( wec(1:im,jbeg:jend, 1:km) ) - allocate ( wc(is:ie,js:je,km)) - - call get_var3_r4( ncid, 'w', 1,im, jbeg,jend, 1,km, wec ) - call get_var_att_double ( ncid, 'w', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'w', 'add_offset', offset ) - wec(:,:,:) = wec(:,:,:)*scale_value + offset - !call p_maxmin('wec', wec, 1, im, jbeg, jend, km, 1.) - -!$OMP parallel do default(none) shared(is,ie,js,je,km,id1,id2,jdc,s2c,wc,wec) & -!$OMP private(i1,i2,j1) - do k=1,km - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - wc(i,j,k) = s2c(i,j,1)*wec(i1,j1 ,k) + s2c(i,j,2)*wec(i2,j1 ,k) + & - s2c(i,j,3)*wec(i2,j1+1,k) + s2c(i,j,4)*wec(i1,j1+1,k) - enddo - enddo - enddo - !call p_maxmin('wc', wc, is, ie, js, je, km, 1.) - - deallocate ( wec ) - if(is_master()) write(*,*) 'done reading and interpolate vertical wind (w) into cubic' - -! remap tracers - psc_r8(:,:) = psc(:,:) - deallocate ( psc ) - - call remap_scalar_ec(Atm(1), km, npz, 6, ak0, bk0, psc_r8, qc, wc, zhc ) - call mpp_update_domains(Atm(1)%phis, Atm(1)%domain) - if(is_master()) write(*,*) 'done remap_scalar_ec' - - deallocate ( zhc ) - deallocate ( wc ) - deallocate ( qc ) - -!! Winds: - ! get lat/lon values of pt_c and pt_d from grid data (pt_b) - allocate (pt_c(isd:ied+1,jsd:jed ,2)) - allocate (pt_d(isd:ied ,jsd:jed+1,2)) - allocate (ud(is:ie , js:je+1, km)) - allocate (vd(is:ie+1, js:je , km)) - - call get_staggered_grid( is, ie, js, je, & - isd, ied, jsd, jed, & - Atm(1)%gridstruct%grid, pt_c, pt_d) - - !------ pt_c part ------ - ! Initialize lat-lon to Cubed bi-linear interpolation coeff: - call remap_coef( is, ie+1, js, je, isd, ied+1, jsd, jed, & - im, jm, lon, lat, id1_c, id2_c, jdc_c, s2c_c, pt_c) - - ! Find bounding latitudes: - jbeg = jm-1; jend = 2 - do j=js,je - do i=is,ie+1 - j1 = jdc_c(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) - enddo - enddo - - ! read in EC wind data - allocate ( uec(1:im,jbeg:jend, 1:km) ) - allocate ( vec(1:im,jbeg:jend, 1:km) ) - - call get_var3_r4( ncid, 'u', 1,im, jbeg,jend, 1,km, uec ) - call get_var_att_double ( ncid, 'u', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'u', 'add_offset', offset ) - do k=1,km - do j=jbeg, jend - do i=1,im - uec(i,j,k) = uec(i,j,k)*scale_value + offset - enddo - enddo - enddo - if(is_master()) write(*,*) 'first time done reading uec' - - call get_var3_r4( ncid, 'v', 1,im, jbeg,jend, 1,km, vec ) - call get_var_att_double ( ncid, 'v', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'v', 'add_offset', offset ) - do k=1,km - do j=jbeg, jend - do i=1,im - vec(i,j,k) = vec(i,j,k)*scale_value + offset - enddo - enddo - enddo - - if(is_master()) write(*,*) 'first time done reading vec' - -!$OMP parallel do default(none) shared(is,ie,js,je,km,s2c_c,id1_c,id2_c,jdc_c,uec,vec,Atm,vd) & -!$OMP private(i1,i2,j1,p1,p2,p3,e2,ex,ey,utmp,vtmp) - do k=1,km - do j=js,je - do i=is,ie+1 - i1 = id1_c(i,j) - i2 = id2_c(i,j) - j1 = jdc_c(i,j) - p1(:) = Atm(1)%gridstruct%grid(i,j ,1:2) - p2(:) = Atm(1)%gridstruct%grid(i,j+1,1:2) - call mid_pt_sphere(p1, p2, p3) - call get_unit_vect2(p1, p2, e2) - call get_latlon_vector(p3, ex, ey) - utmp = s2c_c(i,j,1)*uec(i1,j1 ,k) + & - s2c_c(i,j,2)*uec(i2,j1 ,k) + & - s2c_c(i,j,3)*uec(i2,j1+1,k) + & - s2c_c(i,j,4)*uec(i1,j1+1,k) - vtmp = s2c_c(i,j,1)*vec(i1,j1 ,k) + & - s2c_c(i,j,2)*vec(i2,j1 ,k) + & - s2c_c(i,j,3)*vec(i2,j1+1,k) + & - s2c_c(i,j,4)*vec(i1,j1+1,k) - vd(i,j,k) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey) - enddo - enddo - enddo - - deallocate ( uec, vec ) - - !------ pt_d part ------ - ! Initialize lat-lon to Cubed bi-linear interpolation coeff: - call remap_coef( is, ie, js, je+1, isd, ied, jsd, jed+1, & - im, jm, lon, lat, id1_d, id2_d, jdc_d, s2c_d, pt_d) - deallocate ( pt_c, pt_d ) - - ! Find bounding latitudes: - jbeg = jm-1; jend = 2 - do j=js,je+1 - do i=is,ie - j1 = jdc_d(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) - enddo - enddo - - ! read in EC wind data - allocate ( uec(1:im,jbeg:jend, 1:km) ) - allocate ( vec(1:im,jbeg:jend, 1:km) ) - - call get_var3_r4( ncid, 'u', 1,im, jbeg,jend, 1,km, uec ) - call get_var_att_double ( ncid, 'u', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'u', 'add_offset', offset ) - uec(:,:,:) = uec(:,:,:)*scale_value + offset - if(is_master()) write(*,*) 'second time done reading uec' - - call get_var3_r4( ncid, 'v', 1,im, jbeg,jend, 1,km, vec ) - call get_var_att_double ( ncid, 'v', 'scale_factor', scale_value ) - call get_var_att_double ( ncid, 'v', 'add_offset', offset ) - vec(:,:,:) = vec(:,:,:)*scale_value + offset - if(is_master()) write(*,*) 'second time done reading vec' - -!$OMP parallel do default(none) shared(is,ie,js,je,km,id1_d,id2_d,jdc_d,s2c_d,uec,vec,Atm,ud) & -!$OMP private(i1,i2,j1,p1,p2,p3,e1,ex,ey,utmp,vtmp) - do k=1,km - do j=js,je+1 - do i=is,ie - i1 = id1_d(i,j) - i2 = id2_d(i,j) - j1 = jdc_d(i,j) - p1(:) = Atm(1)%gridstruct%grid(i, j,1:2) - p2(:) = Atm(1)%gridstruct%grid(i+1,j,1:2) - call mid_pt_sphere(p1, p2, p3) - call get_unit_vect2(p1, p2, e1) - call get_latlon_vector(p3, ex, ey) - utmp = s2c_d(i,j,1)*uec(i1,j1 ,k) + & - s2c_d(i,j,2)*uec(i2,j1 ,k) + & - s2c_d(i,j,3)*uec(i2,j1+1,k) + & - s2c_d(i,j,4)*uec(i1,j1+1,k) - vtmp = s2c_d(i,j,1)*vec(i1,j1 ,k) + & - s2c_d(i,j,2)*vec(i2,j1 ,k) + & - s2c_d(i,j,3)*vec(i2,j1+1,k) + & - s2c_d(i,j,4)*vec(i1,j1+1,k) - ud(i,j,k) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey) - enddo - enddo - enddo - deallocate ( uec, vec ) - - call remap_dwinds(km, npz, ak0, bk0, psc_r8, ud, vd, Atm(1)) - deallocate ( ud, vd ) - -#ifndef COND_IFS_IC -! Add cloud condensate from IFS to total MASS -! Adjust the mixing ratios consistently... - do k=1,npz - do j=js,je - do i=is,ie - wt = Atm(1)%delp(i,j,k) - if ( Atm(1)%flagstruct%nwat .eq. 2 ) then - qt = wt*(1.+Atm(1)%q(i,j,k,liq_wat)) - elseif ( Atm(1)%flagstruct%nwat .eq. 6 ) then - qt = wt*(1. + Atm(1)%q(i,j,k,liq_wat) + & - Atm(1)%q(i,j,k,ice_wat) + & - Atm(1)%q(i,j,k,rainwat) + & - Atm(1)%q(i,j,k,snowwat) + & - Atm(1)%q(i,j,k,graupel)) - endif - m_fac = wt / qt - do iq=1,ntracers - Atm(1)%q(i,j,k,iq) = m_fac * Atm(1)%q(i,j,k,iq) - enddo - Atm(1)%delp(i,j,k) = qt - enddo - enddo - enddo -#endif - - deallocate ( ak0, bk0 ) -! deallocate ( psc ) - deallocate ( psc_r8 ) - deallocate ( lat, lon ) - - Atm(1)%flagstruct%make_nh = .false. - - end subroutine get_ecmwf_ic -!------------------------------------------------------------------ -!------------------------------------------------------------------ - subroutine get_fv_ic( Atm, fv_domain, nq ) - type(fv_atmos_type), intent(inout) :: Atm(:) - type(domain2d), intent(inout) :: fv_domain - integer, intent(in):: nq - - character(len=128) :: fname, tracer_name - real, allocatable:: ps0(:,:), gz0(:,:), u0(:,:,:), v0(:,:,:), t0(:,:,:), dp0(:,:,:), q0(:,:,:,:) - real, allocatable:: ua(:,:,:), va(:,:,:) - real, allocatable:: lat(:), lon(:), ak0(:), bk0(:) - integer :: i, j, k, im, jm, km, npz, tr_ind - integer tsize(3) -! integer sphum, liq_wat, ice_wat, cld_amt ! GFDL AM2 physics - logical found - - npz = Atm(1)%npz - -! Zero out all initial tracer fields: - Atm(1)%q = 0. - -! Read in lat-lon FV core restart file - fname = Atm(1)%flagstruct%res_latlon_dynamics - - if( file_exist(fname) ) then - call field_size(fname, 'T', tsize, field_found=found) - if(is_master()) write(*,*) 'Using lat-lon FV restart:', fname - - if ( found ) then - im = tsize(1); jm = tsize(2); km = tsize(3) - if(is_master()) write(*,*) 'External IC dimensions:', tsize - else - call mpp_error(FATAL,'==> Error in get_external_ic: field not found') - endif - -! Define the lat-lon coordinate: - allocate ( lon(im) ) - allocate ( lat(jm) ) - - do i=1,im - lon(i) = (0.5 + real(i-1)) * 2.*pi/real(im) - enddo - - do j=1,jm - lat(j) = -0.5*pi + real(j-1)*pi/real(jm-1) ! SP to NP - enddo - - allocate ( ak0(1:km+1) ) - allocate ( bk0(1:km+1) ) - allocate ( ps0(1:im,1:jm) ) - allocate ( gz0(1:im,1:jm) ) - allocate ( u0(1:im,1:jm,1:km) ) - allocate ( v0(1:im,1:jm,1:km) ) - allocate ( t0(1:im,1:jm,1:km) ) - allocate ( dp0(1:im,1:jm,1:km) ) - - call read_data (fname, 'ak', ak0) - call read_data (fname, 'bk', bk0) - call read_data (fname, 'Surface_geopotential', gz0) - call read_data (fname, 'U', u0) - call read_data (fname, 'V', v0) - call read_data (fname, 'T', t0) - call read_data (fname, 'DELP', dp0) - -! Share the load - if(is_master()) call pmaxmin( 'ZS_data', gz0, im, jm, 1./grav) - if(mpp_pe()==1) call pmaxmin( 'U_data', u0, im*jm, km, 1.) - if(mpp_pe()==1) call pmaxmin( 'V_data', v0, im*jm, km, 1.) - if(mpp_pe()==2) call pmaxmin( 'T_data', t0, im*jm, km, 1.) - if(mpp_pe()==3) call pmaxmin( 'DEL-P', dp0, im*jm, km, 0.01) - - - else - call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for dynamics does not exist') - endif - -! Read in tracers: only AM2 "physics tracers" at this point - fname = Atm(1)%flagstruct%res_latlon_tracers - - if( file_exist(fname) ) then - if(is_master()) write(*,*) 'Using lat-lon tracer restart:', fname - - allocate ( q0(im,jm,km,Atm(1)%ncnst) ) - q0 = 0. - - do tr_ind = 1, nq - call get_tracer_names(MODEL_ATMOS, tr_ind, tracer_name) - if (field_exist(fname,tracer_name)) then - call read_data(fname, tracer_name, q0(1:im,1:jm,1:km,tr_ind)) - call mpp_error(NOTE,'==> Have read tracer '//trim(tracer_name)//' from '//trim(fname)) - cycle - endif - enddo - else - call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for tracers does not exist') - endif - -! D to A transform on lat-lon grid: - allocate ( ua(im,jm,km) ) - allocate ( va(im,jm,km) ) - - call d2a3d(u0, v0, ua, va, im, jm, km, lon) - - deallocate ( u0 ) - deallocate ( v0 ) - - if(mpp_pe()==4) call pmaxmin( 'UA', ua, im*jm, km, 1.) - if(mpp_pe()==4) call pmaxmin( 'VA', va, im*jm, km, 1.) - - do j=1,jm - do i=1,im - ps0(i,j) = ak0(1) - enddo - enddo - - do k=1,km - do j=1,jm - do i=1,im - ps0(i,j) = ps0(i,j) + dp0(i,j,k) - enddo - enddo - enddo - - if (is_master()) call pmaxmin( 'PS_data (mb)', ps0, im, jm, 0.01) - -! Horizontal interpolation to the cubed sphere grid center -! remap vertically with terrain adjustment - - call remap_xyz( im, 1, jm, jm, km, npz, nq, Atm(1)%ncnst, lon, lat, ak0, bk0, & - ps0, gz0, ua, va, t0, q0, Atm(1) ) - - deallocate ( ak0 ) - deallocate ( bk0 ) - deallocate ( ps0 ) - deallocate ( gz0 ) - deallocate ( t0 ) - deallocate ( q0 ) - deallocate ( dp0 ) - deallocate ( ua ) - deallocate ( va ) - deallocate ( lat ) - deallocate ( lon ) - - end subroutine get_fv_ic -!------------------------------------------------------------------ -!------------------------------------------------------------------ -#ifndef DYCORE_SOLO - subroutine ncep2fms(im, jm, lon, lat, wk) - - integer, intent(in):: im, jm - real, intent(in):: lon(im), lat(jm) - real(kind=4), intent(in):: wk(im,jm) -! local: - real :: rdlon(im) - real :: rdlat(jm) - real:: a1, b1 - real:: delx, dely - real:: xc, yc ! "data" location - real:: c1, c2, c3, c4 - integer i,j, i1, i2, jc, i0, j0, it, jt - - do i=1,im-1 - rdlon(i) = 1. / (lon(i+1) - lon(i)) - enddo - rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) - - do j=1,jm-1 - rdlat(j) = 1. / (lat(j+1) - lat(j)) - enddo - -! * Interpolate to "FMS" 1x1 SST data grid -! lon: 0.5, 1.5, ..., 359.5 -! lat: -89.5, -88.5, ... , 88.5, 89.5 - - delx = 360./real(i_sst) - dely = 180./real(j_sst) - - jt = 1 - do 5000 j=1,j_sst - - yc = (-90. + dely * (0.5+real(j-1))) * deg2rad - if ( yclat(jm) ) then - jc = jm-1 - b1 = 1. - else - do j0=jt,jm-1 - if ( yc>=lat(j0) .and. yc<=lat(j0+1) ) then - jc = j0 - jt = j0 - b1 = (yc-lat(jc)) * rdlat(jc) - go to 222 - endif - enddo - endif -222 continue - it = 1 - - do i=1,i_sst - xc = delx * (0.5+real(i-1)) * deg2rad - if ( xc>lon(im) ) then - i1 = im; i2 = 1 - a1 = (xc-lon(im)) * rdlon(im) - elseif ( xc=lon(i0) .and. xc<=lon(i0+1) ) then - i1 = i0; i2 = i0+1 - it = i0 - a1 = (xc-lon(i1)) * rdlon(i0) - go to 111 - endif - enddo - endif -111 continue - - if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then - write(*,*) 'gid=', mpp_pe(), i,j,a1, b1 - endif - - c1 = (1.-a1) * (1.-b1) - c2 = a1 * (1.-b1) - c3 = a1 * b1 - c4 = (1.-a1) * b1 -! Interpolated surface pressure - sst_ncep(i,j) = c1*wk(i1,jc ) + c2*wk(i2,jc ) + & - c3*wk(i2,jc+1) + c4*wk(i1,jc+1) - enddo !i-loop -5000 continue ! j-loop - - end subroutine ncep2fms -#endif - - - subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & - im, jm, lon, lat, id1, id2, jdc, s2c, agrid ) - - integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed - integer, intent(in):: im, jm - real, intent(in):: lon(im), lat(jm) - real, intent(out):: s2c(is:ie,js:je,4) - integer, intent(out), dimension(is:ie,js:je):: id1, id2, jdc - real, intent(in):: agrid(isd:ied,jsd:jed,2) -! local: - real :: rdlon(im) - real :: rdlat(jm) - real:: a1, b1 - integer i,j, i1, i2, jc, i0, j0 - - do i=1,im-1 - rdlon(i) = 1. / (lon(i+1) - lon(i)) - enddo - rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) - - do j=1,jm-1 - rdlat(j) = 1. / (lat(j+1) - lat(j)) - enddo - -! * Interpolate to cubed sphere cell center - do 5000 j=js,je - - do i=is,ie - - if ( agrid(i,j,1)>lon(im) ) then - i1 = im; i2 = 1 - a1 = (agrid(i,j,1)-lon(im)) * rdlon(im) - elseif ( agrid(i,j,1)=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then - i1 = i0; i2 = i0+1 - a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0) - go to 111 - endif - enddo - endif -111 continue - - if ( agrid(i,j,2)lat(jm) ) then - jc = jm-1 - b1 = 1. - else - do j0=1,jm-1 - if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then - jc = j0 - b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc) - go to 222 - endif - enddo - endif -222 continue - - if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then - write(*,*) 'gid=', mpp_pe(), i,j,a1, b1 - endif - - s2c(i,j,1) = (1.-a1) * (1.-b1) - s2c(i,j,2) = a1 * (1.-b1) - s2c(i,j,3) = a1 * b1 - s2c(i,j,4) = (1.-a1) * b1 - id1(i,j) = i1 - id2(i,j) = i2 - jdc(i,j) = jc - enddo !i-loop -5000 continue ! j-loop - - end subroutine remap_coef - - - subroutine remap_scalar(im, jm, km, npz, nq, ncnst, ak0, bk0, psc, gzc, ta, qa, Atm) - type(fv_atmos_type), intent(inout) :: Atm - integer, intent(in):: im, jm, km, npz, nq, ncnst - real, intent(in):: ak0(km+1), bk0(km+1) - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: psc, gzc - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: ta - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km,ncnst):: qa -! local: - real, dimension(Atm%bd%is:Atm%bd%ie,km):: tp - real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0, pn0 - real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1 - real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1, pn1 - real(kind=R_GRID), dimension(2*km+1):: gz, pn - real pk0(km+1) - real qp(Atm%bd%is:Atm%bd%ie,km,ncnst) - real p1, p2, alpha, rdg - real(kind=R_GRID):: pst, pt0 -#ifdef MULTI_GASES - integer spfo, spfo2, spfo3 -#else - integer o3mr -#endif - integer i,j,k, k2,l, iq - integer sphum, clwmr - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = Atm%bd%is - ie = Atm%bd%ie - js = Atm%bd%js - je = Atm%bd%je - isd = Atm%bd%isd - ied = Atm%bd%ied - jsd = Atm%bd%jsd - jed = Atm%bd%jed - - k2 = max(10, km/2) - -! nq is always 1 - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - - if (mpp_pe()==1) then - print *, 'sphum = ', sphum, ' ncnst=', ncnst - print *, 'T_is_Tv = ', T_is_Tv, ' zvir=', zvir, ' kappa=', kappa - endif - - if ( sphum/=1 ) then - call mpp_error(FATAL,'SPHUM must be 1st tracer') - endif - - call prt_maxmin('ZS_FV3', Atm%phis, is, ie, js, je, 3, 1, 1./grav) - call prt_maxmin('ZS_GFS', gzc, is, ie, js, je, 0, 1, 1./grav) - call prt_maxmin('PS_Data', psc, is, ie, js, je, 0, 1, 0.01) - call prt_maxmin('T_Data', ta, is, ie, js, je, 0, km, 1.) - call prt_maxmin('q_Data', qa(is:ie,js:je,1:km,1), is, ie, js, je, 0, km, 1.) - - do 5000 j=js,je - - do i=is,ie - - do iq=1,ncnst - do k=1,km - qp(i,k,iq) = qa(i,j,k,iq) - enddo - enddo - - if ( T_is_Tv ) then -! The "T" field in NCEP analysis is actually virtual temperature (Larry H. post processing) -! BEFORE 20051201 - do k=1,km - tp(i,k) = ta(i,j,k) - enddo - else - do k=1,km -#ifdef MULTI_GASES - tp(i,k) = ta(i,j,k)*virq(qp(i,k,:)) -#else - tp(i,k) = ta(i,j,k)*(1.+zvir*qp(i,k,sphum)) -#endif - enddo - endif -! Tracers: - - do k=1,km+1 - pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) - pn0(i,k) = log(pe0(i,k)) - pk0(k) = pe0(i,k)**kappa - enddo -! gzc is geopotential - -! Note the following line, gz is actully Z (from Jeff's data). - gz(km+1) = gzc(i,j) - do k=km,1,-1 - gz(k) = gz(k+1) + rdgas*tp(i,k)*(pn0(i,k+1)-pn0(i,k)) - enddo - - do k=1,km+1 - pn(k) = pn0(i,k) - enddo -! Use log-p for interpolation/extrapolation -! mirror image method: - do k=km+2, km+k2 - l = 2*(km+1) - k - gz(k) = 2.*gz(km+1) - gz(l) - pn(k) = 2.*pn(km+1) - pn(l) - enddo - do k=km+k2-1, 2, -1 - if( Atm%phis(i,j).le.gz(k) .and. Atm%phis(i,j).ge.gz(k+1) ) then - pst = pn(k) + (pn(k+1)-pn(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) - go to 123 - endif - enddo -123 Atm%ps(i,j) = exp(pst) - enddo ! i-loop - - do i=is,ie - pe1(i,1) = Atm%ak(1) - pn1(i,1) = log(pe1(i,1)) - enddo - do k=2,npz+1 - do i=is,ie - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) - pn1(i,k) = log(pe1(i,k)) - enddo - enddo - -! * Compute delp - do k=1,npz - do i=is,ie - Atm%delp(i,j,k) = pe1(i,k+1) - pe1(i,k) - enddo - enddo - -!--------------- -! map shpum, o3mr, clwmr tracers -!---------------- - do iq=1,ncnst - call mappm(km, pe0, qp(is,1,iq), npz, pe1, qn1, is,ie, 0, 11, Atm%ptop) - do k=1,npz - do i=is,ie - Atm%q(i,j,k,iq) = qn1(i,k) - enddo - enddo - enddo - -!------------------------------------------------------------- -! map virtual temperature using geopotential conserving scheme. -!------------------------------------------------------------- - call mappm(km, pn0, tp, npz, pn1, qn1, is,ie, 1, 9, Atm%ptop) - do k=1,npz - do i=is,ie -#ifdef MULTI_GASES - Atm%pt(i,j,k) = qn1(i,k)/virq(Atm%q(i,j,k,:)) -#else - Atm%pt(i,j,k) = qn1(i,k)/(1.+zvir*Atm%q(i,j,k,sphum)) -#endif - enddo - enddo - - if ( .not. Atm%flagstruct%hydrostatic .and. Atm%flagstruct%ncep_ic ) then -! Replace delz with NCEP hydrostatic state - rdg = -rdgas / grav - do k=1,npz - do i=is,ie - atm%delz(i,j,k) = rdg*qn1(i,k)*(pn1(i,k+1)-pn1(i,k)) - enddo - enddo - endif - -5000 continue - - call prt_maxmin('PS_model', Atm%ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01) - - if (is_master()) write(*,*) 'done remap_scalar' - - end subroutine remap_scalar - - - subroutine remap_scalar_nggps(Atm, km, npz, ncnst, ak0, bk0, psc, t_in, qa, omga, zh) - type(fv_atmos_type), intent(inout) :: Atm - integer, intent(in):: km, npz, ncnst - real, intent(in):: ak0(km+1), bk0(km+1) - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: psc - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: t_in - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: omga - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km,ncnst):: qa - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km+1):: zh -! local: - real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0 - real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1, dp2 - real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1 - real qp(Atm%bd%is:Atm%bd%ie,km) - real wk(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) - real, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: z500 -!!! High-precision - real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pn1 - real(kind=R_GRID):: gz_fv(npz+1) - real(kind=R_GRID), dimension(2*km+1):: gz, pn - real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,km+1):: pn0 - real(kind=R_GRID):: pst -!!! High-precision - integer i,j,k,l,m, k2,iq - integer sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt, liq_aero, ice_aero -#ifdef MULTI_GASES - integer spfo, spfo2, spfo3 -#else - integer o3mr -#endif - integer :: is, ie, js, je - - is = Atm%bd%is - ie = Atm%bd%ie - js = Atm%bd%js - je = Atm%bd%je - - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') - cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') -#ifdef MULTI_GASES - spfo = get_tracer_index(MODEL_ATMOS, 'spfo') - spfo2 = get_tracer_index(MODEL_ATMOS, 'spfo2') - spfo3 = get_tracer_index(MODEL_ATMOS, 'spfo3') -#else - o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') -#endif - liq_aero = get_tracer_index(MODEL_ATMOS, 'liq_aero') - ice_aero = get_tracer_index(MODEL_ATMOS, 'ice_aero') - - k2 = max(10, km/2) - - if (mpp_pe()==1) then - print *, 'sphum = ', sphum - print *, 'clwmr = ', liq_wat -#ifdef MULTI_GASES - print *, 'spfo3 = ', spfo3 - print *, ' spfo = ', spfo - print *, 'spfo2 = ', spfo2 -#else - print *, ' o3mr = ', o3mr -#endif - print *, 'liq_aero = ', liq_aero - print *, 'ice_aero = ', ice_aero - print *, 'ncnst = ', ncnst - endif - - if ( sphum/=1 ) then - call mpp_error(FATAL,'SPHUM must be 1st tracer') - endif - -#ifdef USE_GFS_ZS - Atm%phis(is:ie,js:je) = zh(is:ie,js:je,km+1)*grav -#endif - -!$OMP parallel do default(none) & -!$OMP shared(sphum,liq_wat,rainwat,ice_wat,snowwat,graupel,liq_aero,ice_aero,source, & -!$OMP cld_amt,ncnst,npz,is,ie,js,je,km,k2,ak0,bk0,psc,t_in,zh,omga,qa,Atm,z500) & -!$OMP private(l,m,pst,pn,gz,pe0,pn0,pe1,pn1,dp2,qp,qn1,gz_fv) - do 5000 j=js,je - do k=1,km+1 - do i=is,ie - pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) - pn0(i,k) = log(pe0(i,k)) - enddo - enddo - - do i=is,ie - do k=1,km+1 - pn(k) = pn0(i,k) - gz(k) = zh(i,j,k)*grav - enddo -! Use log-p for interpolation/extrapolation -! mirror image method: - do k=km+2, km+k2 - l = 2*(km+1) - k - gz(k) = 2.*gz(km+1) - gz(l) - pn(k) = 2.*pn(km+1) - pn(l) - enddo - - do k=km+k2-1, 2, -1 - if( Atm%phis(i,j).le.gz(k) .and. Atm%phis(i,j).ge.gz(k+1) ) then - pst = pn(k) + (pn(k+1)-pn(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) - go to 123 - endif - enddo -123 Atm%ps(i,j) = exp(pst) - -! ------------------ -! Find 500-mb height -! ------------------ - pst = log(500.e2) - do k=km+k2-1, 2, -1 - if( pst.le.pn(k+1) .and. pst.ge.pn(k) ) then - z500(i,j) = (gz(k+1) + (gz(k)-gz(k+1))*(pn(k+1)-pst)/(pn(k+1)-pn(k)))/grav - go to 124 - endif - enddo -124 continue - - enddo ! i-loop - - do i=is,ie - pe1(i,1) = Atm%ak(1) - pn1(i,1) = log(pe1(i,1)) - enddo - do k=2,npz+1 - do i=is,ie - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) - pn1(i,k) = log(pe1(i,k)) - enddo - enddo - -! * Compute delp - do k=1,npz - do i=is,ie - dp2(i,k) = pe1(i,k+1) - pe1(i,k) - Atm%delp(i,j,k) = dp2(i,k) - enddo - enddo - -! map tracers - do iq=1,ncnst - do k=1,km - do i=is,ie - qp(i,k) = qa(i,j,k,iq) - enddo - enddo - call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop) - if ( iq==sphum ) then - call fillq(ie-is+1, npz, 1, qn1, dp2) - else - call fillz(ie-is+1, npz, 1, qn1, dp2) - endif -! The HiRam step of blending model sphum with NCEP data is obsolete because nggps is always cold starting... - do k=1,npz - do i=is,ie - Atm%q(i,j,k,iq) = qn1(i,k) - enddo - enddo - enddo - -!--------------------------------------------------- -! Retrive temperature using GFS geopotential height -!--------------------------------------------------- - do i=is,ie -! Make sure FV3 top is lower than GFS; can not do extrapolation above the top at this point - if ( pn1(i,1) .lt. pn0(i,1) ) then - call mpp_error(FATAL,'FV3 top higher than NCEP/GFS') - endif - - do k=1,km+1 - pn(k) = pn0(i,k) - gz(k) = zh(i,j,k)*grav - enddo -!------------------------------------------------- - do k=km+2, km+k2 - l = 2*(km+1) - k - gz(k) = 2.*gz(km+1) - gz(l) - pn(k) = 2.*pn(km+1) - pn(l) - enddo -!------------------------------------------------- - - gz_fv(npz+1) = Atm%phis(i,j) - - m = 1 - - do k=1,npz -! Searching using FV3 log(pe): pn1 -#ifdef USE_ISOTHERMO - do l=m,km - if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then - gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) - goto 555 - elseif ( pn1(i,k) .gt. pn(km+1) ) then -! Isothermal under ground; linear in log-p extra-polation - gz_fv(k) = gz(km+1) + (gz_fv(npz+1)-gz(km+1))*(pn1(i,k)-pn(km+1))/(pn1(i,npz+1)-pn(km+1)) - goto 555 - endif - enddo -#else - do l=m,km+k2-1 - if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then - gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) - goto 555 - endif - enddo -#endif -555 m = l - enddo - - do k=1,npz+1 - Atm%peln(i,k,j) = pn1(i,k) - enddo - -!---------------------------------------------------- -! Compute true temperature using hydrostatic balance -!---------------------------------------------------- - if (trim(source) /= 'FV3GFS GAUSSIAN NEMSIO FILE') then - do k=1,npz -#ifdef MULTI_GASES - Atm%pt(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*virq(Atm%q(i,j,k,:)) ) -#else - Atm%pt(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*(1.+zvir*Atm%q(i,j,k,sphum)) ) -#endif - enddo -!------------------------------ -! Remap input T linearly in p. -!------------------------------ - else - do k=1,km - qp(i,k) = t_in(i,j,k) - enddo - - call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 2, 4, Atm%ptop) - - do k=1,npz - Atm%pt(i,j,k) = qn1(i,k) - enddo - endif - - if ( .not. Atm%flagstruct%hydrostatic ) then - do k=1,npz - Atm%delz(i,j,k) = (gz_fv(k+1) - gz_fv(k)) / grav - enddo - endif - - enddo ! i-loop - -!----------------------------------------------------------------------- -! seperate cloud water and cloud ice -! From Jan-Huey Chen's HiRAM code -!----------------------------------------------------------------------- - if (cld_amt .gt. 0) Atm%q(:,:,:,cld_amt) = 0. - if (trim(source) /= 'FV3GFS GAUSSIAN NEMSIO FILE') then - if ( Atm%flagstruct%nwat .eq. 6 ) then - do k=1,npz - do i=is,ie - qn1(i,k) = Atm%q(i,j,k,liq_wat) - Atm%q(i,j,k,rainwat) = 0. - Atm%q(i,j,k,snowwat) = 0. - Atm%q(i,j,k,graupel) = 0. -! if (cld_amt .gt. 0) Atm%q(i,j,k,cld_amt) = 0. - if ( Atm%pt(i,j,k) > 273.16 ) then ! > 0C all liq_wat - Atm%q(i,j,k,liq_wat) = qn1(i,k) - Atm%q(i,j,k,ice_wat) = 0. -#ifdef ORIG_CLOUDS_PART - else if ( Atm%pt(i,j,k) < 258.16 ) then ! < -15C all ice_wat - Atm%q(i,j,k,liq_wat) = 0. - Atm%q(i,j,k,ice_wat) = qn1(i,k) - else ! between -15~0C: linear interpolation - Atm%q(i,j,k,liq_wat) = qn1(i,k)*((Atm%pt(i,j,k)-258.16)/15.) - Atm%q(i,j,k,ice_wat) = qn1(i,k) - Atm%q(i,j,k,liq_wat) - endif -#else - else if ( Atm%pt(i,j,k) < 233.16 ) then ! < -40C all ice_wat - Atm%q(i,j,k,liq_wat) = 0. - Atm%q(i,j,k,ice_wat) = qn1(i,k) - else - if ( k.eq.1 ) then ! between [-40,0]: linear interpolation - Atm%q(i,j,k,liq_wat) = qn1(i,k)*((Atm%pt(i,j,k)-233.16)/40.) - Atm%q(i,j,k,ice_wat) = qn1(i,k) - Atm%q(i,j,k,liq_wat) - else - if (Atm%pt(i,j,k)<258.16 .and. Atm%q(i,j,k-1,ice_wat)>1.e-5 ) then - Atm%q(i,j,k,liq_wat) = 0. - Atm%q(i,j,k,ice_wat) = qn1(i,k) - else ! between [-40,0]: linear interpolation - Atm%q(i,j,k,liq_wat) = qn1(i,k)*((Atm%pt(i,j,k)-233.16)/40.) - Atm%q(i,j,k,ice_wat) = qn1(i,k) - Atm%q(i,j,k,liq_wat) - endif - endif - endif -#endif - call mp_auto_conversion(Atm%q(i,j,k,liq_wat), Atm%q(i,j,k,rainwat), & - Atm%q(i,j,k,ice_wat), Atm%q(i,j,k,snowwat) ) - enddo - enddo - endif - endif ! data source /= FV3GFS GAUSSIAN NEMSIO FILE - -! For GFS spectral input, omega in pa/sec is stored as w in the input data so actual w(m/s) is calculated -! For GFS nemsio input, omega is 0, so best not to use for input since boundary data will not exist for w -! For FV3GFS NEMSIO input, w is already in m/s (but the code reads in as omga) and just needs to be remapped -!------------------------------------------------------------- -! map omega -!------- ------------------------------------------------------ - if ( .not. Atm%flagstruct%hydrostatic ) then - do k=1,km - do i=is,ie - qp(i,k) = omga(i,j,k) - enddo - enddo - call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4, Atm%ptop) - if (trim(source) == 'FV3GFS GAUSSIAN NEMSIO FILE') then - do k=1,npz - do i=is,ie - atm%w(i,j,k) = qn1(i,k) - enddo - enddo - - else - do k=1,npz - do i=is,ie - atm%w(i,j,k) = qn1(i,k)/atm%delp(i,j,k)*atm%delz(i,j,k) - enddo - enddo - endif - endif !.not. Atm%flagstruct%hydrostatic -5000 continue - -! Add some diagnostics: - call p_maxmin('PS_model (mb)', Atm%ps(is:ie,js:je), is, ie, js, je, 1, 0.01) - call p_maxmin('PT_model', Atm%pt(is:ie,js:je,1:npz), is, ie, js, je, npz, 1.) - do j=js,je - do i=is,ie - wk(i,j) = Atm%phis(i,j)/grav - zh(i,j,km+1) - enddo - enddo - call pmaxmn('ZS_diff (m)', wk, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) - - if (.not.Atm%neststruct%nested) then - call prt_gb_nh_sh('GFS_IC Z500', is,ie, js,je, z500, Atm%gridstruct%area_64(is:ie,js:je), Atm%gridstruct%agrid_64(is:ie,js:je,2)) - if ( .not. Atm%flagstruct%hydrostatic ) & - call prt_height('fv3_IC Z500', is,ie, js,je, 3, npz, 500.E2, Atm%phis, Atm%delz, Atm%peln, & - Atm%gridstruct%area_64(is:ie,js:je), Atm%gridstruct%agrid_64(is:ie,js:je,2)) - endif - - do j=js,je - do i=is,ie - wk(i,j) = Atm%ps(i,j) - psc(i,j) - enddo - enddo - call pmaxmn('PS_diff (mb)', wk, is, ie, js, je, 1, 0.01, Atm%gridstruct%area_64, Atm%domain) - - if (is_master()) write(*,*) 'done remap_scalar_nggps' - - end subroutine remap_scalar_nggps - - subroutine remap_scalar_ec(Atm, km, npz, ncnst, ak0, bk0, psc, qa, wc, zh) - type(fv_atmos_type), intent(inout) :: Atm - integer, intent(in):: km, npz, ncnst - real, intent(in):: ak0(km+1), bk0(km+1) - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: psc - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: wc - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km,ncnst):: qa - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km+1):: zh -! local: - real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0 - real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1, dp2 - real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1 - real qp(Atm%bd%is:Atm%bd%ie,km) - real wk(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) -!!! High-precision - real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pn1 - real(kind=R_GRID):: gz_fv(npz+1) - real(kind=R_GRID), dimension(2*km+1):: gz, pn - real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,km+1):: pn0 - real(kind=R_GRID):: pst - real, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: z500 -!!! High-precision - integer:: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt -#ifdef MULTI_GASES - integer:: spfo, spfo2, spfo3 -#else - integer:: o3mr -#endif - integer:: i,j,k,l,m,k2, iq - integer:: is, ie, js, je - - is = Atm%bd%is - ie = Atm%bd%ie - js = Atm%bd%js - je = Atm%bd%je - - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - - if ( Atm%flagstruct%nwat .eq. 6 ) then - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') - cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') - endif - if (cld_amt .gt. 0) Atm%q(:,:,:,cld_amt) = 0. - - k2 = max(10, km/2) - - if (mpp_pe()==1) then - print *, 'In remap_scalar_ec:' - print *, 'ncnst = ', ncnst - print *, 'sphum = ', sphum - print *, 'liq_wat = ', liq_wat - if ( Atm%flagstruct%nwat .eq. 6 ) then - print *, 'rainwat = ', rainwat - print *, 'ice_wat = ', ice_wat - print *, 'snowwat = ', snowwat - print *, 'graupel = ', graupel - endif - endif - -!$OMP parallel do default(none) shared(sphum,ncnst,npz,is,ie,js,je,km,k2,ak0,bk0,psc,zh,qa,wc,Atm,z500) & -!$OMP private(l,m,pst,pn,gz,pe0,pn0,pe1,pn1,dp2,qp,qn1,gz_fv) - do 5000 j=js,je - do k=1,km+1 - do i=is,ie - pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) - pn0(i,k) = log(pe0(i,k)) - enddo - enddo - - do i=is,ie - do k=1,km+1 - pn(k) = pn0(i,k) - gz(k) = zh(i,j,k)*grav - enddo -! Use log-p for interpolation/extrapolation -! mirror image method: - do k=km+2, km+k2 - l = 2*(km+1) - k - gz(k) = 2.*gz(km+1) - gz(l) - pn(k) = 2.*pn(km+1) - pn(l) - enddo - - do k=km+k2-1, 2, -1 - if( Atm%phis(i,j).le.gz(k) .and. Atm%phis(i,j).ge.gz(k+1) ) then - pst = pn(k) + (pn(k+1)-pn(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) - go to 123 - endif - enddo -123 Atm%ps(i,j) = exp(pst) - -! ------------------ -! Find 500-mb height -! ------------------ - pst = log(500.e2) - do k=km+k2-1, 2, -1 - if( pst.le.pn(k+1) .and. pst.ge.pn(k) ) then - z500(i,j) = (gz(k+1) + (gz(k)-gz(k+1))*(pn(k+1)-pst)/(pn(k+1)-pn(k)))/grav - go to 125 - endif - enddo -125 continue - - enddo ! i-loop - - do i=is,ie - pe1(i,1) = Atm%ak(1) - pn1(i,1) = log(pe1(i,1)) - enddo - do k=2,npz+1 - do i=is,ie - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) - pn1(i,k) = log(pe1(i,k)) - enddo - enddo - -! * Compute delp - do k=1,npz - do i=is,ie - dp2(i,k) = pe1(i,k+1) - pe1(i,k) - Atm%delp(i,j,k) = dp2(i,k) - enddo - enddo - -! map shpum, liq_wat, ice_wat, rainwat, snowwat tracers - do iq=1,ncnst - do k=1,km - do i=is,ie - qp(i,k) = qa(i,j,k,iq) - enddo - enddo - call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop) - if ( iq==1 ) then - call fillq(ie-is+1, npz, 1, qn1, dp2) - else - call fillz(ie-is+1, npz, 1, qn1, dp2) - endif -! The HiRam step of blending model sphum with NCEP data is obsolete because nggps is always cold starting... - do k=1,npz - do i=is,ie - Atm%q(i,j,k,iq) = qn1(i,k) - enddo - enddo - enddo -!--------------------------------------------------- -! Retrive temperature using EC geopotential height -!--------------------------------------------------- - do i=is,ie -! Make sure FV3 top is lower than GFS; can not do extrapolation above the top at this point - if ( pn1(i,1) .lt. pn0(i,1) ) then - call mpp_error(FATAL,'FV3 top higher than ECMWF') - endif - - do k=1,km+1 - pn(k) = pn0(i,k) - gz(k) = zh(i,j,k)*grav - enddo -!------------------------------------------------- - do k=km+2, km+k2 - l = 2*(km+1) - k - gz(k) = 2.*gz(km+1) - gz(l) - pn(k) = 2.*pn(km+1) - pn(l) - enddo -!------------------------------------------------- - gz_fv(npz+1) = Atm%phis(i,j) - - m = 1 - do k=1,npz -! Searching using FV3 log(pe): pn1 -#ifdef USE_ISOTHERMO - do l=m,km - if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then - gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) - goto 555 - elseif ( pn1(i,k) .gt. pn(km+1) ) then -! Isothermal under ground; linear in log-p extra-polation - gz_fv(k) = gz(km+1) + (gz_fv(npz+1)-gz(km+1))*(pn1(i,k)-pn(km+1))/(pn1(i,npz+1)-pn(km+1)) - goto 555 - endif - enddo -#else - do l=m,km+k2-1 - if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then - gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) - goto 555 - endif - enddo -#endif -555 m = l - enddo - - do k=1,npz+1 - Atm%peln(i,k,j) = pn1(i,k) - enddo - -! Compute true temperature using hydrostatic balance - do k=1,npz -! qc = 1.-(Atm%q(i,j,k,liq_wat)+Atm%q(i,j,k,rainwat)+Atm%q(i,j,k,ice_wat)+Atm%q(i,j,k,snowwat)) -! Atm%pt(i,j,k) = (gz_fv(k)-gz_fv(k+1))*qc/( rdgas*(pn1(i,k+1)-pn1(i,k))*(1.+zvir*Atm%q(i,j,k,sphum)) ) -#ifdef MULTI_GASES - Atm%pt(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*virq(Atm%q(i,j,k,:)) ) -#else - Atm%pt(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*(1.+zvir*Atm%q(i,j,k,sphum)) ) -#endif - enddo - if ( .not. Atm%flagstruct%hydrostatic ) then - do k=1,npz - Atm%delz(i,j,k) = (gz_fv(k+1) - gz_fv(k)) / grav - enddo - endif - - enddo ! i-loop - -!------------------------------------------------------------- -! map omega -!------- ------------------------------------------------------ - if ( .not. Atm%flagstruct%hydrostatic ) then - do k=1,km - do i=is,ie - qp(i,k) = wc(i,j,k) - enddo - enddo - call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4, Atm%ptop) - do k=1,npz - do i=is,ie - atm%w(i,j,k) = qn1(i,k)/atm%delp(i,j,k)*atm%delz(i,j,k) - enddo - enddo - endif - -5000 continue - -! Add some diagnostics: - call p_maxmin('PS_model (mb)', Atm%ps(is:ie,js:je), is, ie, js, je, 1, 0.01) - call p_maxmin('PT_model', Atm%pt(is:ie,js:je,1:npz), is, ie, js, je, npz, 1.) - call pmaxmn('ZS_model', Atm%phis(is:ie,js:je)/grav, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) - call pmaxmn('ZS_EC', zh(is:ie,js:je,km+1), is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) - do j=js,je - do i=is,ie - wk(i,j) = Atm%phis(i,j)/grav - zh(i,j,km+1) - ! if ((wk(i,j) > 1800.).or.(wk(i,j)<-1600.)) then - ! print *,' ' - ! print *, 'Diff = ', wk(i,j), 'Atm%phis =', Atm%phis(i,j)/grav, 'zh = ', zh(i,j,km+1) - ! print *, 'lat = ', Atm%gridstruct%agrid(i,j,2)/deg2rad, 'lon = ', Atm%gridstruct%agrid(i,j,1)/deg2rad - ! endif - enddo - enddo - call pmaxmn('ZS_diff (m)', wk, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) - - if (.not.Atm%neststruct%nested) then - call prt_gb_nh_sh('IFS_IC Z500', is,ie, js,je, z500, Atm%gridstruct%area_64(is:ie,js:je), Atm%gridstruct%agrid_64(is:ie,js:je,2)) - if ( .not. Atm%flagstruct%hydrostatic ) & - call prt_height('fv3_IC Z500', is,ie, js,je, 3, npz, 500.E2, Atm%phis, Atm%delz, Atm%peln, & - Atm%gridstruct%area_64(is:ie,js:je), Atm%gridstruct%agrid_64(is:ie,js:je,2)) - endif - - do j=js,je - do i=is,ie - wk(i,j) = Atm%ps(i,j) - psc(i,j) - enddo - enddo - call pmaxmn('PS_diff (mb)', wk, is, ie, js, je, 1, 0.01, Atm%gridstruct%area_64, Atm%domain) - - end subroutine remap_scalar_ec - - subroutine remap_scalar_single(Atm, km, npz, ak0, bk0, psc, qa, zh ,iq) - type(fv_atmos_type), intent(inout) :: Atm - integer, intent(in):: km, npz, iq - real, intent(in):: ak0(km+1), bk0(km+1) - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: psc - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: qa - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km+1):: zh -! local: - real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0 - real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1, dp2 - real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1 - real qp(Atm%bd%is:Atm%bd%ie,km) - real wk(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) -!!! High-precision - real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pn1 - real(kind=R_GRID):: gz_fv(npz+1) - real(kind=R_GRID), dimension(2*km+1):: gz, pn - real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,km+1):: pn0 - real(kind=R_GRID):: pst -!!! High-precision - integer i,j,k, k2, l - integer :: is, ie, js, je - real, allocatable:: ps_temp(:,:) - - is = Atm%bd%is - ie = Atm%bd%ie - js = Atm%bd%js - je = Atm%bd%je - - k2 = max(10, km/2) - - allocate(ps_temp(is:ie,js:je)) - - do 5000 j=js,je - do k=1,km+1 - do i=is,ie - pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) - pn0(i,k) = log(pe0(i,k)) - enddo - enddo - - do i=is,ie - do k=1,km+1 - pn(k) = pn0(i,k) - gz(k) = zh(i,j,k)*grav - enddo -! Use log-p for interpolation/extrapolation -! mirror image method: - do k=km+2, km+k2 - l = 2*(km+1) - k - gz(k) = 2.*gz(km+1) - gz(l) - pn(k) = 2.*pn(km+1) - pn(l) - enddo - - do k=km+k2-1, 2, -1 - if( Atm%phis(i,j).le.gz(k) .and. Atm%phis(i,j).ge.gz(k+1) ) then - pst = pn(k) + (pn(k+1)-pn(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) - go to 123 - endif - enddo -123 ps_temp(i,j) = exp(pst) - enddo ! i-loop - - do i=is,ie - pe1(i,1) = Atm%ak(1) - pn1(i,1) = log(pe1(i,1)) - enddo - do k=2,npz+1 - do i=is,ie - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*ps_temp(i,j) - pn1(i,k) = log(pe1(i,k)) - enddo - enddo - -! * Compute delp - do k=1,npz - do i=is,ie - dp2(i,k) = pe1(i,k+1) - pe1(i,k) - enddo - enddo - - ! map o3mr - do k=1,km - do i=is,ie - qp(i,k) = qa(i,j,k) - enddo - enddo - call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop) - if ( iq==1 ) then - call fillq(ie-is+1, npz, 1, qn1, dp2) - else - call fillz(ie-is+1, npz, 1, qn1, dp2) - endif -! The HiRam step of blending model sphum with NCEP data is obsolete because nggps is always cold starting... - do k=1,npz - do i=is,ie - Atm%q(i,j,k,iq) = qn1(i,k) - enddo - enddo - -5000 continue - call p_maxmin('o3mr remap', Atm%q(is:ie,js:je,1:npz,iq), is, ie, js, je, npz, 1.) - - deallocate(ps_temp) - - end subroutine remap_scalar_single - - - subroutine mp_auto_conversion(ql, qr, qi, qs) - real, intent(inout):: ql, qr, qi, qs - real, parameter:: qi0_max = 2.0e-3 - real, parameter:: ql0_max = 2.5e-3 - -! Convert excess cloud water into rain: - if ( ql > ql0_max ) then - qr = ql - ql0_max - ql = ql0_max - endif -! Convert excess cloud ice into snow: - if ( qi > qi0_max ) then - qs = qi - qi0_max - qi = qi0_max - endif - - end subroutine mp_auto_conversion - - - subroutine remap_dwinds(km, npz, ak0, bk0, psc, ud, vd, Atm) - type(fv_atmos_type), intent(inout) :: Atm - integer, intent(in):: km, npz - real, intent(in):: ak0(km+1), bk0(km+1) - real, intent(in):: psc(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) - real, intent(in):: ud(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1,km) - real, intent(in):: vd(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je,km) -! local: - real, dimension(Atm%bd%isd:Atm%bd%ied,Atm%bd%jsd:Atm%bd%jed):: psd - real, dimension(Atm%bd%is:Atm%bd%ie+1, km+1):: pe0 - real, dimension(Atm%bd%is:Atm%bd%ie+1,npz+1):: pe1 - real, dimension(Atm%bd%is:Atm%bd%ie+1,npz):: qn1 - integer i,j,k - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = Atm%bd%is - ie = Atm%bd%ie - js = Atm%bd%js - je = Atm%bd%je - isd = Atm%bd%isd - ied = Atm%bd%ied - jsd = Atm%bd%jsd - jed = Atm%bd%jed - - if (Atm%neststruct%nested .or. Atm%flagstruct%regional) then - do j=jsd,jed - do i=isd,ied - psd(i,j) = Atm%ps(i,j) - enddo - enddo - else - do j=js,je - do i=is,ie - psd(i,j) = psc(i,j) - enddo - enddo - endif - call mpp_update_domains( psd, Atm%domain, complete=.false. ) - call mpp_update_domains( Atm%ps, Atm%domain, complete=.true. ) - -!$OMP parallel do default(none) shared(is,ie,js,je,npz,km,ak0,bk0,Atm,psc,psd,ud,vd) & -!$OMP private(pe1,pe0,qn1) - do 5000 j=js,je+1 -!------ -! map u -!------ - do k=1,km+1 - do i=is,ie - pe0(i,k) = ak0(k) + bk0(k)*0.5*(psd(i,j-1)+psd(i,j)) - enddo - enddo - do k=1,npz+1 - do i=is,ie - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*0.5*(Atm%ps(i,j-1)+Atm%ps(i,j)) - enddo - enddo - call mappm(km, pe0(is:ie,1:km+1), ud(is:ie,j,1:km), npz, pe1(is:ie,1:npz+1), & - qn1(is:ie,1:npz), is,ie, -1, 8, Atm%ptop) - do k=1,npz - do i=is,ie - Atm%u(i,j,k) = qn1(i,k) - enddo - enddo -!------ -! map v -!------ - if ( j/=(je+1) ) then - - do k=1,km+1 - do i=is,ie+1 - pe0(i,k) = ak0(k) + bk0(k)*0.5*(psd(i-1,j)+psd(i,j)) - enddo - enddo - do k=1,npz+1 - do i=is,ie+1 - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*0.5*(Atm%ps(i-1,j)+Atm%ps(i,j)) - enddo - enddo - call mappm(km, pe0(is:ie+1,1:km+1), vd(is:ie+1,j,1:km), npz, pe1(is:ie+1,1:npz+1), & - qn1(is:ie+1,1:npz), is,ie+1, -1, 8, Atm%ptop) - do k=1,npz - do i=is,ie+1 - Atm%v(i,j,k) = qn1(i,k) - enddo - enddo - - endif - -5000 continue - - if (is_master()) write(*,*) 'done remap_dwinds' - - end subroutine remap_dwinds - - - subroutine remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm) - type(fv_atmos_type), intent(inout) :: Atm - integer, intent(in):: im, jm, km, npz - real, intent(in):: ak0(km+1), bk0(km+1) - real, intent(in):: psc(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) - real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: ua, va -! local: - real, dimension(Atm%bd%isd:Atm%bd%ied,Atm%bd%jsd:Atm%bd%jed,npz):: ut, vt ! winds - real, dimension(Atm%bd%is:Atm%bd%ie, km+1):: pe0 - real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1 - real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1 - integer i,j,k - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = Atm%bd%is - ie = Atm%bd%ie - js = Atm%bd%js - je = Atm%bd%je - isd = Atm%bd%isd - ied = Atm%bd%ied - jsd = Atm%bd%jsd - jed = Atm%bd%jed - - do 5000 j=js,je - - do k=1,km+1 - do i=is,ie - pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) - enddo - enddo - - do k=1,npz+1 - do i=is,ie - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) - enddo - enddo - -!------ -! map u -!------ - call mappm(km, pe0, ua(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8, Atm%ptop) - do k=1,npz - do i=is,ie - ut(i,j,k) = qn1(i,k) - enddo - enddo -!------ -! map v -!------ - call mappm(km, pe0, va(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8, Atm%ptop) - do k=1,npz - do i=is,ie - vt(i,j,k) = qn1(i,k) - enddo - enddo - -5000 continue - - call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1.) - call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1.) - call prt_maxmin('UA_top',ut(:,:,1), is, ie, js, je, ng, 1, 1.) - -!---------------------------------------------- -! winds: lat-lon ON A to Cubed-D transformation: -!---------------------------------------------- - call cubed_a2d(Atm%npx, Atm%npy, npz, ut, vt, Atm%u, Atm%v, Atm%gridstruct, Atm%domain, Atm%bd ) - - if (is_master()) write(*,*) 'done remap_winds' - - end subroutine remap_winds - - - subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0, ps0, gz0, & - ua, va, ta, qa, Atm ) - - type(fv_atmos_type), intent(inout), target :: Atm - integer, intent(in):: im, jm, km, npz, nq, ncnst - integer, intent(in):: jbeg, jend - real, intent(in):: lon(im), lat(jm), ak0(km+1), bk0(km+1) - real, intent(in):: gz0(im,jbeg:jend), ps0(im,jbeg:jend) - real, intent(in), dimension(im,jbeg:jend,km):: ua, va, ta - real, intent(in), dimension(im,jbeg:jend,km,ncnst):: qa - - real, pointer, dimension(:,:,:) :: agrid - -! local: - real, dimension(Atm%bd%isd:Atm%bd%ied,Atm%bd%jsd:Atm%bd%jed,npz):: ut, vt ! winds - real, dimension(Atm%bd%is:Atm%bd%ie,km):: up, vp, tp - real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0, pn0 - real pt0(km), gz(km+1), pk0(km+1) - real qp(Atm%bd%is:Atm%bd%ie,km,ncnst) - real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1 - real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1, pn1 - real :: rdlon(im) - real :: rdlat(jm) - real:: a1, b1, c1, c2, c3, c4 - real:: gzc, psc, pst -#ifdef MULTI_GASES - real:: kappax, pkx -#endif - integer i,j,k, i1, i2, jc, i0, j0, iq -! integer sphum, liq_wat, ice_wat, cld_amt - integer sphum - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = Atm%bd%is - ie = Atm%bd%ie - js = Atm%bd%js - je = Atm%bd%je - isd = Atm%bd%isd - ied = Atm%bd%ied - jsd = Atm%bd%jsd - jed = Atm%bd%jed - - !!NOTE: Only Atm is used in this routine. - agrid => Atm%gridstruct%agrid - - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - - if ( sphum/=1 ) then - call mpp_error(FATAL,'SPHUM must be 1st tracer') - endif - - pk0(1) = ak0(1)**kappa - - do i=1,im-1 - rdlon(i) = 1. / (lon(i+1) - lon(i)) - enddo - rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) - - do j=1,jm-1 - rdlat(j) = 1. / (lat(j+1) - lat(j)) - enddo - -! * Interpolate to cubed sphere cell center - do 5000 j=js,je - - do i=is,ie - pe0(i,1) = ak0(1) - pn0(i,1) = log(ak0(1)) - enddo - - - do i=is,ie - - if ( agrid(i,j,1)>lon(im) ) then - i1 = im; i2 = 1 - a1 = (agrid(i,j,1)-lon(im)) * rdlon(im) - elseif ( agrid(i,j,1)=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then - i1 = i0; i2 = i0+1 - a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0) - go to 111 - endif - enddo - endif - -111 continue - - if ( agrid(i,j,2)lat(jm) ) then - jc = jm-1 - b1 = 1. - else - do j0=1,jm-1 - if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then - jc = j0 - b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc) - go to 222 - endif - enddo - endif -222 continue - -#ifndef DEBUG_REMAP - if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then - write(*,*) i,j,a1, b1 - endif -#endif - c1 = (1.-a1) * (1.-b1) - c2 = a1 * (1.-b1) - c3 = a1 * b1 - c4 = (1.-a1) * b1 - -! Interpolated surface pressure - psc = c1*ps0(i1,jc ) + c2*ps0(i2,jc ) + & - c3*ps0(i2,jc+1) + c4*ps0(i1,jc+1) - -! Interpolated surface geopotential - gzc = c1*gz0(i1,jc ) + c2*gz0(i2,jc ) + & - c3*gz0(i2,jc+1) + c4*gz0(i1,jc+1) - -! 3D fields: - do iq=1,ncnst -! if ( iq==sphum .or. iq==liq_wat .or. iq==ice_wat .or. iq==cld_amt ) then - do k=1,km - qp(i,k,iq) = c1*qa(i1,jc, k,iq) + c2*qa(i2,jc, k,iq) + & - c3*qa(i2,jc+1,k,iq) + c4*qa(i1,jc+1,k,iq) - enddo -! endif - enddo - - do k=1,km - up(i,k) = c1*ua(i1,jc, k) + c2*ua(i2,jc, k) + & - c3*ua(i2,jc+1,k) + c4*ua(i1,jc+1,k) - vp(i,k) = c1*va(i1,jc, k) + c2*va(i2,jc, k) + & - c3*va(i2,jc+1,k) + c4*va(i1,jc+1,k) - tp(i,k) = c1*ta(i1,jc, k) + c2*ta(i2,jc, k) + & - c3*ta(i2,jc+1,k) + c4*ta(i1,jc+1,k) -! Virtual effect: -#ifdef MULTI_GASES - tp(i,k) = tp(i,k)*virq(qp(i,k,:)) -#else - tp(i,k) = tp(i,k)*(1.+zvir*qp(i,k,sphum)) -#endif - enddo -! Tracers: - - do k=2,km+1 - pe0(i,k) = ak0(k) + bk0(k)*psc - pn0(i,k) = log(pe0(i,k)) - pk0(k) = pe0(i,k)**kappa - enddo - -#ifdef USE_DATA_ZS - Atm% ps(i,j) = psc - Atm%phis(i,j) = gzc -#else - -! * Adjust interpolated ps to model terrain - gz(km+1) = gzc - do k=km,1,-1 - gz(k) = gz(k+1) + rdgas*tp(i,k)*(pn0(i,k+1)-pn0(i,k)) - enddo -! Only lowest layer potential temp is needed -#ifdef MULTI_GASES - kappax = virqd(qp(i,km,:))/vicpqd(qp(i,km,:)) - pkx = (pk0(km+1)-pk0(km))*(kappa*(pn0(i,km+1)-pn0(i,km))) - pkx = exp( kappax*log(pkx) ) - pt0(km) = tp(i,km)/pkx -#else - pt0(km) = tp(i,km)/(pk0(km+1)-pk0(km))*(kappa*(pn0(i,km+1)-pn0(i,km))) -#endif - if( Atm%phis(i,j)>gzc ) then - do k=km,1,-1 - if( Atm%phis(i,j) < gz(k) .and. & - Atm%phis(i,j) >= gz(k+1) ) then - pst = pk0(k) + (pk0(k+1)-pk0(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) - go to 123 - endif - enddo - else -! Extrapolation into the ground -#ifdef MULTI_GASES - pst = pk0(km+1) + (gzc-Atm%phis(i,j))/(cp_air*pt0(km)*pkx) -#else - pst = pk0(km+1) + (gzc-Atm%phis(i,j))/(cp_air*pt0(km)) -#endif - endif - -#ifdef MULTI_GASES -123 Atm%ps(i,j) = pst**(1./(kappa*kappax)) -#else -123 Atm%ps(i,j) = pst**(1./kappa) -#endif -#endif - enddo !i-loop - - -! * Compute delp from ps - do i=is,ie - pe1(i,1) = Atm%ak(1) - pn1(i,1) = log(pe1(i,1)) - enddo - do k=2,npz+1 - do i=is,ie - pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) - pn1(i,k) = log(pe1(i,k)) - enddo - enddo - - do k=1,npz - do i=is,ie - Atm%delp(i,j,k) = pe1(i,k+1) - pe1(i,k) - enddo - enddo - -! Use kord=9 for winds; kord=11 for tracers -!------ -! map u -!------ - call mappm(km, pe0, up, npz, pe1, qn1, is,ie, -1, 9, Atm%ptop) - do k=1,npz - do i=is,ie - ut(i,j,k) = qn1(i,k) - enddo - enddo -!------ -! map v -!------ - call mappm(km, pe0, vp, npz, pe1, qn1, is,ie, -1, 9, Atm%ptop) - do k=1,npz - do i=is,ie - vt(i,j,k) = qn1(i,k) - enddo - enddo - -!--------------- -! map tracers -!---------------- - do iq=1,ncnst -! Note: AM2 physics tracers only -! if ( iq==sphum .or. iq==liq_wat .or. iq==ice_wat .or. iq==cld_amt ) then - call mappm(km, pe0, qp(is,1,iq), npz, pe1, qn1, is,ie, 0, 11, Atm%ptop) - do k=1,npz - do i=is,ie - Atm%q(i,j,k,iq) = qn1(i,k) - enddo - enddo -! endif - enddo - -!------------------------------------------------------------- -! map virtual temperature using geopotential conserving scheme. -!------------------------------------------------------------- - call mappm(km, pn0, tp, npz, pn1, qn1, is,ie, 1, 9, Atm%ptop) - do k=1,npz - do i=is,ie -#ifdef MULTI_GASES - Atm%pt(i,j,k) = qn1(i,k)/virq(Atm%q(i,j,k,:)) -#else - Atm%pt(i,j,k) = qn1(i,k)/(1.+zvir*Atm%q(i,j,k,sphum)) -#endif - enddo - enddo - -5000 continue - - call prt_maxmin('PS_model', Atm%ps, is, ie, js, je, ng, 1, 0.01) - call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1.) - call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1.) - -!---------------------------------------------- -! winds: lat-lon ON A to Cubed-D transformation: -!---------------------------------------------- - call cubed_a2d(Atm%npx, Atm%npy, npz, ut, vt, Atm%u, Atm%v, Atm%gridstruct, Atm%domain, Atm%bd ) - - if (is_master()) write(*,*) 'done remap_xyz' - - end subroutine remap_xyz - -!>@brief The subroutine 'cubed_a2d' transforms the wind from the A Grid to the D Grid. - subroutine cubed_a2d( npx, npy, npz, ua, va, u, v, gridstruct, fv_domain, bd ) - use mpp_domains_mod, only: mpp_update_domains - - type(fv_grid_bounds_type), intent(IN) :: bd - integer, intent(in):: npx, npy, npz - real, intent(inout), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: ua, va - real, intent(out):: u(bd%isd:bd%ied, bd%jsd:bd%jed+1,npz) - real, intent(out):: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: fv_domain -! local: - real v3(3,bd%is-1:bd%ie+1,bd%js-1:bd%je+1) - real ue(3,bd%is-1:bd%ie+1,bd%js:bd%je+1) !< 3D winds at edges - real ve(3,bd%is:bd%ie+1,bd%js-1:bd%je+1) !< 3D winds at edges - real, dimension(bd%is:bd%ie):: ut1, ut2, ut3 - real, dimension(bd%js:bd%je):: vt1, vt2, vt3 - integer i, j, k, im2, jm2 - - real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat - real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n - real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - vlon => gridstruct%vlon - vlat => gridstruct%vlat - - edge_vect_w => gridstruct%edge_vect_w - edge_vect_e => gridstruct%edge_vect_e - edge_vect_s => gridstruct%edge_vect_s - edge_vect_n => gridstruct%edge_vect_n - - ew => gridstruct%ew - es => gridstruct%es - - call mpp_update_domains(ua, fv_domain, complete=.false.) - call mpp_update_domains(va, fv_domain, complete=.true.) - - im2 = (npx-1)/2 - jm2 = (npy-1)/2 - - do k=1, npz -! Compute 3D wind on A grid - do j=js-1,je+1 - do i=is-1,ie+1 - v3(1,i,j) = ua(i,j,k)*vlon(i,j,1) + va(i,j,k)*vlat(i,j,1) - v3(2,i,j) = ua(i,j,k)*vlon(i,j,2) + va(i,j,k)*vlat(i,j,2) - v3(3,i,j) = ua(i,j,k)*vlon(i,j,3) + va(i,j,k)*vlat(i,j,3) - enddo - enddo - -! A --> D -! Interpolate to cell edges - do j=js,je+1 - do i=is-1,ie+1 - ue(1,i,j) = 0.5*(v3(1,i,j-1) + v3(1,i,j)) - ue(2,i,j) = 0.5*(v3(2,i,j-1) + v3(2,i,j)) - ue(3,i,j) = 0.5*(v3(3,i,j-1) + v3(3,i,j)) - enddo - enddo - - do j=js-1,je+1 - do i=is,ie+1 - ve(1,i,j) = 0.5*(v3(1,i-1,j) + v3(1,i,j)) - ve(2,i,j) = 0.5*(v3(2,i-1,j) + v3(2,i,j)) - ve(3,i,j) = 0.5*(v3(3,i-1,j) + v3(3,i,j)) - enddo - enddo - -! --- E_W edges (for v-wind): - if (.not. gridstruct%nested) then - if ( is==1) then - i = 1 - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_w(j)*ve(1,i,j-1)+(1.-edge_vect_w(j))*ve(1,i,j) - vt2(j) = edge_vect_w(j)*ve(2,i,j-1)+(1.-edge_vect_w(j))*ve(2,i,j) - vt3(j) = edge_vect_w(j)*ve(3,i,j-1)+(1.-edge_vect_w(j))*ve(3,i,j) - else - vt1(j) = edge_vect_w(j)*ve(1,i,j+1)+(1.-edge_vect_w(j))*ve(1,i,j) - vt2(j) = edge_vect_w(j)*ve(2,i,j+1)+(1.-edge_vect_w(j))*ve(2,i,j) - vt3(j) = edge_vect_w(j)*ve(3,i,j+1)+(1.-edge_vect_w(j))*ve(3,i,j) - endif - enddo - do j=js,je - ve(1,i,j) = vt1(j) - ve(2,i,j) = vt2(j) - ve(3,i,j) = vt3(j) - enddo - endif - - if ( (ie+1)==npx ) then - i = npx - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_e(j)*ve(1,i,j-1)+(1.-edge_vect_e(j))*ve(1,i,j) - vt2(j) = edge_vect_e(j)*ve(2,i,j-1)+(1.-edge_vect_e(j))*ve(2,i,j) - vt3(j) = edge_vect_e(j)*ve(3,i,j-1)+(1.-edge_vect_e(j))*ve(3,i,j) - else - vt1(j) = edge_vect_e(j)*ve(1,i,j+1)+(1.-edge_vect_e(j))*ve(1,i,j) - vt2(j) = edge_vect_e(j)*ve(2,i,j+1)+(1.-edge_vect_e(j))*ve(2,i,j) - vt3(j) = edge_vect_e(j)*ve(3,i,j+1)+(1.-edge_vect_e(j))*ve(3,i,j) - endif - enddo - do j=js,je - ve(1,i,j) = vt1(j) - ve(2,i,j) = vt2(j) - ve(3,i,j) = vt3(j) - enddo - endif - -! N-S edges (for u-wind): - if ( js==1 ) then - j = 1 - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_s(i)*ue(1,i-1,j)+(1.-edge_vect_s(i))*ue(1,i,j) - ut2(i) = edge_vect_s(i)*ue(2,i-1,j)+(1.-edge_vect_s(i))*ue(2,i,j) - ut3(i) = edge_vect_s(i)*ue(3,i-1,j)+(1.-edge_vect_s(i))*ue(3,i,j) - else - ut1(i) = edge_vect_s(i)*ue(1,i+1,j)+(1.-edge_vect_s(i))*ue(1,i,j) - ut2(i) = edge_vect_s(i)*ue(2,i+1,j)+(1.-edge_vect_s(i))*ue(2,i,j) - ut3(i) = edge_vect_s(i)*ue(3,i+1,j)+(1.-edge_vect_s(i))*ue(3,i,j) - endif - enddo - do i=is,ie - ue(1,i,j) = ut1(i) - ue(2,i,j) = ut2(i) - ue(3,i,j) = ut3(i) - enddo - endif - - if ( (je+1)==npy ) then - j = npy - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_n(i)*ue(1,i-1,j)+(1.-edge_vect_n(i))*ue(1,i,j) - ut2(i) = edge_vect_n(i)*ue(2,i-1,j)+(1.-edge_vect_n(i))*ue(2,i,j) - ut3(i) = edge_vect_n(i)*ue(3,i-1,j)+(1.-edge_vect_n(i))*ue(3,i,j) - else - ut1(i) = edge_vect_n(i)*ue(1,i+1,j)+(1.-edge_vect_n(i))*ue(1,i,j) - ut2(i) = edge_vect_n(i)*ue(2,i+1,j)+(1.-edge_vect_n(i))*ue(2,i,j) - ut3(i) = edge_vect_n(i)*ue(3,i+1,j)+(1.-edge_vect_n(i))*ue(3,i,j) - endif - enddo - do i=is,ie - ue(1,i,j) = ut1(i) - ue(2,i,j) = ut2(i) - ue(3,i,j) = ut3(i) - enddo - endif - - endif ! .not. nested - - do j=js,je+1 - do i=is,ie - u(i,j,k) = ue(1,i,j)*es(1,i,j,1) + & - ue(2,i,j)*es(2,i,j,1) + & - ue(3,i,j)*es(3,i,j,1) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j,k) = ve(1,i,j)*ew(1,i,j,2) + & - ve(2,i,j)*ew(2,i,j,2) + & - ve(3,i,j)*ew(3,i,j,2) - enddo - enddo - - enddo ! k-loop - - end subroutine cubed_a2d - - - subroutine d2a3d(u, v, ua, va, im, jm, km, lon) - integer, intent(in):: im, jm, km ! Dimensions - real, intent(in ) :: lon(im) - real, intent(in ), dimension(im,jm,km):: u, v - real, intent(out), dimension(im,jm,km):: ua, va -! local - real :: coslon(im),sinlon(im) ! Sine and cosine in longitude - integer i, j, k - integer imh - real un, vn, us, vs - - integer :: ks, ke - - imh = im/2 - - do i=1,im - sinlon(i) = sin(lon(i)) - coslon(i) = cos(lon(i)) - enddo - - do k=1,km - do j=2,jm-1 - do i=1,im - ua(i,j,k) = 0.5*(u(i,j,k) + u(i,j+1,k)) - enddo - enddo - - do j=2,jm-1 - do i=1,im-1 - va(i,j,k) = 0.5*(v(i,j,k) + v(i+1,j,k)) - enddo - va(im,j,k) = 0.5*(v(im,j,k) + v(1,j,k)) - enddo - -! Projection at SP - us = 0. - vs = 0. - do i=1,imh - us = us + (ua(i+imh,2,k)-ua(i,2,k))*sinlon(i) & - + (va(i,2,k)-va(i+imh,2,k))*coslon(i) - vs = vs + (ua(i+imh,2,k)-ua(i,2,k))*coslon(i) & - + (va(i+imh,2,k)-va(i,2,k))*sinlon(i) - enddo - us = us/im - vs = vs/im - do i=1,imh - ua(i,1,k) = -us*sinlon(i) - vs*coslon(i) - va(i,1,k) = us*coslon(i) - vs*sinlon(i) - ua(i+imh,1,k) = -ua(i,1,k) - va(i+imh,1,k) = -va(i,1,k) - enddo - -! Projection at NP - un = 0. - vn = 0. - do i=1,imh - un = un + (ua(i+imh,jm-1,k)-ua(i,jm-1,k))*sinlon(i) & - + (va(i+imh,jm-1,k)-va(i,jm-1,k))*coslon(i) - vn = vn + (ua(i,jm-1,k)-ua(i+imh,jm-1,k))*coslon(i) & - + (va(i+imh,jm-1,k)-va(i,jm-1,k))*sinlon(i) - enddo - - un = un/im - vn = vn/im - do i=1,imh - ua(i,jm,k) = -un*sinlon(i) + vn*coslon(i) - va(i,jm,k) = -un*coslon(i) - vn*sinlon(i) - ua(i+imh,jm,k) = -ua(i,jm,k) - va(i+imh,jm,k) = -va(i,jm,k) - enddo - enddo - - end subroutine d2a3d - - - subroutine pmaxmin( qname, a, im, jm, fac ) - - integer, intent(in):: im, jm - character(len=*) :: qname - integer i, j - real a(im,jm) - - real qmin(jm), qmax(jm) - real pmax, pmin - real fac ! multiplication factor - - do j=1,jm - pmax = a(1,j) - pmin = a(1,j) - do i=2,im - pmax = max(pmax, a(i,j)) - pmin = min(pmin, a(i,j)) - enddo - qmax(j) = pmax - qmin(j) = pmin - enddo -! -! Now find max/min of amax/amin -! - pmax = qmax(1) - pmin = qmin(1) - do j=2,jm - pmax = max(pmax, qmax(j)) - pmin = min(pmin, qmin(j)) - enddo - - write(*,*) qname, ' max = ', pmax*fac, ' min = ', pmin*fac - - end subroutine pmaxmin - -subroutine pmaxmn(qname, q, is, ie, js, je, km, fac, area, domain) - character(len=*), intent(in):: qname - integer, intent(in):: is, ie, js, je - integer, intent(in):: km - real, intent(in):: q(is:ie, js:je, km) - real, intent(in):: fac - real(kind=R_GRID), intent(IN):: area(is-3:ie+3, js-3:je+3) - type(domain2d), intent(INOUT) :: domain -!---local variables - real qmin, qmax, gmean - integer i,j,k - - qmin = q(is,js,1) - qmax = qmin - gmean = 0. - - do k=1,km - do j=js,je - do i=is,ie - if( q(i,j,k) < qmin ) then - qmin = q(i,j,k) - elseif( q(i,j,k) > qmax ) then - qmax = q(i,j,k) - endif - enddo - enddo - enddo - - call mp_reduce_min(qmin) - call mp_reduce_max(qmax) - - gmean = g_sum(domain, q(is,js,km), is, ie, js, je, 3, area, 1, reproduce=.true.) - if(is_master()) write(6,*) qname, qmax*fac, qmin*fac, gmean*fac - - end subroutine pmaxmn - - subroutine p_maxmin(qname, q, is, ie, js, je, km, fac) - character(len=*), intent(in):: qname - integer, intent(in):: is, ie, js, je, km - real, intent(in):: q(is:ie, js:je, km) - real, intent(in):: fac - real qmin, qmax - integer i,j,k - - qmin = q(is,js,1) - qmax = qmin - do k=1,km - do j=js,je - do i=is,ie - if( q(i,j,k) < qmin ) then - qmin = q(i,j,k) - elseif( q(i,j,k) > qmax ) then - qmax = q(i,j,k) - endif - enddo - enddo - enddo - call mp_reduce_min(qmin) - call mp_reduce_max(qmax) - if(is_master()) write(6,*) qname, qmax*fac, qmin*fac - - end subroutine p_maxmin - - subroutine fillq(im, km, nq, q, dp) - integer, intent(in):: im !< No. of longitudes - integer, intent(in):: km !< No. of levels - integer, intent(in):: nq !< Total number of tracers - real , intent(in):: dp(im,km) !< pressure thickness - real , intent(inout) :: q(im,km,nq) !< tracer mixing ratio -! !LOCAL VARIABLES: - integer i, k, ic, k1 - - do ic=1,nq -! Bottom up: - do k=km,2,-1 - k1 = k-1 - do i=1,im - if( q(i,k,ic) < 0. ) then - q(i,k1,ic) = q(i,k1,ic) + q(i,k,ic)*dp(i,k)/dp(i,k1) - q(i,k ,ic) = 0. - endif - enddo - enddo -! Top down: - do k=1,km-1 - k1 = k+1 - do i=1,im - if( q(i,k,ic) < 0. ) then - q(i,k1,ic) = q(i,k1,ic) + q(i,k,ic)*dp(i,k)/dp(i,k1) - q(i,k ,ic) = 0. - endif - enddo - enddo - - enddo - - end subroutine fillq - - subroutine compute_zh(im, jm, levp, ak0, bk0, ps, zs, t, q, nq, zh ) - implicit none - integer, intent(in):: levp, im,jm, nq - real, intent(in), dimension(levp+1):: ak0, bk0 - real(kind=4), intent(in), dimension(im,jm):: ps, zs - real(kind=4), intent(in), dimension(im,jm,levp):: t - real(kind=4), intent(in), dimension(im,jm,levp,nq):: q - real(kind=4), intent(out), dimension(im,jm,levp+1):: zh - ! Local: - real, dimension(im,levp+1):: pe0, pn0 -! real:: qc - integer:: i,j,k - -!$OMP parallel do default(none) shared(im,jm,levp,ak0,bk0,zs,ps,t,q,zh) & -!$OMP private(pe0,pn0) - do j = 1, jm - - do i=1, im - pe0(i,1) = ak0(1) - pn0(i,1) = log(pe0(i,1)) - zh(i,j,levp+1) = zs(i,j) - enddo - - do k=2,levp+1 - do i=1,im - pe0(i,k) = ak0(k) + bk0(k)*ps(i,j) - pn0(i,k) = log(pe0(i,k)) - enddo - enddo - - do k = levp, 1, -1 - do i = 1, im -! qc = 1.-(q(i,j,k,2)+q(i,j,k,3)+q(i,j,k,4)+q(i,j,k,5)) - zh(i,j,k) = zh(i,j,k+1)+(t(i,j,k)*(1.+zvir*q(i,j,k,1))*(pn0(i,k+1)-pn0(i,k)))*(rdgas/grav) - enddo - enddo - enddo - - !if(is_master()) call pmaxmin( 'zh levp+1', zh(:,:,levp+1), im, jm, 1.) - - end subroutine compute_zh - - subroutine get_staggered_grid( is, ie, js, je, isd, ied, jsd, jed, pt_b, pt_c, pt_d) - integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed - real, dimension(isd:ied+1,jsd:jed+1,2), intent(in) :: pt_b - real, dimension(isd:ied+1,jsd:jed ,2), intent(out) :: pt_c - real, dimension(isd:ied ,jsd:jed+1,2), intent(out) :: pt_d - ! local - real(kind=R_GRID), dimension(2):: p1, p2, p3 - integer :: i, j - - do j=js,je+1 - do i=is,ie - p1(:) = pt_b(i, j,1:2) - p2(:) = pt_b(i+1,j,1:2) - call mid_pt_sphere(p1, p2, p3) - pt_d(i,j,1:2) = p3(:) - enddo - enddo - - do j=js,je - do i=is,ie+1 - p1(:) = pt_b(i,j ,1:2) - p2(:) = pt_b(i,j+1,1:2) - call mid_pt_sphere(p1, p2, p3) - pt_c(i,j,1:2) = p3(:) - enddo - enddo - - end subroutine get_staggered_grid - - end module external_ic_mod - + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +#ifdef OVERLOAD_R4 +#define _GET_VAR1 get_var1_real +#else +#define _GET_VAR1 get_var1_double +#endif + +!>@brief The module 'external_ic_mod' contains routines that read in and +!! remap initial conditions. + +module external_ic_mod + +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
Module NameFunctions Included
constants_modpi=>pi_8, omega, grav, kappa, rdgas, rvgas, cp_air
external_sst_modi_sst, j_sst, sst_ncep
field_manager_modMODEL_ATMOS
fms_modfile_exist, read_data, field_exist, write_version_number, +! open_namelist_file, check_nml_error, close_file, +! get_mosaic_tile_file, read_data, error_mesg
fms_io_modget_tile_string, field_size, free_restart_type, +! restart_file_type, register_restart_field, +! save_restart, restore_state
fv_arrays_modfv_atmos_type, fv_grid_type, fv_grid_bounds_type, R_GRID
fv_control_modfv_init, fv_end, ngrids
fv_diagnostics_modprt_maxmin, prt_gb_nh_sh, prt_height
fv_eta_modset_eta, set_external_eta
fv_fill_modfillz
fv_grid_utils_modptop_min, g_sum,mid_pt_sphere,get_unit_vect2, +! get_latlon_vector,inner_prod
fv_io_modfv_io_read_tracers
fv_mp_modng, is_master, fill_corners, YDir, mp_reduce_min, mp_reduce_max
fv_mapz_modmappm
fv_nwp_nudge_modT_is_Tv
fv_surf_map_modsurfdrv, FV3_zs_filter,sgh_g, oro_g,del2_cubed_sphere, del4_cubed_sphere
fv_timing_modtiming_on, timing_off
fv_update_phys_modfv_update_phys
init_hydro_modp_var
mpp_modmpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe,stdlog, input_nml_file
mpp_domains_modmpp_get_tile_id, domain2d, mpp_update_domains, NORTH, EAST
mpp_parameter_modAGRID_PARAM=>AGRID
sim_nc_modopen_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_real, +! get_var3_r4, get_var2_r4, get_var1_real, get_var_att_double
tracer_manager_modget_tracer_names, get_number_tracers, get_tracer_index, set_tracer_profile
test_cases_modchecker_tracers
+ + use netcdf + use external_sst_mod, only: i_sst, j_sst, sst_ncep + use fms_mod, only: file_exist, read_data, field_exist, write_version_number + use fms_mod, only: open_namelist_file, check_nml_error, close_file + use fms_mod, only: get_mosaic_tile_file, read_data, error_mesg + use fms_io_mod, only: get_tile_string, field_size, free_restart_type + use fms_io_mod, only: restart_file_type, register_restart_field + use fms_io_mod, only: save_restart, restore_state, set_filename_appendix, get_global_att_value + use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe + use mpp_mod, only: stdlog, input_nml_file + use mpp_parameter_mod, only: AGRID_PARAM=>AGRID + use mpp_domains_mod, only: mpp_get_tile_id, domain2d, mpp_update_domains, NORTH, EAST + use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index + use tracer_manager_mod, only: set_tracer_profile + use field_manager_mod, only: MODEL_ATMOS + + use constants_mod, only: pi=>pi_8, omega, grav, kappa, rdgas, rvgas, cp_air + use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_grid_bounds_type, R_GRID + use fv_diagnostics_mod,only: prt_maxmin, prt_gb_nh_sh, prt_height + use fv_grid_utils_mod, only: ptop_min, g_sum,mid_pt_sphere,get_unit_vect2,get_latlon_vector,inner_prod + use fv_io_mod, only: fv_io_read_tracers + use fv_mapz_mod, only: mappm + + use fv_regional_mod, only: dump_field, H_STAGGER, U_STAGGER, V_STAGGER, get_data_source + use fv_mp_mod, only: is_master, fill_corners, YDir, mp_reduce_min, mp_reduce_max + use fv_regional_mod, only: start_regional_cold_start + use fv_surf_map_mod, only: surfdrv, FV3_zs_filter + use fv_surf_map_mod, only: sgh_g, oro_g + use fv_surf_map_mod, only: del2_cubed_sphere, del4_cubed_sphere + use fv_timing_mod, only: timing_on, timing_off + use init_hydro_mod, only: p_var + use fv_fill_mod, only: fillz + use fv_eta_mod, only: set_eta, set_external_eta + use sim_nc_mod, only: open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_real, & + get_var3_r4, get_var2_r4, get_var1_real, get_var_att_double + use fv_nwp_nudge_mod, only: T_is_Tv + use test_cases_mod, only: checker_tracers + +! The "T" field in NCEP analysis is actually virtual temperature (Larry H. post processing) +! BEFORE 20051201 + + use boundary_mod, only: nested_grid_BC, extrapolation_BC + use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_global_domain, mpp_get_compute_domain + +#ifdef MULTI_GASES + use multi_gases_mod, only: virq, virqd, vicpqd +#endif + + implicit none + private + + real, parameter:: zvir = rvgas/rdgas - 1. + real(kind=R_GRID), parameter :: cnst_0p20=0.20d0 + real :: deg2rad + character (len = 80) :: source ! This tells what the input source was for the data + character(len=27), parameter :: source_fv3gfs = 'FV3GFS GAUSSIAN NEMSIO FILE' + public get_external_ic, get_cubed_sphere_terrain + +! version number of this module +! Include variable "version" to be written to log file. +#include + +contains + + subroutine get_external_ic( Atm, fv_domain, cold_start, dt_atmos ) + + type(fv_atmos_type), intent(inout), target :: Atm + type(domain2d), intent(inout) :: fv_domain + logical, intent(IN) :: cold_start + real, intent(IN) :: dt_atmos + real:: alpha = 0. + real rdg + integer i,j,k,nq + + real, pointer, dimension(:,:,:) :: grid, agrid + real, pointer, dimension(:,:) :: fC, f0 + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed, ng + integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel +#ifdef CCPP + integer :: liq_aero, ice_aero +#endif +#ifdef MULTI_GASES + integer :: spfo, spfo2, spfo3 +#else + integer :: o3mr +#endif + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + ng = Atm%bd%ng + + grid => Atm%gridstruct%grid + agrid => Atm%gridstruct%agrid + + fC => Atm%gridstruct%fC + f0 => Atm%gridstruct%f0 + +! * Initialize coriolis param: + + do j=jsd,jed+1 + do i=isd,ied+1 + fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + & + sin(grid(i,j,2))*cos(alpha) ) + enddo + enddo + + do j=jsd,jed + do i=isd,ied + f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + & + sin(agrid(i,j,2))*cos(alpha) ) + enddo + enddo + + call mpp_update_domains( f0, fv_domain ) + if ( Atm%gridstruct%cubed_sphere .and. (.not. Atm%gridstruct%bounded_domain))then + call fill_corners(f0, Atm%npx, Atm%npy, YDir) + endif + +! Read in cubed_sphere terrain + if ( Atm%flagstruct%mountain ) then + call get_cubed_sphere_terrain(Atm, fv_domain) + else + if (.not. Atm%neststruct%nested) Atm%phis = 0. !TODO: Not sure about this line --- lmh 30 may 18 + endif + +! Read in the specified external dataset and do all the needed transformation + if ( Atm%flagstruct%ncep_ic ) then + nq = 1 + call timing_on('NCEP_IC') + call get_ncep_ic( Atm, fv_domain, nq ) + call timing_off('NCEP_IC') +#ifdef FV_TRACERS + if (.not. cold_start) then + call fv_io_read_tracers( fv_domain, Atm ) + if(is_master()) write(*,*) 'All tracers except sphum replaced by FV IC' + endif +#endif + elseif ( Atm%flagstruct%nggps_ic ) then + call timing_on('NGGPS_IC') + call get_nggps_ic( Atm, fv_domain, dt_atmos ) + call timing_off('NGGPS_IC') + elseif ( Atm%flagstruct%ecmwf_ic ) then + if( is_master() ) write(*,*) 'Calling get_ecmwf_ic' + call timing_on('ECMWF_IC') + call get_ecmwf_ic( Atm, fv_domain ) + call timing_off('ECMWF_IC') + else +! The following is to read in legacy lat-lon FV core restart file +! is Atm%q defined in all cases? + nq = size(Atm%q,4) + call get_fv_ic( Atm, fv_domain, nq ) + endif + + call prt_maxmin('PS', Atm%ps, is, ie, js, je, ng, 1, 0.01) + call prt_maxmin('T', Atm%pt, is, ie, js, je, ng, Atm%npz, 1.) + if (.not.Atm%flagstruct%hydrostatic) call prt_maxmin('W', Atm%w, is, ie, js, je, ng, Atm%npz, 1.) + call prt_maxmin('SPHUM', Atm%q(:,:,:,1), is, ie, js, je, ng, Atm%npz, 1.) + if ( Atm%flagstruct%nggps_ic ) then + call prt_maxmin('TS', Atm%ts, is, ie, js, je, 0, 1, 1.) + endif + if ( Atm%flagstruct%nggps_ic .or. Atm%flagstruct%ecmwf_ic ) then + sphum = get_tracer_index(MODEL_ATMOS, 'sphum') + liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') + ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') + rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') + snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') + graupel = get_tracer_index(MODEL_ATMOS, 'graupel') +#ifdef MULTI_GASES + spfo = get_tracer_index(MODEL_ATMOS, 'spfo') + spfo2 = get_tracer_index(MODEL_ATMOS, 'spfo2') + spfo3 = get_tracer_index(MODEL_ATMOS, 'spfo3') +#else + o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') +#endif +#ifdef CCPP + liq_aero = get_tracer_index(MODEL_ATMOS, 'liq_aero') + ice_aero = get_tracer_index(MODEL_ATMOS, 'ice_aero') +#endif + + if ( liq_wat > 0 ) & + call prt_maxmin('liq_wat', Atm%q(:,:,:,liq_wat), is, ie, js, je, ng, Atm%npz, 1.) + if ( ice_wat > 0 ) & + call prt_maxmin('ice_wat', Atm%q(:,:,:,ice_wat), is, ie, js, je, ng, Atm%npz, 1.) + if ( rainwat > 0 ) & + call prt_maxmin('rainwat', Atm%q(:,:,:,rainwat), is, ie, js, je, ng, Atm%npz, 1.) + if ( snowwat > 0 ) & + call prt_maxmin('snowwat', Atm%q(:,:,:,snowwat), is, ie, js, je, ng, Atm%npz, 1.) + if ( graupel > 0 ) & + call prt_maxmin('graupel', Atm%q(:,:,:,graupel), is, ie, js, je, ng, Atm%npz, 1.) +#ifdef MULTI_GASES + if ( spfo > 0 ) & + call prt_maxmin('SPFO', Atm%q(:,:,:,spfo), is, ie, js, je, ng, Atm%npz, 1.) + if ( spfo2 > 0 ) & + call prt_maxmin('SPFO2', Atm%q(:,:,:,spfo2), is, ie, js, je, ng, Atm%npz, 1.) + if ( spfo3 > 0 ) & + call prt_maxmin('SPFO3', Atm%q(:,:,:,spfo3), is, ie, js, je, ng, Atm%npz, 1.) +#else + if ( o3mr > 0 ) & + call prt_maxmin('O3MR', Atm%q(:,:,:,o3mr), is, ie, js, je, ng, Atm%npz, 1.) +#endif +#ifdef CCPP + if ( liq_aero > 0) & + call prt_maxmin('liq_aero',Atm%q(:,:,:,liq_aero),is, ie, js, je, ng, Atm%npz, 1.) + if ( ice_aero > 0) & + call prt_maxmin('ice_aero',Atm%q(:,:,:,ice_aero),is, ie, js, je, ng, Atm%npz, 1.) +#endif + endif + +!Now in fv_restart +!!$ call p_var(Atm%npz, is, ie, js, je, Atm%ak(1), ptop_min, & +!!$ Atm%delp, Atm%delz, Atm%pt, Atm%ps, & +!!$ Atm%pe, Atm%peln, Atm%pk, Atm%pkz, & +!!$ kappa, Atm%q, ng, Atm%ncnst, Atm%gridstruct%area_64, Atm%flagstruct%dry_mass, & +!!$ Atm%flagstruct%adjust_dry_mass, Atm%flagstruct%mountain, Atm%flagstruct%moist_phys, & +!!$ Atm%flagstruct%hydrostatic, Atm%flagstruct%nwat, Atm%domain, Atm%flagstruct%adiabatic, Atm%flagstruct%make_nh) + + end subroutine get_external_ic + + +!------------------------------------------------------------------ + subroutine get_cubed_sphere_terrain( Atm, fv_domain ) + type(fv_atmos_type), intent(inout), target :: Atm + type(domain2d), intent(inout) :: fv_domain + integer :: tile_id(1) + character(len=64) :: fname + character(len=7) :: gn + integer :: n=1 + integer :: jbeg, jend + real ftop + real, allocatable :: g_dat2(:,:,:) + real, allocatable :: pt_coarse(:,:,:) + integer isc_p, iec_p, jsc_p, jec_p, isg, ieg, jsg,jeg + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed, ng + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + ng = Atm%bd%ng + + if (Atm%grid_number > 1) then + !write(gn,'(A2, I1)') ".g", Atm%grid_number + write(gn,'(A5, I2.2)') ".nest", Atm%grid_number + else + gn = '' + end if + + tile_id = mpp_get_tile_id( fv_domain ) + + call get_tile_string(fname, 'INPUT/fv_core.res'//trim(gn)//'.tile', tile_id(n), '.nc' ) + if (mpp_pe() == mpp_root_pe()) print*, 'external_ic: looking for ', fname + + + if( file_exist(fname) ) then + call read_data(fname, 'phis', Atm%phis(is:ie,js:je), & + domain=fv_domain, tile_count=n) + else + call surfdrv( Atm%npx, Atm%npy, Atm%gridstruct%grid_64, Atm%gridstruct%agrid_64, & + Atm%gridstruct%area_64, Atm%gridstruct%dx, Atm%gridstruct%dy, & + Atm%gridstruct%dxa, Atm%gridstruct%dya, & + Atm%gridstruct%dxc, Atm%gridstruct%dyc, Atm%gridstruct%sin_sg, & + Atm%phis, Atm%flagstruct%stretch_fac, & + Atm%neststruct%nested, Atm%gridstruct%bounded_domain, & + Atm%neststruct%npx_global, Atm%domain, & + Atm%flagstruct%grid_number, Atm%bd ) + call mpp_error(NOTE,'terrain datasets generated using USGS data') + endif + + + !Needed for reproducibility. DON'T REMOVE THIS!! + call mpp_update_domains( Atm%phis, Atm%domain ) + ftop = g_sum(Atm%domain, Atm%phis(is:ie,js:je), is, ie, js, je, ng, Atm%gridstruct%area_64, 1) + + call prt_maxmin('ZS', Atm%phis, is, ie, js, je, ng, 1, 1./grav) + if(is_master()) write(*,*) 'mean terrain height (m)=', ftop/grav + + + end subroutine get_cubed_sphere_terrain + +!>@brief The subroutine 'get_nggps_ic' reads in data after it has been preprocessed with +!! NCEP/EMC orography maker and 'global_chgres', and has been horiztontally +!! interpolated to the current cubed-sphere grid + subroutine get_nggps_ic (Atm, fv_domain, dt_atmos ) + +!>variables read in from 'gfs_ctrl.nc' +!> VCOORD - level information +!> maps to 'ak & bk' +!> variables read in from 'sfc_data.nc' +!> land_frac - land-sea-ice mask (L:0 / S:1) +!> maps to 'oro' +!> TSEA - surface skin temperature (k) +!> maps to 'ts' +!> variables read in from 'gfs_data.nc' +!> ZH - GFS grid height at edges (m) +!> PS - surface pressure (Pa) +!> U_W - D-grid west face tangential wind component (m/s) +!> V_W - D-grid west face normal wind component (m/s) +!> U_S - D-grid south face tangential wind component (m/s) +!> V_S - D-grid south face normal wind component (m/s) +!> OMGA- vertical velocity 'omega' (Pa/s) +!> Q - prognostic tracer fields +!> Namelist variables +!> filtered_terrain - use orography maker filtered terrain mapping +#ifdef __PGI + use GFS_restart, only : GFS_restart_type + + implicit none +#endif + + type(fv_atmos_type), intent(inout) :: Atm + type(domain2d), intent(inout) :: fv_domain + real, intent(in) :: dt_atmos +! local: + real, dimension(:), allocatable:: ak, bk + real, dimension(:,:), allocatable:: wk2, ps, oro_g + real, dimension(:,:,:), allocatable:: ud, vd, u_w, v_w, u_s, v_s, omga, temp + real, dimension(:,:,:), allocatable:: zh(:,:,:) ! 3D height at 65 edges + real, dimension(:,:,:,:), allocatable:: q + real, dimension(:,:), allocatable :: phis_coarse ! lmh + real rdg, wt, qt, m_fac, pe1 + integer:: n, npx, npy, npz, itoa, nt, ntprog, ntdiag, ntracers, ntrac, iq + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: ios, ierr, unit, id_res + type (restart_file_type) :: ORO_restart, SFC_restart, GFS_restart + character(len=6) :: gn, stile_name + character(len=64) :: tracer_name + character(len=64) :: fn_gfs_ctl = 'gfs_ctrl.nc' + character(len=64) :: fn_gfs_ics = 'gfs_data.nc' + character(len=64) :: fn_sfc_ics = 'sfc_data.nc' + character(len=64) :: fn_oro_ics = 'oro_data.nc' + ! DH* character(len=64) :: fn_aero_ics = 'aero_data.nc' *DH + logical :: remap + logical :: filtered_terrain = .true. + logical :: gfs_dwinds = .true. + integer :: levp = 64 + logical :: checker_tr = .false. + integer :: nt_checker = 0 + real(kind=R_GRID), dimension(2):: p1, p2, p3 + real(kind=R_GRID), dimension(3):: e1, e2, ex, ey + integer:: i,j,k,nts, ks + integer:: liq_wat, ice_wat, rainwat, snowwat, graupel, tke, ntclamt + namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds, & + checker_tr, nt_checker + + n = 1 !?? + + call mpp_error(NOTE,'Using external_IC::get_nggps_ic which is valid only for data which has been & + &horizontally interpolated to the current cubed-sphere grid') +#ifdef INTERNAL_FILE_NML + read (input_nml_file,external_ic_nml,iostat=ios) + ierr = check_nml_error(ios,'external_ic_nml') +#else + unit=open_namelist_file() + read (unit,external_ic_nml,iostat=ios) + ierr = check_nml_error(ios,'external_ic_nml') + call close_file(unit) +#endif + + unit = stdlog() + call write_version_number ( 'EXTERNAL_IC_MOD::get_nggps_ic', version ) + write(unit, nml=external_ic_nml) + + remap = .true. + if (Atm%flagstruct%external_eta) then + if (filtered_terrain) then + call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, filtered terrain & + &and NCEP pressure levels (no vertical remapping)') + else if (.not. filtered_terrain) then + call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, raw terrain & + &and NCEP pressure levels (no vertical remapping)') + endif + else ! (.not.external_eta) + if (filtered_terrain) then + call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, filtered terrain & + &and FV3 pressure levels (vertical remapping)') + else if (.not. filtered_terrain) then + call mpp_error(NOTE,'External_IC::get_nggps_ic - use externally-generated, raw terrain & + &and FV3 pressure levels (vertical remapping)') + endif + endif + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + npz = Atm%npz + write(*,22001)is,ie,js,je,isd,ied,jsd,jed +22001 format(' enter get_nggps_ic is=',i4,' ie=',i4,' js=',i4,' je=',i4,' isd=',i4,' ied=',i4,' jsd=',i4,' jed=',i4) + call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers, num_prog=ntprog) + ntdiag = ntracers-ntprog + +!--- set the 'nestXX' appendix for all files using fms_io + if (Atm%grid_number > 1) then + write(gn,'(A4, I2.2)') "nest", Atm%grid_number + else + gn = '' + end if + call set_filename_appendix('') + +!--- test for existence of the GFS control file + if (.not. file_exist('INPUT/'//trim(fn_gfs_ctl), no_domain=.TRUE.)) then + call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: file '//trim(fn_gfs_ctl)//' for NGGPS IC does not exist') + endif + call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using control file '//trim(fn_gfs_ctl)//' for NGGPS IC') + +!--- read in the number of tracers in the NCEP NGGPS ICs + call read_data ('INPUT/'//trim(fn_gfs_ctl), 'ntrac', ntrac, no_domain=.TRUE.) + if (ntrac > ntracers) call mpp_error(FATAL,'==> External_ic::get_nggps_ic: more NGGPS tracers & + &than defined in field_table '//trim(fn_gfs_ctl)//' for NGGPS IC') + +! + call get_data_source(source,Atm%flagstruct%regional) + if (trim(source) == source_fv3gfs) then + call mpp_error(NOTE, "READING FROM REGRIDDED FV3GFS NEMSIO FILE") + endif +! +!--- read in ak and bk from the gfs control file using fms_io read_data --- + allocate (wk2(levp+1,2)) + allocate (ak(levp+1)) + allocate (bk(levp+1)) + call read_data('INPUT/'//trim(fn_gfs_ctl),'vcoord',wk2, no_domain=.TRUE.) + ak(1:levp+1) = wk2(1:levp+1,1) + bk(1:levp+1) = wk2(1:levp+1,2) + deallocate (wk2) + + if (.not. file_exist('INPUT/'//trim(fn_oro_ics), domain=Atm%domain)) then + call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_oro_ics)//' for NGGPS IC does not exist') + endif + call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_oro_ics)//' for NGGPS IC') + + if (.not. file_exist('INPUT/'//trim(fn_sfc_ics), domain=Atm%domain)) then + call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_sfc_ics)//' for NGGPS IC does not exist') + endif + call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_sfc_ics)//' for NGGPS IC') + + if (.not. file_exist('INPUT/'//trim(fn_gfs_ics), domain=Atm%domain)) then + call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: tiled file '//trim(fn_gfs_ics)//' for NGGPS IC does not exist') + endif + call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_gfs_ics)//' for NGGPS IC') + + allocate (zh(is:ie,js:je,levp+1)) ! SJL + allocate (ps(is:ie,js:je)) + allocate (omga(is:ie,js:je,levp)) + allocate (q (is:ie,js:je,levp,ntracers)) + allocate ( u_w(is:ie+1, js:je, 1:levp) ) + allocate ( v_w(is:ie+1, js:je, 1:levp) ) + allocate ( u_s(is:ie, js:je+1, 1:levp) ) + allocate ( v_s(is:ie, js:je+1, 1:levp) ) + allocate (temp(is:ie,js:je,levp)) + + !!! If a nested grid, save the filled coarse-grid topography for blending + if (Atm%neststruct%nested) then + allocate(phis_coarse(isd:ied,jsd:jed)) + do j=jsd,jed + do i=isd,ied + phis_coarse(i,j) = Atm%phis(i,j) + enddo + enddo + endif + +!--- read in surface temperature (k) and land-frac + ! surface skin temperature + id_res = register_restart_field (SFC_restart, fn_sfc_ics, 'tsea', Atm%ts, domain=Atm%domain) + + ! terrain surface height -- (needs to be transformed into phis = zs*grav) + if (filtered_terrain) then + id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_filt', Atm%phis, domain=Atm%domain) + elseif (.not. filtered_terrain) then + id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_raw', Atm%phis, domain=Atm%domain) + endif + + if ( Atm%flagstruct%full_zs_filter) then + allocate (oro_g(isd:ied,jsd:jed)) + oro_g = 0. + ! land-frac + id_res = register_restart_field (ORO_restart, fn_oro_ics, 'land_frac', oro_g, domain=Atm%domain) + call mpp_update_domains(oro_g, Atm%domain) + if (Atm%neststruct%nested) then + call extrapolation_BC(oro_g, 0, 0, Atm%npx, Atm%npy, Atm%bd, .true.) + endif + endif + + if ( Atm%flagstruct%fv_land ) then + ! stddev + id_res = register_restart_field (ORO_restart, fn_oro_ics, 'stddev', Atm%sgh, domain=Atm%domain) + ! land-frac + id_res = register_restart_field (ORO_restart, fn_oro_ics, 'land_frac', Atm%oro, domain=Atm%domain) + endif + + ! surface pressure (Pa) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ps', ps, domain=Atm%domain) + + ! D-grid west face tangential wind component (m/s) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'u_w', u_w, domain=Atm%domain,position=EAST) + ! D-grid west face normal wind component (m/s) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'v_w', v_w, domain=Atm%domain,position=EAST) + ! D-grid south face tangential wind component (m/s) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'u_s', u_s, domain=Atm%domain,position=NORTH) + ! D-grid south face normal wind component (m/s) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'v_s', v_s, domain=Atm%domain,position=NORTH) + + ! vertical velocity 'omega' (Pa/s) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'w', omga, domain=Atm%domain) + ! GFS grid height at edges (including surface height) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ZH', zh, domain=Atm%domain) + + ! real temperature (K) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 't', temp, mandatory=.false., & + domain=Atm%domain) + ! prognostic tracers + do nt = 1, ntracers + call get_tracer_names(MODEL_ATMOS, nt, tracer_name) + ! DH* if aerosols are in separate file, need to test for indices liq_aero and ice_aero and change fn_gfs_ics to fn_aero_ics *DH + id_res = register_restart_field (GFS_restart, fn_gfs_ics, trim(tracer_name), q(:,:,:,nt), & + mandatory=.false.,domain=Atm%domain) + enddo + + ! initialize all tracers to default values prior to being input + do nt = 1, ntprog + call get_tracer_names(MODEL_ATMOS, nt, tracer_name) + ! set all tracers to an initial profile value + call set_tracer_profile (MODEL_ATMOS, nt, Atm%q(:,:,:,nt) ) + enddo + do nt = ntprog+1, ntracers + call get_tracer_names(MODEL_ATMOS, nt, tracer_name) + ! set all tracers to an initial profile value + call set_tracer_profile (MODEL_ATMOS, nt, Atm%qdiag(:,:,:,nt) ) + enddo + + ! read in the restart + call restore_state (ORO_restart) + call restore_state (SFC_restart) + call restore_state (GFS_restart) + + ! free the restart type to be re-used by the nest + call free_restart_type(ORO_restart) + call free_restart_type(SFC_restart) + call free_restart_type(GFS_restart) + + ! multiply NCEP ICs terrain 'phis' by gravity to be true geopotential + Atm%phis = Atm%phis*grav + + ! set the pressure levels and ptop to be used + ! else eta is set in grid_init + if (Atm%flagstruct%external_eta) then + itoa = levp - npz + 1 + Atm%ptop = ak(itoa) + Atm%ak(1:npz+1) = ak(itoa:levp+1) + Atm%bk(1:npz+1) = bk(itoa:levp+1) + call set_external_eta (Atm%ak, Atm%bk, Atm%ptop, Atm%ks) + endif + ! call vertical remapping algorithms + if(is_master()) write(*,*) 'GFS ak(1)=', ak(1), ' ak(2)=', ak(2) + ak(1) = max(1.e-9, ak(1)) + +!*** For regional runs read in each of the BC variables from the NetCDF boundary file +!*** and remap in the vertical from the input levels to the model integration levels. +!*** Here in the initialization we begn by allocating the regional domain's boundary +!*** objects. Then we need to read the first two regional BC files so the integration +!*** can begin interpolating between those two times as the forecast proceeds. + + if (n==1.and.Atm%flagstruct%regional) then !<-- Select the parent regional domain. + + call start_regional_cold_start(Atm, dt_atmos, ak, bk, levp, & + is, ie, js, je, & + isd, ied, jsd, jed ) + endif + +! +!*** Remap the variables in the compute domain. +! + call remap_scalar(Atm, levp, npz, ntracers, ak, bk, ps, q, zh, omga, temp) + + allocate ( ud(is:ie, js:je+1, 1:levp) ) + allocate ( vd(is:ie+1,js:je, 1:levp) ) + +!$OMP parallel do default(none) shared(is,ie,js,je,levp,Atm,ud,vd,u_s,v_s,u_w,v_w) & +!$OMP private(p1,p2,p3,e1,e2,ex,ey) + do k=1,levp + do j=js,je+1 + do i=is,ie + p1(:) = Atm%gridstruct%grid(i, j,1:2) + p2(:) = Atm%gridstruct%grid(i+1,j,1:2) + call mid_pt_sphere(p1, p2, p3) + call get_unit_vect2(p1, p2, e1) + call get_latlon_vector(p3, ex, ey) + ud(i,j,k) = u_s(i,j,k)*inner_prod(e1,ex) + v_s(i,j,k)*inner_prod(e1,ey) + enddo + enddo + do j=js,je + do i=is,ie+1 + p1(:) = Atm%gridstruct%grid(i,j ,1:2) + p2(:) = Atm%gridstruct%grid(i,j+1,1:2) + call mid_pt_sphere(p1, p2, p3) + call get_unit_vect2(p1, p2, e2) + call get_latlon_vector(p3, ex, ey) + vd(i,j,k) = u_w(i,j,k)*inner_prod(e2,ex) + v_w(i,j,k)*inner_prod(e2,ey) + enddo + enddo + enddo + deallocate ( u_w ) + deallocate ( v_w ) + deallocate ( u_s ) + deallocate ( v_s ) + + call remap_dwinds(levp, npz, ak, bk, ps, ud, vd, Atm) + + deallocate ( ud ) + deallocate ( vd ) + + if (Atm%neststruct%nested) then + if (is_master()) write(*,*) 'Blending nested and coarse grid topography' + npx = Atm%npx + npy = Atm%npy + do j=jsd,jed + do i=isd,ied + wt = max(0.,min(1.,real(5 - min(i,j,npx-i,npy-j,5))/5. )) + Atm%phis(i,j) = (1.-wt)*Atm%phis(i,j) + wt*phis_coarse(i,j) + enddo + enddo + endif + + + !!! Perform terrain smoothing, if desired + if ( Atm%flagstruct%full_zs_filter ) then + + call mpp_update_domains(Atm%phis, Atm%domain) + + call FV3_zs_filter( Atm%bd, isd, ied, jsd, jed, npx, npy, Atm%neststruct%npx_global, & + Atm%flagstruct%stretch_fac, Atm%gridstruct%bounded_domain, Atm%domain, & + Atm%gridstruct%area_64, Atm%gridstruct%dxa, Atm%gridstruct%dya, & + Atm%gridstruct%dx, Atm%gridstruct%dy, Atm%gridstruct%dxc, & + Atm%gridstruct%dyc, Atm%gridstruct%grid_64, Atm%gridstruct%agrid_64, & + Atm%gridstruct%sin_sg, Atm%phis, oro_g) + deallocate(oro_g) + endif + + + if ( Atm%flagstruct%n_zs_filter > 0 ) then + + if ( Atm%flagstruct%nord_zs_filter == 2 ) then + call del2_cubed_sphere(Atm%npx, Atm%npy, Atm%phis, & + Atm%gridstruct%area_64, Atm%gridstruct%dx, Atm%gridstruct%dy, & + Atm%gridstruct%dxc, Atm%gridstruct%dyc, Atm%gridstruct%sin_sg, & + Atm%flagstruct%n_zs_filter, cnst_0p20*Atm%gridstruct%da_min, & + .false., oro_g, Atm%gridstruct%bounded_domain, & + Atm%domain, Atm%bd) + if ( is_master() ) write(*,*) 'Warning !!! del-2 terrain filter has been applied ', & + Atm%flagstruct%n_zs_filter, ' times' + else if( Atm%flagstruct%nord_zs_filter == 4 ) then + call del4_cubed_sphere(Atm%npx, Atm%npy, Atm%phis, Atm%gridstruct%area_64, & + Atm%gridstruct%dx, Atm%gridstruct%dy, & + Atm%gridstruct%dxc, Atm%gridstruct%dyc, Atm%gridstruct%sin_sg, & + Atm%flagstruct%n_zs_filter, .false., oro_g, & + Atm%gridstruct%bounded_domain, & + Atm%domain, Atm%bd) + if ( is_master() ) write(*,*) 'Warning !!! del-4 terrain filter has been applied ', & + Atm%flagstruct%n_zs_filter, ' times' + endif + + endif + + if ( Atm%neststruct%nested .and. ( Atm%flagstruct%n_zs_filter > 0 .or. Atm%flagstruct%full_zs_filter ) ) then + npx = Atm%npx + npy = Atm%npy + do j=jsd,jed + do i=isd,ied + wt = max(0.,min(1.,real(5 - min(i,j,npx-i,npy-j,5))/5. )) + Atm%phis(i,j) = (1.-wt)*Atm%phis(i,j) + wt*phis_coarse(i,j) + enddo + enddo + deallocate(phis_coarse) + endif + + call mpp_update_domains( Atm%phis, Atm%domain, complete=.true. ) + liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') + ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') + rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') + snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') + graupel = get_tracer_index(MODEL_ATMOS, 'graupel') + ntclamt = get_tracer_index(MODEL_ATMOS, 'cld_amt') + if (trim(source) == source_fv3gfs) then + do k=1,npz + do j=js,je + do i=is,ie + wt = Atm%delp(i,j,k) + if ( Atm%flagstruct%nwat == 6 ) then + qt = wt*(1. + Atm%q(i,j,k,liq_wat) + & + Atm%q(i,j,k,ice_wat) + & + Atm%q(i,j,k,rainwat) + & + Atm%q(i,j,k,snowwat) + & + Atm%q(i,j,k,graupel)) + else ! all other values of nwat + qt = wt*(1. + sum(Atm%q(i,j,k,2:Atm%flagstruct%nwat))) + endif + Atm%delp(i,j,k) = qt + if (ntclamt > 0) Atm%q(i,j,k,ntclamt) = 0.0 ! Moorthi + enddo + enddo + enddo + else +!--- Add cloud condensate from GFS to total MASS +! 20160928: Adjust the mixing ratios consistently... + do k=1,npz + do j=js,je + do i=is,ie + wt = Atm%delp(i,j,k) + if ( Atm%flagstruct%nwat == 6 ) then + qt = wt*(1. + Atm%q(i,j,k,liq_wat) + & + Atm%q(i,j,k,ice_wat) + & + Atm%q(i,j,k,rainwat) + & + Atm%q(i,j,k,snowwat) + & + Atm%q(i,j,k,graupel)) + else ! all other values of nwat + qt = wt*(1. + sum(Atm%q(i,j,k,2:Atm%flagstruct%nwat))) + endif + m_fac = wt / qt + do iq=1,ntracers + Atm%q(i,j,k,iq) = m_fac * Atm%q(i,j,k,iq) + enddo + Atm%delp(i,j,k) = qt + if (ntclamt > 0) Atm%q(i,j,k,ntclamt) = 0.0 ! Moorthi + enddo + enddo + + enddo + endif !end trim(source) test + + + tke = get_tracer_index(MODEL_ATMOS, 'sgs_tke') + if (tke > 0) then + do k=1,npz + do j=js,je + do i=is,ie + !pe1 = Atm%ak(k+1) + Atm%bk(k+1)*Atm%ps(i,j) + Atm%q(i,j,k,tke) = 0.00 ! 1.*exp(-(Atm%ps(i,j) - pe1)**2) + enddo + enddo + enddo + endif + +!--- reset the tracers beyond condensate to a checkerboard pattern + if (checker_tr) then + nts = ntracers - nt_checker+1 + call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, nt_checker, & + npz, Atm%q(:,:,:,nts:ntracers), & + Atm%gridstruct%agrid_64(is:ie,js:je,1), & + Atm%gridstruct%agrid_64(is:ie,js:je,2), 9., 9.) + endif + + Atm%flagstruct%make_nh = .false. + + deallocate (ak) + deallocate (bk) + deallocate (ps) + deallocate (q ) + deallocate (temp) + deallocate (omga) + + end subroutine get_nggps_ic +!------------------------------------------------------------------ +!------------------------------------------------------------------ +!>@brief The subroutine 'get_ncep_ic' reads in the specified NCEP analysis or reanalysis dataset + subroutine get_ncep_ic( Atm, fv_domain, nq ) + type(fv_atmos_type), intent(inout) :: Atm + type(domain2d), intent(inout) :: fv_domain + integer, intent(in):: nq +! local: +#ifdef HIWPP_ETA + real :: ak_HIWPP(65), bk_HIWPP(65) + data ak_HIWPP/ & + 0, 0.00064247, 0.0013779, 0.00221958, 0.00318266, 0.00428434, & + 0.00554424, 0.00698457, 0.00863058, 0.0105108, 0.01265752, 0.01510711, & + 0.01790051, 0.02108366, 0.02470788, 0.02883038, 0.0335146, 0.03883052, & + 0.04485493, 0.05167146, 0.0593705, 0.06804874, 0.0777715, 0.08832537, & + 0.09936614, 0.1105485, 0.1215294, 0.1319707, 0.1415432, 0.1499307, & + 0.1568349, 0.1619797, 0.1651174, 0.166116, 0.1650314, 0.1619731, & + 0.1570889, 0.1505634, 0.1426143, 0.1334867, 0.1234449, 0.1127635, & + 0.1017171, 0.09057051, 0.07956908, 0.06893117, 0.05884206, 0.04945029, & + 0.04086614, 0.03316217, 0.02637553, 0.0205115, 0.01554789, 0.01143988, & + 0.00812489, 0.0055272, 0.00356223, 0.00214015, 0.00116899, 0.00055712, & + 0.00021516, 5.741e-05, 5.75e-06, 0, 0 / + + data bk_HIWPP/ & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 3.697e-05, 0.00043106, 0.00163591, 0.00410671, 0.00829402, 0.01463712, & + 0.02355588, 0.03544162, 0.05064684, 0.06947458, 0.09216691, 0.1188122, & + 0.1492688, 0.1832962, 0.2205702, 0.2606854, 0.3031641, 0.3474685, & + 0.3930182, 0.4392108, 0.4854433, 0.5311348, 0.5757467, 0.6187996, & + 0.659887, 0.6986829, 0.7349452, 0.7685147, 0.7993097, 0.8273188, & + 0.8525907, 0.8752236, 0.895355, 0.913151, 0.9287973, 0.9424911, & + 0.9544341, 0.9648276, 0.9738676, 0.9817423, 0.9886266, 0.9946712, 1 / +#endif + character(len=128) :: fname + real(kind=4), allocatable:: wk1(:), wk2(:,:), wk3(:,:,:) + real, dimension(:), allocatable:: lat, lon, ak0, bk0 + real, dimension(:,:,:), allocatable:: ud, vd + real, dimension(:,:,:,:), allocatable:: qp + real(kind=4), dimension(:,:), allocatable:: psncep, zsncep, psc + real(kind=4), dimension(:,:,:), allocatable:: uncep, vncep, tncep, zhncep + real(kind=4), dimension(:,:,:,:), allocatable:: qncep + real, dimension(:,:), allocatable:: psc_r8 + real, dimension(:,:,:), allocatable:: pt_c, pt_d, gzc + real:: s2c(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,4) + real:: s2c_c(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je,4) + real:: s2c_d(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1,4) + integer, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: id1, id2, jdc + integer, dimension(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je):: & + id1_c, id2_c, jdc_c + integer, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1):: & + id1_d, id2_d, jdc_d + real :: tmean, utmp, vtmp + integer:: i, j, k, im, jm, km, npz, npt + integer:: i1, i2, j1, ncid + integer:: jbeg, jend, jn + integer tsize(3) + logical:: read_ts = .true. + logical:: land_ts = .false. + logical:: found + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + real(kind=R_GRID), dimension(2):: p1, p2, p3 + real(kind=R_GRID), dimension(3):: e1, e2, ex, ey + integer :: id_res, ntprog, ntracers, ks, iq, nt + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + + deg2rad = pi/180. + + npz = Atm%npz + call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers, num_prog=ntprog) + if(is_master()) write(*,*) 'ntracers = ', ntracers, 'ntprog = ',ntprog + +! Zero out all initial tracer fields: +! SJL: 20110716 +! Atm%q = 0. + + fname = Atm%flagstruct%res_latlon_dynamics + + if( file_exist(fname) ) then + call open_ncfile( fname, ncid ) ! open the file + call get_ncdim1( ncid, 'lon', tsize(1) ) + call get_ncdim1( ncid, 'lat', tsize(2) ) + call get_ncdim1( ncid, 'lev', tsize(3) ) + + im = tsize(1); jm = tsize(2); km = tsize(3) + + if(is_master()) write(*,*) fname + if(is_master()) write(*,*) ' NCEP IC dimensions:', tsize + + allocate ( lon(im) ) + allocate ( lat(jm) ) + + call _GET_VAR1(ncid, 'lon', im, lon ) + call _GET_VAR1(ncid, 'lat', jm, lat ) + +! Convert to radian + do i=1,im + lon(i) = lon(i) * deg2rad ! lon(1) = 0. + enddo + do j=1,jm + lat(j) = lat(j) * deg2rad + enddo + + allocate ( ak0(km+1) ) + allocate ( bk0(km+1) ) + +#ifdef HIWPP_ETA +! The HIWPP data from Jeff does not contain (ak,bk) + do k=1, km+1 + ak0(k) = ak_HIWPP (k) + bk0(k) = bk_HIWPP (k) + enddo +#else + call _GET_VAR1(ncid, 'hyai', km+1, ak0, found ) + if ( .not. found ) ak0(:) = 0. + + call _GET_VAR1(ncid, 'hybi', km+1, bk0 ) +#endif + if( is_master() ) then + do k=1,km+1 + write(*,*) k, ak0(k), bk0(k) + enddo + endif + +! Note: definition of NCEP hybrid is p(k) = a(k)*1.E5 + b(k)*ps + ak0(:) = ak0(:) * 1.E5 + +! Limiter to prevent NAN at top during remapping + if ( bk0(1) < 1.E-9 ) ak0(1) = max(1.e-9, ak0(1)) + + else + call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for NCEP IC does not exist') + endif + +! Initialize lat-lon to Cubed bi-linear interpolation coeff: + call remap_coef( is, ie, js, je, isd, ied, jsd, jed, & + im, jm, lon, lat, id1, id2, jdc, s2c , Atm%gridstruct%agrid) + +! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je + do i=is,ie + j1 = jdc(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + if(is_master()) write(*,*) 'jbeg, jend = ', jbeg, jend +! read in surface pressure and height: + allocate ( psncep(im,jbeg:jend) ) + allocate ( zsncep(im,jbeg:jend) ) + + call get_var3_r4( ncid, 'PS', 1,im, jbeg,jend, 1,1, psncep ) + if(is_master()) write(*,*) 'done reading psncep' + call get_var3_r4( ncid, 'PHIS', 1,im, jbeg,jend, 1,1, zsncep ) + zsncep(:,:) = zsncep(:,:)/grav + if(is_master()) write(*,*) 'done reading zsncep' +! read in temperatuer: + allocate ( tncep(1:im,jbeg:jend, 1:km) ) + call get_var3_r4( ncid, 'T', 1,im, jbeg,jend, 1,km, tncep ) + if(is_master()) write(*,*) 'done reading tncep' +! read in specific humidity and cloud water cond: + allocate ( wk3(1:im,jbeg:jend, 1:km) ) + allocate ( qncep(1:im,jbeg:jend, 1:km,2) ) + call get_var3_r4( ncid, 'Q', 1,im, jbeg,jend, 1,km, wk3 ) + if(is_master()) write(*,*) 'done reading sphumncep' + qncep(:,:,:,1) = wk3(:,:,:) + call get_var3_r4( ncid, 'CWAT', 1,im, jbeg,jend, 1,km, wk3 ) + if(is_master()) write(*,*) 'done reading cwatncep' + qncep(:,:,:,2) = wk3(:,:,:) + deallocate (wk3) + + if ( T_is_Tv ) then + ! The "T" field in NCEP analysis is actually virtual temperature (Larry H. post processing) + ! BEFORE 20051201 + do i=1,im + do j=jbeg,jend + do k=1,km + tncep(i,j,k) = tncep(i,j,k)/(1.+zvir*qncep(i,j,k,1)) + enddo + enddo + enddo + endif + +!!!! Compute height on edges, zhncep [ use psncep, zsncep, tncep, sphumncep] + allocate ( zhncep(1:im,jbeg:jend, km+1) ) + jn = jend - jbeg + 1 + + call compute_zh(im, jn, km, ak0, bk0, psncep, zsncep, tncep, qncep, 2, zhncep ) + deallocate (zsncep) + deallocate (tncep) + + if(is_master()) write(*,*) 'done compute zhncep' + +! convert zhncep, psncep from NCEP grid to cubic grid + allocate (psc(is:ie,js:je)) + allocate (psc_r8(is:ie,js:je)) + + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + psc(i,j) = s2c(i,j,1)*psncep(i1,j1 ) + s2c(i,j,2)*psncep(i2,j1 ) + & + s2c(i,j,3)*psncep(i2,j1+1) + s2c(i,j,4)*psncep(i1,j1+1) + enddo + enddo + deallocate ( psncep ) + + + allocate (gzc(is:ie,js:je,km+1)) + do k=1,km+1 + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + gzc(i,j,k) = s2c(i,j,1)*zhncep(i1,j1 ,k) + s2c(i,j,2)*zhncep(i2,j1 ,k) + & + s2c(i,j,3)*zhncep(i2,j1+1,k) + s2c(i,j,4)*zhncep(i1,j1+1,k) + enddo + enddo + enddo + deallocate ( zhncep ) + + if(is_master()) write(*,*) 'done interpolate psncep/zhncep into cubic grid psc/gzc!' + +! read skin temperature; could be used for SST + allocate ( wk2(im,jm) ) + + if ( read_ts ) then ! read skin temperature; could be used for SST + + call get_var2_real( ncid, 'TS', im, jm, wk2 ) + + if ( .not. land_ts ) then + allocate ( wk1(im) ) + + do j=1,jm + ! Read NCEP ORO (1; land; 0: ocean; 2: sea_ice) + call get_var3_r4( ncid, 'ORO', 1,im, j,j, 1,1, wk1 ) + tmean = 0. + npt = 0 + do i=1,im + if( abs(wk1(i)-1.) > 0.99 ) then ! ocean or sea ice + tmean = tmean + wk2(i,j) + npt = npt + 1 + endif + enddo + !------------------------------------------------------ + ! Replace TS over interior land with zonal mean SST/Ice + !------------------------------------------------------ + if ( npt /= 0 ) then + tmean= tmean / real(npt) + do i=1,im + if( abs(wk1(i)-1.) <= 0.99 ) then ! Land points + if ( i==1 ) then + i1 = im; i2 = 2 + elseif ( i==im ) then + i1 = im-1; i2 = 1 + else + i1 = i-1; i2 = i+1 + endif + if ( abs(wk1(i2)-1.)>0.99 ) then ! east side has priority + wk2(i,j) = wk2(i2,j) + elseif ( abs(wk1(i1)-1.)>0.99 ) then ! west side + wk2(i,j) = wk2(i1,j) + else + wk2(i,j) = tmean + endif + endif + enddo + endif + enddo ! j-loop + deallocate ( wk1 ) + endif !(.not.land_ts) + + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + Atm%ts(i,j) = s2c(i,j,1)*wk2(i1,j1 ) + s2c(i,j,2)*wk2(i2,j1 ) + & + s2c(i,j,3)*wk2(i2,j1+1) + s2c(i,j,4)*wk2(i1,j1+1) + enddo + enddo + call prt_maxmin('SST_model', Atm%ts, is, ie, js, je, 0, 1, 1.) + +! Perform interp to FMS SST format/grid +#ifndef DYCORE_SOLO + call ncep2fms(im, jm, lon, lat, wk2) + if( is_master() ) then + write(*,*) 'External_ic_mod: i_sst=', i_sst, ' j_sst=', j_sst + call pmaxmin( 'SST_ncep_fms', sst_ncep, i_sst, j_sst, 1.) + endif +#endif + endif !(read_ts) + + deallocate ( wk2 ) + +! convert qncep from NCEP grid to cubic grid + allocate ( qp(is:ie,js:je,km,2) ) + do k=1,km + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + qp(i,j,k,1) = s2c(i,j,1)*qncep(i1,j1 ,k,1) + s2c(i,j,2)*qncep(i2,j1 ,k,1) + & + s2c(i,j,3)*qncep(i2,j1+1,k,1) + s2c(i,j,4)*qncep(i1,j1+1,k,1) + qp(i,j,k,2) = s2c(i,j,1)*qncep(i1,j1 ,k,2) + s2c(i,j,2)*qncep(i2,j1 ,k,2) + & + s2c(i,j,3)*qncep(i2,j1+1,k,2) + s2c(i,j,4)*qncep(i1,j1+1,k,2) + enddo + enddo + enddo + + deallocate (qncep) + + psc_r8(:,:) = psc(:,:) + deallocate (psc) + + + call remap_scalar(Atm, km, npz, 2, ak0, bk0, psc_r8, qp, gzc) + call mpp_update_domains(Atm%phis, Atm%domain) + if(is_master()) write(*,*) 'done remap_scalar' + deallocate ( qp ) + deallocate ( gzc ) + +! Winds: + ! get lat/lon values of pt_c and pt_d from grid data (pt_b) + allocate (pt_c(isd:ied+1,jsd:jed ,2)) + allocate (pt_d(isd:ied ,jsd:jed+1,2)) + allocate (ud(is:ie , js:je+1, km)) + allocate (vd(is:ie+1, js:je , km)) + + call get_staggered_grid( is, ie, js, je, & + isd, ied, jsd, jed, & + Atm%gridstruct%grid, pt_c, pt_d) + + !------ pt_c part ------ + ! Initialize lat-lon to Cubed bi-linear interpolation coeff: + call remap_coef( is, ie+1, js, je, isd, ied+1, jsd, jed, & + im, jm, lon, lat, id1_c, id2_c, jdc_c, s2c_c, pt_c) + + ! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je + do i=is,ie+1 + j1 = jdc_c(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + ! read in NCEP wind data + allocate ( uncep(1:im,jbeg:jend, 1:km) ) + allocate ( vncep(1:im,jbeg:jend, 1:km) ) + + call get_var3_r4( ncid, 'U', 1,im, jbeg,jend, 1,km, uncep ) + if(is_master()) write(*,*) 'first time done reading Uncep' + call get_var3_r4( ncid, 'V', 1,im, jbeg,jend, 1,km, vncep ) + if(is_master()) write(*,*) 'first time done reading Vncep' + +!$OMP parallel do default(none) shared(is,ie,js,je,km,s2c_c,id1_c,id2_c,jdc_c,uncep,vncep,Atm,vd) & +!$OMP private(i1,i2,j1,p1,p2,p3,e2,ex,ey,utmp,vtmp) + do k=1,km + do j=js,je + do i=is,ie+1 + i1 = id1_c(i,j) + i2 = id2_c(i,j) + j1 = jdc_c(i,j) + p1(:) = Atm%gridstruct%grid(i,j ,1:2) + p2(:) = Atm%gridstruct%grid(i,j+1,1:2) + call mid_pt_sphere(p1, p2, p3) + call get_unit_vect2(p1, p2, e2) + call get_latlon_vector(p3, ex, ey) + utmp = s2c_c(i,j,1)*uncep(i1,j1 ,k) + & + s2c_c(i,j,2)*uncep(i2,j1 ,k) + & + s2c_c(i,j,3)*uncep(i2,j1+1,k) + & + s2c_c(i,j,4)*uncep(i1,j1+1,k) + vtmp = s2c_c(i,j,1)*vncep(i1,j1 ,k) + & + s2c_c(i,j,2)*vncep(i2,j1 ,k) + & + s2c_c(i,j,3)*vncep(i2,j1+1,k) + & + s2c_c(i,j,4)*vncep(i1,j1+1,k) + vd(i,j,k) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey) + enddo + enddo + enddo + + deallocate ( uncep, vncep ) + + !------ pt_d part ------ + ! Initialize lat-lon to Cubed bi-linear interpolation coeff: + call remap_coef( is, ie, js, je+1, isd, ied, jsd, jed+1, & + im, jm, lon, lat, id1_d, id2_d, jdc_d, s2c_d, pt_d) + deallocate ( pt_c, pt_d ) + + ! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je+1 + do i=is,ie + j1 = jdc_d(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + ! read in NCEP wind data + allocate ( uncep(1:im,jbeg:jend, 1:km) ) + allocate ( vncep(1:im,jbeg:jend, 1:km) ) + + call get_var3_r4( ncid, 'U', 1,im, jbeg,jend, 1,km, uncep ) + if(is_master()) write(*,*) 'second time done reading uec' + + call get_var3_r4( ncid, 'V', 1,im, jbeg,jend, 1,km, vncep ) + if(is_master()) write(*,*) 'second time done reading vec' + +!$OMP parallel do default(none) shared(is,ie,js,je,km,id1_d,id2_d,jdc_d,s2c_d,uncep,vncep,Atm,ud) & +!$OMP private(i1,i2,j1,p1,p2,p3,e1,ex,ey,utmp,vtmp) + do k=1,km + do j=js,je+1 + do i=is,ie + i1 = id1_d(i,j) + i2 = id2_d(i,j) + j1 = jdc_d(i,j) + p1(:) = Atm%gridstruct%grid(i, j,1:2) + p2(:) = Atm%gridstruct%grid(i+1,j,1:2) + call mid_pt_sphere(p1, p2, p3) + call get_unit_vect2(p1, p2, e1) + call get_latlon_vector(p3, ex, ey) + utmp = s2c_d(i,j,1)*uncep(i1,j1 ,k) + & + s2c_d(i,j,2)*uncep(i2,j1 ,k) + & + s2c_d(i,j,3)*uncep(i2,j1+1,k) + & + s2c_d(i,j,4)*uncep(i1,j1+1,k) + vtmp = s2c_d(i,j,1)*vncep(i1,j1 ,k) + & + s2c_d(i,j,2)*vncep(i2,j1 ,k) + & + s2c_d(i,j,3)*vncep(i2,j1+1,k) + & + s2c_d(i,j,4)*vncep(i1,j1+1,k) + ud(i,j,k) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey) + enddo + enddo + enddo + deallocate ( uncep, vncep ) + + call remap_dwinds(km, npz, ak0, bk0, psc_r8, ud, vd, Atm) + deallocate ( ud, vd ) + call close_ncfile ( ncid ) + + deallocate ( ak0 ) + deallocate ( bk0 ) + deallocate ( lat ) + deallocate ( lon ) + + end subroutine get_ncep_ic + +!>@brief The subroutine 'get_ecmwf_ic' reads in initial conditions from ECMWF analyses +!! (EXPERIMENTAL: contact Jan-Huey Chen jan-huey.chen@noaa.gov for support) +!>@authors Jan-Huey Chen, Xi Chen, Shian-Jiann Lin + subroutine get_ecmwf_ic( Atm, fv_domain ) + +#ifdef __PGI + use GFS_restart, only : GFS_restart_type + + implicit none +#endif + + type(fv_atmos_type), intent(inout) :: Atm + type(domain2d), intent(inout) :: fv_domain +! local: + real :: ak_ec(138), bk_ec(138) + data ak_ec/ 0.000000, 2.000365, 3.102241, 4.666084, 6.827977, 9.746966, & + 13.605424, 18.608931, 24.985718, 32.985710, 42.879242, 54.955463, & + 69.520576, 86.895882, 107.415741, 131.425507, 159.279404, 191.338562, & + 227.968948, 269.539581, 316.420746, 368.982361, 427.592499, 492.616028, & + 564.413452, 643.339905, 729.744141, 823.967834, 926.344910, 1037.201172, & + 1156.853638, 1285.610352, 1423.770142, 1571.622925, 1729.448975, 1897.519287, & + 2076.095947, 2265.431641, 2465.770508, 2677.348145, 2900.391357, 3135.119385, & + 3381.743652, 3640.468262, 3911.490479, 4194.930664, 4490.817383, 4799.149414, & + 5119.895020, 5452.990723, 5798.344727, 6156.074219, 6526.946777, 6911.870605, & + 7311.869141, 7727.412109, 8159.354004, 8608.525391, 9076.400391, 9562.682617, & + 10065.978516, 10584.631836, 11116.662109, 11660.067383, 12211.547852, 12766.873047, & + 13324.668945, 13881.331055, 14432.139648, 14975.615234, 15508.256836, 16026.115234, & + 16527.322266, 17008.789063, 17467.613281, 17901.621094, 18308.433594, 18685.718750, & + 19031.289063, 19343.511719, 19620.042969, 19859.390625, 20059.931641, 20219.664063, & + 20337.863281, 20412.308594, 20442.078125, 20425.718750, 20361.816406, 20249.511719, & + 20087.085938, 19874.025391, 19608.572266, 19290.226563, 18917.460938, 18489.707031, & + 18006.925781, 17471.839844, 16888.687500, 16262.046875, 15596.695313, 14898.453125, & + 14173.324219, 13427.769531, 12668.257813, 11901.339844, 11133.304688, 10370.175781, & + 9617.515625, 8880.453125, 8163.375000, 7470.343750, 6804.421875, 6168.531250, & + 5564.382813, 4993.796875, 4457.375000, 3955.960938, 3489.234375, 3057.265625, & + 2659.140625, 2294.242188, 1961.500000, 1659.476563, 1387.546875, 1143.250000, & + 926.507813, 734.992188, 568.062500, 424.414063, 302.476563, 202.484375, & + 122.101563, 62.781250, 22.835938, 3.757813, 0.000000, 0.000000 / + + data bk_ec/ 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000007, 0.000024, 0.000059, 0.000112, 0.000199, & + 0.000340, 0.000562, 0.000890, 0.001353, 0.001992, 0.002857, & + 0.003971, 0.005378, 0.007133, 0.009261, 0.011806, 0.014816, & + 0.018318, 0.022355, 0.026964, 0.032176, 0.038026, 0.044548, & + 0.051773, 0.059728, 0.068448, 0.077958, 0.088286, 0.099462, & + 0.111505, 0.124448, 0.138313, 0.153125, 0.168910, 0.185689, & + 0.203491, 0.222333, 0.242244, 0.263242, 0.285354, 0.308598, & + 0.332939, 0.358254, 0.384363, 0.411125, 0.438391, 0.466003, & + 0.493800, 0.521619, 0.549301, 0.576692, 0.603648, 0.630036, & + 0.655736, 0.680643, 0.704669, 0.727739, 0.749797, 0.770798, & + 0.790717, 0.809536, 0.827256, 0.843881, 0.859432, 0.873929, & + 0.887408, 0.899900, 0.911448, 0.922096, 0.931881, 0.940860, & + 0.949064, 0.956550, 0.963352, 0.969513, 0.975078, 0.980072, & + 0.984542, 0.988500, 0.991984, 0.995003, 0.997630, 1.000000 / + +! The following L63 will be used in the model +! The setting is the same as NCEP GFS's L64 except the top layer + real, dimension(64):: ak_sj, bk_sj + data ak_sj/64.247, 137.790, 221.958, & + 318.266, 428.434, 554.424, & + 698.457, 863.05803, 1051.07995, & + 1265.75194, 1510.71101, 1790.05098, & + 2108.36604, 2470.78817, 2883.03811, & + 3351.46002, 3883.05187, 4485.49315, & + 5167.14603, 5937.04991, 6804.87379, & + 7780.84698, 8875.64338, 10100.20534, & + 11264.35673, 12190.64366, 12905.42546, & + 13430.87867, 13785.88765, 13986.77987, & + 14047.96335, 13982.46770, 13802.40331, & + 13519.33841, 13144.59486, 12689.45608, & + 12165.28766, 11583.57006, 10955.84778, & + 10293.60402, 9608.08306, 8910.07678, & + 8209.70131, 7516.18560, 6837.69250, & + 6181.19473, 5552.39653, 4955.72632, & + 4394.37629, 3870.38682, 3384.76586, & + 2937.63489, 2528.37666, 2155.78385, & + 1818.20722, 1513.68173, 1240.03585, & + 994.99144, 776.23591, 581.48797, & + 408.53400, 255.26520, 119.70243, 0. / + + data bk_sj/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00201, 0.00792, 0.01755, & + 0.03079, 0.04751, 0.06761, & + 0.09097, 0.11746, 0.14690, & + 0.17911, 0.21382, 0.25076, & + 0.28960, 0.32994, 0.37140, & + 0.41353, 0.45589, 0.49806, & + 0.53961, 0.58015, 0.61935, & + 0.65692, 0.69261, 0.72625, & + 0.75773, 0.78698, 0.81398, & + 0.83876, 0.86138, 0.88192, & + 0.90050, 0.91722, 0.93223, & + 0.94565, 0.95762, 0.96827, & + 0.97771, 0.98608, 0.99347, 1./ + + character(len=128) :: fname + real, allocatable:: wk2(:,:) + real(kind=4), allocatable:: wk2_r4(:,:) + real, dimension(:,:,:), allocatable:: ud, vd + real, allocatable:: wc(:,:,:) + real(kind=4), allocatable:: uec(:,:,:), vec(:,:,:), tec(:,:,:), wec(:,:,:) + real(kind=4), allocatable:: psec(:,:), zsec(:,:), zhec(:,:,:), qec(:,:,:,:) + real(kind=4), allocatable:: psc(:,:) + real(kind=4), allocatable:: sphumec(:,:,:) + real, allocatable:: psc_r8(:,:), zhc(:,:,:), qc(:,:,:,:) + real, allocatable:: lat(:), lon(:), ak0(:), bk0(:) + real, allocatable:: pt_c(:,:,:), pt_d(:,:,:) + real:: s2c(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,4) + real:: s2c_c(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je,4) + real:: s2c_d(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1,4) + integer, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: & + id1, id2, jdc + integer, dimension(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je):: & + id1_c, id2_c, jdc_c + integer, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1):: & + id1_d, id2_d, jdc_d + real:: utmp, vtmp + integer:: i, j, k, n, im, jm, km, npz, npt + integer:: i1, i2, j1, ncid + integer:: jbeg, jend, jn + integer tsize(3) + logical:: read_ts = .true. + logical:: land_ts = .false. + logical:: found + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel +#ifdef MULTI_GASES + integer :: spfo, spfo2, spfo3 +#else + integer :: o3mr +#endif + real:: wt, qt, m_fac + real(kind=8) :: scale_value, offset, ptmp + real(kind=R_GRID), dimension(2):: p1, p2, p3 + real(kind=R_GRID), dimension(3):: e1, e2, ex, ey + real, allocatable:: ps_gfs(:,:), zh_gfs(:,:,:) +#ifdef MULTI_GASES + real, allocatable:: spfo_gfs(:,:,:), spfo2_gfs(:,:,:), spfo3_gfs(:,:,:) +#else + real, allocatable:: o3mr_gfs(:,:,:) +#endif + real, allocatable:: ak_gfs(:), bk_gfs(:) + integer :: id_res, ntprog, ntracers, ks, iq, nt + character(len=64) :: tracer_name + integer :: levp_gfs = 64 + type (restart_file_type) :: ORO_restart, GFS_restart + character(len=64) :: fn_oro_ics = 'oro_data.nc' + character(len=64) :: fn_gfs_ics = 'gfs_data.nc' + character(len=64) :: fn_gfs_ctl = 'gfs_ctrl.nc' + logical :: filtered_terrain = .true. + namelist /external_ic_nml/ filtered_terrain + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + + deg2rad = pi/180. + + npz = Atm%npz + call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers, num_prog=ntprog) + if(is_master()) write(*,*) 'ntracers = ', ntracers, 'ntprog = ',ntprog + + sphum = get_tracer_index(MODEL_ATMOS, 'sphum') + liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') + ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') + rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') + snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') + graupel = get_tracer_index(MODEL_ATMOS, 'graupel') +#ifdef MULTI_GASES + spfo = get_tracer_index(MODEL_ATMOS, 'spfo') + spfo2 = get_tracer_index(MODEL_ATMOS, 'spfo2') + spfo3 = get_tracer_index(MODEL_ATMOS, 'spfo3') +#else + o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') +#endif + + if (is_master()) then + print *, 'sphum = ', sphum + print *, 'liq_wat = ', liq_wat + if ( Atm%flagstruct%nwat .eq. 6 ) then + print *, 'rainwat = ', rainwat + print *, 'iec_wat = ', ice_wat + print *, 'snowwat = ', snowwat + print *, 'graupel = ', graupel + endif +#ifdef MULTI_GASES + print *, ' spfo3 = ', spfo3 + print *, ' spfo = ', spfo + print *, ' spfo2 = ', spfo2 +#else + print *, ' o3mr = ', o3mr +#endif + endif + + +! Set up model's ak and bk + if (Atm%flagstruct%external_eta) then + call set_external_eta (Atm%ak, Atm%bk, Atm%ptop, Atm%ks) + endif + +!! Read in model terrain from oro_data.tile?.nc + if (filtered_terrain) then + id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_filt', Atm%phis, domain=Atm%domain) + elseif (.not. filtered_terrain) then + id_res = register_restart_field (ORO_restart, fn_oro_ics, 'orog_raw', Atm%phis, domain=Atm%domain) + endif + call restore_state (ORO_restart) + call free_restart_type(ORO_restart) + Atm%phis = Atm%phis*grav + if(is_master()) write(*,*) 'done reading model terrain from oro_data.nc' + call mpp_update_domains( Atm%phis, Atm%domain ) + +!! Read in o3mr, ps and zh from GFS_data.tile?.nc +#ifdef MULTI_GASES + allocate (spfo3_gfs(is:ie,js:je,levp_gfs)) + allocate ( spfo_gfs(is:ie,js:je,levp_gfs)) + allocate (spfo2_gfs(is:ie,js:je,levp_gfs)) +#else + allocate (o3mr_gfs(is:ie,js:je,levp_gfs)) +#endif + allocate (ps_gfs(is:ie,js:je)) + allocate (zh_gfs(is:ie,js:je,levp_gfs+1)) + +#ifdef MULTI_GASES + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'spfo3', spfo3_gfs, & + mandatory=.false.,domain=Atm%domain) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'spfo', spfo_gfs, & + mandatory=.false.,domain=Atm%domain) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'spfo2', spfo2_gfs, & + mandatory=.false.,domain=Atm%domain) +#else + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'o3mr', o3mr_gfs, & + mandatory=.false.,domain=Atm%domain) +#endif + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ps', ps_gfs, domain=Atm%domain) + id_res = register_restart_field (GFS_restart, fn_gfs_ics, 'ZH', zh_gfs, domain=Atm%domain) + call restore_state (GFS_restart) + call free_restart_type(GFS_restart) + + + ! Get GFS ak, bk for o3mr vertical interpolation + allocate (wk2(levp_gfs+1,2)) + allocate (ak_gfs(levp_gfs+1)) + allocate (bk_gfs(levp_gfs+1)) + call read_data('INPUT/'//trim(fn_gfs_ctl),'vcoord',wk2, no_domain=.TRUE.) + ak_gfs(1:levp_gfs+1) = wk2(1:levp_gfs+1,1) + bk_gfs(1:levp_gfs+1) = wk2(1:levp_gfs+1,2) + deallocate (wk2) + + if ( bk_gfs(1) < 1.E-9 ) ak_gfs(1) = max(1.e-9, ak_gfs(1)) + +#ifdef MULTI_GASES + iq = spfo3 + if(is_master()) write(*,*) 'Reading spfo3 from GFS_data.nc:' + if(is_master()) write(*,*) 'spfo3 =', iq + call remap_scalar_single(Atm, levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, spfo3_gfs, zh_gfs, iq) + iq = spfo + if(is_master()) write(*,*) 'Reading spfo from GFS_data.nc:' + if(is_master()) write(*,*) 'spfo =', iq + call remap_scalar_single(Atm, levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, spfo_gfs, zh_gfs, iq) + iq = spfo2 + if(is_master()) write(*,*) 'Reading spfo2 from GFS_data.nc:' + if(is_master()) write(*,*) 'spfo2 =', iq + call remap_scalar_single(Atm, levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, spfo2_gfs, zh_gfs, iq) +#else + iq = o3mr + if(is_master()) write(*,*) 'Reading o3mr from GFS_data.nc:' + if(is_master()) write(*,*) 'o3mr =', iq + call remap_scalar_single(Atm, levp_gfs, npz, ak_gfs, bk_gfs, ps_gfs, o3mr_gfs, zh_gfs, iq) +#endif + + deallocate (ak_gfs, bk_gfs) + deallocate (ps_gfs, zh_gfs) +#ifdef MULTI_GASES + deallocate (spfo3_gfs) + deallocate ( spfo_gfs) + deallocate (spfo2_gfs) +#else + deallocate (o3mr_gfs) +#endif + +!! Start to read EC data + fname = Atm%flagstruct%res_latlon_dynamics + + if( file_exist(fname) ) then + call open_ncfile( fname, ncid ) ! open the file + + call get_ncdim1( ncid, 'longitude', tsize(1) ) + call get_ncdim1( ncid, 'latitude', tsize(2) ) + call get_ncdim1( ncid, 'level', tsize(3) ) + + im = tsize(1); jm = tsize(2); km = tsize(3) + + if(is_master()) write(*,*) fname + if(is_master()) write(*,*) ' ECMWF IC dimensions:', tsize + + allocate ( lon(im) ) + allocate ( lat(jm) ) + + call _GET_VAR1(ncid, 'longitude', im, lon ) + call _GET_VAR1(ncid, 'latitude', jm, lat ) + +!! Convert to radian + do i = 1, im + lon(i) = lon(i) * deg2rad ! lon(1) = 0. + enddo + do j = 1, jm + lat(j) = lat(j) * deg2rad + enddo + + allocate ( ak0(km+1) ) + allocate ( bk0(km+1) ) + +! The ECMWF data from does not contain (ak,bk) + do k=1, km+1 + ak0(k) = ak_ec(k) + bk0(k) = bk_ec(k) + enddo + + if( is_master() ) then + do k=1,km+1 + write(*,*) k, ak0(k), bk0(k) + enddo + endif + +! Limiter to prevent NAN at top during remapping + if ( bk0(1) < 1.E-9 ) ak0(1) = max(1.e-9, ak0(1)) + + else + call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for NCEP IC does not exist') + endif + +! Initialize lat-lon to Cubed bi-linear interpolation coeff: + call remap_coef( is, ie, js, je, isd, ied, jsd, jed, & + im, jm, lon, lat, id1, id2, jdc, s2c , Atm%gridstruct%agrid ) + +! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je + do i=is,ie + j1 = jdc(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + if(is_master()) write(*,*) 'jbeg, jend = ', jbeg, jend +! read in surface pressure and height: + allocate ( psec(im,jbeg:jend) ) + allocate ( zsec(im,jbeg:jend) ) + allocate ( wk2_r4(im,jbeg:jend) ) + + call get_var2_r4( ncid, 'lnsp', 1,im, jbeg,jend, wk2_r4 ) + call get_var_att_double ( ncid, 'lnsp', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'lnsp', 'add_offset', offset ) + psec(:,:) = exp(wk2_r4(:,:)*scale_value + offset) + if(is_master()) write(*,*) 'done reading psec' + + call get_var2_r4( ncid, 'z', 1,im, jbeg,jend, wk2_r4 ) + call get_var_att_double ( ncid, 'z', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'z', 'add_offset', offset ) + zsec(:,:) = (wk2_r4(:,:)*scale_value + offset)/grav + if(is_master()) write(*,*) 'done reading zsec' + + deallocate ( wk2_r4 ) + +! Read in temperature: + allocate ( tec(1:im,jbeg:jend, 1:km) ) + + call get_var3_r4( ncid, 't', 1,im, jbeg,jend, 1,km, tec ) + call get_var_att_double ( ncid, 't', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 't', 'add_offset', offset ) + tec(:,:,:) = tec(:,:,:)*scale_value + offset + if(is_master()) write(*,*) 'done reading tec' + +! read in specific humidity: + allocate ( sphumec(1:im,jbeg:jend, 1:km) ) + + call get_var3_r4( ncid, 'q', 1,im, jbeg,jend, 1,km, sphumec(:,:,:) ) + call get_var_att_double ( ncid, 'q', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'q', 'add_offset', offset ) + sphumec(:,:,:) = sphumec(:,:,:)*scale_value + offset + if(is_master()) write(*,*) 'done reading sphum ec' + +! Read in other tracers from EC data and remap them into cubic sphere grid: + allocate ( qec(1:im,jbeg:jend,1:km,5) ) + + do n = 1, 5 + if (n == sphum) then + qec(:,:,:,sphum) = sphumec(:,:,:) + deallocate ( sphumec ) + else if (n == liq_wat) then + call get_var3_r4( ncid, 'clwc', 1,im, jbeg,jend, 1,km, qec(:,:,:,liq_wat) ) + call get_var_att_double ( ncid, 'clwc', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'clwc', 'add_offset', offset ) + qec(:,:,:,liq_wat) = qec(:,:,:,liq_wat)*scale_value + offset + if(is_master()) write(*,*) 'done reading clwc ec' + else if (n == rainwat) then + call get_var3_r4( ncid, 'crwc', 1,im, jbeg,jend, 1,km, qec(:,:,:,rainwat) ) + call get_var_att_double ( ncid, 'crwc', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'crwc', 'add_offset', offset ) + qec(:,:,:,rainwat) = qec(:,:,:,rainwat)*scale_value + offset + if(is_master()) write(*,*) 'done reading crwc ec' + else if (n == ice_wat) then + call get_var3_r4( ncid, 'ciwc', 1,im, jbeg,jend, 1,km, qec(:,:,:,ice_wat) ) + call get_var_att_double ( ncid, 'ciwc', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'ciwc', 'add_offset', offset ) + qec(:,:,:,ice_wat) = qec(:,:,:,ice_wat)*scale_value + offset + if(is_master()) write(*,*) 'done reading ciwc ec' + else if (n == snowwat) then + call get_var3_r4( ncid, 'cswc', 1,im, jbeg,jend, 1,km, qec(:,:,:,snowwat) ) + call get_var_att_double ( ncid, 'cswc', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'cswc', 'add_offset', offset ) + qec(:,:,:,snowwat) = qec(:,:,:,snowwat)*scale_value + offset + if(is_master()) write(*,*) 'done reading cswc ec' + else + if(is_master()) write(*,*) 'nq is more then 5!' + endif + + enddo + + +!!!! Compute height on edges, zhec [ use psec, zsec, tec, sphum] + allocate ( zhec(1:im,jbeg:jend, km+1) ) + jn = jend - jbeg + 1 + + call compute_zh(im, jn, km, ak0, bk0, psec, zsec, tec, qec, 5, zhec ) + if(is_master()) write(*,*) 'done compute zhec' + deallocate ( zsec ) + deallocate ( tec ) + +! convert zhec, psec from EC grid to cubic grid + allocate (psc(is:ie,js:je)) + allocate (psc_r8(is:ie,js:je)) + +#ifdef LOGP_INTP + do j=jbeg,jend + do i=1,im + psec(i,j) = log(psec(i,j)) + enddo + enddo +#endif + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) +#ifdef LOGP_INTP + ptmp = s2c(i,j,1)*psec(i1,j1 ) + s2c(i,j,2)*psec(i2,j1 ) + & + s2c(i,j,3)*psec(i2,j1+1) + s2c(i,j,4)*psec(i1,j1+1) + psc(i,j) = exp(ptmp) +#else + psc(i,j) = s2c(i,j,1)*psec(i1,j1 ) + s2c(i,j,2)*psec(i2,j1 ) + & + s2c(i,j,3)*psec(i2,j1+1) + s2c(i,j,4)*psec(i1,j1+1) +#endif + enddo + enddo + deallocate ( psec ) + + allocate (zhc(is:ie,js:je,km+1)) +!$OMP parallel do default(none) shared(is,ie,js,je,km,s2c,id1,id2,jdc,zhc,zhec) & +!$OMP private(i1,i2,j1) + do k=1,km+1 + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + zhc(i,j,k) = s2c(i,j,1)*zhec(i1,j1 ,k) + s2c(i,j,2)*zhec(i2,j1 ,k) + & + s2c(i,j,3)*zhec(i2,j1+1,k) + s2c(i,j,4)*zhec(i1,j1+1,k) + enddo + enddo + enddo + deallocate ( zhec ) + + if(is_master()) write(*,*) 'done interpolate psec/zhec into cubic grid psc/zhc!' + +! Read in other tracers from EC data and remap them into cubic sphere grid: + allocate ( qc(is:ie,js:je,km,6) ) + + do n = 1, 5 +!$OMP parallel do default(none) shared(n,is,ie,js,je,km,s2c,id1,id2,jdc,qc,qec) & +!$OMP private(i1,i2,j1) + do k=1,km + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + qc(i,j,k,n) = s2c(i,j,1)*qec(i1,j1 ,k,n) + s2c(i,j,2)*qec(i2,j1 ,k,n) + & + s2c(i,j,3)*qec(i2,j1+1,k,n) + s2c(i,j,4)*qec(i1,j1+1,k,n) + enddo + enddo + enddo + enddo + + qc(:,:,:,graupel) = 0. ! note Graupel must be tracer #6 + + deallocate ( qec ) + if(is_master()) write(*,*) 'done interpolate tracers (qec) into cubic (qc)' + +! Read in vertical wind from EC data and remap them into cubic sphere grid: + allocate ( wec(1:im,jbeg:jend, 1:km) ) + allocate ( wc(is:ie,js:je,km)) + + call get_var3_r4( ncid, 'w', 1,im, jbeg,jend, 1,km, wec ) + call get_var_att_double ( ncid, 'w', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'w', 'add_offset', offset ) + wec(:,:,:) = wec(:,:,:)*scale_value + offset + !call p_maxmin('wec', wec, 1, im, jbeg, jend, km, 1.) + +!$OMP parallel do default(none) shared(is,ie,js,je,km,id1,id2,jdc,s2c,wc,wec) & +!$OMP private(i1,i2,j1) + do k=1,km + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + wc(i,j,k) = s2c(i,j,1)*wec(i1,j1 ,k) + s2c(i,j,2)*wec(i2,j1 ,k) + & + s2c(i,j,3)*wec(i2,j1+1,k) + s2c(i,j,4)*wec(i1,j1+1,k) + enddo + enddo + enddo + !call p_maxmin('wc', wc, is, ie, js, je, km, 1.) + + deallocate ( wec ) + if(is_master()) write(*,*) 'done reading and interpolate vertical wind (w) into cubic' + +! remap tracers + psc_r8(:,:) = psc(:,:) + deallocate ( psc ) + + call remap_scalar(Atm, km, npz, 6, ak0, bk0, psc_r8, qc, zhc, wc) + call mpp_update_domains(Atm%phis, Atm%domain) + if(is_master()) write(*,*) 'done remap_scalar' + + deallocate ( zhc ) + deallocate ( wc ) + deallocate ( qc ) + +!! Winds: + ! get lat/lon values of pt_c and pt_d from grid data (pt_b) + allocate (pt_c(isd:ied+1,jsd:jed ,2)) + allocate (pt_d(isd:ied ,jsd:jed+1,2)) + allocate (ud(is:ie , js:je+1, km)) + allocate (vd(is:ie+1, js:je , km)) + + call get_staggered_grid( is, ie, js, je, & + isd, ied, jsd, jed, & + Atm%gridstruct%grid, pt_c, pt_d) + + !------ pt_c part ------ + ! Initialize lat-lon to Cubed bi-linear interpolation coeff: + call remap_coef( is, ie+1, js, je, isd, ied+1, jsd, jed, & + im, jm, lon, lat, id1_c, id2_c, jdc_c, s2c_c, pt_c) + + ! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je + do i=is,ie+1 + j1 = jdc_c(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + ! read in EC wind data + allocate ( uec(1:im,jbeg:jend, 1:km) ) + allocate ( vec(1:im,jbeg:jend, 1:km) ) + + call get_var3_r4( ncid, 'u', 1,im, jbeg,jend, 1,km, uec ) + call get_var_att_double ( ncid, 'u', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'u', 'add_offset', offset ) + do k=1,km + do j=jbeg, jend + do i=1,im + uec(i,j,k) = uec(i,j,k)*scale_value + offset + enddo + enddo + enddo + if(is_master()) write(*,*) 'first time done reading uec' + + call get_var3_r4( ncid, 'v', 1,im, jbeg,jend, 1,km, vec ) + call get_var_att_double ( ncid, 'v', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'v', 'add_offset', offset ) + do k=1,km + do j=jbeg, jend + do i=1,im + vec(i,j,k) = vec(i,j,k)*scale_value + offset + enddo + enddo + enddo + + if(is_master()) write(*,*) 'first time done reading vec' + +!$OMP parallel do default(none) shared(is,ie,js,je,km,s2c_c,id1_c,id2_c,jdc_c,uec,vec,Atm,vd) & +!$OMP private(i1,i2,j1,p1,p2,p3,e2,ex,ey,utmp,vtmp) + do k=1,km + do j=js,je + do i=is,ie+1 + i1 = id1_c(i,j) + i2 = id2_c(i,j) + j1 = jdc_c(i,j) + p1(:) = Atm%gridstruct%grid(i,j ,1:2) + p2(:) = Atm%gridstruct%grid(i,j+1,1:2) + call mid_pt_sphere(p1, p2, p3) + call get_unit_vect2(p1, p2, e2) + call get_latlon_vector(p3, ex, ey) + utmp = s2c_c(i,j,1)*uec(i1,j1 ,k) + & + s2c_c(i,j,2)*uec(i2,j1 ,k) + & + s2c_c(i,j,3)*uec(i2,j1+1,k) + & + s2c_c(i,j,4)*uec(i1,j1+1,k) + vtmp = s2c_c(i,j,1)*vec(i1,j1 ,k) + & + s2c_c(i,j,2)*vec(i2,j1 ,k) + & + s2c_c(i,j,3)*vec(i2,j1+1,k) + & + s2c_c(i,j,4)*vec(i1,j1+1,k) + vd(i,j,k) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey) + enddo + enddo + enddo + + deallocate ( uec, vec ) + + !------ pt_d part ------ + ! Initialize lat-lon to Cubed bi-linear interpolation coeff: + call remap_coef( is, ie, js, je+1, isd, ied, jsd, jed+1, & + im, jm, lon, lat, id1_d, id2_d, jdc_d, s2c_d, pt_d) + deallocate ( pt_c, pt_d ) + + ! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je+1 + do i=is,ie + j1 = jdc_d(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + ! read in EC wind data + allocate ( uec(1:im,jbeg:jend, 1:km) ) + allocate ( vec(1:im,jbeg:jend, 1:km) ) + + call get_var3_r4( ncid, 'u', 1,im, jbeg,jend, 1,km, uec ) + call get_var_att_double ( ncid, 'u', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'u', 'add_offset', offset ) + uec(:,:,:) = uec(:,:,:)*scale_value + offset + if(is_master()) write(*,*) 'second time done reading uec' + + call get_var3_r4( ncid, 'v', 1,im, jbeg,jend, 1,km, vec ) + call get_var_att_double ( ncid, 'v', 'scale_factor', scale_value ) + call get_var_att_double ( ncid, 'v', 'add_offset', offset ) + vec(:,:,:) = vec(:,:,:)*scale_value + offset + if(is_master()) write(*,*) 'second time done reading vec' + +!$OMP parallel do default(none) shared(is,ie,js,je,km,id1_d,id2_d,jdc_d,s2c_d,uec,vec,Atm,ud) & +!$OMP private(i1,i2,j1,p1,p2,p3,e1,ex,ey,utmp,vtmp) + do k=1,km + do j=js,je+1 + do i=is,ie + i1 = id1_d(i,j) + i2 = id2_d(i,j) + j1 = jdc_d(i,j) + p1(:) = Atm%gridstruct%grid(i, j,1:2) + p2(:) = Atm%gridstruct%grid(i+1,j,1:2) + call mid_pt_sphere(p1, p2, p3) + call get_unit_vect2(p1, p2, e1) + call get_latlon_vector(p3, ex, ey) + utmp = s2c_d(i,j,1)*uec(i1,j1 ,k) + & + s2c_d(i,j,2)*uec(i2,j1 ,k) + & + s2c_d(i,j,3)*uec(i2,j1+1,k) + & + s2c_d(i,j,4)*uec(i1,j1+1,k) + vtmp = s2c_d(i,j,1)*vec(i1,j1 ,k) + & + s2c_d(i,j,2)*vec(i2,j1 ,k) + & + s2c_d(i,j,3)*vec(i2,j1+1,k) + & + s2c_d(i,j,4)*vec(i1,j1+1,k) + ud(i,j,k) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey) + enddo + enddo + enddo + deallocate ( uec, vec ) + + call remap_dwinds(km, npz, ak0, bk0, psc_r8, ud, vd, Atm) + deallocate ( ud, vd ) + +#ifndef COND_IFS_IC +! Add cloud condensate from IFS to total MASS +! Adjust the mixing ratios consistently... + do k=1,npz + do j=js,je + do i=is,ie + wt = Atm%delp(i,j,k) + if ( Atm%flagstruct%nwat .eq. 2 ) then + qt = wt*(1.+Atm%q(i,j,k,liq_wat)) + elseif ( Atm%flagstruct%nwat .eq. 6 ) then + qt = wt*(1. + Atm%q(i,j,k,liq_wat) + & + Atm%q(i,j,k,ice_wat) + & + Atm%q(i,j,k,rainwat) + & + Atm%q(i,j,k,snowwat) + & + Atm%q(i,j,k,graupel)) + endif + m_fac = wt / qt + do iq=1,ntracers + Atm%q(i,j,k,iq) = m_fac * Atm%q(i,j,k,iq) + enddo + Atm%delp(i,j,k) = qt + enddo + enddo + enddo +#endif + + deallocate ( ak0, bk0 ) +! deallocate ( psc ) + deallocate ( psc_r8 ) + deallocate ( lat, lon ) + + Atm%flagstruct%make_nh = .false. + + end subroutine get_ecmwf_ic +!------------------------------------------------------------------ +!------------------------------------------------------------------ + subroutine get_fv_ic( Atm, fv_domain, nq ) + type(fv_atmos_type), intent(inout) :: Atm + type(domain2d), intent(inout) :: fv_domain + integer, intent(in):: nq + + character(len=128) :: fname, tracer_name + real, allocatable:: ps0(:,:), gz0(:,:), u0(:,:,:), v0(:,:,:), t0(:,:,:), dp0(:,:,:), q0(:,:,:,:) + real, allocatable:: ua(:,:,:), va(:,:,:) + real, allocatable:: lat(:), lon(:), ak0(:), bk0(:) + integer :: i, j, k, im, jm, km, npz, tr_ind + integer tsize(3) +! integer sphum, liq_wat, ice_wat, cld_amt ! GFDL AM2 physics + logical found + + npz = Atm%npz + +! Zero out all initial tracer fields: + Atm%q = 0. + +! Read in lat-lon FV core restart file + fname = Atm%flagstruct%res_latlon_dynamics + + if( file_exist(fname) ) then + call field_size(fname, 'T', tsize, field_found=found) + if(is_master()) write(*,*) 'Using lat-lon FV restart:', fname + + if ( found ) then + im = tsize(1); jm = tsize(2); km = tsize(3) + if(is_master()) write(*,*) 'External IC dimensions:', tsize + else + call mpp_error(FATAL,'==> Error in get_external_ic: field not found') + endif + +! Define the lat-lon coordinate: + allocate ( lon(im) ) + allocate ( lat(jm) ) + + do i=1,im + lon(i) = (0.5 + real(i-1)) * 2.*pi/real(im) + enddo + + do j=1,jm + lat(j) = -0.5*pi + real(j-1)*pi/real(jm-1) ! SP to NP + enddo + + allocate ( ak0(1:km+1) ) + allocate ( bk0(1:km+1) ) + allocate ( ps0(1:im,1:jm) ) + allocate ( gz0(1:im,1:jm) ) + allocate ( u0(1:im,1:jm,1:km) ) + allocate ( v0(1:im,1:jm,1:km) ) + allocate ( t0(1:im,1:jm,1:km) ) + allocate ( dp0(1:im,1:jm,1:km) ) + + call read_data (fname, 'ak', ak0) + call read_data (fname, 'bk', bk0) + call read_data (fname, 'Surface_geopotential', gz0) + call read_data (fname, 'U', u0) + call read_data (fname, 'V', v0) + call read_data (fname, 'T', t0) + call read_data (fname, 'DELP', dp0) + +! Share the load + if(is_master()) call pmaxmin( 'ZS_data', gz0, im, jm, 1./grav) + if(mpp_pe()==1) call pmaxmin( 'U_data', u0, im*jm, km, 1.) + if(mpp_pe()==1) call pmaxmin( 'V_data', v0, im*jm, km, 1.) + if(mpp_pe()==2) call pmaxmin( 'T_data', t0, im*jm, km, 1.) + if(mpp_pe()==3) call pmaxmin( 'DEL-P', dp0, im*jm, km, 0.01) + + + else + call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for dynamics does not exist') + endif + +! Read in tracers: only AM2 "physics tracers" at this point + fname = Atm%flagstruct%res_latlon_tracers + + if( file_exist(fname) ) then + if(is_master()) write(*,*) 'Using lat-lon tracer restart:', fname + + allocate ( q0(im,jm,km,Atm%ncnst) ) + q0 = 0. + + do tr_ind = 1, nq + call get_tracer_names(MODEL_ATMOS, tr_ind, tracer_name) + if (field_exist(fname,tracer_name)) then + call read_data(fname, tracer_name, q0(1:im,1:jm,1:km,tr_ind)) + call mpp_error(NOTE,'==> Have read tracer '//trim(tracer_name)//' from '//trim(fname)) + cycle + endif + enddo + else + call mpp_error(FATAL,'==> Error in get_external_ic: Expected file '//trim(fname)//' for tracers does not exist') + endif + +! D to A transform on lat-lon grid: + allocate ( ua(im,jm,km) ) + allocate ( va(im,jm,km) ) + + call d2a3d(u0, v0, ua, va, im, jm, km, lon) + + deallocate ( u0 ) + deallocate ( v0 ) + + if(mpp_pe()==4) call pmaxmin( 'UA', ua, im*jm, km, 1.) + if(mpp_pe()==4) call pmaxmin( 'VA', va, im*jm, km, 1.) + + do j=1,jm + do i=1,im + ps0(i,j) = ak0(1) + enddo + enddo + + do k=1,km + do j=1,jm + do i=1,im + ps0(i,j) = ps0(i,j) + dp0(i,j,k) + enddo + enddo + enddo + + if (is_master()) call pmaxmin( 'PS_data (mb)', ps0, im, jm, 0.01) + +! Horizontal interpolation to the cubed sphere grid center +! remap vertically with terrain adjustment + + call remap_xyz( im, 1, jm, jm, km, npz, nq, Atm%ncnst, lon, lat, ak0, bk0, & + ps0, gz0, ua, va, t0, q0, Atm ) + + deallocate ( ak0 ) + deallocate ( bk0 ) + deallocate ( ps0 ) + deallocate ( gz0 ) + deallocate ( t0 ) + deallocate ( q0 ) + deallocate ( dp0 ) + deallocate ( ua ) + deallocate ( va ) + deallocate ( lat ) + deallocate ( lon ) + + end subroutine get_fv_ic +!------------------------------------------------------------------ +!------------------------------------------------------------------ +#ifndef DYCORE_SOLO + subroutine ncep2fms(im, jm, lon, lat, wk) + + integer, intent(in):: im, jm + real, intent(in):: lon(im), lat(jm) + real(kind=4), intent(in):: wk(im,jm) +! local: + real :: rdlon(im) + real :: rdlat(jm) + real:: a1, b1 + real:: delx, dely + real:: xc, yc ! "data" location + real:: c1, c2, c3, c4 + integer i,j, i1, i2, jc, i0, j0, it, jt + + do i=1,im-1 + rdlon(i) = 1. / (lon(i+1) - lon(i)) + enddo + rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) + + do j=1,jm-1 + rdlat(j) = 1. / (lat(j+1) - lat(j)) + enddo + +! * Interpolate to "FMS" 1x1 SST data grid +! lon: 0.5, 1.5, ..., 359.5 +! lat: -89.5, -88.5, ... , 88.5, 89.5 + + delx = 360./real(i_sst) + dely = 180./real(j_sst) + + jt = 1 + do 5000 j=1,j_sst + + yc = (-90. + dely * (0.5+real(j-1))) * deg2rad + if ( yclat(jm) ) then + jc = jm-1 + b1 = 1. + else + do j0=jt,jm-1 + if ( yc>=lat(j0) .and. yc<=lat(j0+1) ) then + jc = j0 + jt = j0 + b1 = (yc-lat(jc)) * rdlat(jc) + go to 222 + endif + enddo + endif +222 continue + it = 1 + + do i=1,i_sst + xc = delx * (0.5+real(i-1)) * deg2rad + if ( xc>lon(im) ) then + i1 = im; i2 = 1 + a1 = (xc-lon(im)) * rdlon(im) + elseif ( xc=lon(i0) .and. xc<=lon(i0+1) ) then + i1 = i0; i2 = i0+1 + it = i0 + a1 = (xc-lon(i1)) * rdlon(i0) + go to 111 + endif + enddo + endif +111 continue + + if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then + write(*,*) 'gid=', mpp_pe(), i,j,a1, b1 + endif + + c1 = (1.-a1) * (1.-b1) + c2 = a1 * (1.-b1) + c3 = a1 * b1 + c4 = (1.-a1) * b1 +! Interpolated surface pressure + sst_ncep(i,j) = c1*wk(i1,jc ) + c2*wk(i2,jc ) + & + c3*wk(i2,jc+1) + c4*wk(i1,jc+1) + enddo !i-loop +5000 continue ! j-loop + + end subroutine ncep2fms +#endif + + + subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & + im, jm, lon, lat, id1, id2, jdc, s2c, agrid ) + + integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed + integer, intent(in):: im, jm + real, intent(in):: lon(im), lat(jm) + real, intent(out):: s2c(is:ie,js:je,4) + integer, intent(out), dimension(is:ie,js:je):: id1, id2, jdc + real, intent(in):: agrid(isd:ied,jsd:jed,2) +! local: + real :: rdlon(im) + real :: rdlat(jm) + real:: a1, b1 + integer i,j, i1, i2, jc, i0, j0 + + do i=1,im-1 + rdlon(i) = 1. / (lon(i+1) - lon(i)) + enddo + rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) + + do j=1,jm-1 + rdlat(j) = 1. / (lat(j+1) - lat(j)) + enddo + +! * Interpolate to cubed sphere cell center + do 5000 j=js,je + + do i=is,ie + + if ( agrid(i,j,1)>lon(im) ) then + i1 = im; i2 = 1 + a1 = (agrid(i,j,1)-lon(im)) * rdlon(im) + elseif ( agrid(i,j,1)=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then + i1 = i0; i2 = i0+1 + a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0) + go to 111 + endif + enddo + endif +111 continue + + if ( agrid(i,j,2)lat(jm) ) then + jc = jm-1 + b1 = 1. + else + do j0=1,jm-1 + if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then + jc = j0 + b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc) + go to 222 + endif + enddo + endif +222 continue + + if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then + write(*,*) 'gid=', mpp_pe(), i,j,a1, b1 + endif + + s2c(i,j,1) = (1.-a1) * (1.-b1) + s2c(i,j,2) = a1 * (1.-b1) + s2c(i,j,3) = a1 * b1 + s2c(i,j,4) = (1.-a1) * b1 + id1(i,j) = i1 + id2(i,j) = i2 + jdc(i,j) = jc + enddo !i-loop +5000 continue ! j-loop + + end subroutine remap_coef + + + subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) + type(fv_atmos_type), intent(inout) :: Atm + integer, intent(in):: km, npz, ncnst + real, intent(in):: ak0(km+1), bk0(km+1) + real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: psc + real, intent(in), optional, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: omga, t_in + real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km,ncnst):: qa + real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km+1):: zh +! local: + real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0 + real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1, dp2 + real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1 + real qp(Atm%bd%is:Atm%bd%ie,km) + real wk(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) + real, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: z500 +!!! High-precision + real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pn1 + real(kind=R_GRID):: gz_fv(npz+1) + real(kind=R_GRID), dimension(2*km+1):: gz, pn + real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,km+1):: pn0 + real(kind=R_GRID):: pst +!!! High-precision + integer i,j,k,l,m, k2,iq + integer sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt, liq_aero, ice_aero +#ifdef MULTI_GASES + integer spfo, spfo2, spfo3 +#else + integer o3mr +#endif + integer :: is, ie, js, je + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + + sphum = get_tracer_index(MODEL_ATMOS, 'sphum') + liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') + ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') + rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') + snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') + graupel = get_tracer_index(MODEL_ATMOS, 'graupel') + cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') +#ifdef MULTI_GASES + spfo = get_tracer_index(MODEL_ATMOS, 'spfo') + spfo2 = get_tracer_index(MODEL_ATMOS, 'spfo2') + spfo3 = get_tracer_index(MODEL_ATMOS, 'spfo3') +#else + o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') +#endif + liq_aero = get_tracer_index(MODEL_ATMOS, 'liq_aero') + ice_aero = get_tracer_index(MODEL_ATMOS, 'ice_aero') + + k2 = max(10, km/2) + + if (mpp_pe()==1) then + print *, 'In remap_scalar:' + print *, 'ncnst = ', ncnst + print *, 'nwat = ', Atm%flagstruct%nwat + print *, 'sphum = ', sphum + print *, 'clwmr = ', liq_wat +#ifdef MULTI_GASES + print *, 'spfo3 = ', spfo3 + print *, ' spfo = ', spfo + print *, 'spfo2 = ', spfo2 +#else + print *, ' o3mr = ', o3mr +#endif + print *, 'liq_aero = ', liq_aero + print *, 'ice_aero = ', ice_aero + if ( Atm%flagstruct%nwat .eq. 6 ) then + print *, 'rainwat = ', rainwat + print *, 'ice_wat = ', ice_wat + print *, 'snowwat = ', snowwat + print *, 'graupel = ', graupel + endif + endif + + if ( sphum/=1 ) then + call mpp_error(FATAL,'SPHUM must be 1st tracer') + endif + +#ifdef USE_GFS_ZS + Atm%phis(is:ie,js:je) = zh(is:ie,js:je,km+1)*grav +#endif + + if (Atm%flagstruct%ecmwf_ic) then + if (cld_amt .gt. 0) Atm%q(i,j,k,cld_amt) = 0. + endif + +!$OMP parallel do default(none) & +!$OMP shared(sphum,liq_wat,rainwat,ice_wat,snowwat,graupel,liq_aero,ice_aero,source, & +!$OMP cld_amt,ncnst,npz,is,ie,js,je,km,k2,ak0,bk0,psc,t_in,zh,omga,qa,Atm,z500) & +!$OMP private(l,m,pst,pn,gz,pe0,pn0,pe1,pn1,dp2,qp,qn1,gz_fv) + do 5000 j=js,je + do k=1,km+1 + do i=is,ie + pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) + pn0(i,k) = log(pe0(i,k)) + enddo + enddo + + do i=is,ie + do k=1,km+1 + pn(k) = pn0(i,k) + gz(k) = zh(i,j,k)*grav + enddo +! Use log-p for interpolation/extrapolation +! mirror image method: + do k=km+2, km+k2 + l = 2*(km+1) - k + gz(k) = 2.*gz(km+1) - gz(l) + pn(k) = 2.*pn(km+1) - pn(l) + enddo + + do k=km+k2-1, 2, -1 + if( Atm%phis(i,j).le.gz(k) .and. Atm%phis(i,j).ge.gz(k+1) ) then + pst = pn(k) + (pn(k+1)-pn(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) + go to 123 + endif + enddo +123 Atm%ps(i,j) = exp(pst) + +! ------------------ +! Find 500-mb height +! ------------------ + pst = log(500.e2) + do k=km+k2-1, 2, -1 + if( pst.le.pn(k+1) .and. pst.ge.pn(k) ) then + z500(i,j) = (gz(k+1) + (gz(k)-gz(k+1))*(pn(k+1)-pst)/(pn(k+1)-pn(k)))/grav + go to 124 + endif + enddo +124 continue + + enddo ! i-loop + + do i=is,ie + pe1(i,1) = Atm%ak(1) + pn1(i,1) = log(pe1(i,1)) + enddo + do k=2,npz+1 + do i=is,ie + pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) + pn1(i,k) = log(pe1(i,k)) + enddo + enddo + +! * Compute delp + do k=1,npz + do i=is,ie + dp2(i,k) = pe1(i,k+1) - pe1(i,k) + Atm%delp(i,j,k) = dp2(i,k) + enddo + enddo + +! map tracers + do iq=1,ncnst + if (floor(qa(is,j,1,iq)) > -999) then !skip missing scalars + do k=1,km + do i=is,ie + qp(i,k) = qa(i,j,k,iq) + enddo + enddo + call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop) + if ( iq==sphum ) then + call fillq(ie-is+1, npz, 1, qn1, dp2) + else + call fillz(ie-is+1, npz, 1, qn1, dp2) + endif + ! The HiRam step of blending model sphum with NCEP data is obsolete because nggps is always cold starting... + do k=1,npz + do i=is,ie + Atm%q(i,j,k,iq) = qn1(i,k) + enddo + enddo + endif + enddo + +!--------------------------------------------------- +! Retrive temperature using geopotential height from external data +!--------------------------------------------------- + do i=is,ie +! Make sure FV3 top is lower than GFS; can not do extrapolation above the top at this point + if ( pn1(i,1) .lt. pn0(i,1) ) then + call mpp_error(FATAL,'FV3 top higher than external data') + endif + + do k=1,km+1 + pn(k) = pn0(i,k) + gz(k) = zh(i,j,k)*grav + enddo +!------------------------------------------------- + do k=km+2, km+k2 + l = 2*(km+1) - k + gz(k) = 2.*gz(km+1) - gz(l) + pn(k) = 2.*pn(km+1) - pn(l) + enddo +!------------------------------------------------- + + gz_fv(npz+1) = Atm%phis(i,j) + + m = 1 + + do k=1,npz +! Searching using FV3 log(pe): pn1 +#ifdef USE_ISOTHERMO + do l=m,km + if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then + gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) + goto 555 + elseif ( pn1(i,k) .gt. pn(km+1) ) then +! Isothermal under ground; linear in log-p extra-polation + gz_fv(k) = gz(km+1) + (gz_fv(npz+1)-gz(km+1))*(pn1(i,k)-pn(km+1))/(pn1(i,npz+1)-pn(km+1)) + goto 555 + endif + enddo +#else + do l=m,km+k2-1 + if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then + gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) + goto 555 + endif + enddo +#endif +555 m = l + enddo + + do k=1,npz+1 + Atm%peln(i,k,j) = pn1(i,k) + enddo + +!---------------------------------------------------- +! Compute true temperature using hydrostatic balance +!---------------------------------------------------- + if (trim(source) /= source_fv3gfs .or. .not. present(t_in)) then + do k=1,npz +#ifdef MULTI_GASES + Atm%pt(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*virq(Atm%q(i,j,k,:)) ) +#else + Atm%pt(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*(1.+zvir*Atm%q(i,j,k,sphum)) ) +#endif + enddo +!------------------------------ +! Remap input T logarithmically in p. +!------------------------------ + else + do k=1,km + qp(i,k) = t_in(i,j,k) + enddo + + call mappm(km, log(pe0), qp, npz, log(pe1), qn1, is,ie, 2, 4, Atm%ptop) ! pn0 and pn1 are higher-precision + ! and cannot be passed to mappm + do k=1,npz + Atm%pt(i,j,k) = qn1(i,k) + enddo + endif + + if ( .not. Atm%flagstruct%hydrostatic ) then + do k=1,npz + Atm%delz(i,j,k) = (gz_fv(k+1) - gz_fv(k)) / grav + enddo + endif + + enddo ! i-loop + +!----------------------------------------------------------------------- +! seperate cloud water and cloud ice from Jan-Huey Chen's HiRAM code +! only use for NCEP IC and GFDL microphy +!----------------------------------------------------------------------- + if (trim(source) /= source_fv3gfs) then + if ((Atm%flagstruct%nwat .eq. 3 .or. Atm%flagstruct%nwat .eq. 6) .and. & + (Atm%flagstruct%ncep_ic .or. Atm%flagstruct%nggps_ic)) then + do k=1,npz + do i=is,ie + + qn1(i,k) = Atm%q(i,j,k,liq_wat) + if (cld_amt .gt. 0) Atm%q(i,j,k,cld_amt) = 0. + + if ( Atm%pt(i,j,k) > 273.16 ) then ! > 0C all liq_wat + Atm%q(i,j,k,liq_wat) = qn1(i,k) + Atm%q(i,j,k,ice_wat) = 0. +#ifdef ORIG_CLOUDS_PART + else if ( Atm%pt(i,j,k) < 258.16 ) then ! < -15C all ice_wat + Atm%q(i,j,k,liq_wat) = 0. + Atm%q(i,j,k,ice_wat) = qn1(i,k) + else ! between -15~0C: linear interpolation + Atm%q(i,j,k,liq_wat) = qn1(i,k)*((Atm%pt(i,j,k)-258.16)/15.) + Atm%q(i,j,k,ice_wat) = qn1(i,k) - Atm%q(i,j,k,liq_wat) + endif +#else + else if ( Atm%pt(i,j,k) < 233.16 ) then ! < -40C all ice_wat + Atm%q(i,j,k,liq_wat) = 0. + Atm%q(i,j,k,ice_wat) = qn1(i,k) + else + if ( k.eq.1 ) then ! between [-40,0]: linear interpolation + Atm%q(i,j,k,liq_wat) = qn1(i,k)*((Atm%pt(i,j,k)-233.16)/40.) + Atm%q(i,j,k,ice_wat) = qn1(i,k) - Atm%q(i,j,k,liq_wat) + else + if (Atm%pt(i,j,k)<258.16 .and. Atm%q(i,j,k-1,ice_wat)>1.e-5 ) then + Atm%q(i,j,k,liq_wat) = 0. + Atm%q(i,j,k,ice_wat) = qn1(i,k) + else ! between [-40,0]: linear interpolation + Atm%q(i,j,k,liq_wat) = qn1(i,k)*((Atm%pt(i,j,k)-233.16)/40.) + Atm%q(i,j,k,ice_wat) = qn1(i,k) - Atm%q(i,j,k,liq_wat) + endif + endif + endif +#endif + if (Atm%flagstruct%nwat .eq. 6 ) then + Atm%q(i,j,k,rainwat) = 0. + Atm%q(i,j,k,snowwat) = 0. + Atm%q(i,j,k,graupel) = 0. + call mp_auto_conversion(Atm%q(i,j,k,liq_wat), Atm%q(i,j,k,rainwat), & + Atm%q(i,j,k,ice_wat), Atm%q(i,j,k,snowwat) ) + endif + enddo + enddo + endif + endif ! data source /= FV3GFS GAUSSIAN NEMSIO FILE + +! For GFS spectral input, omega in pa/sec is stored as w in the input data so actual w(m/s) is calculated +! For GFS nemsio input, omega is 0, so best not to use for input since boundary data will not exist for w +! For FV3GFS NEMSIO input, w is already in m/s (but the code reads in as omga) and just needs to be remapped +!------------------------------------------------------------- +! map omega or w +!------- ------------------------------------------------------ + if ( (.not. Atm%flagstruct%hydrostatic) .and. (.not. Atm%flagstruct%ncep_ic) ) then + do k=1,km + do i=is,ie + qp(i,k) = omga(i,j,k) + enddo + enddo + call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4, Atm%ptop) + if (trim(source) == source_fv3gfs) then + do k=1,npz + do i=is,ie + atm%w(i,j,k) = qn1(i,k) + enddo + enddo + else + do k=1,npz + do i=is,ie + atm%w(i,j,k) = qn1(i,k)/atm%delp(i,j,k)*atm%delz(i,j,k) + enddo + enddo + endif + endif + +5000 continue + +! Add some diagnostics: + if (.not. Atm%flagstruct%hydrostatic) call p_maxmin('delz_model', Atm%delz, is, ie, js, je, npz, 1.) + call p_maxmin('sphum_model', Atm%q(is:ie,js:je,1:npz,sphum), is, ie, js, je, npz, 1.) + call p_maxmin('liq_wat_model', Atm%q(is:ie,js:je,1:npz,liq_wat), is, ie, js, je, npz, 1.) + if (ice_wat .gt. 0) call p_maxmin('ice_wat_model', Atm%q(is:ie,js:je,1:npz,ice_wat), is, ie, js, je, npz, 1.) + call p_maxmin('PS_model (mb)', Atm%ps(is:ie,js:je), is, ie, js, je, 1, 0.01) + call p_maxmin('PT_model', Atm%pt(is:ie,js:je,1:npz), is, ie, js, je, npz, 1.) + call pmaxmn('ZS_model', Atm%phis(is:ie,js:je)/grav, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) + call pmaxmn('ZS_data', zh(is:ie,js:je,km+1), is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) + do j=js,je + do i=is,ie + wk(i,j) = Atm%phis(i,j)/grav - zh(i,j,km+1) + ! if ((wk(i,j) > 1800.).or.(wk(i,j)<-1600.)) then + ! print *,' ' + ! print *, 'Diff = ', wk(i,j), 'Atm%phis =', Atm%phis(i,j)/grav, 'zh = ', zh(i,j,km+1) + ! print *, 'lat = ', Atm%gridstruct%agrid(i,j,2)/deg2rad, 'lon = ', Atm%gridstruct%agrid(i,j,1)/deg2rad + ! endif + enddo + enddo + call pmaxmn('ZS_diff (m)', wk, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) + + if (.not.Atm%gridstruct%bounded_domain) then + call prt_gb_nh_sh('DATA_IC Z500', is,ie, js,je, z500, Atm%gridstruct%area_64(is:ie,js:je), Atm%gridstruct%agrid_64(is:ie,js:je,2)) + if ( .not. Atm%flagstruct%hydrostatic ) & + call prt_height('fv3_IC Z500', is,ie, js,je, 3, npz, 500.E2, Atm%phis, Atm%delz, Atm%peln, & + Atm%gridstruct%area_64(is:ie,js:je), Atm%gridstruct%agrid_64(is:ie,js:je,2)) + endif + + do j=js,je + do i=is,ie + wk(i,j) = Atm%ps(i,j) - psc(i,j) + enddo + enddo + call pmaxmn('PS_diff (mb)', wk, is, ie, js, je, 1, 0.01, Atm%gridstruct%area_64, Atm%domain) + + if (is_master()) write(*,*) 'done remap_scalar' + + end subroutine remap_scalar + + subroutine remap_scalar_single(Atm, km, npz, ak0, bk0, psc, qa, zh ,iq) + type(fv_atmos_type), intent(inout) :: Atm + integer, intent(in):: km, npz, iq + real, intent(in):: ak0(km+1), bk0(km+1) + real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: psc + real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: qa + real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km+1):: zh +! local: + real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0 + real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1, dp2 + real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1 + real qp(Atm%bd%is:Atm%bd%ie,km) + real wk(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) +!!! High-precision + real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pn1 + real(kind=R_GRID):: gz_fv(npz+1) + real(kind=R_GRID), dimension(2*km+1):: gz, pn + real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie,km+1):: pn0 + real(kind=R_GRID):: pst +!!! High-precision + integer i,j,k, k2, l + integer :: is, ie, js, je + real, allocatable:: ps_temp(:,:) + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + + k2 = max(10, km/2) + + allocate(ps_temp(is:ie,js:je)) + + do 5000 j=js,je + do k=1,km+1 + do i=is,ie + pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) + pn0(i,k) = log(pe0(i,k)) + enddo + enddo + + do i=is,ie + do k=1,km+1 + pn(k) = pn0(i,k) + gz(k) = zh(i,j,k)*grav + enddo +! Use log-p for interpolation/extrapolation +! mirror image method: + do k=km+2, km+k2 + l = 2*(km+1) - k + gz(k) = 2.*gz(km+1) - gz(l) + pn(k) = 2.*pn(km+1) - pn(l) + enddo + + do k=km+k2-1, 2, -1 + if( Atm%phis(i,j).le.gz(k) .and. Atm%phis(i,j).ge.gz(k+1) ) then + pst = pn(k) + (pn(k+1)-pn(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) + go to 123 + endif + enddo +123 ps_temp(i,j) = exp(pst) + enddo ! i-loop + + do i=is,ie + pe1(i,1) = Atm%ak(1) + pn1(i,1) = log(pe1(i,1)) + enddo + do k=2,npz+1 + do i=is,ie + pe1(i,k) = Atm%ak(k) + Atm%bk(k)*ps_temp(i,j) + pn1(i,k) = log(pe1(i,k)) + enddo + enddo + +! * Compute delp + do k=1,npz + do i=is,ie + dp2(i,k) = pe1(i,k+1) - pe1(i,k) + enddo + enddo + + ! map o3mr + do k=1,km + do i=is,ie + qp(i,k) = qa(i,j,k) + enddo + enddo + call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 0, 8, Atm%ptop) + if ( iq==1 ) then + call fillq(ie-is+1, npz, 1, qn1, dp2) + else + call fillz(ie-is+1, npz, 1, qn1, dp2) + endif +! The HiRam step of blending model sphum with NCEP data is obsolete because nggps is always cold starting... + do k=1,npz + do i=is,ie + Atm%q(i,j,k,iq) = qn1(i,k) + enddo + enddo + +5000 continue + call p_maxmin('o3mr remap', Atm%q(is:ie,js:je,1:npz,iq), is, ie, js, je, npz, 1.) + + deallocate(ps_temp) + + end subroutine remap_scalar_single + + + subroutine mp_auto_conversion(ql, qr, qi, qs) + real, intent(inout):: ql, qr, qi, qs + real, parameter:: qi0_max = 2.0e-3 + real, parameter:: ql0_max = 2.5e-3 + +! Convert excess cloud water into rain: + if ( ql > ql0_max ) then + qr = ql - ql0_max + ql = ql0_max + endif +! Convert excess cloud ice into snow: + if ( qi > qi0_max ) then + qs = qi - qi0_max + qi = qi0_max + endif + + end subroutine mp_auto_conversion + + + subroutine remap_dwinds(km, npz, ak0, bk0, psc, ud, vd, Atm) + type(fv_atmos_type), intent(inout) :: Atm + integer, intent(in):: km, npz + real, intent(in):: ak0(km+1), bk0(km+1) + real, intent(in):: psc(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) + real, intent(in):: ud(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1,km) + real, intent(in):: vd(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je,km) +! local: + real, dimension(Atm%bd%isd:Atm%bd%ied,Atm%bd%jsd:Atm%bd%jed):: psd + real, dimension(Atm%bd%is:Atm%bd%ie+1, km+1):: pe0 + real, dimension(Atm%bd%is:Atm%bd%ie+1,npz+1):: pe1 + real, dimension(Atm%bd%is:Atm%bd%ie+1,npz):: qn1 + integer i,j,k + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + +!Not sure what this is for + if (Atm%gridstruct%bounded_domain) then + do j=jsd,jed + do i=isd,ied + psd(i,j) = Atm%ps(i,j) + enddo + enddo + else + do j=js,je + do i=is,ie + psd(i,j) = psc(i,j) + enddo + enddo + endif + call mpp_update_domains( psd, Atm%domain, complete=.false. ) + call mpp_update_domains( Atm%ps, Atm%domain, complete=.true. ) + +!$OMP parallel do default(none) shared(is,ie,js,je,npz,km,ak0,bk0,Atm,psc,psd,ud,vd) & +!$OMP private(pe1,pe0,qn1) + do 5000 j=js,je+1 +!------ +! map u +!------ + do k=1,km+1 + do i=is,ie + pe0(i,k) = ak0(k) + bk0(k)*0.5*(psd(i,j-1)+psd(i,j)) + enddo + enddo + do k=1,npz+1 + do i=is,ie + pe1(i,k) = Atm%ak(k) + Atm%bk(k)*0.5*(Atm%ps(i,j-1)+Atm%ps(i,j)) + enddo + enddo + call mappm(km, pe0(is:ie,1:km+1), ud(is:ie,j,1:km), npz, pe1(is:ie,1:npz+1), & + qn1(is:ie,1:npz), is,ie, -1, 8, Atm%ptop) + do k=1,npz + do i=is,ie + Atm%u(i,j,k) = qn1(i,k) + enddo + enddo +!------ +! map v +!------ + if ( j/=(je+1) ) then + + do k=1,km+1 + do i=is,ie+1 + pe0(i,k) = ak0(k) + bk0(k)*0.5*(psd(i-1,j)+psd(i,j)) + enddo + enddo + do k=1,npz+1 + do i=is,ie+1 + pe1(i,k) = Atm%ak(k) + Atm%bk(k)*0.5*(Atm%ps(i-1,j)+Atm%ps(i,j)) + enddo + enddo + call mappm(km, pe0(is:ie+1,1:km+1), vd(is:ie+1,j,1:km), npz, pe1(is:ie+1,1:npz+1), & + qn1(is:ie+1,1:npz), is,ie+1, -1, 8, Atm%ptop) + do k=1,npz + do i=is,ie+1 + Atm%v(i,j,k) = qn1(i,k) + enddo + enddo + + endif + +5000 continue + + if (is_master()) write(*,*) 'done remap_dwinds' + + end subroutine remap_dwinds + + + subroutine remap_winds(im, jm, km, npz, ak0, bk0, psc, ua, va, Atm) + type(fv_atmos_type), intent(inout) :: Atm + integer, intent(in):: im, jm, km, npz + real, intent(in):: ak0(km+1), bk0(km+1) + real, intent(in):: psc(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je) + real, intent(in), dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,km):: ua, va +! local: + real, dimension(Atm%bd%isd:Atm%bd%ied,Atm%bd%jsd:Atm%bd%jed,npz):: ut, vt ! winds + real, dimension(Atm%bd%is:Atm%bd%ie, km+1):: pe0 + real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1 + real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1 + integer i,j,k + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: ng + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + ng = Atm%bd%ng + + do 5000 j=js,je + + do k=1,km+1 + do i=is,ie + pe0(i,k) = ak0(k) + bk0(k)*psc(i,j) + enddo + enddo + + do k=1,npz+1 + do i=is,ie + pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) + enddo + enddo + +!------ +! map u +!------ + call mappm(km, pe0, ua(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8, Atm%ptop) + do k=1,npz + do i=is,ie + ut(i,j,k) = qn1(i,k) + enddo + enddo +!------ +! map v +!------ + call mappm(km, pe0, va(is:ie,j,1:km), npz, pe1, qn1, is,ie, -1, 8, Atm%ptop) + do k=1,npz + do i=is,ie + vt(i,j,k) = qn1(i,k) + enddo + enddo + +5000 continue + + call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1.) + call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1.) + call prt_maxmin('UA_top',ut(:,:,1), is, ie, js, je, ng, 1, 1.) + +!---------------------------------------------- +! winds: lat-lon ON A to Cubed-D transformation: +!---------------------------------------------- + call cubed_a2d(Atm%npx, Atm%npy, npz, ut, vt, Atm%u, Atm%v, Atm%gridstruct, Atm%domain, Atm%bd ) + + if (is_master()) write(*,*) 'done remap_winds' + + end subroutine remap_winds + + + subroutine remap_xyz( im, jbeg, jend, jm, km, npz, nq, ncnst, lon, lat, ak0, bk0, ps0, gz0, & + ua, va, ta, qa, Atm ) + + type(fv_atmos_type), intent(inout), target :: Atm + integer, intent(in):: im, jm, km, npz, nq, ncnst + integer, intent(in):: jbeg, jend + real, intent(in):: lon(im), lat(jm), ak0(km+1), bk0(km+1) + real, intent(in):: gz0(im,jbeg:jend), ps0(im,jbeg:jend) + real, intent(in), dimension(im,jbeg:jend,km):: ua, va, ta + real, intent(in), dimension(im,jbeg:jend,km,ncnst):: qa + + real, pointer, dimension(:,:,:) :: agrid + +! local: + real, dimension(Atm%bd%isd:Atm%bd%ied,Atm%bd%jsd:Atm%bd%jed,npz):: ut, vt ! winds + real, dimension(Atm%bd%is:Atm%bd%ie,km):: up, vp, tp + real, dimension(Atm%bd%is:Atm%bd%ie,km+1):: pe0, pn0 + real pt0(km), gz(km+1), pk0(km+1) + real qp(Atm%bd%is:Atm%bd%ie,km,ncnst) + real, dimension(Atm%bd%is:Atm%bd%ie,npz):: qn1 + real, dimension(Atm%bd%is:Atm%bd%ie,npz+1):: pe1, pn1 + real :: rdlon(im) + real :: rdlat(jm) + real:: a1, b1, c1, c2, c3, c4 + real:: gzc, psc, pst +#ifdef MULTI_GASES + real:: kappax, pkx +#endif + integer i,j,k, i1, i2, jc, i0, j0, iq +! integer sphum, liq_wat, ice_wat, cld_amt + integer sphum + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed, ng + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + ng = Atm%bd%ng + + !!NOTE: Only Atm is used in this routine. + agrid => Atm%gridstruct%agrid + + sphum = get_tracer_index(MODEL_ATMOS, 'sphum') + + if ( sphum/=1 ) then + call mpp_error(FATAL,'SPHUM must be 1st tracer') + endif + + pk0(1) = ak0(1)**kappa + + do i=1,im-1 + rdlon(i) = 1. / (lon(i+1) - lon(i)) + enddo + rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) + + do j=1,jm-1 + rdlat(j) = 1. / (lat(j+1) - lat(j)) + enddo + +! * Interpolate to cubed sphere cell center + do 5000 j=js,je + + do i=is,ie + pe0(i,1) = ak0(1) + pn0(i,1) = log(ak0(1)) + enddo + + + do i=is,ie + + if ( agrid(i,j,1)>lon(im) ) then + i1 = im; i2 = 1 + a1 = (agrid(i,j,1)-lon(im)) * rdlon(im) + elseif ( agrid(i,j,1)=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then + i1 = i0; i2 = i0+1 + a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0) + go to 111 + endif + enddo + endif + +111 continue + + if ( agrid(i,j,2)lat(jm) ) then + jc = jm-1 + b1 = 1. + else + do j0=1,jm-1 + if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then + jc = j0 + b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc) + go to 222 + endif + enddo + endif +222 continue + +#ifndef DEBUG_REMAP + if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then + write(*,*) i,j,a1, b1 + endif +#endif + c1 = (1.-a1) * (1.-b1) + c2 = a1 * (1.-b1) + c3 = a1 * b1 + c4 = (1.-a1) * b1 + +! Interpolated surface pressure + psc = c1*ps0(i1,jc ) + c2*ps0(i2,jc ) + & + c3*ps0(i2,jc+1) + c4*ps0(i1,jc+1) + +! Interpolated surface geopotential + gzc = c1*gz0(i1,jc ) + c2*gz0(i2,jc ) + & + c3*gz0(i2,jc+1) + c4*gz0(i1,jc+1) + +! 3D fields: + do iq=1,ncnst +! if ( iq==sphum .or. iq==liq_wat .or. iq==ice_wat .or. iq==cld_amt ) then + do k=1,km + qp(i,k,iq) = c1*qa(i1,jc, k,iq) + c2*qa(i2,jc, k,iq) + & + c3*qa(i2,jc+1,k,iq) + c4*qa(i1,jc+1,k,iq) + enddo +! endif + enddo + + do k=1,km + up(i,k) = c1*ua(i1,jc, k) + c2*ua(i2,jc, k) + & + c3*ua(i2,jc+1,k) + c4*ua(i1,jc+1,k) + vp(i,k) = c1*va(i1,jc, k) + c2*va(i2,jc, k) + & + c3*va(i2,jc+1,k) + c4*va(i1,jc+1,k) + tp(i,k) = c1*ta(i1,jc, k) + c2*ta(i2,jc, k) + & + c3*ta(i2,jc+1,k) + c4*ta(i1,jc+1,k) +! Virtual effect: +#ifdef MULTI_GASES + tp(i,k) = tp(i,k)*virq(qp(i,k,:)) +#else + tp(i,k) = tp(i,k)*(1.+zvir*qp(i,k,sphum)) +#endif + enddo +! Tracers: + + do k=2,km+1 + pe0(i,k) = ak0(k) + bk0(k)*psc + pn0(i,k) = log(pe0(i,k)) + pk0(k) = pe0(i,k)**kappa + enddo + +#ifdef USE_DATA_ZS + Atm% ps(i,j) = psc + Atm%phis(i,j) = gzc +#else + +! * Adjust interpolated ps to model terrain + gz(km+1) = gzc + do k=km,1,-1 + gz(k) = gz(k+1) + rdgas*tp(i,k)*(pn0(i,k+1)-pn0(i,k)) + enddo +! Only lowest layer potential temp is needed +#ifdef MULTI_GASES + kappax = virqd(qp(i,km,:))/vicpqd(qp(i,km,:)) + pkx = (pk0(km+1)-pk0(km))*(kappa*(pn0(i,km+1)-pn0(i,km))) + pkx = exp( kappax*log(pkx) ) + pt0(km) = tp(i,km)/pkx +#else + pt0(km) = tp(i,km)/(pk0(km+1)-pk0(km))*(kappa*(pn0(i,km+1)-pn0(i,km))) +#endif + if( Atm%phis(i,j)>gzc ) then + do k=km,1,-1 + if( Atm%phis(i,j) < gz(k) .and. & + Atm%phis(i,j) >= gz(k+1) ) then + pst = pk0(k) + (pk0(k+1)-pk0(k))*(gz(k)-Atm%phis(i,j))/(gz(k)-gz(k+1)) + go to 123 + endif + enddo + else +! Extrapolation into the ground +#ifdef MULTI_GASES + pst = pk0(km+1) + (gzc-Atm%phis(i,j))/(cp_air*pt0(km)*pkx) +#else + pst = pk0(km+1) + (gzc-Atm%phis(i,j))/(cp_air*pt0(km)) +#endif + endif + +#ifdef MULTI_GASES +123 Atm%ps(i,j) = pst**(1./(kappa*kappax)) +#else +123 Atm%ps(i,j) = pst**(1./kappa) +#endif +#endif + enddo !i-loop + + +! * Compute delp from ps + do i=is,ie + pe1(i,1) = Atm%ak(1) + pn1(i,1) = log(pe1(i,1)) + enddo + do k=2,npz+1 + do i=is,ie + pe1(i,k) = Atm%ak(k) + Atm%bk(k)*Atm%ps(i,j) + pn1(i,k) = log(pe1(i,k)) + enddo + enddo + + do k=1,npz + do i=is,ie + Atm%delp(i,j,k) = pe1(i,k+1) - pe1(i,k) + enddo + enddo + +! Use kord=9 for winds; kord=11 for tracers +!------ +! map u +!------ + call mappm(km, pe0, up, npz, pe1, qn1, is,ie, -1, 9, Atm%ptop) + do k=1,npz + do i=is,ie + ut(i,j,k) = qn1(i,k) + enddo + enddo +!------ +! map v +!------ + call mappm(km, pe0, vp, npz, pe1, qn1, is,ie, -1, 9, Atm%ptop) + do k=1,npz + do i=is,ie + vt(i,j,k) = qn1(i,k) + enddo + enddo + +!--------------- +! map tracers +!---------------- + do iq=1,ncnst +! Note: AM2 physics tracers only +! if ( iq==sphum .or. iq==liq_wat .or. iq==ice_wat .or. iq==cld_amt ) then + call mappm(km, pe0, qp(is,1,iq), npz, pe1, qn1, is,ie, 0, 11, Atm%ptop) + do k=1,npz + do i=is,ie + Atm%q(i,j,k,iq) = qn1(i,k) + enddo + enddo +! endif + enddo + +!------------------------------------------------------------- +! map virtual temperature using geopotential conserving scheme. +!------------------------------------------------------------- + call mappm(km, pn0, tp, npz, pn1, qn1, is,ie, 1, 9, Atm%ptop) + do k=1,npz + do i=is,ie +#ifdef MULTI_GASES + Atm%pt(i,j,k) = qn1(i,k)/virq(Atm%q(i,j,k,:)) +#else + Atm%pt(i,j,k) = qn1(i,k)/(1.+zvir*Atm%q(i,j,k,sphum)) +#endif + enddo + enddo + +5000 continue + + call prt_maxmin('PS_model', Atm%ps, is, ie, js, je, ng, 1, 0.01) + call prt_maxmin('UT', ut, is, ie, js, je, ng, npz, 1.) + call prt_maxmin('VT', vt, is, ie, js, je, ng, npz, 1.) + +!---------------------------------------------- +! winds: lat-lon ON A to Cubed-D transformation: +!---------------------------------------------- + call cubed_a2d(Atm%npx, Atm%npy, npz, ut, vt, Atm%u, Atm%v, Atm%gridstruct, Atm%domain, Atm%bd ) + + if (is_master()) write(*,*) 'done remap_xyz' + + end subroutine remap_xyz + +!>@brief The subroutine 'cubed_a2d' transforms the wind from the A Grid to the D Grid. + subroutine cubed_a2d( npx, npy, npz, ua, va, u, v, gridstruct, fv_domain, bd ) + use mpp_domains_mod, only: mpp_update_domains + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(in):: npx, npy, npz + real, intent(inout), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz):: ua, va + real, intent(out):: u(bd%isd:bd%ied, bd%jsd:bd%jed+1,npz) + real, intent(out):: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) + type(fv_grid_type), intent(IN), target :: gridstruct + type(domain2d), intent(INOUT) :: fv_domain +! local: + real v3(3,bd%is-1:bd%ie+1,bd%js-1:bd%je+1) + real ue(3,bd%is-1:bd%ie+1,bd%js:bd%je+1) !< 3D winds at edges + real ve(3,bd%is:bd%ie+1,bd%js-1:bd%je+1) !< 3D winds at edges + real, dimension(bd%is:bd%ie):: ut1, ut2, ut3 + real, dimension(bd%js:bd%je):: vt1, vt2, vt3 + integer i, j, k, im2, jm2 + + real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat + real(kind=R_GRID), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n + real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + vlon => gridstruct%vlon + vlat => gridstruct%vlat + + edge_vect_w => gridstruct%edge_vect_w + edge_vect_e => gridstruct%edge_vect_e + edge_vect_s => gridstruct%edge_vect_s + edge_vect_n => gridstruct%edge_vect_n + + ew => gridstruct%ew + es => gridstruct%es + + call mpp_update_domains(ua, fv_domain, complete=.false.) + call mpp_update_domains(va, fv_domain, complete=.true.) + + im2 = (npx-1)/2 + jm2 = (npy-1)/2 + + do k=1, npz +! Compute 3D wind on A grid + do j=js-1,je+1 + do i=is-1,ie+1 + v3(1,i,j) = ua(i,j,k)*vlon(i,j,1) + va(i,j,k)*vlat(i,j,1) + v3(2,i,j) = ua(i,j,k)*vlon(i,j,2) + va(i,j,k)*vlat(i,j,2) + v3(3,i,j) = ua(i,j,k)*vlon(i,j,3) + va(i,j,k)*vlat(i,j,3) + enddo + enddo + +! A --> D +! Interpolate to cell edges + do j=js,je+1 + do i=is-1,ie+1 + ue(1,i,j) = 0.5*(v3(1,i,j-1) + v3(1,i,j)) + ue(2,i,j) = 0.5*(v3(2,i,j-1) + v3(2,i,j)) + ue(3,i,j) = 0.5*(v3(3,i,j-1) + v3(3,i,j)) + enddo + enddo + + do j=js-1,je+1 + do i=is,ie+1 + ve(1,i,j) = 0.5*(v3(1,i-1,j) + v3(1,i,j)) + ve(2,i,j) = 0.5*(v3(2,i-1,j) + v3(2,i,j)) + ve(3,i,j) = 0.5*(v3(3,i-1,j) + v3(3,i,j)) + enddo + enddo + +! --- E_W edges (for v-wind): + if (.not. gridstruct%bounded_domain) then + if ( is==1) then + i = 1 + do j=js,je + if ( j>jm2 ) then + vt1(j) = edge_vect_w(j)*ve(1,i,j-1)+(1.-edge_vect_w(j))*ve(1,i,j) + vt2(j) = edge_vect_w(j)*ve(2,i,j-1)+(1.-edge_vect_w(j))*ve(2,i,j) + vt3(j) = edge_vect_w(j)*ve(3,i,j-1)+(1.-edge_vect_w(j))*ve(3,i,j) + else + vt1(j) = edge_vect_w(j)*ve(1,i,j+1)+(1.-edge_vect_w(j))*ve(1,i,j) + vt2(j) = edge_vect_w(j)*ve(2,i,j+1)+(1.-edge_vect_w(j))*ve(2,i,j) + vt3(j) = edge_vect_w(j)*ve(3,i,j+1)+(1.-edge_vect_w(j))*ve(3,i,j) + endif + enddo + do j=js,je + ve(1,i,j) = vt1(j) + ve(2,i,j) = vt2(j) + ve(3,i,j) = vt3(j) + enddo + endif + + if ( (ie+1)==npx ) then + i = npx + do j=js,je + if ( j>jm2 ) then + vt1(j) = edge_vect_e(j)*ve(1,i,j-1)+(1.-edge_vect_e(j))*ve(1,i,j) + vt2(j) = edge_vect_e(j)*ve(2,i,j-1)+(1.-edge_vect_e(j))*ve(2,i,j) + vt3(j) = edge_vect_e(j)*ve(3,i,j-1)+(1.-edge_vect_e(j))*ve(3,i,j) + else + vt1(j) = edge_vect_e(j)*ve(1,i,j+1)+(1.-edge_vect_e(j))*ve(1,i,j) + vt2(j) = edge_vect_e(j)*ve(2,i,j+1)+(1.-edge_vect_e(j))*ve(2,i,j) + vt3(j) = edge_vect_e(j)*ve(3,i,j+1)+(1.-edge_vect_e(j))*ve(3,i,j) + endif + enddo + do j=js,je + ve(1,i,j) = vt1(j) + ve(2,i,j) = vt2(j) + ve(3,i,j) = vt3(j) + enddo + endif + +! N-S edges (for u-wind): + if ( js==1 ) then + j = 1 + do i=is,ie + if ( i>im2 ) then + ut1(i) = edge_vect_s(i)*ue(1,i-1,j)+(1.-edge_vect_s(i))*ue(1,i,j) + ut2(i) = edge_vect_s(i)*ue(2,i-1,j)+(1.-edge_vect_s(i))*ue(2,i,j) + ut3(i) = edge_vect_s(i)*ue(3,i-1,j)+(1.-edge_vect_s(i))*ue(3,i,j) + else + ut1(i) = edge_vect_s(i)*ue(1,i+1,j)+(1.-edge_vect_s(i))*ue(1,i,j) + ut2(i) = edge_vect_s(i)*ue(2,i+1,j)+(1.-edge_vect_s(i))*ue(2,i,j) + ut3(i) = edge_vect_s(i)*ue(3,i+1,j)+(1.-edge_vect_s(i))*ue(3,i,j) + endif + enddo + do i=is,ie + ue(1,i,j) = ut1(i) + ue(2,i,j) = ut2(i) + ue(3,i,j) = ut3(i) + enddo + endif + + if ( (je+1)==npy ) then + j = npy + do i=is,ie + if ( i>im2 ) then + ut1(i) = edge_vect_n(i)*ue(1,i-1,j)+(1.-edge_vect_n(i))*ue(1,i,j) + ut2(i) = edge_vect_n(i)*ue(2,i-1,j)+(1.-edge_vect_n(i))*ue(2,i,j) + ut3(i) = edge_vect_n(i)*ue(3,i-1,j)+(1.-edge_vect_n(i))*ue(3,i,j) + else + ut1(i) = edge_vect_n(i)*ue(1,i+1,j)+(1.-edge_vect_n(i))*ue(1,i,j) + ut2(i) = edge_vect_n(i)*ue(2,i+1,j)+(1.-edge_vect_n(i))*ue(2,i,j) + ut3(i) = edge_vect_n(i)*ue(3,i+1,j)+(1.-edge_vect_n(i))*ue(3,i,j) + endif + enddo + do i=is,ie + ue(1,i,j) = ut1(i) + ue(2,i,j) = ut2(i) + ue(3,i,j) = ut3(i) + enddo + endif + + endif ! .not. bounded_domain + + do j=js,je+1 + do i=is,ie + u(i,j,k) = ue(1,i,j)*es(1,i,j,1) + & + ue(2,i,j)*es(2,i,j,1) + & + ue(3,i,j)*es(3,i,j,1) + enddo + enddo + do j=js,je + do i=is,ie+1 + v(i,j,k) = ve(1,i,j)*ew(1,i,j,2) + & + ve(2,i,j)*ew(2,i,j,2) + & + ve(3,i,j)*ew(3,i,j,2) + enddo + enddo + + enddo ! k-loop + + end subroutine cubed_a2d + + + subroutine d2a3d(u, v, ua, va, im, jm, km, lon) + integer, intent(in):: im, jm, km ! Dimensions + real, intent(in ) :: lon(im) + real, intent(in ), dimension(im,jm,km):: u, v + real, intent(out), dimension(im,jm,km):: ua, va +! local + real :: coslon(im),sinlon(im) ! Sine and cosine in longitude + integer i, j, k + integer imh + real un, vn, us, vs + + integer :: ks, ke + + imh = im/2 + + do i=1,im + sinlon(i) = sin(lon(i)) + coslon(i) = cos(lon(i)) + enddo + + do k=1,km + do j=2,jm-1 + do i=1,im + ua(i,j,k) = 0.5*(u(i,j,k) + u(i,j+1,k)) + enddo + enddo + + do j=2,jm-1 + do i=1,im-1 + va(i,j,k) = 0.5*(v(i,j,k) + v(i+1,j,k)) + enddo + va(im,j,k) = 0.5*(v(im,j,k) + v(1,j,k)) + enddo + +! Projection at SP + us = 0. + vs = 0. + do i=1,imh + us = us + (ua(i+imh,2,k)-ua(i,2,k))*sinlon(i) & + + (va(i,2,k)-va(i+imh,2,k))*coslon(i) + vs = vs + (ua(i+imh,2,k)-ua(i,2,k))*coslon(i) & + + (va(i+imh,2,k)-va(i,2,k))*sinlon(i) + enddo + us = us/im + vs = vs/im + do i=1,imh + ua(i,1,k) = -us*sinlon(i) - vs*coslon(i) + va(i,1,k) = us*coslon(i) - vs*sinlon(i) + ua(i+imh,1,k) = -ua(i,1,k) + va(i+imh,1,k) = -va(i,1,k) + enddo + +! Projection at NP + un = 0. + vn = 0. + do i=1,imh + un = un + (ua(i+imh,jm-1,k)-ua(i,jm-1,k))*sinlon(i) & + + (va(i+imh,jm-1,k)-va(i,jm-1,k))*coslon(i) + vn = vn + (ua(i,jm-1,k)-ua(i+imh,jm-1,k))*coslon(i) & + + (va(i+imh,jm-1,k)-va(i,jm-1,k))*sinlon(i) + enddo + + un = un/im + vn = vn/im + do i=1,imh + ua(i,jm,k) = -un*sinlon(i) + vn*coslon(i) + va(i,jm,k) = -un*coslon(i) - vn*sinlon(i) + ua(i+imh,jm,k) = -ua(i,jm,k) + va(i+imh,jm,k) = -va(i,jm,k) + enddo + enddo + + end subroutine d2a3d + + + subroutine pmaxmin( qname, a, im, jm, fac ) + + integer, intent(in):: im, jm + character(len=*) :: qname + integer i, j + real a(im,jm) + + real qmin(jm), qmax(jm) + real pmax, pmin + real fac ! multiplication factor + + do j=1,jm + pmax = a(1,j) + pmin = a(1,j) + do i=2,im + pmax = max(pmax, a(i,j)) + pmin = min(pmin, a(i,j)) + enddo + qmax(j) = pmax + qmin(j) = pmin + enddo +! +! Now find max/min of amax/amin +! + pmax = qmax(1) + pmin = qmin(1) + do j=2,jm + pmax = max(pmax, qmax(j)) + pmin = min(pmin, qmin(j)) + enddo + + write(*,*) qname, ' max = ', pmax*fac, ' min = ', pmin*fac + + end subroutine pmaxmin + +subroutine pmaxmn(qname, q, is, ie, js, je, km, fac, area, domain) + character(len=*), intent(in):: qname + integer, intent(in):: is, ie, js, je + integer, intent(in):: km + real, intent(in):: q(is:ie, js:je, km) + real, intent(in):: fac + real(kind=R_GRID), intent(IN):: area(is-3:ie+3, js-3:je+3) + type(domain2d), intent(INOUT) :: domain +!---local variables + real qmin, qmax, gmean + integer i,j,k + + qmin = q(is,js,1) + qmax = qmin + gmean = 0. + + do k=1,km + do j=js,je + do i=is,ie + if( q(i,j,k) < qmin ) then + qmin = q(i,j,k) + elseif( q(i,j,k) > qmax ) then + qmax = q(i,j,k) + endif + enddo + enddo + enddo + + call mp_reduce_min(qmin) + call mp_reduce_max(qmax) + + gmean = g_sum(domain, q(is,js,km), is, ie, js, je, 3, area, 1, reproduce=.true.) + if(is_master()) write(6,*) qname, qmax*fac, qmin*fac, gmean*fac + + end subroutine pmaxmn + + subroutine p_maxmin(qname, q, is, ie, js, je, km, fac) + character(len=*), intent(in):: qname + integer, intent(in):: is, ie, js, je, km + real, intent(in):: q(is:ie, js:je, km) + real, intent(in):: fac + real qmin, qmax + integer i,j,k + + qmin = q(is,js,1) + qmax = qmin + do k=1,km + do j=js,je + do i=is,ie + if( q(i,j,k) < qmin ) then + qmin = q(i,j,k) + elseif( q(i,j,k) > qmax ) then + qmax = q(i,j,k) + endif + enddo + enddo + enddo + call mp_reduce_min(qmin) + call mp_reduce_max(qmax) + if(is_master()) write(6,*) qname, qmax*fac, qmin*fac + + end subroutine p_maxmin + + subroutine fillq(im, km, nq, q, dp) + integer, intent(in):: im !< No. of longitudes + integer, intent(in):: km !< No. of levels + integer, intent(in):: nq !< Total number of tracers + real , intent(in):: dp(im,km) !< pressure thickness + real , intent(inout) :: q(im,km,nq) !< tracer mixing ratio +! !LOCAL VARIABLES: + integer i, k, ic, k1 + + do ic=1,nq +! Bottom up: + do k=km,2,-1 + k1 = k-1 + do i=1,im + if( q(i,k,ic) < 0. ) then + q(i,k1,ic) = q(i,k1,ic) + q(i,k,ic)*dp(i,k)/dp(i,k1) + q(i,k ,ic) = 0. + endif + enddo + enddo +! Top down: + do k=1,km-1 + k1 = k+1 + do i=1,im + if( q(i,k,ic) < 0. ) then + q(i,k1,ic) = q(i,k1,ic) + q(i,k,ic)*dp(i,k)/dp(i,k1) + q(i,k ,ic) = 0. + endif + enddo + enddo + + enddo + + end subroutine fillq + + subroutine compute_zh(im, jm, levp, ak0, bk0, ps, zs, t, q, nq, zh ) + implicit none + integer, intent(in):: levp, im,jm, nq + real, intent(in), dimension(levp+1):: ak0, bk0 + real(kind=4), intent(in), dimension(im,jm):: ps, zs + real(kind=4), intent(in), dimension(im,jm,levp):: t + real(kind=4), intent(in), dimension(im,jm,levp,nq):: q + real(kind=4), intent(out), dimension(im,jm,levp+1):: zh + ! Local: + real, dimension(im,levp+1):: pe0, pn0 +! real:: qc + integer:: i,j,k + +!$OMP parallel do default(none) shared(im,jm,levp,ak0,bk0,zs,ps,t,q,zh) & +!$OMP private(pe0,pn0) + do j = 1, jm + + do i=1, im + pe0(i,1) = ak0(1) + pn0(i,1) = log(pe0(i,1)) + zh(i,j,levp+1) = zs(i,j) + enddo + + do k=2,levp+1 + do i=1,im + pe0(i,k) = ak0(k) + bk0(k)*ps(i,j) + pn0(i,k) = log(pe0(i,k)) + enddo + enddo + + do k = levp, 1, -1 + do i = 1, im +! qc = 1.-(q(i,j,k,2)+q(i,j,k,3)+q(i,j,k,4)+q(i,j,k,5)) + zh(i,j,k) = zh(i,j,k+1)+(t(i,j,k)*(1.+zvir*q(i,j,k,1))*(pn0(i,k+1)-pn0(i,k)))*(rdgas/grav) + enddo + enddo + enddo + + !if(is_master()) call pmaxmin( 'zh levp+1', zh(:,:,levp+1), im, jm, 1.) + + end subroutine compute_zh + + subroutine get_staggered_grid( is, ie, js, je, isd, ied, jsd, jed, pt_b, pt_c, pt_d) + integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed + real, dimension(isd:ied+1,jsd:jed+1,2), intent(in) :: pt_b + real, dimension(isd:ied+1,jsd:jed ,2), intent(out) :: pt_c + real, dimension(isd:ied ,jsd:jed+1,2), intent(out) :: pt_d + ! local + real(kind=R_GRID), dimension(2):: p1, p2, p3 + integer :: i, j + + do j=js,je+1 + do i=is,ie + p1(:) = pt_b(i, j,1:2) + p2(:) = pt_b(i+1,j,1:2) + call mid_pt_sphere(p1, p2, p3) + pt_d(i,j,1:2) = p3(:) + enddo + enddo + + do j=js,je + do i=is,ie+1 + p1(:) = pt_b(i,j ,1:2) + p2(:) = pt_b(i,j+1,1:2) + call mid_pt_sphere(p1, p2, p3) + pt_c(i,j,1:2) = p3(:) + enddo + enddo + + end subroutine get_staggered_grid + + end module external_ic_mod + diff --git a/tools/fv_diagnostics.F90 b/tools/fv_diagnostics.F90 index 33de06a75..22b38cbb8 100644 --- a/tools/fv_diagnostics.F90 +++ b/tools/fv_diagnostics.F90 @@ -118,17 +118,16 @@ module fv_diagnostics_mod ! use constants_mod, only: grav, rdgas, rvgas, pi=>pi_8, radius, kappa, WTMAIR, WTMCO2, & - omega, hlv, cp_air, cp_vapor + omega, hlv, cp_air, cp_vapor, TFREEZE use fms_mod, only: write_version_number use fms_io_mod, only: set_domain, nullify_domain, write_version_number use time_manager_mod, only: time_type, get_date, get_time - use mpp_domains_mod, only: domain2d, mpp_update_domains, DGRID_NE + use mpp_domains_mod, only: domain2d, mpp_update_domains, DGRID_NE, EAST, NORTH use diag_manager_mod, only: diag_axis_init, register_diag_field, & register_static_field, send_data, diag_grid_init use fv_arrays_mod, only: fv_atmos_type, fv_grid_type, fv_diag_type, fv_grid_bounds_type, & R_GRID - !!! CLEANUP needs rem oval? - use fv_mapz_mod, only: E_Flux, moist_cv + use fv_mapz_mod, only: E_Flux, moist_cv, moist_cp use fv_mp_mod, only: mp_reduce_sum, mp_reduce_min, mp_reduce_max, is_master use fv_eta_mod, only: get_eta_level, gw_1d use fv_grid_utils_mod, only: g_sum @@ -138,13 +137,21 @@ module fv_diagnostics_mod use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index use field_manager_mod, only: MODEL_ATMOS - use mpp_mod, only: mpp_error, FATAL, stdlog, mpp_pe, mpp_root_pe, mpp_sum, mpp_max, NOTE + use mpp_mod, only: mpp_error, FATAL, stdlog, mpp_pe, mpp_root_pe, mpp_sum, mpp_max, NOTE, input_nml_file + use mpp_io_mod, only: mpp_flush use sat_vapor_pres_mod, only: compute_qs, lookup_es use fv_arrays_mod, only: max_step #ifndef GFS_PHYS use gfdl_cloud_microphys_mod, only: wqs1, qsmith_init #endif + + use column_diagnostics_mod, only: column_diagnostics_init, & + initialize_diagnostic_columns, & + column_diagnostics_header, & + close_column_diagnostics_units + + #ifdef MULTI_GASES use multi_gases_mod, only: virq, virqd, vicpqd, vicvqd, num_gas #endif @@ -152,6 +159,10 @@ module fv_diagnostics_mod implicit none private + interface range_check + module procedure range_check_3d + module procedure range_check_2d + end interface range_check real, parameter:: missing_value = -1.e10 real, parameter:: missing_value2 = -1.e3 !< for variables with many missing values @@ -170,7 +181,7 @@ module fv_diagnostics_mod logical :: prt_minmax =.false. logical :: m_calendar integer sphum, liq_wat, ice_wat, cld_amt ! GFDL physics - integer rainwat, snowwat, graupel + integer rainwat, snowwat, graupel, o3mr integer :: istep, mp_top real :: ptop real, parameter :: rad2deg = 180./pi @@ -188,8 +199,43 @@ module fv_diagnostics_mod public :: max_vorticity,max_vorticity_hy1,bunkers_vector public :: helicity_relative_CAPS +#ifdef FEWER_PLEVS + integer, parameter :: nplev = 10 ! 31 ! lmh +#else integer, parameter :: nplev = 31 +#endif integer :: levs(nplev) + integer :: k100, k200, k500 + + integer, parameter :: MAX_DIAG_COLUMN = 100 + logical, allocatable, dimension(:,:) :: do_debug_diag_column + integer, allocatable, dimension(:) :: diag_debug_units, diag_debug_i, diag_debug_j + real, allocatable, dimension(:) :: diag_debug_lon, diag_debug_lat + character(16), dimension(MAX_DIAG_COLUMN) :: diag_debug_names + real, dimension(MAX_DIAG_COLUMN) :: diag_debug_lon_in, diag_debug_lat_in + + logical, allocatable, dimension(:,:) :: do_sonde_diag_column + integer, allocatable, dimension(:) :: diag_sonde_units, diag_sonde_i, diag_sonde_j + real, allocatable, dimension(:) :: diag_sonde_lon, diag_sonde_lat + character(16), dimension(MAX_DIAG_COLUMN) :: diag_sonde_names + real, dimension(MAX_DIAG_COLUMN) :: diag_sonde_lon_in, diag_sonde_lat_in + + logical :: do_diag_debug = .false. + logical :: do_diag_sonde = .false. + logical :: prt_sounding = .false. + integer :: sound_freq = 3 + integer :: num_diag_debug = 0 + integer :: num_diag_sonde = 0 + character(100) :: runname = 'test' + integer :: yr_init, mo_init, dy_init, hr_init, mn_init, sec_init + + real :: vrange(2), vsrange(2), wrange(2), trange(2), slprange(2), rhrange(2), skrange(2) + + + + namelist /fv_diag_column_nml/ do_diag_debug, do_diag_sonde, sound_freq, & + diag_debug_lon_in, diag_debug_lat_in, diag_debug_names, & + diag_sonde_lon_in, diag_sonde_lat_in, diag_sonde_names, runname ! version number of this module ! Include variable "version" to be written to log file. @@ -206,7 +252,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) real, allocatable :: grid_xt(:), grid_yt(:), grid_xe(:), grid_ye(:), grid_xn(:), grid_yn(:) real, allocatable :: grid_x(:), grid_y(:) - real :: vrange(2), vsrange(2), wrange(2), trange(2), slprange(2), rhrange(2), skrange(2) real, allocatable :: a3(:,:,:) real :: pfull(npz) real :: hyam(npz), hybm(npz) @@ -215,8 +260,9 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) integer :: id_bk, id_pk, id_area, id_lon, id_lat, id_lont, id_latt, id_phalf, id_pfull integer :: id_hyam, id_hybm integer :: id_plev - integer :: i, j, k, n, ntileMe, id_xt, id_yt, id_x, id_y, id_xe, id_ye, id_xn, id_yn + integer :: i, j, k, m, n, ntileMe, id_xt, id_yt, id_x, id_y, id_xe, id_ye, id_xn, id_yn integer :: isc, iec, jsc, jec + logical :: used character(len=64) :: plev @@ -227,6 +273,9 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) integer :: ncnst integer :: axe2(3) + character(len=64) :: errmsg + logical :: exists + integer :: nlunit, ios call write_version_number ( 'FV_DIAGNOSTICS_MOD', version ) idiag => Atm(1)%idiag @@ -238,6 +287,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) ncnst = Atm(1)%ncnst m_calendar = Atm(1)%flagstruct%moist_phys + call set_domain(Atm(1)%domain) ! Set domain so that diag_manager can access tile information sphum = get_tracer_index (MODEL_ATMOS, 'sphum') @@ -247,6 +297,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') graupel = get_tracer_index (MODEL_ATMOS, 'graupel') + o3mr = get_tracer_index (MODEL_ATMOS, 'o3mr') cld_amt = get_tracer_index (MODEL_ATMOS, 'cld_amt') ! valid range for some fields @@ -327,9 +378,9 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) ! set_name=trim(field), Domain2=Domain, tile_count=n) id_x = diag_axis_init('grid_x',grid_x,'degrees_E','x','cell corner longitude', & - set_name=trim(field),Domain2=Atm(n)%Domain, tile_count=n) + set_name=trim(field),Domain2=Atm(n)%Domain, tile_count=n, domain_position=EAST) id_y = diag_axis_init('grid_y',grid_y,'degrees_N','y','cell corner latitude', & - set_name=trim(field), Domain2=Atm(n)%Domain, tile_count=n) + set_name=trim(field), Domain2=Atm(n)%Domain, tile_count=n, domain_position=NORTH) ! end do ! deallocate(grid_xt, grid_yt, grid_xe, grid_ye, grid_xn, grid_yn) @@ -381,8 +432,19 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) ! Selected pressure levels ! SJL note: 31 is enough here; if you need more levels you should do it OFF line ! do not add more to prevent the model from slowing down too much. +#ifdef FEWER_PLEVS + levs = (/50,100,200,250,300,500,750,850,925,1000/) ! lmh mini-levs for MJO simulations + k100 = 2 + k200 = 3 + k500 = 6 +#else levs = (/1,2,3,5,7,10,20,30,50,70,100,150,200,250,300,350,400,450,500,550,600,650,700,750,800,850,900,925,950,975,1000/) - + k100 = 11 + k200 = 13 + k500 = 19 +#endif + ! + id_plev = diag_axis_init('plev', levs(:)*1.0, 'mb', 'z', & 'actual pressure level', direction=-1, set_name="dynamics") @@ -559,6 +621,32 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) idiag%id_amdt = register_diag_field ( trim(field), 'amdt', axes(1:2), Time, & 'angular momentum error', 'kg*m^2/s^2', missing_value=missing_value ) +!------------------- +!! 3D Tendency terms from physics +!------------------- + if (Atm(n)%flagstruct%write_3d_diags) then + + idiag%id_T_dt_phys = register_diag_field ( trim(field), 'T_dt_phys', axes(1:3), Time, & + 'temperature tendency from physics', 'K/s', missing_value=missing_value ) + if (idiag%id_T_dt_phys > 0) allocate (Atm(n)%phys_diag%phys_t_dt(isc:iec,jsc:jec,npz)) + idiag%id_u_dt_phys = register_diag_field ( trim(field), 'u_dt_phys', axes(1:3), Time, & + 'zonal wind tendency from physics', 'm/s/s', missing_value=missing_value ) + if (idiag%id_u_dt_phys > 0) allocate (Atm(n)%phys_diag%phys_u_dt(isc:iec,jsc:jec,npz)) + idiag%id_v_dt_phys = register_diag_field ( trim(field), 'v_dt_phys', axes(1:3), Time, & + 'meridional wind tendency from physics', 'm/s/s', missing_value=missing_value ) + if (idiag%id_v_dt_phys > 0) allocate (Atm(n)%phys_diag%phys_v_dt(isc:iec,jsc:jec,npz)) + + idiag%id_qv_dt_phys = register_diag_field ( trim(field), 'qv_dt_phys', axes(1:3), Time, & + 'water vapor specific humidity tendency from physics', 'kg/kg/s', missing_value=missing_value ) + if (idiag%id_qv_dt_phys > 0) allocate (Atm(n)%phys_diag%phys_qv_dt(isc:iec,jsc:jec,npz)) + idiag%id_ql_dt_phys = register_diag_field ( trim(field), 'ql_dt_phys', axes(1:3), Time, & + 'total liquid water tendency from physics', 'kg/kg/s', missing_value=missing_value ) + if (idiag%id_ql_dt_phys > 0) allocate (Atm(n)%phys_diag%phys_ql_dt(isc:iec,jsc:jec,npz)) + idiag%id_qi_dt_phys = register_diag_field ( trim(field), 'qi_dt_phys', axes(1:3), Time, & + 'total ice water tendency from physics', 'kg/kg/s', missing_value=missing_value ) + if (idiag%id_qi_dt_phys > 0) allocate (Atm(n)%phys_diag%phys_qi_dt(isc:iec,jsc:jec,npz)) + endif + ! do i=1,nplev write(plev,'(I5)') levs(i) @@ -582,18 +670,21 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) trim(adjustl(plev))//'-mb omega', 'Pa/s', missing_value=missing_value) enddo - idiag%id_u_plev = register_diag_field ( trim(field), 'u_plev', axe2(1:3), Time, & - 'zonal wind', 'm/sec', missing_value=missing_value, range=vrange ) - idiag%id_v_plev = register_diag_field ( trim(field), 'v_plev', axe2(1:3), Time, & - 'meridional wind', 'm/sec', missing_value=missing_value, range=vrange ) - idiag%id_t_plev = register_diag_field ( trim(field), 't_plev', axe2(1:3), Time, & - 'temperature', 'K', missing_value=missing_value, range=trange ) - idiag%id_h_plev = register_diag_field ( trim(field), 'h_plev', axe2(1:3), Time, & - 'height', 'm', missing_value=missing_value ) - idiag%id_q_plev = register_diag_field ( trim(field), 'q_plev', axe2(1:3), Time, & - 'specific humidity', 'kg/kg', missing_value=missing_value ) - idiag%id_omg_plev = register_diag_field ( trim(field), 'omg_plev', axe2(1:3), Time, & - 'omega', 'Pa/s', missing_value=missing_value ) + if (Atm(n)%flagstruct%write_3d_diags) then + idiag%id_u_plev = register_diag_field ( trim(field), 'u_plev', axe2(1:3), Time, & + 'zonal wind', 'm/sec', missing_value=missing_value, range=vrange ) + idiag%id_v_plev = register_diag_field ( trim(field), 'v_plev', axe2(1:3), Time, & + 'meridional wind', 'm/sec', missing_value=missing_value, range=vrange ) + idiag%id_t_plev = register_diag_field ( trim(field), 't_plev', axe2(1:3), Time, & + 'temperature', 'K', missing_value=missing_value, range=trange ) + idiag%id_h_plev = register_diag_field ( trim(field), 'h_plev', axe2(1:3), Time, & + 'height', 'm', missing_value=missing_value ) + idiag%id_q_plev = register_diag_field ( trim(field), 'q_plev', axe2(1:3), Time, & + 'specific humidity', 'kg/kg', missing_value=missing_value ) + idiag%id_omg_plev = register_diag_field ( trim(field), 'omg_plev', axe2(1:3), Time, & + 'omega', 'Pa/s', missing_value=missing_value ) + endif + ! flag for calculation of geopotential if ( all(idiag%id_h(minloc(abs(levs-10)))>0) .or. all(idiag%id_h(minloc(abs(levs-50)))>0) .or. & @@ -601,9 +692,9 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) all(idiag%id_h(minloc(abs(levs-250)))>0) .or. all(idiag%id_h(minloc(abs(levs-300)))>0) .or. & all(idiag%id_h(minloc(abs(levs-500)))>0) .or. all(idiag%id_h(minloc(abs(levs-700)))>0) .or. & all(idiag%id_h(minloc(abs(levs-850)))>0) .or. all(idiag%id_h(minloc(abs(levs-1000)))>0) ) then - idiag%id_hght = 1 + idiag%id_any_hght = 1 else - idiag%id_hght = 0 + idiag%id_any_hght = 0 endif !----------------------------- ! mean temp between 300-500 mb @@ -672,6 +763,10 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) 'omega', 'Pa/s', missing_value=missing_value ) idiag%id_divg = register_diag_field ( trim(field), 'divg', axes(1:3), Time, & 'mean divergence', '1/s', missing_value=missing_value ) + + idiag%id_hght3d = register_diag_field( trim(field), 'hght', axes(1:3), Time, & + 'height', 'm', missing_value=missing_value ) + ! diagnotic output for skeb testing idiag%id_diss = register_diag_field ( trim(field), 'diss_est', axes(1:3), Time, & 'random', 'none', missing_value=missing_value, range=skrange ) @@ -719,6 +814,24 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) idiag%id_pv = register_diag_field ( trim(field), 'pv', axes(1:3), Time, & 'potential vorticity', '1/s', missing_value=missing_value ) + ! ------------------- + ! Vertical flux correlation terms (good for averages) + ! ------------------- + idiag%id_uw = register_diag_field ( trim(field), 'uw', axes(1:3), Time, & + 'vertical zonal momentum flux', 'N/m**2', missing_value=missing_value ) + idiag%id_vw = register_diag_field ( trim(field), 'vw', axes(1:3), Time, & + 'vertical meridional momentum flux', 'N/m**', missing_value=missing_value ) + idiag%id_hw = register_diag_field ( trim(field), 'hw', axes(1:3), Time, & + 'vertical heat flux', 'W/m**2', missing_value=missing_value ) + idiag%id_qvw = register_diag_field ( trim(field), 'qvw', axes(1:3), Time, & + 'vertical water vapor flux', 'kg/m**2/s', missing_value=missing_value ) + idiag%id_qlw = register_diag_field ( trim(field), 'qlw', axes(1:3), Time, & + 'vertical liquid water flux', 'kg/m**2/s', missing_value=missing_value ) + idiag%id_qiw = register_diag_field ( trim(field), 'qiw', axes(1:3), Time, & + 'vertical ice water flux', 'kg/m**2/s', missing_value=missing_value ) + idiag%id_o3w = register_diag_field ( trim(field), 'o3w', axes(1:3), Time, & + 'vertical ozone flux', 'kg/m**2/s', missing_value=missing_value ) + endif ! Total energy (only when moist_phys = .T.) @@ -741,7 +854,7 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) 'Reflectivity at -10C level', 'm', missing_value=missing_value) !-------------------------- -! Extra surface diagnistics: +! Extra surface diagnostics: !-------------------------- ! Surface (lowest layer) vorticity: for tropical cyclones diag. idiag%id_vorts = register_diag_field ( trim(field), 'vorts', axes(1:2), Time, & @@ -770,6 +883,22 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) 'Convective available potential energy (surface-based)', 'J/kg' , missing_value=missing_value ) idiag%id_cin = register_diag_field( trim(field), 'cin', axes(1:2), Time, & 'Convective inhibition (surface-based)', 'J/kg' , missing_value=missing_value ) +!-------------------------- +! Vertically integrated tracers for GFDL MP +!-------------------------- + idiag%id_intqv = register_diag_field ( trim(field), 'intqv', axes(1:2), Time, & + 'Vertically Integrated Water Vapor', 'kg/m**2', missing_value=missing_value ) + idiag%id_intql = register_diag_field ( trim(field), 'intql', axes(1:2), Time, & + 'Vertically Integrated Cloud Water', 'kg/m**2', missing_value=missing_value ) + idiag%id_intqi = register_diag_field ( trim(field), 'intqi', axes(1:2), Time, & + 'Vertically Integrated Cloud Ice', 'kg/m**2', missing_value=missing_value ) + idiag%id_intqr = register_diag_field ( trim(field), 'intqr', axes(1:2), Time, & + 'Vertically Integrated Rain', 'kg/m**2', missing_value=missing_value ) + idiag%id_intqs = register_diag_field ( trim(field), 'intqs', axes(1:2), Time, & + 'Vertically Integrated Snow', 'kg/m**2', missing_value=missing_value ) + idiag%id_intqg = register_diag_field ( trim(field), 'intqg', axes(1:2), Time, & + 'Vertically Integrated Graupel', 'kg/m**2', missing_value=missing_value ) + #ifdef HIWPP idiag%id_acl = register_diag_field ( trim(field), 'acl', axes(1:2), Time, & 'Column-averaged Cl mixing ratio', 'kg/kg', missing_value=missing_value ) @@ -1009,6 +1138,144 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) Atm(n)%ps, Atm(n)%delp, Atm(n)%q, Atm(n)%gridstruct%area_64, Atm(n)%domain) #endif + + !Set up debug column diagnostics, if desired + !Start by hard-coding one diagnostic column then add options for more later + + diag_debug_names(:) = '' + diag_debug_lon_in(:) = -999. + diag_debug_lat_in(:) = -999. + + !diag_debug_names(1:2) = (/'ORD','Princeton'/) + !diag_debug_lon_in(1:2) = (/272.,285.33/) + !diag_debug_lat_in(1:2) = (/42.,40.36/) + + diag_sonde_names(:) = '' + diag_sonde_lon_in(:) = -999. + diag_sonde_lat_in(:) = -999. + + !diag_sonde_names(1:4) = (/'OUN','MYNN','PIT', 'ORD'/) + !diag_sonde_lon_in(1:4) = (/285.33,282.54,279.78,272./) + !diag_sonde_lat_in(1:4) = (/35.18,25.05,40.53,42./) + + +#ifdef INTERNAL_FILE_NML + read(input_nml_file, nml=fv_diag_column_nml,iostat=ios) +#else + inquire (file=trim(Atm(n)%nml_filename), exist=exists) + if (.not. exists) then + write(errmsg,*) 'fv_diag_column_nml: namelist file ',trim(Atm(n)%nml_filename),' does not exist' + call mpp_error(FATAL, errmsg) + else + open (unit=nlunit, file=Atm(n)%nml_filename, READONLY, status='OLD', iostat=ios) + endif + rewind(nlunit) + read (nlunit, nml=fv_diag_column_nml, iostat=ios) + close (nlunit) +#endif + + call column_diagnostics_init + + if (do_diag_debug) then + + !Determine number of debug columns + do m=1,MAX_DIAG_COLUMN + !if (is_master()) print*, i, diag_debug_names(m), len(trim(diag_debug_names(m))), diag_debug_lon_in(m), diag_debug_lat_in(m) + if (len(trim(diag_debug_names(m))) == 0 .or. diag_debug_lon_in(m) < -180. .or. diag_debug_lat_in(m) < -90.) exit + num_diag_debug = num_diag_debug + 1 + if (diag_debug_lon_in(m) < 0.) diag_debug_lon_in(m) = diag_debug_lon_in(m) + 360. + enddo + + if (num_diag_debug == 0) do_diag_debug = .FALSE. + + endif + + if (do_diag_debug) then + + allocate(do_debug_diag_column(isc:iec,jsc:jec)) + allocate(diag_debug_lon(num_diag_debug)) + allocate(diag_debug_lat(num_diag_debug)) + allocate(diag_debug_i(num_diag_debug)) + allocate(diag_debug_j(num_diag_debug)) + allocate(diag_debug_units(num_diag_debug)) + + + call initialize_diagnostic_columns("DEBUG", num_diag_pts_latlon=num_diag_debug, num_diag_pts_ij=0, & + global_i=(/1/), global_j=(/1/), & + global_lat_latlon=diag_debug_lat_in, global_lon_latlon=diag_debug_lon_in, & + lonb_in=Atm(n)%gridstruct%agrid(isc:iec,jsc:jec,1), latb_in=Atm(n)%gridstruct%agrid(isc:iec,jsc:jec,2), & + do_column_diagnostics=do_debug_diag_column, & + diag_lon=diag_debug_lon, diag_lat=diag_debug_lat, diag_i=diag_debug_i, diag_j=diag_debug_j, diag_units=diag_debug_units) + + do m=1,num_diag_debug + diag_debug_i(m) = diag_debug_i(m) + isc - 1 + diag_debug_j(m) = diag_debug_j(m) + jsc - 1 + + if (diag_debug_i(m) >= isc .and. diag_debug_i(m) <= iec .and. & + diag_debug_j(m) >= jsc .and. diag_debug_j(m) <= jec ) then + write(*,'(A, 1x, I04, 1x, A, 4F7.2, 2I5)') 'DEBUG POINT: ', mpp_pe(), diag_debug_names(m), diag_debug_lon_in(m), diag_debug_lat_in(m), & + Atm(n)%gridstruct%agrid(diag_debug_i(m), diag_debug_j(m),1)*rad2deg, Atm(n)%gridstruct%agrid(diag_debug_i(m), diag_debug_j(m),2)*rad2deg, & + diag_debug_i(m), diag_debug_j(m) + endif + enddo + + endif + + + !Radiosondes + if (do_diag_sonde) then + + !Determine number of sonde columns + do m=1,MAX_DIAG_COLUMN + if (len(trim(diag_sonde_names(m))) == 0 .or. diag_sonde_lon_in(m) < -180. .or. diag_sonde_lat_in(m) < -90.) exit + !if (is_master()) print*, i, diag_sonde_names(m), len(trim(diag_sonde_names(m))), diag_sonde_lon_in(m), diag_sonde_lat_in(m) + num_diag_sonde = num_diag_sonde + 1 + if (diag_sonde_lon_in(m) < 0.) diag_sonde_lon_in(m) = diag_sonde_lon_in(m) + 360. + enddo + + if (num_diag_sonde == 0) do_diag_sonde = .FALSE. + + endif + + if (do_diag_sonde) then + + allocate(do_sonde_diag_column(isc:iec,jsc:jec)) + allocate(diag_sonde_lon(num_diag_sonde)) + allocate(diag_sonde_lat(num_diag_sonde)) + allocate(diag_sonde_i(num_diag_sonde)) + allocate(diag_sonde_j(num_diag_sonde)) + allocate(diag_sonde_units(num_diag_sonde)) + + call initialize_diagnostic_columns("Sounding", num_diag_pts_latlon=num_diag_sonde, num_diag_pts_ij=0, & + global_i=(/1/), global_j=(/1/), & + global_lat_latlon=diag_sonde_lat_in, global_lon_latlon=diag_sonde_lon_in, & + lonb_in=Atm(n)%gridstruct%agrid(isc:iec,jsc:jec,1), latb_in=Atm(n)%gridstruct%agrid(isc:iec,jsc:jec,2), & + do_column_diagnostics=do_sonde_diag_column, & + diag_lon=diag_sonde_lon, diag_lat=diag_sonde_lat, diag_i=diag_sonde_i, diag_j=diag_sonde_j, diag_units=diag_sonde_units) + + do m=1,num_diag_sonde + diag_sonde_i(m) = diag_sonde_i(m) + isc - 1 + diag_sonde_j(m) = diag_sonde_j(m) + jsc - 1 + + if (diag_sonde_i(m) >= isc .and. diag_sonde_i(m) <= iec .and. & + diag_sonde_j(m) >= jsc .and. diag_sonde_j(m) <= jec ) then + write(*,'(A, 1x, I04, 1x, A, 4F7.2, 2I5)') 'SONDE POINT: ', mpp_pe(), diag_sonde_names(m), diag_sonde_lon_in(m), diag_sonde_lat_in(m), & + Atm(n)%gridstruct%agrid(diag_sonde_i(m), diag_sonde_j(m),1)*rad2deg, Atm(n)%gridstruct%agrid(diag_sonde_i(m), diag_sonde_j(m),2)*rad2deg, & + diag_sonde_i(m), diag_sonde_j(m) + endif + enddo + + endif + + !Model initialization time (not necessarily the time this simulation is started, + ! conceivably a restart could be done + if (m_calendar) then + call get_date(Atm(n)%Time_init, yr_init, mo_init, dy_init, hr_init, mn_init, sec_init) + else + call get_time(Atm(n)%Time_init, sec_init, dy_init) + yr_init = 0 ; mo_init = 0 ; hr_init = 0 ; mn_init = 0 + endif + call nullify_domain() ! Nullify set_domain info module_is_initialized=.true. @@ -1118,8 +1385,10 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) real, parameter:: ws_1 = 20. real, parameter:: vort_c0= 2.2e-5 logical, allocatable :: storm(:,:), cat_crt(:,:) - real :: tmp2, pvsum, e2, einf, qm, mm, maxdbz, allmax, rgrav - integer :: Cl, Cl2 + real :: tmp2, pvsum, e2, einf, qm, mm, maxdbz, allmax, rgrav, cv_vapor + real, allocatable :: cvm(:) + integer :: Cl, Cl2, k1, k2 + !!! CLEANUP: does it really make sense to have this routine loop over Atm% anymore? We assume n=1 below anyway ! cat15: SLP<1000; srf_wnd>ws_0; vort>vort_c0 @@ -1172,6 +1441,12 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) else prt_minmax = mod(hr, print_freq) == 0 .and. mn==0 .and. seconds==0 endif + + if ( sound_freq == 0 .or. .not. do_diag_sonde ) then + prt_sounding = .false. + else + prt_sounding = mod(hr, sound_freq) == 0 .and. mn == 0 .and. seconds == 0 + endif else call get_time (fv_time, seconds, days) if( print_freq == 0 ) then @@ -1182,6 +1457,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) else prt_minmax = mod(seconds, 3600*print_freq) == 0 endif + + if ( sound_freq == 0 .or. .not. do_diag_sonde ) then + prt_sounding = .false. + else + prt_sounding = mod(seconds, 3600*sound_freq) == 0 + endif + endif if(prt_minmax) then @@ -1280,19 +1562,21 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) elseif ( Atm(n)%flagstruct%range_warn ) then call range_check('DELP', Atm(n)%delp, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, & - 0.01*ptop, 200.E2, bad_range) + 0.01*ptop, 200.E2, bad_range, Time) call range_check('UA', Atm(n)%ua, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, & - -250., 250., bad_range) + -250., 250., bad_range, Time) call range_check('VA', Atm(n)%va, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, & - -250., 250., bad_range) + -250., 250., bad_range, Time) #ifndef SW_DYNAMICS call range_check('TA', Atm(n)%pt, isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, & #ifdef HIWPP - 130., 350., bad_range) !DCMIP ICs have very low temperatures + 130., 350., bad_range, Time) !DCMIP ICs have very low temperatures #else - 150., 350., bad_range) + 150., 350., bad_range, Time) #endif #endif + call range_check('Qv', Atm(n)%q(:,:,:,sphum), isc, iec, jsc, jec, ngc, npz, Atm(n)%gridstruct%agrid, & + -1.e-8, 1.e20, bad_range, Time) endif @@ -1312,6 +1596,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) #endif if(idiag%id_ps > 0) used=send_data(idiag%id_ps, Atm(n)%ps(isc:iec,jsc:jec), Time) + if (idiag%id_qv_dt_phys > 0) used=send_data(idiag%id_qv_dt_phys, Atm(n)%phys_diag%phys_qv_dt(isc:iec,jsc:jec,1:npz), Time) + if (idiag%id_ql_dt_phys > 0) used=send_data(idiag%id_ql_dt_phys, Atm(n)%phys_diag%phys_ql_dt(isc:iec,jsc:jec,1:npz), Time) + if (idiag%id_qi_dt_phys > 0) used=send_data(idiag%id_qi_dt_phys, Atm(n)%phys_diag%phys_qi_dt(isc:iec,jsc:jec,1:npz), Time) + if (idiag%id_t_dt_phys > 0) used=send_data(idiag%id_t_dt_phys, Atm(n)%phys_diag%phys_t_dt(isc:iec,jsc:jec,1:npz), Time) + if (idiag%id_u_dt_phys > 0) used=send_data(idiag%id_u_dt_phys, Atm(n)%phys_diag%phys_u_dt(isc:iec,jsc:jec,1:npz), Time) + if (idiag%id_v_dt_phys > 0) used=send_data(idiag%id_v_dt_phys, Atm(n)%phys_diag%phys_v_dt(isc:iec,jsc:jec,1:npz), Time) + if(idiag%id_c15>0 .or. idiag%id_c25>0 .or. idiag%id_c35>0 .or. idiag%id_c45>0) then call wind_max(isc, iec, jsc, jec ,isd, ied, jsd, jed, Atm(n)%ua(isc:iec,jsc:jec,npz), & Atm(n)%va(isc:iec,jsc:jec,npz), ws_max, Atm(n)%domain) @@ -1745,7 +2036,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) - if( idiag%id_slp>0 .or. idiag%id_tm>0 .or. idiag%id_hght>0 .or. idiag%id_c15>0 .or. idiag%id_ctz>0 ) then + if( idiag%id_slp>0 .or. idiag%id_tm>0 .or. idiag%id_any_hght>0 .or. idiag%id_hght3d>0 .or. idiag%id_c15>0 .or. idiag%id_ctz>0 ) then allocate ( wz(isc:iec,jsc:jec,npz+1) ) call get_height_field(isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%delz, & @@ -1754,11 +2045,20 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) call prt_mxm('ZTOP',wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3, Atm(n)%gridstruct%area_64, Atm(n)%domain) ! call prt_maxmin('ZTOP', wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3) + if (idiag%id_hght3d > 0) then + used = send_data(idiag%id_hght3d, 0.5*(wz(isc:iec,jsc:jec,1:npz)+wz(isc:iec,jsc:jec,2:npz+1)), Time) + endif + if(idiag%id_slp > 0) then ! Cumpute SLP (pressure at height=0) allocate ( slp(isc:iec,jsc:jec) ) call get_pressure_given_height(isc, iec, jsc, jec, ngc, npz, wz, 1, height(2), & Atm(n)%pt(:,:,npz), Atm(n)%peln, slp, 0.01) + + if ( Atm(n)%flagstruct%range_warn ) then + call range_check('SLP', slp, isc, iec, jsc, jec, 0, Atm(n)%gridstruct%agrid, & + slprange(1), slprange(2), bad_range, Time) + endif used = send_data (idiag%id_slp, slp, Time) if( prt_minmax ) then call prt_maxmin('SLP', slp, isc, iec, jsc, jec, 0, 1, 1.) @@ -1778,7 +2078,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif ! Compute H3000 and/or H500 - if( idiag%id_tm>0 .or. idiag%id_hght>0 .or. idiag%id_ppt>0) then + if( idiag%id_tm>0 .or. idiag%id_any_hght>0 .or. idiag%id_ppt>0) then allocate( a3(isc:iec,jsc:jec,nplev) ) @@ -1810,46 +2110,14 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if( prt_minmax ) then if(all(idiag%id_h(minloc(abs(levs-100)))>0)) & - call prt_mxm('Z100',a3(isc:iec,jsc:jec,11),isc,iec,jsc,jec,0,1,1.E-3,Atm(n)%gridstruct%area_64,Atm(n)%domain) + call prt_mxm('Z100',a3(isc:iec,jsc:jec,k100),isc,iec,jsc,jec,0,1,1.E-3,Atm(n)%gridstruct%area_64,Atm(n)%domain) if(all(idiag%id_h(minloc(abs(levs-500)))>0)) then - if (.not. Atm(n)%neststruct%nested) then -#ifdef TO_BE_DELETED - t_eq = 0. ; t_nh = 0.; t_sh = 0.; t_gb = 0. - area_eq = 0.; area_nh = 0.; area_sh = 0.; area_gb = 0. - do j=jsc,jec - do i=isc,iec - slat = Atm(n)%gridstruct%agrid(i,j,2)*rad2deg - area_gb = area_gb + Atm(n)%gridstruct%area(i,j) - t_gb = t_gb + a3(i,j,19)*Atm(n)%gridstruct%area(i,j) - if( (slat>-20. .and. slat<20.) ) then -! Tropics: - area_eq = area_eq + Atm(n)%gridstruct%area(i,j) - t_eq = t_eq + a3(i,j,19)*Atm(n)%gridstruct%area(i,j) - elseif( slat>=20. .and. slat<80. ) then -! NH - area_nh = area_nh + Atm(n)%gridstruct%area(i,j) - t_nh = t_nh + a3(i,j,19)*Atm(n)%gridstruct%area(i,j) - elseif( slat<=-20. .and. slat>-80. ) then -! SH - area_sh = area_sh + Atm(n)%gridstruct%area(i,j) - t_sh = t_sh + a3(i,j,19)*Atm(n)%gridstruct%area(i,j) - endif - enddo - enddo - call mp_reduce_sum(area_gb) - call mp_reduce_sum( t_gb) - call mp_reduce_sum(area_nh) - call mp_reduce_sum( t_nh) - call mp_reduce_sum(area_sh) - call mp_reduce_sum( t_sh) - call mp_reduce_sum(area_eq) - call mp_reduce_sum( t_eq) - if (master) write(*,*) 'Z500 GB_NH_SH_EQ=', t_gb/area_gb, t_nh/area_nh, t_sh/area_sh, t_eq/area_eq -#endif -! call prt_mxm('Z500',a3(isc:iec,jsc:jec,19),isc,iec,jsc,jec,0,1,1.,Atm(n)%gridstruct%area_64,Atm(n)%domain) - call prt_gb_nh_sh('fv_GFS Z500', isc,iec, jsc,jec, a3(isc,jsc,19), Atm(n)%gridstruct%area_64(isc:iec,jsc:jec), & - Atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2)) + if (Atm(n)%gridstruct%bounded_domain) then + call prt_mxm('Z500',a3(isc:iec,jsc:jec,k500),isc,iec,jsc,jec,0,1,1.,Atm(n)%gridstruct%area_64,Atm(n)%domain) + else + call prt_gb_nh_sh('fv_GFS Z500', isc,iec, jsc,jec, a3(isc,jsc,k500), Atm(n)%gridstruct%area_64(isc:iec,jsc:jec), & + Atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2)) endif endif @@ -1857,12 +2125,31 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) ! mean virtual temp 300mb to 500mb if( idiag%id_tm>0 ) then + k1 = -1 + k2 = -1 + do k=1,nplev + if (abs(levs(k)-500.) < 1.) then + k2 = k + exit + endif + enddo + do k=1,nplev + if (abs(levs(k)-300.) < 1.) then + k1 = k + exit + endif + enddo + if (k1 <= 0 .or. k2 <= 0) then + call mpp_error(NOTE, "Could not find levs for 300--500 mb mean temperature, setting to -1") + a2 = -1. + else do j=jsc,jec do i=isc,iec - a2(i,j) = grav*(a3(i,j,15)-a3(i,j,19))/(rdgas*(plevs(19)-plevs(15))) + a2(i,j) = grav*(a3(i,j,k2)-a3(i,j,k1))/(rdgas*(plevs(k1)-plevs(k2))) enddo enddo - used = send_data ( idiag%id_tm, a2, Time ) + endif + used = send_data ( idiag%id_tm, a2, Time ) endif if(idiag%id_c15>0 .or. idiag%id_c25>0 .or. idiag%id_c35>0 .or. idiag%id_c45>0) then @@ -2014,7 +2301,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if ( all(idiag%id_t(minloc(abs(levs-100)))>0) .and. prt_minmax ) then call prt_mxm('T100:', a3(isc:iec,jsc:jec,11), isc, iec, jsc, jec, 0, 1, 1., & Atm(n)%gridstruct%area_64, Atm(n)%domain) - if (.not. Atm(n)%neststruct%nested) then + if (.not. Atm(n)%gridstruct%bounded_domain) then tmp = 0. sar = 0. ! Compute mean temp at 100 mb near EQ @@ -2037,9 +2324,9 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif endif if ( all(idiag%id_t(minloc(abs(levs-200)))>0) .and. prt_minmax ) then - call prt_mxm('T200:', a3(isc:iec,jsc:jec,13), isc, iec, jsc, jec, 0, 1, 1., & + call prt_mxm('T200:', a3(isc:iec,jsc:jec,k200), isc, iec, jsc, jec, 0, 1, 1., & Atm(n)%gridstruct%area_64, Atm(n)%domain) - if (.not. Atm(n)%neststruct%nested) then + if (.not. Atm(n)%gridstruct%bounded_domain) then tmp = 0. sar = 0. do j=jsc,jec @@ -2047,7 +2334,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) slat = Atm(n)%gridstruct%agrid(i,j,2)*rad2deg if( (slat>-20 .and. slat<20) ) then sar = sar + Atm(n)%gridstruct%area(i,j) - tmp = tmp + a3(i,j,13)*Atm(n)%gridstruct%area(i,j) + tmp = tmp + a3(i,j,k200)*Atm(n)%gridstruct%area(i,j) endif enddo enddo @@ -2095,7 +2382,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) do k=1,npz do j=jsc,jec do i=isc,iec -! a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,1)*Atm(n)%delp(i,j,k) +! a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,1)*Atm(n)%delp(i,j,k) a2(i,j) = a2(i,j) + sum(Atm(n)%q(i,j,k,1:nwater))*Atm(n)%delp(i,j,k) enddo enddo @@ -2181,13 +2468,13 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) einf = max(einf, abs(a2(i,j) - qcly0)) enddo enddo - if (prt_minmax .and. .not. Atm(n)%neststruct%nested) then + if (prt_minmax .and. .not. Atm(n)%gridstruct%bounded_domain) then call mp_reduce_sum(qm) call mp_reduce_max(einf) call mp_reduce_sum(e2) if (master) then write(*,*) ' TERMINATOR TEST: ' - write(*,*) ' chlorine mass: ', real(qm)/(4.*pi*RADIUS*RADIUS) + write(*,*) ' chlorine mass: ', qm/(4.*pi*RADIUS*RADIUS) write(*,*) ' L2 err: ', sqrt(e2)/sqrt(4.*pi*RADIUS*RADIUS)/qcly0 write(*,*) ' max err: ', einf/qcly0 endif @@ -2255,6 +2542,88 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) used = send_data(idiag%id_lw, a2*ginv, Time) endif +!-------------------------- +! Vertically integrated tracers for GFDL MP +!-------------------------- + if ( idiag%id_intqv>0 ) then + a2 = 0. + if (sphum > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,sphum)*Atm(n)%delp(i,j,k) + enddo + enddo + enddo + endif + used = send_data(idiag%id_intqv, a2*ginv, Time) + endif + if ( idiag%id_intql>0 ) then + a2 = 0. + if (liq_wat > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,liq_wat)*Atm(n)%delp(i,j,k) + enddo + enddo + enddo + endif + used = send_data(idiag%id_intql, a2*ginv, Time) + endif + if ( idiag%id_intqi>0 ) then + a2 = 0. + if (ice_wat > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,ice_wat)*Atm(n)%delp(i,j,k) + enddo + enddo + enddo + endif + used = send_data(idiag%id_intqi, a2*ginv, Time) + endif + if ( idiag%id_intqr>0 ) then + a2 = 0. + if (rainwat > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,rainwat)*Atm(n)%delp(i,j,k) + enddo + enddo + enddo + endif + used = send_data(idiag%id_intqr, a2*ginv, Time) + endif + if ( idiag%id_intqs>0 ) then + a2 = 0. + if (snowwat > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,snowwat)*Atm(n)%delp(i,j,k) + enddo + enddo + enddo + endif + used = send_data(idiag%id_intqs, a2*ginv, Time) + endif + if ( idiag%id_intqg>0 ) then + a2 = 0. + if (graupel > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,graupel)*Atm(n)%delp(i,j,k) + enddo + enddo + enddo + endif + used = send_data(idiag%id_intqg, a2*ginv, Time) + endif + ! Cloud top temperature & cloud top press: if ( (idiag%id_ctt>0 .or. idiag%id_ctp>0 .or. idiag%id_ctz>0).and. Atm(n)%flagstruct%nwat==6) then allocate ( var1(isc:iec,jsc:jec) ) @@ -2271,8 +2640,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) var2(i,j) = wz(i,j,k) - wz(i,j,npz+1) ! height AGL exit elseif( k==npz ) then - a2(i,j) = missing_value2 - var1(i,j) = missing_value2 + a2(i,j) = missing_value3 + var1(i,j) = missing_value3 var2(i,j) = missing_value2 !!$ a2(i,j) = Atm(n)%pt(i,j,k) !!$ var1(i,j) = 0.01*Atm(n)%pe(i,k+1,j) ! surface pressure @@ -2406,6 +2775,112 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if(idiag%id_ua > 0) used=send_data(idiag%id_ua, Atm(n)%ua(isc:iec,jsc:jec,:), Time) if(idiag%id_va > 0) used=send_data(idiag%id_va, Atm(n)%va(isc:iec,jsc:jec,:), Time) + if(idiag%id_uw > 0 .or. idiag%id_vw > 0 .or. idiag%id_hw > 0 .or. idiag%id_qvw > 0 .or. & + idiag%id_qlw > 0 .or. idiag%id_qiw > 0 .or. idiag%id_o3w > 0 ) then + allocate( a3(isc:iec,jsc:jec,npz) ) + + do k=1,npz + do j=jsc,jec + do i=isc,iec + wk(i,j,k) = Atm(n)%w(i,j,k)*Atm(n)%delp(i,j,k)*ginv + enddo + enddo + enddo + + if (idiag%id_uw > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a3(i,j,k) = Atm(n)%ua(i,j,k)*wk(i,j,k) + enddo + enddo + enddo + used = send_data(idiag%id_uw, a3, Time) + endif + if (idiag%id_vw > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a3(i,j,k) = Atm(n)%va(i,j,k)*wk(i,j,k) + enddo + enddo + enddo + used = send_data(idiag%id_vw, a3, Time) + endif + + if (idiag%id_hw > 0) then + allocate(cvm(isc:iec)) + do k=1,npz + do j=jsc,jec +#ifdef USE_COND + call moist_cv(isc,iec,isd,ied,jsd,jed,npz,j,k,Atm(n)%flagstruct%nwat,sphum,liq_wat,rainwat, & + ice_wat,snowwat,graupel,Atm(n)%q,Atm(n)%q_con(isc:iec,j,k),cvm) + do i=isc,iec + a3(i,j,k) = Atm(n)%pt(i,j,k)*cvm(i)*wk(i,j,k) + enddo +#else + cv_vapor = cp_vapor - rvgas + do i=isc,iec + a3(i,j,k) = Atm(n)%pt(i,j,k)*cv_vapor*wk(i,j,k) + enddo +#endif + enddo + enddo + used = send_data(idiag%id_hw, a3, Time) + deallocate(cvm) + endif + + if (idiag%id_qvw > 0) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + a3(i,j,k) = Atm(n)%q(i,j,k,sphum)*wk(i,j,k) + enddo + enddo + enddo + used = send_data(idiag%id_qvw, a3, Time) + endif + if (idiag%id_qlw > 0) then + if (liq_wat < 0 .or. rainwat < 0) call mpp_error(FATAL, 'qlw does not work without liq_wat and rainwat defined') + do k=1,npz + do j=jsc,jec + do i=isc,iec + a3(i,j,k) = (Atm(n)%q(i,j,k,liq_wat)+Atm(n)%q(i,j,k,rainwat))*wk(i,j,k) + enddo + enddo + enddo + used = send_data(idiag%id_qlw, a3, Time) + endif + if (idiag%id_qiw > 0) then + if (ice_wat < 0 .or. snowwat < 0 .or. graupel < 0) then + call mpp_error(FATAL, 'qiw does not work without ice_wat, snowwat, and graupel defined') + endif + do k=1,npz + do j=jsc,jec + do i=isc,iec + a3(i,j,k) = (Atm(n)%q(i,j,k,ice_wat)+Atm(n)%q(i,j,k,snowwat)+Atm(n)%q(i,j,k,graupel))*wk(i,j,k) + enddo + enddo + enddo + used = send_data(idiag%id_qiw, a3, Time) + endif + if (idiag%id_o3w > 0) then + if (o3mr < 0) then + call mpp_error(FATAL, 'o3w does not work without o3mr defined') + endif + do k=1,npz + do j=jsc,jec + do i=isc,iec + a3(i,j,k) = Atm(n)%q(i,j,k,o3mr)*wk(i,j,k) + enddo + enddo + enddo + used = send_data(idiag%id_o3w, a3, Time) + endif + + deallocate(a3) + endif + if(idiag%id_ke > 0) then a2(:,:) = 0. do k=1,npz @@ -2497,8 +2972,9 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) allocate(var2(isc:iec,jsc:jec)) allocate(a3(isc:iec,jsc:jec,npz)) - call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd:ied,jsd:jed,1:npz,sphum), & - isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys) + + call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd,jsd,1,sphum), & + isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys) !$OMP parallel do default(shared) do j=jsc,jec @@ -2564,7 +3040,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) used=send_data(idiag%id_pmaskv2, a2, Time) endif - if ( idiag%id_u100m>0 .or. idiag%id_v100m>0 .or. idiag%id_w100m>0 .or. idiag%id_w5km>0 .or. idiag%id_w2500m>0 .or. idiag%id_w1km>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0) then + if ( idiag%id_u100m>0 .or. idiag%id_v100m>0 .or. idiag%id_w100m>0 .or. idiag%id_w5km>0 .or. idiag%id_w2500m>0 & + & .or. idiag%id_w1km>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0) then if (.not.allocated(wz)) allocate ( wz(isc:iec,jsc:jec,npz+1) ) if ( Atm(n)%flagstruct%hydrostatic) then rgrav = 1. / grav @@ -2635,7 +3112,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if(prt_minmax) call prt_maxmin('v100m', a2, isc, iec, jsc, jec, 0, 1, 1.) endif - if ( rainwat > 0 .and. (idiag%id_dbz>0 .or. idiag%id_maxdbz>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0 .or. idiag%id_dbztop>0 .or. idiag%id_dbz_m10C>0)) then + if ( rainwat > 0 .and. (idiag%id_dbz>0 .or. idiag%id_maxdbz>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0 & + & .or. idiag%id_dbztop>0 .or. idiag%id_dbz_m10C>0)) then if (.not. allocated(a3)) allocate(a3(isc:iec,jsc:jec,npz)) @@ -2662,7 +3140,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) if (idiag%id_dbztop > 0) then do j=jsc,jec do i=isc,iec - a2(i,j) = missing_value + a2(i,j) = missing_value2 do k=2,npz if (wz(i,j,k) >= 25000. ) continue ! nothing above 25 km if (a3(i,j,k) >= 18.5 ) then @@ -2697,6 +3175,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) deallocate(a3) endif + !------------------------------------------------------- ! Applying cubic-spline as the intepolator for (u,v,T,q) !------------------------------------------------------- @@ -2898,7 +3377,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo enddo else - call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd:ied,jsd:jed,1:npz,sphum), & + call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd,jsd,1,sphum), & isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys) endif @@ -2943,6 +3422,22 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) #else idiag%pt1 = 0. #endif + if (.not. Atm(n)%flagstruct%hydrostatic) then + do k=1,npz + do j=jsc,jec + do i=isc,iec + wk(i,j,k) = (Atm(n)%pt(i,j,k)*exp(-kappa*log(-Atm(n)%delp(i,j,k)/(Atm(n)%delz(i,j,k)*grav)*rdgas* & +#ifdef MULTI_GASES + Atm(n)%pt(i,j,k)*virq(Atm(n)%q(i,j,k,1:num_gas)))) - idiag%pt1(k)) * pk0 +#else + Atm(n)%pt(i,j,k)*(1.+zvir*Atm(n)%q(i,j,k,sphum)))) - idiag%pt1(k)) * pk0 +#endif +! Atm(n)%pkz(i,j,k) = exp(kappa*log(-Atm(n)%delp(i,j,k)/(Atm(n)%delz(i,j,k)*grav)*rdgas* & +! Atm(n)%pt(i,j,k)*(1.+zvir*Atm(n)%q(i,j,k,sphum)))) + enddo + enddo + enddo + else do k=1,npz do j=jsc,jec do i=isc,iec @@ -2951,6 +3446,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo enddo enddo + endif used=send_data(idiag%id_ppt, wk, Time) if( prt_minmax ) then @@ -3005,7 +3501,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) enddo ! Maximum overlap cloud fraction - if ( .not. Atm(n)%neststruct%nested ) then + if ( .not. Atm(n)%gridstruct%bounded_domain ) then if ( cld_amt > 0 .and. prt_minmax ) then a2(:,:) = 0. do k=1,npz @@ -3022,6 +3518,18 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) #endif + if (do_diag_debug) then + call debug_column(Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%q, & + Atm(n)%npz, Atm(n)%ncnst, sphum, Atm(n)%flagstruct%nwat, Atm(n)%flagstruct%hydrostatic, Atm(n)%bd, Time) + endif + + if (prt_sounding) then + call sounding_column(Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%u, Atm(n)%v, Atm(n)%q, Atm(n)%peln, Atm(n)%pkz, Atm(n)%phis, & + Atm(n)%npz, Atm(n)%ncnst, sphum, Atm(n)%flagstruct%nwat, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys, & + zvir, Atm(n)%ng, Atm(n)%bd, Time) + endif + + ! enddo ! end ntileMe do-loop deallocate ( a2 ) @@ -3112,7 +3620,7 @@ subroutine get_height_field(is, ie, js, je, ng, km, hydrostatic, delz, wz, pt, q real, intent(in):: peln(is:ie,km+1,js:je) real, intent(in):: pt(is-ng:ie+ng,js-ng:je+ng,km) real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) ! water vapor - real, intent(in):: delz(is-ng:,js-ng:,1:) + real, intent(in):: delz(is:,js:,1:) real, intent(in):: zvir logical, intent(in):: hydrostatic real, intent(out):: wz(is:ie,js:je,km+1) @@ -3149,7 +3657,7 @@ subroutine get_height_field(is, ie, js, je, ng, km, hydrostatic, delz, wz, pt, q end subroutine get_height_field - subroutine range_check(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_range) + subroutine range_check_3d(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_range, Time) character(len=*), intent(in):: qname integer, intent(in):: is, ie, js, je integer, intent(in):: n_g, km @@ -3157,9 +3665,11 @@ subroutine range_check(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_ real, intent(in):: pos(is-n_g:ie+n_g, js-n_g:je+n_g,2) real, intent(in):: q_low, q_hi logical, optional, intent(out):: bad_range + type(time_type), optional, intent(IN) :: Time ! real qmin, qmax integer i,j,k + integer year, month, day, hour, minute, second if ( present(bad_range) ) bad_range = .false. qmin = q(is,js,1) @@ -3182,6 +3692,11 @@ subroutine range_check(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_ if( qminq_hi ) then if(master) write(*,*) 'Range_check Warning:', qname, ' max = ', qmax, ' min = ', qmin + if (present(Time)) then + call get_date(Time, year, month, day, hour, minute, second) + if (master) write(*,999) year, month, day, hour, minute, second +999 format(' Range violation on: ', I4, '/', I02, '/', I02, ' ', I02, ':', I02, ':', I02) + endif if ( present(bad_range) ) then bad_range = .true. endif @@ -3194,9 +3709,12 @@ subroutine range_check(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_ do j=js,je do i=is,ie if( q(i,j,k)q_hi ) then - write(*,*) 'Warn_K=',k,'(i,j)=',i,j, pos(i,j,1)*rad2deg, pos(i,j,2)*rad2deg, q(i,j,k) - if ( k/= 1 ) write(*,*) k-1, q(i,j,k-1) - if ( k/=km ) write(*,*) k+1, q(i,j,k+1) + write(*,998) k,i,j, pos(i,j,1)*rad2deg, pos(i,j,2)*rad2deg, qname, q(i,j,k) +! write(*,*) 'Warn_K=',k,'(i,j)=',i,j, pos(i,j,1)*rad2deg, pos(i,j,2)*rad2deg, q(i,j,k) +998 format('Warn_K=',I4,' (i,j)=',2I5,' (lon,lat)=',f7.3,1x,f7.3,1x, A,' =',f10.5) +997 format(' K=',I4,3x,f10.5) + if ( k/= 1 ) write(*,997) k-1, q(i,j,k-1) + if ( k/=km ) write(*,997) k+1, q(i,j,k+1) endif enddo enddo @@ -3204,7 +3722,65 @@ subroutine range_check(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_ call mpp_error(NOTE,'==> Error from range_check: data out of bound') endif - end subroutine range_check + end subroutine range_check_3d + + subroutine range_check_2d(qname, q, is, ie, js, je, n_g, pos, q_low, q_hi, bad_range, Time) + character(len=*), intent(in):: qname + integer, intent(in):: is, ie, js, je + integer, intent(in):: n_g + real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g) + real, intent(in):: pos(is-n_g:ie+n_g, js-n_g:je+n_g,2) + real, intent(in):: q_low, q_hi + logical, optional, intent(out):: bad_range + type(time_type), optional, intent(IN) :: Time +! + real qmin, qmax + integer i,j + integer year, month, day, hour, minute, second + + if ( present(bad_range) ) bad_range = .false. + qmin = q(is,js) + qmax = qmin + + do j=js,je + do i=is,ie + if( q(i,j) < qmin ) then + qmin = q(i,j) + elseif( q(i,j) > qmax ) then + qmax = q(i,j) + endif + enddo + enddo + + call mp_reduce_min(qmin) + call mp_reduce_max(qmax) + + if( qminq_hi ) then + if(master) write(*,*) 'Range_check Warning:', qname, ' max = ', qmax, ' min = ', qmin + if (present(Time)) then + call get_date(Time, year, month, day, hour, minute, second) + if (master) write(*,999) year, month, day, hour, minute, second +999 format(' Range violation on: ', I4, '/', I02, '/', I02, ' ', I02, ':', I02, ':', I02) + endif + if ( present(bad_range) ) then + bad_range = .true. + endif + endif + + if ( present(bad_range) ) then +! Print out where the bad value(s) is (are) + if ( bad_range .EQV. .false. ) return + do j=js,je + do i=is,ie + if( q(i,j)q_hi ) then + write(*,*) 'Warn_(i,j)=',i,j, pos(i,j,1)*rad2deg, pos(i,j,2)*rad2deg, q(i,j) + endif + enddo + enddo + call mpp_error(NOTE,'==> Error from range_check: data out of bound') + endif + + end subroutine range_check_2d subroutine prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac) character(len=*), intent(in):: qname @@ -3545,7 +4121,7 @@ subroutine prt_height(qname, is, ie, js, je, ng, km, press, phis, delz, peln, ar real, intent(in):: press real, intent(in):: peln(is:ie,km+1,js:je) real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng) - real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(in):: delz(is:,js:,1:) real(kind=R_GRID), intent(in), dimension(is:ie, js:je):: area, lat ! local: real:: a2(is:ie,js:je) !< height (m) @@ -3922,7 +4498,7 @@ subroutine helicity_relative(is, ie, js, je, ng, km, zvir, sphum, srh, & integer, intent(in):: is, ie, js, je, ng, km, sphum real, intent(in):: grav, zvir, z_bot, z_top real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, ua, va - real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(in):: delz(is:ie,js:je,km) real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng) real, intent(in):: peln(is:ie,km+1,js:je) @@ -4012,7 +4588,7 @@ subroutine helicity_relative_CAPS(is, ie, js, je, ng, km, zvir, sphum, srh, uc, integer, intent(in):: is, ie, js, je, ng, km, sphum real, intent(in):: grav, zvir, z_bot, z_top real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, ua, va - real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(in):: delz(is:ie,js:je,km) real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng) real, intent(in):: peln(is:ie,km+1,js:je) @@ -4048,7 +4624,7 @@ subroutine helicity_relative_CAPS(is, ie, js, je, ng, km, zvir, sphum, srh, uc, zh0 = 0. below = .true. - K_LOOP:do k=km,1,-1 + do k=km,1,-1 if ( hydrostatic ) then #ifdef MULTI_GASES dz(i) = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j)) @@ -4069,10 +4645,11 @@ subroutine helicity_relative_CAPS(is, ie, js, je, ng, km, zvir, sphum, srh, uc, elseif ( zh(i) < z_top ) then k0 = k else - EXIT K_LOOP + goto 123 endif - enddo K_LOOP + enddo +123 continue ! Lowest layer wind shear computed betw top edge and mid-layer k = k1 @@ -4094,7 +4671,7 @@ subroutine bunkers_vector(is, ie, js, je, ng, km, zvir, sphum, uc, vc, & integer, intent(in):: is, ie, js, je, ng, km, sphum real, intent(in):: grav, zvir real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, ua, va - real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(in):: delz(is:ie,js:je,km) real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng) real, intent(in):: peln(is:ie,km+1,js:je) @@ -4130,7 +4707,7 @@ subroutine bunkers_vector(is, ie, js, je, ng, km, zvir, sphum, uc, vc, & usfc = ua(i,j,km) vsfc = va(i,j,km) - K_LOOP:do k=km,1,-1 + do k=km,1,-1 if ( hydrostatic ) then #ifdef MULTI_GASES dz = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j)) @@ -4149,10 +4726,11 @@ subroutine bunkers_vector(is, ie, js, je, ng, km, zvir, sphum, uc, vc, & umn = umn + ua(i,j,k)*dz vmn = vmn + va(i,j,k)*dz else - EXIT K_LOOP + goto 123 endif - enddo K_LOOP + enddo +123 continue u6km = u6km + (ua(i,j,k) - u6km) / dz * (6000. - (zh - dz)) v6km = v6km + (va(i,j,k) - v6km) / dz * (6000. - (zh - dz)) @@ -4179,7 +4757,7 @@ subroutine updraft_helicity(is, ie, js, je, ng, km, zvir, sphum, uh, & real, intent(in):: grav, zvir, z_bot, z_top real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, w real, intent(in), dimension(is:ie,js:je,km):: vort - real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(in):: delz(is:ie,js:je,km) real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng) real, intent(in):: peln(is:ie,km+1,js:je) @@ -4482,7 +5060,7 @@ subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, np real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz,*):: qi #endif real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz):: pt, delp, q - real, intent(in), dimension(is-ng: ,js-ng: ,1: ):: delz + real, intent(in), dimension(is: ,js: ,1: ):: delz real, intent(in), dimension(is:ie,npz+1,js:je):: peln real, intent(in):: pkz(is:ie,js:je,npz) logical, intent(in):: hydrostatic, moist @@ -4591,6 +5169,9 @@ subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, qi, is, ie, js, je, ng, n subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, npz, & #endif hydrostatic, moist) +! calculate the equvalent potential temperature +! author: Xi.Chen@noaa.gov +! created on: 07/28/2015 ! Modified by SJL integer, intent(in):: is,ie,js,je,ng,npz #ifdef MULTI_GASES @@ -4599,7 +5180,7 @@ subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, np real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz):: q #endif real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz):: pt, delp - real, intent(in), dimension(is-ng: ,js-ng: ,1: ):: delz + real, intent(in), dimension(is: ,js: ,1: ):: delz real, intent(in), dimension(is:ie,npz+1,js:je):: peln real, intent(in):: pkz(is:ie,js:je,npz) logical, intent(in):: hydrostatic, moist @@ -4699,10 +5280,14 @@ subroutine nh_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, & w, delz, pt, delp, q, hs, area, domain, & sphum, liq_wat, rainwat, ice_wat, & snowwat, graupel, nwat, ua, va, moist_phys, te) -! INPUT PARAMETERS: +!------------------------------------------------------ +! Compute vertically integrated total energy per column +!------------------------------------------------------ +! !INPUT PARAMETERS: integer, intent(in):: km, is, ie, js, je, isd, ied, jsd, jed integer, intent(in):: nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel - real, intent(in), dimension(isd:ied,jsd:jed,km):: ua, va, pt, delp, w, delz + real, intent(in), dimension(isd:ied,jsd:jed,km):: ua, va, pt, delp, w + real, intent(in), dimension(is:ie,js:je,km) :: delz real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q real, intent(in):: hs(isd:ied,jsd:jed) !< surface geopotential real, intent(in):: area(isd:ied, jsd:jed) @@ -4830,7 +5415,8 @@ subroutine dbzcalc(q, pt, delp, peln, delz, & type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npz, ncnst - real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz) :: pt, delp, delz + real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz) :: pt, delp + real, intent(IN), dimension(bd%is:, bd%js:, 1:) :: delz real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst) :: q real, intent(IN), dimension(bd%is :bd%ie, npz+1, bd%js:bd%je) :: peln real, intent(OUT), dimension(bd%is :bd%ie, bd%js :bd%je , npz) :: dbz @@ -4841,9 +5427,6 @@ subroutine dbzcalc(q, pt, delp, peln, delz, & !Parameters for constant intercepts (in0[rsg] = .false.) !Using GFDL MP values - real(kind=R_GRID), parameter:: rn0_r = 8.e6 ! m^-4 - real(kind=R_GRID), parameter:: rn0_s = 3.e6 ! m^-4 - real(kind=R_GRID), parameter:: rn0_g = 4.e6 ! m^-4 real(kind=R_GRID), parameter:: vconr = 2503.23638966667 real(kind=R_GRID), parameter:: vcong = 87.2382675 real(kind=R_GRID), parameter:: vcons = 6.6280504 @@ -4863,29 +5446,27 @@ subroutine dbzcalc(q, pt, delp, peln, delz, & real, parameter :: ron_delqr0 = 0.25*ron_qr0 real, parameter :: ron_const1r = (ron2-ron_min)*0.5 real, parameter :: ron_const2r = (ron2+ron_min)*0.5 + real, parameter :: rnzs = 3.0e6 ! lin83 !Other constants real, parameter :: gamma_seven = 720. !The following values are also used in GFDL MP - real, parameter :: rho_r = 1.0e3 ! LFO83 - real, parameter :: rho_s = 100. ! kg m^-3 - real, parameter :: rho_g0 = 400. ! kg m^-3 - real, parameter :: rho_g = 500. ! graupel-hail mix -! real, parameter :: rho_g = 900. ! hail/frozen rain - real, parameter :: alpha = 0.224 - real(kind=R_GRID), parameter :: factor_r = gamma_seven * 1.e18 * (1./(pi*rho_r))**1.75 - real(kind=R_GRID), parameter :: factor_s = gamma_seven * 1.e18 * (1./(pi*rho_s))**1.75 & - * (rho_s/rho_r)**2 * alpha - real(kind=R_GRID), parameter :: factor_g = gamma_seven * 1.e18 * (1./(pi*rho_g))**1.75 & - * (rho_g/rho_r)**2 * alpha + real, parameter :: rhor = 1.0e3 ! LFO83 + real, parameter :: rhos = 100. ! kg m^-3 + real, parameter :: rhog0 = 400. ! kg m^-3 + real, parameter :: rhog = 500. ! graupel-hail mix +! real, parameter :: rho_g = 900. ! hail/frozen rain + real, parameter :: alpha = 0.224 + real(kind=R_GRID), parameter :: factor_s = gamma_seven * 1.e18 * (1./(pi*rhos))**1.75 & + * (rhos/rhor)**2 * alpha real, parameter :: qmin = 1.E-12 real, parameter :: tice = 273.16 ! Double precision - real(kind=R_GRID):: rhoair(bd%is:bd%ie) - real(kind=R_GRID):: qr1, qs1, qg1, t1, t2, t3, rwat, denfac, vtr, vtg, vts + real(kind=R_GRID), dimension(bd%is:bd%ie) :: rhoair, denfac, z_e + real(kind=R_GRID):: qr1, qs1, qg1, t1, t2, t3, rwat, vtr, vtg, vts real(kind=R_GRID):: factorb_s, factorb_g - real(kind=R_GRID):: temp_c, pres, sonv, gonv, ronv, z_e + real(kind=R_GRID):: temp_c, pres, sonv, gonv, ronv integer :: i,j,k integer :: is, ie, js, je @@ -4911,32 +5492,44 @@ subroutine dbzcalc(q, pt, delp, peln, delz, & #else rhoair(i) = delp(i,j,k)/( (peln(i,k+1,j)-peln(i,k,j)) * rdgas * pt(i,j,k) * ( 1. + zvir*q(i,j,k,sphum) ) ) #endif + denfac(i) = sqrt(min(10., 1.2/rhoair(i))) + z_e(i) = 0. enddo else do i=is, ie rhoair(i) = -delp(i,j,k)/(grav*delz(i,j,k)) ! moist air density + denfac(i) = sqrt(min(10., 1.2/rhoair(i))) + z_e(i) = 0. enddo endif + if (rainwat > 0) then do i=is, ie ! The following form vectorizes better & more consistent with GFDL_MP -! SJL notes: Marshall-Palmer, dBZ = 200*precip**1.6, precip = 3.6e6*t1/rho_r*vtr ! [mm/hr] +! SJL notes: Marshall-Palmer, dBZ = 200*precip**1.6, precip = 3.6e6*t1/rhor*vtr ! [mm/hr] ! GFDL_MP terminal fall speeds are used ! Date modified 20170701 ! Account for excessively high cloud water -> autoconvert (diag only) excess cloud water t1 = rhoair(i)*max(qmin, q(i,j,k,rainwat)+dim(q(i,j,k,liq_wat), 1.0e-3)) - t2 = rhoair(i)*max(qmin, q(i,j,k,snowwat)) - if (graupel > 0) then - t3 = rhoair(i)*max(qmin, q(i,j,k,graupel)) - else - t3 = rhoair(i)*qmin - endif - denfac = sqrt(min(10., 1.2/rhoair(i))) - vtr = max(1.e-3, vconr*denfac*exp(0.2 *log(t1/normr))) - vtg = max(1.e-3, vcong*denfac*exp(0.125 *log(t3/normg))) -! vts = max(1.e-3, vcons*denfac*exp(0.0625*log(t2/norms))) - z_e = 200.*(exp(1.6*log(3.6e6*t1/rho_r*vtr)) + exp(1.6*log(3.6e6*t3/rho_g0*vtg))) + (factor_s/alpha)*t2*exp(0.75*log(t2/rn0_s)) -! z_e = 200.*(exp(1.6*log(3.6e6*t1/rho_r*vtr)) + exp(1.6*log(3.6e6*t3/rho_g*vtg)) + exp(1.6*log(3.6e6*t2/rho_s*vts))) - dbz(i,j,k) = 10.*log10( max(0.01, z_e) ) + vtr = max(1.e-3, vconr*denfac(i)*exp(0.2 *log(t1/normr))) + z_e(i) = 200.*exp(1.6*log(3.6e6*t1/rhor*vtr)) + enddo + endif + if (graupel > 0) then + do i=is, ie + t3 = rhoair(i)*max(qmin, q(i,j,k,graupel)) + vtg = max(1.e-3, vcong*denfac(i)*exp(0.125 *log(t3/normg))) + z_e(i) = z_e(i) + 200.*exp(1.6*log(3.6e6*t3/rhog*vtg)) + enddo + endif + if (snowwat > 0) then + do i=is, ie + t2 = rhoair(i)*max(qmin, q(i,j,k,snowwat)) + ! vts = max(1.e-3, vcons*denfac*exp(0.0625*log(t2/norms))) + z_e(i) = z_e(i) + (factor_s/alpha)*t2*exp(0.75*log(t2/rnzs)) + enddo + endif + do i=is,ie + dbz(i,j,k) = 10.*log10( max(0.01, z_e(i)) ) enddo enddo enddo @@ -4979,7 +5572,7 @@ subroutine max_vorticity(is, ie, js, je, ng, km, zvir, sphum, delz, q, hydrostat real, intent(in):: grav, zvir, z_bot, z_top real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt real, intent(in), dimension(is:ie,js:je,km):: vort - real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(in):: delz(is:ie,js:je,km) real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng) real, intent(in):: peln(is:ie,km+1,js:je) @@ -5003,7 +5596,11 @@ subroutine max_vorticity(is, ie, js, je, ng, km, zvir, sphum, delz, q, hydrostat K_LOOP:do k=km,1,-1 if ( hydrostatic ) then +#ifdef MULTI_GASES + dz(i) = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j)) +#else dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j)) +#endif else dz(i) = - delz(i,j,k) endif @@ -5033,7 +5630,7 @@ subroutine max_uh(is, ie, js, je, ng, km, zvir, sphum, uphmax,uphmin, & real, intent(in):: grav, zvir, z_bot, z_top real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, w real, intent(in), dimension(is:ie,js:je,km):: vort - real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(in):: delz(is:ie,js:je,km) real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng) real, intent(in):: peln(is:ie,km+1,js:je) @@ -5060,7 +5657,11 @@ subroutine max_uh(is, ie, js, je, ng, km, zvir, sphum, uphmax,uphmin, & ! if ( phis(i,j)/grav < 1.E3 ) then K_LOOP:do k=km,1,-1 if ( hydrostatic ) then +#ifdef MULTI_GASES + dz(i) = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j)) +#else dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j)) +#endif else dz(i) = - delz(i,j,k) endif @@ -5475,19 +6076,15 @@ subroutine getcape( nk , p , t , dz, q, the, cape , cin, source_in ) if(i.gt.90) print *,i,th2,thlast,th2-thlast if(i.gt.100)then - print * - print *,' Error: lack of convergence' - print * - print *,' ... stopping iteration ' - print * - stop 1001 + print *,' getcape() error: lack of convergence, stopping iteration' + not_converged = .false. endif if( abs(th2-thlast).gt.converge )then thlast=thlast+0.3*(th2-thlast) else not_converged = .false. endif - enddo + enddo ! Latest pressure increment is complete. Calculate some ! important stuff: @@ -5571,8 +6168,23 @@ subroutine getcape( nk , p , t , dz, q, the, cape , cin, source_in ) return end subroutine getcape -!----------------------------------------------------------------------- +!!$ subroutine divg_diagnostics(divg, ..., idiag, bd, npz,gridstruct%area_64, domain, fv_time)) +!!$ real, INPUT(IN) :: divg(bd%isd:bd%ied,bd%jsd:bd%jed,npz) +!!$ .... +!!$ +!!$ if (idiag%id_divg>0) then +!!$ used = send_data(idiag%id_divg, divg, fv_time) +!!$ +!!$ endif +!!$ +!!$ +!!$ if(flagstruct%fv_debug) call prt_mxm('divg', dp1, is, ie, js, je, 0, npz, 1.,gridstruct%area_64, domain) +!!$ end subroutine divg_diagnostics +!!$ +!----------------------------------------------------------------------- +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!----------------------------------------------------------------------- real function getqvs(p,t) implicit none @@ -5603,4 +6215,171 @@ real function getqvi(p,t) end function getqvi !----------------------------------------------------------------------- + subroutine debug_column(pt, delp, delz, u, v, w, q, npz, ncnst, sphum, nwat, hydrostatic, bd, Time) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npz, ncnst, sphum, nwat + logical, intent(IN) :: hydrostatic + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz), intent(IN) :: pt, delp, w + real, dimension(bd%is:, bd%js:,1:), intent(IN) :: delz + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz), intent(IN) :: u + real, dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed,npz), intent(IN) :: v + real, dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst), intent(IN) :: q + + + type(time_type), intent(IN) :: Time + integer :: i,j,k,n,l + real cond + + do n=1,size(diag_debug_i) + + i=diag_debug_i(n) + j=diag_debug_j(n) + + if (i < bd%is .or. i > bd%ie) cycle + if (j < bd%js .or. j > bd%je) cycle + + if (do_debug_diag_column(i,j)) then + call column_diagnostics_header(diag_debug_names(n), diag_debug_units(n), Time, n, & + diag_debug_lon, diag_debug_lat, diag_debug_i, diag_debug_j) + + write(diag_debug_units(n),'(A4, A7, A8, A6, A8, A8, A8, A8, A9)') 'k', 'T', 'delp', 'delz', 'u', 'v', 'w', 'sphum', 'cond' + write(diag_debug_units(n),'(A4, A7, A8, A6, A8, A8, A8, A8, A9)') '', 'K', 'mb', 'm', 'm/s', 'm/s', 'm/s', 'g/kg', 'g/kg' + if (hydrostatic) then + call mpp_error(NOTE, 'Hydrostatic debug sounding not yet supported') + else + do k=2*npz/3,npz + cond = 0. + do l=2,nwat + cond = cond + q(i,j,k,l) + enddo + write(diag_debug_units(n),'(I4, F7.2, F8.3, I6, F8.3, F8.3, F8.3, F8.3, F9.5 )') & + k, pt(i,j,k), delp(i,j,k)*0.01, -int(delz(i,j,k)), u(i,j,k), v(i,j,k), w(i,j,k), & + q(i,j,k,sphum)*1000., cond*1000. + enddo + endif + + !call mpp_flush(diag_units(n)) + + endif + + enddo + + end subroutine debug_column + + subroutine sounding_column( pt, delp, delz, u, v, q, peln, pkz, phis, & + npz, ncnst, sphum, nwat, hydrostatic, moist_phys, zvir, ng, bd, Time ) + + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npz, ncnst, sphum, nwat, ng + real, intent(IN) :: zvir + logical, intent(IN) :: hydrostatic, moist_phys + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz), intent(IN) :: pt, delp + real, dimension(bd%is:, bd%js:, 1:), intent(IN) :: delz + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz), intent(IN) :: u + real, dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed,npz), intent(IN) :: v + real, dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst), intent(IN) :: q + real, dimension(bd%is:bd%ie,npz+1,bd%js:bd%je), intent(in):: peln + real, dimension(bd%is:bd%ie,bd%js:bd%je,npz), intent(in):: pkz + real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed), intent(IN) :: phis + type(time_type), intent(IN) :: Time + + real :: Tv, pres, hght(npz), dewpt, rh, mixr, tmp, qs(1), wspd, wdir, rpk, theta, thetav + real :: thetae(bd%is:bd%ie,bd%js:bd%je,npz) + + real, PARAMETER :: rgrav = 1./grav + real, PARAMETER :: rdg = -rdgas*rgrav + real, PARAMETER :: sounding_top = 10.e2 + real, PARAMETER :: ms_to_knot = 1.9438445 + real, PARAMETER :: p0 = 1000.e2 + + integer :: i, j, k, n + integer :: yr_v, mo_v, dy_v, hr_v, mn_v, sec_v ! need to get numbers for these + + if (.not. any(do_sonde_diag_column)) return + call get_date(Time, yr_v, mo_v, dy_v, hr_v, mn_v, sec_v) + call eqv_pot(thetae, pt, delp, delz, peln, pkz, q(bd%isd,bd%jsd,1,sphum), & + bd%is, bd%ie, bd%js, bd%je, ng, npz, hydrostatic, moist_phys) + + do n=1,size(diag_sonde_i) + + i=diag_sonde_i(n) + j=diag_sonde_j(n) + + if (i < bd%is .or. i > bd%ie) cycle + if (j < bd%js .or. j > bd%je) cycle + + if (do_sonde_diag_column(i,j)) then + !call column_diagnostics_header(diag_sonde_names(n), diag_sonde_units(n), Time, n, & + ! diag_sonde_lon, diag_sonde_lat, diag_sonde_i, diag_sonde_j) + + write(diag_sonde_units(n),600) & + trim(diag_sonde_names(n)), yr_v, mo_v, dy_v, hr_v, yr_init, mo_init, dy_init, hr_init, trim(runname) +600 format(A,'.v', I4, I2.2, I2.2, I2.2, '.i', I4, I2.2, I2.2, I2.2, '.', A, '.dat########################################################') + write(diag_sonde_units(n),601) trim(diag_sonde_names(n)), yr_v, mo_v, dy_v, hr_v, yr_init, mo_init, dy_init, hr_init, & + trim(runname), diag_sonde_lon(n), diag_sonde_lat(n) +601 format(3x, A16, ' Valid ', I4, I2.2, I2.2, '.', I2.2, 'Z Init ', I4, I2.2, I2.2, '.', I2.2, 'Z \n', A, 2F8.3) + write(diag_sonde_units(n),*) + write(diag_sonde_units(n),*) '-------------------------------------------------------------------------------' + write(diag_sonde_units(n),'(11A7)') 'PRES', 'HGHT', "TEMP", "DWPT", "RELH", "MIXR", "DRCT", "SKNT", "THTA", "THTE", "THTV" + write(diag_sonde_units(n),'(11A7)') 'hPa', 'm', 'C', 'C', '%', 'g/kg', 'deg', 'knot', 'K', 'K', 'K' + write(diag_sonde_units(n),*) '-------------------------------------------------------------------------------' + + if (hydrostatic) then + call mpp_error(NOTE, 'Hydrostatic diagnostic sounding not yet supported') + else + hght(npz) = phis(i,j)*rgrav - 0.5*delz(i,j,npz) + do k=npz-1,1,-1 + hght(k) = hght(k+1) - 0.5*(delz(i,j,k)+delz(i,j,k+1)) + enddo + + do k=npz,1,-1 + +#ifdef MULTI_GASES + Tv = pt(i,j,k)*virq(q(i,j,k,1:num_gas)) +#else + Tv = pt(i,j,k)*(1.+zvir*q(i,j,k,sphum)) +#endif + pres = delp(i,j,k)/delz(i,j,k)*rdg*Tv + !if (pres < sounding_top) cycle + +#ifdef MULTI_GASES + call qsmith((bd%ie-bd%is+1)*(bd%je-bd%js+1), npz, & + 1, 1, pt(i,j,k:k), & + (/pres/), q(i,j,k:k,sphum), qs) +#else + call qsmith(1, 1, 1, pt(i,j,k:k), & + (/pres/), q(i,j,k:k,sphum), qs) +#endif + + mixr = q(i,j,k,sphum)/(1.-sum(q(i,j,k,1:nwat))) ! convert from sphum to mixing ratio + rh = q(i,j,k,sphum)/qs(1) + tmp = ( log(max(rh,1.e-2))/ 17.27 + ( pt(i,j,k) - 273.14 )/ ( -35.84 + pt(i,j,k)) ) + dewpt = 237.3* tmp/ ( 1. - tmp ) ! deg C + wspd = 0.5*sqrt((u(i,j,k)+u(i,j+1,k))*(u(i,j,k)+u(i,j+1,k)) + (v(i,j,k)+v(i+1,j,k))*(v(i,j,k)+v(i+1,j,k)))*ms_to_knot ! convert to knots + if (wspd > 0.01) then + !https://www.eol.ucar.edu/content/wind-direction-quick-reference + wdir = atan2(u(i,j,k)+u(i,j+1,k),v(i,j,k)+v(i+1,j,k)) * rad2deg + else + wdir = 0. + endif + rpk = exp(-kappa*log(pres/p0)) + theta = pt(i,j,k)*rpk + thetav = Tv*rpk + + write(diag_sonde_units(n),'(F7.1, I7, F7.1, F7.1, I7, F7.2, I7, F7.2, F7.1, F7.1, F7.1)') & + pres*1.e-2, int(hght(k)), pt(i,j,k)-TFREEZE, dewpt, int(rh*100.), mixr*1.e3, int(wdir), wspd, theta, thetae(i,j,k), thetav + enddo + endif + + !call mpp_flush(diag_units(n)) + + endif + + enddo + + + end subroutine sounding_column + + end module fv_diagnostics_mod diff --git a/tools/fv_eta.F90 b/tools/fv_eta.F90 index 3c49530f8..ece1a3f0c 100644 --- a/tools/fv_eta.F90 +++ b/tools/fv_eta.F90 @@ -54,9 +54,11 @@ module fv_eta_mod contains -!!!NOTE: USE_VAR_ETA not used in fvGFS +!!!NOTE: USE_VAR_ETA not used in SHiELD +!!! This routine will be kept here +!!! for the time being to not disrupt idealized tests #ifdef USE_VAR_ETA - subroutine set_eta(km, ks, ptop, ak, bk) + subroutine set_eta(km, ks, ptop, ak, bk, npz_type) ! This is the easy to use version of the set_eta integer, intent(in):: km ! vertical dimension integer, intent(out):: ks ! number of pure p layers @@ -107,6 +109,7 @@ subroutine set_eta(km, ks, ptop, ak, bk) real, intent(out):: ak(km+1) real, intent(out):: bk(km+1) real, intent(out):: ptop ! model top (Pa) + character(24), intent(IN) :: npz_type real pint, stretch_fac integer k real :: s_rate = -1.0 ! dummy value to not use var_les @@ -278,1234 +281,476 @@ subroutine set_eta(km, ks, ptop, ak, bk) end subroutine set_eta - subroutine mount_waves(km, ak, bk, ptop, ks, pint) - integer, intent(in):: km - real, intent(out):: ak(km+1), bk(km+1) - real, intent(out):: ptop, pint - integer, intent(out):: ks -! Local - real, parameter:: p00 = 1.E5 - real, dimension(km+1):: ze, pe1, peln, eta - real, dimension(km):: dz, dlnp - real ztop, t0, dz0, sum1, tmp1 - real ep, es, alpha, beta, gama, s_fac - integer k, k500 - - pint = 300.e2 -! s_fac = 1.05 -! dz0 = 500. - if ( km <= 60 ) then - s_fac = 1.0 - dz0 = 500. - else - s_fac = 1. - dz0 = 250. - endif - -! Basic parameters for HIWPP mountain waves - t0 = 300. -! ztop = 20.0e3; 500-m resolution in halft of the vertical domain -! ztop = real(km-1)*500. -!----------------------- -! Compute temp ptop based on isothermal atm -! ptop = p00*exp(-grav*ztop/(rdgas*t0)) - -! Lowest half has constant resolution - ze(km+1) = 0. - do k=km, km-19, -1 - ze(k) = ze(k+1) + dz0 - enddo - -! Stretching from 10-km and up: - do k=km-20, 3, -1 - dz0 = s_fac * dz0 - ze(k) = ze(k+1) + dz0 - enddo - ze(2) = ze(3) + sqrt(2.)*dz0 - ze(1) = ze(2) + 2.0*dz0 - -! call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 1) - -! Given z --> p - do k=1,km - dz(k) = ze(k) - ze(k+1) - dlnp(k) = grav*dz(k) / (rdgas*t0) - enddo - - pe1(km+1) = p00 - peln(km+1) = log(p00) - do k=km,1,-1 - peln(k) = peln(k+1) - dlnp(k) - pe1(k) = exp(peln(k)) - enddo -! Comnpute new ptop - ptop = pe1(1) +#else + !This is the version of set_eta used in SHiELD and AM4 + subroutine set_eta(km, ks, ptop, ak, bk, npz_type) -! Pe(k) = ak(k) + bk(k) * PS -! Locate pint and KS - ks = 0 - do k=2,km - if ( pint < pe1(k)) then - ks = k-1 - exit - endif - enddo +!Level definitions are now in this header file +#include - if ( is_master() ) then - write(*,*) 'For (input) PINT=', 0.01*pint, ' KS=', ks, 'pint(computed)=', 0.01*pe1(ks+1) - write(*,*) 'Modified ptop =', ptop, ' ztop=', ze(1)/1000. - do k=1,km - write(*,*) k, 'ze =', ze(k)/1000. - enddo - endif - pint = pe1(ks+1) + integer, intent(in):: km ! vertical dimension + integer, intent(out):: ks ! number of pure p layers + real, intent(out):: ak(km+1) + real, intent(out):: bk(km+1) + real, intent(out):: ptop ! model top (Pa) + character(24), intent(IN) :: npz_type -#ifdef NO_UKMO_HB - do k=1,ks+1 - ak(k) = pe1(k) - bk(k) = 0. - enddo + real:: p0=1000.E2 + real:: pc=200.E2 - do k=ks+2,km+1 - bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma - ak(k) = pe1(k) - bk(k) * pe1(km+1) - enddo - bk(km+1) = 1. - ak(km+1) = 0. -#else -! Problematic for non-hydrostatic - do k=1,km+1 - eta(k) = pe1(k) / pe1(km+1) - enddo - ep = eta(ks+1) - es = eta(km) -! es = 1. - alpha = (ep**2-2.*ep*es) / (es-ep)**2 - beta = 2.*ep*es**2 / (es-ep)**2 - gama = -(ep*es)**2 / (es-ep)**2 - -! Pure pressure: - do k=1,ks+1 - ak(k) = eta(k)*1.e5 - bk(k) = 0. - enddo + real pt, lnpe, dlnp + real press(km+1), pt1(km) + integer k + integer :: var_fn = 0 - do k=ks+2, km - ak(k) = alpha*eta(k) + beta + gama/eta(k) - ak(k) = ak(k)*1.e5 - enddo - ak(km+1) = 0. + real :: pint = 100.E2 + real :: stretch_fac = 1.03 + integer :: auto_routine = 0 - do k=ks+2, km - bk(k) = (pe1(k) - ak(k))/pe1(km+1) - enddo - bk(km+1) = 1. -#endif - if ( is_master() ) then - tmp1 = ak(ks+1) - do k=ks+1,km - tmp1 = max(tmp1, (ak(k)-ak(k+1))/max(1.E-5, (bk(k+1)-bk(k))) ) - enddo - write(*,*) 'Hybrid Sigma-P: minimum allowable surface pressure (hpa)=', tmp1/100. - endif + ptop = 1. - end subroutine mount_waves + ! Definition: press(i,j,k) = ak(k) + bk(k) * ps(i,j) -#else - !>This is the version of set_eta used in fvGFS and AM4 - !>@note 01/2018: 'set_eta' is being cleaned up. - subroutine set_eta(km, ks, ptop, ak, bk) - integer, intent(in):: km !< vertical dimension - integer, intent(out):: ks !< number of pure p layers - real, intent(out):: ak(km+1) - real, intent(out):: bk(km+1) - real, intent(out):: ptop !< model top (Pa) -! local - real a24(25),b24(25) !< GFDL AM2L24 - real a26(27),b26(27) !< Jablonowski & Williamson 26-level - real a32(33),b32(33) - real a32w(33),b32w(33) - real a47(48),b47(48) - real a48(49),b48(49) - real a52(53),b52(53) - real a54(55),b54(55) - real a56(57),b56(57) - real a60(61),b60(61) - real a63(64),b63(64) - real a64(65),b64(65) - real a68(69),b68(69) !< cjg: grid with enhanced PBL resolution - real a96(97),b96(97) !< cjg: grid with enhanced PBL resolution - real a100(101),b100(101) - real a104(105),b104(105) - real a125(126),b125(126) - - real:: p0=1000.E2 - real:: pc=200.E2 - - real pt, pint, lnpe, dlnp - real press(km+1), pt1(km) - integer k + if (trim(npz_type) == 'superC' .or. trim(npz_type) == 'superK') then -! Definition: press(i,j,k) = ak(k) + bk(k) * ps(i,j) - -!----------------------------------------------- -! GFDL AM2-L24: modified by SJL at the model top -!----------------------------------------------- -! data a24 / 100.0000, 1050.0000, 3474.7942, 7505.5556, 12787.2428, & - data a24 / 100.0000, 903.4465, 3474.7942, 7505.5556, 12787.2428, & - 19111.3683, 21854.9274, 22884.1866, 22776.3058, 21716.1604, & - 20073.2963, 18110.5123, 16004.7832, 13877.6253, 11812.5452, & - 9865.8840, 8073.9726, 6458.0834, 5027.9899, 3784.6085, & - 2722.0086, 1828.9752, 1090.2396, 487.4595, 0.0000 / - - data b24 / 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, & - 0.0000000, 0.0435679, 0.1102275, 0.1922249, 0.2817656, & - 0.3694997, 0.4532348, 0.5316253, 0.6038733, 0.6695556, & - 0.7285176, 0.7808017, 0.8265992, 0.8662148, 0.9000406, & - 0.9285364, 0.9522140, 0.9716252, 0.9873523, 1.0000000 / - -! Jablonowski & Williamson 26-level setup - data a26 / 219.4067, 489.5209, 988.2418, 1805.2010, 2983.7240, 4462.3340, & - 6160.5870, 7851.2430, 7731.2710, 7590.1310, 7424.0860, & - 7228.7440, 6998.9330, 6728.5740, 6410.5090, 6036.3220, & - 5596.1110, 5078.2250, 4468.9600, 3752.1910, 2908.9490, & - 2084.739, 1334.443, 708.499, 252.1360, 0.0, 0.0 / - - data b26 / 0.0, 0.0, 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000,& - 0.0000000, 0.01505309, 0.03276228, 0.05359622, 0.07810627, & - 0.1069411, 0.1408637, 0.1807720, 0.2277220, 0.2829562, & - 0.3479364, 0.4243822, 0.5143168, 0.6201202, 0.7235355, & - 0.8176768, 0.8962153, 0.9534761, 0.9851122, 1.0000000 / - - -! High-resolution troposphere setup -#ifdef OLD_32 -! Revised Apr 14, 2004: PINT = 245.027 mb - data a32/100.00000, 400.00000, 818.60211, & - 1378.88653, 2091.79519, 2983.64084, & - 4121.78960, 5579.22148, 7419.79300, & - 9704.82578, 12496.33710, 15855.26306, & - 19839.62499, 24502.73262, 28177.10152, & - 29525.28447, 29016.34358, 27131.32792, & - 24406.11225, 21326.04907, 18221.18357, & - 15275.14642, 12581.67796, 10181.42843, & - 8081.89816, 6270.86956, 4725.35001, & - 3417.39199, 2317.75459, 1398.09473, & - 632.49506, 0.00000, 0.00000 / - - data b32/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.01711, & - 0.06479, 0.13730, 0.22693, & - 0.32416, 0.42058, 0.51105, & - 0.59325, 0.66628, 0.73011, & - 0.78516, 0.83217, 0.87197, & - 0.90546, 0.93349, 0.95685, & - 0.97624, 0.99223, 1.00000 / -#else -! SJL June 26, 2012 -! pint= 55.7922 - data a32/100.00000, 400.00000, 818.60211, & - 1378.88653, 2091.79519, 2983.64084, & - 4121.78960, 5579.22148, 6907.19063, & - 7735.78639, 8197.66476, 8377.95525, & - 8331.69594, 8094.72213, 7690.85756, & - 7139.01788, 6464.80251, 5712.35727, & - 4940.05347, 4198.60465, 3516.63294, & - 2905.19863, 2366.73733, 1899.19455, & - 1497.78137, 1156.25252, 867.79199, & - 625.59324, 423.21322, 254.76613, & - 115.06646, 0.00000, 0.00000 / - - data b32/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00513, & - 0.01969, 0.04299, 0.07477, & - 0.11508, 0.16408, 0.22198, & - 0.28865, 0.36281, 0.44112, & - 0.51882, 0.59185, 0.65810, & - 0.71694, 0.76843, 0.81293, & - 0.85100, 0.88331, 0.91055, & - 0.93338, 0.95244, 0.96828, & - 0.98142, 0.99223, 1.00000 / -#endif + auto_routine = 1 + select case (km) + case (20) + ptop = 56.e2 + pint = ptop + stretch_fac = 1.03 + case (24) + ptop = 56.e2 + pint = ptop + stretch_fac = 1.03 + case (30) + ptop = 56.e2 + pint = ptop + stretch_fac = 1.03 + case (40) + ptop = 56.e2 + pint = ptop + stretch_fac = 1.03 + case (50) + ptop = 56.e2 + pint = ptop + stretch_fac = 1.03 + case (60) + ptop = 56.e2 + pint = ptop + stretch_fac = 1.03 + case (80) + ptop = 56.e2 + pint = ptop + stretch_fac = 1.03 + case (90) ! super-duper cell + ptop = 40.e2 + stretch_fac = 1.025 + auto_routine = 2 + end select -!--------------------- -! Wilson's 32L settings: -!--------------------- -! Top changed to 0.01 mb - data a32w/ 1.00, 26.6378, 84.5529, 228.8592, & - 539.9597, 1131.7087, 2141.8082, 3712.0454, & - 5963.5317, 8974.1873, 12764.5388, 17294.5911, & - 20857.7007, 22221.8651, 22892.7202, 22891.1641, & - 22286.0724, 21176.0846, 19673.0671, 17889.0989, & - 15927.5060, 13877.6239, 11812.5474, 9865.8830, & - 8073.9717, 6458.0824, 5027.9893, 3784.6104, & - 2722.0093, 1828.9741, 1090.2397, 487.4575, & - 0.0000 / - - data b32w/ 0.0000, 0.0000, 0.0000, 0.0000, & - 0.0000, 0.0000, 0.0000, 0.0000, & - 0.0000, 0.0000, 0.0000, 0.0000, & - 0.0159, 0.0586, 0.1117, 0.1734, & - 0.2415, 0.3137, 0.3878, 0.4619, & - 0.5344, 0.6039, 0.6696, 0.7285, & - 0.7808, 0.8266, 0.8662, 0.9000, & - 0.9285, 0.9522, 0.9716, 0.9874, & - 1.0000 / - - -#ifdef OLD_L47 -! QBO setting with ptop = 0.1 mb and p_full=0.17 mb; pint ~ 100 mb - data a47/ 10.00000, 24.45365, 48.76776, & - 85.39458, 133.41983, 191.01402, & - 257.94919, 336.63306, 431.52741, & - 548.18995, 692.78825, 872.16512, & - 1094.18467, 1368.11917, 1704.99489, & - 2117.91945, 2622.42986, 3236.88281, & - 3982.89623, 4885.84733, 5975.43260, & - 7286.29500, 8858.72424, 10739.43477, & - 12982.41110, 15649.68745, 18811.37629, & - 22542.71275, 25724.93857, 27314.36781, & - 27498.59474, 26501.79312, 24605.92991, & - 22130.51655, 19381.30274, 16601.56419, & - 13952.53231, 11522.93244, 9350.82303, & - 7443.47723, 5790.77434, 4373.32696, & - 3167.47008, 2148.51663, 1293.15510, & - 581.62429, 0.00000, 0.00000 / - - data b47/ 0.0000, 0.0000, 0.0000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.01188, 0.04650, & - 0.10170, 0.17401, 0.25832, & - 0.34850, 0.43872, 0.52448, & - 0.60307, 0.67328, 0.73492, & - 0.78834, 0.83418, 0.87320, & - 0.90622, 0.93399, 0.95723, & - 0.97650, 0.99223, 1.00000 / -#else -! Oct 23, 2012 -! QBO setting with ptop = 0.1 mb, pint ~ 60 mb - data a47/ 10.00000, 24.45365, 48.76776, & - 85.39458, 133.41983, 191.01402, & - 257.94919, 336.63306, 431.52741, & - 548.18995, 692.78825, 872.16512, & - 1094.18467, 1368.11917, 1704.99489, & - 2117.91945, 2622.42986, 3236.88281, & - 3982.89623, 4885.84733, 5975.43260, & - 7019.26669, 7796.15848, 8346.60209, & - 8700.31838, 8878.27554, 8894.27179, & - 8756.46404, 8469.60171, 8038.92687, & - 7475.89006, 6803.68067, 6058.68992, & - 5285.28859, 4526.01565, 3813.00206, & - 3164.95553, 2589.26318, 2085.96929, & - 1651.11596, 1278.81205, 962.38875, & - 695.07046, 470.40784, 282.61654, & - 126.92745, 0.00000, 0.00000 / - data b47/ 0.0000, 0.0000, 0.0000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00267, 0.01063, 0.02393, & - 0.04282, 0.06771, 0.09917, & - 0.13786, 0.18444, 0.23925, & - 0.30193, 0.37100, 0.44379, & - 0.51695, 0.58727, 0.65236, & - 0.71094, 0.76262, 0.80757, & - 0.84626, 0.87930, 0.90731, & - 0.93094, 0.95077, 0.96733, & - 0.98105, 0.99223, 1.00000 / -#endif + else - data a48/ & - 1.00000, 2.69722, 5.17136, & - 8.89455, 14.24790, 22.07157, & - 33.61283, 50.48096, 74.79993, & - 109.40055, 158.00460, 225.44108, & - 317.89560, 443.19350, 611.11558, & - 833.74392, 1125.83405, 1505.20759, & - 1993.15829, 2614.86254, 3399.78420, & - 4382.06240, 5600.87014, 7100.73115, & - 8931.78242, 11149.97021, 13817.16841, & - 17001.20930, 20775.81856, 23967.33875, & - 25527.64563, 25671.22552, 24609.29622, & - 22640.51220, 20147.13482, 17477.63530, & - 14859.86462, 12414.92533, 10201.44191, & - 8241.50255, 6534.43202, 5066.17865, & - 3815.60705, 2758.60264, 1870.64631, & - 1128.33931, 510.47983, 0.00000, & - 0.00000 / - - data b48/ & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.01253, & - 0.04887, 0.10724, 0.18455, & - 0.27461, 0.36914, 0.46103, & - 0.54623, 0.62305, 0.69099, & - 0.75016, 0.80110, 0.84453, & - 0.88127, 0.91217, 0.93803, & - 0.95958, 0.97747, 0.99223, & - 1.00000 / - -! High PBL resolution with top at 1 mb -! SJL modified May 7, 2013 to ptop ~ 100 mb - data a54/100.00000, 254.83931, 729.54278, & - 1602.41121, 2797.50667, 4100.18977, & - 5334.87140, 6455.24153, 7511.80944, & - 8580.26355, 9714.44293, 10938.62253, & - 12080.36051, 12987.13921, 13692.75084, & - 14224.92180, 14606.55444, 14856.69953, & - 14991.32121, 15023.90075, 14965.91493, & - 14827.21612, 14616.33505, 14340.72252, & - 14006.94280, 13620.82849, 13187.60470, & - 12711.98873, 12198.27003, 11650.37451, & - 11071.91608, 10466.23819, 9836.44706, & - 9185.43852, 8515.96231, 7831.01080, & - 7135.14301, 6436.71659, 5749.00215, & - 5087.67188, 4465.67510, 3889.86419, & - 3361.63433, 2879.51065, 2441.02496, & - 2043.41345, 1683.80513, 1359.31122, & - 1067.09135, 804.40101, 568.62625, & - 357.32525, 168.33263, 0.00000, & - 0.00000 / - - data b54/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00180, 0.00694, 0.01510, & - 0.02601, 0.03942, 0.05515, & - 0.07302, 0.09288, 0.11459, & - 0.13803, 0.16307, 0.18960, & - 0.21753, 0.24675, 0.27716, & - 0.30866, 0.34115, 0.37456, & - 0.40879, 0.44375, 0.47935, & - 0.51551, 0.55215, 0.58916, & - 0.62636, 0.66334, 0.69946, & - 0.73395, 0.76622, 0.79594, & - 0.82309, 0.84780, 0.87020, & - 0.89047, 0.90876, 0.92524, & - 0.94006, 0.95336, 0.96529, & - 0.97596, 0.98551, 0.99400, & - 1.00000 / - - -! The 56-L setup - data a56/ 10.00000, 24.97818, 58.01160, & - 115.21466, 199.29210, 309.39897, & - 445.31785, 610.54747, 812.28518, & - 1059.80882, 1363.07092, 1732.09335, & - 2176.91502, 2707.68972, 3334.70962, & - 4068.31964, 4918.76594, 5896.01890, & - 7009.59166, 8268.36324, 9680.41211, & - 11252.86491, 12991.76409, 14901.95764, & - 16987.01313, 19249.15733, 21689.24182, & - 23845.11055, 25330.63353, 26243.52467, & - 26663.84998, 26657.94696, 26281.61371, & - 25583.05256, 24606.03265, 23393.39510, & - 21990.28845, 20445.82122, 18811.93894, & - 17139.59660, 15473.90350, 13850.50167, & - 12294.49060, 10821.62655, 9440.57746, & - 8155.11214, 6965.72496, 5870.70511, & - 4866.83822, 3949.90019, 3115.03562, & - 2357.07879, 1670.87329, 1051.65120, & - 495.51399, 0.00000, 0.00000 / - - data b56 /0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00462, 0.01769, 0.03821, & - 0.06534, 0.09834, 0.13659, & - 0.17947, 0.22637, 0.27660, & - 0.32929, 0.38343, 0.43791, & - 0.49162, 0.54361, 0.59319, & - 0.63989, 0.68348, 0.72391, & - 0.76121, 0.79545, 0.82679, & - 0.85537, 0.88135, 0.90493, & - 0.92626, 0.94552, 0.96286, & - 0.97840, 0.99223, 1.00000 / - - data a60/ 1.7861000000e-01, 1.0805100000e+00, 3.9647100000e+00, & - 9.7516000000e+00, 1.9816580000e+01, 3.6695950000e+01, & - 6.2550570000e+01, 9.9199620000e+01, 1.4792505000e+02, & - 2.0947487000e+02, 2.8422571000e+02, 3.7241721000e+02, & - 4.7437835000e+02, 5.9070236000e+02, 7.2236063000e+02, & - 8.7076746000e+02, 1.0378138800e+03, 1.2258877300e+03, & - 1.4378924600e+03, 1.6772726600e+03, 1.9480506400e+03, & - 2.2548762700e+03, 2.6030909400e+03, 2.9988059200e+03, & - 3.4489952300e+03, 3.9616028900e+03, 4.5456641600e+03, & - 5.2114401700e+03, 5.9705644000e+03, 6.8361981800e+03, & - 7.8231906000e+03, 8.9482351000e+03, 1.0230010660e+04, & - 1.1689289750e+04, 1.3348986860e+04, 1.5234111060e+04, & - 1.7371573230e+04, 1.9789784580e+04, 2.2005564550e+04, & - 2.3550115120e+04, 2.4468583320e+04, 2.4800548800e+04, & - 2.4582445070e+04, 2.3849999620e+04, 2.2640519740e+04, & - 2.0994737150e+04, 1.8957848730e+04, 1.6579413230e+04, & - 1.4080071030e+04, 1.1753630920e+04, 9.6516996300e+03, & - 7.7938009300e+03, 6.1769062800e+03, 4.7874276000e+03, & - 3.6050497500e+03, 2.6059860700e+03, 1.7668328200e+03, & - 1.0656131200e+03, 4.8226201000e+02, 0.0000000000e+00, & - 0.0000000000e+00 / - - - data b60/ 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 5.0600000000e-03, & - 2.0080000000e-02, 4.4900000000e-02, 7.9360000000e-02, & - 1.2326000000e-01, 1.7634000000e-01, 2.3820000000e-01, & - 3.0827000000e-01, 3.8581000000e-01, 4.6989000000e-01, & - 5.5393000000e-01, 6.2958000000e-01, 6.9642000000e-01, & - 7.5458000000e-01, 8.0463000000e-01, 8.4728000000e-01, & - 8.8335000000e-01, 9.1368000000e-01, 9.3905000000e-01, & - 9.6020000000e-01, 9.7775000000e-01, 9.9223000000e-01, & - 1.0000000000e+00 / - -! This is activated by USE_GFSL63 -! Thfollowing L63 setting is the same as NCEP GFS's L64 except the top -! 3 layers - data a63/64.247, 137.790, 221.958, & - 318.266, 428.434, 554.424, & - 698.457, 863.05803, 1051.07995, & - 1265.75194, 1510.71101, 1790.05098, & - 2108.36604, 2470.78817, 2883.03811, & - 3351.46002, 3883.05187, 4485.49315, & - 5167.14603, 5937.04991, 6804.87379, & - 7780.84698, 8875.64338, 10100.20534, & - 11264.35673, 12190.64366, 12905.42546, & - 13430.87867, 13785.88765, 13986.77987, & - 14047.96335, 13982.46770, 13802.40331, & - 13519.33841, 13144.59486, 12689.45608, & - 12165.28766, 11583.57006, 10955.84778, & - 10293.60402, 9608.08306, 8910.07678, & - 8209.70131, 7516.18560, 6837.69250, & - 6181.19473, 5552.39653, 4955.72632, & - 4394.37629, 3870.38682, 3384.76586, & - 2937.63489, 2528.37666, 2155.78385, & - 1818.20722, 1513.68173, 1240.03585, & - 994.99144, 776.23591, 581.48797, & - 408.53400, 255.26520, 119.70243, 0. / + select case (km) - data b63/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00201, 0.00792, 0.01755, & - 0.03079, 0.04751, 0.06761, & - 0.09097, 0.11746, 0.14690, & - 0.17911, 0.21382, 0.25076, & - 0.28960, 0.32994, 0.37140, & - 0.41353, 0.45589, 0.49806, & - 0.53961, 0.58015, 0.61935, & - 0.65692, 0.69261, 0.72625, & - 0.75773, 0.78698, 0.81398, & - 0.83876, 0.86138, 0.88192, & - 0.90050, 0.91722, 0.93223, & - 0.94565, 0.95762, 0.96827, & - 0.97771, 0.98608, 0.99347, 1./ -#ifdef GFSL64 - data a64/20.00000, 68.00000, 137.79000, & - 221.95800, 318.26600, 428.43400, & - 554.42400, 698.45700, 863.05803, & - 1051.07995, 1265.75194, 1510.71101, & - 1790.05098, 2108.36604, 2470.78817, & - 2883.03811, 3351.46002, 3883.05187, & - 4485.49315, 5167.14603, 5937.04991, & - 6804.87379, 7780.84698, 8875.64338, & - 9921.40745, 10760.99844, 11417.88354, & - 11911.61193, 12258.61668, 12472.89642, & - 12566.58298, 12550.43517, 12434.26075, & - 12227.27484, 11938.39468, 11576.46910, & - 11150.43640, 10669.41063, 10142.69482, & - 9579.72458, 8989.94947, 8382.67090, & - 7766.85063, 7150.91171, 6542.55077, & - 5948.57894, 5374.81094, 4825.99383, & - 4305.79754, 3816.84622, 3360.78848, & - 2938.39801, 2549.69756, 2194.08449, & - 1870.45732, 1577.34218, 1313.00028, & - 1075.52114, 862.90778, 673.13815, & - 504.22118, 354.22752, 221.32110, & - 103.78014, 0./ - data b64/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00179, 0.00705, 0.01564, & - 0.02749, 0.04251, 0.06064, & - 0.08182, 0.10595, 0.13294, & - 0.16266, 0.19492, 0.22950, & - 0.26615, 0.30455, 0.34435, & - 0.38516, 0.42656, 0.46815, & - 0.50949, 0.55020, 0.58989, & - 0.62825, 0.66498, 0.69987, & - 0.73275, 0.76351, 0.79208, & - 0.81845, 0.84264, 0.86472, & - 0.88478, 0.90290, 0.91923, & - 0.93388, 0.94697, 0.95865, & - 0.96904, 0.97826, 0.98642, & - 0.99363, 1./ -#else - data a64/1.00000, 3.90000, 8.70000, & - 15.42000, 24.00000, 34.50000, & - 47.00000, 61.50000, 78.60000, & - 99.13500, 124.12789, 154.63770, & - 191.69700, 236.49300, 290.38000, & - 354.91000, 431.82303, 523.09300, & - 630.92800, 757.79000, 906.45000, & - 1079.85000, 1281.00000, 1515.00000, & - 1788.00000, 2105.00000, 2470.00000, & - 2889.00000, 3362.00000, 3890.00000, & - 4475.00000, 5120.00000, 5830.00000, & - 6608.00000, 7461.00000, 8395.00000, & - 9424.46289, 10574.46880, 11864.80270, & - 13312.58890, 14937.03710, 16759.70700, & - 18804.78710, 21099.41210, 23674.03710, & - 26562.82810, 29804.11720, 32627.31640, & - 34245.89840, 34722.28910, 34155.19920, & - 32636.50390, 30241.08200, 27101.44920, & - 23362.20700, 19317.05270, 15446.17090, & - 12197.45210, 9496.39941, 7205.66992, & - 5144.64307, 3240.79346, 1518.62134, & - 0.00000, 0.00000 / - - data b64/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00813, & - 0.03224, 0.07128, 0.12445, & - 0.19063, 0.26929, 0.35799, & - 0.45438, 0.55263, 0.64304, & - 0.71703, 0.77754, 0.82827, & - 0.87352, 0.91502, 0.95235, & - 0.98511, 1.00000 / -#endif -!-->cjg - data a68/1.00000, 2.68881, 5.15524, & - 8.86683, 14.20349, 22.00278, & - 33.50807, 50.32362, 74.56680, & - 109.05958, 157.51214, 224.73844, & - 316.90481, 441.81219, 609.21090, & - 831.14537, 1122.32514, 1500.51628, & - 1986.94617, 2606.71274, 3389.18802, & - 4368.40473, 5583.41379, 7078.60015, & - 8903.94455, 11115.21886, 13774.60566, & - 16936.82070, 20340.47045, 23193.71492, & - 24870.36141, 25444.59363, 25252.57081, & - 24544.26211, 23474.29096, 22230.65331, & - 20918.50731, 19589.96280, 18296.26682, & - 17038.02866, 15866.85655, 14763.18943, & - 13736.83624, 12794.11850, 11930.72442, & - 11137.17217, 10404.78946, 9720.03954, & - 9075.54055, 8466.72650, 7887.12346, & - 7333.90490, 6805.43028, 6297.33773, & - 5805.78227, 5327.94995, 4859.88765, & - 4398.63854, 3942.81761, 3491.08449, & - 3043.04531, 2598.71608, 2157.94527, & - 1720.87444, 1287.52805, 858.02944, & - 432.71276, 8.10905, 0.00000 / - - data b68/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00283, 0.01590, & - 0.04412, 0.08487, 0.13284, & - 0.18470, 0.23828, 0.29120, & - 0.34211, 0.39029, 0.43518, & - 0.47677, 0.51536, 0.55091, & - 0.58331, 0.61263, 0.63917, & - 0.66333, 0.68552, 0.70617, & - 0.72555, 0.74383, 0.76117, & - 0.77765, 0.79335, 0.80838, & - 0.82287, 0.83693, 0.85069, & - 0.86423, 0.87760, 0.89082, & - 0.90392, 0.91689, 0.92973, & - 0.94244, 0.95502, 0.96747, & - 0.97979, 0.99200, 1.00000 / - - data a96/1.00000, 2.35408, 4.51347, & - 7.76300, 12.43530, 19.26365, & - 29.33665, 44.05883, 65.28397, & - 95.48274, 137.90344, 196.76073, & - 277.45330, 386.81095, 533.37018, & - 727.67600, 982.60677, 1313.71685, & - 1739.59104, 2282.20281, 2967.26766, & - 3824.58158, 4888.33404, 6197.38450, & - 7795.49158, 9731.48414, 11969.71024, & - 14502.88894, 17304.52434, 20134.76139, & - 22536.63814, 24252.54459, 25230.65591, & - 25585.72044, 25539.91412, 25178.87141, & - 24644.84493, 23978.98781, 23245.49366, & - 22492.11600, 21709.93990, 20949.64473, & - 20225.94258, 19513.31158, 18829.32485, & - 18192.62250, 17589.39396, 17003.45386, & - 16439.01774, 15903.91204, 15396.39758, & - 14908.02140, 14430.65897, 13967.88643, & - 13524.16667, 13098.30227, 12687.56457, & - 12287.08757, 11894.41553, 11511.54106, & - 11139.22483, 10776.01912, 10419.75711, & - 10067.11881, 9716.63489, 9369.61967, & - 9026.69066, 8687.29884, 8350.04978, & - 8013.20925, 7677.12187, 7343.12994, & - 7011.62844, 6681.98102, 6353.09764, & - 6025.10535, 5699.10089, 5375.54503, & - 5053.63074, 4732.62740, 4413.38037, & - 4096.62775, 3781.79777, 3468.45371, & - 3157.19882, 2848.25306, 2541.19150, & - 2236.21942, 1933.50628, 1632.83741, & - 1334.35954, 1038.16655, 744.22318, & - 452.71094, 194.91899, 0.00000, & - 0.00000 / - - data b96/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00193, & - 0.00974, 0.02538, 0.04876, & - 0.07817, 0.11081, 0.14514, & - 0.18007, 0.21486, 0.24866, & - 0.28088, 0.31158, 0.34030, & - 0.36701, 0.39210, 0.41554, & - 0.43733, 0.45774, 0.47707, & - 0.49540, 0.51275, 0.52922, & - 0.54495, 0.56007, 0.57459, & - 0.58850, 0.60186, 0.61471, & - 0.62715, 0.63922, 0.65095, & - 0.66235, 0.67348, 0.68438, & - 0.69510, 0.70570, 0.71616, & - 0.72651, 0.73675, 0.74691, & - 0.75700, 0.76704, 0.77701, & - 0.78690, 0.79672, 0.80649, & - 0.81620, 0.82585, 0.83542, & - 0.84492, 0.85437, 0.86375, & - 0.87305, 0.88229, 0.89146, & - 0.90056, 0.90958, 0.91854, & - 0.92742, 0.93623, 0.94497, & - 0.95364, 0.96223, 0.97074, & - 0.97918, 0.98723, 0.99460, & - 1.00000 / -!<--cjg -! -! Ultra high troposphere resolution - data a100/100.00000, 300.00000, 800.00000, & - 1762.35235, 3106.43596, 4225.71874, & - 4946.40525, 5388.77387, 5708.35540, & - 5993.33124, 6277.73673, 6571.49996, & - 6877.05339, 7195.14327, 7526.24920, & - 7870.82981, 8229.35361, 8602.30193, & - 8990.16936, 9393.46399, 9812.70768, & - 10248.43625, 10701.19980, 11171.56286, & - 11660.10476, 12167.41975, 12694.11735, & - 13240.82253, 13808.17600, 14396.83442, & - 15007.47066, 15640.77407, 16297.45067, & - 16978.22343, 17683.83253, 18415.03554, & - 19172.60771, 19957.34218, 20770.05022, & - 21559.14829, 22274.03147, 22916.87519, & - 23489.70456, 23994.40187, 24432.71365, & - 24806.25734, 25116.52754, 25364.90190, & - 25552.64670, 25680.92203, 25750.78675, & - 25763.20311, 25719.04113, 25619.08274, & - 25464.02630, 25254.49482, 24991.06137, & - 24674.32737, 24305.11235, 23884.79781, & - 23415.77059, 22901.76510, 22347.84738, & - 21759.93950, 21144.07284, 20505.73136, & - 19849.54271, 19179.31412, 18498.23400, & - 17809.06809, 17114.28232, 16416.10343, & - 15716.54833, 15017.44246, 14320.43478, & - 13627.01116, 12938.50682, 12256.11762, & - 11580.91062, 10913.83385, 10255.72526, & - 9607.32122, 8969.26427, 8342.11044, & - 7726.33606, 7122.34405, 6530.46991, & - 5950.98721, 5384.11279, 4830.01153, & - 4288.80090, 3760.55514, 3245.30920, & - 2743.06250, 2253.78294, 1777.41285, & - 1313.88054, 863.12371, 425.13088, & - 0.00000, 0.00000 / - - - data b100/0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00000, 0.00000, 0.00000, & - 0.00052, 0.00209, 0.00468, & - 0.00828, 0.01288, 0.01849, & - 0.02508, 0.03266, 0.04121, & - 0.05075, 0.06126, 0.07275, & - 0.08521, 0.09866, 0.11308, & - 0.12850, 0.14490, 0.16230, & - 0.18070, 0.20009, 0.22042, & - 0.24164, 0.26362, 0.28622, & - 0.30926, 0.33258, 0.35605, & - 0.37958, 0.40308, 0.42651, & - 0.44981, 0.47296, 0.49591, & - 0.51862, 0.54109, 0.56327, & - 0.58514, 0.60668, 0.62789, & - 0.64872, 0.66919, 0.68927, & - 0.70895, 0.72822, 0.74709, & - 0.76554, 0.78357, 0.80117, & - 0.81835, 0.83511, 0.85145, & - 0.86736, 0.88286, 0.89794, & - 0.91261, 0.92687, 0.94073, & - 0.95419, 0.96726, 0.97994, & - 0.99223, 1.00000 / - - data a104/ & - 1.8827062944e-01, 7.7977549145e-01, 2.1950593583e+00, & - 4.9874566624e+00, 9.8041418997e+00, 1.7019717163e+01, & - 2.7216579591e+01, 4.0518628401e+01, 5.6749646818e+01, & - 7.5513868331e+01, 9.6315093333e+01, 1.1866706195e+02, & - 1.4216835396e+02, 1.6653733709e+02, 1.9161605772e+02, & - 2.1735580129e+02, 2.4379516604e+02, 2.7103771847e+02, & - 2.9923284173e+02, 3.2856100952e+02, 3.5922338766e+02, & - 3.9143507908e+02, 4.2542117983e+02, 4.6141487902e+02, & - 4.9965698106e+02, 5.4039638379e+02, 5.8389118154e+02, & - 6.3041016829e+02, 6.8023459505e+02, 7.3366009144e+02, & - 7.9099869949e+02, 8.5258099392e+02, 9.1875827946e+02, & - 9.8990486716e+02, 1.0664204381e+03, 1.1487325074e+03, & - 1.2372990044e+03, 1.3326109855e+03, 1.4351954993e+03, & - 1.5456186222e+03, 1.6644886848e+03, 1.7924597105e+03, & - 1.9302350870e+03, 2.0785714934e+03, 2.2382831070e+03, & - 2.4102461133e+03, 2.5954035462e+03, 2.7947704856e+03, & - 3.0094396408e+03, 3.2405873512e+03, 3.4894800360e+03, & - 3.7574811281e+03, 4.0460585279e+03, 4.3567926151e+03, & - 4.6913848588e+03, 5.0516670674e+03, 5.4396113207e+03, & - 5.8573406270e+03, 6.3071403487e+03, 6.7914704368e+03, & - 7.3129785102e+03, 7.8745138115e+03, 8.4791420557e+03, & - 9.1301611750e+03, 9.8311179338e+03, 1.0585825354e+04, & - 1.1398380836e+04, 1.2273184781e+04, 1.3214959424e+04, & - 1.4228767429e+04, 1.5320029596e+04, 1.6494540743e+04, & - 1.7758482452e+04, 1.9118430825e+04, 2.0422798801e+04, & - 2.1520147587e+04, 2.2416813461e+04, 2.3118184510e+04, & - 2.3628790785e+04, 2.3952411814e+04, 2.4092209011e+04, & - 2.4050892106e+04, 2.3830930156e+04, 2.3434818358e+04, & - 2.2865410898e+04, 2.2126326004e+04, 2.1222420323e+04, & - 2.0160313690e+04, 1.8948920926e+04, 1.7599915822e+04, & - 1.6128019809e+04, 1.4550987232e+04, 1.2889169132e+04, & - 1.1164595563e+04, 9.4227665517e+03, 7.7259097899e+03, & - 6.1538244381e+03, 4.7808126007e+03, 3.5967415552e+03, & - 2.5886394104e+03, 1.7415964865e+03, 1.0393721271e+03, & - 4.6478852032e+02, 7.0308342481e-13, 0.0000000000e+00 / - - - data b104/ & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & - 0.0000000000e+00, 0.0000000000e+00, 1.5648447298e-03, & - 6.2617046389e-03, 1.4104157933e-02, 2.5118187415e-02, & - 3.9340510972e-02, 5.6816335609e-02, 7.7596328431e-02, & - 1.0173255472e-01, 1.2927309709e-01, 1.6025505622e-01, & - 1.9469566981e-01, 2.3258141217e-01, 2.7385520518e-01, & - 3.1840233814e-01, 3.6603639170e-01, 4.1648734767e-01, & - 4.6939496013e-01, 5.2431098738e-01, 5.8071350676e-01, & - 6.3803478105e-01, 6.9495048840e-01, 7.4963750338e-01, & - 7.9975208897e-01, 8.4315257576e-01, 8.8034012292e-01, & - 9.1184389721e-01, 9.3821231526e-01, 9.6000677644e-01, & - 9.7779792223e-01, 9.9216315122e-01, 1.0000000000e+00 / - -! IFS-like L125(top 12 levels removed from IFSL137) - data a125/ 64., & - 86.895882, 107.415741, 131.425507, 159.279404, 191.338562, & - 227.968948, 269.539581, 316.420746, 368.982361, 427.592499, 492.616028, & - 564.413452, 643.339905, 729.744141, 823.967834, 926.344910, 1037.201172, & - 1156.853638, 1285.610352, 1423.770142, 1571.622925, 1729.448975, 1897.519287, & - 2076.095947, 2265.431641, 2465.770508, 2677.348145, 2900.391357, 3135.119385, & - 3381.743652, 3640.468262, 3911.490479, 4194.930664, 4490.817383, 4799.149414, & - 5119.895020, 5452.990723, 5798.344727, 6156.074219, 6526.946777, 6911.870605, & - 7311.869141, 7727.412109, 8159.354004, 8608.525391, 9076.400391, 9562.682617, & - 10065.978516, 10584.631836, 11116.662109, 11660.067383, 12211.547852, 12766.873047, & - 13324.668945, 13881.331055, 14432.139648, 14975.615234, 15508.256836, 16026.115234, & - 16527.322266, 17008.789063, 17467.613281, 17901.621094, 18308.433594, 18685.718750, & - 19031.289063, 19343.511719, 19620.042969, 19859.390625, 20059.931641, 20219.664063, & - 20337.863281, 20412.308594, 20442.078125, 20425.718750, 20361.816406, 20249.511719, & - 20087.085938, 19874.025391, 19608.572266, 19290.226563, 18917.460938, 18489.707031, & - 18006.925781, 17471.839844, 16888.687500, 16262.046875, 15596.695313, 14898.453125, & - 14173.324219, 13427.769531, 12668.257813, 11901.339844, 11133.304688, 10370.175781, & - 9617.515625, 8880.453125, 8163.375000, 7470.343750, 6804.421875, 6168.531250, & - 5564.382813, 4993.796875, 4457.375000, 3955.960938, 3489.234375, 3057.265625, & - 2659.140625, 2294.242188, 1961.500000, 1659.476563, 1387.546875, 1143.250000, & - 926.507813, 734.992188, 568.062500, 424.414063, 302.476563, 202.484375, & - 122.101563, 62.781250, 22.835938, 3.757813, 0.000000, 0.000000 / - - data b125/ 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000007, 0.000024, 0.000059, 0.000112, 0.000199, & - 0.000340, 0.000562, 0.000890, 0.001353, 0.001992, 0.002857, & - 0.003971, 0.005378, 0.007133, 0.009261, 0.011806, 0.014816, & - 0.018318, 0.022355, 0.026964, 0.032176, 0.038026, 0.044548, & - 0.051773, 0.059728, 0.068448, 0.077958, 0.088286, 0.099462, & - 0.111505, 0.124448, 0.138313, 0.153125, 0.168910, 0.185689, & - 0.203491, 0.222333, 0.242244, 0.263242, 0.285354, 0.308598, & - 0.332939, 0.358254, 0.384363, 0.411125, 0.438391, 0.466003, & - 0.493800, 0.521619, 0.549301, 0.576692, 0.603648, 0.630036, & - 0.655736, 0.680643, 0.704669, 0.727739, 0.749797, 0.770798, & - 0.790717, 0.809536, 0.827256, 0.843881, 0.859432, 0.873929, & - 0.887408, 0.899900, 0.911448, 0.922096, 0.931881, 0.940860, & - 0.949064, 0.956550, 0.963352, 0.969513, 0.975078, 0.980072, & - 0.984542, 0.988500, 0.991984, 0.995003, 0.997630, 1.000000 / + case (5,10) ! does this work???? - select case (km) + ! Equivalent Shallow Water: for modon test + ptop = 500.e2 + ks = 0 + do k=1,km+1 + bk(k) = real(k-1) / real (km) + ak(k) = ptop*(1.-bk(k)) + enddo - case (24) + case (24) - ks = 5 - do k=1,km+1 + ks = 5 + do k=1,km+1 ak(k) = a24(k) bk(k) = b24(k) - enddo + enddo - case (26) - - ks = 7 - do k=1,km+1 + case (26) + + ks = 7 + do k=1,km+1 ak(k) = a26(k) bk(k) = b26(k) - enddo + enddo - case (32) -#ifdef OLD_32 - ks = 13 ! high-res trop_32 setup -#else - ks = 7 -#endif - do k=1,km+1 - ak(k) = a32(k) - bk(k) = b32(k) - enddo + case (30) ! For Baroclinic Instability Test + ptop = 2.26e2 + pint = 250.E2 + stretch_fac = 1.03 + auto_routine = 1 + + case (31) ! N = 4, M=2 + if (trim(npz_type) == 'lowtop') then + ptop = 300. + pint = 100.E2 + stretch_fac = 1.035 + auto_routine = 5 + else + ptop = 100. + stretch_fac = 1.035 + auto_routine = 1 + endif - case (47) -! ks = 27 ! high-res trop-strat - ks = 20 ! Oct 23, 2012 - do k=1,km+1 - ak(k) = a47(k) - bk(k) = b47(k) - enddo + case (32) - case (48) - ks = 28 - do k=1,km+1 + if (trim(npz_type) == 'old32') then + ks = 13 ! high-res trop_32 setup + do k=1,km+1 + ak(k) = a32old(k) + bk(k) = b32old(k) + enddo + elseif (trim(npz_type) == 'lowtop') then + ptop = 100. + stretch_fac = 1.035 + auto_routine = 1 + else + ks = 7 + do k=1,km+1 + ak(k) = a32(k) + bk(k) = b32(k) + enddo + endif + !miz + case (33) + ks = 7 + do k=1,km+1 + ak(k) = a33(k) + bk(k) = b33(k) + enddo + !miz + + case (39) ! N = 5 + ptop = 100. + stretch_fac = 1.035 + auto_routine = 1 + + case (40) + ptop = 50.e2 ! For super cell test + pint = 300.E2 + stretch_fac = 1.03 + auto_routine = 1 + + case (41) + ptop = 100. + pint = 100.E2 + stretch_fac = 1.035 + auto_routine = 1 + + case (47) + + if (trim(npz_type) == 'lowtop') then + ptop = 100. + stretch_fac = 1.035 + auto_routine = 1 + else + ! ks = 27 ! high-res trop-strat + ks = 20 ! Oct 23, 2012 + do k=1,km+1 + ak(k) = a47(k) + bk(k) = b47(k) + enddo + endif + + case (48) + ks = 28 + do k=1,km+1 ak(k) = a48(k) bk(k) = b48(k) - enddo + enddo - case (52) - ks = 35 ! pint = 223 - do k=1,km+1 - ak(k) = a52(k) - bk(k) = b52(k) - enddo + case (50) + ! *Very-low top: for idealized super-cell simulation: + ptop = 50.e2 + pint = 250.E2 + stretch_fac = 1.03 + auto_routine = 1 + + case (51) + if (trim(npz_type) == 'lowtop') then + ptop = 100. + stretch_fac = 1.03 + auto_routine = 1 + elseif (trim(npz_type) == 'meso') then + ptop = 20.E2 + pint = 100.E2 + stretch_fac = 1.05 + auto_routine = 1 + elseif (trim(npz_type) == 'meso2') then + ptop = 1.E2 + pint = 100.E2 + stretch_fac = 1.05 + auto_routine = 6 + else + ptop = 100. + pint = 100.E2 + stretch_fac = 1.035 + auto_routine = 1 + endif - case (54) - ks = 11 ! pint = 109.4 - do k=1,km+1 + case (52) + + if (trim(npz_type) == 'rce') then + ptop = 30.e2 ! for special DPM RCE experiments + stretch_fac = 1.03 + auto_routine = 1 + else + ks = 35 ! pint = 223 + do k=1,km+1 + ak(k) = a52(k) + bk(k) = b52(k) + enddo + endif + + case (54) + ks = 11 ! pint = 109.4 + do k=1,km+1 ak(k) = a54(k) bk(k) = b54(k) - enddo + enddo - case (56) - ks = 26 - do k=1,km+1 + ! Mid-top: + case (55) ! N = 7 + ptop = 10. + pint = 100.E2 + stretch_fac = 1.035 + auto_routine = 1 + + case (56) + ks = 26 + do k=1,km+1 ak(k) = a56(k) bk(k) = b56(k) - enddo + enddo - case (60) - ks = 37 - do k=1,km+1 - ak(k) = a60(k) - bk(k) = b60(k) - enddo + case (60) + if (trim(npz_type) == 'gfs') then + ks = 20 + do k=1,km+1 + ak(k) = a60gfs(k) + bk(k) = b60gfs(k) + enddo + else if (trim(npz_type) == 'BCwave') then + ptop = 3.e2 + ! pint = 250.E2 + pint = 300.E2 ! revised for Moist test + stretch_fac = 1.03 + auto_routine = 1 + else if (trim(npz_type) == 'meso') then + + ptop = 40.e2 + pint = 250.E2 + stretch_fac = 1.03 + auto_routine = 1 - case (64) -#ifdef GFSL64 - ks = 23 -#else - ks = 46 -#endif - do k=1,km+1 - ak(k) = a64(k) - bk(k) = b64(k) - enddo -!-->cjg - case (68) - ks = 27 - do k=1,km+1 + else + ks = 19 + do k=1,km+1 + ak(k) = a60(k) + bk(k) = b60(k) + enddo + endif + + case (63) + if (trim(npz_type) == 'meso') then + ks = 11 + do k=1,km+1 + ak(k) = a63meso(k) + bk(k) = b63meso(k) + enddo + elseif (trim(npz_type) == 'hitop') then + ptop = 1. ! high top + pint = 100.E2 + stretch_fac = 1.035 + auto_routine = 1 + else!if (trim(npz_type) == 'gfs') then + !Used for SHiELD + ! GFS L64 equivalent setting + ks = 23 + do k=1,km+1 + ak(k) = a63(k) + bk(k) = b63(k) + enddo + endif + + case (64) + + if (trim(npz_type) == 'gfs') then + ks = 23 + do k=1,km+1 + ak(k) = a64gfs(k) + bk(k) = b64gfs(k) + enddo + + else + + ks = 46 + do k=1,km+1 + ak(k) = a64(k) + bk(k) = b64(k) + enddo + + endif + !-->cjg + case (68) + ks = 27 + do k=1,km+1 ak(k) = a68(k) bk(k) = b68(k) - enddo + enddo - case (96) - ks = 27 - do k=1,km+1 + case (71) ! N = 9 + ptop = 1. + stretch_fac = 1.03 + auto_routine = 1 + case (75) ! HS-SGO test configuration + pint = 100.E2 + ptop = 10.E2 + stretch_fac = 1.035 + auto_routine = 6 + case (79) ! N = 10, M=5 + if (trim(npz_type) == 'gcrm') then + pint = 100.E2 + ptop = 3.E2 + stretch_fac = 1.035 + auto_routine = 6 + else + ptop = 1. + stretch_fac = 1.03 + auto_routine = 1 + endif + case (90) ! super-duper cell + ptop = 40.e2 + stretch_fac = 1.025 + auto_routine = 2 + + ! NGGPS_GFS + case (91) + pint = 100.E2 + ptop = 40. + stretch_fac = 1.029 + auto_routine = 6 + + case (95) + ! Mid-top settings: + pint = 100.E2 + ptop = 20. + stretch_fac = 1.029 + auto_routine = 6 + + case (96) + ks = 27 + do k=1,km+1 ak(k) = a96(k) bk(k) = b96(k) - enddo -!<--cjg + enddo + !<--cjg - case (100) - ks = 38 - do k=1,km+1 + case (100) + ks = 38 + do k=1,km+1 ak(k) = a100(k) bk(k) = b100(k) - enddo + enddo - case (104) - ks = 73 - do k=1,km+1 + case (104) + ks = 73 + do k=1,km+1 ak(k) = a104(k) bk(k) = b104(k) - enddo - -#ifndef TEST_GWAVES - case (10) -!-------------------------------------------------- -! Pure sigma-coordinate with uniform spacing in "z" -!-------------------------------------------------- -! - pt = 2000. ! model top pressure (pascal) -! pt = 100. ! 1 mb - press(1) = pt - press(km+1) = p0 - dlnp = (log(p0) - log(pt)) / real(km) - - lnpe = log(press(km+1)) - do k=km,2,-1 - lnpe = lnpe - dlnp - press(k) = exp(lnpe) - enddo - -! Search KS - ks = 0 - do k=1,km - if(press(k) >= pc) then - ks = k-1 - goto 123 - endif enddo -123 continue - - if(ks /= 0) then - do k=1,ks - ak(k) = press(k) - bk(k) = 0. - enddo - endif - - pint = press(ks+1) - do k=ks+1,km - ak(k) = pint*(press(km)-press(k))/(press(km)-pint) - bk(k) = (press(k) - ak(k)) / press(km+1) - enddo - ak(km+1) = 0. - bk(km+1) = 1. - -! do k=2,km -! bk(k) = real(k-1) / real(km) -! ak(k) = pt * ( 1. - bk(k) ) -! enddo -#endif -! The following 4 selections are better for non-hydrostatic -! Low top: - case (31) - ptop = 300. - pint = 100.E2 - call var_dz(km, ak, bk, ptop, ks, pint, 1.035) -#ifndef TEST_GWAVES - case (41) - ptop = 100. - pint = 100.E2 - call var_hi(km, ak, bk, ptop, ks, pint, 1.035) -#endif - case (51) - ptop = 100. - pint = 100.E2 - call var_hi(km, ak, bk, ptop, ks, pint, 1.035) -! Mid-top: - case (55) - ptop = 10. - pint = 100.E2 -! call var_dz(km, ak, bk, ptop, ks, pint, 1.035) - call var_hi(km, ak, bk, ptop, ks, pint, 1.035) -#ifdef USE_GFSL63 -! GFS L64 equivalent setting - case (63) - ks = 23 - ptop = a63(1) - pint = a63(ks+1) - do k=1,km+1 - ak(k) = a63(k) - bk(k) = b63(k) - enddo -#else - case (63) - ptop = 1. ! high top - pint = 100.E2 - call var_hi(km, ak, bk, ptop, ks, pint, 1.035) -#endif -! NGGPS_GFS - case (91) - pint = 100.E2 - ptop = 40. - call var_gfs(km, ak, bk, ptop, ks, pint, 1.029) -! call var_gfs(km, ak, bk, ptop, ks, pint, 1.03) - case (95) -! Mid-top settings: - pint = 100.E2 - ptop = 20. - call var_gfs(km, ak, bk, ptop, ks, pint, 1.028) - case (127) - ptop = 1. - pint = 75.E2 - call var_gfs(km, ak, bk, ptop, ks, pint, 1.028) -! IFS-like L125 - case (125) - ks = 33 - ptop = a125(1) - pint = a125(ks+1) - do k=1,km+1 + ! IFS-like L125 + case (125) + ks = 33 + ptop = a125(1) + pint = a125(ks+1) + do k=1,km+1 ak(k) = a125(k) bk(k) = b125(k) - enddo - case default + enddo -#ifdef TEST_GWAVES -!-------------------------------------------------- -! Pure sigma-coordinate with uniform spacing in "z" -!-------------------------------------------------- - call gw_1d(km, 1000.E2, ak, bk, ptop, 10.E3, pt1) - ks = 0 - pint = ak(1) -#else + case (127) ! N = 10, M=5 + if (trim(npz_type) == 'hitop') then + ptop = 1. + stretch_fac = 1.03 + auto_routine = 2 + else + ptop = 1. + pint = 75.E2 + stretch_fac = 1.028 + auto_routine = 6 + endif + case (151) + !LES applications + ptop = 75.e2 + pint = 500.E2 + stretch_fac = 1.01 + auto_routine = 3 + + case default + + if(trim(npz_type) == 'hitop') then + ptop = 1. + pint = 100.E2 + elseif(trim(npz_type) == 'midtop') then + ptop = 10. + pint = 100.E2 + elseif(trim(npz_type) == 'lowtop') then + ptop = 1.E2 + pint = 100.E2 + endif + + if (trim(npz_type) == 'gfs') then + auto_routine = 6 + elseif(trim(npz_type) == 'les') then + auto_routine = 3 + elseif(trim(npz_type) == 'mountain_wave') then + auto_routine = 4 + elseif (km > 79) then + auto_routine = 2 + else + auto_routine = 1 + endif -!---------------------------------------------------------------- -! Sigma-coordinate with uniform spacing in sigma and ptop = 1 mb -!---------------------------------------------------------------- - pt = 100. -! One pressure layer - ks = 1 -! pint = pt + 0.5*1.E5/real(km) ! SJL: 20120327 - pint = pt + 1.E5/real(km) - - ak(1) = pt - bk(1) = 0. - ak(2) = pint - bk(2) = 0. - - do k=3,km+1 - bk(k) = real(k-2) / real(km-1) - ak(k) = pint - bk(k)*pint - enddo - ak(km+1) = 0. - bk(km+1) = 1. -#endif end select - ptop = ak(1) - pint = ak(ks+1) + + endif ! superC/superK + + select case (auto_routine) + + case (1) + call var_hi(km, ak, bk, ptop, ks, pint, stretch_fac) + case (2) + call var_hi2(km, ak, bk, ptop, ks, pint, stretch_fac) + case (3) + call var_les(km, ak, bk, ptop, ks, pint, stretch_fac) + case (4) + call mount_waves(km, ak, bk, ptop, ks, pint) + case (5) + call var_dz(km, ak, bk, ptop, ks, pint, stretch_fac) + case (6) + call var_gfs(km, ak, bk, ptop, ks, pint, stretch_fac) + end select + + ptop = ak(1) + pint = ak(ks+1) + + if (is_master()) then + write(*, '(A4, A13, A13, A11)') 'klev', 'ak', 'bk', 'p_ref' + do k=1,km+1 + write(*,'(I4, F13.5, F13.5, F11.2)') k, ak(k), bk(k), 1000.E2*bk(k) + ak(k) + enddo + endif + end subroutine set_eta #endif @@ -3071,6 +2316,140 @@ subroutine gw_1d(km, p0, ak, bk, ptop, ztop, pt1) end subroutine gw_1d + subroutine mount_waves(km, ak, bk, ptop, ks, pint) + integer, intent(in):: km + real, intent(out):: ak(km+1), bk(km+1) + real, intent(out):: ptop, pint + integer, intent(out):: ks +! Local + real, parameter:: p00 = 1.E5 + real, dimension(km+1):: ze, pe1, peln, eta + real, dimension(km):: dz, dlnp + real ztop, t0, dz0, sum1, tmp1 + real ep, es, alpha, beta, gama, s_fac + integer k, k500 + + pint = 300.e2 +! s_fac = 1.05 +! dz0 = 500. + if ( km <= 60 ) then + s_fac = 1.0 + dz0 = 500. + else + s_fac = 1. + dz0 = 250. + endif + +! Basic parameters for HIWPP mountain waves + t0 = 300. +! ztop = 20.0e3; 500-m resolution in halft of the vertical domain +! ztop = real(km-1)*500. +!----------------------- +! Compute temp ptop based on isothermal atm +! ptop = p00*exp(-grav*ztop/(rdgas*t0)) + +! Lowest half has constant resolution + ze(km+1) = 0. + do k=km, km-19, -1 + ze(k) = ze(k+1) + dz0 + enddo + +! Stretching from 10-km and up: + do k=km-20, 3, -1 + dz0 = s_fac * dz0 + ze(k) = ze(k+1) + dz0 + enddo + ze(2) = ze(3) + sqrt(2.)*dz0 + ze(1) = ze(2) + 2.0*dz0 + +! call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 1) + +! Given z --> p + do k=1,km + dz(k) = ze(k) - ze(k+1) + dlnp(k) = grav*dz(k) / (rdgas*t0) + enddo + + pe1(km+1) = p00 + peln(km+1) = log(p00) + do k=km,1,-1 + peln(k) = peln(k+1) - dlnp(k) + pe1(k) = exp(peln(k)) + enddo + +! Comnpute new ptop + ptop = pe1(1) + +! Pe(k) = ak(k) + bk(k) * PS +! Locate pint and KS + ks = 0 + do k=2,km + if ( pint < pe1(k)) then + ks = k-1 + exit + endif + enddo + + if ( is_master() ) then + write(*,*) 'For (input) PINT=', 0.01*pint, ' KS=', ks, 'pint(computed)=', 0.01*pe1(ks+1) + write(*,*) 'Modified ptop =', ptop, ' ztop=', ze(1)/1000. + do k=1,km + write(*,*) k, 'ze =', ze(k)/1000. + enddo + endif + pint = pe1(ks+1) + +#ifdef NO_UKMO_HB + do k=1,ks+1 + ak(k) = pe1(k) + bk(k) = 0. + enddo + + do k=ks+2,km+1 + bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma + ak(k) = pe1(k) - bk(k) * pe1(km+1) + enddo + bk(km+1) = 1. + ak(km+1) = 0. +#else +! Problematic for non-hydrostatic + do k=1,km+1 + eta(k) = pe1(k) / pe1(km+1) + enddo + ep = eta(ks+1) + es = eta(km) +! es = 1. + alpha = (ep**2-2.*ep*es) / (es-ep)**2 + beta = 2.*ep*es**2 / (es-ep)**2 + gama = -(ep*es)**2 / (es-ep)**2 + +! Pure pressure: + do k=1,ks+1 + ak(k) = eta(k)*1.e5 + bk(k) = 0. + enddo + + do k=ks+2, km + ak(k) = alpha*eta(k) + beta + gama/eta(k) + ak(k) = ak(k)*1.e5 + enddo + ak(km+1) = 0. + + do k=ks+2, km + bk(k) = (pe1(k) - ak(k))/pe1(km+1) + enddo + bk(km+1) = 1. +#endif + + if ( is_master() ) then + tmp1 = ak(ks+1) + do k=ks+1,km + tmp1 = max(tmp1, (ak(k)-ak(k+1))/max(1.E-5, (bk(k+1)-bk(k))) ) + enddo + write(*,*) 'Hybrid Sigma-P: minimum allowable surface pressure (hpa)=', tmp1/100. + endif + + end subroutine mount_waves subroutine zflip(q, im, km) diff --git a/tools/fv_eta.h b/tools/fv_eta.h new file mode 100644 index 000000000..e01415ce0 --- /dev/null +++ b/tools/fv_eta.h @@ -0,0 +1,945 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** +#ifndef _FV_ETA_ +#define _FV_ETA__ + +! -*-f90-*-* + +! local + real a24(25),b24(25) ! GFDL AM2L24 + real a26(27),b26(27) ! Jablonowski & Williamson 26-level + real a32old(33),b32old(33) + real a32(33),b32(33) + real a32w(33),b32w(33) + real a33(34),b33(34) ! miz: grid with enhanced surface-layer resolution + real a47(48),b47(48) + real a48(49),b48(49) + real a52(53),b52(53) + real a54(55),b54(55) + real a56(57),b56(57) + real a60(61),b60(61) + real a60gfs(61),b60gfs(61) + real a63(64),b63(64) + real a63meso(64),b63meso(64) + real a64(65),b64(65) + real a64gfs(65),b64gfs(65) + real a68(69),b68(69) ! cjg: grid with enhanced PBL resolution + real a96(97),b96(97) ! cjg: grid with enhanced PBL resolution + real a100(101),b100(101) + real a104(105),b104(105) + real a125(126),b125(126) + +!----------------------------------------------- +! GFDL AM2-L24: modified by SJL at the model top +!----------------------------------------------- +! data a24 / 100.0000, 1050.0000, 3474.7942, 7505.5556, 12787.2428, & + data a24 / 100.0000, 903.4465, 3474.7942, 7505.5556, 12787.2428, & + 19111.3683, 21854.9274, 22884.1866, 22776.3058, 21716.1604, & + 20073.2963, 18110.5123, 16004.7832, 13877.6253, 11812.5452, & + 9865.8840, 8073.9726, 6458.0834, 5027.9899, 3784.6085, & + 2722.0086, 1828.9752, 1090.2396, 487.4595, 0.0000 / + + data b24 / 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, & + 0.0000000, 0.0435679, 0.1102275, 0.1922249, 0.2817656, & + 0.3694997, 0.4532348, 0.5316253, 0.6038733, 0.6695556, & + 0.7285176, 0.7808017, 0.8265992, 0.8662148, 0.9000406, & + 0.9285364, 0.9522140, 0.9716252, 0.9873523, 1.0000000 / + +! Jablonowski & Williamson 26-level setup + data a26 / 219.4067, 489.5209, 988.2418, 1805.2010, 2983.7240, 4462.3340, & + 6160.5870, 7851.2430, 7731.2710, 7590.1310, 7424.0860, & + 7228.7440, 6998.9330, 6728.5740, 6410.5090, 6036.3220, & + 5596.1110, 5078.2250, 4468.9600, 3752.1910, 2908.9490, & + 2084.739, 1334.443, 708.499, 252.1360, 0.0, 0.0 / + + data b26 / 0.0, 0.0, 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000,& + 0.0000000, 0.01505309, 0.03276228, 0.05359622, 0.07810627, & + 0.1069411, 0.1408637, 0.1807720, 0.2277220, 0.2829562, & + 0.3479364, 0.4243822, 0.5143168, 0.6201202, 0.7235355, & + 0.8176768, 0.8962153, 0.9534761, 0.9851122, 1.0000000 / + + +! High-resolution troposphere setup +! Revised Apr 14, 2004: PINT = 245.027 mb + data a32old/100.00000, 400.00000, 818.60211, & + 1378.88653, 2091.79519, 2983.64084, & + 4121.78960, 5579.22148, 7419.79300, & + 9704.82578, 12496.33710, 15855.26306, & + 19839.62499, 24502.73262, 28177.10152, & + 29525.28447, 29016.34358, 27131.32792, & + 24406.11225, 21326.04907, 18221.18357, & + 15275.14642, 12581.67796, 10181.42843, & + 8081.89816, 6270.86956, 4725.35001, & + 3417.39199, 2317.75459, 1398.09473, & + 632.49506, 0.00000, 0.00000 / + + data b32old/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.01711, & + 0.06479, 0.13730, 0.22693, & + 0.32416, 0.42058, 0.51105, & + 0.59325, 0.66628, 0.73011, & + 0.78516, 0.83217, 0.87197, & + 0.90546, 0.93349, 0.95685, & + 0.97624, 0.99223, 1.00000 / + +! SJL June 26, 2012 +! pint= 55.7922 + data a32/100.00000, 400.00000, 818.60211, & + 1378.88653, 2091.79519, 2983.64084, & + 4121.78960, 5579.22148, 6907.19063, & + 7735.78639, 8197.66476, 8377.95525, & + 8331.69594, 8094.72213, 7690.85756, & + 7139.01788, 6464.80251, 5712.35727, & + 4940.05347, 4198.60465, 3516.63294, & + 2905.19863, 2366.73733, 1899.19455, & + 1497.78137, 1156.25252, 867.79199, & + 625.59324, 423.21322, 254.76613, & + 115.06646, 0.00000, 0.00000 / + + data b32/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00513, & + 0.01969, 0.04299, 0.07477, & + 0.11508, 0.16408, 0.22198, & + 0.28865, 0.36281, 0.44112, & + 0.51882, 0.59185, 0.65810, & + 0.71694, 0.76843, 0.81293, & + 0.85100, 0.88331, 0.91055, & + 0.93338, 0.95244, 0.96828, & + 0.98142, 0.99223, 1.00000 / + +!--------------------- +! Wilson's 32L settings: +!--------------------- +! Top changed to 0.01 mb + data a32w/ 1.00, 26.6378, 84.5529, 228.8592, & + 539.9597, 1131.7087, 2141.8082, 3712.0454, & + 5963.5317, 8974.1873, 12764.5388, 17294.5911, & + 20857.7007, 22221.8651, 22892.7202, 22891.1641, & + 22286.0724, 21176.0846, 19673.0671, 17889.0989, & + 15927.5060, 13877.6239, 11812.5474, 9865.8830, & + 8073.9717, 6458.0824, 5027.9893, 3784.6104, & + 2722.0093, 1828.9741, 1090.2397, 487.4575, & + 0.0000 / + + data b32w/ 0.0000, 0.0000, 0.0000, 0.0000, & + 0.0000, 0.0000, 0.0000, 0.0000, & + 0.0000, 0.0000, 0.0000, 0.0000, & + 0.0159, 0.0586, 0.1117, 0.1734, & + 0.2415, 0.3137, 0.3878, 0.4619, & + 0.5344, 0.6039, 0.6696, 0.7285, & + 0.7808, 0.8266, 0.8662, 0.9000, & + 0.9285, 0.9522, 0.9716, 0.9874, & + 1.0000 / + +!miz + data a33/100.00000, 400.00000, 818.60211, & + 1378.88653, 2091.79519, 2983.64084, & + 4121.78960, 5579.22148, 6907.19063, & + 7735.78639, 8197.66476, 8377.95525, & + 8331.69594, 8094.72213, 7690.85756, & + 7139.01788, 6464.80251, 5712.35727, & + 4940.05347, 4198.60465, 3516.63294, & + 2905.19863, 2366.73733, 1899.19455, & + 1497.78137, 1156.25252, 867.79199, & + 625.59324, 426.21322, 264.76613, & + 145.06646, 60.00000, 15.00000, & + 0.00000 / + + data b33/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00513, & + 0.01969, 0.04299, 0.07477, & + 0.11508, 0.16408, 0.22198, & + 0.28865, 0.36281, 0.44112, & + 0.51882, 0.59185, 0.65810, & + 0.71694, 0.76843, 0.81293, & + 0.85100, 0.88331, 0.91055, & + 0.93331, 0.95214, 0.96750, & + 0.97968, 0.98908, 0.99575, & + 1.00000 / +!miz +#ifdef OLD_L47 +! QBO setting with ptop = 0.1 mb and p_full=0.17 mb; pint ~ 100 mb + data a47/ 10.00000, 24.45365, 48.76776, & + 85.39458, 133.41983, 191.01402, & + 257.94919, 336.63306, 431.52741, & + 548.18995, 692.78825, 872.16512, & + 1094.18467, 1368.11917, 1704.99489, & + 2117.91945, 2622.42986, 3236.88281, & + 3982.89623, 4885.84733, 5975.43260, & + 7286.29500, 8858.72424, 10739.43477, & + 12982.41110, 15649.68745, 18811.37629, & + 22542.71275, 25724.93857, 27314.36781, & + 27498.59474, 26501.79312, 24605.92991, & + 22130.51655, 19381.30274, 16601.56419, & + 13952.53231, 11522.93244, 9350.82303, & + 7443.47723, 5790.77434, 4373.32696, & + 3167.47008, 2148.51663, 1293.15510, & + 581.62429, 0.00000, 0.00000 / + + data b47/ 0.0000, 0.0000, 0.0000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.01188, 0.04650, & + 0.10170, 0.17401, 0.25832, & + 0.34850, 0.43872, 0.52448, & + 0.60307, 0.67328, 0.73492, & + 0.78834, 0.83418, 0.87320, & + 0.90622, 0.93399, 0.95723, & + 0.97650, 0.99223, 1.00000 / +#else +! Oct 23, 2012 +! QBO setting with ptop = 0.1 mb, pint ~ 60 mb + data a47/ 10.00000, 24.45365, 48.76776, & + 85.39458, 133.41983, 191.01402, & + 257.94919, 336.63306, 431.52741, & + 548.18995, 692.78825, 872.16512, & + 1094.18467, 1368.11917, 1704.99489, & + 2117.91945, 2622.42986, 3236.88281, & + 3982.89623, 4885.84733, 5975.43260, & + 7019.26669, 7796.15848, 8346.60209, & + 8700.31838, 8878.27554, 8894.27179, & + 8756.46404, 8469.60171, 8038.92687, & + 7475.89006, 6803.68067, 6058.68992, & + 5285.28859, 4526.01565, 3813.00206, & + 3164.95553, 2589.26318, 2085.96929, & + 1651.11596, 1278.81205, 962.38875, & + 695.07046, 470.40784, 282.61654, & + 126.92745, 0.00000, 0.00000 / + data b47/ 0.0000, 0.0000, 0.0000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00267, 0.01063, 0.02393, & + 0.04282, 0.06771, 0.09917, & + 0.13786, 0.18444, 0.23925, & + 0.30193, 0.37100, 0.44379, & + 0.51695, 0.58727, 0.65236, & + 0.71094, 0.76262, 0.80757, & + 0.84626, 0.87930, 0.90731, & + 0.93094, 0.95077, 0.96733, & + 0.98105, 0.99223, 1.00000 / +#endif + + data a48/ & + 1.00000, 2.69722, 5.17136, & + 8.89455, 14.24790, 22.07157, & + 33.61283, 50.48096, 74.79993, & + 109.40055, 158.00460, 225.44108, & + 317.89560, 443.19350, 611.11558, & + 833.74392, 1125.83405, 1505.20759, & + 1993.15829, 2614.86254, 3399.78420, & + 4382.06240, 5600.87014, 7100.73115, & + 8931.78242, 11149.97021, 13817.16841, & + 17001.20930, 20775.81856, 23967.33875, & + 25527.64563, 25671.22552, 24609.29622, & + 22640.51220, 20147.13482, 17477.63530, & + 14859.86462, 12414.92533, 10201.44191, & + 8241.50255, 6534.43202, 5066.17865, & + 3815.60705, 2758.60264, 1870.64631, & + 1128.33931, 510.47983, 0.00000, & + 0.00000 / + + data b48/ & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.01253, & + 0.04887, 0.10724, 0.18455, & + 0.27461, 0.36914, 0.46103, & + 0.54623, 0.62305, 0.69099, & + 0.75016, 0.80110, 0.84453, & + 0.88127, 0.91217, 0.93803, & + 0.95958, 0.97747, 0.99223, & + 1.00000 / + +! High PBL resolution with top at 1 mb +! SJL modified May 7, 2013 to ptop ~ 100 mb + data a54/100.00000, 254.83931, 729.54278, & + 1602.41121, 2797.50667, 4100.18977, & + 5334.87140, 6455.24153, 7511.80944, & + 8580.26355, 9714.44293, 10938.62253, & + 12080.36051, 12987.13921, 13692.75084, & + 14224.92180, 14606.55444, 14856.69953, & + 14991.32121, 15023.90075, 14965.91493, & + 14827.21612, 14616.33505, 14340.72252, & + 14006.94280, 13620.82849, 13187.60470, & + 12711.98873, 12198.27003, 11650.37451, & + 11071.91608, 10466.23819, 9836.44706, & + 9185.43852, 8515.96231, 7831.01080, & + 7135.14301, 6436.71659, 5749.00215, & + 5087.67188, 4465.67510, 3889.86419, & + 3361.63433, 2879.51065, 2441.02496, & + 2043.41345, 1683.80513, 1359.31122, & + 1067.09135, 804.40101, 568.62625, & + 357.32525, 168.33263, 0.00000, & + 0.00000 / + + data b54/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00180, 0.00694, 0.01510, & + 0.02601, 0.03942, 0.05515, & + 0.07302, 0.09288, 0.11459, & + 0.13803, 0.16307, 0.18960, & + 0.21753, 0.24675, 0.27716, & + 0.30866, 0.34115, 0.37456, & + 0.40879, 0.44375, 0.47935, & + 0.51551, 0.55215, 0.58916, & + 0.62636, 0.66334, 0.69946, & + 0.73395, 0.76622, 0.79594, & + 0.82309, 0.84780, 0.87020, & + 0.89047, 0.90876, 0.92524, & + 0.94006, 0.95336, 0.96529, & + 0.97596, 0.98551, 0.99400, & + 1.00000 / + + +! The 56-L setup + data a56/ 10.00000, 24.97818, 58.01160, & + 115.21466, 199.29210, 309.39897, & + 445.31785, 610.54747, 812.28518, & + 1059.80882, 1363.07092, 1732.09335, & + 2176.91502, 2707.68972, 3334.70962, & + 4068.31964, 4918.76594, 5896.01890, & + 7009.59166, 8268.36324, 9680.41211, & + 11252.86491, 12991.76409, 14901.95764, & + 16987.01313, 19249.15733, 21689.24182, & + 23845.11055, 25330.63353, 26243.52467, & + 26663.84998, 26657.94696, 26281.61371, & + 25583.05256, 24606.03265, 23393.39510, & + 21990.28845, 20445.82122, 18811.93894, & + 17139.59660, 15473.90350, 13850.50167, & + 12294.49060, 10821.62655, 9440.57746, & + 8155.11214, 6965.72496, 5870.70511, & + 4866.83822, 3949.90019, 3115.03562, & + 2357.07879, 1670.87329, 1051.65120, & + 495.51399, 0.00000, 0.00000 / + + data b56 /0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00462, 0.01769, 0.03821, & + 0.06534, 0.09834, 0.13659, & + 0.17947, 0.22637, 0.27660, & + 0.32929, 0.38343, 0.43791, & + 0.49162, 0.54361, 0.59319, & + 0.63989, 0.68348, 0.72391, & + 0.76121, 0.79545, 0.82679, & + 0.85537, 0.88135, 0.90493, & + 0.92626, 0.94552, 0.96286, & + 0.97840, 0.99223, 1.00000 / + + data a60gfs/300.0000, 430.00000, 558.00000, & + 700.00000, 863.05803, 1051.07995, & + 1265.75194, 1510.71101, 1790.05098, & + 2108.36604, 2470.78817, 2883.03811, & + 3351.46002, 3883.05187, 4485.49315, & + 5167.14603, 5937.04991, 6804.87379, & + 7780.84698, 8875.64338, 10100.20534, & + 11264.35673, 12190.64366, 12905.42546, & + 13430.87867, 13785.88765, 13986.77987, & + 14047.96335, 13982.46770, 13802.40331, & + 13519.33841, 13144.59486, 12689.45608, & + 12165.28766, 11583.57006, 10955.84778, & + 10293.60402, 9608.08306, 8910.07678, & + 8209.70131, 7516.18560, 6837.69250, & + 6181.19473, 5552.39653, 4955.72632, & + 4394.37629, 3870.38682, 3384.76586, & + 2937.63489, 2528.37666, 2155.78385, & + 1818.20722, 1513.68173, 1240.03585, & + 994.99144, 776.23591, 581.48797, & + 408.53400, 255.26520, 119.70243, 0. / + + data b60gfs/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00201, 0.00792, 0.01755, & + 0.03079, 0.04751, 0.06761, & + 0.09097, 0.11746, 0.14690, & + 0.17911, 0.21382, 0.25076, & + 0.28960, 0.32994, 0.37140, & + 0.41353, 0.45589, 0.49806, & + 0.53961, 0.58015, 0.61935, & + 0.65692, 0.69261, 0.72625, & + 0.75773, 0.78698, 0.81398, & + 0.83876, 0.86138, 0.88192, & + 0.90050, 0.91722, 0.93223, & + 0.94565, 0.95762, 0.96827, & + 0.97771, 0.98608, 0.99347, 1./ + +! NAM levels + data a60/200., 1311.4934, 2424.6044, 3541.7594,& + 4662.9584, 5790.2234, 6932.6534, 8095.3034,& + 9278.1734, 10501.4834, 11755.1234, 13049.2034,& + 14403.9434, 15809.2334, 17315.6234, 18953.4434,& + 20783.3534, 22815.4634, 25059.8834, 27567.1634,& + 30148.42896047, 32193.91776039, 33237.35176644, 33332.15200668,& + 32747.34688095, 31710.06232008, 30381.0344269, 28858.71577772,& + 27218.00439794, 25500.31691133, 23734.52294749, 21947.3406187,& + 20167.06984021, 18396.08144096, 16688.20978135, 15067.73749198,& + 13564.49530178, 12183.34512952, 10928.24869364, 9815.02787644,& + 8821.38325756, 7943.05793658, 7181.90985128, 6500.94645341,& + 5932.84856135, 5420.87683616, 4959.15585353, 4522.15047657,& + 4103.63596619, 3703.72540955, 3322.52525084, 2953.65688391,& + 2597.18532669, 2253.10764634, 1915.10585833, 1583.14516612,& + 1257.18953818, 937.3977544 , 623.60136981, 311.11085215,& + 0. / + data b60/0., 0., 0., 0., 0.,& + 0. , 0. , 0. , 0. , 0. ,& + 0. , 0. , 0. , 0. , 0. ,& + 0. , 0. , 0. , 0. , 0. ,& + 0.0014653 , 0.01021565, 0.0301554 , 0.06025816, 0.09756877,& + 0.13994493, 0.18550048, 0.23318371, 0.2819159 , 0.33120838,& + 0.38067633, 0.42985641, 0.47816985, 0.52569303, 0.57109611,& + 0.61383996, 0.6532309 , 0.68922093, 0.72177094, 0.75052515,& + 0.77610288, 0.79864598, 0.81813309, 0.83553022, 0.85001773,& + 0.86305395, 0.8747947 , 0.88589325, 0.89650986, 0.9066434 ,& + 0.91629284, 0.92562094, 0.93462705, 0.94331221, 0.95183659,& + 0.96020153, 0.96840839, 0.97645359, 0.98434181, 0.99219119, 1. / + + +! This is activated by USE_GFSL63 +! Thfollowing L63 setting is the same as NCEP GFS's L64 except the top +! 3 layers + data a63/64.247, 137.790, 221.958, & + 318.266, 428.434, 554.424, & + 698.457, 863.05803, 1051.07995, & + 1265.75194, 1510.71101, 1790.05098, & + 2108.36604, 2470.78817, 2883.03811, & + 3351.46002, 3883.05187, 4485.49315, & + 5167.14603, 5937.04991, 6804.87379, & + 7780.84698, 8875.64338, 10100.20534, & + 11264.35673, 12190.64366, 12905.42546, & + 13430.87867, 13785.88765, 13986.77987, & + 14047.96335, 13982.46770, 13802.40331, & + 13519.33841, 13144.59486, 12689.45608, & + 12165.28766, 11583.57006, 10955.84778, & + 10293.60402, 9608.08306, 8910.07678, & + 8209.70131, 7516.18560, 6837.69250, & + 6181.19473, 5552.39653, 4955.72632, & + 4394.37629, 3870.38682, 3384.76586, & + 2937.63489, 2528.37666, 2155.78385, & + 1818.20722, 1513.68173, 1240.03585, & + 994.99144, 776.23591, 581.48797, & + 408.53400, 255.26520, 119.70243, 0. / + + data b63/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00201, 0.00792, 0.01755, & + 0.03079, 0.04751, 0.06761, & + 0.09097, 0.11746, 0.14690, & + 0.17911, 0.21382, 0.25076, & + 0.28960, 0.32994, 0.37140, & + 0.41353, 0.45589, 0.49806, & + 0.53961, 0.58015, 0.61935, & + 0.65692, 0.69261, 0.72625, & + 0.75773, 0.78698, 0.81398, & + 0.83876, 0.86138, 0.88192, & + 0.90050, 0.91722, 0.93223, & + 0.94565, 0.95762, 0.96827, & + 0.97771, 0.98608, 0.99347, 1./ + + data a63meso/ 64.247, 234.14925, 444.32075, & + 719.10698, 1077.83197, 1545.21700, & + 2152.6203, 2939.37353, 3954.07197, & + 5255.55443, 6913.13424, 8955.12932, & + 10898.75012, 12137.76737, 12858.09331, & + 13388.26761, 13747.35846, 13951.85268, & + 14016.29356, 13953.82551, 13776.65318, & + 13496.41874, 13124.49605, 12672.19867, & + 12150.90036, 11572.06889, 10947.21741, & + 10287.78472, 9604.96173, 8909.48448, & + 8211.41625, 7519.94125, 6843.19133, & + 6188.11962, 5560.42852, 4964.55636, & + 4403.71643, 3879.97894, 3394.38835, & + 2996.77033, 2730.02573, 2530.11329, & + 2339.36720, 2157.57530, 1984.53745, & + 1820.00086, 1663.72705, 1515.43668, & + 1374.86622, 1241.72259, 1115.72934, & + 996.58895, 884.02079, 777.73138, & + 677.44387, 582.87349, 493.75161, & + 409.80694, 330.78356, 256.42688, & + 186.49670, 120.75560, 58.97959, 0. / + + data b63meso/ 0. , 0. , 0. , & + 0. , 0. , 0. , & + 0. , 0. , 0. , & + 0. , 0. , 0.0005 , & + 0.00298, 0.00885, 0.01845, & + 0.03166, 0.04836, 0.06842, & + 0.09175, 0.1182 , 0.14759, & + 0.17974, 0.21438, 0.25123, & + 0.28997, 0.33022, 0.37157, & + 0.41359, 0.45584, 0.49791, & + 0.53936, 0.57981, 0.61894, & + 0.65645, 0.6921 , 0.72571, & + 0.75717, 0.78642, 0.81343, & + 0.83547, 0.85023, 0.86128, & + 0.8718 , 0.88182, 0.89135, & + 0.9004 , 0.90898, 0.91712, & + 0.92483, 0.93213, 0.93904, & + 0.94556, 0.95172, 0.95754, & + 0.96302, 0.96819, 0.97306, & + 0.97764, 0.98196, 0.98601, & + 0.98983, 0.99341, 0.99678, 1. / + + data a64gfs/20.00000, 68.00000, 137.79000, & + 221.95800, 318.26600, 428.43400, & + 554.42400, 698.45700, 863.05803, & + 1051.07995, 1265.75194, 1510.71101, & + 1790.05098, 2108.36604, 2470.78817, & + 2883.03811, 3351.46002, 3883.05187, & + 4485.49315, 5167.14603, 5937.04991, & + 6804.87379, 7780.84698, 8875.64338, & + 9921.40745, 10760.99844, 11417.88354, & + 11911.61193, 12258.61668, 12472.89642, & + 12566.58298, 12550.43517, 12434.26075, & + 12227.27484, 11938.39468, 11576.46910, & + 11150.43640, 10669.41063, 10142.69482, & + 9579.72458, 8989.94947, 8382.67090, & + 7766.85063, 7150.91171, 6542.55077, & + 5948.57894, 5374.81094, 4825.99383, & + 4305.79754, 3816.84622, 3360.78848, & + 2938.39801, 2549.69756, 2194.08449, & + 1870.45732, 1577.34218, 1313.00028, & + 1075.52114, 862.90778, 673.13815, & + 504.22118, 354.22752, 221.32110, & + 103.78014, 0./ + data b64gfs/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00179, 0.00705, 0.01564, & + 0.02749, 0.04251, 0.06064, & + 0.08182, 0.10595, 0.13294, & + 0.16266, 0.19492, 0.22950, & + 0.26615, 0.30455, 0.34435, & + 0.38516, 0.42656, 0.46815, & + 0.50949, 0.55020, 0.58989, & + 0.62825, 0.66498, 0.69987, & + 0.73275, 0.76351, 0.79208, & + 0.81845, 0.84264, 0.86472, & + 0.88478, 0.90290, 0.91923, & + 0.93388, 0.94697, 0.95865, & + 0.96904, 0.97826, 0.98642, & + 0.99363, 1./ + + data a64/1.00000, 3.90000, 8.70000, & + 15.42000, 24.00000, 34.50000, & + 47.00000, 61.50000, 78.60000, & + 99.13500, 124.12789, 154.63770, & + 191.69700, 236.49300, 290.38000, & + 354.91000, 431.82303, 523.09300, & + 630.92800, 757.79000, 906.45000, & + 1079.85000, 1281.00000, 1515.00000, & + 1788.00000, 2105.00000, 2470.00000, & + 2889.00000, 3362.00000, 3890.00000, & + 4475.00000, 5120.00000, 5830.00000, & + 6608.00000, 7461.00000, 8395.00000, & + 9424.46289, 10574.46880, 11864.80270, & + 13312.58890, 14937.03710, 16759.70700, & + 18804.78710, 21099.41210, 23674.03710, & + 26562.82810, 29804.11720, 32627.31640, & + 34245.89840, 34722.28910, 34155.19920, & + 32636.50390, 30241.08200, 27101.44920, & + 23362.20700, 19317.05270, 15446.17090, & + 12197.45210, 9496.39941, 7205.66992, & + 5144.64307, 3240.79346, 1518.62134, & + 0.00000, 0.00000 / + + data b64/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00813, & + 0.03224, 0.07128, 0.12445, & + 0.19063, 0.26929, 0.35799, & + 0.45438, 0.55263, 0.64304, & + 0.71703, 0.77754, 0.82827, & + 0.87352, 0.91502, 0.95235, & + 0.98511, 1.00000 / + +!-->cjg + data a68/1.00000, 2.68881, 5.15524, & + 8.86683, 14.20349, 22.00278, & + 33.50807, 50.32362, 74.56680, & + 109.05958, 157.51214, 224.73844, & + 316.90481, 441.81219, 609.21090, & + 831.14537, 1122.32514, 1500.51628, & + 1986.94617, 2606.71274, 3389.18802, & + 4368.40473, 5583.41379, 7078.60015, & + 8903.94455, 11115.21886, 13774.60566, & + 16936.82070, 20340.47045, 23193.71492, & + 24870.36141, 25444.59363, 25252.57081, & + 24544.26211, 23474.29096, 22230.65331, & + 20918.50731, 19589.96280, 18296.26682, & + 17038.02866, 15866.85655, 14763.18943, & + 13736.83624, 12794.11850, 11930.72442, & + 11137.17217, 10404.78946, 9720.03954, & + 9075.54055, 8466.72650, 7887.12346, & + 7333.90490, 6805.43028, 6297.33773, & + 5805.78227, 5327.94995, 4859.88765, & + 4398.63854, 3942.81761, 3491.08449, & + 3043.04531, 2598.71608, 2157.94527, & + 1720.87444, 1287.52805, 858.02944, & + 432.71276, 8.10905, 0.00000 / + + data b68/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00283, 0.01590, & + 0.04412, 0.08487, 0.13284, & + 0.18470, 0.23828, 0.29120, & + 0.34211, 0.39029, 0.43518, & + 0.47677, 0.51536, 0.55091, & + 0.58331, 0.61263, 0.63917, & + 0.66333, 0.68552, 0.70617, & + 0.72555, 0.74383, 0.76117, & + 0.77765, 0.79335, 0.80838, & + 0.82287, 0.83693, 0.85069, & + 0.86423, 0.87760, 0.89082, & + 0.90392, 0.91689, 0.92973, & + 0.94244, 0.95502, 0.96747, & + 0.97979, 0.99200, 1.00000 / + + data a96/1.00000, 2.35408, 4.51347, & + 7.76300, 12.43530, 19.26365, & + 29.33665, 44.05883, 65.28397, & + 95.48274, 137.90344, 196.76073, & + 277.45330, 386.81095, 533.37018, & + 727.67600, 982.60677, 1313.71685, & + 1739.59104, 2282.20281, 2967.26766, & + 3824.58158, 4888.33404, 6197.38450, & + 7795.49158, 9731.48414, 11969.71024, & + 14502.88894, 17304.52434, 20134.76139, & + 22536.63814, 24252.54459, 25230.65591, & + 25585.72044, 25539.91412, 25178.87141, & + 24644.84493, 23978.98781, 23245.49366, & + 22492.11600, 21709.93990, 20949.64473, & + 20225.94258, 19513.31158, 18829.32485, & + 18192.62250, 17589.39396, 17003.45386, & + 16439.01774, 15903.91204, 15396.39758, & + 14908.02140, 14430.65897, 13967.88643, & + 13524.16667, 13098.30227, 12687.56457, & + 12287.08757, 11894.41553, 11511.54106, & + 11139.22483, 10776.01912, 10419.75711, & + 10067.11881, 9716.63489, 9369.61967, & + 9026.69066, 8687.29884, 8350.04978, & + 8013.20925, 7677.12187, 7343.12994, & + 7011.62844, 6681.98102, 6353.09764, & + 6025.10535, 5699.10089, 5375.54503, & + 5053.63074, 4732.62740, 4413.38037, & + 4096.62775, 3781.79777, 3468.45371, & + 3157.19882, 2848.25306, 2541.19150, & + 2236.21942, 1933.50628, 1632.83741, & + 1334.35954, 1038.16655, 744.22318, & + 452.71094, 194.91899, 0.00000, & + 0.00000 / + + data b96/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00193, & + 0.00974, 0.02538, 0.04876, & + 0.07817, 0.11081, 0.14514, & + 0.18007, 0.21486, 0.24866, & + 0.28088, 0.31158, 0.34030, & + 0.36701, 0.39210, 0.41554, & + 0.43733, 0.45774, 0.47707, & + 0.49540, 0.51275, 0.52922, & + 0.54495, 0.56007, 0.57459, & + 0.58850, 0.60186, 0.61471, & + 0.62715, 0.63922, 0.65095, & + 0.66235, 0.67348, 0.68438, & + 0.69510, 0.70570, 0.71616, & + 0.72651, 0.73675, 0.74691, & + 0.75700, 0.76704, 0.77701, & + 0.78690, 0.79672, 0.80649, & + 0.81620, 0.82585, 0.83542, & + 0.84492, 0.85437, 0.86375, & + 0.87305, 0.88229, 0.89146, & + 0.90056, 0.90958, 0.91854, & + 0.92742, 0.93623, 0.94497, & + 0.95364, 0.96223, 0.97074, & + 0.97918, 0.98723, 0.99460, & + 1.00000 / +!<--cjg +! +! Ultra high troposphere resolution + data a100/100.00000, 300.00000, 800.00000, & + 1762.35235, 3106.43596, 4225.71874, & + 4946.40525, 5388.77387, 5708.35540, & + 5993.33124, 6277.73673, 6571.49996, & + 6877.05339, 7195.14327, 7526.24920, & + 7870.82981, 8229.35361, 8602.30193, & + 8990.16936, 9393.46399, 9812.70768, & + 10248.43625, 10701.19980, 11171.56286, & + 11660.10476, 12167.41975, 12694.11735, & + 13240.82253, 13808.17600, 14396.83442, & + 15007.47066, 15640.77407, 16297.45067, & + 16978.22343, 17683.83253, 18415.03554, & + 19172.60771, 19957.34218, 20770.05022, & + 21559.14829, 22274.03147, 22916.87519, & + 23489.70456, 23994.40187, 24432.71365, & + 24806.25734, 25116.52754, 25364.90190, & + 25552.64670, 25680.92203, 25750.78675, & + 25763.20311, 25719.04113, 25619.08274, & + 25464.02630, 25254.49482, 24991.06137, & + 24674.32737, 24305.11235, 23884.79781, & + 23415.77059, 22901.76510, 22347.84738, & + 21759.93950, 21144.07284, 20505.73136, & + 19849.54271, 19179.31412, 18498.23400, & + 17809.06809, 17114.28232, 16416.10343, & + 15716.54833, 15017.44246, 14320.43478, & + 13627.01116, 12938.50682, 12256.11762, & + 11580.91062, 10913.83385, 10255.72526, & + 9607.32122, 8969.26427, 8342.11044, & + 7726.33606, 7122.34405, 6530.46991, & + 5950.98721, 5384.11279, 4830.01153, & + 4288.80090, 3760.55514, 3245.30920, & + 2743.06250, 2253.78294, 1777.41285, & + 1313.88054, 863.12371, 425.13088, & + 0.00000, 0.00000 / + + + data b100/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00052, 0.00209, 0.00468, & + 0.00828, 0.01288, 0.01849, & + 0.02508, 0.03266, 0.04121, & + 0.05075, 0.06126, 0.07275, & + 0.08521, 0.09866, 0.11308, & + 0.12850, 0.14490, 0.16230, & + 0.18070, 0.20009, 0.22042, & + 0.24164, 0.26362, 0.28622, & + 0.30926, 0.33258, 0.35605, & + 0.37958, 0.40308, 0.42651, & + 0.44981, 0.47296, 0.49591, & + 0.51862, 0.54109, 0.56327, & + 0.58514, 0.60668, 0.62789, & + 0.64872, 0.66919, 0.68927, & + 0.70895, 0.72822, 0.74709, & + 0.76554, 0.78357, 0.80117, & + 0.81835, 0.83511, 0.85145, & + 0.86736, 0.88286, 0.89794, & + 0.91261, 0.92687, 0.94073, & + 0.95419, 0.96726, 0.97994, & + 0.99223, 1.00000 / + + data a104/ & + 1.8827062944e-01, 7.7977549145e-01, 2.1950593583e+00, & + 4.9874566624e+00, 9.8041418997e+00, 1.7019717163e+01, & + 2.7216579591e+01, 4.0518628401e+01, 5.6749646818e+01, & + 7.5513868331e+01, 9.6315093333e+01, 1.1866706195e+02, & + 1.4216835396e+02, 1.6653733709e+02, 1.9161605772e+02, & + 2.1735580129e+02, 2.4379516604e+02, 2.7103771847e+02, & + 2.9923284173e+02, 3.2856100952e+02, 3.5922338766e+02, & + 3.9143507908e+02, 4.2542117983e+02, 4.6141487902e+02, & + 4.9965698106e+02, 5.4039638379e+02, 5.8389118154e+02, & + 6.3041016829e+02, 6.8023459505e+02, 7.3366009144e+02, & + 7.9099869949e+02, 8.5258099392e+02, 9.1875827946e+02, & + 9.8990486716e+02, 1.0664204381e+03, 1.1487325074e+03, & + 1.2372990044e+03, 1.3326109855e+03, 1.4351954993e+03, & + 1.5456186222e+03, 1.6644886848e+03, 1.7924597105e+03, & + 1.9302350870e+03, 2.0785714934e+03, 2.2382831070e+03, & + 2.4102461133e+03, 2.5954035462e+03, 2.7947704856e+03, & + 3.0094396408e+03, 3.2405873512e+03, 3.4894800360e+03, & + 3.7574811281e+03, 4.0460585279e+03, 4.3567926151e+03, & + 4.6913848588e+03, 5.0516670674e+03, 5.4396113207e+03, & + 5.8573406270e+03, 6.3071403487e+03, 6.7914704368e+03, & + 7.3129785102e+03, 7.8745138115e+03, 8.4791420557e+03, & + 9.1301611750e+03, 9.8311179338e+03, 1.0585825354e+04, & + 1.1398380836e+04, 1.2273184781e+04, 1.3214959424e+04, & + 1.4228767429e+04, 1.5320029596e+04, 1.6494540743e+04, & + 1.7758482452e+04, 1.9118430825e+04, 2.0422798801e+04, & + 2.1520147587e+04, 2.2416813461e+04, 2.3118184510e+04, & + 2.3628790785e+04, 2.3952411814e+04, 2.4092209011e+04, & + 2.4050892106e+04, 2.3830930156e+04, 2.3434818358e+04, & + 2.2865410898e+04, 2.2126326004e+04, 2.1222420323e+04, & + 2.0160313690e+04, 1.8948920926e+04, 1.7599915822e+04, & + 1.6128019809e+04, 1.4550987232e+04, 1.2889169132e+04, & + 1.1164595563e+04, 9.4227665517e+03, 7.7259097899e+03, & + 6.1538244381e+03, 4.7808126007e+03, 3.5967415552e+03, & + 2.5886394104e+03, 1.7415964865e+03, 1.0393721271e+03, & + 4.6478852032e+02, 7.0308342481e-13, 0.0000000000e+00 / + + + data b104/ & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 0.0000000000e+00, & + 0.0000000000e+00, 0.0000000000e+00, 1.5648447298e-03, & + 6.2617046389e-03, 1.4104157933e-02, 2.5118187415e-02, & + 3.9340510972e-02, 5.6816335609e-02, 7.7596328431e-02, & + 1.0173255472e-01, 1.2927309709e-01, 1.6025505622e-01, & + 1.9469566981e-01, 2.3258141217e-01, 2.7385520518e-01, & + 3.1840233814e-01, 3.6603639170e-01, 4.1648734767e-01, & + 4.6939496013e-01, 5.2431098738e-01, 5.8071350676e-01, & + 6.3803478105e-01, 6.9495048840e-01, 7.4963750338e-01, & + 7.9975208897e-01, 8.4315257576e-01, 8.8034012292e-01, & + 9.1184389721e-01, 9.3821231526e-01, 9.6000677644e-01, & + 9.7779792223e-01, 9.9216315122e-01, 1.0000000000e+00 / + +! IFS-like L125(top 12 levels removed from IFSL137) + data a125/ 64., & + 86.895882, 107.415741, 131.425507, 159.279404, 191.338562, & + 227.968948, 269.539581, 316.420746, 368.982361, 427.592499, 492.616028, & + 564.413452, 643.339905, 729.744141, 823.967834, 926.344910, 1037.201172, & + 1156.853638, 1285.610352, 1423.770142, 1571.622925, 1729.448975, 1897.519287, & + 2076.095947, 2265.431641, 2465.770508, 2677.348145, 2900.391357, 3135.119385, & + 3381.743652, 3640.468262, 3911.490479, 4194.930664, 4490.817383, 4799.149414, & + 5119.895020, 5452.990723, 5798.344727, 6156.074219, 6526.946777, 6911.870605, & + 7311.869141, 7727.412109, 8159.354004, 8608.525391, 9076.400391, 9562.682617, & + 10065.978516, 10584.631836, 11116.662109, 11660.067383, 12211.547852, 12766.873047, & + 13324.668945, 13881.331055, 14432.139648, 14975.615234, 15508.256836, 16026.115234, & + 16527.322266, 17008.789063, 17467.613281, 17901.621094, 18308.433594, 18685.718750, & + 19031.289063, 19343.511719, 19620.042969, 19859.390625, 20059.931641, 20219.664063, & + 20337.863281, 20412.308594, 20442.078125, 20425.718750, 20361.816406, 20249.511719, & + 20087.085938, 19874.025391, 19608.572266, 19290.226563, 18917.460938, 18489.707031, & + 18006.925781, 17471.839844, 16888.687500, 16262.046875, 15596.695313, 14898.453125, & + 14173.324219, 13427.769531, 12668.257813, 11901.339844, 11133.304688, 10370.175781, & + 9617.515625, 8880.453125, 8163.375000, 7470.343750, 6804.421875, 6168.531250, & + 5564.382813, 4993.796875, 4457.375000, 3955.960938, 3489.234375, 3057.265625, & + 2659.140625, 2294.242188, 1961.500000, 1659.476563, 1387.546875, 1143.250000, & + 926.507813, 734.992188, 568.062500, 424.414063, 302.476563, 202.484375, & + 122.101563, 62.781250, 22.835938, 3.757813, 0.000000, 0.000000 / + + data b125/ 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000007, 0.000024, 0.000059, 0.000112, 0.000199, & + 0.000340, 0.000562, 0.000890, 0.001353, 0.001992, 0.002857, & + 0.003971, 0.005378, 0.007133, 0.009261, 0.011806, 0.014816, & + 0.018318, 0.022355, 0.026964, 0.032176, 0.038026, 0.044548, & + 0.051773, 0.059728, 0.068448, 0.077958, 0.088286, 0.099462, & + 0.111505, 0.124448, 0.138313, 0.153125, 0.168910, 0.185689, & + 0.203491, 0.222333, 0.242244, 0.263242, 0.285354, 0.308598, & + 0.332939, 0.358254, 0.384363, 0.411125, 0.438391, 0.466003, & + 0.493800, 0.521619, 0.549301, 0.576692, 0.603648, 0.630036, & + 0.655736, 0.680643, 0.704669, 0.727739, 0.749797, 0.770798, & + 0.790717, 0.809536, 0.827256, 0.843881, 0.859432, 0.873929, & + 0.887408, 0.899900, 0.911448, 0.922096, 0.931881, 0.940860, & + 0.949064, 0.956550, 0.963352, 0.969513, 0.975078, 0.980072, & + 0.984542, 0.988500, 0.991984, 0.995003, 0.997630, 1.000000 / + + + +#endif _FV_ETA_ diff --git a/tools/fv_grid_tools.F90 b/tools/fv_grid_tools.F90 index 73deceb29..5a3a964a4 100644 --- a/tools/fv_grid_tools.F90 +++ b/tools/fv_grid_tools.F90 @@ -120,11 +120,11 @@ module fv_grid_tools_mod use fv_grid_utils_mod, only: gnomonic_grids, great_circle_dist, & mid_pt_sphere, spherical_angle, & cell_center2, get_area, inner_prod, fill_ghost, & - direct_transform, dist2side_latlon, & + direct_transform, cube_transform, dist2side_latlon, & spherical_linear_interpolation, big_number use fv_timing_mod, only: timing_on, timing_off - use fv_mp_mod, only: ng, is_master, fill_corners, XDir, YDir - use fv_mp_mod, only: mp_gather, mp_bcst, mp_reduce_max, mp_stop + use fv_mp_mod, only: is_master, fill_corners, XDir, YDir + use fv_mp_mod, only: mp_gather, mp_bcst, mp_reduce_max, mp_stop, grids_master_procs use sorted_index_mod, only: sorted_inta, sorted_intb use mpp_mod, only: mpp_error, FATAL, get_unit, mpp_chksum, mpp_pe, stdout, & mpp_send, mpp_recv, mpp_sync_self, EVENT_RECV, mpp_npes, & @@ -150,6 +150,7 @@ module fv_grid_tools_mod get_global_att_value, get_var_att_value use mosaic_mod, only : get_mosaic_ntiles + use mpp_mod, only: mpp_transmit, mpp_recv implicit none private #include @@ -188,7 +189,7 @@ subroutine read_grid(Atm, grid_file, ndims, nregions, ng) integer :: start(4), nread(4) integer :: is, ie, js, je integer :: isd, ied, jsd, jed - integer,save :: halo=3 + integer,save :: halo=3 ! for regional domain external tools is = Atm%bd%is ie = Atm%bd%ie @@ -230,12 +231,11 @@ subroutine read_grid(Atm, grid_file, ndims, nregions, ng) !FIXME: Doesn't work for a nested grid ntiles = get_mosaic_ntiles(atm_mosaic) - - if( .not. Atm%flagstruct%regional) then !<-- The regional setup has only 1 tile so do not shutdown in that case. - if(ntiles .NE. 6) call mpp_error(FATAL, & - 'fv_grid_tools(read_grid): ntiles should be 6 in mosaic file '//trim(atm_mosaic) ) - if(nregions .NE. 6) call mpp_error(FATAL, & - 'fv_grid_tools(read_grid): nregions should be 6 when reading from mosaic file '//trim(grid_file) ) + if( .not. Atm%gridstruct%bounded_domain) then !<-- The regional setup has only 1 tile so do not shutdown in that case. + if(ntiles .NE. 6) call mpp_error(FATAL, & + 'fv_grid_tools(read_grid): ntiles should be 6 in mosaic file '//trim(atm_mosaic) ) + if(nregions .NE. 6) call mpp_error(FATAL, & + 'fv_grid_tools(read_grid): nregions should be 6 when reading from mosaic file '//trim(grid_file) ) endif call get_var_att_value(atm_hgrid, 'x', 'units', units) @@ -243,7 +243,7 @@ subroutine read_grid(Atm, grid_file, ndims, nregions, ng) !--- get the geographical coordinates of super-grid. isc2 = 2*is-1; iec2 = 2*ie+1 jsc2 = 2*js-1; jec2 = 2*je+1 - if( Atm%flagstruct%regional) then + if( Atm%gridstruct%bounded_domain ) then isc2 = 2*(isd+halo)-1; iec2 = 2*(ied+1+halo)-1 ! For the regional domain the cell corner locations must be transferred jsc2 = 2*(jsd+halo)-1; jec2 = 2*(jed+1+halo)-1 ! from the entire supergrid to the compute grid, including the halo region. endif @@ -263,14 +263,14 @@ subroutine read_grid(Atm, grid_file, ndims, nregions, ng) if(len_trim(units) < 6) call mpp_error(FATAL, & "fv_grid_tools_mod(read_grid): the length of units must be no less than 6") if(units(1:6) == 'degree') then - if( .not. Atm%flagstruct%regional) then - do j = js, je+1 + if( .not. Atm%gridstruct%bounded_domain) then + do j = js, je+1 do i = is, ie+1 grid(i,j,1) = tmpx(2*i-1,2*j-1)*pi/180. grid(i,j,2) = tmpy(2*i-1,2*j-1)*pi/180. enddo - enddo - else + enddo + else ! !*** In the regional case the halo surrounding the domain was included in the read. !*** Transfer the compute and halo regions to the compute grid. @@ -526,7 +526,7 @@ end subroutine get_symmetry !>@brief The subroutine 'init_grid' reads the grid from the input file !! and sets up grid descriptors. - subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, ng) + subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, ng, tile_coarse) !-------------------------------------------------------- type(fv_atmos_type), intent(inout), target :: Atm character(len=80), intent(IN) :: grid_name @@ -535,6 +535,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, integer, intent(IN) :: ndims integer, intent(IN) :: nregions integer, intent(IN) :: ng + integer, intent(IN) :: tile_coarse(:) !-------------------------------------------------------- real(kind=R_GRID) :: xs(npx,npy) real(kind=R_GRID) :: ys(npx,npy) @@ -649,7 +650,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, have_north_pole => Atm%gridstruct%have_north_pole stretched_grid => Atm%gridstruct%stretched_grid - tile => Atm%tile + tile => Atm%tile_of_mosaic domain => Atm%domain @@ -659,7 +660,12 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, latlon = .false. cubed_sphere = .false. - if ( Atm%flagstruct%do_schmidt .and. abs(atm%flagstruct%stretch_fac-1.) > 1.E-5 ) stretched_grid = .true. + if ( (Atm%flagstruct%do_schmidt .or. Atm%flagstruct%do_cube_transform) .and. abs(atm%flagstruct%stretch_fac-1.) > 1.E-5 ) then + stretched_grid = .true. + if (Atm%flagstruct%do_schmidt .and. Atm%flagstruct%do_cube_transform) then + call mpp_error(FATAL, ' Cannot set both do_schmidt and do_cube_transform to .true.') + endif + endif if (Atm%flagstruct%grid_type>3) then if (Atm%flagstruct%grid_type == 4) then @@ -671,7 +677,10 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, else cubed_sphere = .true. + if (Atm%neststruct%nested) then + !Read grid if it exists + ! still need to set up call setup_aligned_nest(Atm) else if(trim(grid_file) == 'INPUT/grid_spec.nc') then @@ -695,8 +704,8 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, ! Shift the corner away from Japan !--------------------------------- !--------------------- This will result in the corner close to east coast of China ------------------ - if ( .not.Atm%flagstruct%do_schmidt .and. (Atm%flagstruct%shift_fac)>1.E-4 ) & - grid_global(i,j,1,n) = grid_global(i,j,1,n) - pi/Atm%flagstruct%shift_fac + if ( .not. ( Atm%flagstruct%do_schmidt .or. Atm%flagstruct%do_cube_transform) .and. (Atm%flagstruct%shift_fac)>1.E-4 ) & + grid_global(i,j,1,n) = grid_global(i,j,1,n) - pi/Atm%flagstruct%shift_fac !---------------------------------------------------------------------------------------------------- if ( grid_global(i,j,1,n) < 0. ) & grid_global(i,j,1,n) = grid_global(i,j,1,n) + 2.*pi @@ -730,50 +739,53 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, !------------------------ ! Schmidt transformation: !------------------------ - if ( Atm%flagstruct%do_schmidt ) then - do n=1,nregions - call direct_transform(Atm%flagstruct%stretch_fac, 1, npx, 1, npy, & - Atm%flagstruct%target_lon, Atm%flagstruct%target_lat, & - n, grid_global(1:npx,1:npy,1,n), grid_global(1:npx,1:npy,2,n)) - enddo - endif - endif !is master - call mpp_broadcast(grid_global, size(grid_global), mpp_root_pe()) -!--- copy grid to compute domain - do n=1,ndims - do j=js,je+1 - do i=is,ie+1 - grid(i,j,n) = grid_global(i,j,n,tile) - enddo - enddo - enddo - endif !(trim(grid_file) == 'INPUT/grid_spec.nc') - + if ( Atm%flagstruct%do_schmidt ) then + do n=1,nregions + call direct_transform(Atm%flagstruct%stretch_fac, 1, npx, 1, npy, & + Atm%flagstruct%target_lon, Atm%flagstruct%target_lat, & + n, grid_global(1:npx,1:npy,1,n), grid_global(1:npx,1:npy,2,n)) + enddo + elseif (Atm%flagstruct%do_cube_transform) then + do n=1,nregions + call cube_transform(Atm%flagstruct%stretch_fac, 1, npx, 1, npy, & + Atm%flagstruct%target_lon, Atm%flagstruct%target_lat, & + n, grid_global(1:npx,1:npy,1,n), grid_global(1:npx,1:npy,2,n)) + enddo + endif + endif !is master + call mpp_broadcast(grid_global, size(grid_global), mpp_root_pe()) + !--- copy grid to compute domain + do n=1,ndims + do j=js,je+1 + do i=is,ie+1 + grid(i,j,n) = grid_global(i,j,n,tile) + enddo + enddo + enddo + endif !(trim(grid_file) == 'INPUT/grid_spec.nc') ! ! SJL: For phys/exchange grid, etc ! - call mpp_update_domains( grid, Atm%domain, position=CORNER) - if (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then - call fill_corners(grid(:,:,1), npx, npy, FILL=XDir, BGRID=.true.) - call fill_corners(grid(:,:,2), npx, npy, FILL=XDir, BGRID=.true.) - endif - - - !--- dx and dy - - if( .not. Atm%flagstruct%regional) then - istart=is - iend=ie - jstart=js - jend=je - else - istart=isd - iend=ied - jstart=jsd - jend=jed - endif - - do j = jstart, jend+1 + call mpp_update_domains( grid, Atm%domain, position=CORNER) + if (.not. (Atm%gridstruct%bounded_domain)) then + call fill_corners(grid(:,:,1), npx, npy, FILL=XDir, BGRID=.true.) + call fill_corners(grid(:,:,2), npx, npy, FILL=XDir, BGRID=.true.) + endif + + !--- dx and dy + if( .not. Atm%gridstruct%bounded_domain) then + istart=is + iend=ie + jstart=js + jend=je + else + istart=isd + iend=ied + jstart=jsd + jend=jed + endif + + do j = jstart, jend+1 do i = istart, iend p1(1) = grid(i ,j,1) p1(2) = grid(i ,j,2) @@ -781,9 +793,9 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, p2(2) = grid(i+1,j,2) dx(i,j) = great_circle_dist( p2, p1, radius ) enddo - enddo - if( stretched_grid ) then - do j = jstart, jend + enddo + if( stretched_grid .or. Atm%gridstruct%bounded_domain ) then + do j = jstart, jend do i = istart, iend+1 p1(1) = grid(i,j, 1) p1(2) = grid(i,j, 2) @@ -791,28 +803,28 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, p2(2) = grid(i,j+1,2) dy(i,j) = great_circle_dist( p2, p1, radius ) enddo - enddo - else - call get_symmetry(dx(is:ie,js:je+1), dy(is:ie+1,js:je), 0, 1, Atm%layout(1), Atm%layout(2), & - Atm%domain, Atm%tile, Atm%gridstruct%npx_g, Atm%bd) - endif + enddo + else + call get_symmetry(dx(is:ie,js:je+1), dy(is:ie+1,js:je), 0, 1, Atm%layout(1), Atm%layout(2), & + Atm%domain, Atm%tile_of_mosaic, Atm%gridstruct%npx_g, Atm%bd) + endif - call mpp_get_boundary( dy, dx, Atm%domain, ebufferx=ebuffer, wbufferx=wbuffer, sbuffery=sbuffer, nbuffery=nbuffer,& - flags=SCALAR_PAIR+XUPDATE, gridtype=CGRID_NE_PARAM) - if( .not. Atm%flagstruct%regional ) then - if(is == 1 .AND. mod(tile,2) .NE. 0) then ! on the west boundary - dy(is, js:je) = wbuffer(js:je) - endif - if(ie == npx-1) then ! on the east boundary - dy(ie+1, js:je) = ebuffer(js:je) - endif - endif + call mpp_get_boundary( dy, dx, Atm%domain, ebufferx=ebuffer, wbufferx=wbuffer, sbuffery=sbuffer, nbuffery=nbuffer,& + flags=SCALAR_PAIR+XUPDATE, gridtype=CGRID_NE_PARAM) + if( .not. Atm%gridstruct%bounded_domain ) then + if(is == 1 .AND. mod(tile,2) .NE. 0) then ! on the west boundary + dy(is, js:je) = wbuffer(js:je) + endif + if(ie == npx-1) then ! on the east boundary + dy(ie+1, js:je) = ebuffer(js:je) + endif + endif - call mpp_update_domains( dy, dx, Atm%domain, flags=SCALAR_PAIR, & - gridtype=CGRID_NE_PARAM, complete=.true.) - if (cubed_sphere .and. (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional))) then - call fill_corners(dx, dy, npx, npy, DGRID=.true.) - endif + call mpp_update_domains( dy, dx, Atm%domain, flags=SCALAR_PAIR, & + gridtype=CGRID_NE_PARAM, complete=.true.) + if (cubed_sphere .and. (.not. (Atm%gridstruct%bounded_domain))) then + call fill_corners(dx, dy, npx, npy, DGRID=.true.) + endif if( .not. stretched_grid ) & call sorted_inta(isd, ied, jsd, jed, cubed_sphere, grid, iinta, jinta) @@ -833,31 +845,32 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, grid(iinta(3,i,j),jinta(3,i,j),1:2), & grid(iinta(4,i,j),jinta(4,i,j),1:2), & agrid(i,j,1:2) ) - endif - enddo - enddo - - call mpp_update_domains( agrid, Atm%domain, position=CENTER, complete=.true. ) - if (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional)) then - call fill_corners(agrid(:,:,1), npx, npy, XDir, AGRID=.true.) - call fill_corners(agrid(:,:,2), npx, npy, YDir, AGRID=.true.) - endif + endif + enddo + enddo - do j=jsd,jed - do i=isd,ied - call mid_pt_sphere(grid(i, j,1:2), grid(i, j+1,1:2), p1) - call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2) - dxa(i,j) = great_circle_dist( p2, p1, radius ) -! - call mid_pt_sphere(grid(i,j ,1:2), grid(i+1,j ,1:2), p1) - call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2) - dya(i,j) = great_circle_dist( p2, p1, radius ) - enddo - enddo + call mpp_update_domains( agrid, Atm%domain, position=CENTER, complete=.true. ) + if (.not. (Atm%gridstruct%bounded_domain)) then + call fill_corners(agrid(:,:,1), npx, npy, XDir, AGRID=.true.) + call fill_corners(agrid(:,:,2), npx, npy, YDir, AGRID=.true.) + endif + + do j=jsd,jed + do i=isd,ied + call mid_pt_sphere(grid(i, j,1:2), grid(i, j+1,1:2), p1) + call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2) + dxa(i,j) = great_circle_dist( p2, p1, radius ) + ! + call mid_pt_sphere(grid(i,j ,1:2), grid(i+1,j ,1:2), p1) + call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2) + dya(i,j) = great_circle_dist( p2, p1, radius ) + enddo + enddo ! call mpp_update_domains( dxa, dya, Atm%domain, flags=SCALAR_PAIR, gridtype=AGRID_PARAM) - if (cubed_sphere .and. (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional))) then - call fill_corners(dxa, dya, npx, npy, AGRID=.true.) - endif + if (cubed_sphere .and. (.not. (Atm%gridstruct%bounded_domain))) then + call fill_corners(dxa, dya, npx, npy, AGRID=.true.) + endif + end if !if nested @@ -893,14 +906,13 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, call sorted_intb(isd, ied, jsd, jed, is, ie, js, je, npx, npy, & cubed_sphere, agrid, iintb, jintb) - call grid_area( npx, npy, ndims, nregions, Atm%neststruct%nested, Atm%gridstruct, Atm%domain, Atm%bd, Atm%flagstruct%regional ) + call grid_area( npx, npy, ndims, nregions, Atm%gridstruct%bounded_domain, Atm%gridstruct, Atm%domain, Atm%bd ) ! stretched_grid = .false. !---------------------------------- ! Compute area_c, rarea_c, dxc, dyc !---------------------------------- - - if ( .not. stretched_grid .and. (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional))) then + if ( .not. stretched_grid .and. (.not. (Atm%gridstruct%bounded_domain))) then ! For symmetrical grids: if ( is==1 ) then i = 1 @@ -1000,7 +1012,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, call mpp_update_domains( dxc, dyc, Atm%domain, flags=SCALAR_PAIR, & gridtype=CGRID_NE_PARAM, complete=.true.) - if (cubed_sphere .and. (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional))) then + if (cubed_sphere .and. (.not. (Atm%gridstruct%bounded_domain))) then call fill_corners(dxc, dyc, npx, npy, CGRID=.true.) endif @@ -1008,7 +1020,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, !Handling outermost ends for area_c - if (Atm%neststruct%nested .or. Atm%flagstruct%regional) then + if (Atm%gridstruct%bounded_domain) then if (is == 1) then do j=jsd,jed area_c(isd,j) = area_c(isd+1,j) @@ -1038,7 +1050,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, call mpp_update_domains( area_c, Atm%domain, position=CORNER, complete=.true.) ! Handle corner Area ghosting - if (cubed_sphere .and. (.not. (Atm%neststruct%nested .or. Atm%flagstruct%regional))) then + if (cubed_sphere .and. (.not. (Atm%gridstruct%bounded_domain))) then call fill_ghost(area, npx, npy, -big_number, Atm%bd) ! fill in garbage values call fill_corners(area_c, npx, npy, FILL=XDir, BGRID=.true.) endif @@ -1090,7 +1102,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, angM = -missing aspN = missing aspM = -missing - if (tile == 1) then + !if (tile == 1) then ! doing a GLOBAL domain search on each grid do j=js, je do i=is, ie if(i>ceiling(npx/2.) .OR. j>ceiling(npy/2.)) cycle @@ -1120,7 +1132,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, aspN = MIN(aspN,asp) enddo enddo - endif + !endif call mpp_sum(angAv) call mpp_sum(dxAV) call mpp_sum(aspAV) @@ -1141,13 +1153,32 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, write(*,*) ' REDUCED EARTH: Radius is ', radius, ', omega is ', omega #endif write(*,* ) ' Cubed-Sphere Grid Stats : ', npx,'x',npy,'x',nregions -!xxxxxxx write(*,201) ' Grid Length : min: ', dxN,' max: ', dxM,' avg: ', dxAV, ' min/max: ',dxN/dxM + print*, dxN, dxM, dxAV, dxN, dxM + write(*,201) ' Grid Length : min: ', dxN,' max: ', dxM,' avg: ', dxAV, ' min/max: ',dxN/dxM write(*,200) ' Deviation from Orthogonal : min: ',angN,' max: ',angM,' avg: ',angAV write(*,200) ' Aspect Ratio : min: ',aspN,' max: ',aspM,' avg: ',aspAV write(*,* ) '' endif endif!if gridtype > 3 + !SEND grid global if any child nests + !Matching receive in setup_aligned_nest + do n=1,size(Atm%neststruct%child_grids) + if (Atm%neststruct%child_grids(n) .and. is_master()) then + !need to get tile_coarse AND determine local number for tile + if (ntiles_g > 1) then ! coarse grid only!! +!!$ !!! DEBUG CODE +!!$ print*, 'SENDING GRID_GLOBAL: ', mpp_pe(), tile_coarse(n), grids_master_procs(n), grid_global(1,npy,:,tile_coarse(n)) +!!$ !!! END DEBUG CODE + call mpp_send(grid_global(:,:,:,tile_coarse(n)), & + size(grid_global)/Atm%flagstruct%ntiles,grids_master_procs(n)) + else + call mpp_send(grid_global(:,:,:,1),size(grid_global),grids_master_procs(n)) + endif + call mpp_sync_self() + endif + enddo + if (Atm%neststruct%nested .or. ANY(Atm%neststruct%child_grids)) then nullify(grid_global) else if( trim(grid_file) .NE. 'INPUT/grid_spec.nc') then @@ -1270,6 +1301,21 @@ subroutine setup_cartesian(npx, npy, dx_const, dy_const, deglat, bd) end subroutine setup_cartesian + !This routine currently does two things: + ! 1) Create the nested grid on-the-fly from the parent + ! 2) Compute the weights and indices for the boundary conditions + ! We should split these into two routines in case we can + ! read the nest from the input mosaic. Then we only need + ! to set up the weights. + ! When creating the nest on-the-fly we need the global parent grid, + ! as we are doing now. For nests crossing a cube edge + ! new code is needed. + ! Creating the indices should be relatvely straightforward procedure + ! since we will always know ioffset and joffset, which are needed + ! to initialize the mpp nesting structure + ! Computing the weights can be simplified by simply retreiving the + ! BC agrid/grid structures? + subroutine setup_aligned_nest(Atm) type(fv_atmos_type), intent(INOUT), target :: Atm @@ -1290,7 +1336,7 @@ subroutine setup_aligned_nest(Atm) real(kind=R_GRID), dimension(2) :: q1, q2 integer, pointer :: parent_tile, refinement, ioffset, joffset - integer, pointer, dimension(:,:,:) :: ind_h, ind_u, ind_v, ind_update_h + integer, pointer, dimension(:,:,:) :: ind_h, ind_u, ind_v real, pointer, dimension(:,:,:) :: wt_h, wt_u, wt_v integer, pointer, dimension(:,:,:) :: ind_b @@ -1319,8 +1365,6 @@ subroutine setup_aligned_nest(Atm) ind_u => Atm%neststruct%ind_u ind_v => Atm%neststruct%ind_v - ind_update_h => Atm%neststruct%ind_update_h - wt_h => Atm%neststruct%wt_h wt_u => Atm%neststruct%wt_u wt_v => Atm%neststruct%wt_v @@ -1341,21 +1385,31 @@ subroutine setup_aligned_nest(Atm) allocate(p_grid( isg-ng:ieg+1+ng, jsg-ng:jeg+1+ng,1:2) ) p_grid = 1.e25 - !Need to RECEIVE grid_global; matching mpp_send of grid_global from parent grid is in fv_control + !Need to RECEIVE parent grid_global; + !matching mpp_send of grid_global from parent grid is in init_grid() if( is_master() ) then - p_ind = -1000000000 call mpp_recv(p_grid( isg-ng:ieg+1+ng, jsg-ng:jeg+1+ng,1:2), size(p_grid( isg-ng:ieg+1+ng, jsg-ng:jeg+1+ng,1:2)), & Atm%parent_grid%pelist(1)) +!!$ !!!! DEBUG CODE +!!$ print*, 'RECEIVING GRID GLOBAL: ', mpp_pe(), Atm%parent_grid%pelist(1), p_grid(1,jeg+1,:) +!!$ !!!! END DEBUG CODE + + endif + + call mpp_broadcast( p_grid(isg-ng:ieg+ng+1, jsg-ng:jeg+ng+1, :), & + (ieg-isg+2+2*ng)*(jeg-jsg+2+2*ng)*ndims, mpp_root_pe() ) + + !NOTE : Grid now allowed to lie outside of parent !Check that the grid does not lie outside its parent !3aug15: allows halo of nest to lie within halo of coarse grid. - ! NOTE: will this then work with the mpp_update_nest_fine? - if ( joffset + floor( real(1-ng) / real(refinement) ) < 1-ng .or. & - ioffset + floor( real(1-ng) / real(refinement) ) < 1-ng .or. & - joffset + floor( real(npy+ng) / real(refinement) ) > Atm%parent_grid%npy+ng .or. & - ioffset + floor( real(npx+ng) / real(refinement) ) > Atm%parent_grid%npx+ng ) then - call mpp_error(FATAL, 'nested grid lies outside its parent') - end if +!!$ ! NOTE: will this then work with the mpp_update_nest_fine? +!!$ if ( joffset + floor( real(1-ng) / real(refinement) ) < 1-ng .or. & +!!$ ioffset + floor( real(1-ng) / real(refinement) ) < 1-ng .or. & +!!$ joffset + floor( real(npy+ng) / real(refinement) ) > Atm%parent_grid%npy+ng .or. & +!!$ ioffset + floor( real(npx+ng) / real(refinement) ) > Atm%parent_grid%npx+ng ) then +!!$ call mpp_error(FATAL, 'nested grid lies outside its parent') +!!$ end if do j=1-ng,npy+ng jc = joffset + (j-1)/refinement !int( real(j-1) / real(refinement) ) @@ -1430,21 +1484,18 @@ subroutine setup_aligned_nest(Atm) end do end do - end if - - call mpp_broadcast(grid_global(1-ng:npx+ng, 1-ng:npy+ng ,:,1), & - ((npx+ng)-(1-ng)+1)*((npy+ng)-(1-ng)+1)*ndims, mpp_root_pe() ) - call mpp_broadcast( p_ind(1-ng:npx+ng, 1-ng:npy+ng ,1:4), & - ((npx+ng)-(1-ng)+1)*((npy+ng)-(1-ng)+1)*4, mpp_root_pe() ) - call mpp_broadcast( pa_grid( isg:ieg , jsg:jeg , :), & - ((ieg-isg+1))*(jeg-jsg+1)*ndims, mpp_root_pe()) - call mpp_broadcast( p_grid_u( isg:ieg , jsg:jeg+1, :), & - (ieg-isg+1)*(jeg-jsg+2)*ndims, mpp_root_pe()) - call mpp_broadcast( p_grid_v( isg:ieg+1, jsg:jeg , :), & - (ieg-isg+2)*(jeg-jsg+1)*ndims, mpp_root_pe()) - - call mpp_broadcast( p_grid(isg-ng:ieg+ng+1, jsg-ng:jeg+ng+1, :), & - (ieg-isg+2+2*ng)*(jeg-jsg+2+2*ng)*ndims, mpp_root_pe() ) +!!$ !TODO: can we just send around ONE grid and re-calculate +!!$ ! staggered grids from that?? +!!$ call mpp_broadcast(grid_global(1-ng:npx+ng, 1-ng:npy+ng ,:,1), & +!!$ ((npx+ng)-(1-ng)+1)*((npy+ng)-(1-ng)+1)*ndims, mpp_root_pe() ) +!!$ call mpp_broadcast( p_ind(1-ng:npx+ng, 1-ng:npy+ng ,1:4), & +!!$ ((npx+ng)-(1-ng)+1)*((npy+ng)-(1-ng)+1)*4, mpp_root_pe() ) +!!$ call mpp_broadcast( pa_grid( isg:ieg , jsg:jeg , :), & +!!$ ((ieg-isg+1))*(jeg-jsg+1)*ndims, mpp_root_pe()) +!!$ call mpp_broadcast( p_grid_u( isg:ieg , jsg:jeg+1, :), & +!!$ (ieg-isg+1)*(jeg-jsg+2)*ndims, mpp_root_pe()) +!!$ call mpp_broadcast( p_grid_v( isg:ieg+1, jsg:jeg , :), & +!!$ (ieg-isg+2)*(jeg-jsg+1)*ndims, mpp_root_pe()) do n=1,ndims do j=jsd,jed+1 @@ -1500,8 +1551,6 @@ subroutine setup_aligned_nest(Atm) enddo enddo - !In a concurrent simulation, p_ind was passed off to the parent processes above, so they can create ind_update_h - ind_u = -99999999 !New BCs for wind components: ! For aligned grid segments (mod(j-1,R) == 0) set @@ -1783,7 +1832,7 @@ subroutine setup_aligned_nest(Atm) ic = p_ind(npx,1,1) ; jc = p_ind(npx,1,1) write(*,'(A, 2I5, 4F10.4)') 'SE CORNER: ', ic, jc, grid_global(npx,1,:,1)*90./pi else - write(*,*) 'PARENT GRID ', Atm%parent_grid%grid_number, Atm%parent_grid%tile + write(*,*) 'PARENT GRID ', Atm%parent_grid%grid_number, Atm%parent_grid%global_tile ic = p_ind(1,1,1) ; jc = p_ind(1,1,1) write(*,'(A, 2I5, 4F10.4)') 'SW CORNER: ', ic, jc, Atm%parent_grid%grid_global(ic,jc,:,parent_tile)*90./pi ic = p_ind(1,npy,1) ; jc = p_ind(1,npy,1) @@ -2042,10 +2091,10 @@ end function get_area_tri !>@brief The subroutine 'grid_area' gets the surface area on a grid in lat/lon or xyz coordinates. !>@details Determined by 'ndims' argument: 2=lat/lon, 3=xyz) !! The area is returned in m^2 on a unit sphere. - subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, regional ) + subroutine grid_area(nx, ny, ndims, nregions, bounded_domain, gridstruct, domain, bd ) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: nx, ny, ndims, nregions - logical, intent(IN) :: nested, regional + logical, intent(IN) :: bounded_domain type(fv_grid_type), intent(IN), target :: gridstruct type(domain2d), intent(INOUT) :: domain @@ -2069,7 +2118,7 @@ subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, re real(kind=R_GRID), pointer, dimension(:,:) :: area, area_c integer :: is, ie, js, je - integer :: isd, ied, jsd, jed + integer :: isd, ied, jsd, jed, ng is = bd%is ie = bd%ie @@ -2079,6 +2128,7 @@ subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, re ied = bd%ied jsd = bd%jsd jed = bd%jed + ng = bd%ng grid => gridstruct%grid_64 agrid => gridstruct%agrid_64 @@ -2090,7 +2140,7 @@ subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, re area => gridstruct%area_64 area_c => gridstruct%area_c_64 - if (nested .or. regional) nh = ng + if (bounded_domain) nh = ng maxarea = -1.e25 minarea = 1.e25 @@ -2099,7 +2149,7 @@ subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, re do j=js-nh,je+nh do i=is-nh,ie+nh do n=1,ndims - if ( gridstruct%stretched_grid .or. nested ) then + if ( gridstruct%stretched_grid .or. bounded_domain ) then p_lL(n) = grid(i ,j ,n) p_uL(n) = grid(i ,j+1,n) p_lR(n) = grid(i+1,j ,n) @@ -2155,7 +2205,7 @@ subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, re if (is_master()) write(*,209) 'GLOBAL AREA (m*m):', globalarea, ' IDEAL GLOBAL AREA (m*m):', 4.0*pi*radius**2 209 format(A,e21.14,A,e21.14) - if (nested .or. regional) then + if (bounded_domain) then nh = ng-1 !cannot get rarea_c on boundary directly area_c = 1.e30 end if @@ -2163,7 +2213,7 @@ subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, re do j=js-nh,je+nh+1 do i=is-nh,ie+nh+1 do n=1,ndims - if ( gridstruct%stretched_grid .or. nested ) then + if ( gridstruct%stretched_grid .or. bounded_domain ) then p_lL(n) = agrid(i-1,j-1,n) p_lR(n) = agrid(i ,j-1,n) p_uL(n) = agrid(i-1,j ,n) @@ -2181,7 +2231,7 @@ subroutine grid_area(nx, ny, ndims, nregions, nested, gridstruct, domain, bd, re enddo ! Corners: assuming triangular cells - if (gridstruct%cubed_sphere .and. .not. (nested .or. regional)) then + if (gridstruct%cubed_sphere .and. .not. bounded_domain) then ! SW: i=1 j=1 diff --git a/tools/fv_iau_mod.F90 b/tools/fv_iau_mod.F90 index e9b961cbb..9bb20c293 100644 --- a/tools/fv_iau_mod.F90 +++ b/tools/fv_iau_mod.F90 @@ -93,6 +93,7 @@ module fv_iau_mod real,allocatable :: delz_inc(:,:,:) real,allocatable :: tracer_inc(:,:,:,:) logical :: in_interval = .false. + logical :: drymassfixer = .false. end type iau_external_data_type type iau_state_type type(iau_internal_data_type):: inc1 @@ -224,7 +225,7 @@ subroutine IAU_initialize (IPD_Control, IAU_Data,Init_parm) agrid(is-1+i,js-1+j,2)=Init_parm%xlat(i,j) enddo enddo - call remap_coef( is, ie, js, je, & + call remap_coef( is, ie, js, je, is, ie, js, je, & im, jm, lon, lat, id1, id2, jdc, s2c, & agrid) deallocate ( lon, lat,agrid ) @@ -280,6 +281,7 @@ subroutine IAU_initialize (IPD_Control, IAU_Data,Init_parm) call read_iau_forcing(IPD_Control,iau_state%inc2,'INPUT/'//trim(IPD_Control%iau_inc_files(2))) endif ! print*,'in IAU init',dt,rdt + IAU_data%drymassfixer = IPD_control%iau_drymassfixer end subroutine IAU_initialize diff --git a/tools/fv_io.F90 b/tools/fv_io.F90 index 4c83b1408..81b93ae11 100644 --- a/tools/fv_io.F90 +++ b/tools/fv_io.F90 @@ -1,21 +1,21 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** @@ -109,13 +109,16 @@ module fv_io_mod use fv_arrays_mod, only: fv_atmos_type, fv_nest_BC_type_3D use fv_eta_mod, only: set_external_eta - use fv_mp_mod, only: ng, mp_gather, is_master + use fv_mp_mod, only: mp_gather, is_master + use fms_io_mod, only: set_domain + use fv_treat_da_inc_mod, only: read_da_inc + implicit none private public :: fv_io_init, fv_io_exit, fv_io_read_restart, remap_restart, fv_io_write_restart public :: fv_io_read_tracers, fv_io_register_restart, fv_io_register_nudge_restart - public :: fv_io_register_restart_BCs, fv_io_register_restart_BCs_NH + public :: fv_io_register_restart_BCs public :: fv_io_write_BCs, fv_io_read_BCs logical :: module_is_initialized = .FALSE. @@ -294,6 +297,7 @@ subroutine remap_restart(fv_domain,Atm) real, allocatable:: q_r(:,:,:,:), qdiag_r(:,:,:,:) !------------------------------------------------------------------------- integer npz, npz_rst, ng + integer i,j,k npz = Atm(1)%npz ! run time z dimension npz_rst = Atm(1)%flagstruct%npz_rst ! restart z dimension @@ -345,6 +349,10 @@ subroutine remap_restart(fv_domain,Atm) stile_name = '' endif +!!!! A NOTE about file names +!!! file_exist() needs the full relative path, including INPUT/ +!!! But register_restart_field ONLY looks in INPUT/ and so JUST needs the file name!! + ! do n = 1, ntileMe n = 1 fname = 'fv_core.res'//trim(stile_name)//'.nc' @@ -370,8 +378,8 @@ subroutine remap_restart(fv_domain,Atm) domain=fv_domain, tile_count=n) call restore_state(FV_tile_restart_r) call free_restart_type(FV_tile_restart_r) - fname = 'INPUT/fv_srf_wnd.res'//trim(stile_name)//'.nc' - if (file_exist(fname)) then + fname = 'fv_srf_wnd.res'//trim(stile_name)//'.nc' + if (file_exist('INPUT/'//fname)) then call restore_state(Atm(n)%Rsf_restart) Atm(n)%flagstruct%srf_init = .true. else @@ -381,15 +389,15 @@ subroutine remap_restart(fv_domain,Atm) if ( Atm(n)%flagstruct%fv_land ) then !--- restore data for mg_drag - if it exists - fname = 'INPUT/mg_drag.res'//trim(stile_name)//'.nc' - if (file_exist(fname)) then + fname = 'mg_drag.res'//trim(stile_name)//'.nc' + if (file_exist('INPUT/'//fname)) then call restore_state(Atm(n)%Mg_restart) else call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist') endif !--- restore data for fv_land - if it exists - fname = 'INPUT/fv_land.res'//trim(stile_name)//'.nc' - if (file_exist(fname)) then + fname = 'fv_land.res'//trim(stile_name)//'.nc' + if (file_exist('INPUT/'//fname)) then call restore_state(Atm(n)%Lnd_restart) else call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist') @@ -397,7 +405,7 @@ subroutine remap_restart(fv_domain,Atm) endif fname = 'fv_tracer.res'//trim(stile_name)//'.nc' - if (file_exist('INPUT'//trim(fname))) then + if (file_exist('INPUT/'//fname)) then do nt = 1, ntprog call get_tracer_names(MODEL_ATMOS, nt, tracer_name) call set_tracer_profile (MODEL_ATMOS, nt, q_r(isc:iec,jsc:jec,:,nt) ) @@ -416,6 +424,20 @@ subroutine remap_restart(fv_domain,Atm) call mpp_error(NOTE,'==> Warning from remap_restart: Expected file '//trim(fname)//' does not exist') endif +! ====== PJP added DA functionality ====== + if (Atm(n)%flagstruct%read_increment) then + ! print point in middle of domain for a sanity check + i = (isc + iec)/2 + j = (jsc + jec)/2 + k = npz_rst/2 + if( is_master() ) write(*,*) 'Calling read_da_inc',pt_r(i,j,k) + call read_da_inc(Atm(n), Atm(n)%domain, Atm(n)%bd, npz_rst, ntprog, & + u_r, v_r, q_r, delp_r, pt_r, delz_r, isc, jsc, iec, jec, & + isc, jsc, iec, jec ) + if( is_master() ) write(*,*) 'Back from read_da_inc',pt_r(i,j,k) + endif +! ====== end PJP added DA functionailty====== + call rst_remap(npz_rst, npz, isc, iec, jsc, jec, isd, ied, jsd, jed, ntracers, ntprog, & delp_r, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r,& Atm(n)%delp, Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, Atm(n)%pt, Atm(n)%q, & @@ -451,11 +473,12 @@ subroutine fv_io_register_nudge_restart(Atm) ! use_ncep_sst may not be initialized at this point? call mpp_error(NOTE, 'READING FROM SST_restart DISABLED') -!!$ if ( use_ncep_sst .or. Atm(1)%nudge .or. Atm(1)%ncep_ic ) then -!!$ fname = 'sst_ncep.res.nc' -!!$ id_restart = register_restart_field(Atm(1)%SST_restart, fname, 'sst_ncep', sst_ncep) -!!$ id_restart = register_restart_field(Atm(1)%SST_restart, fname, 'sst_anom', sst_anom) -!!$ endif + if ( use_ncep_sst .or. Atm(1)%flagstruct%nudge .or. Atm(1)%flagstruct%ncep_ic ) then +! if ( Atm(1)%nudge .or. Atm(1)%ncep_ic ) then + fname = 'sst_ncep.res.nc' + id_restart = register_restart_field(Atm(1)%SST_restart, fname, 'sst_ncep', sst_ncep) + id_restart = register_restart_field(Atm(1)%SST_restart, fname, 'sst_anom', sst_anom) + endif end subroutine fv_io_register_nudge_restart @@ -492,7 +515,7 @@ subroutine fv_io_register_restart(fv_domain,Atm) ! use_ncep_sst may not be initialized at this point? #ifndef DYCORE_SOLO - call mpp_error(NOTE, 'READING FROM SST_RESTART DISABLED') +! call mpp_error(NOTE, 'READING FROM SST_RESTART DISABLED') !!$ if ( use_ncep_sst .or. Atm(1)%flagstruct%nudge .or. Atm(1)%flagstruct%ncep_ic ) then !!$ fname = 'sst_ncep'//trim(gn)//'.res.nc' !!$ id_restart = register_restart_field(Atm(1)%SST_restart, fname, 'sst_ncep', sst_ncep) @@ -573,44 +596,39 @@ subroutine fv_io_register_restart(fv_domain,Atm) domain=fv_domain, mandatory=.false., tile_count=n) enddo + if ( Atm(n)%neststruct%nested ) then + call fv_io_register_restart_BCs(Atm(n)) !TODO put into fv_io_register_restart + endif + enddo end subroutine fv_io_register_restart !>@brief The subroutine 'fv_io_write_restart' writes restart files. - subroutine fv_io_write_restart(Atm, grids_on_this_pe, timestamp) - - type(fv_atmos_type), intent(inout) :: Atm(:) - logical, intent(IN) :: grids_on_this_pe(:) + subroutine fv_io_write_restart(Atm, timestamp) + type(fv_atmos_type), intent(inout) :: Atm character(len=*), optional, intent(in) :: timestamp - integer :: n, ntileMe - - ntileMe = size(Atm(:)) ! This will need mods for more than 1 tile per pe - if ( use_ncep_sst .or. Atm(1)%flagstruct%nudge .or. Atm(1)%flagstruct%ncep_ic ) then - call mpp_error(NOTE, 'READING FROM SST_RESTART DISABLED') - !call save_restart(Atm(1)%SST_restart, timestamp) - endif +!!$ if ( use_ncep_sst .or. Atm%flagstruct%nudge .or. Atm%flagstruct%ncep_ic ) then +!!$ call mpp_error(NOTE, 'READING FROM SST_RESTART DISABLED') +!!$ !call save_restart(Atm%SST_restart, timestamp) +!!$ endif - do n = 1, ntileMe - if (.not. grids_on_this_pe(n)) cycle + if ( (use_ncep_sst .or. Atm%flagstruct%nudge) .and. .not. Atm%gridstruct%nested ) then + call save_restart(Atm%SST_restart, timestamp) + endif - if ( (use_ncep_sst .or. Atm(n)%flagstruct%nudge) .and. .not. Atm(n)%gridstruct%nested ) then - call save_restart(Atm(n)%SST_restart, timestamp) - endif - - call save_restart(Atm(n)%Fv_restart, timestamp) - call save_restart(Atm(n)%Fv_tile_restart, timestamp) - call save_restart(Atm(n)%Rsf_restart, timestamp) + call save_restart(Atm%Fv_restart, timestamp) + call save_restart(Atm%Fv_tile_restart, timestamp) + call save_restart(Atm%Rsf_restart, timestamp) - if ( Atm(n)%flagstruct%fv_land ) then - call save_restart(Atm(n)%Mg_restart, timestamp) - call save_restart(Atm(n)%Lnd_restart, timestamp) - endif + if ( Atm%flagstruct%fv_land ) then + call save_restart(Atm%Mg_restart, timestamp) + call save_restart(Atm%Lnd_restart, timestamp) + endif - call save_restart(Atm(n)%Tra_restart, timestamp) + call save_restart(Atm%Tra_restart, timestamp) - end do end subroutine fv_io_write_restart @@ -938,12 +956,13 @@ subroutine fv_io_register_restart_BCs(Atm) #ifndef SW_DYNAMICS call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & fname_ne, fname_sw, 'pt', Atm%pt, Atm%neststruct%pt_BC) - if ((.not.Atm%flagstruct%hydrostatic) .and. (.not.Atm%flagstruct%make_nh)) then - if (is_master()) print*, 'fv_io_register_restart_BCs: REGISTERING NH BCs', Atm%flagstruct%hydrostatic, Atm%flagstruct%make_nh + if ((.not.Atm%flagstruct%hydrostatic)) then + if (is_master()) print*, 'fv_io_register_restart_BCs: REGISTERING NH BCs' call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & fname_ne, fname_sw, 'w', Atm%w, Atm%neststruct%w_BC, mandatory=.false.) call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & - fname_ne, fname_sw, 'delz', Atm%delz, Atm%neststruct%delz_BC, mandatory=.false.) + fname_ne, fname_sw, 'delz', var_bc=Atm%neststruct%delz_BC, mandatory=.false.) +! fname_ne, fname_sw, 'delz', Atm%delz, Atm%neststruct%delz_BC, mandatory=.false.) endif #ifdef USE_COND call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & @@ -964,37 +983,11 @@ subroutine fv_io_register_restart_BCs(Atm) fname_ne, fname_sw, 'vc', var_bc=Atm%neststruct%vc_BC, jstag=1) call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & fname_ne, fname_sw, 'divg', var_bc=Atm%neststruct%divg_BC, istag=1,jstag=1, mandatory=.false.) - Atm%neststruct%divg_BC%initialized = field_exist(fname_ne, 'divg_north_t1', Atm%domain) - return end subroutine fv_io_register_restart_BCs - subroutine fv_io_register_restart_BCs_NH(Atm) - type(fv_atmos_type), intent(inout) :: Atm - - integer :: n - character(len=120) :: tname, fname_ne, fname_sw - - fname_ne = 'fv_BC_ne.res.nc' - fname_sw = 'fv_BC_sw.res.nc' - - call set_domain(Atm%domain) - - if (is_master()) print*, 'fv_io_register_restart_BCs_NH: REGISTERING NH BCs', Atm%flagstruct%hydrostatic, Atm%flagstruct%make_nh -#ifndef SW_DYNAMICS - call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & - fname_ne, fname_sw, 'w', Atm%w, Atm%neststruct%w_BC) - call register_bcs_3d(Atm, Atm%neststruct%BCfile_ne, Atm%neststruct%BCfile_sw, & - fname_ne, fname_sw, 'delz', Atm%delz, Atm%neststruct%delz_BC) -#endif - - return - end subroutine fv_io_register_restart_BCs_NH - - -!>@brief The subroutine 'fv_io_write_BCs' writes BCs to a restart file. subroutine fv_io_write_BCs(Atm, timestamp) type(fv_atmos_type), intent(inout) :: Atm character(len=*), intent(in), optional :: timestamp @@ -1005,13 +998,20 @@ subroutine fv_io_write_BCs(Atm, timestamp) return end subroutine fv_io_write_BCs -!>@brief The subroutine 'fv_io_read_BCs' reads BCs from a restart file. + subroutine fv_io_read_BCs(Atm) type(fv_atmos_type), intent(inout) :: Atm call restore_state_border(Atm%neststruct%BCfile_ne) call restore_state_border(Atm%neststruct%BCfile_sw) + !These do not work yet + !need to modify register_bcs_?d to get ids for registered variables, and then use query_initialized_id + !Atm%neststruct%divg_BC%initialized = field_exist(fname_ne, 'divg_north_t1', Atm%domain) + !Atm%neststruct%w_BC%initialized = field_exist(fname_ne, 'w_north_t1', Atm%domain) + !Atm%neststruct%delz_BC%initialized = field_exist(fname_ne, 'delz_north_t1', Atm%domain) + !if (is_master()) print*, ' BCs: ', Atm%neststruct%divg_BC%initialized, Atm%neststruct%w_BC%initialized, Atm%neststruct%delz_BC%initialized + return end subroutine fv_io_read_BCs diff --git a/tools/fv_mp_mod.F90 b/tools/fv_mp_mod.F90 index cd29b5f39..618b4f973 100644 --- a/tools/fv_mp_mod.F90 +++ b/tools/fv_mp_mod.F90 @@ -91,14 +91,11 @@ module fv_mp_mod use mpp_domains_mod, only : mpp_group_update_initialized, mpp_do_group_update use mpp_domains_mod, only : mpp_create_group_update,mpp_reset_group_update_field use mpp_domains_mod, only : group_halo_update_type => mpp_group_update_type + use mpp_domains_mod, only: nest_domain_type use mpp_parameter_mod, only : WUPDATE, EUPDATE, SUPDATE, NUPDATE, XUPDATE, YUPDATE - use fv_arrays_mod, only: fv_atmos_type + use fv_arrays_mod, only: fv_atmos_type, fv_grid_bounds_type use fms_io_mod, only: set_domain - use mpp_mod, only : mpp_get_current_pelist - use mpp_domains_mod, only : mpp_define_domains - use mpp_domains_mod, only : mpp_define_nest_domains, nest_domain_type - use mpp_domains_mod, only : mpp_get_C2F_index, mpp_update_nest_fine - use mpp_domains_mod, only : mpp_get_F2C_index, mpp_update_nest_coarse + use mpp_mod, only : mpp_get_current_pelist, mpp_set_current_pelist use mpp_domains_mod, only : mpp_get_domain_shift use ensemble_manager_mod, only : get_ensemble_id @@ -106,6 +103,7 @@ module fv_mp_mod private integer, parameter:: ng = 3 ! Number of ghost zones required + integer, parameter :: MAX_NNEST=20, MAX_NTILE=50 #include "mpif.h" integer, parameter :: XDir=1 @@ -123,7 +121,6 @@ module fv_mp_mod logical :: master - type(nest_domain_type), allocatable, dimension(:) :: nest_domain integer :: this_pe_grid = 0 integer, EXTERNAL :: omp_get_thread_num, omp_get_num_threads @@ -136,6 +133,9 @@ module fv_mp_mod integer :: isd, ied, jsd, jed integer :: isc, iec, jsc, jec + integer, allocatable :: grids_master_procs(:) + integer, dimension(MAX_NNEST) :: tile_fine = 0 !Global index of LAST tile in a mosaic + type(nest_domain_type) :: global_nest_domain !ONE structure for ALL levels of nesting #ifdef CCPP public commglobal #endif @@ -145,12 +145,9 @@ module fv_mp_mod public fill_corners, XDir, YDir public switch_current_domain, switch_current_Atm, broadcast_domains public is_master, setup_master - !The following variables are declared public by this module for convenience; - !they will need to be switched when domains are switched -!!! CLEANUP: ng is a PARAMETER and is OK to be shared by a use statement - public is, ie, js, je, isd, ied, jsd, jed, isc, iec, jsc, jec, ng public start_group_halo_update, complete_group_halo_update - public group_halo_update_type + public group_halo_update_type, grids_master_procs, tile_fine + public global_nest_domain, MAX_NNEST, MAX_NTILE, ng interface start_group_halo_update module procedure start_var_group_update_2d @@ -347,12 +344,11 @@ end subroutine mp_stop !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! !>@brief The subroutine 'domain_decomp' sets up the domain decomposition. - subroutine domain_decomp(npx,npy,nregions,grid_type,nested,Atm,layout,io_layout) - + subroutine domain_decomp(npx,npy,nregions,grid_type,nested,layout,io_layout,bd,tile,square_domain,& + npes_per_tile,domain,domain_for_coupler,num_contact,pelist) integer, intent(IN) :: npx,npy,grid_type - integer, intent(INOUT) :: nregions + integer, intent(INOUT) :: nregions, tile logical, intent(IN):: nested - type(fv_atmos_type), intent(INOUT), target :: Atm integer, intent(INOUT) :: layout(2), io_layout(2) integer, allocatable :: pe_start(:), pe_end(:) @@ -366,21 +362,15 @@ subroutine domain_decomp(npx,npy,nregions,grid_type,nested,Atm,layout,io_layout) integer i integer :: npes_x, npes_y - integer, pointer :: pelist(:), grid_number, num_contact, npes_per_tile - logical, pointer :: square_domain - type(domain2D), pointer :: domain, domain_for_coupler + integer, intent(INOUT) :: pelist(:) + integer, intent(OUT) :: num_contact, npes_per_tile + logical, intent(OUT) :: square_domain + type(domain2D), intent(OUT) :: domain, domain_for_coupler + type(fv_grid_bounds_type), intent(INOUT) :: bd nx = npx-1 ny = npy-1 - !! Init pointers - pelist => Atm%pelist - grid_number => Atm%grid_number - num_contact => Atm%num_contact - domain => Atm%domain - domain_for_coupler => Atm%domain_for_coupler - npes_per_tile => Atm%npes_per_tile - npes_x = layout(1) npes_y = layout(2) @@ -410,7 +400,7 @@ subroutine domain_decomp(npx,npy,nregions,grid_type,nested,Atm,layout,io_layout) npes_y = layout(2) endif - if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x ) Atm%gridstruct%square_domain = .true. + if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x ) square_domain = .true. if ( (npx/npes_x < ng) .or. (npy/npes_y < ng) ) then write(*,310) npes_x, npes_y, npx/npes_x, npy/npes_y @@ -479,7 +469,7 @@ subroutine domain_decomp(npx,npy,nregions,grid_type,nested,Atm,layout,io_layout) npes_y = layout(2) endif - if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x ) Atm%gridstruct%square_domain = .true. + if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x ) square_domain = .true. if ( (npx/npes_x < ng) .or. (npy/npes_y < ng) ) then write(*,310) npes_x, npes_y, npx/npes_x, npy/npes_y @@ -628,8 +618,7 @@ subroutine domain_decomp(npx,npy,nregions,grid_type,nested,Atm,layout,io_layout) if( nregions .NE. 1 ) then call mpp_error(FATAL, 'domain_decomp: nregions should be 1 for nested region, contact developer') endif - tile_id(1) = 7 ! currently we assuming the nested tile is nested in one face of cubic sphere grid. - ! we need a more general way to deal with nested grid tile id. + tile_id(1) = 7 ! TODO need update for multiple nests else do n = 1, nregions tile_id(n) = n @@ -656,27 +645,27 @@ subroutine domain_decomp(npx,npy,nregions,grid_type,nested,Atm,layout,io_layout) deallocate(istart2, iend2, jstart2, jend2) !--- find the tile number - Atm%tile = (gid-pelist(1))/npes_per_tile+1 + tile = (gid-pelist(1))/npes_per_tile+1 if (ANY(pelist == gid)) then npes_this_grid = npes_per_tile*nregions - tile = Atm%tile + tile = tile call mpp_get_compute_domain( domain, is, ie, js, je ) call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) - Atm%bd%is = is - Atm%bd%js = js - Atm%bd%ie = ie - Atm%bd%je = je + bd%is = is + bd%js = js + bd%ie = ie + bd%je = je - Atm%bd%isd = isd - Atm%bd%jsd = jsd - Atm%bd%ied = ied - Atm%bd%jed = jed + bd%isd = isd + bd%jsd = jsd + bd%ied = ied + bd%jed = jed - Atm%bd%isc = is - Atm%bd%jsc = js - Atm%bd%iec = ie - Atm%bd%jec = je + bd%isc = is + bd%jsc = js + bd%iec = ie + bd%jec = je if (debug .and. nregions==1) then tile=1 @@ -687,20 +676,20 @@ subroutine domain_decomp(npx,npy,nregions,grid_type,nested,Atm,layout,io_layout) 200 format(i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ') else - Atm%bd%is = 0 - Atm%bd%js = 0 - Atm%bd%ie = -1 - Atm%bd%je = -1 + bd%is = 0 + bd%js = 0 + bd%ie = -1 + bd%je = -1 - Atm%bd%isd = 0 - Atm%bd%jsd = 0 - Atm%bd%ied = -1 - Atm%bd%jed = -1 + bd%isd = 0 + bd%jsd = 0 + bd%ied = -1 + bd%jed = -1 - Atm%bd%isc = 0 - Atm%bd%jsc = 0 - Atm%bd%iec = -1 - Atm%bd%jec = -1 + bd%isc = 0 + bd%jsc = 0 + bd%iec = -1 + bd%jec = -1 endif @@ -957,12 +946,14 @@ end subroutine complete_group_halo_update - -subroutine broadcast_domains(Atm) +!Depreciated +subroutine broadcast_domains(Atm,current_pelist,current_npes) type(fv_atmos_type), intent(INOUT) :: Atm(:) + integer, intent(IN) :: current_npes + integer, intent(IN) :: current_pelist(current_npes) - integer :: n, i1, i2, j1, j2, i + integer :: n, i integer :: ens_root_pe, ensemble_id !I think the idea is that each process needs to properly be part of a pelist, @@ -975,13 +966,15 @@ subroutine broadcast_domains(Atm) !Pelist needs to be set to ALL ensemble PEs for broadcast_domain to work call mpp_set_current_pelist((/ (i,i=ens_root_pe,npes-1+ens_root_pe) /)) - do n=1,size(Atm) - call mpp_broadcast_domain(Atm(n)%domain) - call mpp_broadcast_domain(Atm(n)%domain_for_coupler) - end do + do n=1,size(Atm) + call mpp_broadcast_domain(Atm(n)%domain) + call mpp_broadcast_domain(Atm(n)%domain_for_coupler) + end do + call mpp_set_current_pelist(current_pelist) end subroutine broadcast_domains +!depreciated subroutine switch_current_domain(new_domain,new_domain_for_coupler) type(domain2D), intent(in), target :: new_domain, new_domain_for_coupler @@ -1004,6 +997,7 @@ subroutine switch_current_domain(new_domain,new_domain_for_coupler) end subroutine switch_current_domain +!depreciated subroutine switch_current_Atm(new_Atm, switch_domain) type(fv_atmos_type), intent(IN), target :: new_Atm @@ -1011,13 +1005,16 @@ subroutine switch_current_Atm(new_Atm, switch_domain) logical, parameter :: debug = .false. logical :: swD - if (debug .AND. (gid==masterproc)) print*, 'SWITCHING ATM STRUCTURES', new_Atm%grid_number - if (present(switch_domain)) then - swD = switch_domain - else - swD = .true. - end if - if (swD) call switch_current_domain(new_Atm%domain, new_Atm%domain_for_coupler) + + call mpp_error(FATAL, "switch_current_Atm depreciated. call set_domain instead.") + +!!$ if (debug .AND. (gid==masterproc)) print*, 'SWITCHING ATM STRUCTURES', new_Atm%grid_number +!!$ if (present(switch_domain)) then +!!$ swD = switch_domain +!!$ else +!!$ swD = .true. +!!$ end if +!!$ if (swD) call switch_current_domain(new_Atm%domain, new_Atm%domain_for_coupler) !!$ if (debug .AND. (gid==masterproc)) WRITE(*,'(A, 6I5)') 'NEW GRID DIMENSIONS: ', & !!$ isd, ied, jsd, jed, new_Atm%npx, new_Atm%npy @@ -1536,387 +1533,11 @@ end subroutine fill_corners_agrid_r8 ! ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! !------------------------------------------------------------------------------- - -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! -!!$! mp_corner_comm :: Point-based MPI communcation routine for Cubed-Sphere -!!$! ghosted corner point on B-Grid -!!$! this routine sends 24 16-byte messages -!!$! -!!$ subroutine mp_corner_comm(q, npx, npy, tile) -!!$ integer, intent(IN) :: npx,npy, tile -!!$ real , intent(INOUT):: q(isd:ied+1,jsd:jed+1) -!!$ -!!$ integer, parameter :: ntiles = 6 -!!$ -!!$ real :: qsend(24) -!!$ real :: send_tag, recv_tag -!!$ integer :: sqest(24), rqest(24) -!!$ integer :: Stats(24*MPI_STATUS_SIZE) -!!$ integer :: nsend, nrecv, nread -!!$ integer :: dest_gid, src_gid -!!$ integer :: n -!!$ -!!$ qsend = 1.e25 -!!$ nsend=0 -!!$ nrecv=0 -!!$ -!!$ if ( mod(tile,2) == 0 ) then -!!$! Even Face LL and UR pairs 6 2-way -!!$ if ( (is==1) .and. (js==1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(is,js+1) -!!$ send_tag = 300+tile -!!$ dest_gid = (tile-2)*npes_x*npes_y - 1 -!!$ if (dest_gid < 0) dest_gid=npes+dest_gid -!!$ recv_tag = 100+(tile-2) -!!$ if (tile==2) recv_tag = 100+(ntiles) -!!$ src_gid = (tile-3)*npes_x*npes_y -!!$ src_gid = src_gid + npes_x*(npes_y-1) + npes_x - 1 -!!$ if (src_gid < 0) src_gid=npes+src_gid -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(is-1,js), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(is-1,js), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ endif -!!$ if ( (ie==npx-1) .and. (je==npy-1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(ie,je+1) -!!$ send_tag = 100+tile -!!$ dest_gid = (tile+1)*npes_x*npes_y -!!$ if (dest_gid+1 > npes) dest_gid=dest_gid-npes -!!$ recv_tag = 300+(tile+2) -!!$ if (tile==6) recv_tag = 300+2 -!!$ src_gid = (tile+1)*npes_x*npes_y -!!$ if (src_gid+1 > npes) src_gid=src_gid-npes -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ endif -!!$! wait for comm to complete -!!$ if (npes==6) then -!!$ if (nsend>0) then -!!$ call MPI_WAITALL(nsend, sqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ if (nrecv>0) then -!!$ call MPI_WAITALL(nrecv, rqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ nsend=0 ; nrecv=0 -!!$ endif -!!$ -!!$! Even Face LR 1 pair ; 1 1-way -!!$ if ( (tile==2) .and. (ie==npx-1) .and. (js==1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(ie,js) -!!$ send_tag = 200+tile -!!$ dest_gid = (tile+1)*npes_x*npes_y + npes_x-1 -!!$ recv_tag = 200+(tile+2) -!!$ src_gid = dest_gid -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(ie+2,js), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ endif -!!$ if ( (tile==4) .and. (ie==npx-1) .and. (js==1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(ie+1,js+1) -!!$ send_tag = 200+tile -!!$ dest_gid = (tile-3)*npes_x*npes_y + npes_x-1 -!!$ recv_tag = 200+(tile-2) -!!$ src_gid = dest_gid -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(ie+2,js), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(ie,js) -!!$ send_tag = 200+tile -!!$ dest_gid = (tile+1)*npes_x*npes_y + npes_x-1 -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ endif -!!$ if ( (tile==6) .and. (ie==npx-1) .and. (js==1) ) then -!!$ recv_tag = 200+(tile-2) -!!$ src_gid = (tile-3)*npes_x*npes_y + npes_x-1 -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ -!!$! wait for comm to complete -!!$ if (npes==6) then -!!$ if (nsend>0) then -!!$ call MPI_WAITALL(nsend, sqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ if (nrecv>0) then -!!$ call MPI_WAITALL(nrecv, rqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ nsend=0 ; nrecv=0 -!!$ endif -!!$ -!!$! Send to Odd face LR 3 1-way -!!$ if ( (is==1) .and. (js==1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(is+1,js) -!!$ send_tag = 200+tile -!!$ dest_gid = (tile-2)*npes_x*npes_y + npes_x-1 -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ endif -!!$ -!!$! Receive Even Face UL 3 1-way -!!$ if ( (is==1) .and. (je==npy-1) ) then -!!$ recv_tag = 400+(tile-1) -!!$ src_gid = (tile-2)*npes_x*npes_y + npes_x*(npes_y-1) + npes_x-1 -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ -!!$ else -!!$ -!!$! Odd Face LL and UR pairs 6 2-way -!!$ if ( (is==1) .and. (js==1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(is+1,js) -!!$ send_tag = 300+tile -!!$ dest_gid = (tile-2)*npes_x*npes_y - 1 -!!$ if (dest_gid < 0) dest_gid=npes+dest_gid -!!$ recv_tag = 100+(tile-2) -!!$ if (tile==1) recv_tag = 100+(ntiles-tile) -!!$ src_gid = (tile-3)*npes_x*npes_y -!!$ src_gid = src_gid + npes_x*(npes_y-1) + npes_x - 1 -!!$ if (src_gid < 0) src_gid=npes+src_gid -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(is-1,js), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(is-1,js), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ endif -!!$ if ( (ie==npx-1) .and. (je==npy-1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(ie+1,je) -!!$ send_tag = 100+tile -!!$ dest_gid = (tile+1)*npes_x*npes_y -!!$ if (dest_gid+1 > npes) dest_gid=dest_gid-npes -!!$ recv_tag = 300+(tile+2) -!!$ if (tile==5) recv_tag = 300+1 -!!$ src_gid = (tile+1)*npes_x*npes_y -!!$ if (src_gid+1 > npes) src_gid=src_gid-npes -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(ie+2,je+1), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ endif -!!$! wait for comm to complete -!!$ if (npes==6) then -!!$ if (nsend>0) then -!!$ call MPI_WAITALL(nsend, sqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ if (nrecv>0) then -!!$ call MPI_WAITALL(nrecv, rqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ nsend=0 ; nrecv=0 -!!$ endif -!!$ -!!$! Odd Face UL 1 pair ; 1 1-way -!!$ if ( (tile==1) .and. (is==1) .and. (je==npy-1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(is,je) -!!$ send_tag = 400+tile -!!$ dest_gid = (tile+1)*npes_x*npes_y + npes_x*(npes_y-1) -!!$ recv_tag = 400+(tile+2) -!!$ src_gid = dest_gid -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ endif -!!$ if ( (tile==3) .and. (is==1) .and. (je==npy-1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(is+1,je+1) -!!$ send_tag = 400+tile -!!$ dest_gid = npes_x*(npes_y-1) -!!$ recv_tag = 400+(tile-2) -!!$ src_gid = dest_gid -!!$ if (npes>6) then -!!$ call MPI_SENDRECV( qsend(nsend), 1, MPI_DOUBLE_PRECISION, & -!!$ dest_gid, send_tag, & -!!$ q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, & -!!$ src_gid, recv_tag, & -!!$ commglobal, Stats, ierror ) -!!$ nsend=nsend-1 -!!$ else -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(is,je) -!!$ send_tag = 400+tile -!!$ dest_gid = (tile+1)*npes_x*npes_y + npes_x*(npes_y-1) -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ endif -!!$ if ( (tile==5) .and. (is==1) .and. (je==npy-1) ) then -!!$ recv_tag = 400+(tile-2) -!!$ src_gid = (tile-3)*npes_x*npes_y + npes_x*(npes_y-1) -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(is-1,je+1), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ -!!$! wait for comm to complete -!!$ if (npes==6) then -!!$ if (nsend>0) then -!!$ call MPI_WAITALL(nsend, sqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ if (nrecv>0) then -!!$ call MPI_WAITALL(nrecv, rqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ nsend=0 ; nrecv=0 -!!$ endif -!!$ -!!$! Send to Even face UL 3 1-way -!!$ if ( (ie==npx-1) .and. (je==npy-1) ) then -!!$ nsend=nsend+1 -!!$ qsend(nsend) = q(ie,je+1) -!!$ send_tag = 400+tile -!!$ dest_gid = tile*npes_x*npes_y + npes_x*(npes_y-1) -!!$ call MPI_ISEND( qsend(nsend), 1, MPI_DOUBLE_PRECISION, dest_gid, & -!!$ send_tag, commglobal, sqest(nsend), ierror ) -!!$ endif -!!$ -!!$! Receive Odd Face LR 3 1-way -!!$ if ( (ie==npx-1) .and. (js==1) ) then -!!$ recv_tag = 200+(tile+1) -!!$ src_gid = (tile-1)*npes_x*npes_y + npes_x*npes_y -!!$ nrecv=nrecv+1 -!!$ call MPI_IRECV( q(ie+2,js), 1, MPI_DOUBLE_PRECISION, src_gid, & -!!$ recv_tag, commglobal, rqest(nrecv), ierror ) -!!$ endif -!!$ -!!$ endif -!!$ -!!$! wait for comm to complete -!!$ if (nsend>0) then -!!$ call MPI_WAITALL(nsend, sqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ if (nrecv>0) then -!!$ call MPI_WAITALL(nrecv, rqest, Stats, ierror) -!!$ -!!$ -!!$ -!!$ endif -!!$ -!!$ end subroutine mp_corner_comm -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- - !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!>@brief The subroutine 'mp_gather_4d_r4' calls SPMD Gather. +! +! mp_gather_4d_r4 :: Call SPMD Gather +! subroutine mp_gather_4d_r4(q, i1,i2, j1,j2, idim, jdim, kdim, ldim) integer, intent(IN) :: i1,i2, j1,j2 integer, intent(IN) :: idim, jdim, kdim, ldim diff --git a/tools/fv_nudge.F90 b/tools/fv_nudge.F90 index 21a1b4f42..ea2242f79 100644 --- a/tools/fv_nudge.F90 +++ b/tools/fv_nudge.F90 @@ -360,7 +360,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt real(kind=R_GRID), pointer :: da_min - logical, pointer :: nested, sw_corner, se_corner, nw_corner, ne_corner + logical, pointer :: bounded_domain, sw_corner, se_corner, nw_corner, ne_corner if ( .not. module_is_initialized ) then call mpp_error(FATAL,'==> Error from fv_nwp_nudge: module not initialized') @@ -382,7 +382,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt da_min => gridstruct%da_min - nested => gridstruct%nested + sw_corner => gridstruct%sw_corner se_corner => gridstruct%se_corner nw_corner => gridstruct%nw_corner @@ -783,7 +783,6 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt nullify(da_min) - nullify(nested) nullify(sw_corner) nullify(se_corner) nullify(nw_corner) @@ -1504,7 +1503,7 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) if( .not. file_exist(fname) ) then - call mpp_error(FATAL,'==> Error from get_ncep_analysis: file not found') + call mpp_error(FATAL,'==> Error from get_ncep_analysis: file not found: '//fname) else call open_ncfile( fname, ncid ) ! open the file if(master) write(*,*) 'Reading NCEP anlysis file:', fname @@ -3569,7 +3568,7 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) real(kind=R_GRID), pointer :: da_min - logical, pointer :: nested, sw_corner, se_corner, nw_corner, ne_corner + logical, pointer :: bounded_domain, sw_corner, se_corner, nw_corner, ne_corner area => gridstruct%area rarea => gridstruct%rarea @@ -3585,7 +3584,7 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) da_min => gridstruct%da_min - nested => gridstruct%nested + bounded_domain => gridstruct%bounded_domain sw_corner => gridstruct%sw_corner se_corner => gridstruct%se_corner nw_corner => gridstruct%nw_corner @@ -3611,13 +3610,13 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) nt = ntimes - n -!$OMP parallel do default(none) shared(is,ie,js,je,kmd,nt,dy,q,isd,jsd,npx,npy,nested, & +!$OMP parallel do default(none) shared(is,ie,js,je,kmd,nt,dy,q,isd,jsd,npx,npy,bounded_domain, & !$OMP bd,sw_corner,se_corner,nw_corner,ne_corner, & !$OMP sina_u,rdxc,sin_sg,dx,rdyc,sina_v,qdt,damp,rarea) & !$OMP private(fx, fy) do k=1,kmd - if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 1, nested, bd, & + if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 1, bounded_domain, bd, & sw_corner, se_corner, nw_corner, ne_corner) do j=js-nt,je+nt do i=is-nt,ie+1+nt @@ -3629,7 +3628,7 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) 0.5*(sin_sg(npx,j,1) + sin_sg(npx-1,j,3)) enddo - if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 2, nested, bd, & + if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 2, bounded_domain, bd, & sw_corner, se_corner, nw_corner, ne_corner) do j=js-nt,je+1+nt if (j == 1 .OR. j == npy) then diff --git a/tools/fv_restart.F90 b/tools/fv_restart.F90 index 1632212ed..c4722b33d 100644 --- a/tools/fv_restart.F90 +++ b/tools/fv_restart.F90 @@ -1,22 +1,22 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** module fv_restart_mod @@ -138,33 +138,34 @@ module fv_restart_mod use fv_arrays_mod, only: fv_atmos_type, fv_nest_type, fv_grid_bounds_type, R_GRID use fv_io_mod, only: fv_io_init, fv_io_read_restart, fv_io_write_restart, & remap_restart, fv_io_register_restart, fv_io_register_nudge_restart, & - fv_io_register_restart_BCs, fv_io_register_restart_BCs_NH, fv_io_write_BCs, fv_io_read_BCs + fv_io_register_restart_BCs, fv_io_write_BCs, fv_io_read_BCs use fv_grid_utils_mod, only: ptop_min, fill_ghost, g_sum, & make_eta_level, cubed_to_latlon, great_circle_dist use fv_diagnostics_mod, only: prt_maxmin use init_hydro_mod, only: p_var - use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain use mpp_domains_mod, only: mpp_update_domains, domain2d, DGRID_NE - use mpp_domains_mod, only: CENTER, CORNER, NORTH, EAST, mpp_get_C2F_index, WEST, SOUTH - use mpp_domains_mod, only: mpp_global_field use mpp_mod, only: mpp_chksum, stdout, mpp_error, FATAL, NOTE - use mpp_mod, only: get_unit, mpp_sum - use mpp_mod, only: mpp_get_current_pelist, mpp_set_current_pelist - use mpp_mod, only: mpp_send, mpp_recv, mpp_sync_self, mpp_npes, mpp_pe, mpp_sync - use test_cases_mod, only: test_case, alpha, init_case, init_double_periodic, init_latlon - use fv_mp_mod, only: is_master, switch_current_Atm, mp_reduce_min, mp_reduce_max + use mpp_mod, only: get_unit, mpp_sum, mpp_broadcast + use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_set_current_pelist + use test_cases_mod, only: alpha, init_case, init_double_periodic!, init_latlon + use fv_mp_mod, only: is_master, mp_reduce_min, mp_reduce_max, corners_YDir => YDir, fill_corners, tile_fine, global_nest_domain use fv_surf_map_mod, only: sgh_g, oro_g - use fv_surf_map_mod, only: del2_cubed_sphere, del4_cubed_sphere use tracer_manager_mod, only: get_tracer_names - use tracer_manager_mod, only: get_tracer_index use field_manager_mod, only: MODEL_ATMOS - use external_ic_mod, only: get_external_ic, get_cubed_sphere_terrain + use external_ic_mod, only: get_external_ic use fv_eta_mod, only: compute_dz_var, compute_dz_L32, set_hybrid_z - use boundary_mod, only: fill_nested_grid, nested_grid_BC, update_coarse_grid + use fv_surf_map_mod, only: del2_cubed_sphere, del4_cubed_sphere + use boundary_mod, only: fill_nested_grid, nested_grid_BC, update_coarse_grid + use tracer_manager_mod, only: get_tracer_index use field_manager_mod, only: MODEL_ATMOS use fv_timing_mod, only: timing_on, timing_off + use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain + use mpp_mod, only: mpp_send, mpp_recv, mpp_sync_self, mpp_set_current_pelist, mpp_get_current_pelist, mpp_npes, mpp_pe, mpp_sync + use mpp_domains_mod, only: CENTER, CORNER, NORTH, EAST, mpp_get_C2F_index, WEST, SOUTH + use mpp_domains_mod, only: mpp_global_field use fms_mod, only: file_exist use fv_treat_da_inc_mod, only: read_da_inc + use fv_regional_mod, only: write_full_fields #ifdef MULTI_GASES use multi_gases_mod, only: virq #endif @@ -172,8 +173,7 @@ module fv_restart_mod implicit none private - public :: fv_restart_init, fv_restart_end, fv_restart, fv_write_restart, setup_nested_boundary_halo - public :: d2c_setup, d2a_setup + public :: fv_restart_init, fv_restart_end, fv_restart, fv_write_restart real(kind=R_GRID), parameter :: cnst_0p20=0.20d0 !--- private data type @@ -192,414 +192,450 @@ end subroutine fv_restart_init !>@details The modules also writes out restart files at the end of the !! model run, and prints out diagnostics of the initial state. !! There are several options to control the initialization process. - subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_type, grids_on_this_pe) + subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_type, this_grid) type(domain2d), intent(inout) :: fv_domain type(fv_atmos_type), intent(inout) :: Atm(:) real, intent(in) :: dt_atmos integer, intent(out) :: seconds integer, intent(out) :: days - logical, intent(inout) :: cold_start - integer, intent(in) :: grid_type - logical, intent(INOUT) :: grids_on_this_pe(:) - + logical, intent(inout) :: cold_start + integer, intent(in) :: grid_type, this_grid integer :: i, j, k, n, ntileMe, nt, iq - integer :: isc, iec, jsc, jec, npz, npz_rst, ncnst, ntprog, ntdiag - integer :: isd, ied, jsd, jed + integer :: isc, iec, jsc, jec, ncnst, ntprog, ntdiag + integer :: isd, ied, jsd, jed, npz integer isd_p, ied_p, jsd_p, jed_p, isc_p, iec_p, jsc_p, jec_p, isg, ieg, jsg,jeg, npx_p, npy_p real, allocatable :: g_dat(:,:,:) integer :: unit real, allocatable :: dz1(:) - real rgrav, f00, ztop, pertn + real rgrav, f00, ztop, pertn, ph logical :: hybrid - logical :: cold_start_grids(size(Atm)) character(len=128):: tname, errstring, fname, tracer_name character(len=120):: fname_ne, fname_sw character(len=3) :: gn - integer :: npts + integer :: npts, sphum + integer, allocatable :: pelist(:), smoothed_topo(:) real :: sumpertn + real :: zvir + + integer :: i_butterfly, j_butterfly + logical :: do_read_restart = .false. + logical :: do_read_restart_bc = .false. + integer, allocatable :: ideal_test_case(:), new_nest_topo(:) rgrav = 1. / grav if(.not.module_is_initialized) call mpp_error(FATAL, 'You must call fv_restart_init.') ntileMe = size(Atm(:)) + allocate(smoothed_topo(ntileme)) + smoothed_topo(:) = 0 + allocate(ideal_test_case(ntileme)) + ideal_test_case(:) = 0 + allocate(new_nest_topo(ntileme)) + new_nest_topo(:) = 0 - cold_start_grids(:) = cold_start do n = 1, ntileMe - if (is_master()) then - print*, 'FV_RESTART: ', n, cold_start_grids(n) - endif + isd = Atm(n)%bd%isd + ied = Atm(n)%bd%ied + jsd = Atm(n)%bd%jsd + jed = Atm(n)%bd%jed + isc = Atm(n)%bd%isc + iec = Atm(n)%bd%iec + jsc = Atm(n)%bd%jsc + jec = Atm(n)%bd%jec + ncnst = Atm(n)%ncnst + if( is_master() ) write(*,*) 'in fv_restart ncnst=', ncnst + npz = Atm(n)%npz + ntprog = size(Atm(n)%q,4) + ntdiag = size(Atm(n)%qdiag,4) + +!!$ if (is_master()) then +!!$ print*, 'FV_RESTART: ', n, cold_start_grids(n) +!!$ endif + !1. sort out restart, external_ic, and cold-start (idealized) if (Atm(n)%neststruct%nested) then - write(fname,'(A, I2.2, A)') 'INPUT/fv_core.res.nest', Atm(n)%grid_number, '.nc' + write(fname, '(A, I2.2, A)') 'INPUT/fv_core.res.nest', Atm(n)%grid_number, '.nc' write(fname_ne,'(A, I2.2, A)') 'INPUT/fv_BC_ne.res.nest', Atm(n)%grid_number, '.nc' write(fname_sw,'(A, I2.2, A)') 'INPUT/fv_BC_sw.res.nest', Atm(n)%grid_number, '.nc' - if (Atm(n)%flagstruct%external_ic) then - if (is_master()) print*, 'External IC set on grid', Atm(n)%grid_number, ', re-initializing grid' - cold_start_grids(n) = .true. - Atm(n)%flagstruct%warm_start = .false. !resetting warm_start flag to avoid FATAL error below - else - if (is_master()) print*, 'Searching for nested grid restart file ', trim(fname) - cold_start_grids(n) = .not. file_exist(fname, Atm(n)%domain) - Atm(n)%flagstruct%warm_start = file_exist(fname, Atm(n)%domain)!resetting warm_start flag to avoid FATAL error below + if (is_master()) print*, 'Searching for nested grid BC files ', trim(fname_ne), ' ', trim (fname_sw) + do_read_restart = file_exist(fname, Atm(n)%domain) + do_read_restart_bc = file_exist(fname_ne, Atm(n)%domain) .and. file_exist(fname_sw, Atm(n)%domain) + if (is_master()) then + print*, 'FV_RESTART: ', n, do_read_restart, do_read_restart_bc + if (.not. do_read_restart_bc) write(*,*) 'BC files not found, re-generating nested grid boundary conditions' endif + Atm(N)%neststruct%first_step = .not. do_read_restart_bc + else + fname='INPUT/fv_core.res.nc' + do_read_restart = file_exist('INPUT/fv_core.res.nc') .or. file_exist('INPUT/fv_core.res.tile1.nc') + if (is_master()) print*, 'FV_RESTART: ', n, do_read_restart, do_read_restart_bc endif - if (.not. grids_on_this_pe(n)) then - - !Even if this grid is not on this PE, if it has child grids we must send - !along the data that is needed. - !This is a VERY complicated bit of code that attempts to follow the entire decision tree - ! of the initialization without doing anything. This could very much be cleaned up. + !2. Register restarts + !--- call fv_io_register_restart to register restart field to be written out in fv_io_write_restart + if ( n==this_grid ) call fv_io_register_restart(Atm(n)%domain,Atm(n:n)) + !if (Atm(n)%neststruct%nested) call fv_io_register_restart_BCs(Atm(n)) !TODO put into fv_io_register_restart - if (Atm(n)%neststruct%nested) then - if (cold_start_grids(n)) then - if (Atm(n)%parent_grid%flagstruct%n_zs_filter > 0) call fill_nested_grid_topo_halo(Atm(n), .false.) - if (Atm(n)%flagstruct%nggps_ic) then - call fill_nested_grid_topo(Atm(n), .false.) - call fill_nested_grid_topo_halo(Atm(n), .false.) - call nested_grid_BC(Atm(n)%ps, Atm(n)%parent_grid%ps, Atm(n)%neststruct%nest_domain, & - Atm(n)%neststruct%ind_h, Atm(n)%neststruct%wt_h, 0, 0, & - Atm(n)%npx, Atm(n)%npy,Atm(n)%bd, isg, ieg, jsg, jeg, proc_in=.false.) - call setup_nested_boundary_halo(Atm(n),.false.) - else - call fill_nested_grid_topo(Atm(n), .false.) - call setup_nested_boundary_halo(Atm(n),.false.) - if ( Atm(n)%flagstruct%external_ic .and. grid_type < 4 ) call fill_nested_grid_data(Atm(n:n), .false.) - endif - else - if (is_master()) print*, 'Searching for nested grid BC files ', trim(fname_ne), ' ', trim (fname_sw) - !!!! PROBLEM: file_exist doesn't know to look for fv_BC_ne.res.nest02.nc instead of fv_BC_ne.res.nc on coarse grid - if (file_exist(fname_ne, Atm(n)%domain) .and. file_exist(fname_sw, Atm(n)%domain)) then - else - if ( is_master() ) write(*,*) 'BC files not found, re-generating nested grid boundary conditions' - call fill_nested_grid_topo_halo(Atm(n), .false.) - call setup_nested_boundary_halo(Atm(n), .false.) - Atm(N)%neststruct%first_step = .true. - endif - end if - - if (.not. Atm(n)%flagstruct%hydrostatic .and. Atm(n)%flagstruct%make_nh .and. & - (.not. Atm(n)%flagstruct%nggps_ic .and. .not. Atm(n)%flagstruct%ecmwf_ic) ) then - call nested_grid_BC(Atm(n)%delz, Atm(n)%parent_grid%delz, Atm(n)%neststruct%nest_domain, & - Atm(n)%neststruct%ind_h, Atm(n)%neststruct%wt_h, 0, 0, & - Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%bd, isg, ieg, jsg, jeg, proc_in=.false.) - call nested_grid_BC(Atm(n)%w, Atm(n)%parent_grid%w, Atm(n)%neststruct%nest_domain, & + !3preN. Topography BCs for nest, including setup for blending + + if (Atm(n)%neststruct%nested) then + if (.not. allocated(pelist)) then + allocate(pelist(0:mpp_npes()-1)) + call mpp_get_current_pelist(pelist) + endif + call mpp_set_current_pelist() !global + call mpp_broadcast(Atm(n)%flagstruct%external_ic,Atm(n)%pelist(1)) + call mpp_sync() + call mpp_set_current_pelist(pelist) + if ( ( smoothed_topo(Atm(n)%parent_grid%grid_number) > 0 .or. & + .not. do_read_restart_bc .or. & + Atm(n)%flagstruct%external_ic ) ) then + new_nest_topo(n) = 1 + if (n==this_grid) then + + call fill_nested_grid_topo(Atm(n), n==this_grid) + call fill_nested_grid_topo_halo(Atm(n), n==this_grid) !TODO can we combine these? + call nested_grid_BC(Atm(n)%ps, Atm(n)%parent_grid%ps, global_nest_domain, & Atm(n)%neststruct%ind_h, Atm(n)%neststruct%wt_h, 0, 0, & - Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%bd, isg, ieg, jsg, jeg, proc_in=.false.) + Atm(n)%npx, Atm(n)%npy, Atm(n)%bd, 1, Atm(n)%npx-1, 1, Atm(n)%npy-1) + + elseif (this_grid==Atm(n)%parent_grid%grid_number) then !this_grid is grid n's parent + + call fill_nested_grid_topo(Atm(n), n==this_grid) + call fill_nested_grid_topo_halo(Atm(n), n==this_grid) !TODO can we combine these? + !call mpp_get_data_domain( Atm(n)%parent_grid%domain, isd, ied, jsd, jed) + call nested_grid_BC(Atm(n)%parent_grid%ps, global_nest_domain, 0, 0, n-1) + !Atm(n)%ps, Atm(n)%parent_grid%ps, global_nest_domain, & + !Atm(n)%neststruct%ind_h, Atm(n)%neststruct%wt_h, 0, 0, & + !Atm(n)%npx, Atm(n)%npy, Atm(n)%bd, isd, ied, jsd, jed, proc_in=n==this_grid) + endif endif - - cycle - endif - !This call still appears to be necessary to get isd, etc. correct - call switch_current_Atm(Atm(n)) - - !--- call fv_io_register_restart to register restart field to be written out in fv_io_write_restart - call fv_io_register_restart(Atm(n)%domain,Atm(n:n)) - if (Atm(n)%neststruct%nested) call fv_io_register_restart_BCs(Atm(n)) - if( .not.cold_start_grids(n) .and. (.not. Atm(n)%flagstruct%external_ic) ) then - - - if ( Atm(n)%flagstruct%npz_rst /= 0 .and. Atm(n)%flagstruct%npz_rst /= Atm(n)%npz ) then -! Remap vertically the prognostic variables for the chosen vertical resolution - if( is_master() ) then - write(*,*) ' ' - write(*,*) '***** Important Note from FV core ********************' - write(*,*) 'Remapping dynamic IC from', Atm(n)%flagstruct%npz_rst, 'levels to ', Atm(n)%npz,'levels' - write(*,*) '***** End Note from FV core **************************' - write(*,*) ' ' - endif - call remap_restart( Atm(n)%domain, Atm(n:n) ) - if( is_master() ) write(*,*) 'Done remapping dynamical IC' - else - if( is_master() ) write(*,*) 'Warm starting, calling fv_io_restart' - call fv_io_read_restart(Atm(n)%domain,Atm(n:n)) -! ====== PJP added DA functionality ====== - if (Atm(n)%flagstruct%read_increment) then - ! print point in middle of domain for a sanity check - i = (Atm(n)%bd%isc + Atm(n)%bd%iec)/2 - j = (Atm(n)%bd%jsc + Atm(n)%bd%jec)/2 - k = Atm(n)%npz/2 - if( is_master() ) write(*,*) 'Calling read_da_inc',Atm(n)%pt(i,j,k) - call read_da_inc(Atm(n:n), Atm(n)%domain) - if( is_master() ) write(*,*) 'Back from read_da_inc',Atm(n)%pt(i,j,k) - endif -! ====== end PJP added DA functionailty====== - endif - endif -!--------------------------------------------------------------------------------------------- -! Read, interpolate (latlon to cubed), then remap vertically with terrain adjustment if needed -!--------------------------------------------------------------------------------------------- - if (Atm(n)%neststruct%nested) then - if (cold_start_grids(n)) call fill_nested_grid_topo(Atm(n), .true.) - !if (cold_start_grids(n) .and. .not. Atm(n)%flagstruct%nggps_ic) call fill_nested_grid_topo(Atm(n), .true.) - if (cold_start_grids(n)) then - if (Atm(n)%parent_grid%flagstruct%n_zs_filter > 0 .or. Atm(n)%flagstruct%nggps_ic) call fill_nested_grid_topo_halo(Atm(n), .true.) - end if - if (Atm(n)%flagstruct%external_ic .and. Atm(n)%flagstruct%nggps_ic) then - !Fill nested grid halo with ps - call nested_grid_BC(Atm(n)%ps, Atm(n)%parent_grid%ps, Atm(n)%neststruct%nest_domain, & - Atm(n)%neststruct%ind_h, Atm(n)%neststruct%wt_h, 0, 0, & - Atm(n)%npx, Atm(n)%npy,Atm(n)%bd, isg, ieg, jsg, jeg, proc_in=.true.) - endif - endif - if ( Atm(n)%flagstruct%external_ic ) then - if( is_master() ) write(*,*) 'Calling get_external_ic' - call get_external_ic(Atm(n:n), Atm(n)%domain, cold_start_grids(n)) - if( is_master() ) write(*,*) 'IC generated from the specified external source' - endif + !This call still appears to be necessary to get isd, etc. correct + !call switch_current_Atm(Atm(n)) !TODO should NOT be necessary now that we manually set isd, etc. - seconds = 0; days = 0 ! Restart needs to be modified to record seconds and days. + !--- call fv_io_register_restart to register restart field to be written out in fv_io_write_restart + !if (n==this_grid) call fv_io_register_restart(Atm(n)%domain,Atm(n:n)) + !if (Atm(n)%neststruct%nested) call fv_io_register_restart_BCs(Atm(n)) !TODO put into fv_io_register_restart -! Notes by Jeff D. - ! This logic doesn't work very well. - ! Shouldn't have read for all tiles then loop over tiles + if (n==this_grid) then + + !3. External_ic + if (Atm(n)%flagstruct%external_ic) then + if( is_master() ) write(*,*) 'Calling get_external_ic' + call get_external_ic(Atm(n), Atm(n)%domain, .not. do_read_restart, dt_atmos) + if( is_master() ) write(*,*) 'IC generated from the specified external source' - isd = Atm(n)%bd%isd - ied = Atm(n)%bd%ied - jsd = Atm(n)%bd%jsd - jed = Atm(n)%bd%jed - ncnst = Atm(n)%ncnst - if( is_master() ) write(*,*) 'in fv_restart ncnst=', ncnst - isc = Atm(n)%bd%isc; iec = Atm(n)%bd%iec; jsc = Atm(n)%bd%jsc; jec = Atm(n)%bd%jec + !4. Restart + elseif (do_read_restart) then - ! Init model data - if(.not.cold_start_grids(n))then - Atm(N)%neststruct%first_step = .false. - if (Atm(n)%neststruct%nested) then if ( Atm(n)%flagstruct%npz_rst /= 0 .and. Atm(n)%flagstruct%npz_rst /= Atm(n)%npz ) then - call setup_nested_boundary_halo(Atm(n)) + !Remap vertically the prognostic variables for the chosen vertical resolution + if( is_master() ) then + write(*,*) ' ' + write(*,*) '***** Important Note from FV core ********************' + write(*,*) 'Remapping dynamic IC from', Atm(n)%flagstruct%npz_rst, 'levels to ', Atm(n)%npz,'levels' + write(*,*) '***** End Note from FV core **************************' + write(*,*) ' ' + endif + call remap_restart( Atm(n)%domain, Atm(n:n) ) + if( is_master() ) write(*,*) 'Done remapping dynamical IC' else - !If BC file is found, then read them in. Otherwise we need to initialize the BCs. - if (is_master()) print*, 'Searching for nested grid BC files ', trim(fname_ne), ' ', trim (fname_sw) - if (file_exist(fname_ne, Atm(n)%domain) .and. file_exist(fname_sw, Atm(n)%domain)) then - call fv_io_read_BCs(Atm(n)) - else - if ( is_master() ) write(*,*) 'BC files not found, re-generating nested grid boundary conditions' - call fill_nested_grid_topo_halo(Atm(n), .true.) - call setup_nested_boundary_halo(Atm(n), .true.) - Atm(N)%neststruct%first_step = .true. + if( is_master() ) write(*,*) 'Warm starting, calling fv_io_restart' + call fv_io_read_restart(Atm(n)%domain,Atm(n:n)) + !====== PJP added DA functionality ====== + if (Atm(n)%flagstruct%read_increment) then + ! print point in middle of domain for a sanity check + i = (Atm(n)%bd%isc + Atm(n)%bd%iec)/2 + j = (Atm(n)%bd%jsc + Atm(n)%bd%jec)/2 + k = Atm(n)%npz/2 + if( is_master() ) write(*,*) 'Calling read_da_inc',Atm(n)%pt(i,j,k) + call read_da_inc(Atm(n), Atm(n)%domain, Atm(n)%bd, Atm(n)%npz, Atm(n)%ncnst, & + Atm(n)%u, Atm(n)%v, Atm(n)%q, Atm(n)%delp, Atm(n)%pt, Atm(n)%delz, isd, jsd, ied, jed, & + isc, jsc, iec, jec ) + if( is_master() ) write(*,*) 'Back from read_da_inc',Atm(n)%pt(i,j,k) endif - !Following line to make sure u and v are consistent across processor subdomains + !====== end PJP added DA functionailty====== + endif + + seconds = 0; days = 0 ! Restart needs to be modified to record seconds and days. + + if (Atm(n)%neststruct%nested) then + if ( Atm(n)%flagstruct%npz_rst /= 0 .and. Atm(n)%flagstruct%npz_rst /= npz ) then + call mpp_error(FATAL, "Remap-restart not implemented for nests.") + endif + if (do_read_restart_BC) call fv_io_read_BCs(Atm(n)) call mpp_update_domains(Atm(n)%u, Atm(n)%v, Atm(n)%domain, gridtype=DGRID_NE, complete=.true.) endif - endif - if ( Atm(n)%flagstruct%mountain ) then -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! !!! Additional terrain filter -- should not be called repeatedly !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( Atm(n)%flagstruct%n_zs_filter > 0 ) then - if ( Atm(n)%flagstruct%nord_zs_filter == 2 ) then - call del2_cubed_sphere(Atm(n)%npx, Atm(n)%npy, Atm(n)%phis, & - Atm(n)%gridstruct%area_64, Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, & - Atm(n)%gridstruct%dxc, Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%sin_sg, & - Atm(n)%flagstruct%n_zs_filter, cnst_0p20*Atm(n)%gridstruct%da_min, & - .false., oro_g, Atm(n)%neststruct%nested, Atm(n)%domain, Atm(n)%bd, Atm(n)%flagstruct%regional) - if ( is_master() ) write(*,*) 'Warning !!! del-2 terrain filter has been applied ', & - Atm(n)%flagstruct%n_zs_filter, ' times' - else if( Atm(n)%flagstruct%nord_zs_filter == 4 ) then - call del4_cubed_sphere(Atm(n)%npx, Atm(n)%npy, Atm(n)%phis, Atm(n)%gridstruct%area_64, & - Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, & - Atm(n)%gridstruct%dxc, Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%sin_sg, & - Atm(n)%flagstruct%n_zs_filter, .false., oro_g, Atm(n)%neststruct%nested, & - Atm(n)%domain, Atm(n)%bd, Atm(n)%flagstruct%regional) - if ( is_master() ) write(*,*) 'Warning !!! del-4 terrain filter has been applied ', & - Atm(n)%flagstruct%n_zs_filter, ' times' - endif - endif + if ( Atm(n)%flagstruct%mountain ) then + ! !!! Additional terrain filter -- should not be called repeatedly !!! + if ( Atm(n)%flagstruct%n_zs_filter > 0 ) then + if ( Atm(n)%flagstruct%nord_zs_filter == 2 ) then + !!! TODO: move this block into its own routine or CLEAN UP these subroutine calls + call del2_cubed_sphere(Atm(n)%npx, Atm(n)%npy, Atm(n)%phis, & + Atm(n)%gridstruct%area_64, Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, & + Atm(n)%gridstruct%dxc, Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%sin_sg, & + Atm(n)%flagstruct%n_zs_filter, cnst_0p20*Atm(n)%gridstruct%da_min, & + .false., oro_g, Atm(n)%gridstruct%bounded_domain, Atm(n)%domain, Atm(n)%bd) + if ( is_master() ) write(*,*) 'Warning !!! del-2 terrain filter has been applied ', & + Atm(n)%flagstruct%n_zs_filter, ' times' + else if( Atm(n)%flagstruct%nord_zs_filter == 4 ) then + call del4_cubed_sphere(Atm(n)%npx, Atm(n)%npy, Atm(n)%phis, Atm(n)%gridstruct%area_64, & + Atm(n)%gridstruct%dx, Atm(n)%gridstruct%dy, & + Atm(n)%gridstruct%dxc, Atm(n)%gridstruct%dyc, Atm(n)%gridstruct%sin_sg, & + Atm(n)%flagstruct%n_zs_filter, .false., oro_g, Atm(n)%gridstruct%bounded_domain, & + Atm(n)%domain, Atm(n)%bd) + if ( is_master() ) write(*,*) 'Warning !!! del-4 terrain filter has been applied ', & + Atm(n)%flagstruct%n_zs_filter, ' times' + endif + endif + call mpp_update_domains( Atm(n)%phis, Atm(n)%domain, complete=.true. ) + else + Atm(n)%phis = 0. + if( is_master() ) write(*,*) 'phis set to zero' + endif !mountain - call mpp_update_domains( Atm(n)%phis, Atm(n)%domain, complete=.true. ) - else - Atm(n)%phis = 0. - if( is_master() ) write(*,*) 'phis set to zero' - endif !mountain -#ifdef SW_DYNAMICS - Atm(n)%pt(:,:,:) = 1. -#else - if ( .not.Atm(n)%flagstruct%hybrid_z ) then - if(Atm(n)%ptop /= Atm(n)%ak(1)) call mpp_error(FATAL,'FV restart: ptop not equal Atm(n)%ak(1)') - else - Atm(n)%ptop = Atm(n)%ak(1) ; Atm(n)%ks = 0 - endif - call p_var(Atm(n)%npz, isc, iec, jsc, jec, Atm(n)%ptop, ptop_min, & - Atm(n)%delp, Atm(n)%delz, Atm(n)%pt, Atm(n)%ps, Atm(n)%pe, Atm(n)%peln, & - Atm(n)%pk, Atm(n)%pkz, kappa, Atm(n)%q, Atm(n)%ng, & - ncnst, Atm(n)%gridstruct%area_64, Atm(n)%flagstruct%dry_mass, & - Atm(n)%flagstruct%adjust_dry_mass, Atm(n)%flagstruct%mountain, & - Atm(n)%flagstruct%moist_phys, Atm(n)%flagstruct%hydrostatic, & - Atm(n)%flagstruct%nwat, Atm(n)%domain, Atm(n)%flagstruct%make_nh) -#endif - if ( grid_type < 7 .and. grid_type /= 4 ) then -! Fill big values in the non-existing corner regions: -! call fill_ghost(Atm(n)%phis, Atm(n)%npx, Atm(n)%npy, big_number) - do j=jsd,jed+1 - do i=isd,ied+1 - Atm(n)%gridstruct%fc(i,j) = 2.*omega*( -cos(Atm(n)%gridstruct%grid(i,j,1))*cos(Atm(n)%gridstruct%grid(i,j,2))*sin(alpha) + & - sin(Atm(n)%gridstruct%grid(i,j,2))*cos(alpha) ) - enddo - enddo - do j=jsd,jed - do i=isd,ied - Atm(n)%gridstruct%f0(i,j) = 2.*omega*( -cos(Atm(n)%gridstruct%agrid(i,j,1))*cos(Atm(n)%gridstruct%agrid(i,j,2))*sin(alpha) + & - sin(Atm(n)%gridstruct%agrid(i,j,2))*cos(alpha) ) - enddo - enddo - else - f00 = 2.*omega*sin(Atm(n)%flagstruct%deglat/180.*pi) - do j=jsd,jed+1 - do i=isd,ied+1 - Atm(n)%gridstruct%fc(i,j) = f00 - enddo - enddo - do j=jsd,jed - do i=isd,ied - Atm(n)%gridstruct%f0(i,j) = f00 - enddo - enddo - endif - else - if ( Atm(n)%flagstruct%warm_start ) then - call mpp_error(FATAL, 'FV restart files not found; set warm_start = .F. if cold_start is desired.') - endif -! Cold start - if ( Atm(n)%flagstruct%make_hybrid_z ) then - hybrid = .false. - else - hybrid = Atm(n)%flagstruct%hybrid_z - endif - if (grid_type < 4) then - if ( .not. Atm(n)%flagstruct%external_ic ) then - call init_case(Atm(n)%u,Atm(n)%v,Atm(n)%w,Atm(n)%pt,Atm(n)%delp,Atm(n)%q, & - Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, & - Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va, & - Atm(n)%ak, Atm(n)%bk, Atm(n)%gridstruct, Atm(n)%flagstruct,& - Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%ng, & - ncnst, Atm(n)%flagstruct%nwat, & - Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ntiles, & - Atm(n)%flagstruct%dry_mass, & - Atm(n)%flagstruct%mountain, & - Atm(n)%flagstruct%moist_phys, Atm(n)%flagstruct%hydrostatic, & - hybrid, Atm(n)%delz, Atm(n)%ze0, & - Atm(n)%flagstruct%adiabatic, Atm(n)%ks, Atm(n)%neststruct%npx_global, & - Atm(n)%ptop, Atm(n)%domain, Atm(n)%tile, Atm(n)%bd) - endif - elseif (grid_type == 4) then - call init_double_periodic(Atm(n)%u,Atm(n)%v,Atm(n)%w,Atm(n)%pt, & - Atm(n)%delp,Atm(n)%q,Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, & - Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, & - Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va, & - Atm(n)%ak, Atm(n)%bk, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%ng, & - ncnst, Atm(n)%flagstruct%nwat, & - Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ntiles, & - Atm(n)%flagstruct%dry_mass, Atm(n)%flagstruct%mountain, & - Atm(n)%flagstruct%moist_phys, Atm(n)%flagstruct%hydrostatic, & - hybrid, Atm(n)%delz, Atm(n)%ze0, Atm(n)%ks, Atm(n)%ptop, & - Atm(n)%domain, Atm(n)%tile, Atm(n)%bd) - if( is_master() ) write(*,*) 'Doubly Periodic IC generated' - elseif (grid_type == 5 .or. grid_type == 6) then - call init_latlon(Atm(n)%u,Atm(n)%v,Atm(n)%pt,Atm(n)%delp,Atm(n)%q,& - Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, & - Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, & - Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va, & - Atm(n)%ak, Atm(n)%bk, Atm(n)%gridstruct, & - Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, Atm(n)%ng, ncnst, & - Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ntiles, & - Atm(n)%flagstruct%dry_mass, & - Atm(n)%flagstruct%mountain, & - Atm(n)%flagstruct%moist_phys, hybrid, Atm(n)%delz, & - Atm(n)%ze0, Atm(n)%domain, Atm(n)%tile) - endif + !5. Idealized test case + else + + ideal_test_case(n) = 1 + + if ( Atm(n)%flagstruct%make_hybrid_z ) then + hybrid = .false. + else + hybrid = Atm(n)%flagstruct%hybrid_z + endif + if (grid_type < 4) then + if ( .not. Atm(n)%flagstruct%external_ic ) then + call init_case(Atm(n)%u,Atm(n)%v,Atm(n)%w,Atm(n)%pt,Atm(n)%delp,Atm(n)%q, & + Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, & + Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va, & + Atm(n)%ak, Atm(n)%bk, Atm(n)%gridstruct, Atm(n)%flagstruct,& + Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ng, & + ncnst, Atm(n)%flagstruct%nwat, & + Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ntiles, & + Atm(n)%flagstruct%dry_mass, & + Atm(n)%flagstruct%mountain, & + Atm(n)%flagstruct%moist_phys, Atm(n)%flagstruct%hydrostatic, & + hybrid, Atm(n)%delz, Atm(n)%ze0, & + Atm(n)%flagstruct%adiabatic, Atm(n)%ks, Atm(n)%neststruct%npx_global, & + Atm(n)%ptop, Atm(n)%domain, Atm(n)%tile_of_mosaic, Atm(n)%bd) + endif + elseif (grid_type == 4) then + call init_double_periodic(Atm(n)%u,Atm(n)%v,Atm(n)%w,Atm(n)%pt, & + Atm(n)%delp,Atm(n)%q,Atm(n)%phis, Atm(n)%ps,Atm(n)%pe, & + Atm(n)%peln,Atm(n)%pk,Atm(n)%pkz, & + Atm(n)%uc,Atm(n)%vc, Atm(n)%ua,Atm(n)%va, & + Atm(n)%ak, Atm(n)%bk, & + Atm(n)%gridstruct, Atm(n)%flagstruct, & + Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%ng, & + ncnst, Atm(n)%flagstruct%nwat, & + Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ntiles, & + Atm(n)%flagstruct%dry_mass, Atm(n)%flagstruct%mountain, & + Atm(n)%flagstruct%moist_phys, Atm(n)%flagstruct%hydrostatic, & + hybrid, Atm(n)%delz, Atm(n)%ze0, Atm(n)%ks, Atm(n)%ptop, & + Atm(n)%domain, Atm(n)%tile_of_mosaic, Atm(n)%bd) + if( is_master() ) write(*,*) 'Doubly Periodic IC generated' + elseif (grid_type == 5 .or. grid_type == 6) then + call mpp_error(FATAL, "Idealized test cases for grid_type == 5,6 (global lat-lon) grid not supported") + endif - !Turn this off on the nested grid if you are just interpolating topography from the coarse grid! - if ( Atm(n)%flagstruct%fv_land ) then - do j=jsc,jec - do i=isc,iec - Atm(n)%sgh(i,j) = sgh_g(i,j) - Atm(n)%oro(i,j) = oro_g(i,j) + !Turn this off on the nested grid if you are just interpolating topography from the coarse grid! + !These parameters are needed in LM3/LM4, and are communicated through restart files + if ( Atm(n)%flagstruct%fv_land ) then + do j=jsc,jec + do i=isc,iec + Atm(n)%sgh(i,j) = sgh_g(i,j) + Atm(n)%oro(i,j) = oro_g(i,j) + enddo enddo - enddo - endif + endif + + endif !external_ic vs. restart vs. idealized + + + endif !n==this_grid - !Set up nested grids + !!!! NOT NEEDED?? !Currently even though we do fill in the nested-grid IC from ! init_case or external_ic we appear to overwrite it using ! coarse-grid data - !if (Atm(n)%neststruct%nested) then - ! Only fill nested-grid data if external_ic is called for the cubed-sphere grid +!!$ if (Atm(n)%neststruct%nested) then +!!$ if (.not. Atm(n)%flagstruct%external_ic .and. .not. Atm(n)%flagstruct%nggps_ic .and. grid_type < 4 ) then +!!$ call fill_nested_grid_data(Atm(n:n)) +!!$ endif +!!$ end if + +! endif !end cold_start check + + !5n. Nesting setup (part I) + + !Broadcast data for nesting + if (ntileMe > 1) then + if (.not. allocated(pelist)) then + allocate(pelist(0:mpp_npes()-1)) + call mpp_get_current_pelist(pelist) + endif + + call mpp_set_current_pelist()!global + !for remap BCs + call mpp_broadcast(Atm(n)%ptop,Atm(n)%pelist(1)) + call mpp_broadcast(Atm(n)%ak,Atm(n)%npz+1,Atm(n)%pelist(1)) + call mpp_broadcast(Atm(n)%bk,Atm(n)%npz+1,Atm(n)%pelist(1)) + !smoothed_topo + call mpp_broadcast(smoothed_topo(n),Atm(n)%pelist(1)) + + call mpp_sync() + call mpp_set_current_pelist(pelist) + + if (Atm(n)%neststruct%nested) then - call setup_nested_boundary_halo(Atm(n), .true.) - if (Atm(n)%flagstruct%external_ic .and. .not. Atm(n)%flagstruct%nggps_ic .and. grid_type < 4 ) then - call fill_nested_grid_data(Atm(n:n)) + Atm(n)%neststruct%do_remap_BC(ntileMe) = .false. + + if (Atm(n)%npz /= Atm(n)%parent_grid%npz) then + Atm(n)%neststruct%do_remap_BC(n) = .true. + else + do k=1,Atm(n)%npz+1 + if (Atm(n)%ak(k) /= Atm(n)%parent_grid%ak(k)) then + Atm(n)%neststruct%do_remap_BC(n) = .true. + exit + endif + if (Atm(n)%bk(k) /= Atm(n)%parent_grid%bk(k)) then + Atm(n)%neststruct%do_remap_BC(n) = .true. + exit + endif + enddo endif - end if - endif !end cold_start check + Atm(n)%parent_grid%neststruct%do_remap_BC(n) = Atm(n)%neststruct%do_remap_BC(n) + if (is_master() .and. n==this_grid) then + if (Atm(n)%neststruct%do_remap_BC(n)) then + print*, ' Remapping BCs ENABLED on grid', n + else + print*, ' Remapping BCs DISABLED (not necessary) on grid', n + endif + write(*,'(A, I3, A, F8.2, A)') ' Nested grid ', n, ', ptop = ', Atm(n)%ak(1), ' Pa' + write(*,'(A, I3, A, F8.2, A)') ' Parent grid ', n, ', ptop = ', Atm(n)%parent_grid%ak(1), ' Pa' + if (Atm(n)%ak(1) < Atm(n)%parent_Grid%ak(1)) then + print*, ' WARNING nested grid top above parent grid top. May have problems with remapping BCs.' + endif + endif + endif - if ( (.not.Atm(n)%flagstruct%hydrostatic) .and. Atm(n)%flagstruct%make_nh .and. Atm(n)%neststruct%nested) then - call nested_grid_BC(Atm(n)%delz, Atm(n)%parent_grid%delz, Atm(n)%neststruct%nest_domain, & - Atm(n)%neststruct%ind_h, Atm(n)%neststruct%wt_h, 0, 0, & - Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%bd, isg, ieg, jsg, jeg, proc_in=.true.) - call nested_grid_BC(Atm(n)%w, Atm(n)%parent_grid%w, Atm(n)%neststruct%nest_domain, & - Atm(n)%neststruct%ind_h, Atm(n)%neststruct%wt_h, 0, 0, & - Atm(n)%npx, Atm(n)%npy, npz, Atm(n)%bd, isg, ieg, jsg, jeg, proc_in=.true.) - call fv_io_register_restart_BCs_NH(Atm(n)) !needed to register nested-grid BCs not registered earlier endif - end do + end do !break cycling loop to finish nesting setup do n = ntileMe,1,-1 - if (Atm(n)%neststruct%nested .and. Atm(n)%flagstruct%external_ic .and. & - Atm(n)%flagstruct%grid_type < 4 .and. cold_start_grids(n)) then - call fill_nested_grid_data_end(Atm(n), grids_on_this_pe(n)) + if (new_nest_topo(n) > 0 ) then + call twoway_topo_update(Atm(n), n==this_grid) endif end do + !6. Data Setup do n = 1, ntileMe - if (.not. grids_on_this_pe(n)) cycle + + if (n/=this_grid) cycle isd = Atm(n)%bd%isd ied = Atm(n)%bd%ied jsd = Atm(n)%bd%jsd jed = Atm(n)%bd%jed + isc = Atm(n)%bd%isc + iec = Atm(n)%bd%iec + jsc = Atm(n)%bd%jsc + jec = Atm(n)%bd%jec ncnst = Atm(n)%ncnst + if( is_master() ) write(*,*) 'in fv_restart ncnst=', ncnst + npz = Atm(n)%npz ntprog = size(Atm(n)%q,4) ntdiag = size(Atm(n)%qdiag,4) - isc = Atm(n)%bd%isc; iec = Atm(n)%bd%iec; jsc = Atm(n)%bd%jsc; jec = Atm(n)%bd%jec + + + if ( ideal_test_case(n) == 0 ) then +#ifdef SW_DYNAMICS + Atm(n)%pt(:,:,:)=1. +#else + if ( .not.Atm(n)%flagstruct%hybrid_z ) then + if(Atm(n)%ptop/=Atm(n)%ak(1)) call mpp_error(FATAL,'FV restart: ptop not equal Atm(n)%ak(1)') + else + Atm(n)%ptop = Atm(n)%ak(1); Atm(n)%ks = 0 + endif + call p_var(npz, isc, iec, jsc, jec, Atm(n)%ptop, ptop_min, & + Atm(n)%delp, Atm(n)%delz, Atm(n)%pt, Atm(n)%ps, Atm(n)%pe, Atm(n)%peln, & + Atm(n)%pk, Atm(n)%pkz, kappa, Atm(n)%q, Atm(n)%ng, & + ncnst, Atm(n)%gridstruct%area_64, Atm(n)%flagstruct%dry_mass, & + Atm(n)%flagstruct%adjust_dry_mass, Atm(n)%flagstruct%mountain, & + Atm(n)%flagstruct%moist_phys, Atm(n)%flagstruct%hydrostatic, & + Atm(n)%flagstruct%nwat, Atm(n)%domain, Atm(1)%flagstruct%adiabatic, Atm(n)%flagstruct%make_nh) +#endif + if ( grid_type < 7 .and. grid_type /= 4 ) then + ! Fill big values in the non-existing corner regions: + ! call fill_ghost(Atm(n)%phis, Atm(n)%npx, Atm(n)%npy, big_number) + do j=jsd,jed+1 + do i=isd,ied+1 + Atm(n)%gridstruct%fc(i,j) = 2.*omega*( -cos(Atm(n)%gridstruct%grid(i,j,1))*cos(Atm(n)%gridstruct%grid(i,j,2))*sin(alpha) + & + sin(Atm(n)%gridstruct%grid(i,j,2))*cos(alpha) ) + enddo + enddo + do j=jsd,jed + do i=isd,ied + Atm(n)%gridstruct%f0(i,j) = 2.*omega*( -cos(Atm(n)%gridstruct%agrid(i,j,1))*cos(Atm(n)%gridstruct%agrid(i,j,2))*sin(alpha) + & + sin(Atm(n)%gridstruct%agrid(i,j,2))*cos(alpha) ) + enddo + enddo + else + f00 = 2.*omega*sin(Atm(n)%flagstruct%deglat/180.*pi) + do j=jsd,jed+1 + do i=isd,ied+1 + Atm(n)%gridstruct%fc(i,j) = f00 + enddo + enddo + do j=jsd,jed + do i=isd,ied + Atm(n)%gridstruct%f0(i,j) = f00 + enddo + enddo + endif + call mpp_update_domains( Atm(n)%gridstruct%f0, Atm(n)%domain ) + if ( Atm(n)%gridstruct%cubed_sphere .and. (.not. Atm(n)%gridstruct%bounded_domain))then + call fill_corners(Atm(n)%gridstruct%f0, Atm(n)%npx, Atm(n)%npy, Corners_YDir) + endif + endif + !--------------------------------------------------------------------------------------------- ! Transform the (starting) Eulerian vertical coordinate from sigma-p to hybrid_z if ( Atm(n)%flagstruct%hybrid_z ) then if ( Atm(n)%flagstruct%make_hybrid_z ) then - allocate ( dz1(Atm(n)%npz) ) - if( Atm(n)%npz==32 ) then - call compute_dz_L32(Atm(n)%npz, ztop, dz1) + allocate ( dz1(npz) ) + if( npz==32 ) then + call compute_dz_L32(npz, ztop, dz1) else ztop = 45.E3 - call compute_dz_var(Atm(n)%npz, ztop, dz1) + call compute_dz_var(npz, ztop, dz1) endif - call set_hybrid_z(isc, iec, jsc, jec, Atm(n)%ng, Atm(n)%npz, ztop, dz1, rgrav, & + call set_hybrid_z(isc, iec, jsc, jec, Atm(n)%ng, npz, ztop, dz1, rgrav, & Atm(n)%phis, Atm(n)%ze0) deallocate ( dz1 ) -! call prt_maxmin('ZE0', Atm(n)%ze0, isc, iec, jsc, jec, 0, Atm(n)%npz, 1.E-3) -! call prt_maxmin('DZ0', Atm(n)%delz, isc, iec, jsc, jec, 0, Atm(n)%npz, 1. ) +! call prt_maxmin('ZE0', Atm(n)%ze0, isc, iec, jsc, jec, 0, npz, 1.E-3) +! call prt_maxmin('DZ0', Atm(n)%delz, isc, iec, jsc, jec, 0, npz, 1. ) endif -! call make_eta_level(Atm(n)%npz, Atm(n)%pe, area, Atm(n)%ks, Atm(n)%ak, Atm(n)%bk, Atm(n)%ptop) +! call make_eta_level(npz, Atm(n)%pe, area, Atm(n)%ks, Atm(n)%ak, Atm(n)%bk, Atm(n)%ptop) endif !--------------------------------------------------------------------------------------------- @@ -609,7 +645,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ call random_seed npts = 0 sumpertn = 0. - do k=1,Atm(n)%npz + do k=1,npz do j=jsc,jec do i=isc,iec call random_number(pertn) @@ -626,6 +662,35 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ call mpp_error(NOTE, errstring) endif + if (Atm(n)%flagstruct%butterfly_effect) then + if (n==1 .and. Atm(n)%tile_of_mosaic == 1) then + i_butterfly = Atm(n)%npx / 2 + j_butterfly = Atm(n)%npy / 2 + if (isc <= i_butterfly .and. i_butterfly <= iec) then + if (jsc <= j_butterfly .and. j_butterfly <= jec) then + + write(*,'(A, I0, A, I0)') "Adding butterfly effect at (i,j) ", i_butterfly, ", ", j_butterfly + write(*,'(A, E24.17)') "pt (before) :", Atm(n)%pt(i_butterfly,j_butterfly,Atm(n)%npz) + + Atm(n)%pt(i_butterfly,j_butterfly,Atm(n)%npz) = nearest(Atm(n)%pt(i_butterfly,j_butterfly,Atm(n)%npz), -1.0) + + write(*,'(A, E24.17)') "pt (after) :", Atm(n)%pt(i_butterfly,j_butterfly,Atm(n)%npz) + + endif + endif + endif + endif + if (Atm(n)%flagstruct%fv_sg_adj > 0 .and. Atm(n)%flagstruct%sg_cutoff > 0) then + !Choose n_sponge from first reference level above sg_cutoff + do k=1,npz + ph = Atm(n)%ak(k+1) + Atm(n)%bk(k+1)*Atm(n)%flagstruct%p_ref + if (ph > Atm(n)%flagstruct%sg_cutoff) exit + enddo + Atm(n)%flagstruct%n_sponge = min(k,npz) + write(errstring,'(A, I3, A)') ' Override n_sponge: applying 2dz filter to ', k , ' levels' + call mpp_error(NOTE, errstring) + endif + if (Atm(n)%grid_number > 1) then write(gn,'(A2, I1)') " g", Atm(n)%grid_number else @@ -633,6 +698,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ end if unit = stdout() + !!!NOTE: Checksums not yet working in stand-alone regional model!! write(unit,*) write(unit,*) 'fv_restart u ', trim(gn),' = ', mpp_chksum(Atm(n)%u(isc:iec,jsc:jec,:)) write(unit,*) 'fv_restart v ', trim(gn),' = ', mpp_chksum(Atm(n)%v(isc:iec,jsc:jec,:)) @@ -653,32 +719,38 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ call get_tracer_names(MODEL_ATMOS, iq, tracer_name) write(unit,*) 'fv_restart '//trim(tracer_name)//' = ', mpp_chksum(Atm(n)%q(isc:iec,jsc:jec,:,iq)) enddo + !--------------- ! Check Min/Max: !--------------- call pmaxmn_g('ZS', Atm(n)%phis, isc, iec, jsc, jec, 1, rgrav, Atm(n)%gridstruct%area_64, Atm(n)%domain) call pmaxmn_g('PS', Atm(n)%ps, isc, iec, jsc, jec, 1, 0.01, Atm(n)%gridstruct%area_64, Atm(n)%domain) - call pmaxmn_g('T ', Atm(n)%pt, isc, iec, jsc, jec, Atm(n)%npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call pmaxmn_g('T ', Atm(n)%pt, isc, iec, jsc, jec, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) ! Check tracers: do i=1, ntprog call get_tracer_names ( MODEL_ATMOS, i, tname ) - call pmaxmn_g(trim(tname), Atm(n)%q(isd:ied,jsd:jed,1:Atm(n)%npz,i:i), isc, iec, jsc, jec, Atm(n)%npz, & + call pmaxmn_g(trim(tname), Atm(n)%q(isd:ied,jsd:jed,1:npz,i:i), isc, iec, jsc, jec, npz, & 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) enddo #endif - call prt_maxmin('U ', Atm(n)%u(isc:iec,jsc:jec,1:Atm(n)%npz), isc, iec, jsc, jec, 0, Atm(n)%npz, 1.) - call prt_maxmin('V ', Atm(n)%v(isc:iec,jsc:jec,1:Atm(n)%npz), isc, iec, jsc, jec, 0, Atm(n)%npz, 1.) + call prt_maxmin('U ', Atm(n)%u(isc:iec,jsc:jec,1:npz), isc, iec, jsc, jec, 0, npz, 1.) + call prt_maxmin('V ', Atm(n)%v(isc:iec,jsc:jec,1:npz), isc, iec, jsc, jec, 0, npz, 1.) if ( (.not.Atm(n)%flagstruct%hydrostatic) .and. Atm(n)%flagstruct%make_nh ) then call mpp_error(NOTE, " Initializing w to 0") Atm(n)%w = 0. + sphum = get_tracer_index (MODEL_ATMOS, 'sphum') if ( .not.Atm(n)%flagstruct%hybrid_z ) then - call mpp_error(NOTE, " Initializing delz from hydrostatic state") - do k=1,Atm(n)%npz + if (Atm(n)%flagstruct%adiabatic .or. sphum < 0) then + zvir = 0. + else + zvir = rvgas/rdgas - 1. + endif + do k=1,npz do j=jsc,jec do i=isc,iec - Atm(n)%delz(i,j,k) = (rdgas*rgrav)*Atm(n)%pt(i,j,k)*(Atm(n)%peln(i,k,j)-Atm(n)%peln(i,k+1,j)) + Atm(n)%delz(i,j,k) = (rdgas*rgrav)*Atm(n)%pt(i,j,k)*(1.+zvir*Atm(n)%q(i,j,k,sphum))*(Atm(n)%peln(i,k,j)-Atm(n)%peln(i,k+1,j)) enddo enddo enddo @@ -686,7 +758,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ endif if ( .not.Atm(n)%flagstruct%hydrostatic ) & - call pmaxmn_g('W ', Atm(n)%w, isc, iec, jsc, jec, Atm(n)%npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) + call pmaxmn_g('W ', Atm(n)%w, isc, iec, jsc, jec, npz, 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) if (is_master()) write(unit,*) @@ -696,13 +768,13 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ if ( .not. Atm(n)%flagstruct%srf_init ) then call cubed_to_latlon(Atm(n)%u, Atm(n)%v, Atm(n)%ua, Atm(n)%va, & Atm(n)%gridstruct, & - Atm(n)%npx, Atm(n)%npy, Atm(n)%npz, 1, & + Atm(n)%npx, Atm(n)%npy, npz, 1, & Atm(n)%gridstruct%grid_type, Atm(n)%domain, & - Atm(n)%gridstruct%nested, Atm(n)%flagstruct%c2l_ord, Atm(n)%bd) + Atm(n)%gridstruct%bounded_domain, Atm(n)%flagstruct%c2l_ord, Atm(n)%bd) do j=jsc,jec do i=isc,iec - Atm(n)%u_srf(i,j) = Atm(n)%ua(i,j,Atm(n)%npz) - Atm(n)%v_srf(i,j) = Atm(n)%va(i,j,Atm(n)%npz) + Atm(n)%u_srf(i,j) = Atm(n)%ua(i,j,npz) + Atm(n)%v_srf(i,j) = Atm(n)%va(i,j,npz) enddo enddo Atm(n)%flagstruct%srf_init = .true. @@ -711,170 +783,25 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ end do ! n_tile end subroutine fv_restart + ! NAME="fv_restart" - subroutine setup_nested_boundary_halo(Atm, proc_in) - - !This routine is now taking the "easy way out" with regards - ! to pt (virtual potential temperature), q_con, and cappa; - ! their halo values are now set up when the BCs are set up - ! in fv_dynamics - - type(fv_atmos_type), intent(INOUT) :: Atm - logical, INTENT(IN), OPTIONAL :: proc_in - real, allocatable :: g_dat(:,:,:), g_dat2(:,:,:) - real, allocatable :: pt_coarse(:,:,:) - integer i,j,k,nq, sphum, ncnst, istart, iend, npz, nwat - integer isc, iec, jsc, jec, isd, ied, jsd, jed, is, ie, js, je - integer isd_p, ied_p, jsd_p, jed_p, isc_p, iec_p, jsc_p, jec_p, isg, ieg, jsg,jeg, npx_p, npy_p - real zvir - logical process - integer :: liq_wat, ice_wat, rainwat, snowwat, graupel - real :: qv, dp1, q_liq, q_sol, q_con, cvm, cappa, dp, pt, dz, pkz, rdg - - if (PRESENT(proc_in)) then - process = proc_in - else - process = .true. - endif - - isd = Atm%bd%isd - ied = Atm%bd%ied - jsd = Atm%bd%jsd - jed = Atm%bd%jed - ncnst = Atm%ncnst - isc = Atm%bd%isc; iec = Atm%bd%iec; jsc = Atm%bd%jsc; jec = Atm%bd%jec - is = Atm%bd%is ; ie = Atm%bd%ie ; js = Atm%bd%js ; je = Atm%bd%je - npz = Atm%npz - nwat = Atm%flagstruct%nwat - - if (nwat >= 3) then - liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat') - endif - if ( nwat== 5) then - rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') - elseif (nwat == 6) then - rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index (MODEL_ATMOS, 'graupel') - endif - - call mpp_get_data_domain( Atm%parent_grid%domain, & - isd_p, ied_p, jsd_p, jed_p ) - call mpp_get_compute_domain( Atm%parent_grid%domain, & - isc_p, iec_p, jsc_p, jec_p ) - call mpp_get_global_domain( Atm%parent_grid%domain, & - isg, ieg, jsg, jeg, xsize=npx_p, ysize=npy_p) - - call nested_grid_BC(Atm%delp, Atm%parent_grid%delp, Atm%neststruct%nest_domain, & - Atm%neststruct%ind_h, Atm%neststruct%wt_h, 0, 0, & - Atm%npx, Atm%npy, npz, Atm%bd, isg, ieg, jsg, jeg, proc_in=process) - do nq=1,ncnst - call nested_grid_BC(Atm%q(:,:,:,nq), & - Atm%parent_grid%q(:,:,:,nq), Atm%neststruct%nest_domain, & - Atm%neststruct%ind_h, Atm%neststruct%wt_h, 0, 0, & - Atm%npx, Atm%npy, npz, Atm%bd, isg, ieg, jsg, jeg, proc_in=process) - end do - - if (process) then - if (is_master()) print*, 'FILLING NESTED GRID HALO' - else - if (is_master()) print*, 'SENDING DATA TO FILL NESTED GRID HALO' - endif - - - !Filling phis? - !In idealized test cases, where the topography is EXACTLY known (ex case 13), - !interpolating the topography yields a much worse result. In comparison in - !real topography cases little difference is seen. - - !This is probably because the halo phis, which is used to compute - !geopotential height (gz, gh), only affects the interior by being - !used to compute corner gz in a2b_ord[24]. We might suppose this - !computation would be more accurate when using values of phis which - !are more consistent with those on the interior (ie the exactly-known - !values) than the crude values given through linear interpolation. - - !For real topography cases, or in cases in which the coarse-grid topo - ! is smoothed, we fill the boundary halo with the coarse-grid topo. - -#ifndef SW_DYNAMICS - !pt --- actually temperature - - call nested_grid_BC(Atm%pt, Atm%parent_grid%pt, Atm%neststruct%nest_domain, & - Atm%neststruct%ind_h, Atm%neststruct%wt_h, 0, 0, & - Atm%npx, Atm%npy, npz, Atm%bd, isg, ieg, jsg, jeg, proc_in=process) - - if (.not. Atm%flagstruct%hydrostatic) then - - !w - call nested_grid_BC(Atm%w(:,:,:), & - Atm%parent_grid%w(:,:,:), & - Atm%neststruct%nest_domain, Atm%neststruct%ind_h, Atm%neststruct%wt_h, 0, 0, & - Atm%npx, Atm%npy, npz, Atm%bd, isg, ieg, jsg, jeg, proc_in=process) - - - !delz - call nested_grid_BC(Atm%delz(:,:,:), & - Atm%parent_grid%delz(:,:,:), & - Atm%neststruct%nest_domain, Atm%neststruct%ind_h, Atm%neststruct%wt_h, 0, 0, & - Atm%npx, Atm%npy, npz, Atm%bd, isg, ieg, jsg, jeg, proc_in=process) - - end if - -#endif - - if (Atm%neststruct%child_proc) then - call nested_grid_BC(Atm%u, Atm%parent_grid%u(:,:,:), & - Atm%neststruct%nest_domain, Atm%neststruct%ind_u, Atm%neststruct%wt_u, 0, 1, & - Atm%npx, Atm%npy, npz, Atm%bd, isg, ieg, jsg, jeg, proc_in=process) - call nested_grid_BC(Atm%v, Atm%parent_grid%v(:,:,:), & - Atm%neststruct%nest_domain, Atm%neststruct%ind_v, Atm%neststruct%wt_v, 1, 0, & - Atm%npx, Atm%npy, npz, Atm%bd, isg, ieg, jsg, jeg, proc_in=process) - else - call nested_grid_BC(Atm%parent_grid%u(:,:,:), & - Atm%neststruct%nest_domain, 0, 1) - call nested_grid_BC(Atm%parent_grid%v(:,:,:), & - Atm%neststruct%nest_domain, 1, 0) - endif - - - if (process) then -!!$#ifdef SW_DYNAMICS -!!$ !ps: first level only -!!$ !This is only valid for shallow-water simulations -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ -!!$ Atm%ps(i,j) = Atm%delp(i,j,1)/grav -!!$ -!!$ end do -!!$ end do -!!$#endif - call mpp_update_domains(Atm%u, Atm%v, Atm%domain, gridtype=DGRID_NE) - call mpp_update_domains(Atm%w, Atm%domain, complete=.true.) ! needs an update-domain for rayleigh damping - endif - - call mpp_sync_self() - - end subroutine setup_nested_boundary_halo subroutine fill_nested_grid_topo_halo(Atm, proc_in) type(fv_atmos_type), intent(INOUT) :: Atm logical, intent(IN), OPTIONAL :: proc_in - integer :: isg, ieg, jsg, jeg + integer :: isd, ied, jsd, jed if (.not. Atm%neststruct%nested) return - call mpp_get_global_domain( Atm%parent_grid%domain, & - isg, ieg, jsg, jeg) + call mpp_get_data_domain( Atm%parent_grid%domain, & + isd, ied, jsd, jed) + !This is 2D and doesn't need remapping if (is_master()) print*, ' FILLING NESTED GRID HALO WITH INTERPOLATED TERRAIN' - call nested_grid_BC(Atm%phis, Atm%parent_grid%phis, Atm%neststruct%nest_domain, & + call nested_grid_BC(Atm%phis, Atm%parent_grid%phis, global_nest_domain, & Atm%neststruct%ind_h, Atm%neststruct%wt_h, 0, 0, & - Atm%npx, Atm%npy, Atm%bd, isg, ieg, jsg, jeg, proc_in=proc_in) + Atm%npx, Atm%npy, Atm%bd, isd, ied, jsd, jed, proc_in=proc_in, nest_level=Atm%grid_number-1) end subroutine fill_nested_grid_topo_halo @@ -913,8 +840,10 @@ subroutine fill_nested_grid_topo(Atm, proc_in) if (is_master() .and. .not. Atm%flagstruct%external_ic ) print*, ' FILLING NESTED GRID INTERIOR WITH INTERPOLATED TERRAIN' - sending_proc = Atm%parent_grid%pelist(1) + (Atm%neststruct%parent_tile-1)*Atm%parent_grid%npes_per_tile - if (Atm%neststruct%parent_proc .and. Atm%neststruct%parent_tile == Atm%parent_grid%tile) then + sending_proc = (Atm%parent_grid%pelist(1)) + & + (Atm%neststruct%parent_tile-tile_fine(Atm%parent_grid%grid_number)+Atm%parent_grid%flagstruct%ntiles-1)*Atm%parent_grid%npes_per_tile + if (Atm%neststruct%parent_tile == Atm%parent_grid%global_tile) then + !if (Atm%neststruct%parent_proc .and. Atm%neststruct%parent_tile == Atm%parent_grid%global_tile) then call mpp_global_field( & Atm%parent_grid%domain, & Atm%parent_grid%phis(isd_p:ied_p,jsd_p:jed_p), g_dat(isg:,jsg:,1), position=CENTER) @@ -941,6 +870,9 @@ subroutine fill_nested_grid_topo(Atm, proc_in) end subroutine fill_nested_grid_topo + !This will still probably be needed for moving nests + !NOTE: this has NOT been maintained and so %global_tile is now meaningless if not referring to data on the current PE + ! needs to be re-coded to follow method in fill_nested_grid_Topo subroutine fill_nested_grid_data(Atm, proc_in) type(fv_atmos_type), intent(INOUT) :: Atm(:) !Only intended to be one element; needed for cubed_sphere_terrain @@ -956,6 +888,8 @@ subroutine fill_nested_grid_data(Atm, proc_in) integer :: p, sending_proc, gid, n logical process + call mpp_error(FATAL, " FILL_NESTED_GRID_DATA not yet updated for remap BCs") + if (present(proc_in)) then process = proc_in else @@ -1000,7 +934,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) !Call mpp_global_field on the procs that have the required data. !Then broadcast from the head PE to the receiving PEs - if (Atm(1)%neststruct%parent_proc .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (Atm(1)%neststruct%parent_proc .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%delp(isd_p:ied_p,jsd_p:jed_p,:), g_dat, position=CENTER) @@ -1026,7 +960,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) call timing_on('COMM_TOTAL') - if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%q(isd_p:ied_p,jsd_p:jed_p,:,nq), g_dat, position=CENTER) @@ -1058,7 +992,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) call timing_on('COMM_TOTAL') - if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%pt(isd_p:ied_p,jsd_p:jed_p,:), g_dat, position=CENTER) @@ -1093,7 +1027,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) call timing_on('COMM_TOTAL') - if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%pkz(isc_p:iec_p,jsc_p:jec_p,:), g_dat, position=CENTER) @@ -1203,7 +1137,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) !delz call timing_on('COMM_TOTAL') - if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%delz(isd_p:ied_p,jsd_p:jed_p,:), g_dat, position=CENTER) @@ -1228,7 +1162,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) call timing_on('COMM_TOTAL') - if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%w(isd_p:ied_p,jsd_p:jed_p,:), g_dat, position=CENTER) @@ -1262,7 +1196,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) call timing_on('COMM_TOTAL') - if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%u(isd_p:ied_p,jsd_p:jed_p+1,:), g_dat, position=NORTH) @@ -1292,7 +1226,7 @@ subroutine fill_nested_grid_data(Atm, proc_in) call timing_on('COMM_TOTAL') - if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%tile) then + if (ANY(Atm(1)%parent_grid%pelist == gid) .and. Atm(1)%neststruct%parent_tile == Atm(1)%parent_grid%global_tile) then call mpp_global_field( & Atm(1)%parent_grid%domain, & Atm(1)%parent_grid%v(isd_p:ied_p+1,jsd_p:jed_p,:), g_dat, position=EAST) @@ -1317,9 +1251,9 @@ subroutine fill_nested_grid_data(Atm, proc_in) end subroutine fill_nested_grid_data - !>@brief The subroutine ' fill_nested_grid_data_end' + !>@brief The subroutine ' twoway_topo_update' !! actually sets up the coarse-grid TOPOGRAPHY. - subroutine fill_nested_grid_data_end(Atm, proc_in) + subroutine twoway_topo_update(Atm, proc_in) type(fv_atmos_type), intent(INOUT) :: Atm logical, intent(IN), OPTIONAL :: proc_in real, allocatable :: g_dat(:,:,:), pt_coarse(:,:,:) @@ -1347,15 +1281,15 @@ subroutine fill_nested_grid_data_end(Atm, proc_in) isc = Atm%bd%isc; iec = Atm%bd%iec; jsc = Atm%bd%jsc; jec = Atm%bd%jec npz = Atm%npz - isd_p = Atm%parent_grid%bd%isd - ied_p = Atm%parent_grid%bd%ied - jsd_p = Atm%parent_grid%bd%jsd - jed_p = Atm%parent_grid%bd%jed - isc_p = Atm%parent_grid%bd%isc - iec_p = Atm%parent_grid%bd%iec - jsc_p = Atm%parent_grid%bd%jsc - jec_p = Atm%parent_grid%bd%jec - sending_proc = Atm%parent_grid%pelist(1) + (Atm%neststruct%parent_tile-1)*Atm%parent_grid%npes_per_tile + isd_p = Atm%parent_grid%bd%isd + ied_p = Atm%parent_grid%bd%ied + jsd_p = Atm%parent_grid%bd%jsd + jed_p = Atm%parent_grid%bd%jed + isc_p = Atm%parent_grid%bd%isc + iec_p = Atm%parent_grid%bd%iec + jsc_p = Atm%parent_grid%bd%jsc + jec_p = Atm%parent_grid%bd%jec + sending_proc = Atm%parent_grid%pelist(1) + (Atm%neststruct%parent_tile-1)*Atm%parent_grid%npes_per_tile call mpp_get_global_domain( Atm%parent_grid%domain, & isg, ieg, jsg, jeg, xsize=npx_p, ysize=npy_p) @@ -1367,14 +1301,13 @@ subroutine fill_nested_grid_data_end(Atm, proc_in) if (Atm%neststruct%twowaynest) then if (ANY(Atm%parent_grid%pelist == mpp_pe()) .or. Atm%neststruct%child_proc) then call update_coarse_grid(Atm%parent_grid%phis, & - Atm%phis, Atm%neststruct%nest_domain, & - Atm%neststruct%ind_update_h(isd_p:ied_p+1,jsd_p:jed_p+1,:), & + Atm%phis, global_nest_domain, & Atm%gridstruct%dx, Atm%gridstruct%dy, Atm%gridstruct%area, & - isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & + Atm%bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & Atm%neststruct%isu, Atm%neststruct%ieu, Atm%neststruct%jsu, Atm%neststruct%jeu, & Atm%npx, Atm%npy, 0, 0, & Atm%neststruct%refinement, Atm%neststruct%nestupdate, 0, 0, & - Atm%neststruct%parent_proc, Atm%neststruct%child_proc, Atm%parent_grid) + Atm%neststruct%parent_proc, Atm%neststruct%child_proc, Atm%parent_grid, Atm%grid_number-1) Atm%parent_grid%neststruct%parent_of_twoway = .true. !NOTE: mpp_update_nest_coarse (and by extension, update_coarse_grid) does **NOT** pass data !allowing a two-way update into the halo of the coarse grid. It only passes data so that the INTERIOR @@ -1386,8 +1319,6 @@ subroutine fill_nested_grid_data_end(Atm, proc_in) end if - - #ifdef SW_DYNAMICS !!$ !ps: first level only !!$ !This is only valid for shallow-water simulations @@ -1401,45 +1332,41 @@ subroutine fill_nested_grid_data_end(Atm, proc_in) !!$ end do !!$ endif #else - !Sets up flow to be initially hydrostatic (shouldn't be the case for all ICs?) + !Reset p_var after updating topography if (process) call p_var(npz, isc, iec, jsc, jec, Atm%ptop, ptop_min, Atm%delp, & Atm%delz, Atm%pt, Atm%ps, & Atm%pe, Atm%peln, Atm%pk, Atm%pkz, kappa, Atm%q, & Atm%ng, ncnst, Atm%gridstruct%area_64, Atm%flagstruct%dry_mass, .false., Atm%flagstruct%mountain, & - Atm%flagstruct%moist_phys, .true., Atm%flagstruct%nwat, Atm%domain) + Atm%flagstruct%moist_phys, .true., Atm%flagstruct%nwat, Atm%domain, Atm%flagstruct%adiabatic) #endif - end subroutine fill_nested_grid_data_end + end subroutine twoway_topo_update !>@brief The subroutine 'fv_write_restart' writes restart files to disk. !>@details This subroutine may be called during an integration to write out !! intermediate restart files. - subroutine fv_write_restart(Atm, grids_on_this_pe, timestamp) - type(fv_atmos_type), intent(inout) :: Atm(:) + subroutine fv_write_restart(Atm, timestamp) + type(fv_atmos_type), intent(inout) :: Atm character(len=*), intent(in) :: timestamp - logical, intent(IN) :: grids_on_this_pe(:) - integer n - call fv_io_write_restart(Atm, grids_on_this_pe, timestamp) - do n=1,size(Atm) - if (Atm(n)%neststruct%nested .and. grids_on_this_pe(n)) then - call fv_io_write_BCs(Atm(n)) - endif - enddo + call fv_io_write_restart(Atm, timestamp) + if (Atm%neststruct%nested) then + call fv_io_write_BCs(Atm) + endif end subroutine fv_write_restart !>@brief The subroutine 'fv_restart_end' writes ending restart files, !! terminates I/O, and prints out diagnostics including global totals !! and checksums. - subroutine fv_restart_end(Atm, grids_on_this_pe) - type(fv_atmos_type), intent(inout) :: Atm(:) - logical, intent(INOUT) :: grids_on_this_pe(:) + subroutine fv_restart_end(Atm, restart_endfcst) + type(fv_atmos_type), intent(inout) :: Atm + logical, intent(in) :: restart_endfcst integer :: isc, iec, jsc, jec - integer :: iq, n, ntileMe, ncnst, ntprog, ntdiag + integer :: iq, ncnst, ntprog, ntdiag integer :: isd, ied, jsd, jed, npz integer :: unit integer :: file_unit @@ -1447,514 +1374,93 @@ subroutine fv_restart_end(Atm, grids_on_this_pe) character(len=128):: tracer_name character(len=3):: gn + call mpp_set_current_pelist(Atm%pelist) - ntileMe = size(Atm(:)) - - do n = 1, ntileMe - - if (.not. grids_on_this_pe(n)) then - cycle - endif - - call mpp_set_current_pelist(Atm(n)%pelist) - - isc = Atm(n)%bd%isc; iec = Atm(n)%bd%iec; jsc = Atm(n)%bd%jsc; jec = Atm(n)%bd%jec + isc = Atm%bd%isc; iec = Atm%bd%iec; jsc = Atm%bd%jsc; jec = Atm%bd%jec - isd = Atm(n)%bd%isd - ied = Atm(n)%bd%ied - jsd = Atm(n)%bd%jsd - jed = Atm(n)%bd%jed - npz = Atm(n)%npz - ncnst = Atm(n)%ncnst - ntprog = size(Atm(n)%q,4) - ntdiag = size(Atm(n)%qdiag,4) + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + npz = Atm%npz + ncnst = Atm%ncnst + ntprog = size(Atm%q,4) + ntdiag = size(Atm%qdiag,4) - if (Atm(n)%grid_number > 1) then - write(gn,'(A2, I1)') " g", Atm(n)%grid_number - else - gn = '' - end if + if (Atm%grid_number > 1) then + write(gn,'(A2, I1)') " g", Atm%grid_number + else + gn = '' + end if - unit = stdout() - write(unit,*) - write(unit,*) 'fv_restart_end u ', trim(gn),' = ', mpp_chksum(Atm(n)%u(isc:iec,jsc:jec,:)) - write(unit,*) 'fv_restart_end v ', trim(gn),' = ', mpp_chksum(Atm(n)%v(isc:iec,jsc:jec,:)) - if ( .not. Atm(n)%flagstruct%hydrostatic ) & - write(unit,*) 'fv_restart_end w ', trim(gn),' = ', mpp_chksum(Atm(n)%w(isc:iec,jsc:jec,:)) - write(unit,*) 'fv_restart_end delp', trim(gn),' = ', mpp_chksum(Atm(n)%delp(isc:iec,jsc:jec,:)) - write(unit,*) 'fv_restart_end phis', trim(gn),' = ', mpp_chksum(Atm(n)%phis(isc:iec,jsc:jec)) + unit = stdout() + write(unit,*) + write(unit,*) 'fv_restart_end u ', trim(gn),' = ', mpp_chksum(Atm%u(isc:iec,jsc:jec,:)) + write(unit,*) 'fv_restart_end v ', trim(gn),' = ', mpp_chksum(Atm%v(isc:iec,jsc:jec,:)) + if ( .not. Atm%flagstruct%hydrostatic ) & + write(unit,*) 'fv_restart_end w ', trim(gn),' = ', mpp_chksum(Atm%w(isc:iec,jsc:jec,:)) + write(unit,*) 'fv_restart_end delp', trim(gn),' = ', mpp_chksum(Atm%delp(isc:iec,jsc:jec,:)) + write(unit,*) 'fv_restart_end phis', trim(gn),' = ', mpp_chksum(Atm%phis(isc:iec,jsc:jec)) #ifndef SW_DYNAMICS - write(unit,*) 'fv_restart_end pt ', trim(gn),' = ', mpp_chksum(Atm(n)%pt(isc:iec,jsc:jec,:)) - if (ntprog>0) & - write(unit,*) 'fv_restart_end q(prog) nq ', trim(gn),' =',ntprog, mpp_chksum(Atm(n)%q(isc:iec,jsc:jec,:,:)) - if (ntdiag>0) & - write(unit,*) 'fv_restart_end q(diag) nq ', trim(gn),' =',ntdiag, mpp_chksum(Atm(n)%qdiag(isc:iec,jsc:jec,:,:)) - do iq=1,min(17, ntprog) ! Check up to 17 tracers - call get_tracer_names(MODEL_ATMOS, iq, tracer_name) - write(unit,*) 'fv_restart_end '//trim(tracer_name)// trim(gn),' = ', mpp_chksum(Atm(n)%q(isc:iec,jsc:jec,:,iq)) - enddo + write(unit,*) 'fv_restart_end pt ', trim(gn),' = ', mpp_chksum(Atm%pt(isc:iec,jsc:jec,:)) + if (ntprog>0) & + write(unit,*) 'fv_restart_end q(prog) nq ', trim(gn),' =',ntprog, mpp_chksum(Atm%q(isc:iec,jsc:jec,:,:)) + if (ntdiag>0) & + write(unit,*) 'fv_restart_end q(diag) nq ', trim(gn),' =',ntdiag, mpp_chksum(Atm%qdiag(isc:iec,jsc:jec,:,:)) + do iq=1,min(17, ntprog) ! Check up to 17 tracers + call get_tracer_names(MODEL_ATMOS, iq, tracer_name) + write(unit,*) 'fv_restart_end '//trim(tracer_name)// trim(gn),' = ', mpp_chksum(Atm%q(isc:iec,jsc:jec,:,iq)) + enddo -!--------------- -! Check Min/Max: -!--------------- -! call prt_maxmin('ZS', Atm(n)%phis, isc, iec, jsc, jec, Atm(n)%ng, 1, 1./grav) - call pmaxmn_g('ZS', Atm(n)%phis, isc, iec, jsc, jec, 1, 1./grav, Atm(n)%gridstruct%area_64, Atm(n)%domain) - call pmaxmn_g('PS ', Atm(n)%ps, isc, iec, jsc, jec, 1, 0.01 , Atm(n)%gridstruct%area_64, Atm(n)%domain) - call prt_maxmin('PS*', Atm(n)%ps, isc, iec, jsc, jec, Atm(n)%ng, 1, 0.01) - call prt_maxmin('U ', Atm(n)%u(isd:ied,jsd:jed,1:npz), isc, iec, jsc, jec, Atm(n)%ng, npz, 1.) - call prt_maxmin('V ', Atm(n)%v(isd:ied,jsd:jed,1:npz), isc, iec, jsc, jec, Atm(n)%ng, npz, 1.) - if ( .not. Atm(n)%flagstruct%hydrostatic ) & - call prt_maxmin('W ', Atm(n)%w , isc, iec, jsc, jec, Atm(n)%ng, npz, 1.) - call prt_maxmin('T ', Atm(n)%pt, isc, iec, jsc, jec, Atm(n)%ng, npz, 1.) - do iq=1, ntprog - call get_tracer_names ( MODEL_ATMOS, iq, tracer_name ) - call pmaxmn_g(trim(tracer_name), Atm(n)%q(isd:ied,jsd:jed,1:npz,iq:iq), isc, iec, jsc, jec, npz, & - 1., Atm(n)%gridstruct%area_64, Atm(n)%domain) - enddo -! Write4 energy correction term + !--------------- + ! Check Min/Max: + !--------------- + ! call prt_maxmin('ZS', Atm%phis, isc, iec, jsc, jec, Atm%ng, 1, 1./grav) + call pmaxmn_g('ZS', Atm%phis, isc, iec, jsc, jec, 1, 1./grav, Atm%gridstruct%area_64, Atm%domain) + call pmaxmn_g('PS ', Atm%ps, isc, iec, jsc, jec, 1, 0.01 , Atm%gridstruct%area_64, Atm%domain) + call prt_maxmin('PS*', Atm%ps, isc, iec, jsc, jec, Atm%ng, 1, 0.01) + call prt_maxmin('U ', Atm%u(isd:ied,jsd:jed,1:npz), isc, iec, jsc, jec, Atm%ng, npz, 1.) + call prt_maxmin('V ', Atm%v(isd:ied,jsd:jed,1:npz), isc, iec, jsc, jec, Atm%ng, npz, 1.) + if ( .not. Atm%flagstruct%hydrostatic ) & + call prt_maxmin('W ', Atm%w , isc, iec, jsc, jec, Atm%ng, npz, 1.) + call prt_maxmin('T ', Atm%pt, isc, iec, jsc, jec, Atm%ng, npz, 1.) + do iq=1, ntprog + call get_tracer_names ( MODEL_ATMOS, iq, tracer_name ) + call pmaxmn_g(trim(tracer_name), Atm%q(isd:ied,jsd:jed,1:npz,iq:iq), isc, iec, jsc, jec, npz, & + 1., Atm%gridstruct%area_64, Atm%domain) + enddo + ! Write4 energy correction term #endif - enddo - - call fv_io_write_restart(Atm, grids_on_this_pe) - do n=1,ntileMe - if (Atm(n)%neststruct%nested .and. grids_on_this_pe(n)) call fv_io_write_BCs(Atm(n)) - end do + if ( restart_endfcst ) then + call fv_io_write_restart(Atm) + if (Atm%neststruct%nested) call fv_io_write_BCs(Atm) + endif + if(Atm%flagstruct%write_restart_with_bcs)then + call write_full_fields(Atm) + endif - module_is_initialized = .FALSE. + module_is_initialized = .FALSE. #ifdef EFLUX_OUT - if( is_master() ) then - write(*,*) steps, 'Mean equivalent Heat flux for this integration period=',Atm(1)%idiag%efx_sum/real(max(1,Atm(1)%idiag%steps)), & - 'Mean nesting-related flux for this integration period=',Atm(1)%idiag%efx_sum_nest/real(max(1,Atm(1)%idiag%steps)), & - 'Mean mountain torque=',Atm(1)%idiag%mtq_sum/real(max(1,Atm(1)%idiag%steps)) - file_unit = get_unit() - open (unit=file_unit, file='e_flux.data', form='unformatted',status='unknown', access='sequential') - do n=1,steps - write(file_unit) Atm(1)%idiag%efx(n) - write(file_unit) Atm(1)%idiag%mtq(n) ! time series global mountain torque - !write(file_unit) Atm(1)%idiag%efx_nest(n) - enddo - close(unit=file_unit) - endif + if( is_master() ) then + write(*,*) steps, 'Mean equivalent Heat flux for this integration period=',Atm(1)%idiag%efx_sum/real(max(1,Atm(1)%idiag%steps)), & + 'Mean nesting-related flux for this integration period=',Atm(1)%idiag%efx_sum_nest/real(max(1,Atm(1)%idiag%steps)), & + 'Mean mountain torque=',Atm(1)%idiag%mtq_sum/real(max(1,Atm(1)%idiag%steps)) + file_unit = get_unit() + open (unit=file_unit, file='e_flux.data', form='unformatted',status='unknown', access='sequential') + do n=1,steps + write(file_unit) Atm(1)%idiag%efx(n) + write(file_unit) Atm(1)%idiag%mtq(n) ! time series global mountain torque + !write(file_unit) Atm(1)%idiag%efx_nest(n) + enddo + close(unit=file_unit) + endif #endif end subroutine fv_restart_end - subroutine d2c_setup(u, v, & - ua, va, & - uc, vc, dord4, & - isd,ied,jsd,jed, is,ie,js,je, npx,npy, & - grid_type, nested, & - se_corner, sw_corner, ne_corner, nw_corner, & - rsin_u,rsin_v,cosa_s,rsin2,regional ) - - logical, intent(in):: dord4 - real, intent(in) :: u(isd:ied,jsd:jed+1) - real, intent(in) :: v(isd:ied+1,jsd:jed) - real, intent(out), dimension(isd:ied ,jsd:jed ):: ua - real, intent(out), dimension(isd:ied ,jsd:jed ):: va - real, intent(out), dimension(isd:ied+1,jsd:jed ):: uc - real, intent(out), dimension(isd:ied ,jsd:jed+1):: vc - integer, intent(in) :: isd,ied,jsd,jed, is,ie,js,je, npx,npy,grid_type - logical, intent(in) :: nested, se_corner, sw_corner, ne_corner, nw_corner, regional - real, intent(in) :: rsin_u(isd:ied+1,jsd:jed) - real, intent(in) :: rsin_v(isd:ied,jsd:jed+1) - real, intent(in) :: cosa_s(isd:ied,jsd:jed) - real, intent(in) :: rsin2(isd:ied,jsd:jed) - -! Local - real, dimension(isd:ied,jsd:jed):: utmp, vtmp - real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28. - real, parameter:: a1 = 0.5625 - real, parameter:: a2 = -0.0625 - real, parameter:: c1 = -2./14. - real, parameter:: c2 = 11./14. - real, parameter:: c3 = 5./14. - integer npt, i, j, ifirst, ilast, id - - if ( dord4) then - id = 1 - else - id = 0 - endif - - - if (grid_type < 3 .and. .not. (nested .or. regional)) then - npt = 4 - else - npt = -2 - endif - - if ( nested) then - - do j=jsd+1,jed-1 - do i=isd,ied - utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) - enddo - enddo - do i=isd,ied - j = jsd - utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) - j = jed - utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) - end do - - do j=jsd,jed - do i=isd+1,ied-1 - vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) - enddo - i = isd - vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) - i = ied - vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) - enddo - - do j=jsd,jed - do i=isd,ied - ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - enddo - enddo - - else - - !---------- - ! Interior: - !---------- - utmp = 0. - vtmp = 0. - - - do j=max(npt,js-1),min(npy-npt,je+1) - do i=max(npt,isd),min(npx-npt,ied) - utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) - enddo - enddo - do j=max(npt,jsd),min(npy-npt,jed) - do i=max(npt,is-1),min(npx-npt,ie+1) - vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) - enddo - enddo - - !---------- - ! edges: - !---------- - if (grid_type < 3) then - - if ( js==1 .or. jsd=(npy-npt)) then - do j=npy-npt+1,jed - do i=isd,ied - utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) - vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) - enddo - enddo - endif - - if ( is==1 .or. isd=(npx-npt)) then - do j=max(npt,jsd),min(npy-npt,jed) - do i=npx-npt+1,ied - utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) - vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) - enddo - enddo - endif - - endif - do j=js-1-id,je+1+id - do i=is-1-id,ie+1+id - ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - enddo - enddo - - end if - -! A -> C -!-------------- -! Fix the edges -!-------------- -! Xdir: - if( sw_corner ) then - do i=-2,0 - utmp(i,0) = -vtmp(0,1-i) - enddo - endif - if( se_corner ) then - do i=0,2 - utmp(npx+i,0) = vtmp(npx,i+1) - enddo - endif - if( ne_corner ) then - do i=0,2 - utmp(npx+i,npy) = -vtmp(npx,je-i) - enddo - endif - if( nw_corner ) then - do i=-2,0 - utmp(i,npy) = vtmp(0,je+i) - enddo - endif - - if (grid_type < 3 .and. .not. (nested .or. regional)) then - ifirst = max(3, is-1) - ilast = min(npx-2,ie+2) - else - ifirst = is-1 - ilast = ie+2 - endif -!--------------------------------------------- -! 4th order interpolation for interior points: -!--------------------------------------------- - do j=js-1,je+1 - do i=ifirst,ilast - uc(i,j) = a1*(utmp(i-1,j)+utmp(i,j))+a2*(utmp(i-2,j)+utmp(i+1,j)) - enddo - enddo - - if (grid_type < 3) then -! Xdir: - if( is==1 .and. .not. (nested .or. regional) ) then - do j=js-1,je+1 - uc(0,j) = c1*utmp(-2,j) + c2*utmp(-1,j) + c3*utmp(0,j) - uc(1,j) = ( t14*(utmp( 0,j)+utmp(1,j)) & - + t12*(utmp(-1,j)+utmp(2,j)) & - + t15*(utmp(-2,j)+utmp(3,j)) )*rsin_u(1,j) - uc(2,j) = c1*utmp(3,j) + c2*utmp(2,j) + c3*utmp(1,j) - enddo - endif - - if( (ie+1)==npx .and. .not. (nested .or. regional) ) then - do j=js-1,je+1 - uc(npx-1,j) = c1*utmp(npx-3,j)+c2*utmp(npx-2,j)+c3*utmp(npx-1,j) - uc(npx,j) = (t14*(utmp(npx-1,j)+utmp(npx,j))+ & - t12*(utmp(npx-2,j)+utmp(npx+1,j)) & - + t15*(utmp(npx-3,j)+utmp(npx+2,j)))*rsin_u(npx,j) - uc(npx+1,j) = c3*utmp(npx,j)+c2*utmp(npx+1,j)+c1*utmp(npx+2,j) - enddo - endif - - endif - -!------ -! Ydir: -!------ - if( sw_corner ) then - do j=-2,0 - vtmp(0,j) = -utmp(1-j,0) - enddo - endif - if( nw_corner ) then - do j=0,2 - vtmp(0,npy+j) = utmp(j+1,npy) - enddo - endif - if( se_corner ) then - do j=-2,0 - vtmp(npx,j) = utmp(ie+j,0) - enddo - endif - if( ne_corner ) then - do j=0,2 - vtmp(npx,npy+j) = -utmp(ie-j,npy) - enddo - endif - - if (grid_type < 3) then - - do j=js-1,je+2 - if ( j==1 .and. .not. (nested .or. regional)) then - do i=is-1,ie+1 - vc(i,1) = (t14*(vtmp(i, 0)+vtmp(i,1)) & - + t12*(vtmp(i,-1)+vtmp(i,2)) & - + t15*(vtmp(i,-2)+vtmp(i,3)))*rsin_v(i,1) - enddo - elseif ( (j==0 .or. j==(npy-1)) .and. .not. (nested .or. regional)) then - do i=is-1,ie+1 - vc(i,j) = c1*vtmp(i,j-2) + c2*vtmp(i,j-1) + c3*vtmp(i,j) - enddo - elseif ( (j==2 .or. j==(npy+1)) .and. .not. (nested .or. regional)) then - do i=is-1,ie+1 - vc(i,j) = c1*vtmp(i,j+1) + c2*vtmp(i,j) + c3*vtmp(i,j-1) - enddo - elseif ( j==npy .and. .not. (nested .or. regional)) then - do i=is-1,ie+1 - vc(i,npy) = (t14*(vtmp(i,npy-1)+vtmp(i,npy)) & - + t12*(vtmp(i,npy-2)+vtmp(i,npy+1)) & - + t15*(vtmp(i,npy-3)+vtmp(i,npy+2)))*rsin_v(i,npy) - enddo - else -! 4th order interpolation for interior points: - do i=is-1,ie+1 - vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j)) - enddo - endif - enddo - else -! 4th order interpolation: - do j=js-1,je+2 - do i=is-1,ie+1 - vc(i,j) = a2*(vtmp(i,j-2)+vtmp(i,j+1))+a1*(vtmp(i,j-1)+vtmp(i,j)) - enddo - enddo - endif - - end subroutine d2c_setup - - subroutine d2a_setup(u, v, ua, va, dord4, & - isd,ied,jsd,jed, is,ie,js,je, npx,npy, & - grid_type, nested, & - cosa_s,rsin2,regional ) - - logical, intent(in):: dord4 - real, intent(in) :: u(isd:ied,jsd:jed+1) - real, intent(in) :: v(isd:ied+1,jsd:jed) - real, intent(out), dimension(isd:ied ,jsd:jed ):: ua - real, intent(out), dimension(isd:ied ,jsd:jed ):: va - integer, intent(in) :: isd,ied,jsd,jed, is,ie,js,je, npx,npy,grid_type - real, intent(in) :: cosa_s(isd:ied,jsd:jed) - real, intent(in) :: rsin2(isd:ied,jsd:jed) - logical, intent(in) :: nested, regional - -! Local - real, dimension(isd:ied,jsd:jed):: utmp, vtmp - real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28. - real, parameter:: a1 = 0.5625 - real, parameter:: a2 = -0.0625 - real, parameter:: c1 = -2./14. - real, parameter:: c2 = 11./14. - real, parameter:: c3 = 5./14. - integer npt, i, j, ifirst, ilast, id - - if ( dord4) then - id = 1 - else - id = 0 - endif - - - if (grid_type < 3 .and. .not. (nested .or. regional)) then - npt = 4 - else - npt = -2 - endif - - if ( nested) then - - do j=jsd+1,jed-1 - do i=isd,ied - utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) - enddo - enddo - do i=isd,ied - j = jsd - utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) - j = jed - utmp(i,j) = 0.5*(u(i,j)+u(i,j+1)) - end do - - do j=jsd,jed - do i=isd+1,ied-1 - vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) - enddo - i = isd - vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) - i = ied - vtmp(i,j) = 0.5*(v(i,j)+v(i+1,j)) - enddo - - else - - !---------- - ! Interior: - !---------- - - do j=max(npt,js-1),min(npy-npt,je+1) - do i=max(npt,isd),min(npx-npt,ied) - utmp(i,j) = a2*(u(i,j-1)+u(i,j+2)) + a1*(u(i,j)+u(i,j+1)) - enddo - enddo - do j=max(npt,jsd),min(npy-npt,jed) - do i=max(npt,is-1),min(npx-npt,ie+1) - vtmp(i,j) = a2*(v(i-1,j)+v(i+2,j)) + a1*(v(i,j)+v(i+1,j)) - enddo - enddo - - !---------- - ! edges: - !---------- - if (grid_type < 3) then - - if ( js==1 .or. jsd=(npy-npt)) then - do j=npy-npt+1,jed - do i=isd,ied - utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) - vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) - enddo - enddo - endif - - if ( is==1 .or. isd=(npx-npt)) then - do j=max(npt,jsd),min(npy-npt,jed) - do i=npx-npt+1,ied - utmp(i,j) = 0.5*(u(i,j) + u(i,j+1)) - vtmp(i,j) = 0.5*(v(i,j) + v(i+1,j)) - enddo - enddo - endif - - endif - - end if - - - - do j=js-1-id,je+1+id - do i=is-1-id,ie+1+id - ua(i,j) = (utmp(i,j)-vtmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - va(i,j) = (vtmp(i,j)-utmp(i,j)*cosa_s(i,j)) * rsin2(i,j) - enddo - enddo - -end subroutine d2a_setup -!>@brief The subroutine 'pmaxn_g' writes domain max, min, and averages quantities. subroutine pmaxmn_g(qname, q, is, ie, js, je, km, fac, area, domain) character(len=*), intent(in):: qname integer, intent(in):: is, ie, js, je @@ -1973,7 +1479,10 @@ subroutine pmaxmn_g(qname, q, is, ie, js, je, km, fac, area, domain) do k=1,km do j=js,je do i=is,ie - if( q(i,j,k) < qmin ) then + !if ( (q(i,j,k) >= 1e30) .eqv. (q(i,j,k) < 1e30) ) then !NAN checking + ! print*, ' NAN found for ', qname, mpp_pe(), i,j,k + !else + if( q(i,j,k) < qmin) then qmin = q(i,j,k) elseif( q(i,j,k) > qmax ) then qmax = q(i,j,k) diff --git a/tools/fv_surf_map.F90 b/tools/fv_surf_map.F90 index 8a4105b0e..2d308246b 100644 --- a/tools/fv_surf_map.F90 +++ b/tools/fv_surf_map.F90 @@ -72,7 +72,6 @@ module fv_surf_map_mod use fv_grid_utils_mod, only: great_circle_dist, latlon2xyz, v_prod, normalize_vect use fv_grid_utils_mod, only: g_sum, global_mx, vect_cross - use fv_mp_mod, only: ng use fv_mp_mod, only: mp_stop, mp_reduce_min, mp_reduce_max, is_master use fv_timing_mod, only: timing_on, timing_off use fv_arrays_mod, only: fv_grid_bounds_type, R_GRID @@ -131,7 +130,7 @@ module fv_surf_map_mod contains subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_sg, phis, & - stretch_fac, nested, npx_global, domain,grid_number, bd, regional) + stretch_fac, nested, bounded_domain, npx_global, domain,grid_number, bd) implicit none #include @@ -139,24 +138,24 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ ! INPUT arrays type(fv_grid_bounds_type), intent(IN) :: bd - real(kind=R_GRID), intent(in)::area(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng) - real, intent(in):: dx(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng+1) - real, intent(in):: dy(bd%is-ng:bd%ie+ng+1, bd%js-ng:bd%je+ng) - real, intent(in), dimension(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng)::dxa, dya - real, intent(in)::dxc(bd%is-ng:bd%ie+ng+1, bd%js-ng:bd%je+ng) - real, intent(in)::dyc(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng+1) - - real(kind=R_GRID), intent(in):: grid(bd%is-ng:bd%ie+ng+1, bd%js-ng:bd%je+ng+1,2) - real(kind=R_GRID), intent(in):: agrid(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng,2) + real(kind=R_GRID), intent(in)::area(bd%isd:bd%ied, bd%jsd:bd%jed) + real, intent(in):: dx(bd%isd:bd%ied, bd%jsd:bd%jed+1) + real, intent(in):: dy(bd%isd:bd%ied+1, bd%jsd:bd%jed) + real, intent(in), dimension(bd%isd:bd%ied, bd%jsd:bd%jed)::dxa, dya + real, intent(in)::dxc(bd%isd:bd%ied+1, bd%jsd:bd%jed) + real, intent(in)::dyc(bd%isd:bd%ied, bd%jsd:bd%jed+1) + + real(kind=R_GRID), intent(in):: grid(bd%isd:bd%ied+1, bd%jsd:bd%jed+1,2) + real(kind=R_GRID), intent(in):: agrid(bd%isd:bd%ied, bd%jsd:bd%jed,2) real, intent(IN):: sin_sg(bd%isd:bd%ied,bd%jsd:bd%jed,9) real(kind=R_GRID), intent(IN):: stretch_fac - logical, intent(IN) :: nested, regional + logical, intent(IN) :: nested, bounded_domain integer, intent(IN) :: npx_global type(domain2d), intent(INOUT) :: domain integer, intent(IN) :: grid_number ! OUTPUT arrays - real, intent(out):: phis(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng) + real, intent(out):: phis(bd%isd:bd%ied, bd%jsd:bd%jed) ! Local: real, allocatable :: z2(:,:) ! Position of edges of the box containing the original data point: @@ -176,7 +175,7 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ integer status integer :: is, ie, js, je - integer :: isd, ied, jsd, jed + integer :: isd, ied, jsd, jed, ng real phis_coarse(bd%isd:bd%ied, bd%jsd:bd%jed) real wt @@ -188,6 +187,7 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ ied = bd%ied jsd = bd%jsd jed = bd%jed + ng = bd%ng if (nested) then !Divide all by grav rgrav = 1./grav @@ -375,7 +375,7 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ allocate ( sgh_g(isd:ied, jsd:jed) ) call timing_on('map_to_cubed') call map_to_cubed_raw(igh, nlon, jt, lat1(jstart:jend+1), lon1, zs, ft, grid, agrid, & - phis, oro_g, sgh_g, npx, npy, jstart, jend, stretch_fac, nested, npx_global, bd, regional) + phis, oro_g, sgh_g, npx, npy, jstart, jend, stretch_fac, bounded_domain, npx_global, bd) if (is_master()) write(*,*) 'map_to_cubed_raw: master PE done' call timing_off('map_to_cubed') @@ -435,8 +435,8 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ write(*,*) 'Applying terrain filters. zero_ocean is', zero_ocean endif call FV3_zs_filter (bd, isd, ied, jsd, jed, npx, npy, npx_global, & - stretch_fac, nested, domain, area, dxa, dya, dx, dy, dxc, dyc, grid, & - agrid, sin_sg, phis, oro_g, regional) + stretch_fac, bounded_domain, domain, area, dxa, dya, dx, dy, dxc, dyc, grid, & + agrid, sin_sg, phis, oro_g) call mpp_update_domains(phis, domain) endif ! end terrain filter call timing_off('Terrain_filter') @@ -496,7 +496,7 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ !----------------------------------------------- call global_mx(area, ng, da_min, da_max, bd) - if(zs_filter) call del4_cubed_sphere(npx, npy, sgh_g, area, dx, dy, dxc, dyc, sin_sg, 1, zero_ocean, oro_g, nested, domain, bd, regional) + if(zs_filter) call del4_cubed_sphere(npx, npy, sgh_g, area, dx, dy, dxc, dyc, sin_sg, 1, zero_ocean, oro_g, bounded_domain, domain, bd) call global_mx(real(sgh_g,kind=R_GRID), ng, da_min, da_max, bd) if ( is_master() ) write(*,*) 'After filter SGH', trim(grid_string), ' min=', da_min, ' Max=', da_max @@ -509,8 +509,8 @@ subroutine surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_ end subroutine surfdrv subroutine FV3_zs_filter (bd, isd, ied, jsd, jed, npx, npy, npx_global, & - stretch_fac, nested, domain, area, dxa, dya, dx, dy, dxc, dyc, grid, & - agrid, sin_sg, phis, oro ,regional) + stretch_fac, bounded_domain, domain, area, dxa, dya, dx, dy, dxc, dyc, grid, & + agrid, sin_sg, phis, oro ) integer, intent(in):: isd, ied, jsd, jed, npx, npy, npx_global type(fv_grid_bounds_type), intent(IN) :: bd real(kind=R_GRID), intent(in), dimension(isd:ied,jsd:jed)::area @@ -522,7 +522,7 @@ subroutine FV3_zs_filter (bd, isd, ied, jsd, jed, npx, npy, npx_global, & real(kind=R_GRID), intent(in):: agrid(isd:ied, jsd:jed, 2) real, intent(IN):: sin_sg(isd:ied,jsd:jed,9) real(kind=R_GRID), intent(IN):: stretch_fac - logical, intent(IN) :: nested, regional + logical, intent(IN) :: bounded_domain real, intent(inout):: phis(isd:ied,jsd,jed) real, intent(inout):: oro(isd:ied,jsd,jed) type(domain2d), intent(INOUT) :: domain @@ -532,12 +532,12 @@ subroutine FV3_zs_filter (bd, isd, ied, jsd, jed, npx, npy, npx_global, & if (is_master()) print*, ' Calling FV3_zs_filter...' if (.not. namelist_read) call read_namelist !when calling from external_ic - call global_mx(area, ng, da_min, da_max, bd) + call global_mx(area, bd%ng, da_min, da_max, bd) mdim = nint( real(npx_global) * min(10., stretch_fac) ) ! Del-2: high resolution only -! call del2_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, sin_sg, n_del2, cd2, zero_ocean, oro, nested, domain, bd) +! call del2_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, sin_sg, n_del2, cd2, zero_ocean, oro, bounded_domain, domain, bd) if (n_del2_strong < 0) then if ( npx_global<=97) then n_del2_strong = 0 @@ -551,7 +551,7 @@ subroutine FV3_zs_filter (bd, isd, ied, jsd, jed, npx, npy, npx_global, & ! Applying strong 2-delta-filter: if ( n_del2_strong > 0 ) & call two_delta_filter(npx, npy, phis, area, dx, dy, dxa, dya, dxc, dyc, sin_sg, cd2, zero_ocean, & - .true., 0, oro, nested, domain, bd, n_del2_strong, regional) + .true., 0, oro, bounded_domain, domain, bd, n_del2_strong) ! MFCT Del-4: if (n_del4 < 0) then @@ -563,18 +563,18 @@ subroutine FV3_zs_filter (bd, isd, ied, jsd, jed, npx, npy, npx_global, & n_del4 = 3 endif endif - call del4_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, sin_sg, n_del4, zero_ocean, oro, nested, domain, bd, regional) + call del4_cubed_sphere(npx, npy, phis, area, dx, dy, dxc, dyc, sin_sg, n_del4, zero_ocean, oro, bounded_domain, domain, bd) ! Applying weak 2-delta-filter: cd2 = 0.12*da_min call two_delta_filter(npx, npy, phis, area, dx, dy, dxa, dya, dxc, dyc, sin_sg, cd2, zero_ocean, & - .true., 1, oro, nested, domain, bd, n_del2_weak, regional) + .true., 1, oro, bounded_domain, domain, bd, n_del2_weak) end subroutine FV3_zs_filter subroutine two_delta_filter(npx, npy, q, area, dx, dy, dxa, dya, dxc, dyc, sin_sg, cd, zero_ocean, & - check_slope, filter_type, oro, nested, domain, bd, ntmax, regional) + check_slope, filter_type, oro, bounded_domain, domain, bd, ntmax) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(in):: npx, npy integer, intent(in):: ntmax @@ -591,7 +591,7 @@ subroutine two_delta_filter(npx, npy, q, area, dx, dy, dxa, dya, dxc, dyc, sin_s real, intent(in):: sin_sg(bd%isd:bd%ied,bd%jsd:bd%jed,9) real, intent(in):: oro(bd%isd:bd%ied, bd%jsd:bd%jed) !< 0==water, 1==land logical, intent(in):: zero_ocean, check_slope - logical, intent(in):: nested, regional + logical, intent(in):: bounded_domain type(domain2d), intent(inout) :: domain ! OUTPUT arrays real, intent(inout):: q(bd%isd:bd%ied, bd%jsd:bd%jed) @@ -623,7 +623,7 @@ subroutine two_delta_filter(npx, npy, q, area, dx, dy, dxa, dya, dxc, dyc, sin_s jsd = bd%jsd jed = bd%jed - if ( nested ) then + if ( bounded_domain ) then is1 = is-1; ie2 = ie+2 js1 = js-1; je2 = je+2 else @@ -665,7 +665,7 @@ subroutine two_delta_filter(npx, npy, q, area, dx, dy, dxa, dya, dxc, dyc, sin_s endif ! First step: average the corners: - if ( .not. (nested .or. regional) .and. nt==1 ) then + if ( .not. bounded_domain .and. nt==1 ) then if ( is==1 .and. js==1 ) then q(1,1) = (q(1,1)*area(1,1)+q(0,1)*area(0,1)+q(1,0)*area(1,0)) & / ( area(1,1)+ area(0,1)+ area(1,0) ) @@ -700,7 +700,7 @@ subroutine two_delta_filter(npx, npy, q, area, dx, dy, dxa, dya, dxc, dyc, sin_s a1(i) = p1*(q(i-1,j)+q(i,j)) + p2*(q(i-2,j)+q(i+1,j)) enddo - if ( .not. (nested .or. regional) ) then + if ( .not. bounded_domain ) then if ( is==1 ) then a1(0) = c1*q(-2,j) + c2*q(-1,j) + c3*q(0,j) a1(1) = 0.5*(((2.*dxa(0,j)+dxa(-1,j))*q(0,j)-dxa(0,j)*q(-1,j))/(dxa(-1,j)+dxa(0,j)) & @@ -752,7 +752,7 @@ subroutine two_delta_filter(npx, npy, q, area, dx, dy, dxa, dya, dxc, dyc, sin_s a2(i,j) = p1*(q(i,j-1)+q(i,j)) + p2*(q(i,j-2)+q(i,j+1)) enddo enddo - if ( .not. (nested .or. regional) ) then + if ( .not. bounded_domain ) then if( js==1 ) then do i=is,ie a2(i,0) = c1*q(i,-2) + c2*q(i,-1) + c3*q(i,0) @@ -856,7 +856,7 @@ end subroutine two_delta_filter - subroutine del2_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, cd, zero_ocean, oro, nested, domain, bd, regional) + subroutine del2_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, cd, zero_ocean, oro, bounded_domain, domain, bd) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(in):: npx, npy integer, intent(in):: nmax @@ -870,16 +870,17 @@ subroutine del2_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, real, intent(in):: dyc(bd%isd:bd%ied, bd%jsd:bd%jed+1) real, intent(IN):: sin_sg(bd%isd:bd%ied,bd%jsd:bd%jed,9) real, intent(in):: oro(bd%isd:bd%ied, bd%jsd:bd%jed) !< 0==water, 1==land - logical, intent(IN) :: nested, regional + logical, intent(IN) :: bounded_domain type(domain2d), intent(INOUT) :: domain ! OUTPUT arrays - real, intent(inout):: q(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng) + real, intent(inout):: q(bd%isd:bd%ied, bd%jsd:bd%jed) ! Local: real ddx(bd%is:bd%ie+1,bd%js:bd%je), ddy(bd%is:bd%ie,bd%js:bd%je+1) integer i,j,n integer :: is, ie, js, je integer :: isd, ied, jsd, jed + integer :: ng is = bd%is ie = bd%ie @@ -889,30 +890,30 @@ subroutine del2_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, ied = bd%ied jsd = bd%jsd jed = bd%jed - + ng = bd%ng call mpp_update_domains(q,domain,whalo=ng,ehalo=ng,shalo=ng,nhalo=ng) ! First step: average the corners: - if ( is==1 .and. js==1 .and. .not. (nested .or. regional)) then + if ( is==1 .and. js==1 .and. .not. bounded_domain) then q(1,1) = (q(1,1)*area(1,1)+q(0,1)*area(0,1)+q(1,0)*area(1,0)) & / ( area(1,1)+ area(0,1)+ area(1,0) ) q(0,1) = q(1,1) q(1,0) = q(1,1) endif - if ( (ie+1)==npx .and. js==1 .and. .not. (nested .or. regional)) then + if ( (ie+1)==npx .and. js==1 .and. .not. bounded_domain) then q(ie, 1) = (q(ie,1)*area(ie,1)+q(npx,1)*area(npx,1)+q(ie,0)*area(ie,0)) & / ( area(ie,1)+ area(npx,1)+ area(ie,0)) q(npx,1) = q(ie,1) q(ie, 0) = q(ie,1) endif - if ( (ie+1)==npx .and. (je+1)==npy .and. .not. (nested .or. regional) ) then + if ( (ie+1)==npx .and. (je+1)==npy .and. .not. bounded_domain ) then q(ie, je) = (q(ie,je)*area(ie,je)+q(npx,je)*area(npx,je)+q(ie,npy)*area(ie,npy)) & / ( area(ie,je)+ area(npx,je)+ area(ie,npy)) q(npx,je) = q(ie,je) q(ie,npy) = q(ie,je) endif - if ( is==1 .and. (je+1)==npy .and. .not. (nested .or. regional)) then + if ( is==1 .and. (je+1)==npy .and. .not. bounded_domain) then q(1, je) = (q(1,je)*area(1,je)+q(0,je)*area(0,je)+q(1,npy)*area(1,npy)) & / ( area(1,je)+ area(0,je)+ area(1,npy)) q(0, je) = q(1,je) @@ -958,7 +959,7 @@ subroutine del2_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, end subroutine del2_cubed_sphere - subroutine del4_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, zero_ocean, oro, nested, domain, bd, regional) + subroutine del4_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, zero_ocean, oro, bounded_domain, domain, bd) type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(in):: npx, npy, nmax logical, intent(in):: zero_ocean @@ -969,8 +970,8 @@ subroutine del4_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, real, intent(in):: dxc(bd%isd:bd%ied+1,bd%jsd:bd%jed) real, intent(in):: dyc(bd%isd:bd%ied, bd%jsd:bd%jed+1) real, intent(IN):: sin_sg(bd%isd:bd%ied,bd%jsd:bd%jed,9) - real, intent(inout):: q(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng) - logical, intent(IN) :: nested, regional + real, intent(inout):: q(bd%isd:bd%ied, bd%jsd:bd%jed) + logical, intent(IN) :: bounded_domain type(domain2d), intent(INOUT) :: domain ! diffusivity real :: diff(bd%is-3:bd%ie+2,bd%js-3:bd%je+2) @@ -995,7 +996,7 @@ subroutine del4_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, jsd = bd%jsd jed = bd%jed - !On a nested grid the haloes are not filled. Set to zero. + !On a bounded_domain grid the haloes are not filled. Set to zero. d2 = 0. win = 0. wou = 0. @@ -1016,28 +1017,28 @@ subroutine del4_cubed_sphere(npx, npy, q, area, dx, dy, dxc, dyc, sin_sg, nmax, call mpp_update_domains(q,domain) ! First step: average the corners: - if ( is==1 .and. js==1 .and. .not. (nested .or. regional)) then + if ( is==1 .and. js==1 .and. .not. bounded_domain) then q(1,1) = (q(1,1)*area(1,1)+q(0,1)*area(0,1)+q(1,0)*area(1,0)) & / ( area(1,1)+ area(0,1)+ area(1,0) ) q(0,1) = q(1,1) q(1,0) = q(1,1) q(0,0) = q(1,1) endif - if ( (ie+1)==npx .and. js==1 .and. .not. (nested .or. regional)) then + if ( (ie+1)==npx .and. js==1 .and. .not. bounded_domain) then q(ie, 1) = (q(ie,1)*area(ie,1)+q(npx,1)*area(npx,1)+q(ie,0)*area(ie,0)) & / ( area(ie,1)+ area(npx,1)+ area(ie,0)) q(npx,1) = q(ie,1) q(ie, 0) = q(ie,1) q(npx,0) = q(ie,1) endif - if ( (ie+1)==npx .and. (je+1)==npy .and. .not. (nested .or. regional)) then + if ( (ie+1)==npx .and. (je+1)==npy .and. .not. bounded_domain) then q(ie, je) = (q(ie,je)*area(ie,je)+q(npx,je)*area(npx,je)+q(ie,npy)*area(ie,npy)) & / ( area(ie,je)+ area(npx,je)+ area(ie,npy)) q(npx, je) = q(ie,je) q(ie, npy) = q(ie,je) q(npx,npy) = q(ie,je) endif - if ( is==1 .and. (je+1)==npy .and. .not. (nested .or. regional)) then + if ( is==1 .and. (je+1)==npy .and. .not. bounded_domain) then q(1, je) = (q(1,je)*area(1,je)+q(0,je)*area(0,je)+q(1,npy)*area(1,npy)) & / ( area(1,je)+ area(0,je)+ area(1,npy)) q(0, je) = q(1,je) @@ -1194,7 +1195,7 @@ end subroutine del4_cubed_sphere subroutine map_to_cubed_raw(igh, im, jt, lat1, lon1, zs, ft, grid, agrid, & q2, f2, h2, npx, npy, jstart, jend, stretch_fac, & - nested, npx_global, bd, regional) + bounded_domain, npx_global, bd) ! Input type(fv_grid_bounds_type), intent(IN) :: bd @@ -1207,7 +1208,7 @@ subroutine map_to_cubed_raw(igh, im, jt, lat1, lon1, zs, ft, grid, agrid, & real(kind=R_GRID), intent(in):: agrid(bd%isd:bd%ied, bd%jsd:bd%jed, 2) integer, intent(in):: jstart, jend real(kind=R_GRID), intent(IN) :: stretch_fac - logical, intent(IN) :: nested, regional + logical, intent(IN) :: bounded_domain ! Output real, intent(out):: q2(bd%isd:bd%ied,bd%jsd:bd%jed) !< Mapped data at the target resolution real, intent(out):: f2(bd%isd:bd%ied,bd%jsd:bd%jed) !< oro @@ -1347,7 +1348,7 @@ subroutine map_to_cubed_raw(igh, im, jt, lat1, lon1, zs, ft, grid, agrid, & if (((i < is .and. j < js) .or. & (i < is .and. j > je) .or. & (i > ie .and. j < js) .or. & - (i > ie .and. j > je)) .and. .not. (nested .or. regional)) then + (i > ie .and. j > je)) .and. .not. bounded_domain) then q2(i,j) = 1.e25 f2(i,j) = 1.e25 h2(i,j) = 1.e25 @@ -1594,12 +1595,14 @@ end subroutine remove_ice_sheets !>@brief The subroutine 'read_namelis' reads the namelist file, !! writes the namelist to log file, and initializes constants. subroutine read_namelist - integer :: unit, ierr, io + + integer :: unit, ierr, io ! real :: dtr, ght ! read namelist if (namelist_read) return + #ifdef INTERNAL_FILE_NML read (input_nml_file, nml=surf_map_nml, iostat=io) ierr = check_nml_error(io,'surf_map_nml') @@ -1626,6 +1629,7 @@ end subroutine read_namelist !> The sugroutine 'zonal_mean' replaces 'p' with its zonal mean. subroutine zonal_mean(im, p, zmean) +! replace p with its zonal mean integer, intent(in):: im real(kind=4), intent(inout):: p(im) real, intent(out):: zmean diff --git a/tools/fv_timing.F90 b/tools/fv_timing.F90 index e6ef5de1e..609063e2c 100644 --- a/tools/fv_timing.F90 +++ b/tools/fv_timing.F90 @@ -1,21 +1,21 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** diff --git a/tools/fv_treat_da_inc.F90 b/tools/fv_treat_da_inc.F90 index c75e6db30..267531661 100644 --- a/tools/fv_treat_da_inc.F90 +++ b/tools/fv_treat_da_inc.F90 @@ -129,8 +129,7 @@ module fv_treat_da_inc_mod mid_pt_sphere, get_unit_vect2, & get_latlon_vector, inner_prod, & cubed_to_latlon - use fv_mp_mod, only: ng, & - is_master, & + use fv_mp_mod, only: is_master, & fill_corners, & YDir, & mp_reduce_min, & @@ -156,12 +155,20 @@ module fv_treat_da_inc_mod !! and added upon request. !>@author Xi.Chen !>@date 02/12/2016 - subroutine read_da_inc(Atm, fv_domain) - type(fv_atmos_type), intent(inout) :: Atm(:) - type(domain2d), intent(inout) :: fv_domain + subroutine read_da_inc(Atm, fv_domain, bd, npz_in, nq, u, v, q, delp, pt, delz, is_in, js_in, ie_in, je_in, & + isc_in, jsc_in, iec_in, jec_in ) + type(fv_atmos_type), intent(inout) :: Atm + type(domain2d), intent(inout) :: fv_domain + type(fv_grid_bounds_type), intent(IN) :: bd + integer, intent(IN) :: npz_in, nq, is_in, js_in, ie_in, je_in, isc_in, jsc_in, iec_in, jec_in + real, intent(inout), dimension(is_in:ie_in, js_in:je_in+1,npz_in):: u ! D grid zonal wind (m/s) + real, intent(inout), dimension(is_in:ie_in+1,js_in:je_in ,npz_in):: v ! D grid meridional wind (m/s) + real, intent(inout) :: delp(is_in:ie_in ,js_in:je_in ,npz_in) ! pressure thickness (pascal) + real, intent(inout) :: pt( is_in:ie_in ,js_in:je_in ,npz_in) ! temperature (K) + real, intent(inout) :: q( is_in:ie_in ,js_in:je_in ,npz_in, nq) ! + real, intent(inout) :: delz(isc_in:iec_in ,jsc_in:jec_in ,npz_in) ! ! local - integer :: nq - + real :: deg2rad character(len=128) :: fname real(kind=4), allocatable:: wk1(:), wk2(:,:), wk3(:,:,:) @@ -170,17 +177,17 @@ subroutine read_da_inc(Atm, fv_domain) real, dimension(:,:,:), allocatable:: u_inc, v_inc, ud_inc, vd_inc real, allocatable:: lat(:), lon(:) real, allocatable:: pt_c(:,:,:), pt_d(:,:,:) - real:: s2c(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je,4) - real:: s2c_c(Atm(1)%bd%is:Atm(1)%bd%ie+1,Atm(1)%bd%js:Atm(1)%bd%je,4) - real:: s2c_d(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je+1,4) - integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je):: & + real:: s2c(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je,4) + real:: s2c_c(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je,4) + real:: s2c_d(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1,4) + integer, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je):: & id1, id2, jdc - integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie+1,Atm(1)%bd%js:Atm(1)%bd%je)::& + integer, dimension(Atm%bd%is:Atm%bd%ie+1,Atm%bd%js:Atm%bd%je)::& id1_c, id2_c, jdc_c - integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je+1)::& + integer, dimension(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je+1)::& id1_d, id2_d, jdc_d - integer:: i, j, k, im, jm, km, npz, npt + integer:: i, j, k, im, jm, km, npt integer:: i1, i2, j1, ncid integer:: jbeg, jend integer tsize(3) @@ -197,20 +204,18 @@ subroutine read_da_inc(Atm, fv_domain) integer :: o3mr #endif - is = Atm(1)%bd%is - ie = Atm(1)%bd%ie - js = Atm(1)%bd%js - je = Atm(1)%bd%je - isd = Atm(1)%bd%isd - ied = Atm(1)%bd%ied - jsd = Atm(1)%bd%jsd - jed = Atm(1)%bd%jed + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed deg2rad = pi/180. - npz = Atm(1)%npz - - fname = 'INPUT/'//Atm(1)%flagstruct%res_latlon_dynamics + fname = 'INPUT/'//Atm%flagstruct%res_latlon_dynamics if( file_exist(fname) ) then call open_ncfile( fname, ncid ) ! open the file @@ -220,10 +225,10 @@ subroutine read_da_inc(Atm, fv_domain) im = tsize(1); jm = tsize(2); km = tsize(3) - if (km.ne.npz) then + if (km.ne.npz_in) then if (is_master()) print *, 'km = ', km call mpp_error(FATAL, & - '==> Error in read_da_inc: km is not equal to npz') + '==> Error in read_da_inc: km is not equal to npz_in') endif if(is_master()) write(*,*) fname, ' DA increment dimensions:', tsize @@ -248,9 +253,9 @@ subroutine read_da_inc(Atm, fv_domain) endif ! Initialize lat-lon to Cubed bi-linear interpolation coeff: - call remap_coef( is, ie, js, je, & + call remap_coef( is, ie, js, je, isd, ied, jsd, jed, & im, jm, lon, lat, id1, id2, jdc, s2c, & - Atm(1)%gridstruct%agrid(is:ie,js:je,:)) + Atm%gridstruct%agrid) ! Find bounding latitudes: jbeg = jm-1; jend = 2 @@ -276,38 +281,38 @@ subroutine read_da_inc(Atm, fv_domain) allocate ( wk3(1:im,jbeg:jend, 1:km) ) allocate ( tp(is:ie,js:je,km) ) - call apply_inc_on_3d_scalar('T_inc',Atm(1)%pt) - call apply_inc_on_3d_scalar('delp_inc',Atm(1)%delp) - if (.not. Atm(1)%flagstruct%hydrostatic) then - call apply_inc_on_3d_scalar('delz_inc',Atm(1)%delz) + call apply_inc_on_3d_scalar('T_inc',pt, is_in, js_in, ie_in, je_in) + call apply_inc_on_3d_scalar('delp_inc',delp, is_in, js_in, ie_in, je_in) + if ( .not. Atm%flagstruct%hydrostatic ) then + call apply_inc_on_3d_scalar('delz_inc',delz, isc_in, jsc_in, iec_in, jec_in) endif - call apply_inc_on_3d_scalar('sphum_inc',Atm(1)%q(:,:,:,sphum)) - call apply_inc_on_3d_scalar('liq_wat_inc',Atm(1)%q(:,:,:,liq_wat)) + call apply_inc_on_3d_scalar('sphum_inc',q(:,:,:,sphum), is_in, js_in, ie_in, je_in) + call apply_inc_on_3d_scalar('liq_wat_inc',q(:,:,:,liq_wat), is_in, js_in, ie_in, je_in) #ifdef MULTI_GASES - call apply_inc_on_3d_scalar('spfo3_inc',Atm(1)%q(:,:,:,spfo3)) - call apply_inc_on_3d_scalar('spfo_inc',Atm(1)%q(:,:,:,spfo)) - call apply_inc_on_3d_scalar('spfo2_inc',Atm(1)%q(:,:,:,spfo2)) + call apply_inc_on_3d_scalar('spfo3_inc',q(:,:,:,spfo3), is_in, js_in, ie_in, je_in) + call apply_inc_on_3d_scalar('spfo_inc',q(:,:,:,spfo), is_in, js_in, ie_in, je_in) + call apply_inc_on_3d_scalar('spfo2_inc',q(:,:,:,spfo2), is_in, js_in, ie_in, je_in) #else - call apply_inc_on_3d_scalar('o3mr_inc',Atm(1)%q(:,:,:,o3mr)) + call apply_inc_on_3d_scalar('o3mr_inc',q(:,:,:,o3mr), is_in, js_in, ie_in, je_in) #endif deallocate ( tp ) deallocate ( wk3 ) ! perform increments on winds - allocate (pt_c(is:ie+1,js:je ,2)) - allocate (pt_d(is:ie ,js:je+1,2)) + allocate (pt_c(isd:ied+1,jsd:jed ,2)) + allocate (pt_d(isd:ied ,jsd:jed+1,2)) allocate (ud_inc(is:ie , js:je+1, km)) allocate (vd_inc(is:ie+1, js:je , km)) call get_staggered_grid( & is, ie, js, je, & isd, ied, jsd, jed, & - Atm(1)%gridstruct%grid, pt_c, pt_d) + Atm%gridstruct%grid, pt_c, pt_d) !------ pt_c part ------ ! Initialize lat-lon to Cubed bi-linear interpolation coeff: - call remap_coef( is, ie+1, js, je, & + call remap_coef( is, ie+1, js, je, isd, ied+1, jsd, jed, & im, jm, lon, lat, id1_c, id2_c, jdc_c, s2c_c, & pt_c) @@ -343,14 +348,14 @@ subroutine read_da_inc(Atm, fv_domain) s2c_c(i,j,2)*wk3_v(i2,j1 ,k) + & s2c_c(i,j,3)*wk3_v(i2,j1+1,k) + & s2c_c(i,j,4)*wk3_v(i1,j1+1,k) - p1(:) = Atm(1)%gridstruct%grid(i,j ,1:2) - p2(:) = Atm(1)%gridstruct%grid(i,j+1,1:2) + p1(:) = Atm%gridstruct%grid(i,j ,1:2) + p2(:) = Atm%gridstruct%grid(i,j+1,1:2) call mid_pt_sphere(p1, p2, p3) call get_unit_vect2(p1, p2, e2) call get_latlon_vector(p3, ex, ey) vd_inc(i,j,k) = u_inc(i,j,k)*inner_prod(e2,ex) + & v_inc(i,j,k)*inner_prod(e2,ey) - Atm(1)%v(i,j,k) = Atm(1)%v(i,j,k) + vd_inc(i,j,k) + v(i,j,k) = v(i,j,k) + vd_inc(i,j,k) enddo enddo enddo @@ -360,7 +365,7 @@ subroutine read_da_inc(Atm, fv_domain) !------ pt_d part ------ ! Initialize lat-lon to Cubed bi-linear interpolation coeff: - call remap_coef( is, ie, js, je+1,& + call remap_coef( is, ie, js, je+1, isd, ied, jsd, jed+1, & im, jm, lon, lat, id1_d, id2_d, jdc_d, s2c_d, & pt_d) @@ -396,14 +401,14 @@ subroutine read_da_inc(Atm, fv_domain) s2c_d(i,j,2)*wk3_v(i2,j1 ,k) + & s2c_d(i,j,3)*wk3_v(i2,j1+1,k) + & s2c_d(i,j,4)*wk3_v(i1,j1+1,k) - p1(:) = Atm(1)%gridstruct%grid(i, j,1:2) - p2(:) = Atm(1)%gridstruct%grid(i+1,j,1:2) + p1(:) = Atm%gridstruct%grid(i, j,1:2) + p2(:) = Atm%gridstruct%grid(i+1,j,1:2) call mid_pt_sphere(p1, p2, p3) call get_unit_vect2(p1, p2, e1) call get_latlon_vector(p3, ex, ey) ud_inc(i,j,k) = u_inc(i,j,k)*inner_prod(e1,ex) + & v_inc(i,j,k)*inner_prod(e1,ey) - Atm(1)%u(i,j,k) = Atm(1)%u(i,j,k) + ud_inc(i,j,k) + u(i,j,k) = u(i,j,k) + ud_inc(i,j,k) enddo enddo enddo @@ -412,11 +417,11 @@ subroutine read_da_inc(Atm, fv_domain) deallocate ( wk3_u, wk3_v ) !rab The following is not necessary as ua/va will be re-calculated during model startup -!rab call cubed_to_latlon(Atm(1)%u, Atm(1)%v, Atm(1)%ua, Atm(1)%va, & -!rab Atm(1)%gridstruct, Atm(1)%flagstruct%npx, Atm(1)%flagstruct%npy, & -!rab Atm(1)%flagstruct%npz, 1, Atm(1)%gridstruct%grid_type, & -!rab fv_domain, Atm(1)%gridstruct%nested, & -!rab Atm(1)%flagstruct%c2l_ord, Atm(1)%bd) +!rab call cubed_to_latlon(Atm%u, Atm%v, Atm%ua, Atm%va, & +!rab Atm%gridstruct, Atm%flagstruct%npx, Atm%flagstruct%npy, & +!rab Atm%flagstruct%npz, 1, Atm%gridstruct%grid_type, & +!rab fv_domain, Atm%gridstruct%nested, & +!rab Atm%flagstruct%c2l_ord, Atm%bd) !------ winds clean up ------ deallocate ( pt_c, pt_d, ud_inc, vd_inc ) @@ -427,9 +432,10 @@ subroutine read_da_inc(Atm, fv_domain) !--------------------------------------------------------------------------- !> @brief The subroutine 'apply_inc_on3d_scalar' applies the input increments !! to the prognostic variables. - subroutine apply_inc_on_3d_scalar(field_name,var) + subroutine apply_inc_on_3d_scalar(field_name,var, is_in, js_in, ie_in, je_in) character(len=*), intent(in) :: field_name - real, dimension(isd:ied,jsd:jed,1:km), intent(inout) :: var + integer, intent(IN) :: is_in, js_in, ie_in, je_in + real, dimension(is_in:ie_in,js_in:je_in,1:km), intent(inout) :: var integer :: ierr call check_var_exists(ncid, field_name, ierr) @@ -460,15 +466,15 @@ end subroutine read_da_inc !============================================================================= !>@brief The subroutine 'remap_coef' calculates the coefficients for horizonal regridding. - subroutine remap_coef( is, ie, js, je,& + subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & im, jm, lon, lat, id1, id2, jdc, s2c, agrid ) - integer, intent(in):: is, ie, js, je + integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed integer, intent(in):: im, jm real, intent(in):: lon(im), lat(jm) real, intent(out):: s2c(is:ie,js:je,4) integer, intent(out), dimension(is:ie,js:je):: id1, id2, jdc - real, intent(in):: agrid(is:ie,js:je,2) + real, intent(in):: agrid(isd:ied,jsd:jed,2) ! local: real :: rdlon(im) real :: rdlat(jm) @@ -545,11 +551,10 @@ subroutine get_staggered_grid( & is, ie, js, je, & isd, ied, jsd, jed, & pt_b, pt_c, pt_d) - integer, intent(in) :: is, ie, js, je - integer, intent(in) :: isd, ied, jsd, jed + integer, intent(in) :: is, ie, js, je, isd, ied, jsd, jed real, dimension(isd:ied+1,jsd:jed+1,2), intent(in) :: pt_b - real, dimension(is:ie+1,js:je ,2), intent(out) :: pt_c - real, dimension(is:ie ,js:je+1,2), intent(out) :: pt_d + real, dimension(isd:ied+1,jsd:jed ,2), intent(out) :: pt_c + real, dimension(isd:ied ,jsd:jed+1,2), intent(out) :: pt_d ! local real(kind=R_GRID), dimension(2):: p1, p2, p3 integer :: i, j diff --git a/tools/init_hydro.F90 b/tools/init_hydro.F90 index 082a3216a..58ca269ff 100644 --- a/tools/init_hydro.F90 +++ b/tools/init_hydro.F90 @@ -1,22 +1,21 @@ - !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** @@ -83,7 +82,8 @@ module init_hydro_mod subroutine p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min, & delp, delz, pt, ps, pe, peln, pk, pkz, cappa, q, ng, nq, area, & dry_mass, adjust_dry_mass, mountain, moist_phys, & - hydrostatic, nwat, domain, make_nh) + hydrostatic, nwat, domain, adiabatic, make_nh) + ! Given (ptop, delp) computes (ps, pk, pe, peln, pkz) ! Input: integer, intent(in):: km @@ -91,10 +91,10 @@ subroutine p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min, & integer, intent(in):: jfirst, jlast !< Latitude strip integer, intent(in):: nq, nwat integer, intent(in):: ng - logical, intent(in):: adjust_dry_mass, mountain, moist_phys, hydrostatic + logical, intent(in):: adjust_dry_mass, mountain, moist_phys, hydrostatic, adiabatic real, intent(in):: dry_mass, cappa, ptop, ptop_min real, intent(in ):: pt(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km) - real, intent(inout):: delz(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km) + real, intent(inout):: delz(ifirst:ilast,jfirst:jlast, km) real, intent(inout):: delp(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km) real, intent(inout):: q(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km, nq) real(kind=R_GRID), intent(IN) :: area(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) @@ -176,6 +176,12 @@ subroutine p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min, & endif enddo + if ( adiabatic ) then + zvir = 0. + else + zvir = rvgas/rdgas - 1. + endif + sphum = get_tracer_index (MODEL_ATMOS, 'sphum') if ( .not.hydrostatic ) then @@ -183,11 +189,11 @@ subroutine p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min, & if ( present(make_nh) ) then if ( make_nh ) then delz = 1.e25 -!$OMP parallel do default(none) shared(ifirst,ilast,jfirst,jlast,km,delz,rdg,pt,peln) +!$OMP parallel do default(none) shared(ifirst,ilast,jfirst,jlast,km,delz,rdg,pt,peln,zvir,sphum,q) do k=1,km do j=jfirst,jlast do i=ifirst,ilast - delz(i,j,k) = rdg*pt(i,j,k)*(peln(i,k+1,j)-peln(i,k,j)) + delz(i,j,k) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j)) enddo enddo enddo @@ -199,8 +205,6 @@ subroutine p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min, & !------------------------------------------------------------------ ! The following form is the same as in "fv_update_phys.F90" !------------------------------------------------------------------ - zvir = rvgas/rdgas - 1. - sphum = get_tracer_index (MODEL_ATMOS, 'sphum') !$OMP parallel do default(none) shared(ifirst,ilast,jfirst,jlast,km,pkz,cappa,rdg, & !$OMP delp,pt,zvir,q,sphum,delz) do k=1,km @@ -263,7 +267,7 @@ subroutine drymadj(km, ifirst, ilast, jfirst, jlast, ng, & ! INPUT/OUTPUT PARAMETERS: real, intent(in):: q(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng,km,nq) real, intent(in)::delp(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng,km) - real, intent(inout):: ps(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) !< surface pressure + real, intent(inout):: ps(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) ! surface pressure real, intent(out):: dpd ! Local real psd(ifirst:ilast,jfirst:jlast) !< surface pressure due to dry air mass @@ -341,7 +345,7 @@ subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, & real, intent(out):: ps(is-ng:ie+ng,js-ng:je+ng) real, intent(out):: pt(is-ng:ie+ng,js-ng:je+ng,km) real, intent(out):: delp(is-ng:ie+ng,js-ng:je+ng,km) - real, intent(inout):: delz(is-ng:ie+ng,js-ng:je+ng,km) + real, intent(inout):: delz(is:,js:,1:) ! Local real gz(is:ie,km+1) real ph(is:ie,km+1) diff --git a/tools/sim_nc_mod.F90 b/tools/sim_nc_mod.F90 index a0b0f95c6..5bd043c3e 100644 --- a/tools/sim_nc_mod.F90 +++ b/tools/sim_nc_mod.F90 @@ -1,21 +1,21 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** diff --git a/tools/sorted_index.F90 b/tools/sorted_index.F90 index 2cd22d5cb..bb3d84f88 100644 --- a/tools/sorted_index.F90 +++ b/tools/sorted_index.F90 @@ -1,21 +1,21 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** !>@brief The module 'sorted_index' sorts cell corner indices in lat-lon diff --git a/tools/test_cases.F90 b/tools/test_cases.F90 index 5a33aca4d..9146d230e 100644 --- a/tools/test_cases.F90 +++ b/tools/test_cases.F90 @@ -1,21 +1,21 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** @@ -99,8 +99,7 @@ module test_cases_mod use constants_mod, only: cnst_radius=>radius, pi=>pi_8, omega, grav, kappa, rdgas, cp_air, rvgas use init_hydro_mod, only: p_var, hydro_eq - use fv_mp_mod, only: ng, is_master, & - is,js,ie,je, isd,jsd,ied,jed, & + use fv_mp_mod, only: is_master, & domain_decomp, fill_corners, XDir, YDir, & mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst use fv_grid_utils_mod, only: cubed_to_latlon, great_circle_dist, mid_pt_sphere, & @@ -113,6 +112,8 @@ module test_cases_mod hybrid_z_dz use mpp_mod, only: mpp_error, FATAL, mpp_root_pe, mpp_broadcast, mpp_sum + use mpp_mod, only: stdlog, input_nml_file + use fms_mod, only: check_nml_error, close_file, open_namelist_file use mpp_domains_mod, only: mpp_update_domains, domain2d use mpp_parameter_mod, only: AGRID_PARAM=>AGRID,CGRID_NE_PARAM=>CGRID_NE, & SCALAR_PAIR @@ -127,7 +128,12 @@ module test_cases_mod implicit none private -! Test Case Number +!!! A NOTE ON TEST CASES +!!! If you have a DRY test case with no physics, be sure to set adiabatic = .TRUE. in your runscript. +!!!! This is especially important for nonhydrostatic cases in which delz will be initialized with the +!!!! virtual temperature effect. + +! Test Case Number (cubed-sphere domain) ! -1 = Divergence conservation test ! 0 = Idealized non-linear deformational flow ! 1 = Cosine Bell advection @@ -165,15 +171,16 @@ module test_cases_mod ! 45 = New test ! 51 = 3D tracer advection (deformational nondivergent flow) ! 55 = TC +! -55 = DCMIP 2016 TC test ! 101 = 3D non-hydrostatic Large-Eddy-Simulation (LES) with hybrid_z IC integer :: sphum, theta_d real(kind=R_GRID), parameter :: radius = cnst_radius real(kind=R_GRID), parameter :: one = 1.d0 - integer :: test_case - logical :: bubble_do - real :: alpha - integer :: Nsolitons + integer :: test_case = 11 + logical :: bubble_do = .false. + real :: alpha = 0.0 + integer :: Nsolitons = 1 real :: soliton_size = 750.e3, soliton_Umax = 50. ! Case 0 parameters @@ -223,13 +230,13 @@ module test_cases_mod integer, parameter :: interpOrder = 1 public :: pz0, zz0 - public :: test_case, bubble_do, alpha, tracer_test, wind_field, nsolitons, soliton_Umax, soliton_size - public :: init_case, get_stats, check_courant_numbers + public :: read_namelist_test_case_nml, alpha + public :: init_case #ifdef NCDF_OUTPUT public :: output, output_ncdf #endif public :: case9_forcing1, case9_forcing2, case51_forcing - public :: init_double_periodic, init_latlon + public :: init_double_periodic public :: checker_tracers INTERFACE mp_update_dwinds @@ -241,22 +248,26 @@ module test_cases_mod !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! - subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nregions, nested, gridstruct, domain, tile) +! +! init_winds :: initialize the winds +! + subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nregions, bounded_domain, gridstruct, domain, tile, bd) ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate + type(fv_grid_bounds_type), intent(IN) :: bd real , intent(INOUT) :: UBar - real , intent(INOUT) :: u(isd:ied ,jsd:jed+1) - real , intent(INOUT) :: v(isd:ied+1,jsd:jed ) - real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ) - real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1) - real , intent(INOUT) :: ua(isd:ied ,jsd:jed ) - real , intent(INOUT) :: va(isd:ied ,jsd:jed ) + real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1) + real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ) + real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ) + real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1) + real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ) + real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ) integer, intent(IN) :: defOnGrid integer, intent(IN) :: npx, npy integer, intent(IN) :: ng integer, intent(IN) :: ndims integer, intent(IN) :: nregions - logical, intent(IN) :: nested + logical, intent(IN) :: bounded_domain type(fv_grid_type), intent(IN), target :: gridstruct type(domain2d), intent(INOUT) :: domain integer, intent(IN) :: tile @@ -268,7 +279,7 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre integer :: i,j,k,n real :: utmp, vtmp - real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2 + real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1), psi(bd%isd:bd%ied,bd%jsd:bd%jed), psi1, psi2 integer :: is2, ie2, js2, je2 real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid @@ -284,6 +295,9 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre integer, pointer :: ntiles_g real, pointer :: acapN, acapS, globalarea + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + grid => gridstruct%grid_64 agrid=> gridstruct%agrid_64 @@ -320,7 +334,16 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre acapS => gridstruct%acapS globalarea => gridstruct%globalarea - if (nested) then + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + + if (bounded_domain) then is2 = is-2 ie2 = ie+2 @@ -385,7 +408,7 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre if (dist==0) u(i,j) = 0. enddo enddo - call mp_update_dwinds(u, v, npx, npy, domain) + call mp_update_dwinds(u, v, npx, npy, domain, bd) do j=js,je do i=is,ie psi1 = 0.5*(psi(i,j)+psi(i,j-1)) @@ -418,8 +441,8 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre enddo call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM) call fill_corners(uc, vc, npx, npy, VECTOR=.true., CGRID=.true.) - call ctoa(uc,vc,ua,va,dx, dy, dxc,dyc,dxa,dya,npx,npy,ng) - call atod(ua,va,u ,v ,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain) + call ctoa(uc,vc,ua,va,dx, dy, dxc,dyc,dxa,dya,npx,npy,ng, bd) + call atod(ua,va,u ,v ,dxa, dya,dxc,dyc,npx,npy,ng, bounded_domain, domain, bd) ! call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd),v(isd,jsd), & ! ua(isd,jsd),va(isd,jsd), uc(isd,jsd),vc(isd,jsd)) elseif ( (cubed_sphere) .and. (defOnGrid==2) ) then @@ -437,9 +460,9 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre if (dist==0) u(i,j) = 0. enddo enddo - call mp_update_dwinds(u, v, npx, npy, domain) - call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain) + call mp_update_dwinds(u, v, npx, npy, domain, bd) + call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng, bd) + call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain, domain, bd) elseif ( (cubed_sphere) .and. (defOnGrid==3) ) then do j=js,je do i=is,ie @@ -456,8 +479,8 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre enddo enddo call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM) - call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested,domain) + call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, bounded_domain, domain, bd) + call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain,domain, bd) elseif ( (latlon) .or. (defOnGrid==4) ) then do j=js,je @@ -479,8 +502,8 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre enddo enddo call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM) - call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain) + call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, bounded_domain, domain, bd) + call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain, domain, bd) elseif ( (latlon) .or. (defOnGrid==5) ) then ! SJL mods: ! v-wind: @@ -512,9 +535,9 @@ subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nre enddo enddo - call mp_update_dwinds(u, v, npx, npy, domain) - call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain) + call mp_update_dwinds(u, v, npx, npy, domain, bd) + call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng, bd) + call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain, domain, bd) else !print*, 'Choose an appropriate grid to define the winds on' !stop @@ -527,6 +550,7 @@ end subroutine init_winds !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +! ! init_case :: initialize the Williamson test cases: ! case 1 (2-D advection of a cosine bell) ! case 2 (Steady State Zonal Geostrophic Flow) @@ -559,7 +583,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) - real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:) + real , intent(inout) :: delz(bd%is:,bd%js:,1:) real , intent(inout) :: ze0(bd%is:,bd%js:,1:) real , intent(inout) :: ak(npz+1) @@ -708,6 +732,9 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, integer, pointer :: ntiles_g real, pointer :: acapN, acapS, globalarea + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + is = bd%is ie = bd%ie js = bd%js @@ -756,7 +783,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, acapS => gridstruct%acapS globalarea => gridstruct%globalarea - if (gridstruct%nested) then + if (gridstruct%bounded_domain) then is2 = isd ie2 = ied js2 = jsd @@ -806,7 +833,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0 enddo enddo - call init_winds(UBar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile) + call init_winds(UBar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile) ! Test Divergence operator at cell centers do j=js,je @@ -842,7 +869,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, write(*,201) 'Divergence Linf_norm : ', Linf_norm endif - call init_winds(UBar, u,v,ua,va,uc,vc, 3, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile) + call init_winds(UBar, u,v,ua,va,uc,vc, 3, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile, bd) ! Test Divergence operator at cell centers do j=js,je do i=is,ie @@ -872,7 +899,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, write(*,201) 'Divergence Linf_norm : ', Linf_norm endif - call init_winds(UBar, u,v,ua,va,uc,vc, 2, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile) + call init_winds(UBar, u,v,ua,va,uc,vc, 2, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile, bd) !call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd,1),v(isd,jsd,1), & ! ua(isd,jsd,1),va(isd,jsd,1), uc(isd,jsd,1),vc(isd,jsd,1)) ! Test Divergence operator at cell centers @@ -931,9 +958,9 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, enddo enddo call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM) - call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain) - call mp_update_dwinds(u, v, npx, npy, npz, domain) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain) + call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%bounded_domain, domain, bd) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) + call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd) call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM) call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.) initWindsCase=initWindsCase0 @@ -1112,11 +1139,11 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, p1(1) = pi*1.5 - ddeg p1(2) = pi/18. ! 10 N - call rankine_vortex(ubar, r0, p1, u, v, grid) + call rankine_vortex(ubar, r0, p1, u, v, grid, bd) p2(1) = pi*1.5 + ddeg p2(2) = pi/18. ! 10 N - call rankine_vortex(ubar, r0, p2, u, v, grid) + call rankine_vortex(ubar, r0, p2, u, v, grid, bd) #ifndef SINGULAR_VORTEX !----------- @@ -1128,16 +1155,16 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, e1(i) = -e1(i) enddo call cart_to_latlon(1, e1, p3(1), p3(2)) - call rankine_vortex(ubar, r0, p3, u, v, grid) + call rankine_vortex(ubar, r0, p3, u, v, grid, bd) call latlon2xyz(p2, e1) do i=1,3 e1(i) = -e1(i) enddo call cart_to_latlon(1, e1, p4(1), p4(2)) - call rankine_vortex(ubar, r0, p4, u, v, grid) + call rankine_vortex(ubar, r0, p4, u, v, grid, bd) #endif - call mp_update_dwinds(u, v, npx, npy, npz, domain) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) initWindsCase=-1 ! do nothing case(5) @@ -1211,10 +1238,10 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey) enddo enddo - call mp_update_dwinds(u, v, npx, npy, npz, domain) - call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) + call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng,bd) !call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain) + call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd) initWindsCase=initWindsCase6 case(7) ! Barotropically unstable jet @@ -1493,15 +1520,15 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, enddo call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain) + call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd) call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM) call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.) - call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain) - call mp_update_dwinds(u, v, npx, npy, npz, domain) + call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%bounded_domain, domain, bd) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) initWindsCase=initWindsCase9 - call get_case9_B(case9_B, agrid) + call get_case9_B(case9_B, agrid, isd, ied, jsd, jed) AofT(:) = 0.0 #else !---------------------------- @@ -1565,7 +1592,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, call mpp_update_domains( phis, domain ) phi0 = delp - call init_winds(UBar, u,v,ua,va,uc,vc, initWindsCase, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile) + call init_winds(UBar, u,v,ua,va,uc,vc, initWindsCase, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile, bd) ! Copy 3D data for Shallow Water Tests do z=2,npz u(:,:,z) = u(:,:,1) @@ -1619,8 +1646,8 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, call surfdrv(npx, npy, gridstruct%grid_64, gridstruct%agrid_64, & gridstruct%area_64, dx, dy, dxa, dya, dxc, dyc, & gridstruct%sin_sg, phis, & - flagstruct%stretch_fac, gridstruct%nested, & - npx_global, domain, flagstruct%grid_number, bd, flagstruct%regional) + flagstruct%stretch_fac, gridstruct%nested, gridstruct%bounded_domain, & + npx_global, domain, flagstruct%grid_number, bd) call mpp_update_domains( phis, domain ) if ( hybrid_z ) then @@ -1694,7 +1721,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, cl2 = get_tracer_index(MODEL_ATMOS, 'cl2') if (cl > 0 .and. cl2 > 0) then call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, & - q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2)) + q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2),bd) call mpp_update_domains(q,domain) endif @@ -2029,7 +2056,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, call DCMIP16_BC(delp,pt,u,v,q,w,delz, & is,ie,js,je,isd,ied,jsd,jed,npz,ncnst,ak,bk,ptop, & pk,peln,pe,pkz,gz,phis,ps,grid,agrid,hydrostatic, & - nwat, adiabatic, test_case == -13, domain) + nwat, adiabatic, test_case == -13, domain, bd) write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je)) @@ -2648,7 +2675,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM) call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.) - call mp_update_dwinds(u, v, npx, npy, npz, domain) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) case (2) !DCMIP 12 @@ -2788,6 +2815,9 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) enddo +#ifndef GFS_PHYS + call SuperCell_Sounding(npz, p00, pk1, ts1, qs1) +#endif w(:,:,:) = 0. q(:,:,:,:) = 0. @@ -2887,7 +2917,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & - .true., hydrostatic, nwat, domain) + .true., hydrostatic, nwat, domain, adiabatic) ! *** Add Initial perturbation *** pturb = 2. @@ -3140,7 +3170,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & - .true., hydrostatic, nwat, domain) + .true., hydrostatic, nwat, domain, adiabatic) else if ( test_case==36 .or. test_case==37 ) then !------------------------------------ @@ -3706,7 +3736,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, enddo endif - call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) + call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng, bd) call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01) @@ -3746,7 +3776,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, #ifndef SUPER_K call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., mountain, & - moist_phys, hydrostatic, nwat, domain, .not.hydrostatic) + moist_phys, hydrostatic, nwat, domain, adiabatic, .not.hydrostatic) #endif #ifdef COLUMN_TRACER @@ -3772,7 +3802,7 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, #endif #endif - call mp_update_dwinds(u, v, npx, npy, npz, domain) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) nullify(agrid) @@ -3919,11 +3949,13 @@ subroutine checker_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, & end subroutine checker_tracers subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, & - km, q, delp, ncnst, lon, lat) + km, q, delp, ncnst, lon, lat, bd) !-------------------------------------------------------------------- ! This routine implements the terminator test. ! Coded by Lucas Harris for DCMIP 2016, May 2016 +! NOTE: Implementation assumes DRY mixing ratio!!! !-------------------------------------------------------------------- + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(in):: km ! vertical dimension integer, intent(in):: i0, i1 ! compute domain dimension in E-W integer, intent(in):: j0, j1 ! compute domain dimension in N-S @@ -3972,8 +4004,8 @@ subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, & !Compute qcly0 qcly0 = 0. if (is_master()) then - i = is - j = js + i = bd%is + j = bd%js mm = 0. do k=1,km qcly0 = qcly0 + (q(i,j,k,Cl) + 2.*q(i,j,k,Cl2))*delp(i,j,k) @@ -3987,16 +4019,18 @@ subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, & end subroutine terminator_tracers - subroutine rankine_vortex(ubar, r0, p1, u, v, grid ) + subroutine rankine_vortex(ubar, r0, p1, u, v, grid, bd ) !---------------------------- ! Rankine vortex !---------------------------- + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(in):: ubar ! max wind (m/s) real, intent(in):: r0 ! Radius of max wind (m) real, intent(in):: p1(2) ! center position (longitude, latitude) in radian - real, intent(inout):: u(isd:ied, jsd:jed+1) - real, intent(inout):: v(isd:ied+1,jsd:jed) - real(kind=R_GRID), intent(IN) :: grid(isd:ied+1,jsd:jed+1,2) + real, intent(inout):: u(bd%isd:bd%ied, bd%jsd:bd%jed+1) + real, intent(inout):: v(bd%isd:bd%ied+1,bd%jsd:bd%jed) + real(kind=R_GRID), intent(IN) :: grid(bd%isd:bd%ied+1,bd%jsd:bd%jed+1,2) ! local: real(kind=R_GRID):: p2(2), p3(2), p4(2) real(kind=R_GRID):: e1(3), e2(3), ex(3), ey(3) @@ -4004,6 +4038,18 @@ subroutine rankine_vortex(ubar, r0, p1, u, v, grid ) real:: utmp, vtmp integer i, j + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + ! Compute u-wind do j=js,je+1 do i=is,ie @@ -4127,7 +4173,8 @@ real function u_jet(lat) endif end function u_jet - subroutine get_case9_B(B, agrid) + subroutine get_case9_B(B, agrid, isd, ied, jsd, jed) + integer, intent(IN) :: isd, ied, jsd, jed real, intent(OUT) :: B(isd:ied,jsd:jed) real, intent(IN) :: agrid(isd:ied,jsd:jed,2) real :: myC,yy,myB @@ -4156,8 +4203,9 @@ end subroutine get_case9_B !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! ! - subroutine case9_forcing1(phis,time_since_start) + subroutine case9_forcing1(phis,time_since_start,isd,ied,jsd,jed) + integer, intent(IN) :: isd,ied,jsd,jed real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) real , intent(IN) :: time_since_start real :: tday, amean @@ -4191,7 +4239,8 @@ end subroutine case9_forcing1 !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! ! - subroutine case9_forcing2(phis) + subroutine case9_forcing2(phis,isd,ied,jsd,jed) + integer, intent(IN) :: isd,ied,jsd,jed real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) integer :: i,j ! @@ -4209,16 +4258,17 @@ end subroutine case9_forcing2 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! !------------------------------------------------------------------------------- - subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain) - - real, intent(INOUT) :: delp(isd:ied,jsd:jed,npz) - real, intent(INOUT) :: uc(isd:ied+1,jsd:jed,npz) - real, intent(INOUT) :: vc(isd:ied,jsd:jed+1,npz) - real, intent(INOUT) :: u(isd:ied,jsd:jed+1,npz) - real, intent(INOUT) :: v(isd:ied+1,jsd:jed,npz) - real, intent(INOUT) :: ua(isd:ied,jsd:jed,npz) - real, intent(INOUT) :: va(isd:ied,jsd:jed,npz) - real, intent(INOUT) :: pe(is-1:ie+1, npz+1,js-1:je+1) ! edge pressure (pascal) + subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain, bd) + + type(fv_grid_bounds_type), intent(IN) :: bd + real, intent(INOUT) :: delp(bd%isd:bd%ied,bd%jsd:bd%jed,npz) + real, intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed,npz) + real, intent(INOUT) :: vc(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz) + real, intent(INOUT) :: u(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz) + real, intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed,npz) + real, intent(INOUT) :: ua(bd%isd:bd%ied,bd%jsd:bd%jed,npz) + real, intent(INOUT) :: va(bd%isd:bd%ied,bd%jsd:bd%jed,npz) + real, intent(INOUT) :: pe(bd%is-1:bd%ie+1, npz+1,bd%js-1:bd%je+1) ! edge pressure (pascal) real, intent(IN) :: time, dt real, intent(INOUT) :: ptop integer, intent(IN) :: npx, npy, npz @@ -4234,8 +4284,8 @@ subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, real :: ull, vll, lonp real :: p0(2), elon(3), elat(3) - real :: psi(isd:ied,jsd:jed) - real :: psi_b(isd:ied+1,jsd:jed+1) + real :: psi(bd%isd:bd%ied,bd%jsd:bd%jed) + real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1) real :: dist, psi1, psi2 real :: k_cell = 5 @@ -4248,6 +4298,19 @@ subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid real, pointer, dimension(:,:) :: dx, dxa, dy, dya, dxc, dyc + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed, ng + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + ng = bd%ng + agrid => gridstruct%agrid_64 grid => gridstruct%grid_64 @@ -4415,7 +4478,7 @@ subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, enddo enddo - call mp_update_dwinds(u(:,:,1), v(:,:,1), npx, npy, domain) + call mp_update_dwinds(u(:,:,1), v(:,:,1), npx, npy, domain, bd) ! copy vertically; no wind shear do k=2,npz @@ -4431,11 +4494,11 @@ subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, enddo enddo - call mp_update_dwinds(u, v, npx, npy, npz, domain) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) - call dtoa( u(:,:,1), v(:,:,1),ua(:,:,1),va(:,:,1),dx,dy,dxa,dya,dxc,dyc,npx,npy,ng) + call dtoa( u(:,:,1), v(:,:,1),ua(:,:,1),va(:,:,1),dx,dy,dxa,dya,dxc,dyc,npx,npy,ng,bd) call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM) !! ABSOLUTELY NECESSARY!! - call atoc(ua(:,:,1),va(:,:,1),uc(:,:,1),vc(:,:,1),dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain) + call atoc(ua(:,:,1),va(:,:,1),uc(:,:,1),vc(:,:,1),dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd) do k=2,npz do j=js,je @@ -4512,7 +4575,7 @@ subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM) call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.) - call mp_update_dwinds(u, v, npx, npy, npz, domain) + call mp_update_dwinds(u, v, npx, npy, npz, domain, bd) nullify(agrid) nullify(grid) @@ -4524,454 +4587,467 @@ subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, end subroutine case51_forcing -!------------------------------------------------------------------------------- -! -! get_stats :: get L-1, L-2, and L-inf norms and other stats as defined -! in Williamson, 1994 (p.16) - subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, & - uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions, & - gridstruct, stats_lun, consv_lun, monitorFreq, tile, & - domain, nested) - integer, intent(IN) :: nt, maxnt - real , intent(IN) :: dt, dtout, ndays - real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) - real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) - real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) - real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) - integer, intent(IN) :: npx, npy, npz, ncnst, tile - integer, intent(IN) :: ndims - integer, intent(IN) :: nregions - integer, intent(IN) :: stats_lun - integer, intent(IN) :: consv_lun - integer, intent(IN) :: monitorFreq - type(fv_grid_type), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - logical, intent(IN) :: nested - - real :: L1_norm - real :: L2_norm - real :: Linf_norm - real :: pmin, pmin1, uamin1, vamin1 - real :: pmax, pmax1, uamax1, vamax1 - real(kind=4) :: arr_r4(5) - real :: tmass0, tvort0, tener0, tKE0 - real :: tmass, tvort, tener, tKE - real :: temp(is:ie,js:je) - integer :: i0, j0, k0, n0 - integer :: i, j, k, n, iq - - real :: psmo, Vtx, p, w_p, p0 - real :: x1,y1,z1,x2,y2,z2,ang - - real :: p1(2), p2(2), p3(2), r, r0, dist, heading - - real :: uc0(isd:ied+1,jsd:jed ,npz) - real :: vc0(isd:ied ,jsd:jed+1,npz) - - real :: myDay - integer :: myRec - - real, save, allocatable, dimension(:,:,:) :: u0, v0 - real :: up(isd:ied ,jsd:jed+1,npz) - real :: vp(isd:ied+1,jsd:jed ,npz) - - real, dimension(:,:,:), pointer :: grid, agrid - real, dimension(:,:), pointer :: area, f0, dx, dy, dxa, dya, dxc, dyc - - grid => gridstruct%grid - agrid=> gridstruct%agrid - - area => gridstruct%area - f0 => gridstruct%f0 - - dx => gridstruct%dx - dy => gridstruct%dy - dxa => gridstruct%dxa - dya => gridstruct%dya - dxc => gridstruct%dxc - dyc => gridstruct%dyc - - !!! DEBUG CODE - if (nt == 0 .and. is_master()) print*, 'INITIALIZING GET_STATS' - !!! END DEBUG CODE - - myDay = ndays*((FLOAT(nt)/FLOAT(maxnt))) - -#if defined(SW_DYNAMICS) - if (test_case==0) then - phi0 = 0.0 - do j=js,je - do i=is,ie - x1 = agrid(i,j,1) - y1 = agrid(i,j,2) - z1 = radius - p = p0_c0 * cos(y1) - Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) - w_p = 0.0 - if (p /= 0.0) w_p = Vtx/p - ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) - phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) - enddo - enddo - elseif (test_case==1) then -! Get Current Height Field "Truth" - p1(1) = pi/2. + pi_shift - p1(2) = 0. - p2(1) = 3.*pi/2. + pi_shift - p2(2) = 0. - r0 = radius/3. !RADIUS 3. - dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) - heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha - call get_pt_on_great_circle( p1, p2, dist, heading, p3) - phi0 = 0.0 - do j=js,je - do i=is,ie - p2(1) = agrid(i,j,1) - p2(2) = agrid(i,j,2) - r = great_circle_dist( p3, p2, radius ) - if (r < r0) then - phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) - else - phi0(i,j,1) = phis(i,j) - endif - enddo - enddo - endif - -! Get Height Field Stats - call pmxn(delp(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0) - pmin1=pmin1/Grav - pmax1=pmax1/Grav - if (test_case <= 2) then - call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, & - pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile) - pmin=pmin/Grav - pmax=pmax/Grav - arr_r4(1) = pmin1 - arr_r4(2) = pmax1 - arr_r4(3) = L1_norm - arr_r4(4) = L2_norm - arr_r4(5) = Linf_norm - !if (is_master()) write(stats_lun,rec=(nt)*2 + 1) arr_r4 - else - arr_r4(1) = pmin1 - arr_r4(2) = pmax1 - arr_r4(3:5) = 0. - pmin = 0. - pmax = 0. - L1_norm = 0. - L2_norm = 0. - Linf_norm = 0. - endif - - 200 format(i6.6,A,i6.6,A,e21.14) - 201 format(' ',A,e21.14,' ',e21.14) - 202 format(' ',A,i4.4,'x',i4.4,'x',i4.4) - - if ( (is_master()) .and. MOD(nt,monitorFreq)==0 ) then - write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay - write(*,201) 'Height MAX : ', pmax1 - write(*,201) 'Height MIN : ', pmin1 - write(*,202) 'HGT MAX location : ', i0, j0, n0 - if (test_case <= 2) then - write(*,201) 'Height L1_norm : ', L1_norm - write(*,201) 'Height L2_norm : ', L2_norm - write(*,201) 'Height Linf_norm : ', Linf_norm - endif - endif - -! Get UV Stats - call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) - call pmxn(ua(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0) - if (test_case <= 2) then - call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, & - pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile) - endif - arr_r4(1) = pmin1 - arr_r4(2) = pmax1 - arr_r4(3) = L1_norm - arr_r4(4) = L2_norm - arr_r4(5) = Linf_norm - !if (is_master()) write(stats_lun,rec=(nt)*2 + 2) arr_r4 - if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then - write(*,201) 'UV MAX : ', pmax1 - write(*,201) 'UV MIN : ', pmin1 - write(*,202) 'UV MAX location : ', i0, j0, n0 - if (test_case <= 2) then - write(*,201) 'UV L1_norm : ', L1_norm - write(*,201) 'UV L2_norm : ', L2_norm - write(*,201) 'UV Linf_norm : ', Linf_norm - endif - endif -#else - - 200 format(i6.6,A,i6.6,A,e10.4) - 201 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4) - 202 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4) - 203 format(' ',A,i3.3,A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4) - - if(is_master()) write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay - -! Surface Pressure - psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - if(is_master()) write(*,*) ' Total surface pressure =', 0.01*psmo - call pmxn(ps, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - if (is_master()) then - write(*,201) 'PS MAX|MIN : ', 0.01*pmax, 0.01*pmin, i0, j0, n0 - endif - -! Get PT Stats - pmax1 = -1.e25 - pmin1 = 1.e25 - i0=-999 - j0=-999 - k0=-999 - n0=-999 - do k=1,npz - call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - pmin1 = min(pmin, pmin1) - pmax1 = max(pmax, pmax1) - if (pmax1 == pmax) k0 = k - enddo - if (is_master()) then - write(*,201) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 - endif - -#if defined(DEBUG_TEST_CASES) - if(is_master()) write(*,*) ' ' - do k=1,npz - pmax1 = -1.e25 - pmin1 = 1.e25 - i0=-999 - j0=-999 - k0=-999 - n0=-999 - call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - pmin1 = min(pmin, pmin1) - pmax1 = max(pmax, pmax1) - if (is_master()) then - write(*,202) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k, n0, 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) ) - endif - enddo - if(is_master()) write(*,*) ' ' -#endif - -! Get DELP Stats - pmax1 = -1.e25 - pmin1 = 1.e25 - i0=-999 - j0=-999 - k0=-999 - n0=-999 - do k=1,npz - call pmxn(delp(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - pmin1 = min(pmin, pmin1) - pmax1 = max(pmax, pmax1) - if (pmax1 == pmax) k0 = k - enddo - if (is_master()) then - write(*,201) 'Delp MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 - endif - -! Get UV Stats - uamax1 = -1.e25 - uamin1 = 1.e25 - i0=-999 - j0=-999 - k0=-999 - n0=-999 - do k=1,npz - call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) - call pmxn(ua(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - uamin1 = min(pmin, uamin1) - uamax1 = max(pmax, uamax1) - if (uamax1 == pmax) k0 = k - enddo - if (is_master()) then - write(*,201) 'U MAX|MIN : ', uamax1, uamin1, i0, j0, k0, n0 - endif - - vamax1 = -1.e25 - vamin1 = 1.e25 - i0=-999 - j0=-999 - k0=-999 - n0=-999 - do k=1,npz - call pmxn(va(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - vamin1 = min(pmin, vamin1) - vamax1 = max(pmax, vamax1) - if (vamax1 == pmax) k0 = k - enddo - if (is_master()) then - write(*,201) 'V MAX|MIN : ', vamax1, vamin1, i0, j0, k0, n0 - endif - -! Get Q Stats - pmax1 = -1.e25 - pmin1 = 1.e25 - i0=-999 - j0=-999 - k0=-999 - n0=-999 - do k=1,npz - call pmxn(q(isd,jsd,k,1), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - pmin1 = min(pmin, pmin1) - pmax1 = max(pmax, pmax1) - if (pmax1 == pmax) k0 = k - enddo - if (is_master()) then - write(*,201) 'Q MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 - endif - -! Get tracer Stats - do iq=2,ncnst - pmax1 = -1.e25 - pmin1 = 1.e25 - i0=-999 - j0=-999 - k0=-999 - n0=-999 - do k=1,npz - call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - pmin1 = min(pmin, pmin1) - pmax1 = max(pmax, pmax1) - if (pmax1 == pmax) k0 = k - enddo - if (is_master()) then - write(*,203) 'TR',iq-1,' MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 - endif - enddo - -#endif - - if (test_case == 12) then -! Get UV Stats - call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, & - pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile) - if (is_master()) then - write(*,201) 'UV(850) L1_norm : ', L1_norm - write(*,201) 'UV(850) L2_norm : ', L2_norm - write(*,201) 'UV(850) Linf_norm : ', Linf_norm - endif - endif - - tmass = 0.0 - tKE = 0.0 - tener = 0.0 - tvort = 0.0 -#if defined(SW_DYNAMICS) - do k=1,1 -#else - do k=1,npz -#endif -! Get conservation Stats - -! Conservation of Mass - temp(:,:) = delp(is:ie,js:je,k) - tmass0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - tmass = tmass + tmass0 - - !if (.not. allocated(u0, v0)) then - if (nt == 0) then - allocate(u0(isd:ied,jsd:jed+1,npz)) - allocate(v0(isd:ied+1,jsd:jed,npz)) - u0 = u - v0 = v - endif - - !! UA is the PERTURBATION now - up = u - u0 - vp = v - v0 - - call dtoa(up(isd,jsd,k), vp(isd,jsd,k), ua, va, dx,dy, dxa, dya, dxc, dyc, npx, npy, ng) - call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),dx,dy,dxa,dya,npx,npy,ng,nested, domain, noComm=.true.) -! Conservation of Kinetic Energy - do j=js,je - do i=is,ie - temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + & - vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) ) - enddo - enddo - tKE0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - tKE = tKE + tKE0 - -! Conservation of Energy - do j=js,je - do i=is,ie - temp(i,j) = 0.5 * (delp(i,j,k)/Grav) * temp(i,j) ! Include Previously calcullated KE - temp(i,j) = temp(i,j) + & - Grav*((delp(i,j,k)/Grav + phis(i,j))*(delp(i,j,k)/Grav + phis(i,j))) - & - phis(i,j)*phis(i,j) - enddo - enddo - tener0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - tener = tener + tener0 - -! Conservation of Potential Enstrophy - if (test_case>1) then - do j=js,je - do i=is,ie - temp(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - & - (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) ) - temp(i,j) = ( Grav*(temp(i,j)*temp(i,j))/delp(i,j,k) ) - enddo - enddo - tvort0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - tvort = tvort + tvort0 - else - tvort=1. - endif - enddo - - if (nt == 0) then - tmass_orig = tmass - tener_orig = tener - tvort_orig = tvort - endif - arr_r4(1) = (tmass-tmass_orig)/tmass_orig - arr_r4(2) = (tener-tener_orig)/tener_orig - arr_r4(3) = (tvort-tvort_orig)/tvort_orig - arr_r4(4) = tKE - if (test_case==12) arr_r4(4) = L2_norm -#if defined(SW_DYNAMICS) - myRec = nt+1 -#else - myRec = myDay*86400.0/dtout + 1 -#endif - if (is_master()) write(consv_lun,rec=myRec) arr_r4(1:4) -#if defined(SW_DYNAMICS) - if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then -#else - if ( (is_master()) ) then -#endif - write(*,201) 'MASS TOTAL : ', tmass - write(*,201) 'NORMALIZED MASS : ', (tmass-tmass_orig)/tmass_orig - if (test_case >= 2) then - write(*,201) 'Kinetic Energy KE : ', tKE - write(*,201) 'ENERGY TOTAL : ', tener - write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig - write(*,201) 'ENSTR TOTAL : ', tvort - write(*,201) 'NORMALIZED ENSTR : ', (tvort-tvort_orig)/tvort_orig - endif - write(*,*) ' ' - endif - - nullify(grid) - nullify(agrid) - nullify(area) - nullify(f0) - nullify(dx) - nullify(dy) - - end subroutine get_stats +!!$!------------------------------------------------------------------------------- +!!$! +!!$! get_stats :: get L-1, L-2, and L-inf norms and other stats as defined +!!$! in Williamson, 1994 (p.16) +!!$ subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, & +!!$ uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions, & +!!$ gridstruct, stats_lun, consv_lun, monitorFreq, tile, & +!!$ domain, bounded_domain, bd) +!!$ type(fv_grid_bounds_type), intent(IN) :: bd +!!$ integer, intent(IN) :: nt, maxnt +!!$ real , intent(IN) :: dt, dtout, ndays +!!$ real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) +!!$ real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) +!!$ real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) +!!$ real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) +!!$ real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) +!!$ real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed ) +!!$ real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed ) +!!$ real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) +!!$ real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) +!!$ real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) +!!$ real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) +!!$ integer, intent(IN) :: npx, npy, npz, ncnst, tile +!!$ integer, intent(IN) :: ndims +!!$ integer, intent(IN) :: nregions +!!$ integer, intent(IN) :: stats_lun +!!$ integer, intent(IN) :: consv_lun +!!$ integer, intent(IN) :: monitorFreq +!!$ type(fv_grid_type), target :: gridstruct +!!$ type(domain2d), intent(INOUT) :: domain +!!$ logical, intent(IN) :: bounded_domain +!!$ +!!$ real :: L1_norm +!!$ real :: L2_norm +!!$ real :: Linf_norm +!!$ real :: pmin, pmin1, uamin1, vamin1 +!!$ real :: pmax, pmax1, uamax1, vamax1 +!!$ real(kind=4) :: arr_r4(5) +!!$ real :: tmass0, tvort0, tener0, tKE0 +!!$ real :: tmass, tvort, tener, tKE +!!$ real :: temp(bd%is:bd%ie,bd%js:bd%je) +!!$ integer :: i0, j0, k0, n0 +!!$ integer :: i, j, k, n, iq +!!$ +!!$ real :: psmo, Vtx, p, w_p, p0 +!!$ real :: x1,y1,z1,x2,y2,z2,ang +!!$ +!!$ real :: p1(2), p2(2), p3(2), r, r0, dist, heading +!!$ +!!$ real :: uc0(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) +!!$ real :: vc0(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) +!!$ +!!$ real :: myDay +!!$ integer :: myRec +!!$ +!!$ real, save, allocatable, dimension(:,:,:) :: u0, v0 +!!$ real :: up(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) +!!$ real :: vp(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) +!!$ +!!$ real, dimension(:,:,:), pointer :: grid, agrid +!!$ real, dimension(:,:), pointer :: area, f0, dx, dy, dxa, dya, dxc, dyc +!!$ +!!$ integer :: is, ie, js, je +!!$ integer :: isd, ied, jsd, jed +!!$ +!!$ is = bd%is +!!$ ie = bd%ie +!!$ js = bd%js +!!$ je = bd%je +!!$ isd = bd%isd +!!$ ied = bd%ied +!!$ jsd = bd%jsd +!!$ jed = bd%jed +!!$ +!!$ grid => gridstruct%grid +!!$ agrid=> gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ f0 => gridstruct%f0 +!!$ +!!$ dx => gridstruct%dx +!!$ dy => gridstruct%dy +!!$ dxa => gridstruct%dxa +!!$ dya => gridstruct%dya +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ !!! DEBUG CODE +!!$ if (nt == 0 .and. is_master()) print*, 'INITIALIZING GET_STATS' +!!$ !!! END DEBUG CODE +!!$ +!!$ myDay = ndays*((FLOAT(nt)/FLOAT(maxnt))) +!!$ +!!$#if defined(SW_DYNAMICS) +!!$ if (test_case==0) then +!!$ phi0 = 0.0 +!!$ do j=js,je +!!$ do i=is,ie +!!$ x1 = agrid(i,j,1) +!!$ y1 = agrid(i,j,2) +!!$ z1 = radius +!!$ p = p0_c0 * cos(y1) +!!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) +!!$ w_p = 0.0 +!!$ if (p /= 0.0) w_p = Vtx/p +!!$ ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) +!!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) +!!$ enddo +!!$ enddo +!!$ elseif (test_case==1) then +!!$! Get Current Height Field "Truth" +!!$ p1(1) = pi/2. + pi_shift +!!$ p1(2) = 0. +!!$ p2(1) = 3.*pi/2. + pi_shift +!!$ p2(2) = 0. +!!$ r0 = radius/3. !RADIUS 3. +!!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) +!!$ heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha +!!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3) +!!$ phi0 = 0.0 +!!$ do j=js,je +!!$ do i=is,ie +!!$ p2(1) = agrid(i,j,1) +!!$ p2(2) = agrid(i,j,2) +!!$ r = great_circle_dist( p3, p2, radius ) +!!$ if (r < r0) then +!!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) +!!$ else +!!$ phi0(i,j,1) = phis(i,j) +!!$ endif +!!$ enddo +!!$ enddo +!!$ endif +!!$ +!!$! Get Height Field Stats +!!$ call pmxn(delp(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0) +!!$ pmin1=pmin1/Grav +!!$ pmax1=pmax1/Grav +!!$ if (test_case <= 2) then +!!$ call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, & +!!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) +!!$ pmin=pmin/Grav +!!$ pmax=pmax/Grav +!!$ arr_r4(1) = pmin1 +!!$ arr_r4(2) = pmax1 +!!$ arr_r4(3) = L1_norm +!!$ arr_r4(4) = L2_norm +!!$ arr_r4(5) = Linf_norm +!!$ !if (is_master()) write(stats_lun,rec=(nt)*2 + 1) arr_r4 +!!$ else +!!$ arr_r4(1) = pmin1 +!!$ arr_r4(2) = pmax1 +!!$ arr_r4(3:5) = 0. +!!$ pmin = 0. +!!$ pmax = 0. +!!$ L1_norm = 0. +!!$ L2_norm = 0. +!!$ Linf_norm = 0. +!!$ endif +!!$ +!!$ 200 format(i6.6,A,i6.6,A,e21.14) +!!$ 201 format(' ',A,e21.14,' ',e21.14) +!!$ 202 format(' ',A,i4.4,'x',i4.4,'x',i4.4) +!!$ +!!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0 ) then +!!$ write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay +!!$ write(*,201) 'Height MAX : ', pmax1 +!!$ write(*,201) 'Height MIN : ', pmin1 +!!$ write(*,202) 'HGT MAX location : ', i0, j0, n0 +!!$ if (test_case <= 2) then +!!$ write(*,201) 'Height L1_norm : ', L1_norm +!!$ write(*,201) 'Height L2_norm : ', L2_norm +!!$ write(*,201) 'Height Linf_norm : ', Linf_norm +!!$ endif +!!$ endif +!!$ +!!$! Get UV Stats +!!$ call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) +!!$ call pmxn(ua(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0) +!!$ if (test_case <= 2) then +!!$ call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, & +!!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile) +!!$ endif +!!$ arr_r4(1) = pmin1 +!!$ arr_r4(2) = pmax1 +!!$ arr_r4(3) = L1_norm +!!$ arr_r4(4) = L2_norm +!!$ arr_r4(5) = Linf_norm +!!$ !if (is_master()) write(stats_lun,rec=(nt)*2 + 2) arr_r4 +!!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then +!!$ write(*,201) 'UV MAX : ', pmax1 +!!$ write(*,201) 'UV MIN : ', pmin1 +!!$ write(*,202) 'UV MAX location : ', i0, j0, n0 +!!$ if (test_case <= 2) then +!!$ write(*,201) 'UV L1_norm : ', L1_norm +!!$ write(*,201) 'UV L2_norm : ', L2_norm +!!$ write(*,201) 'UV Linf_norm : ', Linf_norm +!!$ endif +!!$ endif +!!$#else +!!$ +!!$ 200 format(i6.6,A,i6.6,A,e10.4) +!!$ 201 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4) +!!$ 202 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4) +!!$ 203 format(' ',A,i3.3,A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4) +!!$ +!!$ if(is_master()) write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay +!!$ +!!$! Surface Pressure +!!$ psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ if(is_master()) write(*,*) ' Total surface pressure =', 0.01*psmo +!!$ call pmxn(ps, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ if (is_master()) then +!!$ write(*,201) 'PS MAX|MIN : ', 0.01*pmax, 0.01*pmin, i0, j0, n0 +!!$ endif +!!$ +!!$! Get PT Stats +!!$ pmax1 = -1.e25 +!!$ pmin1 = 1.e25 +!!$ i0=-999 +!!$ j0=-999 +!!$ k0=-999 +!!$ n0=-999 +!!$ do k=1,npz +!!$ call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ pmin1 = min(pmin, pmin1) +!!$ pmax1 = max(pmax, pmax1) +!!$ if (pmax1 == pmax) k0 = k +!!$ enddo +!!$ if (is_master()) then +!!$ write(*,201) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 +!!$ endif +!!$ +!!$#if defined(DEBUG_TEST_CASES) +!!$ if(is_master()) write(*,*) ' ' +!!$ do k=1,npz +!!$ pmax1 = -1.e25 +!!$ pmin1 = 1.e25 +!!$ i0=-999 +!!$ j0=-999 +!!$ k0=-999 +!!$ n0=-999 +!!$ call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ pmin1 = min(pmin, pmin1) +!!$ pmax1 = max(pmax, pmax1) +!!$ if (is_master()) then +!!$ write(*,202) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k, n0, 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) ) +!!$ endif +!!$ enddo +!!$ if(is_master()) write(*,*) ' ' +!!$#endif +!!$ +!!$! Get DELP Stats +!!$ pmax1 = -1.e25 +!!$ pmin1 = 1.e25 +!!$ i0=-999 +!!$ j0=-999 +!!$ k0=-999 +!!$ n0=-999 +!!$ do k=1,npz +!!$ call pmxn(delp(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ pmin1 = min(pmin, pmin1) +!!$ pmax1 = max(pmax, pmax1) +!!$ if (pmax1 == pmax) k0 = k +!!$ enddo +!!$ if (is_master()) then +!!$ write(*,201) 'Delp MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 +!!$ endif +!!$ +!!$! Get UV Stats +!!$ uamax1 = -1.e25 +!!$ uamin1 = 1.e25 +!!$ i0=-999 +!!$ j0=-999 +!!$ k0=-999 +!!$ n0=-999 +!!$ do k=1,npz +!!$ call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, bd%ng) +!!$ call pmxn(ua(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ uamin1 = min(pmin, uamin1) +!!$ uamax1 = max(pmax, uamax1) +!!$ if (uamax1 == pmax) k0 = k +!!$ enddo +!!$ if (is_master()) then +!!$ write(*,201) 'U MAX|MIN : ', uamax1, uamin1, i0, j0, k0, n0 +!!$ endif +!!$ +!!$ vamax1 = -1.e25 +!!$ vamin1 = 1.e25 +!!$ i0=-999 +!!$ j0=-999 +!!$ k0=-999 +!!$ n0=-999 +!!$ do k=1,npz +!!$ call pmxn(va(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ vamin1 = min(pmin, vamin1) +!!$ vamax1 = max(pmax, vamax1) +!!$ if (vamax1 == pmax) k0 = k +!!$ enddo +!!$ if (is_master()) then +!!$ write(*,201) 'V MAX|MIN : ', vamax1, vamin1, i0, j0, k0, n0 +!!$ endif +!!$ +!!$! Get Q Stats +!!$ pmax1 = -1.e25 +!!$ pmin1 = 1.e25 +!!$ i0=-999 +!!$ j0=-999 +!!$ k0=-999 +!!$ n0=-999 +!!$ do k=1,npz +!!$ call pmxn(q(isd,jsd,k,1), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ pmin1 = min(pmin, pmin1) +!!$ pmax1 = max(pmax, pmax1) +!!$ if (pmax1 == pmax) k0 = k +!!$ enddo +!!$ if (is_master()) then +!!$ write(*,201) 'Q MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 +!!$ endif +!!$ +!!$! Get tracer Stats +!!$ do iq=2,ncnst +!!$ pmax1 = -1.e25 +!!$ pmin1 = 1.e25 +!!$ i0=-999 +!!$ j0=-999 +!!$ k0=-999 +!!$ n0=-999 +!!$ do k=1,npz +!!$ call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ pmin1 = min(pmin, pmin1) +!!$ pmax1 = max(pmax, pmax1) +!!$ if (pmax1 == pmax) k0 = k +!!$ enddo +!!$ if (is_master()) then +!!$ write(*,203) 'TR',iq-1,' MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 +!!$ endif +!!$ enddo +!!$ +!!$#endif +!!$ +!!$ if (test_case == 12) then +!!$! Get UV Stats +!!$ call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, & +!!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) +!!$ if (is_master()) then +!!$ write(*,201) 'UV(850) L1_norm : ', L1_norm +!!$ write(*,201) 'UV(850) L2_norm : ', L2_norm +!!$ write(*,201) 'UV(850) Linf_norm : ', Linf_norm +!!$ endif +!!$ endif +!!$ +!!$ tmass = 0.0 +!!$ tKE = 0.0 +!!$ tener = 0.0 +!!$ tvort = 0.0 +!!$#if defined(SW_DYNAMICS) +!!$ do k=1,1 +!!$#else +!!$ do k=1,npz +!!$#endif +!!$! Get conservation Stats +!!$ +!!$! Conservation of Mass +!!$ temp(:,:) = delp(is:ie,js:je,k) +!!$ tmass0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ tmass = tmass + tmass0 +!!$ +!!$ !if (.not. allocated(u0, v0)) then +!!$ if (nt == 0) then +!!$ allocate(u0(isd:ied,jsd:jed+1,npz)) +!!$ allocate(v0(isd:ied+1,jsd:jed,npz)) +!!$ u0 = u +!!$ v0 = v +!!$ endif +!!$ +!!$ !! UA is the PERTURBATION now +!!$ up = u - u0 +!!$ vp = v - v0 +!!$ +!!$ call dtoa(up(isd,jsd,k), vp(isd,jsd,k), ua, va, dx,dy, dxa, dya, dxc, dyc, npx, npy, bd%ng) +!!$ call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),dx,dy,dxa,dya,npx,npy,bd%ng,bounded_domain, domain, noComm=.true.) +!!$! Conservation of Kinetic Energy +!!$ do j=js,je +!!$ do i=is,ie +!!$ temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + & +!!$ vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) ) +!!$ enddo +!!$ enddo +!!$ tKE0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ tKE = tKE + tKE0 +!!$ +!!$! Conservation of Energy +!!$ do j=js,je +!!$ do i=is,ie +!!$ temp(i,j) = 0.5 * (delp(i,j,k)/Grav) * temp(i,j) ! Include Previously calcullated KE +!!$ temp(i,j) = temp(i,j) + & +!!$ Grav*((delp(i,j,k)/Grav + phis(i,j))*(delp(i,j,k)/Grav + phis(i,j))) - & +!!$ phis(i,j)*phis(i,j) +!!$ enddo +!!$ enddo +!!$ tener0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ tener = tener + tener0 +!!$ +!!$! Conservation of Potential Enstrophy +!!$ if (test_case>1) then +!!$ do j=js,je +!!$ do i=is,ie +!!$ temp(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - & +!!$ (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) ) +!!$ temp(i,j) = ( Grav*(temp(i,j)*temp(i,j))/delp(i,j,k) ) +!!$ enddo +!!$ enddo +!!$ tvort0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ tvort = tvort + tvort0 +!!$ else +!!$ tvort=1. +!!$ endif +!!$ enddo +!!$ +!!$ if (nt == 0) then +!!$ tmass_orig = tmass +!!$ tener_orig = tener +!!$ tvort_orig = tvort +!!$ endif +!!$ arr_r4(1) = (tmass-tmass_orig)/tmass_orig +!!$ arr_r4(2) = (tener-tener_orig)/tener_orig +!!$ arr_r4(3) = (tvort-tvort_orig)/tvort_orig +!!$ arr_r4(4) = tKE +!!$ if (test_case==12) arr_r4(4) = L2_norm +!!$#if defined(SW_DYNAMICS) +!!$ myRec = nt+1 +!!$#else +!!$ myRec = myDay*86400.0/dtout + 1 +!!$#endif +!!$ if (is_master()) write(consv_lun,rec=myRec) arr_r4(1:4) +!!$#if defined(SW_DYNAMICS) +!!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then +!!$#else +!!$ if ( (is_master()) ) then +!!$#endif +!!$ write(*,201) 'MASS TOTAL : ', tmass +!!$ write(*,201) 'NORMALIZED MASS : ', (tmass-tmass_orig)/tmass_orig +!!$ if (test_case >= 2) then +!!$ write(*,201) 'Kinetic Energy KE : ', tKE +!!$ write(*,201) 'ENERGY TOTAL : ', tener +!!$ write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig +!!$ write(*,201) 'ENSTR TOTAL : ', tvort +!!$ write(*,201) 'NORMALIZED ENSTR : ', (tvort-tvort_orig)/tvort_orig +!!$ endif +!!$ write(*,*) ' ' +!!$ endif +!!$ +!!$ nullify(grid) +!!$ nullify(agrid) +!!$ nullify(area) +!!$ nullify(f0) +!!$ nullify(dx) +!!$ nullify(dy) +!!$ +!!$ end subroutine get_stats @@ -5003,2494 +5079,2326 @@ end subroutine get_pt_on_great_circle ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! !------------------------------------------------------------------------------- +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! +!!$! get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined +!!$! in Williamson, 1994 (p.16) +!!$! for any var +!!$ +!!$ subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, & +!!$ vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) +!!$ type(fv_grid_bounds_type), intent(IN) :: bd +!!$ integer, intent(IN) :: npx, npy +!!$ integer, intent(IN) :: ndims +!!$ integer, intent(IN) :: nregions, tile +!!$ real , intent(IN) :: var(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real , intent(IN) :: varT(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real , intent(OUT) :: vmin +!!$ real , intent(OUT) :: vmax +!!$ real , intent(OUT) :: L1_norm +!!$ real , intent(OUT) :: L2_norm +!!$ real , intent(OUT) :: Linf_norm +!!$ +!!$ type(fv_grid_type), target :: gridstruct +!!$ +!!$ real :: vmean +!!$ real :: vvar +!!$ real :: vmin1 +!!$ real :: vmax1 +!!$ real :: pdiffmn +!!$ real :: pdiffmx +!!$ +!!$ real :: varSUM, varSUM2, varMAX +!!$ real :: gsum +!!$ real :: vminT, vmaxT, vmeanT, vvarT +!!$ integer :: i0, j0, n0 +!!$ +!!$ real, dimension(:,:,:), pointer :: grid, agrid +!!$ real, dimension(:,:), pointer :: area +!!$ +!!$ integer :: is, ie, js, je +!!$ integer :: isd, ied, jsd, jed, ng +!!$ +!!$ is = bd%is +!!$ ie = bd%ie +!!$ js = bd%js +!!$ je = bd%je +!!$ isd = bd%isd +!!$ ied = bd%ied +!!$ jsd = bd%jsd +!!$ jed = bd%jed +!!$ ng = bd%ng +!!$ +!!$ grid => gridstruct%grid +!!$ agrid=> gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ +!!$ varSUM = 0. +!!$ varSUM2 = 0. +!!$ varMAX = 0. +!!$ L1_norm = 0. +!!$ L2_norm = 0. +!!$ Linf_norm = 0. +!!$ vmean = 0. +!!$ vvar = 0. +!!$ vmax = 0. +!!$ vmin = 0. +!!$ pdiffmn= 0. +!!$ pdiffmx= 0. +!!$ vmeanT = 0. +!!$ vvarT = 0. +!!$ vmaxT = 0. +!!$ vminT = 0. +!!$ +!!$ vmean = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ vmeanT = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ vmean = vmean / (4.0*pi) +!!$ vmeanT = vmeanT / (4.0*pi) +!!$ +!!$ call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin , vmax , i0, j0, n0) +!!$ call pmxn(varT, npx, npy, nregions, tile, gridstruct, vminT, vmaxT, i0, j0, n0) +!!$ call pmxn(var-varT, npx, npy, nregions, tile, gridstruct, pdiffmn, pdiffmx, i0, j0, n0) +!!$ +!!$ vmax = (vmax - vmaxT) / (vmaxT-vminT) +!!$ vmin = (vmin - vminT) / (vmaxT-vminT) +!!$ +!!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ varSUM2 = globalsum(varT(is:ie,js:je)**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ L1_norm = globalsum(ABS(var(is:ie,js:je)-varT(is:ie,js:je)), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ L2_norm = globalsum((var(is:ie,js:je)-varT(is:ie,js:je))**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ L1_norm = L1_norm/varSUM +!!$ L2_norm = SQRT(L2_norm)/SQRT(varSUM2) +!!$ +!!$ call pmxn(ABS(varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) +!!$ varMAX = vmax +!!$ call pmxn(ABS(var-varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) +!!$ Linf_norm = vmax/varMAX +!!$ +!!$ end subroutine get_scalar_stats +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- +!!$ +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! +!!$! get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined +!!$! in Williamson, 1994 (p.16) +!!$! for any var +!!$ +!!$ subroutine get_vector_stats(varU, varUT, varV, varVT, & +!!$ npx, npy, ndims, nregions, & +!!$ vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) +!!$ type(fv_grid_bounds_type), intent(IN) :: bd +!!$ integer, intent(IN) :: npx, npy +!!$ integer, intent(IN) :: ndims +!!$ integer, intent(IN) :: nregions, tile +!!$ real , intent(IN) :: varU(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real , intent(IN) :: varUT(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real , intent(IN) :: varV(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real , intent(IN) :: varVT(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real , intent(OUT) :: vmin +!!$ real , intent(OUT) :: vmax +!!$ real , intent(OUT) :: L1_norm +!!$ real , intent(OUT) :: L2_norm +!!$ real , intent(OUT) :: Linf_norm +!!$ +!!$ real :: var(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real :: varT(bd%isd:bd%ied,bd%jsd:bd%jed) +!!$ real :: vmean +!!$ real :: vvar +!!$ real :: vmin1 +!!$ real :: vmax1 +!!$ real :: pdiffmn +!!$ real :: pdiffmx +!!$ +!!$ real :: varSUM, varSUM2, varMAX +!!$ real :: gsum +!!$ real :: vminT, vmaxT, vmeanT, vvarT +!!$ integer :: i,j,n +!!$ integer :: i0, j0, n0 +!!$ +!!$ type(fv_grid_type), target :: gridstruct +!!$ +!!$ real, dimension(:,:,:), pointer :: grid, agrid +!!$ real, dimension(:,:), pointer :: area +!!$ +!!$ integer :: is, ie, js, je +!!$ integer :: isd, ied, jsd, jed, ng +!!$ +!!$ is = bd%is +!!$ ie = bd%ie +!!$ js = bd%js +!!$ je = bd%je +!!$ isd = bd%isd +!!$ ied = bd%ied +!!$ jsd = bd%jsd +!!$ jed = bd%jed +!!$ ng = bd%ng +!!$ +!!$ grid => gridstruct%grid +!!$ agrid=> gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ +!!$ varSUM = 0. +!!$ varSUM2 = 0. +!!$ varMAX = 0. +!!$ L1_norm = 0. +!!$ L2_norm = 0. +!!$ Linf_norm = 0. +!!$ vmean = 0. +!!$ vvar = 0. +!!$ vmax = 0. +!!$ vmin = 0. +!!$ pdiffmn= 0. +!!$ pdiffmx= 0. +!!$ vmeanT = 0. +!!$ vvarT = 0. +!!$ vmaxT = 0. +!!$ vminT = 0. +!!$ +!!$ do j=js,je +!!$ do i=is,ie +!!$ var(i,j) = SQRT( (varU(i,j)-varUT(i,j))**2. + & +!!$ (varV(i,j)-varVT(i,j))**2. ) +!!$ varT(i,j) = SQRT( varUT(i,j)*varUT(i,j) + & +!!$ varVT(i,j)*varVT(i,j) ) +!!$ enddo +!!$ enddo +!!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ L1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ L1_norm = L1_norm/varSUM +!!$ +!!$ call pmxn(varT, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) +!!$ varMAX = vmax +!!$ call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) +!!$ Linf_norm = vmax/varMAX +!!$ +!!$ do j=js,je +!!$ do i=is,ie +!!$ var(i,j) = ( (varU(i,j)-varUT(i,j))**2. + & +!!$ (varV(i,j)-varVT(i,j))**2. ) +!!$ varT(i,j) = ( varUT(i,j)*varUT(i,j) + & +!!$ varVT(i,j)*varVT(i,j) ) +!!$ enddo +!!$ enddo +!!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ L2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) +!!$ L2_norm = SQRT(L2_norm)/SQRT(varSUM) +!!$ +!!$ end subroutine get_vector_stats +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- + +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! +!!$! check_courant_numbers :: +!!$! +!!$ subroutine check_courant_numbers(uc,vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint) +!!$ +!!$ real, intent(IN) :: ndt +!!$ integer, intent(IN) :: n_split +!!$ integer, intent(IN) :: npx, npy, npz, tile +!!$ logical, OPTIONAL, intent(IN) :: noPrint +!!$ real , intent(IN) :: uc(isd:ied+1,jsd:jed ,npz) +!!$ real , intent(IN) :: vc(isd:ied ,jsd:jed+1,npz) +!!$ +!!$ real :: ideal_c=0.06 +!!$ real :: tolerance= 1.e-3 +!!$ real :: dt_inc, dt_orig +!!$ real :: meanCy, minCy, maxCy, meanCx, minCx, maxCx +!!$ +!!$ real :: counter +!!$ logical :: ideal +!!$ +!!$ integer :: i,j,k +!!$ real :: dt +!!$ +!!$ type(fv_grid_type), intent(IN), target :: gridstruct +!!$ real, dimension(:,:), pointer :: dxc, dyc +!!$ +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ dt = ndt/real(n_split) +!!$ +!!$ 300 format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14) +!!$ +!!$ dt_orig = dt +!!$ dt_inc = 1 +!!$ ideal = .false. +!!$ +!!$ do while(.not. ideal) +!!$ +!!$ counter = 0 +!!$ minCy = missing +!!$ maxCy = -1.*missing +!!$ minCx = missing +!!$ maxCx = -1.*missing +!!$ meanCx = 0 +!!$ meanCy = 0 +!!$ do k=1,npz +!!$ do j=js,je +!!$ do i=is,ie+1 +!!$ minCx = MIN(minCx, ABS( (dt/dxc(i,j))*uc(i,j,k) )) +!!$ maxCx = MAX(maxCx, ABS( (dt/dxc(i,j))*uc(i,j,k) )) +!!$ meanCx = meanCx + ABS( (dt/dxc(i,j))*uc(i,j,k) ) +!!$ +!!$ if (ABS( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then +!!$ counter = counter+1 +!!$ write(*,300) i,j,k,tile, ABS( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter +!!$ call exit(1) +!!$ endif +!!$ +!!$ enddo +!!$ enddo +!!$ do j=js,je+1 +!!$ do i=is,ie +!!$ minCy = MIN(minCy, ABS( (dt/dyc(i,j))*vc(i,j,k) )) +!!$ maxCy = MAX(maxCy, ABS( (dt/dyc(i,j))*vc(i,j,k) )) +!!$ meanCy = meanCy + ABS( (dt/dyc(i,j))*vc(i,j,k) ) +!!$ +!!$ if (ABS( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then +!!$ counter = counter+1 +!!$ write(*,300) i,j,k,tile, ABS( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter +!!$ call exit(1) +!!$ endif +!!$ +!!$ enddo +!!$ enddo +!!$ enddo +!!$ +!!$ call mp_reduce_max(maxCx) +!!$ call mp_reduce_max(maxCy) +!!$ minCx = -minCx +!!$ minCy = -minCy +!!$ call mp_reduce_max(minCx) +!!$ call mp_reduce_max(minCy) +!!$ minCx = -minCx +!!$ minCy = -minCy +!!$ call mp_reduce_sum(meanCx) +!!$ call mp_reduce_sum(meanCy) +!!$ meanCx = meanCx/(6.0*DBLE(npx)*DBLE(npy-1)) +!!$ meanCy = meanCy/(6.0*DBLE(npx-1)*DBLE(npy)) +!!$ +!!$ !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then +!!$ ideal = .true. +!!$ !elseif (maxCy-ideal_c > 0) then +!!$ ! dt = dt - dt_inc +!!$ !else +!!$ ! dt = dt + dt_inc +!!$ !endif +!!$ +!!$ enddo +!!$ +!!$ if ( (.not. present(noPrint)) .and. (is_master()) ) then +!!$ print*, '' +!!$ print*, '--------------------------------------------' +!!$ print*, 'Y-dir Courant number MIN : ', minCy +!!$ print*, 'Y-dir Courant number MAX : ', maxCy +!!$ print*, '' +!!$ print*, 'X-dir Courant number MIN : ', minCx +!!$ print*, 'X-dir Courant number MAX : ', maxCx +!!$ print*, '' +!!$ print*, 'X-dir Courant number MEAN : ', meanCx +!!$ print*, 'Y-dir Courant number MEAN : ', meanCy +!!$ print*, '' +!!$ print*, 'NDT: ', ndt +!!$ print*, 'n_split: ', n_split +!!$ print*, 'DT: ', dt +!!$ print*, '' +!!$ print*, '--------------------------------------------' +!!$ print*, '' +!!$ endif +!!$ +!!$ end subroutine check_courant_numbers +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- + +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! +!!$! pmxn :: find max and min of field p +!!$! +!!$ subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) +!!$ integer, intent(IN) :: npx +!!$ integer, intent(IN) :: npy +!!$ integer, intent(IN) :: nregions, tile +!!$ real , intent(IN) :: p(isd:ied,jsd:jed) +!!$ type(fv_grid_type), intent(IN), target :: gridstruct +!!$ real , intent(OUT) :: pmin +!!$ real , intent(OUT) :: pmax +!!$ integer, intent(OUT) :: i0 +!!$ integer, intent(OUT) :: j0 +!!$ integer, intent(OUT) :: n0 +!!$ +!!$ real :: temp +!!$ integer :: i,j,n +!!$ +!!$ +!!$ real, pointer, dimension(:,:,:) :: agrid, grid +!!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0 +!!$ real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 +!!$ real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es +!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc +!!$ +!!$ logical, pointer :: cubed_sphere, latlon +!!$ +!!$ logical, pointer :: have_south_pole, have_north_pole +!!$ +!!$ integer, pointer :: ntiles_g +!!$ real, pointer :: acapN, acapS, globalarea +!!$ +!!$ grid => gridstruct%grid +!!$ agrid=> gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ rarea => gridstruct%rarea +!!$ +!!$ fC => gridstruct%fC +!!$ f0 => gridstruct%f0 +!!$ +!!$ ee1 => gridstruct%ee1 +!!$ ee2 => gridstruct%ee2 +!!$ ew => gridstruct%ew +!!$ es => gridstruct%es +!!$ en1 => gridstruct%en1 +!!$ en2 => gridstruct%en2 +!!$ +!!$ dx => gridstruct%dx +!!$ dy => gridstruct%dy +!!$ dxa => gridstruct%dxa +!!$ dya => gridstruct%dya +!!$ rdxa => gridstruct%rdxa +!!$ rdya => gridstruct%rdya +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ cubed_sphere => gridstruct%cubed_sphere +!!$ latlon => gridstruct%latlon +!!$ +!!$ have_south_pole => gridstruct%have_south_pole +!!$ have_north_pole => gridstruct%have_north_pole +!!$ +!!$ ntiles_g => gridstruct%ntiles_g +!!$ acapN => gridstruct%acapN +!!$ acapS => gridstruct%acapS +!!$ globalarea => gridstruct%globalarea +!!$ +!!$ pmax = -1.e25 +!!$ pmin = 1.e25 +!!$ i0 = -999 +!!$ j0 = -999 +!!$ n0 = tile +!!$ +!!$ do j=js,je +!!$ do i=is,ie +!!$ temp = p(i,j) +!!$ if (temp > pmax) then +!!$ pmax = temp +!!$ i0 = i +!!$ j0 = j +!!$ elseif (temp < pmin) then +!!$ pmin = temp +!!$ endif +!!$ enddo +!!$ enddo +!!$ +!!$ temp = pmax +!!$ call mp_reduce_max(temp) +!!$ if (temp /= pmax) then +!!$ i0 = -999 +!!$ j0 = -999 +!!$ n0 = -999 +!!$ endif +!!$ pmax = temp +!!$ call mp_reduce_max(i0) +!!$ call mp_reduce_max(j0) +!!$ call mp_reduce_max(n0) +!!$ +!!$ pmin = -pmin +!!$ call mp_reduce_max(pmin) +!!$ pmin = -pmin +!!$ +!!$ end subroutine pmxn +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- +!!$ +!!$!! These routines are no longer used +!!$#ifdef NCDF_OUTPUT +!!$ +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! +!!$! output_ncdf :: write out NETCDF fields +!!$! +!!$ subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, & +!!$ omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, & +!!$ npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, & +!!$ phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids, & +!!$ lats_id, lons_id, gridstruct, flagstruct) +!!$ real, intent(IN) :: dt +!!$ integer, intent(IN) :: nt, maxnt +!!$ integer, intent(INOUT) :: nout +!!$ +!!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) +!!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) +!!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) +!!$ +!!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) +!!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) +!!$ +!!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) +!!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) +!!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: omga(isd:ied ,jsd:jed ,npz) +!!$ +!!$ integer, intent(IN) :: npx, npy, npz +!!$ integer, intent(IN) :: ng, ncnst +!!$ integer, intent(IN) :: ndims +!!$ integer, intent(IN) :: nregions +!!$ integer, intent(IN) :: ncid +!!$ integer, intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id +!!$ integer, intent(IN) :: ntiles_id, nt_id +!!$ integer, intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id +!!$ integer, intent(IN) :: om_id ! omega (dp/dt) +!!$ integer, intent(IN) :: tracers_ids(ncnst-1) +!!$ integer, intent(IN) :: lats_id, lons_id +!!$ +!!$ type(fv_grid_type), target :: gridstruct +!!$ type(fv_flags_type), intent(IN) :: flagstruct +!!$ +!!$ real, allocatable :: tmp(:,:,:) +!!$ real, allocatable :: tmpA(:,:,:) +!!$#if defined(SW_DYNAMICS) +!!$ real, allocatable :: ut(:,:,:) +!!$ real, allocatable :: vt(:,:,:) +!!$#else +!!$ real, allocatable :: ut(:,:,:,:) +!!$ real, allocatable :: vt(:,:,:,:) +!!$ real, allocatable :: tmpA_3d(:,:,:,:) +!!$#endif +!!$ real, allocatable :: vort(:,:) +!!$ +!!$ real :: p1(2) ! Temporary Point +!!$ real :: p2(2) ! Temporary Point +!!$ real :: p3(2) ! Temporary Point +!!$ real :: p4(2) ! Temporary Point +!!$ real :: pa(2) ! Temporary Point +!!$ real :: utmp, vtmp, r, r0, dist, heading +!!$ integer :: i,j,k,n,iq,nreg +!!$ +!!$ real :: Vtx, p, w_p +!!$ real :: x1,y1,z1,x2,y2,z2,ang +!!$ +!!$ real, pointer, dimension(:,:,:) :: agrid, grid +!!$ real, pointer, dimension(:,:) :: area, rarea +!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc +!!$ +!!$ grid => gridstruct%grid +!!$ agrid => gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ rarea => gridstruct%rarea +!!$ +!!$ dx => gridstruct%dx +!!$ dy => gridstruct%dy +!!$ dxa => gridstruct%dxa +!!$ dya => gridstruct%dya +!!$ rdxa => gridstruct%rdxa +!!$ rdya => gridstruct%rdya +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ allocate( tmp(npx ,npy ,nregions) ) +!!$ allocate( tmpA(npx-1,npy-1,nregions) ) +!!$#if defined(SW_DYNAMICS) +!!$ allocate( ut(npx-1,npy-1,nregions) ) +!!$ allocate( vt(npx-1,npy-1,nregions) ) +!!$#else +!!$ allocate( ut(npx-1,npy-1,npz,nregions) ) +!!$ allocate( vt(npx-1,npy-1,npz,nregions) ) +!!$ allocate( tmpA_3d(npx-1,npy-1,npz,nregions) ) +!!$#endif +!!$ allocate( vort(isd:ied,jsd:jed) ) +!!$ +!!$ nout = nout + 1 +!!$ +!!$ if (nt==0) then +!!$ tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2) +!!$ call wrtvar_ncdf(ncid, lats_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3) +!!$ tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1) +!!$ call wrtvar_ncdf(ncid, lons_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3) +!!$ endif +!!$ +!!$#if defined(SW_DYNAMICS) +!!$ if (test_case > 1) then +!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav +!!$ +!!$ if ((nt==0) .and. (test_case==2)) then +!!$ Ubar = (2.0*pi*radius)/(12.0*86400.0) +!!$ gh0 = 2.94e4 +!!$ phis = 0.0 +!!$ do j=js,je+1 +!!$ do i=is,ie+1 +!!$ tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * & +!!$ ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + & +!!$ sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav +!!$ enddo +!!$ enddo +!!$ endif +!!$ +!!$ else +!!$ +!!$ if (test_case==1) then +!!$! Get Current Height Field "Truth" +!!$ p1(1) = pi/2. + pi_shift +!!$ p1(2) = 0. +!!$ p2(1) = 3.*pi/2. + pi_shift +!!$ p2(2) = 0. +!!$ r0 = radius/3. !RADIUS /3. +!!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) +!!$ heading = 5.0*pi/2.0 - alpha +!!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3) +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ p2(1) = agrid(i,j,1) +!!$ p2(2) = agrid(i,j,2) +!!$ r = great_circle_dist( p3, p2, radius ) +!!$ if (r < r0) then +!!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) +!!$ else +!!$ phi0(i,j,1) = phis(i,j) +!!$ endif +!!$ enddo +!!$ enddo +!!$ elseif (test_case == 0) then +!!$ phi0 = 0.0 +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ x1 = agrid(i,j,1) +!!$ y1 = agrid(i,j,2) +!!$ z1 = radius +!!$ p = p0_c0 * cos(y1) +!!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) +!!$ w_p = 0.0 +!!$ if (p /= 0.0) w_p = Vtx/p +!!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) +!!$ enddo +!!$ enddo +!!$ endif +!!$ +!!$ tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1) +!!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) +!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1) +!!$ endif +!!$ call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) +!!$ +!!$ if (test_case == 9) then +!!$! Calc Vorticity +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - & +!!$ (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) ) +!!$ vort(i,j) = Grav*vort(i,j)/delp(i,j,1) +!!$ enddo +!!$ enddo +!!$ tmpA(is:ie,js:je,tile) = vort(is:ie,js:je) +!!$ call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) +!!$ endif +!!$ +!!$ call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, 1, 1, gridstruct%grid_type, gridstruct%bounded_domain, flagstruct%c2l_ord, bd) +!!$ do j=js,je +!!$ do i=is,ie +!!$ ut(i,j,tile) = ua(i,j,1) +!!$ vt(i,j,tile) = va(i,j,1) +!!$ enddo +!!$ enddo +!!$ +!!$ call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:nregions), 3) +!!$ call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:nregions), 3) +!!$ +!!$ if ((test_case >= 2) .and. (nt==0) ) then +!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav +!!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) +!!$ endif +!!$#else +!!$ +!!$! Write Moisture Data +!!$ tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1) +!!$ call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) +!!$ +!!$! Write Tracer Data +!!$ do iq=2,ncnst +!!$ tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq) +!!$ call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) +!!$ enddo +!!$ +!!$! Write Surface height data +!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav +!!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3) +!!$ +!!$! Write Pressure Data +!!$ tmpA(is:ie,js:je,tile) = ps(is:ie,js:je) +!!$ call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3) +!!$ do k=1,npz +!!$ tmpA_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/Grav +!!$ enddo +!!$ call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) +!!$ +!!$! Write PT Data +!!$ do k=1,npz +!!$ tmpA_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k) +!!$ enddo +!!$ call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) +!!$ +!!$! Write U,V Data +!!$ call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, npz, gridstruct%grid_type, gridstruct%bounded_domain, flagstruct%c2l_ord) +!!$ do k=1,npz +!!$ do j=js,je +!!$ do i=is,ie +!!$ ut(i,j,k,tile) = ua(i,j,k) +!!$ vt(i,j,k,tile) = va(i,j,k) +!!$ enddo +!!$ enddo +!!$ enddo +!!$ call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:npz,1:nregions), 4) +!!$ call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:npz,1:nregions), 4) +!!$ +!!$ +!!$! Calc Vorticity +!!$ do k=1,npz +!!$ do j=js,je +!!$ do i=is,ie +!!$ tmpA_3d(i,j,k,tile) = rarea(i,j) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - & +!!$ (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) ) +!!$ enddo +!!$ enddo +!!$ enddo +!!$ call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) +!!$! +!!$! Output omega (dp/dt): +!!$ do k=1,npz +!!$ do j=js,je +!!$ do i=is,ie +!!$ tmpA_3d(i,j,k,tile) = omga(i,j,k) +!!$ enddo +!!$ enddo +!!$ enddo +!!$ call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) +!!$ +!!$#endif +!!$ +!!$ deallocate( tmp ) +!!$ deallocate( tmpA ) +!!$#if defined(SW_DYNAMICS) +!!$ deallocate( ut ) +!!$ deallocate( vt ) +!!$#else +!!$ deallocate( ut ) +!!$ deallocate( vt ) +!!$ deallocate( tmpA_3d ) +!!$#endif +!!$ deallocate( vort ) +!!$ +!!$ nullify(grid) +!!$ nullify(agrid) +!!$ +!!$ nullify(area) +!!$ +!!$ nullify(dx) +!!$ nullify(dy) +!!$ nullify(dxa) +!!$ nullify(dya) +!!$ nullify(rdxa) +!!$ nullify(rdya) +!!$ nullify(dxc) +!!$ nullify(dyc) +!!$ +!!$ end subroutine output_ncdf +!!$ +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- +!!$ +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! +!!$! output :: write out fields +!!$! +!!$ subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, & +!!$ npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, & +!!$ pt_lun, pv_lun, uv_lun, gridstruct) +!!$ +!!$ real, intent(IN) :: dt +!!$ integer, intent(IN) :: nt, maxnt +!!$ integer, intent(INOUT) :: nout +!!$ +!!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) +!!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) +!!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) +!!$ +!!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) +!!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) +!!$ +!!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) +!!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) +!!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) +!!$ +!!$ integer, intent(IN) :: npx, npy, npz +!!$ integer, intent(IN) :: ng, ncnst +!!$ integer, intent(IN) :: ndims +!!$ integer, intent(IN) :: nregions +!!$ integer, intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun +!!$ +!!$ type(fv_grid_type), target :: gridstruct +!!$ +!!$ real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions) +!!$ real :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions) +!!$ real :: p1(2) ! Temporary Point +!!$ real :: p2(2) ! Temporary Point +!!$ real :: p3(2) ! Temporary Point +!!$ real :: p4(2) ! Temporary Point +!!$ real :: pa(2) ! Temporary Point +!!$ real :: ut(1:npx,1:npy,1:nregions) +!!$ real :: vt(1:npx,1:npy,1:nregions) +!!$ real :: utmp, vtmp, r, r0, dist, heading +!!$ integer :: i,j,k,n,nreg +!!$ real :: vort(isd:ied,jsd:jed) +!!$ +!!$ real :: Vtx, p, w_p +!!$ real :: x1,y1,z1,x2,y2,z2,ang +!!$ +!!$ real, pointer, dimension(:,:,:) :: agrid, grid +!!$ real, pointer, dimension(:,:) :: area, rarea +!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc +!!$ +!!$ grid => gridstruct%grid +!!$ agrid => gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ +!!$ dx => gridstruct%dx +!!$ dy => gridstruct%dy +!!$ dxa => gridstruct%dxa +!!$ dya => gridstruct%dya +!!$ rdxa => gridstruct%rdxa +!!$ rdya => gridstruct%rdya +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ cubed_sphere => gridstruct%cubed_sphere +!!$ +!!$ nout = nout + 1 +!!$ +!!$#if defined(SW_DYNAMICS) +!!$ if (test_case > 1) then +!!$ call atob_s(delp(:,:,1)/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) +!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav +!!$ +!!$ if ((nt==0) .and. (test_case==2)) then +!!$ Ubar = (2.0*pi*radius)/(12.0*86400.0) +!!$ gh0 = 2.94e4 +!!$ phis = 0.0 +!!$ do j=js,je+1 +!!$ do i=is,ie+1 +!!$ tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * & +!!$ ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + & +!!$ sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav +!!$ enddo +!!$ enddo +!!$ endif +!!$ +!!$ else +!!$ +!!$ if (test_case==1) then +!!$! Get Current Height Field "Truth" +!!$ p1(1) = pi/2. + pi_shift +!!$ p1(2) = 0. +!!$ p2(1) = 3.*pi/2. + pi_shift +!!$ p2(2) = 0. +!!$ r0 = radius/3. !RADIUS /3. +!!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) +!!$ heading = 5.0*pi/2.0 - alpha +!!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3) +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ p2(1) = agrid(i,j,1) +!!$ p2(2) = agrid(i,j,2) +!!$ r = great_circle_dist( p3, p2, radius ) +!!$ if (r < r0) then +!!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) +!!$ else +!!$ phi0(i,j,1) = phis(i,j) +!!$ endif +!!$ enddo +!!$ enddo +!!$ elseif (test_case == 0) then +!!$ phi0 = 0.0 +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ x1 = agrid(i,j,1) +!!$ y1 = agrid(i,j,2) +!!$ z1 = radius +!!$ p = p0_c0 * cos(y1) +!!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) +!!$ w_p = 0.0 +!!$ if (p /= 0.0) w_p = Vtx/p +!!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) +!!$ enddo +!!$ enddo +!!$ endif +!!$ +!!$ call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) +!!$ tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1) +!!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) +!!$ call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) +!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1) +!!$ endif +!!$ ! call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) +!!$ call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) +!!$ +!!$ if (test_case == 9) then +!!$! Calc Vorticity +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - & +!!$ (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) ) +!!$ vort(i,j) = Grav*vort(i,j)/delp(i,j,1) +!!$ enddo +!!$ enddo +!!$ call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) +!!$ call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) +!!$ endif +!!$ +!!$ call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) +!!$! Rotate winds to standard Lat-Lon orientation +!!$ if (cubed_sphere) then +!!$ do j=js,je +!!$ do i=is,ie +!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1) +!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2) +!!$ call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3) +!!$ call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4) +!!$ utmp = ua(i,j,1) +!!$ vtmp = va(i,j,1) +!!$ if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2) +!!$ ut(i,j,tile) = utmp +!!$ vt(i,j,tile) = vtmp +!!$ enddo +!!$ enddo +!!$ endif +!!$ +!!$ call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions)) +!!$ call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions)) +!!$ +!!$ if ((test_case >= 2) .and. (nt==0) ) then +!!$ call atob_s(phis/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) +!!$ ! call wrt2d(phis_lun, nout , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) +!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav +!!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) +!!$ endif +!!$#else +!!$ +!!$! Write Surface height data +!!$ if (nt==0) then +!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav +!!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) +!!$ endif +!!$ +!!$! Write Pressure Data +!!$ +!!$ !if (tile==2) then +!!$ ! do i=is,ie +!!$ ! print*, i, ps(i,35) +!!$ ! enddo +!!$ !endif +!!$ tmpA(is:ie,js:je,tile) = ps(is:ie,js:je) +!!$ call wrt2d(phi_lun, (nout-1)*(npz+1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) +!!$ do k=1,npz +!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,k)/Grav +!!$ call wrt2d(phi_lun, (nout-1)*(npz+1) + 1 + k, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) +!!$ enddo +!!$ +!!$! Write PT Data +!!$ do k=1,npz +!!$ tmpA(is:ie,js:je,tile) = pt(is:ie,js:je,k) +!!$ call wrt2d(pt_lun, (nout-1)*npz + (k-1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) +!!$ enddo +!!$ +!!$! Write U,V Data +!!$ do k=1,npz +!!$ call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) +!!$! Rotate winds to standard Lat-Lon orientation +!!$ if (cubed_sphere) then +!!$ do j=js,je +!!$ do i=is,ie +!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1) +!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2) +!!$ call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3) +!!$ call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4) +!!$ utmp = ua(i,j,k) +!!$ vtmp = va(i,j,k) +!!$ if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2) +!!$ ut(i,j,tile) = utmp +!!$ vt(i,j,tile) = vtmp +!!$ enddo +!!$ enddo +!!$ endif +!!$ call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions)) +!!$ call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions)) +!!$ enddo +!!$#endif +!!$ +!!$ nullify(grid) +!!$ nullify(agrid) +!!$ +!!$ nullify(area) +!!$ +!!$ nullify(dx) +!!$ nullify(dy) +!!$ nullify(dxa) +!!$ nullify(dya) +!!$ nullify(rdxa) +!!$ nullify(rdya) +!!$ nullify(dxc) +!!$ nullify(dyc) +!!$ +!!$ nullify(cubed_sphere) +!!$ +!!$ end subroutine output +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- +!!$ +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! wrt2d_ncdf :: write out a 2d field +!!$! +!!$ subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims) +!!$#include +!!$ integer, intent(IN) :: ncid, varid +!!$ integer, intent(IN) :: nrec +!!$ integer, intent(IN) :: i1,i2,j1,j2 +!!$ integer, intent(IN) :: npx +!!$ integer, intent(IN) :: npy +!!$ integer, intent(IN) :: npz +!!$ integer, intent(IN) :: ntiles +!!$ real , intent(IN) :: p(npx-1,npy-1,npz,ntiles) +!!$ integer, intent(IN) :: ndims +!!$ +!!$ integer :: error +!!$ real(kind=4), allocatable :: p_R4(:,:,:,:) +!!$ integer :: i,j,k,n +!!$ integer :: istart(ndims+1), icount(ndims+1) +!!$ +!!$ allocate( p_R4(npx-1,npy-1,npz,ntiles) ) +!!$ +!!$ p_R4(:,:,:,:) = missing +!!$ p_R4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile) +!!$ call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles) +!!$ +!!$ istart(:) = 1 +!!$ istart(ndims+1) = nrec +!!$ icount(1) = npx-1 +!!$ icount(2) = npy-1 +!!$ icount(3) = npz +!!$ if (ndims == 3) icount(3) = ntiles +!!$ if (ndims == 4) icount(4) = ntiles +!!$ icount(ndims+1) = 1 +!!$ +!!$ if (is_master()) then +!!$ error = NF_PUT_VARA_REAL(ncid, varid, istart, icount, p_R4) +!!$ endif ! masterproc +!!$ +!!$ deallocate( p_R4 ) +!!$ +!!$ end subroutine wrtvar_ncdf +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- +!!$ +!!$!------------------------------------------------------------------------------- +!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!!$! wrt2d :: write out a 2d field +!!$! +!!$ subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p) +!!$ integer, intent(IN) :: iout +!!$ integer, intent(IN) :: nrec +!!$ integer, intent(IN) :: i1,i2,j1,j2 +!!$ integer, intent(IN) :: npx +!!$ integer, intent(IN) :: npy +!!$ integer, intent(IN) :: nregions +!!$ real , intent(IN) :: p(npx-1,npy-1,nregions) +!!$ +!!$ real(kind=4) :: p_R4(npx-1,npy-1,nregions) +!!$ integer :: i,j,n +!!$ +!!$ do n=tile,tile +!!$ do j=j1,j2 +!!$ do i=i1,i2 +!!$ p_R4(i,j,n) = p(i,j,n) +!!$ enddo +!!$ enddo +!!$ enddo +!!$ +!!$ call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, nregions) +!!$ +!!$ if (is_master()) then +!!$ write(iout,rec=nrec) p_R4(1:npx-1,1:npy-1,1:nregions) +!!$ endif ! masterproc +!!$ +!!$ end subroutine wrt2d +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- +!!$#endif !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +! init_double_periodic ! -! get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined -! in Williamson, 1994 (p.16) -! for any var - - subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, & - vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile) - integer, intent(IN) :: npx, npy - integer, intent(IN) :: ndims - integer, intent(IN) :: nregions, tile - real , intent(IN) :: var(isd:ied,jsd:jed) - real , intent(IN) :: varT(isd:ied,jsd:jed) - real , intent(OUT) :: vmin - real , intent(OUT) :: vmax - real , intent(OUT) :: L1_norm - real , intent(OUT) :: L2_norm - real , intent(OUT) :: Linf_norm - - type(fv_grid_type), target :: gridstruct - - real :: vmean - real :: vvar - real :: vmin1 - real :: vmax1 - real :: pdiffmn - real :: pdiffmx - - real :: varSUM, varSUM2, varMAX - real :: gsum - real :: vminT, vmaxT, vmeanT, vvarT - integer :: i0, j0, n0 - - real, dimension(:,:,:), pointer :: grid, agrid - real, dimension(:,:), pointer :: area - - grid => gridstruct%grid - agrid=> gridstruct%agrid - - area => gridstruct%area - - varSUM = 0. - varSUM2 = 0. - varMAX = 0. - L1_norm = 0. - L2_norm = 0. - Linf_norm = 0. - vmean = 0. - vvar = 0. - vmax = 0. - vmin = 0. - pdiffmn= 0. - pdiffmx= 0. - vmeanT = 0. - vvarT = 0. - vmaxT = 0. - vminT = 0. - - vmean = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - vmeanT = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - vmean = vmean / (4.0*pi) - vmeanT = vmeanT / (4.0*pi) - - call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin , vmax , i0, j0, n0) - call pmxn(varT, npx, npy, nregions, tile, gridstruct, vminT, vmaxT, i0, j0, n0) - call pmxn(var-varT, npx, npy, nregions, tile, gridstruct, pdiffmn, pdiffmx, i0, j0, n0) - - vmax = (vmax - vmaxT) / (vmaxT-vminT) - vmin = (vmin - vminT) / (vmaxT-vminT) - - varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - varSUM2 = globalsum(varT(is:ie,js:je)**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - L1_norm = globalsum(ABS(var(is:ie,js:je)-varT(is:ie,js:je)), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - L2_norm = globalsum((var(is:ie,js:je)-varT(is:ie,js:je))**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - L1_norm = L1_norm/varSUM - L2_norm = SQRT(L2_norm)/SQRT(varSUM2) - - call pmxn(ABS(varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) - varMAX = vmax - call pmxn(ABS(var-varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) - Linf_norm = vmax/varMAX - - end subroutine get_scalar_stats -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- - -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! -! get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined -! in Williamson, 1994 (p.16) -! for any var - - subroutine get_vector_stats(varU, varUT, varV, varVT, & - npx, npy, ndims, nregions, & - vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile) - integer, intent(IN) :: npx, npy - integer, intent(IN) :: ndims - integer, intent(IN) :: nregions, tile - real , intent(IN) :: varU(isd:ied,jsd:jed) - real , intent(IN) :: varUT(isd:ied,jsd:jed) - real , intent(IN) :: varV(isd:ied,jsd:jed) - real , intent(IN) :: varVT(isd:ied,jsd:jed) - real , intent(OUT) :: vmin - real , intent(OUT) :: vmax - real , intent(OUT) :: L1_norm - real , intent(OUT) :: L2_norm - real , intent(OUT) :: Linf_norm - - real :: var(isd:ied,jsd:jed) - real :: varT(isd:ied,jsd:jed) - real :: vmean - real :: vvar - real :: vmin1 - real :: vmax1 - real :: pdiffmn - real :: pdiffmx - - real :: varSUM, varSUM2, varMAX - real :: gsum - real :: vminT, vmaxT, vmeanT, vvarT - integer :: i,j,n - integer :: i0, j0, n0 - - type(fv_grid_type), target :: gridstruct - - real, dimension(:,:,:), pointer :: grid, agrid - real, dimension(:,:), pointer :: area - - grid => gridstruct%grid - agrid=> gridstruct%agrid - - area => gridstruct%area - - varSUM = 0. - varSUM2 = 0. - varMAX = 0. - L1_norm = 0. - L2_norm = 0. - Linf_norm = 0. - vmean = 0. - vvar = 0. - vmax = 0. - vmin = 0. - pdiffmn= 0. - pdiffmx= 0. - vmeanT = 0. - vvarT = 0. - vmaxT = 0. - vminT = 0. - - do j=js,je - do i=is,ie - var(i,j) = SQRT( (varU(i,j)-varUT(i,j))**2. + & - (varV(i,j)-varVT(i,j))**2. ) - varT(i,j) = SQRT( varUT(i,j)*varUT(i,j) + & - varVT(i,j)*varVT(i,j) ) - enddo - enddo - varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - L1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - L1_norm = L1_norm/varSUM - - call pmxn(varT, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) - varMAX = vmax - call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) - Linf_norm = vmax/varMAX - - do j=js,je - do i=is,ie - var(i,j) = ( (varU(i,j)-varUT(i,j))**2. + & - (varV(i,j)-varVT(i,j))**2. ) - varT(i,j) = ( varUT(i,j)*varUT(i,j) + & - varVT(i,j)*varVT(i,j) ) - enddo - enddo - varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - L2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) - L2_norm = SQRT(L2_norm)/SQRT(varSUM) - - end subroutine get_vector_stats -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- - -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! -! check_courant_numbers :: -! - subroutine check_courant_numbers(uc,vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint) - - real, intent(IN) :: ndt - integer, intent(IN) :: n_split - integer, intent(IN) :: npx, npy, npz, tile - logical, OPTIONAL, intent(IN) :: noPrint - real , intent(IN) :: uc(isd:ied+1,jsd:jed ,npz) - real , intent(IN) :: vc(isd:ied ,jsd:jed+1,npz) - - real :: ideal_c=0.06 - real :: tolerance= 1.e-3 - real :: dt_inc, dt_orig - real :: meanCy, minCy, maxCy, meanCx, minCx, maxCx - - real :: counter - logical :: ideal - - integer :: i,j,k - real :: dt + subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, & + gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, & + mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd) - type(fv_grid_type), intent(IN), target :: gridstruct - real, dimension(:,:), pointer :: dxc, dyc + + type(fv_grid_bounds_type), intent(IN) :: bd + real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) + real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) + real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:) + real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) + real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) + real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) + + real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed ) - dxc => gridstruct%dxc - dyc => gridstruct%dyc + real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed ) + real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1) + real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1) + real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je) + real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz ) + real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) + real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) + real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) + real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) + real , intent(inout) :: delz(bd%is:,bd%js:,1:) + real , intent(inout) :: ze0(bd%is:,bd%js:,1:) + + real , intent(inout) :: ak(npz+1) + real , intent(inout) :: bk(npz+1) + + integer, intent(IN) :: npx, npy, npz + integer, intent(IN) :: ng, ncnst, nwat + integer, intent(IN) :: ndims + integer, intent(IN) :: nregions + + real, intent(IN) :: dry_mass + logical, intent(IN) :: mountain + logical, intent(IN) :: moist_phys + logical, intent(IN) :: hydrostatic, hybrid_z + integer, intent(INOUT) :: ks + integer, intent(INOUT), target :: tile_in + real, intent(INOUT) :: ptop - dt = ndt/real(n_split) + type(domain2d), intent(IN), target :: domain_in - 300 format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14) + type(fv_grid_type), target :: gridstruct + type(fv_flags_type), target :: flagstruct - dt_orig = dt - dt_inc = 1 - ideal = .false. + real, dimension(bd%is:bd%ie):: pm, qs + real, dimension(1:npz):: pk1, ts1, qs1 + real :: us0 = 30. + real :: dist, r0, f0_const, prf, rgrav + real :: ptmp, ze, zc, zm, utmp, vtmp + real :: t00, p00, xmax, xc, xx, yy, pk0, pturb, ztop + real :: ze1(npz+1) + real:: dz1(npz) + real:: zvir + integer :: i, j, k, m, icenter, jcenter - do while(.not. ideal) - - counter = 0 - minCy = missing - maxCy = -1.*missing - minCx = missing - maxCx = -1.*missing - meanCx = 0 - meanCy = 0 - do k=1,npz - do j=js,je - do i=is,ie+1 - minCx = MIN(minCx, ABS( (dt/dxc(i,j))*uc(i,j,k) )) - maxCx = MAX(maxCx, ABS( (dt/dxc(i,j))*uc(i,j,k) )) - meanCx = meanCx + ABS( (dt/dxc(i,j))*uc(i,j,k) ) - - if (ABS( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then - counter = counter+1 - write(*,300) i,j,k,tile, ABS( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter - call exit(1) - endif + real, pointer, dimension(:,:,:) :: agrid, grid + real(kind=R_GRID), pointer, dimension(:,:) :: area + real, pointer, dimension(:,:) :: rarea, fC, f0 + real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 + real, pointer, dimension(:,:,:,:) :: ew, es + real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc - enddo - enddo - do j=js,je+1 - do i=is,ie - minCy = MIN(minCy, ABS( (dt/dyc(i,j))*vc(i,j,k) )) - maxCy = MAX(maxCy, ABS( (dt/dyc(i,j))*vc(i,j,k) )) - meanCy = meanCy + ABS( (dt/dyc(i,j))*vc(i,j,k) ) - - if (ABS( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then - counter = counter+1 - write(*,300) i,j,k,tile, ABS( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter - call exit(1) - endif + logical, pointer :: cubed_sphere, latlon - enddo - enddo - enddo + type(domain2d), pointer :: domain + integer, pointer :: tile - call mp_reduce_max(maxCx) - call mp_reduce_max(maxCy) - minCx = -minCx - minCy = -minCy - call mp_reduce_max(minCx) - call mp_reduce_max(minCy) - minCx = -minCx - minCy = -minCy - call mp_reduce_sum(meanCx) - call mp_reduce_sum(meanCy) - meanCx = meanCx/(6.0*DBLE(npx)*DBLE(npy-1)) - meanCy = meanCy/(6.0*DBLE(npx-1)*DBLE(npy)) - - !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then - ideal = .true. - !elseif (maxCy-ideal_c > 0) then - ! dt = dt - dt_inc - !else - ! dt = dt + dt_inc - !endif + logical, pointer :: have_south_pole, have_north_pole - enddo + integer, pointer :: ntiles_g + real, pointer :: acapN, acapS, globalarea - if ( (.not. present(noPrint)) .and. (is_master()) ) then - print*, '' - print*, '--------------------------------------------' - print*, 'Y-dir Courant number MIN : ', minCy - print*, 'Y-dir Courant number MAX : ', maxCy - print*, '' - print*, 'X-dir Courant number MIN : ', minCx - print*, 'X-dir Courant number MAX : ', maxCx - print*, '' - print*, 'X-dir Courant number MEAN : ', meanCx - print*, 'Y-dir Courant number MEAN : ', meanCy - print*, '' - print*, 'NDT: ', ndt - print*, 'n_split: ', n_split - print*, 'DT: ', dt - print*, '' - print*, '--------------------------------------------' - print*, '' - endif + real(kind=R_GRID), pointer :: dx_const, dy_const + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed - end subroutine check_courant_numbers -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! -! pmxn :: find max and min of field p -! - subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) - integer, intent(IN) :: npx - integer, intent(IN) :: npy - integer, intent(IN) :: nregions, tile - real , intent(IN) :: p(isd:ied,jsd:jed) - type(fv_grid_type), intent(IN), target :: gridstruct - real , intent(OUT) :: pmin - real , intent(OUT) :: pmax - integer, intent(OUT) :: i0 - integer, intent(OUT) :: j0 - integer, intent(OUT) :: n0 - - real :: temp - integer :: i,j,n + agrid => gridstruct%agrid + grid => gridstruct%grid + area => gridstruct%area_64 - real, pointer, dimension(:,:,:) :: agrid, grid - real, pointer, dimension(:,:) :: area, rarea, fC, f0 - real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 - real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es - real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc + dx => gridstruct%dx + dy => gridstruct%dy + dxa => gridstruct%dxa + dya => gridstruct%dya + rdxa => gridstruct%rdxa + rdya => gridstruct%rdya + dxc => gridstruct%dxc + dyc => gridstruct%dyc - logical, pointer :: cubed_sphere, latlon + fC => gridstruct%fC + f0 => gridstruct%f0 - logical, pointer :: have_south_pole, have_north_pole + !These are frequently used and so have pointers set up for them + dx_const => flagstruct%dx_const + dy_const => flagstruct%dy_const - integer, pointer :: ntiles_g - real, pointer :: acapN, acapS, globalarea + domain => domain_in + tile => tile_in - grid => gridstruct%grid - agrid=> gridstruct%agrid + have_south_pole => gridstruct%have_south_pole + have_north_pole => gridstruct%have_north_pole - area => gridstruct%area - rarea => gridstruct%rarea + ntiles_g => gridstruct%ntiles_g + acapN => gridstruct%acapN + acapS => gridstruct%acapS + globalarea => gridstruct%globalarea - fC => gridstruct%fC - f0 => gridstruct%f0 + f0_const = 2.*omega*sin(flagstruct%deglat/180.*pi) + f0(:,:) = f0_const + fC(:,:) = f0_const - ee1 => gridstruct%ee1 - ee2 => gridstruct%ee2 - ew => gridstruct%ew - es => gridstruct%es - en1 => gridstruct%en1 - en2 => gridstruct%en2 + q = 0. - dx => gridstruct%dx - dy => gridstruct%dy - dxa => gridstruct%dxa - dya => gridstruct%dya - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - dxc => gridstruct%dxc - dyc => gridstruct%dyc - - cubed_sphere => gridstruct%cubed_sphere - latlon => gridstruct%latlon + select case (test_case) + case ( 1 ) - have_south_pole => gridstruct%have_south_pole - have_north_pole => gridstruct%have_north_pole + phis(:,:)=0. - ntiles_g => gridstruct%ntiles_g - acapN => gridstruct%acapN - acapS => gridstruct%acapS - globalarea => gridstruct%globalarea + u (:,:,:)=10. + v (:,:,:)=10. + ua(:,:,:)=10. + va(:,:,:)=10. + uc(:,:,:)=10. + vc(:,:,:)=10. + pt(:,:,:)=1. + delp(:,:,:)=0. + + do j=js,je + if (j>0 .and. j<5) then + do i=is,ie + if (i>0 .and. i<5) then + delp(i,j,:)=1. + endif + enddo + endif + enddo + call mpp_update_domains( delp, domain ) - pmax = -1.e25 - pmin = 1.e25 - i0 = -999 - j0 = -999 - n0 = tile + case ( 2 ) - do j=js,je - do i=is,ie - temp = p(i,j) - if (temp > pmax) then - pmax = temp - i0 = i - j0 = j - elseif (temp < pmin) then - pmin = temp - endif - enddo - enddo + phis(:,:) = 0. - temp = pmax - call mp_reduce_max(temp) - if (temp /= pmax) then - i0 = -999 - j0 = -999 - n0 = -999 - endif - pmax = temp - call mp_reduce_max(i0) - call mp_reduce_max(j0) - call mp_reduce_max(n0) +! r0 = 5000. + r0 = 5.*sqrt(dx_const**2 + dy_const**2) + icenter = npx/2 + jcenter = npy/2 + do j=jsd,jed + do i=isd,ied + dist=(i-icenter)*dx_const*(i-icenter)*dx_const & + +(j-jcenter)*dy_const*(j-jcenter)*dy_const + dist=min(r0,sqrt(dist)) + phis(i,j)=1500.*(1. - (dist/r0)) + enddo + enddo - pmin = -pmin - call mp_reduce_max(pmin) - pmin = -pmin + u (:,:,:)=0. + v (:,:,:)=0. + ua(:,:,:)=0. + va(:,:,:)=0. + uc(:,:,:)=0. + vc(:,:,:)=0. + pt(:,:,:)=1. + delp(:,:,:)=1500. - end subroutine pmxn -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- + case ( 14 ) +!--------------------------- +! Doubly periodic Aqua-plane +!--------------------------- + u(:,:,:) = 0. + v(:,:,:) = 0. + phis(:,:) = 0. -!! These routines are no longer used -#ifdef NCDF_OUTPUT + call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, & + delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain) -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! -! output_ncdf :: write out NETCDF fields -! - subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, & - omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, & - npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, & - phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids, & - lats_id, lons_id, gridstruct, flagstruct) - real, intent(IN) :: dt - integer, intent(IN) :: nt, maxnt - integer, intent(INOUT) :: nout - - real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) - - real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) - real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) - - real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: omga(isd:ied ,jsd:jed ,npz) + ! *** Add Initial perturbation *** + if (bubble_do) then + r0 = 100.*sqrt(dx_const**2 + dy_const**2) + icenter = npx/2 + jcenter = npy/2 - integer, intent(IN) :: npx, npy, npz - integer, intent(IN) :: ng, ncnst - integer, intent(IN) :: ndims - integer, intent(IN) :: nregions - integer, intent(IN) :: ncid - integer, intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id - integer, intent(IN) :: ntiles_id, nt_id - integer, intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id - integer, intent(IN) :: om_id ! omega (dp/dt) - integer, intent(IN) :: tracers_ids(ncnst-1) - integer, intent(IN) :: lats_id, lons_id + do j=js,je + do i=is,ie + dist = (i-icenter)*dx_const*(i-icenter)*dx_const & + +(j-jcenter)*dy_const*(j-jcenter)*dy_const + dist = min(r0, sqrt(dist)) + do k=1,npz + prf = ak(k) + ps(i,j)*bk(k) + if ( prf > 100.E2 ) then + pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j) + endif + enddo + enddo + enddo + endif + if ( hydrostatic ) then + call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & + pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & + moist_phys, .true., nwat , domain, flagstruct%adiabatic) + else + w(:,:,:) = 0. + call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & + pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & + moist_phys, hydrostatic, nwat, domain, flagstruct%adiabatic, .true. ) + endif - type(fv_grid_type), target :: gridstruct - type(fv_flags_type), intent(IN) :: flagstruct - - real, allocatable :: tmp(:,:,:) - real, allocatable :: tmpA(:,:,:) -#if defined(SW_DYNAMICS) - real, allocatable :: ut(:,:,:) - real, allocatable :: vt(:,:,:) -#else - real, allocatable :: ut(:,:,:,:) - real, allocatable :: vt(:,:,:,:) - real, allocatable :: tmpA_3d(:,:,:,:) + q = 0. + do k=1,npz + do j=js,je + do i=is,ie + pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) + enddo +#ifdef MULTI_GASES + call qsmith((ie-is+1)*(je-js+1), npz, & + ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) +#else + call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) #endif - real, allocatable :: vort(:,:) + do i=is,ie + q(i,j,k,1) = max(2.E-6, 0.8*pm(i)/ps(i,j)*qs(i) ) + enddo + enddo + enddo - real :: p1(2) ! Temporary Point - real :: p2(2) ! Temporary Point - real :: p3(2) ! Temporary Point - real :: p4(2) ! Temporary Point - real :: pa(2) ! Temporary Point - real :: utmp, vtmp, r, r0, dist, heading - integer :: i,j,k,n,iq,nreg + case ( 15 ) +!--------------------------- +! Doubly periodic bubble +!--------------------------- + t00 = 250. - real :: Vtx, p, w_p - real :: x1,y1,z1,x2,y2,z2,ang + u(:,:,:) = 0. + v(:,:,:) = 0. + pt(:,:,:) = t00 + q(:,:,:,:) = 1.E-6 - real, pointer, dimension(:,:,:) :: agrid, grid - real, pointer, dimension(:,:) :: area, rarea - real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc + if ( .not. hydrostatic ) w(:,:,:) = 0. - grid => gridstruct%grid - agrid => gridstruct%agrid + do j=jsd,jed + do i=isd,ied + phis(i,j) = 0. + ps(i,j) = 1000.E2 + enddo + enddo - area => gridstruct%area - rarea => gridstruct%rarea + do k=1,npz + do j=jsd,jed + do i=isd,ied + delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) + enddo + enddo + enddo - dx => gridstruct%dx - dy => gridstruct%dy - dxa => gridstruct%dxa - dya => gridstruct%dya - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - dxc => gridstruct%dxc - dyc => gridstruct%dyc - allocate( tmp(npx ,npy ,nregions) ) - allocate( tmpA(npx-1,npy-1,nregions) ) -#if defined(SW_DYNAMICS) - allocate( ut(npx-1,npy-1,nregions) ) - allocate( vt(npx-1,npy-1,nregions) ) -#else - allocate( ut(npx-1,npy-1,npz,nregions) ) - allocate( vt(npx-1,npy-1,npz,nregions) ) - allocate( tmpA_3d(npx-1,npy-1,npz,nregions) ) -#endif - allocate( vort(isd:ied,jsd:jed) ) + do k=1,npz + do j=jsd,jed + do i=isd,ied + ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) +! pt(i,j,k) = t00 + enddo + enddo + enddo - nout = nout + 1 - - if (nt==0) then - tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2) - call wrtvar_ncdf(ncid, lats_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3) - tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1) - call wrtvar_ncdf(ncid, lons_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3) - endif - -#if defined(SW_DYNAMICS) - if (test_case > 1) then - tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav - - if ((nt==0) .and. (test_case==2)) then - Ubar = (2.0*pi*radius)/(12.0*86400.0) - gh0 = 2.94e4 - phis = 0.0 - do j=js,je+1 - do i=is,ie+1 - tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * & - ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + & - sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav - enddo - enddo - endif + call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & + pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & + moist_phys, .false., nwat, domain, flagstruct%adiabatic) - else +! *** Add Initial perturbation *** + r0 = 5.*max(dx_const, dy_const) + zc = 0.5e3 ! center of bubble from surface + icenter = npx/2 + jcenter = npy/2 - if (test_case==1) then -! Get Current Height Field "Truth" - p1(1) = pi/2. + pi_shift - p1(2) = 0. - p2(1) = 3.*pi/2. + pi_shift - p2(2) = 0. - r0 = radius/3. !RADIUS /3. - dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) - heading = 5.0*pi/2.0 - alpha - call get_pt_on_great_circle( p1, p2, dist, heading, p3) - do j=jsd,jed - do i=isd,ied - p2(1) = agrid(i,j,1) - p2(2) = agrid(i,j,2) - r = great_circle_dist( p3, p2, radius ) - if (r < r0) then - phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) - else - phi0(i,j,1) = phis(i,j) - endif - enddo - enddo - elseif (test_case == 0) then - phi0 = 0.0 - do j=jsd,jed - do i=isd,ied - x1 = agrid(i,j,1) - y1 = agrid(i,j,2) - z1 = radius - p = p0_c0 * cos(y1) - Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) - w_p = 0.0 - if (p /= 0.0) w_p = Vtx/p - phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) + do j=js,je + do i=is,ie + ze = 0. + do k=npz,1,-1 + zm = ze - 0.5*delz(i,j,k) ! layer center + ze = ze - delz(i,j,k) + dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + & + (zm-zc)**2 + dist = sqrt(dist) + if ( dist <= r0 ) then + pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0) + endif + enddo enddo enddo - endif - - tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1) - call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) - tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1) - endif - call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) - - if (test_case == 9) then -! Calc Vorticity - do j=jsd,jed - do i=isd,ied - vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - & - (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) ) - vort(i,j) = Grav*vort(i,j)/delp(i,j,1) - enddo - enddo - tmpA(is:ie,js:je,tile) = vort(is:ie,js:je) - call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) - endif - call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, 1, 1, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord, bd) - do j=js,je - do i=is,ie - ut(i,j,tile) = ua(i,j,1) - vt(i,j,tile) = va(i,j,1) + case ( 16 ) +!------------------------------------ +! Non-hydrostatic 3D density current: +!------------------------------------ + phis = 0. + u = 0. + v = 0. + w = 0. + t00 = 300. + p00 = 1.E5 + pk0 = p00**kappa +! Set up vertical coordinare with constant del-z spacing: +! Control: npz=64; dx = 100 m; dt = 1; n_split=10 + ztop = 6.4E3 + ze1( 1) = ztop + ze1(npz+1) = 0. + do k=npz,2,-1 + ze1(k) = ze1(k+1) + ztop/real(npz) enddo - enddo - - call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:nregions), 3) - call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:nregions), 3) - if ((test_case >= 2) .and. (nt==0) ) then - tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav - call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) - endif -#else + do j=js,je + do i=is,ie + ps(i,j) = p00 + pe(i,npz+1,j) = p00 + pk(i,j,npz+1) = pk0 + enddo + enddo -! Write Moisture Data - tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1) - call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) + do k=npz,1,-1 + do j=js,je + do i=is,ie + delz(i,j,k) = ze1(k+1) - ze1(k) + pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0 + pe(i,k,j) = pk(i,j,k)**(1./kappa) + enddo + enddo + enddo -! Write Tracer Data - do iq=2,ncnst - tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq) - call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) - enddo + ptop = pe(is,1,js) + if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100. -! Write Surface height data - tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav - call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3) + do k=1,npz+1 + do j=js,je + do i=is,ie + peln(i,k,j) = log(pe(i,k,j)) + ze0(i,j,k) = ze1(k) + enddo + enddo + enddo -! Write Pressure Data - tmpA(is:ie,js:je,tile) = ps(is:ie,js:je) - call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3) - do k=1,npz - tmpA_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/Grav - enddo - call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) + do k=1,npz + do j=js,je + do i=is,ie + pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) + delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j) + pt(i,j,k) = t00/pk0 ! potential temp + enddo + enddo + enddo -! Write PT Data - do k=1,npz - tmpA_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k) - enddo - call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) + pturb = 15. + xmax = 51.2E3 + xc = xmax / 2. -! Write U,V Data - call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, npz, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord) - do k=1,npz - do j=js,je - do i=is,ie - ut(i,j,k,tile) = ua(i,j,k) - vt(i,j,k,tile) = va(i,j,k) + do k=1,npz + zm = (0.5*(ze1(k)+ze1(k+1))-3.E3) / 2.E3 + do j=js,je + do i=is,ie +! Impose perturbation in potential temperature: pturb + xx = (dx_const * (0.5+real(i-1)) - xc) / 4.E3 + yy = (dy_const * (0.5+real(j-1)) - xc) / 4.E3 + dist = sqrt( xx**2 + yy**2 + zm**2 ) + if ( dist<=1. ) then + pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2. + endif +! Transform back to temperature: + pt(i,j,k) = pt(i,j,k) * pkz(i,j,k) + enddo enddo - enddo - enddo - call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:npz,1:nregions), 4) - call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:npz,1:nregions), 4) + enddo + case ( 17 ) +!--------------------------- +! Doubly periodic SuperCell, straight wind (v==0) +!-------------------------- + zvir = rvgas/rdgas - 1. + p00 = 1000.E2 + ps(:,:) = p00 + phis(:,:) = 0. + do j=js,je + do i=is,ie + pk(i,j,1) = ptop**kappa + pe(i,1,j) = ptop + peln(i,1,j) = log(ptop) + enddo + enddo -! Calc Vorticity - do k=1,npz - do j=js,je - do i=is,ie - tmpA_3d(i,j,k,tile) = rarea(i,j) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - & - (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) ) - enddo - enddo - enddo - call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) -! -! Output omega (dp/dt): - do k=1,npz - do j=js,je - do i=is,ie - tmpA_3d(i,j,k,tile) = omga(i,j,k) - enddo - enddo - enddo - call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) + do k=1,npz + do j=js,je + do i=is,ie + delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) + pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1) + peln(i,k+1,j) = log(pe(i,k+1,j)) + pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) ) + enddo + enddo + enddo -#endif + i = is + j = js + do k=1,npz + pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) + enddo - deallocate( tmp ) - deallocate( tmpA ) -#if defined(SW_DYNAMICS) - deallocate( ut ) - deallocate( vt ) -#else - deallocate( ut ) - deallocate( vt ) - deallocate( tmpA_3d ) +#ifndef GFS_PHYS + call SuperCell_Sounding(npz, p00, pk1, ts1, qs1) #endif - deallocate( vort ) - - nullify(grid) - nullify(agrid) - - nullify(area) - nullify(dx) - nullify(dy) - nullify(dxa) - nullify(dya) - nullify(rdxa) - nullify(rdya) - nullify(dxc) - nullify(dyc) + v(:,:,:) = 0. + w(:,:,:) = 0. + q(:,:,:,:) = 0. - end subroutine output_ncdf + do k=1,npz + do j=js,je + do i=is,ie + pt(i,j,k) = ts1(k) + q(i,j,k,1) = qs1(k) + delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)) + enddo + enddo + enddo -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- + ze1(npz+1) = 0. + do k=npz,1,-1 + ze1(k) = ze1(k+1) - delz(is,js,k) + enddo -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! -! output :: write out fields -! - subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, & - npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, & - pt_lun, pv_lun, uv_lun, gridstruct) + do k=1,npz + zm = 0.5*(ze1(k)+ze1(k+1)) + utmp = us0*tanh(zm/3.E3) + do j=js,je+1 + do i=is,ie + u(i,j,k) = utmp + enddo + enddo + enddo - real, intent(IN) :: dt - integer, intent(IN) :: nt, maxnt - integer, intent(INOUT) :: nout + call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & + pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & + .true., hydrostatic, nwat, domain, flagstruct%adiabatic) - real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) +! *** Add Initial perturbation *** + pturb = 2. + r0 = 10.e3 + zc = 1.4e3 ! center of bubble from surface + icenter = (npx-1)/3 + 1 + jcenter = (npy-1)/2 + 1 + do k=1, npz + zm = 0.5*(ze1(k)+ze1(k+1)) + ptmp = ( (zm-zc)/zc ) **2 + if ( ptmp < 1. ) then + do j=js,je + do i=is,ie + dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2 + if ( dist < 1. ) then + pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist)) + endif + enddo + enddo + endif + enddo - real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) - real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) - - real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) - - integer, intent(IN) :: npx, npy, npz - integer, intent(IN) :: ng, ncnst - integer, intent(IN) :: ndims - integer, intent(IN) :: nregions - integer, intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun + case ( 18 ) +!--------------------------- +! Doubly periodic SuperCell, quarter circle hodograph +! M. Toy, Apr 2013, MWR + pturb = 2.5 + zvir = rvgas/rdgas - 1. + p00 = 1000.E2 + ps(:,:) = p00 + phis(:,:) = 0. + do j=js,je + do i=is,ie + pk(i,j,1) = ptop**kappa + pe(i,1,j) = ptop + peln(i,1,j) = log(ptop) + enddo + enddo - type(fv_grid_type), target :: gridstruct + do k=1,npz + do j=js,je + do i=is,ie + delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) + pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1) + peln(i,k+1,j) = log(pe(i,k+1,j)) + pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) ) + enddo + enddo + enddo - real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions) - real :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions) - real :: p1(2) ! Temporary Point - real :: p2(2) ! Temporary Point - real :: p3(2) ! Temporary Point - real :: p4(2) ! Temporary Point - real :: pa(2) ! Temporary Point - real :: ut(1:npx,1:npy,1:nregions) - real :: vt(1:npx,1:npy,1:nregions) - real :: utmp, vtmp, r, r0, dist, heading - integer :: i,j,k,n,nreg - real :: vort(isd:ied,jsd:jed) + i = is + j = js + do k=1,npz + pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) + enddo +#ifndef GFS_PHYS - real :: Vtx, p, w_p - real :: x1,y1,z1,x2,y2,z2,ang + call SuperCell_Sounding(npz, p00, pk1, ts1, qs1) +#endif + w(:,:,:) = 0. + q(:,:,:,:) = 0. - real, pointer, dimension(:,:,:) :: agrid, grid - real, pointer, dimension(:,:) :: area, rarea - real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc + do k=1,npz + do j=js,je + do i=is,ie + pt(i,j,k) = ts1(k) + q(i,j,k,1) = qs1(k) + delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)) + enddo + enddo + enddo - grid => gridstruct%grid - agrid => gridstruct%agrid + ze1(npz+1) = 0. + do k=npz,1,-1 + ze1(k) = ze1(k+1) - delz(is,js,k) + enddo - area => gridstruct%area +! Quarter-circle hodograph (Harris approximation) + us0 = 30. + do k=1,npz + zm = 0.5*(ze1(k)+ze1(k+1)) + if ( zm .le. 2.e3 ) then + utmp = 8.*(1.-cos(pi*zm/4.e3)) + vtmp = 8.*sin(pi*zm/4.e3) + elseif (zm .le. 6.e3 ) then + utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3 + vtmp = 8. + else + utmp = us0 + vtmp = 8. + endif +! u-wind + do j=js,je+1 + do i=is,ie + u(i,j,k) = utmp - 8. + enddo + enddo +! v-wind + do j=js,je + do i=is,ie+1 + v(i,j,k) = vtmp - 4. + enddo + enddo + enddo - dx => gridstruct%dx - dy => gridstruct%dy - dxa => gridstruct%dxa - dya => gridstruct%dya - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - dxc => gridstruct%dxc - dyc => gridstruct%dyc - cubed_sphere => gridstruct%cubed_sphere + call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & + pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & + .true., hydrostatic, nwat, domain, flagstruct%adiabatic) - nout = nout + 1 +! *** Add Initial perturbation *** + if (bubble_do) then + r0 = 10.e3 + zc = 1.4e3 ! center of bubble from surface + icenter = (npx-1)/2 + 1 + jcenter = (npy-1)/2 + 1 + do k=1, npz + zm = 0.5*(ze1(k)+ze1(k+1)) + ptmp = ( (zm-zc)/zc ) **2 + if ( ptmp < 1. ) then + do j=js,je + do i=is,ie + dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2 + if ( dist < 1. ) then + pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist)) + endif + enddo + enddo + endif + enddo + endif -#if defined(SW_DYNAMICS) - if (test_case > 1) then - call atob_s(delp(:,:,1)/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1) - tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav + case ( 101 ) - if ((nt==0) .and. (test_case==2)) then - Ubar = (2.0*pi*radius)/(12.0*86400.0) - gh0 = 2.94e4 - phis = 0.0 - do j=js,je+1 - do i=is,ie+1 - tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * & - ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + & - sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav - enddo - enddo - endif +! IC for LES + t00 = 250. ! constant temp + p00 = 1.E5 + pk0 = p00**kappa - else + phis = 0. + u = 0. + v = 0. + w = 0. + pt(:,:,:) = t00 + q(:,:,:,1) = 0. - if (test_case==1) then -! Get Current Height Field "Truth" - p1(1) = pi/2. + pi_shift - p1(2) = 0. - p2(1) = 3.*pi/2. + pi_shift - p2(2) = 0. - r0 = radius/3. !RADIUS /3. - dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) - heading = 5.0*pi/2.0 - alpha - call get_pt_on_great_circle( p1, p2, dist, heading, p3) - do j=jsd,jed - do i=isd,ied - p2(1) = agrid(i,j,1) - p2(2) = agrid(i,j,2) - r = great_circle_dist( p3, p2, radius ) - if (r < r0) then - phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) - else - phi0(i,j,1) = phis(i,j) - endif - enddo - enddo - elseif (test_case == 0) then - phi0 = 0.0 - do j=jsd,jed - do i=isd,ied - x1 = agrid(i,j,1) - y1 = agrid(i,j,2) - z1 = radius - p = p0_c0 * cos(y1) - Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) - w_p = 0.0 - if (p /= 0.0) w_p = Vtx/p - phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) - enddo - enddo - endif + if (.not.hybrid_z) call mpp_error(FATAL, 'hybrid_z must be .TRUE.') - call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1) - tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1) - call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) - call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1) - tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1) - endif - ! call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) - call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) + rgrav = 1./ grav - if (test_case == 9) then -! Calc Vorticity - do j=jsd,jed - do i=isd,ied - vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - & - (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) ) - vort(i,j) = Grav*vort(i,j)/delp(i,j,1) - enddo - enddo - call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1) - call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) - endif + if ( npz/=101) then + call mpp_error(FATAL, 'npz must be == 101 ') + else + call compute_dz_L101( npz, ztop, dz1 ) + endif - call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) -! Rotate winds to standard Lat-Lon orientation - if (cubed_sphere) then - do j=js,je - do i=is,ie - call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1) - call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2) - call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3) - call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4) - utmp = ua(i,j,1) - vtmp = va(i,j,1) - if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2) - ut(i,j,tile) = utmp - vt(i,j,tile) = vtmp - enddo - enddo - endif + call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, & + phis, ze0, delz) - call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions)) - call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions)) + do j=js,je + do i=is,ie + ps(i,j) = p00 + pe(i,npz+1,j) = p00 + pk(i,j,npz+1) = pk0 + peln(i,npz+1,j) = log(p00) + enddo + enddo - if ((test_case >= 2) .and. (nt==0) ) then - call atob_s(phis/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1) - ! call wrt2d(phis_lun, nout , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) - tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav - call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) - endif -#else + do k=npz,1,-1 + do j=js,je + do i=is,ie + peln(i,k,j) = peln(i,k+1,j) + grav*delz(i,j,k)/(rdgas*t00) + pe(i,k,j) = exp(peln(i,k,j)) + pk(i,j,k) = pe(i,k,j)**kappa + enddo + enddo + enddo -! Write Surface height data - if (nt==0) then - tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav - call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) - endif -! Write Pressure Data +! Set up fake "sigma" coordinate + call make_eta_level(npz, pe, area, ks, ak, bk, ptop, domain, bd) - !if (tile==2) then - ! do i=is,ie - ! print*, i, ps(i,35) - ! enddo - !endif - tmpA(is:ie,js:je,tile) = ps(is:ie,js:je) - call wrt2d(phi_lun, (nout-1)*(npz+1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) - do k=1,npz - tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,k)/Grav - call wrt2d(phi_lun, (nout-1)*(npz+1) + 1 + k, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) - enddo + if ( is_master() ) write(*,*) 'LES testcase: computed model top (mb)=', ptop/100. -! Write PT Data - do k=1,npz - tmpA(is:ie,js:je,tile) = pt(is:ie,js:je,k) - call wrt2d(pt_lun, (nout-1)*npz + (k-1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) - enddo + do k=1,npz + do j=js,je + do i=is,ie + pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) + delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j) + enddo + enddo + enddo -! Write U,V Data - do k=1,npz - call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) -! Rotate winds to standard Lat-Lon orientation - if (cubed_sphere) then + do k=1,npz do j=js,je do i=is,ie - call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1) - call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2) - call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3) - call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4) - utmp = ua(i,j,k) - vtmp = va(i,j,k) - if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2) - ut(i,j,tile) = utmp - vt(i,j,tile) = vtmp + pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) enddo - enddo - endif - call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions)) - call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions)) - enddo +#ifdef MULTI_GASES + call qsmith((ie-is+1)*(je-js+1), npz, & + ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) +#else + call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) #endif + do i=is,ie + if ( pm(i) > 100.E2 ) then + q(i,j,k,1) = 0.9*qs(i) + else + q(i,j,k,1) = 2.E-6 + endif + enddo + enddo + enddo - nullify(grid) - nullify(agrid) +! *** Add perturbation *** + r0 = 1.0e3 ! radius (m) + zc = 1.0e3 ! center of bubble + icenter = npx/2 + jcenter = npy/2 - nullify(area) + do k=1,npz + do j=js,je + do i=is,ie + zm = 0.5*(ze0(i,j,k)+ze0(i,j,k+1)) + dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + (zm-zc)**2 + dist = sqrt(dist) + if ( dist <= r0 ) then + pt(i,j,k) = pt(i,j,k) + 2.0*(1.-dist/r0) + endif + enddo + enddo + enddo - nullify(dx) - nullify(dy) - nullify(dxa) - nullify(dya) - nullify(rdxa) - nullify(rdya) - nullify(dxc) - nullify(dyc) + end select - nullify(cubed_sphere) + nullify(grid) + nullify(agrid) - end subroutine output -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- + nullify(area) -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! wrt2d_ncdf :: write out a 2d field -! - subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims) -#include - integer, intent(IN) :: ncid, varid - integer, intent(IN) :: nrec - integer, intent(IN) :: i1,i2,j1,j2 - integer, intent(IN) :: npx - integer, intent(IN) :: npy - integer, intent(IN) :: npz - integer, intent(IN) :: ntiles - real , intent(IN) :: p(npx-1,npy-1,npz,ntiles) - integer, intent(IN) :: ndims - - integer :: error - real(kind=4), allocatable :: p_R4(:,:,:,:) - integer :: i,j,k,n - integer :: istart(ndims+1), icount(ndims+1) + nullify(fC) + nullify(f0) - allocate( p_R4(npx-1,npy-1,npz,ntiles) ) + nullify(ee1) + nullify(ee2) + nullify(ew) + nullify(es) + nullify(en1) + nullify(en2) - p_R4(:,:,:,:) = missing - p_R4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile) - call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles) + nullify(dx) + nullify(dy) + nullify(dxa) + nullify(dya) + nullify(rdxa) + nullify(rdya) + nullify(dxc) + nullify(dyc) - istart(:) = 1 - istart(ndims+1) = nrec - icount(1) = npx-1 - icount(2) = npy-1 - icount(3) = npz - if (ndims == 3) icount(3) = ntiles - if (ndims == 4) icount(4) = ntiles - icount(ndims+1) = 1 + nullify(dx_const) + nullify(dy_const) - if (is_master()) then - error = NF_PUT_VARA_REAL(ncid, varid, istart, icount, p_R4) - endif ! masterproc + nullify(domain) + nullify(tile) - deallocate( p_R4 ) + nullify(have_south_pole) + nullify(have_north_pole) - end subroutine wrtvar_ncdf -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- + nullify(ntiles_g) + nullify(acapN) + nullify(acapS) + nullify(globalarea) -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! wrt2d :: write out a 2d field -! - subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p) - integer, intent(IN) :: iout - integer, intent(IN) :: nrec - integer, intent(IN) :: i1,i2,j1,j2 - integer, intent(IN) :: npx - integer, intent(IN) :: npy - integer, intent(IN) :: nregions - real , intent(IN) :: p(npx-1,npy-1,nregions) - - real(kind=4) :: p_R4(npx-1,npy-1,nregions) - integer :: i,j,n + end subroutine init_double_periodic - do n=tile,tile - do j=j1,j2 - do i=i1,i2 - p_R4(i,j,n) = p(i,j,n) - enddo - enddo - enddo + subroutine read_namelist_test_case_nml(nml_filename) - call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, nregions) + character(*), intent(IN) :: nml_filename + integer :: ierr, f_unit, unit, ios - if (is_master()) then - write(iout,rec=nrec) p_R4(1:npx-1,1:npy-1,1:nregions) - endif ! masterproc +#include + namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons,soliton_Umax, soliton_size - end subroutine wrt2d -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- -#endif -!------------------------------------------------------------------------------- -! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -! init_double_periodic -! - subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, & - gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, & - mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd) + unit = stdlog() + ! Make alpha = 0 the default: + alpha = 0. + bubble_do = .false. + test_case = 11 ! (USGS terrain) - type(fv_grid_bounds_type), intent(IN) :: bd - real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) - real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) - real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:) - real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) - real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) - real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) - - real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed ) +#ifdef INTERNAL_FILE_NML + ! Read Test_Case namelist + read (input_nml_file,test_case_nml,iostat=ios) + ierr = check_nml_error(ios,'test_case_nml') +#else + f_unit = open_namelist_file(nml_filename) - real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed ) - real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1) - real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1) - real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je) - real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz ) - real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) - real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) - real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) - real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) - real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:) - real , intent(inout) :: ze0(bd%is:,bd%js:,1:) - - real , intent(inout) :: ak(npz+1) - real , intent(inout) :: bk(npz+1) - - integer, intent(IN) :: npx, npy, npz - integer, intent(IN) :: ng, ncnst, nwat - integer, intent(IN) :: ndims - integer, intent(IN) :: nregions - - real, intent(IN) :: dry_mass - logical, intent(IN) :: mountain - logical, intent(IN) :: moist_phys - logical, intent(IN) :: hydrostatic, hybrid_z - integer, intent(INOUT) :: ks - integer, intent(INOUT), target :: tile_in - real, intent(INOUT) :: ptop + ! Read Test_Case namelist + rewind (f_unit) + read (f_unit,test_case_nml,iostat=ios) + ierr = check_nml_error(ios,'test_case_nml') + call close_file(f_unit) +#endif + write(unit, nml=test_case_nml) - type(domain2d), intent(IN), target :: domain_in - type(fv_grid_type), target :: gridstruct - type(fv_flags_type), target :: flagstruct + end subroutine read_namelist_test_case_nml - real, dimension(bd%is:bd%ie):: pm, qs - real, dimension(1:npz):: pk1, ts1, qs1 - real :: us0 = 30. - real :: dist, r0, f0_const, prf, rgrav - real :: ptmp, ze, zc, zm, utmp, vtmp - real :: t00, p00, xmax, xc, xx, yy, pk0, pturb, ztop - real :: ze1(npz+1) - real:: dz1(npz) - real:: zvir - integer :: i, j, k, m, icenter, jcenter - real, pointer, dimension(:,:,:) :: agrid, grid - real(kind=R_GRID), pointer, dimension(:,:) :: area - real, pointer, dimension(:,:) :: rarea, fC, f0 - real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 - real, pointer, dimension(:,:,:,:) :: ew, es - real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc + subroutine SuperK_Sounding(km, pe, p00, ze, pt, qz) +! This is the z-ccordinate version: +! Morris Weisman & J. Klemp 2002 sounding + integer, intent(in):: km + real, intent(in):: p00 + real, intent(inout), dimension(km+1):: pe + real, intent(in), dimension(km+1):: ze +! pt: potential temperature / pk0 +! qz: specific humidity (mixing ratio) + real, intent(out), dimension(km):: pt, qz +! Local: + integer, parameter:: nx = 5 + real, parameter:: qst = 1.0e-6 + real, parameter:: qv0 = 1.4e-2 + real, parameter:: ztr = 12.E3 + real, parameter:: ttr = 213. + real, parameter:: ptr = 343. !< Tropopause potential temp. + real, parameter:: pt0 = 300. !< surface potential temperature + real, dimension(km):: zs, rh, temp, dp, dp0 + real, dimension(km+1):: peln, pk + real:: qs, zvir, fac_z, pk0, temp1, pm + integer:: k, n, kk - logical, pointer :: cubed_sphere, latlon + zvir = rvgas/rdgas - 1. + pk0 = p00**kappa + if ( (is_master()) ) then + write(*,*) 'Computing sounding for HIWPP super-cell test using p00=', p00 + endif - type(domain2d), pointer :: domain - integer, pointer :: tile + qz(:) = qst + rh(:) = 0.25 - logical, pointer :: have_south_pole, have_north_pole + do k=1, km + zs(k) = 0.5*(ze(k)+ze(k+1)) +! Potential temperature + if ( zs(k) .gt. ztr ) then +! Stratosphere: + pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr)) + else +! Troposphere: + fac_z = (zs(k)/ztr)**1.25 + pt(k) = pt0 + (ptr-pt0)* fac_z + rh(k) = 1. - 0.75 * fac_z +! First guess on q: + qz(k) = qv0 - (qv0-qst)*fac_z + endif + if ( is_master() ) write(*,*) zs(k), pt(k), qz(k) +! Convert to FV's definition of potential temperature + pt(k) = pt(k) / pk0 + enddo - integer, pointer :: ntiles_g - real, pointer :: acapN, acapS, globalarea +#ifdef USE_MOIST_P00 +!-------------------------------------- +! Iterate nx times with virtual effect: +!-------------------------------------- +! pt & height remain unchanged + pk(km+1) = pk0 + pe(km+1) = p00 ! Dry + peln(km+1) = log(p00) - real(kind=R_GRID), pointer :: dx_const, dy_const - - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed + do n=1, nx +! Derive pressure fields from hydrostatic balance: + do k=km,1,-1 + pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k))) + peln(k) = log(pk(k)) / kappa + pe(k) = exp(peln(k)) + enddo + do k=1, km + pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k)) + temp(k) = pt(k)*pm**kappa +! NCAR form: + qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.)) + qz(k) = min( qv0, rh(k)*qs ) + if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs + enddo + enddo +#else +! pt & height remain unchanged + pk(km+1) = pk0 + pe(km+1) = p00 ! Dry + peln(km+1) = log(p00) - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed +! Derive "dry" pressure fields from hydrostatic balance: + do k=km,1,-1 + pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)) + peln(k) = log(pk(k)) / kappa + pe(k) = exp(peln(k)) + enddo + do k=1, km + dp0(k) = pe(k+1) - pe(k) + pm = dp0(k)/(peln(k+1)-peln(k)) + temp(k) = pt(k)*pm**kappa +! NCAR form: + qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.)) + qz(k) = min( qv0, rh(k)*qs ) + enddo - agrid => gridstruct%agrid - grid => gridstruct%grid + do n=1, nx - area => gridstruct%area_64 + do k=1, km + dp(k) = dp0(k)*(1. + qz(k)) ! moist air + pe(k+1) = pe(k) + dp(k) + enddo +! dry pressure, pt & height remain unchanged + pk(km+1) = pe(km+1)**kappa + peln(km+1) = log(pe(km+1)) - dx => gridstruct%dx - dy => gridstruct%dy - dxa => gridstruct%dxa - dya => gridstruct%dya - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - dxc => gridstruct%dxc - dyc => gridstruct%dyc +! Derive pressure fields from hydrostatic balance: + do k=km,1,-1 + pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k))) + peln(k) = log(pk(k)) / kappa + pe(k) = exp(peln(k)) + enddo + do k=1, km + pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k)) + temp(k) = pt(k)*pm**kappa +! NCAR form: + qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.)) + qz(k) = min( qv0, rh(k)*qs ) + if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs + enddo + enddo +#endif + + if ( is_master() ) then + write(*,*) 'Super_K: computed ptop (mb)=', 0.01*pe(1), ' PS=', 0.01*pe(km+1) + call prt_m1('1D Sounding T0', temp, 1, km, 1, 1, 0, 1, 1.) + endif - fC => gridstruct%fC - f0 => gridstruct%f0 - - !These are frequently used and so have pointers set up for them - dx_const => flagstruct%dx_const - dy_const => flagstruct%dy_const - - domain => domain_in - tile => tile_in - - have_south_pole => gridstruct%have_south_pole - have_north_pole => gridstruct%have_north_pole - - ntiles_g => gridstruct%ntiles_g - acapN => gridstruct%acapN - acapS => gridstruct%acapS - globalarea => gridstruct%globalarea - - f0_const = 2.*omega*sin(flagstruct%deglat/180.*pi) - f0(:,:) = f0_const - fC(:,:) = f0_const - - q = 0. - - select case (test_case) - case ( 1 ) - - phis(:,:)=0. - - u (:,:,:)=10. - v (:,:,:)=10. - ua(:,:,:)=10. - va(:,:,:)=10. - uc(:,:,:)=10. - vc(:,:,:)=10. - pt(:,:,:)=1. - delp(:,:,:)=0. - - do j=js,je - if (j>0 .and. j<5) then - do i=is,ie - if (i>0 .and. i<5) then - delp(i,j,:)=1. - endif - enddo - endif - enddo - call mpp_update_domains( delp, domain ) - - case ( 2 ) - - phis(:,:) = 0. - -! r0 = 5000. - r0 = 5.*sqrt(dx_const**2 + dy_const**2) - icenter = npx/2 - jcenter = npy/2 - do j=jsd,jed - do i=isd,ied - dist=(i-icenter)*dx_const*(i-icenter)*dx_const & - +(j-jcenter)*dy_const*(j-jcenter)*dy_const - dist=min(r0,sqrt(dist)) - phis(i,j)=1500.*(1. - (dist/r0)) - enddo - enddo - - u (:,:,:)=0. - v (:,:,:)=0. - ua(:,:,:)=0. - va(:,:,:)=0. - uc(:,:,:)=0. - vc(:,:,:)=0. - pt(:,:,:)=1. - delp(:,:,:)=1500. - - case ( 14 ) -!--------------------------- -! Doubly periodic Aqua-plane -!--------------------------- - u(:,:,:) = 0. - v(:,:,:) = 0. - phis(:,:) = 0. - - call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, & - delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain) - - ! *** Add Initial perturbation *** - if (bubble_do) then - r0 = 100.*sqrt(dx_const**2 + dy_const**2) - icenter = npx/2 - jcenter = npy/2 - - do j=js,je - do i=is,ie - dist = (i-icenter)*dx_const*(i-icenter)*dx_const & - +(j-jcenter)*dy_const*(j-jcenter)*dy_const - dist = min(r0, sqrt(dist)) - do k=1,npz - prf = ak(k) + ps(i,j)*bk(k) - if ( prf > 100.E2 ) then - pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j) - endif - enddo - enddo - enddo - endif - if ( hydrostatic ) then - call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & - pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & - moist_phys, .true., nwat , domain) - else - w(:,:,:) = 0. - call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & - pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & - moist_phys, hydrostatic, nwat, domain, .true. ) - endif - - q = 0. - do k=1,npz - do j=js,je - do i=is,ie - pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - enddo -#ifdef MULTI_GASES - call qsmith((ie-is+1)*(je-js+1), npz, & - ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) -#else - call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) -#endif - do i=is,ie - q(i,j,k,1) = max(2.E-6, 0.8*pm(i)/ps(i,j)*qs(i) ) - enddo - enddo - enddo - - case ( 15 ) -!--------------------------- -! Doubly periodic bubble -!--------------------------- - t00 = 250. - - u(:,:,:) = 0. - v(:,:,:) = 0. - pt(:,:,:) = t00 - q(:,:,:,:) = 1.E-6 - - if ( .not. hydrostatic ) w(:,:,:) = 0. - - do j=jsd,jed - do i=isd,ied - phis(i,j) = 0. - ps(i,j) = 1000.E2 - enddo - enddo - - do k=1,npz - do j=jsd,jed - do i=isd,ied - delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) - enddo - enddo - enddo - - - do k=1,npz - do j=jsd,jed - do i=isd,ied - ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) -! pt(i,j,k) = t00 - enddo - enddo - enddo - - call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & - pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & - moist_phys, .false., nwat, domain) - -! *** Add Initial perturbation *** - r0 = 5.*max(dx_const, dy_const) - zc = 0.5e3 ! center of bubble from surface - icenter = npx/2 - jcenter = npy/2 - - do j=js,je - do i=is,ie - ze = 0. - do k=npz,1,-1 - zm = ze - 0.5*delz(i,j,k) ! layer center - ze = ze - delz(i,j,k) - dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + & - (zm-zc)**2 - dist = sqrt(dist) - if ( dist <= r0 ) then - pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0) - endif - enddo - enddo - enddo - - case ( 16 ) -!------------------------------------ -! Non-hydrostatic 3D density current: -!------------------------------------ - phis = 0. - u = 0. - v = 0. - w = 0. - t00 = 300. - p00 = 1.E5 - pk0 = p00**kappa -! Set up vertical coordinare with constant del-z spacing: -! Control: npz=64; dx = 100 m; dt = 1; n_split=10 - ztop = 6.4E3 - ze1( 1) = ztop - ze1(npz+1) = 0. - do k=npz,2,-1 - ze1(k) = ze1(k+1) + ztop/real(npz) - enddo - - do j=js,je - do i=is,ie - ps(i,j) = p00 - pe(i,npz+1,j) = p00 - pk(i,j,npz+1) = pk0 - enddo - enddo - - do k=npz,1,-1 - do j=js,je - do i=is,ie - delz(i,j,k) = ze1(k+1) - ze1(k) - pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0 - pe(i,k,j) = pk(i,j,k)**(1./kappa) - enddo - enddo - enddo - - ptop = pe(is,1,js) - if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100. - - do k=1,npz+1 - do j=js,je - do i=is,ie - peln(i,k,j) = log(pe(i,k,j)) - ze0(i,j,k) = ze1(k) - enddo - enddo - enddo - - do k=1,npz - do j=js,je - do i=is,ie - pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) - delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j) - pt(i,j,k) = t00/pk0 ! potential temp - enddo - enddo - enddo - - pturb = 15. - xmax = 51.2E3 - xc = xmax / 2. - - do k=1,npz - zm = (0.5*(ze1(k)+ze1(k+1))-3.E3) / 2.E3 - do j=js,je - do i=is,ie -! Impose perturbation in potential temperature: pturb - xx = (dx_const * (0.5+real(i-1)) - xc) / 4.E3 - yy = (dy_const * (0.5+real(j-1)) - xc) / 4.E3 - dist = sqrt( xx**2 + yy**2 + zm**2 ) - if ( dist<=1. ) then - pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2. - endif -! Transform back to temperature: - pt(i,j,k) = pt(i,j,k) * pkz(i,j,k) - enddo - enddo - enddo - - case ( 17 ) -!--------------------------- -! Doubly periodic SuperCell, straight wind (v==0) -!-------------------------- - zvir = rvgas/rdgas - 1. - p00 = 1000.E2 - ps(:,:) = p00 - phis(:,:) = 0. - do j=js,je - do i=is,ie - pk(i,j,1) = ptop**kappa - pe(i,1,j) = ptop - peln(i,1,j) = log(ptop) - enddo - enddo - - do k=1,npz - do j=js,je - do i=is,ie - delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) - pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1) - peln(i,k+1,j) = log(pe(i,k+1,j)) - pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) ) - enddo - enddo - enddo - - i = is - j = js - do k=1,npz - pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) - enddo - - - v(:,:,:) = 0. - w(:,:,:) = 0. - q(:,:,:,:) = 0. - - do k=1,npz - do j=js,je - do i=is,ie - pt(i,j,k) = ts1(k) - q(i,j,k,1) = qs1(k) - delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)) - enddo - enddo - enddo - - ze1(npz+1) = 0. - do k=npz,1,-1 - ze1(k) = ze1(k+1) - delz(is,js,k) - enddo - - do k=1,npz - zm = 0.5*(ze1(k)+ze1(k+1)) - utmp = us0*tanh(zm/3.E3) - do j=js,je+1 - do i=is,ie - u(i,j,k) = utmp - enddo - enddo - enddo - - call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & - pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & - .true., hydrostatic, nwat, domain) - -! *** Add Initial perturbation *** - pturb = 2. - r0 = 10.e3 - zc = 1.4e3 ! center of bubble from surface - icenter = (npx-1)/3 + 1 - jcenter = (npy-1)/2 + 1 - do k=1, npz - zm = 0.5*(ze1(k)+ze1(k+1)) - ptmp = ( (zm-zc)/zc ) **2 - if ( ptmp < 1. ) then - do j=js,je - do i=is,ie - dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2 - if ( dist < 1. ) then - pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist)) - endif - enddo - enddo - endif - enddo - - case ( 18 ) -!--------------------------- -! Doubly periodic SuperCell, quarter circle hodograph -! M. Toy, Apr 2013, MWR - pturb = 2.5 - zvir = rvgas/rdgas - 1. - p00 = 1000.E2 - ps(:,:) = p00 - phis(:,:) = 0. - do j=js,je - do i=is,ie - pk(i,j,1) = ptop**kappa - pe(i,1,j) = ptop - peln(i,1,j) = log(ptop) - enddo - enddo - - do k=1,npz - do j=js,je - do i=is,ie - delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) - pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1) - peln(i,k+1,j) = log(pe(i,k+1,j)) - pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) ) - enddo - enddo - enddo - - i = is - j = js - do k=1,npz - pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) - enddo - - - w(:,:,:) = 0. - q(:,:,:,:) = 0. - - do k=1,npz - do j=js,je - do i=is,ie - pt(i,j,k) = ts1(k) - q(i,j,k,1) = qs1(k) - delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)) - enddo - enddo - enddo - - ze1(npz+1) = 0. - do k=npz,1,-1 - ze1(k) = ze1(k+1) - delz(is,js,k) - enddo - -! Quarter-circle hodograph (Harris approximation) - us0 = 30. - do k=1,npz - zm = 0.5*(ze1(k)+ze1(k+1)) - if ( zm .le. 2.e3 ) then - utmp = 8.*(1.-cos(pi*zm/4.e3)) - vtmp = 8.*sin(pi*zm/4.e3) - elseif (zm .le. 6.e3 ) then - utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3 - vtmp = 8. - else - utmp = us0 - vtmp = 8. - endif -! u-wind - do j=js,je+1 - do i=is,ie - u(i,j,k) = utmp - 8. - enddo - enddo -! v-wind - do j=js,je - do i=is,ie+1 - v(i,j,k) = vtmp - 4. - enddo - enddo - enddo - - - call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, & - pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., & - .true., hydrostatic, nwat, domain) - -! *** Add Initial perturbation *** - if (bubble_do) then - r0 = 10.e3 - zc = 1.4e3 ! center of bubble from surface - icenter = (npx-1)/2 + 1 - jcenter = (npy-1)/2 + 1 - do k=1, npz - zm = 0.5*(ze1(k)+ze1(k+1)) - ptmp = ( (zm-zc)/zc ) **2 - if ( ptmp < 1. ) then - do j=js,je - do i=is,ie - dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2 - if ( dist < 1. ) then - pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist)) - endif - enddo - enddo - endif - enddo - endif - - case ( 101 ) - -! IC for LES - t00 = 250. ! constant temp - p00 = 1.E5 - pk0 = p00**kappa - - phis = 0. - u = 0. - v = 0. - w = 0. - pt(:,:,:) = t00 - q(:,:,:,1) = 0. - - if (.not.hybrid_z) call mpp_error(FATAL, 'hybrid_z must be .TRUE.') - - rgrav = 1./ grav - - if ( npz/=101) then - call mpp_error(FATAL, 'npz must be == 101 ') - else - call compute_dz_L101( npz, ztop, dz1 ) - endif - - call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, & - phis, ze0, delz) - - do j=js,je - do i=is,ie - ps(i,j) = p00 - pe(i,npz+1,j) = p00 - pk(i,j,npz+1) = pk0 - peln(i,npz+1,j) = log(p00) - enddo - enddo - - do k=npz,1,-1 - do j=js,je - do i=is,ie - peln(i,k,j) = peln(i,k+1,j) + grav*delz(i,j,k)/(rdgas*t00) - pe(i,k,j) = exp(peln(i,k,j)) - pk(i,j,k) = pe(i,k,j)**kappa - enddo - enddo - enddo - - -! Set up fake "sigma" coordinate - call make_eta_level(npz, pe, area, ks, ak, bk, ptop, domain, bd) - - if ( is_master() ) write(*,*) 'LES testcase: computed model top (mb)=', ptop/100. - - do k=1,npz - do j=js,je - do i=is,ie - pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) - delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j) - enddo - enddo - enddo - - do k=1,npz - do j=js,je - do i=is,ie - pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - enddo -#ifdef MULTI_GASES - call qsmith((ie-is+1)*(je-js+1), npz, & - ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) -#else - call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs) -#endif - do i=is,ie - if ( pm(i) > 100.E2 ) then - q(i,j,k,1) = 0.9*qs(i) - else - q(i,j,k,1) = 2.E-6 - endif - enddo - enddo - enddo - -! *** Add perturbation *** - r0 = 1.0e3 ! radius (m) - zc = 1.0e3 ! center of bubble - icenter = npx/2 - jcenter = npy/2 - - do k=1,npz - do j=js,je - do i=is,ie - zm = 0.5*(ze0(i,j,k)+ze0(i,j,k+1)) - dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + (zm-zc)**2 - dist = sqrt(dist) - if ( dist <= r0 ) then - pt(i,j,k) = pt(i,j,k) + 2.0*(1.-dist/r0) - endif - enddo - enddo - enddo - - end select - - nullify(grid) - nullify(agrid) - - nullify(area) - - nullify(fC) - nullify(f0) - - nullify(ee1) - nullify(ee2) - nullify(ew) - nullify(es) - nullify(en1) - nullify(en2) - - nullify(dx) - nullify(dy) - nullify(dxa) - nullify(dya) - nullify(rdxa) - nullify(rdya) - nullify(dxc) - nullify(dyc) - - nullify(dx_const) - nullify(dy_const) - - nullify(domain) - nullify(tile) - - nullify(have_south_pole) - nullify(have_north_pole) - - nullify(ntiles_g) - nullify(acapN) - nullify(acapS) - nullify(globalarea) - - end subroutine init_double_periodic - - subroutine SuperK_Sounding(km, pe, p00, ze, pt, qz) - integer, intent(in):: km - real, intent(in):: p00 - real, intent(inout), dimension(km+1):: pe - real, intent(in), dimension(km+1):: ze -! pt: potential temperature / pk0 -! qz: specific humidity (mixing ratio) - real, intent(out), dimension(km):: pt, qz -! Local: - integer, parameter:: nx = 5 - real, parameter:: qst = 1.0e-6 - real, parameter:: qv0 = 1.4e-2 - real, parameter:: ztr = 12.E3 - real, parameter:: ttr = 213. - real, parameter:: ptr = 343. !< Tropopause potential temp. - real, parameter:: pt0 = 300. !< surface potential temperature - real, dimension(km):: zs, rh, temp, dp, dp0 - real, dimension(km+1):: peln, pk - real:: qs, zvir, fac_z, pk0, temp1, pm - integer:: k, n, kk - - zvir = rvgas/rdgas - 1. - pk0 = p00**kappa - if ( (is_master()) ) then - write(*,*) 'Computing sounding for HIWPP super-cell test using p00=', p00 - endif - - qz(:) = qst - rh(:) = 0.25 - - do k=1, km - zs(k) = 0.5*(ze(k)+ze(k+1)) -! Potential temperature - if ( zs(k) .gt. ztr ) then -! Stratosphere: - pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr)) - else -! Troposphere: - fac_z = (zs(k)/ztr)**1.25 - pt(k) = pt0 + (ptr-pt0)* fac_z - rh(k) = 1. - 0.75 * fac_z -! First guess on q: - qz(k) = qv0 - (qv0-qst)*fac_z - endif - if ( is_master() ) write(*,*) zs(k), pt(k), qz(k) -! Convert to FV's definition of potential temperature - pt(k) = pt(k) / pk0 - enddo - -#ifdef USE_MOIST_P00 -!-------------------------------------- -! Iterate nx times with virtual effect: -!-------------------------------------- -! pt & height remain unchanged - pk(km+1) = pk0 - pe(km+1) = p00 ! Dry - peln(km+1) = log(p00) - - do n=1, nx -! Derive pressure fields from hydrostatic balance: - do k=km,1,-1 - pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k))) - peln(k) = log(pk(k)) / kappa - pe(k) = exp(peln(k)) - enddo - do k=1, km - pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k)) - temp(k) = pt(k)*pm**kappa -! NCAR form: - qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.)) - qz(k) = min( qv0, rh(k)*qs ) - if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs - enddo - enddo -#else -! pt & height remain unchanged - pk(km+1) = pk0 - pe(km+1) = p00 ! Dry - peln(km+1) = log(p00) - -! Derive "dry" pressure fields from hydrostatic balance: - do k=km,1,-1 - pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)) - peln(k) = log(pk(k)) / kappa - pe(k) = exp(peln(k)) - enddo - do k=1, km - dp0(k) = pe(k+1) - pe(k) - pm = dp0(k)/(peln(k+1)-peln(k)) - temp(k) = pt(k)*pm**kappa -! NCAR form: - qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.)) - qz(k) = min( qv0, rh(k)*qs ) - enddo - - do n=1, nx - - do k=1, km - dp(k) = dp0(k)*(1. + qz(k)) ! moist air - pe(k+1) = pe(k) + dp(k) - enddo -! dry pressure, pt & height remain unchanged - pk(km+1) = pe(km+1)**kappa - peln(km+1) = log(pe(km+1)) - -! Derive pressure fields from hydrostatic balance: - do k=km,1,-1 - pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k))) - peln(k) = log(pk(k)) / kappa - pe(k) = exp(peln(k)) - enddo - do k=1, km - pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k)) - temp(k) = pt(k)*pm**kappa -! NCAR form: - qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.)) - qz(k) = min( qv0, rh(k)*qs ) - if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs - enddo - enddo -#endif - - if ( is_master() ) then - write(*,*) 'Super_K: computed ptop (mb)=', 0.01*pe(1), ' PS=', 0.01*pe(km+1) - call prt_m1('1D Sounding T0', temp, 1, km, 1, 1, 0, 1, 1.) - endif - - end subroutine SuperK_Sounding - - subroutine balanced_K(km, is, ie, js, je, ng, ps0, ze1, ts1, qs1, uz1, dudz, pe, pk, pt, & - delz, zvir, ptop, ak, bk, agrid) - integer, intent(in):: is, ie, js, je, ng, km - real, intent(in), dimension(km ):: ts1, qs1, uz1, dudz - real, intent(in), dimension(km+1):: ze1 - real, intent(in):: zvir, ps0 - real, intent(inout):: ptop - real(kind=R_GRID), intent(in):: agrid(is-ng:ie+ng,js-ng:je+ng,2) - real, intent(inout), dimension(km+1):: ak, bk - real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delz - real, intent(out), dimension(is:ie,js:je,km+1):: pk -! pt is FV's cp*thelta_v - real, intent(inout), dimension(is-1:ie+1,km+1,js-1:je+1):: pe -! Local - integer, parameter:: nt=5 - integer, parameter:: nlat=1001 - real, dimension(nlat,km):: pt2, pky, dzc - real, dimension(nlat,km+1):: pk2, pe2, peln2, pte - real, dimension(km+1):: pe1 - real:: lat(nlat), latc(nlat-1) - real:: fac_y, dlat, dz0, pk0, tmp1, tmp2, tmp3, pint - integer::i,j,k,n, jj, k1 - real:: p00=1.e5 - - pk0 = p00**kappa - dz0 = ze1(km) - ze1(km+1) -!!! dzc(:,:) =dz0 - - dlat = 0.5*pi/real(nlat-1) - do j=1,nlat - lat(j) = dlat*real(j-1) - do k=1,km - dzc(j,k) = ze1(k) - ze1(k+1) - enddo - enddo - do j=1,nlat-1 - latc(j) = 0.5*(lat(j)+lat(j+1)) - enddo - -! Initialize pt2 - do k=1,km - do j=1,nlat - pt2(j,k) = ts1(k) - enddo - enddo - if ( is_master() ) then - tmp1 = pk0/cp_air - call prt_m1('Super_K PT0', pt2, 1, nlat, 1, km, 0, 1, tmp1) - endif - -! pt2 defined from Eq to NP -! Check NP - do n=1, nt -! Compute edge values - call ppme(pt2, pte, dzc, nlat, km) - do k=1,km - do j=2,nlat - tmp1 = 0.5*(pte(j-1,k ) + pte(j,k )) - tmp3 = 0.5*(pte(j-1,k+1) + pte(j,k+1)) - pt2(j,k) = pt2(j-1,k) + dlat/(2.*grav)*sin(2.*latc(j-1))*uz1(k)* & - ( uz1(k)*(tmp1-tmp3)/dzc(j,k) - (pt2(j-1,k)+pt2(j,k))*dudz(k) ) - enddo - enddo - if ( is_master() ) then - call prt_m1('Super_K PT', pt2, 1, nlat, 1, km, 0, 1, pk0/cp_air) - endif - enddo -! -! Compute surface pressure using gradient-wind balance: -!!! pk2(1,km+1) = pk0 - pk2(1,km+1) = ps0**kappa ! fixed at equator - do j=2,nlat - pk2(j,km+1) = pk2(j-1,km+1) - dlat*uz1(km)*uz1(km)*sin(2.*latc(j-1)) & - / (pt2(j-1,km) + pt2(j,km)) - enddo -! Compute pressure using hydrostatic balance: - do j=1,nlat - do k=km,1,-1 - pk2(j,k) = pk2(j,k+1) - grav*dzc(j,k)/pt2(j,k) - enddo - enddo - - do k=1,km+1 - do j=1,nlat - peln2(j,k) = log(pk2(j,k)) / kappa - pe2(j,k) = exp(peln2(j,k)) - enddo - enddo -! Convert pt2 to temperature - do k=1,km - do j=1,nlat - pky(j,k) = (pk2(j,k+1)-pk2(j,k))/(kappa*(peln2(j,k+1)-peln2(j,k))) - pt2(j,k) = pt2(j,k)*pky(j,k)/(cp_air*(1.+zvir*qs1(k))) - enddo - enddo - - do k=1,km+1 - pe1(k) = pe2(1,k) - enddo - - if ( is_master() ) then - write(*,*) 'SuperK ptop at EQ=', 0.01*pe1(1), 'new ptop=', 0.01*ptop - call prt_m1('Super_K pe', pe2, 1, nlat, 1, km+1, 0, 1, 0.01) - call prt_m1('Super_K Temp', pt2, 1, nlat, 1, km, 0, 1, 1.) - endif - -! Interpolate (pt2, pk2) from lat-dir to cubed-sphere - do j=js, je - do i=is, ie - do jj=1,nlat-1 - if (abs(agrid(i,j,2))>=lat(jj) .and. abs(agrid(i,j,2))<=lat(jj+1) ) then -! found it ! - fac_y = (abs(agrid(i,j,2))-lat(jj)) / dlat - do k=1,km - pt(i, j,k) = pt2(jj, k) + fac_y*(pt2(jj+1, k)-pt2(jj,k)) - enddo - do k=1,km+1 - pe(i,k,j) = pe2(jj,k) + fac_y*(pe2(jj+1,k)-pe2(jj,k)) - enddo -! k = km+1 -! pk(i,j,k) = pk2(jj,k) + fac_y*(pk2(jj+1,k)-pk2(jj,k)) - goto 123 - endif - enddo -123 continue - enddo - enddo - -! Adjust pk -! ak & bk -! Adjusting model top to be a constant pressure surface, assuming isothermal atmosphere -! pe = ak + bk*ps -! One pressure layer - pe1(1) = ptop - ak(1) = ptop - pint = pe1(2) - bk(1) = 0. - ak(2) = pint - bk(2) = 0. - do k=3,km+1 - bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma - ak(k) = pe1(k) - bk(k) * pe1(km+1) - if ( is_master() ) write(*,*) k, ak(k), bk(k) - enddo - ak(km+1) = 0. - bk(km+1) = 1. - do j=js, je - do i=is, ie - pe(i,1,j) = ptop - enddo - enddo - - - end subroutine balanced_K - - subroutine SuperK_u(km, zz, um, dudz) - integer, intent(in):: km - real, intent(in):: zz(km) - real, intent(out):: um(km), dudz(km) -! Local - real, parameter:: zs = 5.e3 - real, parameter:: us = 30. - real:: uc = 15. - integer k - - do k=1, km -#ifndef TEST_TANHP -! MPAS specification: - if ( zz(k) .gt. zs+1.e3 ) then - um(k) = us - dudz(k) = 0. - elseif ( abs(zz(k)-zs) .le. 1.e3 ) then - um(k) = us*(-4./5. + 3.*zz(k)/zs - 5./4.*(zz(k)/zs)**2) - dudz(k) = us/zs*(3. - 5./2.*zz(k)/zs) - else - um(k) = us*zz(k)/zs - dudz(k) = us/zs - endif -! constant wind so as to make the storm relatively stationary - um(k) = um(k) - uc -#else - uc = 12. ! this gives near stationary (in longitude) storms - um(k) = us*tanh( zz(k)/zs ) - uc - dudz(k) = (us/zs)/cosh(zz(k)/zs)**2 -#endif - enddo - - end subroutine superK_u - - - subroutine DCMIP16_BC(delp,pt,u,v,q,w,delz,& - is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, & - pk,peln,pe,pkz,gz,phis,ps,grid,agrid, & - hydrostatic, nwat, adiabatic, do_pert, domain) - - integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat - real, intent(IN) :: ptop - real, intent(IN), dimension(npz+1) :: ak, bk - real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q - real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz - real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u - real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v - real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk - real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln - real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe - real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz - real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps - real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid - real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid - real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz - logical, intent(IN) :: hydrostatic,adiabatic,do_pert - type(domain2d), intent(INOUT) :: domain - - real, parameter :: p0 = 1.e5 - real, parameter :: u0 = 35. - real, parameter :: b = 2. - real, parameter :: KK = 3. - real, parameter :: Te = 310. - real, parameter :: Tp = 240. - real, parameter :: T0 = 0.5*(Te + Tp) !!WRONG in document - real, parameter :: up = 1. - real, parameter :: zp = 1.5e4 - real(kind=R_GRID), parameter :: lamp = pi/9. - real(kind=R_GRID), parameter :: phip = 2.*lamp - real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /) - real, parameter :: Rp = radius/10. - real, parameter :: lapse = 5.e-3 - real, parameter :: dT = 4.8e5 - real, parameter :: phiW = 2.*pi/9. - real, parameter :: pW = 34000. - real, parameter :: q0 = .018 - real, parameter :: qt = 1.e-12 - real, parameter :: ptrop = 1.e4 - - real, parameter :: zconv = 1.e-6 - real, parameter :: rdgrav = rdgas/grav - real, parameter :: zvir = rvgas/rdgas - 1. - real, parameter :: rrdgrav = grav/rdgas - - integer :: i,j,k,iter, sphum, cl, cl2, n - real :: p,z,z0,ziter,piter,titer,uu,vv,pl,pt_u,pt_v - real(kind=R_GRID), dimension(2) :: pa - real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey - real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2 - real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u - real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2 - real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v - - !Compute ps, phis, delp, aux pressure variables, Temperature, winds - ! (with or without perturbation), moisture, Terminator tracer, w, delz - - !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal - ! and meridional winds on both grids, and rotate as needed - - !PS - do j=js,je - do i=is,ie - ps(i,j) = p0 - enddo - enddo - - !delp - do k=1,npz - do j=js,je - do i=is,ie - delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) - enddo - enddo - enddo - - !Pressure variables - do j=js,je - do i=is,ie - pe(i,1,j) = ptop - enddo - do i=is,ie - peln(i,1,j) = log(ptop) - pk(i,j,1) = ptop**kappa - enddo - do k=2,npz+1 - do i=is,ie - pe(i,k,j) = ak(k) + ps (i,j)*bk(k) - enddo - do i=is,ie - pk(i,j,k) = exp(kappa*log(pe(i,k,j))) - peln(i,k,j) = log(pe(i,k,j)) - enddo - enddo - enddo - - do k=1,npz - do j=js,je - do i=is,ie - pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) - enddo - enddo - enddo - - !Height: Use Newton's method - !Cell centered - do j=js,je - do i=is,ie - phis(i,j) = 0. - gz(i,j,npz+1) = 0. - enddo - enddo - do k=npz,1,-1 - do j=js,je - do i=is,ie - p = pe(i,k,j) - z = gz(i,j,k+1) - do iter=1,30 - ziter = z - piter = DCMIP16_BC_pressure(ziter,agrid(i,j,2)) - titer = DCMIP16_BC_temperature(ziter,agrid(i,j,2)) - z = ziter + (piter - p)*rdgrav*titer/piter -!!$ !!! DEBUG CODE -!!$ if (is_master() .and. i == is .and. j == js) then -!!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer -!!$ endif -!!$ !!! END DEBUG CODE - if (abs(z - ziter) < zconv) exit - enddo - gz(i,j,k) = z - enddo - enddo - enddo - - !Temperature: Compute from hydro balance - do k=1,npz - do j=js,je - do i=is,ie - pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j)) - enddo - enddo - enddo - - !Compute height and temperature for u and v points also, to be able to compute the local winds - !Use temporary 2d arrays for this purpose - do j=js,je+1 - do i=is,ie - gz_u(i,j) = 0. - p_u(i,j) = p0 - peln_u(i,j) = log(p0) - ps_u(i,j) = p0 - call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa) - lat_u(i,j) = pa(2) - lon_u(i,j) = pa(1) - call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1) - call get_latlon_vector(pa,ex,ey) - u1(i,j) = inner_prod(e1,ex) !u components - u2(i,j) = inner_prod(e1,ey) - enddo - enddo - do k=npz,1,-1 - do j=js,je+1 - do i=is,ie - !Pressure (Top of interface) - p = ak(k) + ps_u(i,j)*bk(k) - pl = log(p) - !Height (top of interface); use newton's method - z = gz_u(i,j) !first guess, height of lower level - z0 = z - do iter=1,30 - ziter = z - piter = DCMIP16_BC_pressure(ziter,lat_u(i,j)) - titer = DCMIP16_BC_temperature(ziter,lat_u(i,j)) - z = ziter + (piter - p)*rdgrav*titer/piter - if (abs(z - ziter) < zconv) exit - enddo - !Temperature, compute from hydro balance - pt_u = rrdgrav * ( z - gz_u(i,j) ) / (peln_u(i,j) - pl) - !Now compute winds. Note no meridional winds - !!!NOTE: do we need to use LAYER-mean z? - uu = DCMIP16_BC_uwind(0.5*(z+z0),pt_u,lat_u(i,j)) - if (do_pert) then - uu = uu + DCMIP16_BC_uwind_pert(0.5*(z+z0),lat_u(i,j),lon_u(i,j)) - endif - u(i,j,k) = u1(i,j)*uu - - gz_u(i,j) = z - p_u(i,j) = p - peln_u(i,j) = pl - enddo - enddo - enddo - - do j=js,je - do i=is,ie+1 - gz_v(i,j) = 0. - p_v(i,j) = p0 - peln_v(i,j) = log(p0) - ps_v(i,j) = p0 - call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa) - lat_v(i,j) = pa(2) - lon_v(i,j) = pa(1) - call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2) - call get_latlon_vector(pa,ex,ey) - v1(i,j) = inner_prod(e2,ex) !v components - v2(i,j) = inner_prod(e2,ey) - enddo - enddo - do k=npz,1,-1 - do j=js,je - do i=is,ie+1 - !Pressure (Top of interface) - p = ak(k) + ps_v(i,j)*bk(k) - pl = log(p) - !Height (top of interface); use newton's method - z = gz_v(i,j) !first guess, height of lower level - z0 = z - do iter=1,30 - ziter = z - piter = DCMIP16_BC_pressure(ziter,lat_v(i,j)) - titer = DCMIP16_BC_temperature(ziter,lat_v(i,j)) - z = ziter + (piter - p)*rdgrav*titer/piter - if (abs(z - ziter) < zconv) exit - enddo - !Temperature, compute from hydro balance - pt_v = rrdgrav * ( z - gz_v(i,j) ) / (peln_v(i,j) - pl) - !Now compute winds - uu = DCMIP16_BC_uwind(0.5*(z+z0),pt_v,lat_v(i,j)) - if (do_pert) then - uu = uu + DCMIP16_BC_uwind_pert(0.5*(z+z0),lat_v(i,j),lon_v(i,j)) - endif - v(i,j,k) = v1(i,j)*uu - gz_v(i,j) = z - p_v(i,j) = p - peln_v(i,j) = pl - enddo - enddo - enddo - - !Compute moisture and other tracer fields, as desired - do n=1,nq - do k=1,npz - do j=jsd,jed - do i=isd,ied - q(i,j,k,n) = 0. - enddo - enddo - enddo - enddo - if (.not. adiabatic) then - sphum = get_tracer_index (MODEL_ATMOS, 'sphum') - do k=1,npz - do j=js,je - do i=is,ie - p = delp(i,j,k)/(peln(i,k+1,j) - peln(i,k,j)) - q(i,j,k,sphum) = DCMIP16_BC_sphum(p,ps(i,j),agrid(i,j,2),agrid(i,j,1)) - !Convert pt to non-virtual temperature - pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum)) - enddo - enddo - enddo - endif - - cl = get_tracer_index(MODEL_ATMOS, 'cl') - cl2 = get_tracer_index(MODEL_ATMOS, 'cl2') - if (cl > 0 .and. cl2 > 0) then - call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, & - q, delp,nq,agrid(isd,jsd,1),agrid(isd,jsd,2)) - call mpp_update_domains(q,domain) - endif + end subroutine SuperK_Sounding - !Compute nonhydrostatic variables, if needed - if (.not. hydrostatic) then - do k=1,npz - do j=js,je - do i=is,ie - w(i,j,k) = 0. - delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1) - enddo - enddo - enddo - endif + subroutine balanced_K(km, is, ie, js, je, ng, ps0, ze1, ts1, qs1, uz1, dudz, pe, pk, pt, & + delz, zvir, ptop, ak, bk, agrid) + integer, intent(in):: is, ie, js, je, ng, km + real, intent(in), dimension(km ):: ts1, qs1, uz1, dudz + real, intent(in), dimension(km+1):: ze1 + real, intent(in):: zvir, ps0 + real, intent(inout):: ptop + real(kind=R_GRID), intent(in):: agrid(is-ng:ie+ng,js-ng:je+ng,2) + real, intent(inout), dimension(km+1):: ak, bk + real, intent(inout), dimension(is:ie,js:je,km):: pt + real, intent(inout), dimension(is:,js:,1:) :: delz + real, intent(out), dimension(is:ie,js:je,km+1):: pk +! pt is FV's cp*thelta_v + real, intent(inout), dimension(is-1:ie+1,km+1,js-1:je+1):: pe +! Local + integer, parameter:: nt=5 + integer, parameter:: nlat=1001 + real, dimension(nlat,km):: pt2, pky, dzc + real, dimension(nlat,km+1):: pk2, pe2, peln2, pte + real, dimension(km+1):: pe1 + real:: lat(nlat), latc(nlat-1) + real:: fac_y, dlat, dz0, pk0, tmp1, tmp2, tmp3, pint + integer::i,j,k,n, jj, k1 + real:: p00=1.e5 - contains + pk0 = p00**kappa + dz0 = ze1(km) - ze1(km+1) +!!! dzc(:,:) =dz0 - - real function DCMIP16_BC_temperature(z, lat) + dlat = 0.5*pi/real(nlat-1) + do j=1,nlat + lat(j) = dlat*real(j-1) + do k=1,km + dzc(j,k) = ze1(k) - ze1(k+1) + enddo + enddo + do j=1,nlat-1 + latc(j) = 0.5*(lat(j)+lat(j+1)) + enddo - real, intent(IN) :: z - real(kind=R_GRID), intent(IN) :: lat - real :: IT, T1, T2, Tr, zsc +! Initialize pt2 + do k=1,km + do j=1,nlat + pt2(j,k) = ts1(k) + enddo + enddo + if ( is_master() ) then + tmp1 = pk0/cp_air + call prt_m1('Super_K PT0', pt2, 1, nlat, 1, km, 0, 1, tmp1) + endif - IT = exp(KK * log(cos(lat))) - KK/(KK+2.)*exp((KK+2.)*log(cos(lat))) - zsc = z*grav/(b*Rdgas*T0) - Tr = ( 1. - 2.*zsc**2.) * exp(-zsc**2. ) +! pt2 defined from Eq to NP +! Check NP + do n=1, nt +! Compute edge values + call ppme(pt2, pte, dzc, nlat, km) + do k=1,km + do j=2,nlat + tmp1 = 0.5*(pte(j-1,k ) + pte(j,k )) + tmp3 = 0.5*(pte(j-1,k+1) + pte(j,k+1)) + pt2(j,k) = pt2(j-1,k) + dlat/(2.*grav)*sin(2.*latc(j-1))*uz1(k)* & + ( uz1(k)*(tmp1-tmp3)/dzc(j,k) - (pt2(j-1,k)+pt2(j,k))*dudz(k) ) + enddo + enddo + if ( is_master() ) then + call prt_m1('Super_K PT', pt2, 1, nlat, 1, km, 0, 1, pk0/cp_air) + endif + enddo +! +! Compute surface pressure using gradient-wind balance: +!!! pk2(1,km+1) = pk0 + pk2(1,km+1) = ps0**kappa ! fixed at equator + do j=2,nlat + pk2(j,km+1) = pk2(j-1,km+1) - dlat*uz1(km)*uz1(km)*sin(2.*latc(j-1)) & + / (pt2(j-1,km) + pt2(j,km)) + enddo +! Compute pressure using hydrostatic balance: + do j=1,nlat + do k=km,1,-1 + pk2(j,k) = pk2(j,k+1) - grav*dzc(j,k)/pt2(j,k) + enddo + enddo - T1 = (1./T0)*exp(lapse*z/T0) + (T0 - Tp)/(T0*Tp) * Tr - T2 = 0.5* ( KK + 2.) * (Te - Tp)/(Te*Tp) * Tr + do k=1,km+1 + do j=1,nlat + peln2(j,k) = log(pk2(j,k)) / kappa + pe2(j,k) = exp(peln2(j,k)) + enddo + enddo +! Convert pt2 to temperature + do k=1,km + do j=1,nlat + pky(j,k) = (pk2(j,k+1)-pk2(j,k))/(kappa*(peln2(j,k+1)-peln2(j,k))) + pt2(j,k) = pt2(j,k)*pky(j,k)/(cp_air*(1.+zvir*qs1(k))) + enddo + enddo - DCMIP16_BC_temperature = 1./(T1 - T2*IT) + do k=1,km+1 + pe1(k) = pe2(1,k) + enddo - end function DCMIP16_BC_temperature + if ( is_master() ) then + write(*,*) 'SuperK ptop at EQ=', 0.01*pe1(1), 'new ptop=', 0.01*ptop + call prt_m1('Super_K pe', pe2, 1, nlat, 1, km+1, 0, 1, 0.01) + call prt_m1('Super_K Temp', pt2, 1, nlat, 1, km, 0, 1, 1.) + endif - real function DCMIP16_BC_pressure(z,lat) +! Interpolate (pt2, pk2) from lat-dir to cubed-sphere + do j=js, je + do i=is, ie + do jj=1,nlat-1 + if (abs(agrid(i,j,2))>=lat(jj) .and. abs(agrid(i,j,2))<=lat(jj+1) ) then +! found it ! + fac_y = (abs(agrid(i,j,2))-lat(jj)) / dlat + do k=1,km + pt(i, j,k) = pt2(jj, k) + fac_y*(pt2(jj+1, k)-pt2(jj,k)) + enddo + do k=1,km+1 + pe(i,k,j) = pe2(jj,k) + fac_y*(pe2(jj+1,k)-pe2(jj,k)) + enddo +! k = km+1 +! pk(i,j,k) = pk2(jj,k) + fac_y*(pk2(jj+1,k)-pk2(jj,k)) + goto 123 + endif + enddo +123 continue + enddo + enddo - real, intent(IN) :: z - real(kind=R_GRID), intent(IN) :: lat - real :: IT, Ti1, Ti2, Tir +! Adjust pk +! ak & bk +! Adjusting model top to be a constant pressure surface, assuming isothermal atmosphere +! pe = ak + bk*ps +! One pressure layer + pe1(1) = ptop + ak(1) = ptop + pint = pe1(2) + bk(1) = 0. + ak(2) = pint + bk(2) = 0. + do k=3,km+1 + bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma + ak(k) = pe1(k) - bk(k) * pe1(km+1) + if ( is_master() ) write(*,*) k, ak(k), bk(k) + enddo + ak(km+1) = 0. + bk(km+1) = 1. + do j=js, je + do i=is, ie + pe(i,1,j) = ptop + enddo + enddo - IT = exp(KK * log(cos(lat))) - KK/(KK+2.)*exp((KK+2.)*log(cos(lat))) - Tir = z*exp(-(z*grav/(b*Rdgas*T0))*(z*grav/(b*Rdgas*T0)) ) - Ti1 = 1./lapse* (exp(lapse*z/T0) - 1.) + Tir*(T0-Tp)/(T0*Tp) - Ti2 = 0.5*(KK+2.)*(Te-Tp)/(Te*Tp) * Tir + end subroutine balanced_K - DCMIP16_BC_pressure = p0*exp(-grav/Rdgas * ( Ti1 - Ti2*IT)) + subroutine SuperK_u(km, zz, um, dudz) + integer, intent(in):: km + real, intent(in):: zz(km) + real, intent(out):: um(km), dudz(km) +! Local + real, parameter:: zs = 5.e3 + real, parameter:: us = 30. + real:: uc = 15. + integer k - end function DCMIP16_BC_pressure + do k=1, km +#ifndef TEST_TANHP +! MPAS specification: + if ( zz(k) .gt. zs+1.e3 ) then + um(k) = us + dudz(k) = 0. + elseif ( abs(zz(k)-zs) .le. 1.e3 ) then + um(k) = us*(-4./5. + 3.*zz(k)/zs - 5./4.*(zz(k)/zs)**2) + dudz(k) = us/zs*(3. - 5./2.*zz(k)/zs) + else + um(k) = us*zz(k)/zs + dudz(k) = us/zs + endif +! constant wind so as to make the storm relatively stationary + um(k) = um(k) - uc +#else + uc = 12. ! this gives near stationary (in longitude) storms + um(k) = us*tanh( zz(k)/zs ) - uc + dudz(k) = (us/zs)/cosh(zz(k)/zs)**2 +#endif + enddo - real function DCMIP16_BC_uwind(z,T,lat) + end subroutine superK_u - real, intent(IN) :: z, T - real(kind=R_GRID), intent(IN) :: lat - real :: Tir, Ti2, UU, ur +#ifndef GFS_PHYS + subroutine SuperCell_Sounding(km, ps, pk1, tp, qp) + use gfdl_cloud_microphys_mod, only: wqsat_moist, qsmith_init, qs_blend +! Morris Weisman & J. Klemp 2002 sounding +! Output sounding on pressure levels: + integer, intent(in):: km + real, intent(in):: ps ! surface pressure (Pa) + real, intent(in), dimension(km):: pk1 + real, intent(out), dimension(km):: tp, qp +! Local: + integer, parameter:: ns = 401 + integer, parameter:: nx = 3 + real, dimension(ns):: zs, pt, qs, us, rh, pp, pk, dpk, dqdt + real, parameter:: Tmin = 175. + real, parameter:: p00 = 1.0e5 + real, parameter:: qst = 3.0e-6 + real, parameter:: qv0 = 1.4e-2 + real, parameter:: ztr = 12.E3 + real, parameter:: ttr = 213. + real, parameter:: ptr = 343. ! Tropopause potential temp. + real, parameter:: pt0 = 300. ! surface potential temperature + real:: dz0, zvir, fac_z, pk0, temp1, p2 + integer:: k, n, kk - Tir = z*exp(-(z*grav/(b*Rdgas*T0))*(z*grav/(b*Rdgas*T0)) ) - Ti2 = 0.5*(KK+2.)*(Te-Tp)/(Te*Tp) * Tir +!#ifdef GFS_PHYS - UU = grav*KK/radius * Ti2 * ( cos(lat)**(int(KK)-1) - cos(lat)**(int(KK)+1) ) * T - ur = - omega * radius * cos(lat) + sqrt( (omega*radius*cos(lat))**2 + radius*cos(lat)*UU) +! call mpp_error(FATAL, 'SuperCell sounding cannot perform with GFS Physics.') - DCMIP16_BC_uwind = ur +!#else - end function DCMIP16_BC_uwind + zvir = rvgas/rdgas - 1. + pk0 = p00**kappa + pp(ns) = ps + pk(ns) = ps**kappa + if ( (is_master()) ) then + write(*,*) 'Computing sounding for super-cell test' + endif - real function DCMIP16_BC_uwind_pert(z,lat,lon) + call qsmith_init - real, intent(IN) :: z - real(kind=R_GRID), intent(IN) :: lat, lon - real :: ZZ, zrat - real(kind=R_GRID) :: dst, pphere(2) + dz0 = 50. + zs(ns) = 0. + qs(:) = qst + rh(:) = 0.25 - zrat = z/zp - ZZ = max(1. - 3.*zrat*zrat + 2.*zrat*zrat*zrat, 0.) + do k=ns-1, 1, -1 + zs(k) = zs(k+1) + dz0 + enddo - pphere = (/ lon, lat /) - dst = great_circle_dist(pphere, ppcenter, radius) - - DCMIP16_BC_uwind_pert = max(0., up*ZZ*exp(-(dst/Rp)**2) ) + do k=1,ns +! Potential temperature + if ( zs(k) .gt. ztr ) then +! Stratosphere: + pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr)) + else +! Troposphere: + fac_z = (zs(k)/ztr)**1.25 + pt(k) = pt0 + (ptr-pt0)* fac_z + rh(k) = 1. - 0.75 * fac_z +! First guess on q: + qs(k) = qv0 - (qv0-qst)*fac_z + endif + pt(k) = pt(k) / pk0 + enddo - end function DCMIP16_BC_uwind_pert +!-------------------------------------- +! Iterate nx times with virtual effect: +!-------------------------------------- + do n=1, nx + do k=1,ns-1 + temp1 = 0.5*(pt(k)*(1.+zvir*qs(k)) + pt(k+1)*(1.+zvir*qs(k+1))) + dpk(k) = grav*(zs(k)-zs(k+1))/(cp_air*temp1) ! DPK > 0 + enddo - real function DCMIP16_BC_sphum(p,ps,lat, lon) + do k=ns-1,1,-1 + pk(k) = pk(k+1) - dpk(k) + enddo - real, intent(IN) :: p, ps - real(kind=R_GRID), intent(IN) :: lat, lon - real :: eta + do k=1, ns + temp1 = pt(k)*pk(k) +! if ( (is_master()) ) write(*,*) k, temp1, rh(k) + if ( pk(k) > 0. ) then + pp(k) = exp(log(pk(k))/kappa) +#ifdef SUPER_K + qs(k) = 380./pp(k)*exp(17.27*(temp1-273.)/(temp1-36.)) + qs(k) = min( qv0, rh(k)*qs(k) ) + if ( (is_master()) ) write(*,*) 0.01*pp(k), qs(k) +#else - eta = p/ps +#ifdef USE_MIXED_TABLE + qs(k) = min(qv0, rh(k)*qs_blend(temp1, pp(k), qs(k))) +#else + qs(k) = min(qv0, rh(k)*wqsat_moist(temp1, qs(k), pp(k))) +#endif - DCMIP16_BC_sphum = qt - if (p > ptrop) then - DCMIP16_BC_sphum = q0 * exp(-(lat/phiW)**4) * exp(-( (eta-1.)*p0/pw)**2) - endif +#endif + else + if ( (is_master()) ) write(*,*) n, k, pk(k) + call mpp_error(FATAL, 'Super-Cell case: pk < 0') + endif + enddo + enddo - end function DCMIP16_BC_sphum +! Interpolate to p levels using pk1: p**kappa + do 555 k=1, km + if ( pk1(k) .le. pk(1) ) then + tp(k) = pt(1)*pk(1)/pk1(k) ! isothermal above + qp(k) = qst ! set to stratosphere value + elseif ( pk1(k) .ge. pk(ns) ) then + tp(k) = pt(ns) + qp(k) = qs(ns) + else + do kk=1,ns-1 + if( (pk1(k).le.pk(kk+1)) .and. (pk1(k).ge.pk(kk)) ) then + fac_z = (pk1(k)-pk(kk))/(pk(kk+1)-pk(kk)) + tp(k) = pt(kk) + (pt(kk+1)-pt(kk))*fac_z + qp(k) = qs(kk) + (qs(kk+1)-qs(kk))*fac_z + goto 555 + endif + enddo + endif +555 continue + + do k=1,km + tp(k) = tp(k)*pk1(k) ! temperature + tp(k) = max(Tmin, tp(k)) + enddo + +!#endif - end subroutine DCMIP16_BC + end subroutine SuperCell_Sounding +#endif - subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& + subroutine DCMIP16_BC(delp,pt,u,v,q,w,delz,& is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, & pk,peln,pe,pkz,gz,phis,ps,grid,agrid, & - hydrostatic, nwat, adiabatic) + hydrostatic, nwat, adiabatic, do_pert, domain, bd) + + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat real, intent(IN) :: ptop real, intent(IN), dimension(npz+1) :: ak, bk real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q - real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz + real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w + real, intent(OUT), dimension(is:,js:,1:) :: delz real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk @@ -7501,59 +7409,56 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz - logical, intent(IN) :: hydrostatic,adiabatic + logical, intent(IN) :: hydrostatic,adiabatic,do_pert + type(domain2d), intent(INOUT) :: domain - real, parameter :: zt = 15000 !< m - real, parameter :: q0 = 0.021 !< kg/kg - real, parameter :: qt = 1.e-11 !< kg/kg - real, parameter :: T0 = 302.15 !< K - real, parameter :: Tv0 = 302.15*(1.+0.608*q0) !< K - real, parameter :: Ts = 302.15 !< K - real, parameter :: zq1 = 3000. !< m - real, parameter :: zq2 = 8000. !< m - real, parameter :: lapse = 7.e-3 !< K/m - real, parameter :: Tvt = Tv0 - lapse*zt !< K - real, parameter :: pb = 101500. !< Pa - real, parameter :: ptt = pb*(TvT/Tv0)**(grav/Rdgas/lapse) - real(kind=R_GRID), parameter :: lamp = pi - real(kind=R_GRID), parameter :: phip = pi/18. + real, parameter :: p0 = 1.e5 + real, parameter :: u0 = 35. + real, parameter :: b = 2. + real, parameter :: KK = 3. + real, parameter :: Te = 310. + real, parameter :: Tp = 240. + real, parameter :: T0 = 0.5*(Te + Tp) !!WRONG in document + real, parameter :: up = 1. + real, parameter :: zp = 1.5e4 + real(kind=R_GRID), parameter :: lamp = pi/9. + real(kind=R_GRID), parameter :: phip = 2.*lamp real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /) - real, parameter :: dp = 1115. !< Pa - real, parameter :: rp = 282000. !< m - real, parameter :: zp = 7000. !< m - real, parameter :: fc = 2.*OMEGA*sin(phip) + real, parameter :: Rp = radius/10. + real, parameter :: lapse = 5.e-3 + real, parameter :: dT = 4.8e5 + real, parameter :: phiW = 2.*pi/9. + real, parameter :: pW = 34000. + real, parameter :: q0 = .018 + real, parameter :: qt = 1.e-12 + real, parameter :: ptrop = 1.e4 real, parameter :: zconv = 1.e-6 real, parameter :: rdgrav = rdgas/grav + !real, parameter :: zvir = rvgas/rdgas - 1. + real :: zvir real, parameter :: rrdgrav = grav/rdgas integer :: i,j,k,iter, sphum, cl, cl2, n - real :: p,z,z0,ziter,piter,titer,uu,vv,pl, r + real :: p,z,z0,ziter,piter,titer,uu,vv,pl,pt_u,pt_v real(kind=R_GRID), dimension(2) :: pa real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey - real, dimension(is:ie,js:je) :: rc - real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2, rc_u + real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2 real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u - real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2, rc_v + real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2 real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v !Compute ps, phis, delp, aux pressure variables, Temperature, winds - ! (with or without perturbation), moisture, w, delz + ! (with or without perturbation), moisture, Terminator tracer, w, delz !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal ! and meridional winds on both grids, and rotate as needed - - !Save r for easy use - do j=js,je - do i=is,ie - rc(i,j) = great_circle_dist(agrid(i,j,:), ppcenter, radius) - enddo - enddo + zvir = rvgas/rdgas - 1. !PS do j=js,je do i=is,ie - ps(i,j) = pb - dp*exp( -sqrt((rc(i,j)/rp)**3) ) + ps(i,j) = p0 enddo enddo @@ -7609,8 +7514,8 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& z = gz(i,j,k+1) do iter=1,30 ziter = z - piter = DCMIP16_TC_pressure(ziter,rc(i,j)) - titer = DCMIP16_TC_temperature(ziter,rc(i,j)) + piter = DCMIP16_BC_pressure(ziter,agrid(i,j,2)) + titer = DCMIP16_BC_temperature(ziter,agrid(i,j,2)) z = ziter + (piter - p)*rdgrav*titer/piter !!$ !!! DEBUG CODE !!$ if (is_master() .and. i == is .and. j == js) then @@ -7624,7 +7529,7 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& enddo enddo - !Temperature: Compute from hydro balance + !(Virtual) Temperature: Compute from hydro balance do k=1,npz do j=js,je do i=is,ie @@ -7633,10 +7538,16 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& enddo enddo + call mpp_update_domains(pt, domain) + call mpp_update_domains(gz, domain) !Compute height and temperature for u and v points also, to be able to compute the local winds !Use temporary 2d arrays for this purpose do j=js,je+1 do i=is,ie + gz_u(i,j) = 0. + p_u(i,j) = p0 + peln_u(i,j) = log(p0) + ps_u(i,j) = p0 call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa) lat_u(i,j) = pa(2) lon_u(i,j) = pa(1) @@ -7644,11 +7555,6 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& call get_latlon_vector(pa,ex,ey) u1(i,j) = inner_prod(e1,ex) !u components u2(i,j) = inner_prod(e1,ey) - rc_u(i,j) = great_circle_dist(pa, ppcenter, radius) - gz_u(i,j) = 0. - p_u(i,j) = pb - dp*exp( -sqrt((rc_u(i,j)/rp)**3) ) - peln_u(i,j) = log(p_u(i,j)) - ps_u(i,j) = p_u(i,j) enddo enddo do k=npz,1,-1 @@ -7662,14 +7568,20 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& z0 = z do iter=1,30 ziter = z - piter = DCMIP16_TC_pressure(ziter,rc_u(i,j)) - titer = DCMIP16_TC_temperature(ziter,rc_u(i,j)) + piter = DCMIP16_BC_pressure(ziter,lat_u(i,j)) + titer = DCMIP16_BC_temperature(ziter,lat_u(i,j)) z = ziter + (piter - p)*rdgrav*titer/piter if (abs(z - ziter) < zconv) exit enddo - !Now compute winds - call DCMIP16_TC_uwind_pert(0.5*(z+z0),rc_u(i,j),lon_u(i,j),lat_u(i,j), uu, vv) - u(i,j,k) = u1(i,j)*uu + u2(i,j)*vv + !Temperature, compute from hydro balance + pt_u = rrdgrav * ( z - gz_u(i,j) ) / (peln_u(i,j) - pl) + !Now compute winds. Note no meridional winds + !!!NOTE: do we need to use LAYER-mean z? + uu = DCMIP16_BC_uwind(0.5*(z+z0),pt_u,lat_u(i,j)) + if (do_pert) then + uu = uu + DCMIP16_BC_uwind_pert(0.5*(z+z0),lat_u(i,j),lon_u(i,j)) + endif + u(i,j,k) = u1(i,j)*uu gz_u(i,j) = z p_u(i,j) = p @@ -7680,6 +7592,10 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& do j=js,je do i=is,ie+1 + gz_v(i,j) = 0. + p_v(i,j) = p0 + peln_v(i,j) = log(p0) + ps_v(i,j) = p0 call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa) lat_v(i,j) = pa(2) lon_v(i,j) = pa(1) @@ -7687,11 +7603,6 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& call get_latlon_vector(pa,ex,ey) v1(i,j) = inner_prod(e2,ex) !v components v2(i,j) = inner_prod(e2,ey) - rc_v(i,j) = great_circle_dist(pa, ppcenter, radius) - gz_v(i,j) = 0. - p_v(i,j) = pb - dp*exp( - sqrt((rc_v(i,j)/rp)**3) ) - peln_v(i,j) = log(p_v(i,j)) - ps_v(i,j) = p_v(i,j) enddo enddo do k=npz,1,-1 @@ -7705,787 +7616,1168 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& z0 = z do iter=1,30 ziter = z - piter = DCMIP16_TC_pressure(ziter,rc_v(i,j)) - titer = DCMIP16_TC_temperature(ziter,rc_v(i,j)) + piter = DCMIP16_BC_pressure(ziter,lat_v(i,j)) + titer = DCMIP16_BC_temperature(ziter,lat_v(i,j)) z = ziter + (piter - p)*rdgrav*titer/piter if (abs(z - ziter) < zconv) exit enddo - !Now compute winds - call DCMIP16_TC_uwind_pert(0.5*(z+z0),rc_v(i,j),lon_v(i,j),lat_v(i,j), uu, vv) - v(i,j,k) = v1(i,j)*uu + v2(i,j)*vv - gz_v(i,j) = z - p_v(i,j) = p - peln_v(i,j) = pl - enddo - enddo - enddo - - !Compute moisture and other tracer fields, as desired - do n=1,nq - do k=1,npz - do j=jsd,jed - do i=isd,ied - q(i,j,k,n) = 0. - enddo - enddo - enddo - enddo - if (.not. adiabatic) then - sphum = get_tracer_index (MODEL_ATMOS, 'sphum') - do k=1,npz - do j=js,je - do i=is,ie - z = 0.5*(gz(i,j,k) + gz(i,j,k+1)) - q(i,j,k,sphum) = DCMIP16_TC_sphum(z) - enddo - enddo - enddo - endif - - !Compute nonhydrostatic variables, if needed - if (.not. hydrostatic) then - do k=1,npz - do j=js,je - do i=is,ie - w(i,j,k) = 0. - delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1) - enddo - enddo - enddo - endif - - contains - - !Initialize with virtual temperature - real function DCMIP16_TC_temperature(z, r) - - real, intent(IN) :: z, r - real :: Tv, term1, term2 - - if (z > zt) then - DCMIP16_TC_temperature = Tvt - return - endif - - Tv = Tv0 - lapse*z - term1 = grav*zp*zp* ( 1. - pb/dp * exp( sqrt(r/rp)**3 + (z/zp)**2 ) ) - term2 = 2*rdgas*Tv*z - DCMIP16_TC_temperature = Tv + Tv*( 1./(1 + term2/term1) - 1.) - - end function DCMIP16_TC_temperature - - !Initialize with moist air mass - real function DCMIP16_TC_pressure(z, r) - - real, intent(IN) :: z, r - - if (z <= zt) then - DCMIP16_TC_pressure = pb*exp(grav/(Rdgas*lapse) * log( (Tv0-lapse*z)/Tv0) ) -dp* exp(-sqrt((r/rp)**3) - (z/zp)**2) * & - exp( grav/(Rdgas*lapse) * log( (Tv0-lapse*z)/Tv0) ) - else - DCMIP16_TC_pressure = ptt*exp(grav*(zt-z)/(Rdgas*Tvt)) - endif - - end function DCMIP16_TC_pressure - - subroutine DCMIP16_TC_uwind_pert(z,r,lon,lat,uu,vv) - - real, intent(IN) :: z, r - real(kind=R_GRID), intent(IN) :: lon, lat - real, intent(OUT) :: uu, vv - real :: rfac, Tvrd, vt, fr5, d1, d2, d - real(kind=R_GRID) :: dst, pphere(2) - - if (z > zt) then - uu = 0. - vv = 0. - return - endif - - rfac = sqrt(r/rp)**3 - - fr5 = 0.5*fc*r - Tvrd = (Tv0 - lapse*z)*Rdgas - - vt = -fr5 + sqrt( fr5**2 - (1.5 * rfac * Tvrd) / & - ( 1. + 2*Tvrd*z/(grav*zp**2) - pb/dp*exp( rfac + (z/zp)**2) ) ) - - d1 = sin(phip)*cos(lat) - cos(phip)*sin(lat)*cos(lon - lamp) - d2 = cos(phip)*sin(lon - lamp) - d = max(1.e-25,sqrt(d1*d1 + d2*d2)) - - uu = vt * d1/d - vv = vt * d2/d - - end subroutine DCMIP16_TC_uwind_pert - - real function DCMIP16_TC_sphum(z) - - real, intent(IN) :: z - - DCMIP16_TC_sphum = qt - if (z < zt) then - DCMIP16_TC_sphum = q0 * exp(-z/zq1) * exp(-(z/zq2 )**2) - endif - - end function DCMIP16_TC_sphum - - end subroutine DCMIP16_TC - - subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, & - gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, & - mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in) - - real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) - - real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) - - real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) - real , intent(INOUT) :: pe(is-1:ie+1,npz+1,js-1:je+1) - real , intent(INOUT) :: pk(is:ie ,js:je ,npz+1) - real , intent(INOUT) :: peln(is :ie ,npz+1 ,js:je) - real , intent(INOUT) :: pkz(is:ie ,js:je ,npz ) - real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) - real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) - real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) - real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) - real , intent(inout) :: delz(isd:,jsd:,1:) - real , intent(inout) :: ze0(is:,js:,1:) - - real , intent(IN) :: ak(npz+1) - real , intent(IN) :: bk(npz+1) - - integer, intent(IN) :: npx, npy, npz - integer, intent(IN) :: ng, ncnst - integer, intent(IN) :: ndims - integer, intent(IN) :: nregions - integer,target,intent(IN):: tile_in - - real, intent(IN) :: dry_mass - logical, intent(IN) :: mountain - logical, intent(IN) :: moist_phys - logical, intent(IN) :: hybrid_z - - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(IN), target :: domain_in - - real, pointer, dimension(:,:,:) :: agrid, grid - real, pointer, dimension(:,:) :: area, rarea, fC, f0 - real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 - real, pointer, dimension(:,:,:,:) :: ew, es - real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc - - logical, pointer :: cubed_sphere, latlon - - type(domain2d), pointer :: domain - integer, pointer :: tile - - logical, pointer :: have_south_pole, have_north_pole + !Temperature, compute from hydro balance + pt_v = rrdgrav * ( z - gz_v(i,j) ) / (peln_v(i,j) - pl) + !Now compute winds + uu = DCMIP16_BC_uwind(0.5*(z+z0),pt_v,lat_v(i,j)) + if (do_pert) then + uu = uu + DCMIP16_BC_uwind_pert(0.5*(z+z0),lat_v(i,j),lon_v(i,j)) + endif + v(i,j,k) = v1(i,j)*uu + gz_v(i,j) = z + p_v(i,j) = p + peln_v(i,j) = pl + enddo + enddo + enddo - integer, pointer :: ntiles_g - real, pointer :: acapN, acapS, globalarea + !Compute nonhydrostatic variables, if needed + if (.not. hydrostatic) then + do k=1,npz + do j=js,je + do i=is,ie + w(i,j,k) = 0. + !Re-compute from hydro balance + delz(i,j,k) = rdgrav * (peln(i,k+1,j) - peln(i,k,j)) * pt(i,j,k) + !delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1) + enddo + enddo + enddo + endif + !Compute moisture and other tracer fields, as desired + do n=1,nq + do k=1,npz + do j=jsd,jed + do i=isd,ied + q(i,j,k,n) = 0. + enddo + enddo + enddo + enddo + sphum = get_tracer_index (MODEL_ATMOS, 'sphum') + do k=1,npz + do j=js,je + do i=is,ie + p = delp(i,j,k)/(peln(i,k+1,j) - peln(i,k,j)) + q(i,j,k,sphum) = DCMIP16_BC_sphum(p,ps(i,j),agrid(i,j,2),agrid(i,j,1)) + enddo + enddo + enddo - real(kind=R_GRID) :: p1(2), p2(2) - real :: r, r0 - integer :: i,j + cl = get_tracer_index(MODEL_ATMOS, 'cl') + cl2 = get_tracer_index(MODEL_ATMOS, 'cl2') + if (cl > 0 .and. cl2 > 0) then + call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, & + q, delp,nq,agrid(isd,jsd,1),agrid(isd,jsd,2),bd) + call mpp_update_domains(q,domain) + endif - agrid => gridstruct%agrid - grid => gridstruct%grid + if (.not. adiabatic) then + do k=1,npz + do j=js,je + do i=is,ie + !Convert pt to non-virtual temperature + pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum)) + enddo + enddo + enddo + endif - area => gridstruct%area + contains - dx => gridstruct%dx - dy => gridstruct%dy - dxa => gridstruct%dxa - dya => gridstruct%dya - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - dxc => gridstruct%dxc - dyc => gridstruct%dyc + + real function DCMIP16_BC_temperature(z, lat) - fC => gridstruct%fC - f0 => gridstruct%f0 + real, intent(IN) :: z + real(kind=R_GRID), intent(IN) :: lat + real :: IT, T1, T2, Tr, zsc - ntiles_g => gridstruct%ntiles_g - acapN => gridstruct%acapN - acapS => gridstruct%acapS - globalarea => gridstruct%globalarea + IT = exp(KK * log(cos(lat))) - KK/(KK+2.)*exp((KK+2.)*log(cos(lat))) + zsc = z*grav/(b*Rdgas*T0) + Tr = ( 1. - 2.*zsc**2.) * exp(-zsc**2. ) - domain => domain_in - tile => tile_in + T1 = (1./T0)*exp(lapse*z/T0) + (T0 - Tp)/(T0*Tp) * Tr + T2 = 0.5* ( KK + 2.) * (Te - Tp)/(Te*Tp) * Tr - have_south_pole => gridstruct%have_south_pole - have_north_pole => gridstruct%have_north_pole + DCMIP16_BC_temperature = 1./(T1 - T2*IT) - do j=jsd,jed+1 - do i=isd,ied+1 - fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) & - +sin(grid(i,j,2))*cos(alpha) ) - enddo - enddo - do j=jsd,jed - do i=isd,ied - f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) & - +sin(agrid(i,j,2))*cos(alpha) ) - enddo - enddo + end function DCMIP16_BC_temperature - select case (test_case) - case ( 1 ) + real function DCMIP16_BC_pressure(z,lat) - Ubar = (2.0*pi*radius)/(12.0*86400.0) - phis = 0.0 - r0 = radius/3. !RADIUS radius/3. -!!$ p1(1) = 0. - p1(1) = pi/2. + pi_shift - p1(2) = 0. - do j=jsd,jed - do i=isd,ied - p2(1) = agrid(i,j,1) - p2(2) = agrid(i,j,2) - r = great_circle_dist( p1, p2, radius ) - if (r < r0) then - delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(PI*r/r0)) - else - delp(i,j,1) = phis(i,j) - endif - enddo - enddo - call init_latlon_winds(UBar, u, v, ua, va, uc, vc, 1, gridstruct) + real, intent(IN) :: z + real(kind=R_GRID), intent(IN) :: lat + real :: IT, Ti1, Ti2, Tir + IT = exp(KK * log(cos(lat))) - KK/(KK+2.)*exp((KK+2.)*log(cos(lat))) + Tir = z*exp(-(z*grav/(b*Rdgas*T0))*(z*grav/(b*Rdgas*T0)) ) -!!$ phis(:,:)=0. -!!$ -!!$ u (:,:,:)=10. -!!$ v (:,:,:)=10. -!!$ ua(:,:,:)=10. -!!$ va(:,:,:)=10. -!!$ uc(:,:,:)=10. -!!$ vc(:,:,:)=10. -!!$ pt(:,:,:)=1. -!!$ delp(:,:,:)=0. -!!$ -!!$ do j=js,je -!!$ if (j>10 .and. j<15) then -!!$ do i=is,ie -!!$ if (i>10 .and. i<15) then -!!$ delp(i,j,:)=1. -!!$ endif -!!$ enddo -!!$ endif -!!$ enddo -!!$ call mpp_update_domains( delp, domain ) + Ti1 = 1./lapse* (exp(lapse*z/T0) - 1.) + Tir*(T0-Tp)/(T0*Tp) + Ti2 = 0.5*(KK+2.)*(Te-Tp)/(Te*Tp) * Tir - end select + DCMIP16_BC_pressure = p0*exp(-grav/Rdgas * ( Ti1 - Ti2*IT)) - nullify(grid) - nullify(agrid) + end function DCMIP16_BC_pressure - nullify(area) + real function DCMIP16_BC_uwind(z,T,lat) - nullify(fC) - nullify(f0) + real, intent(IN) :: z, T + real(kind=R_GRID), intent(IN) :: lat + real :: Tir, Ti2, UU, ur - nullify(dx) - nullify(dy) - nullify(dxa) - nullify(dya) - nullify(rdxa) - nullify(rdya) - nullify(dxc) - nullify(dyc) + Tir = z*exp(-(z*grav/(b*Rdgas*T0))*(z*grav/(b*Rdgas*T0)) ) + Ti2 = 0.5*(KK+2.)*(Te-Tp)/(Te*Tp) * Tir - nullify(domain) - nullify(tile) - - nullify(have_south_pole) - nullify(have_north_pole) + UU = grav*KK/radius * Ti2 * ( cos(lat)**(int(KK)-1) - cos(lat)**(int(KK)+1) ) * T + ur = - omega * radius * cos(lat) + sqrt( (omega*radius*cos(lat))**2 + radius*cos(lat)*UU) - nullify(ntiles_g) - nullify(acapN) - nullify(acapS) - nullify(globalarea) + DCMIP16_BC_uwind = ur - end subroutine init_latlon + end function DCMIP16_BC_uwind - subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct) + real function DCMIP16_BC_uwind_pert(z,lat,lon) - ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate + real, intent(IN) :: z + real(kind=R_GRID), intent(IN) :: lat, lon + real :: ZZ, zrat + real(kind=R_GRID) :: dst, pphere(2) - real, intent(INOUT) :: UBar - real, intent(INOUT) :: u(isd:ied ,jsd:jed+1) - real, intent(INOUT) :: v(isd:ied+1,jsd:jed ) - real, intent(INOUT) :: uc(isd:ied+1,jsd:jed ) - real, intent(INOUT) :: vc(isd:ied ,jsd:jed+1) - real, intent(INOUT) :: ua(isd:ied ,jsd:jed ) - real, intent(INOUT) :: va(isd:ied ,jsd:jed ) - integer, intent(IN) :: defOnGrid - type(fv_grid_type), intent(IN), target :: gridstruct + zrat = z/zp + ZZ = max(1. - 3.*zrat*zrat + 2.*zrat*zrat*zrat, 0.) - real :: p1(2),p2(2),p3(2),p4(2), pt(2) - real :: e1(3), e2(3), ex(3), ey(3) + pphere = (/ lon, lat /) + dst = great_circle_dist(pphere, ppcenter, radius) + + DCMIP16_BC_uwind_pert = max(0., up*ZZ*exp(-(dst/Rp)**2) ) - real :: dist, r, r0 - integer :: i,j,k,n - real :: utmp, vtmp + end function DCMIP16_BC_uwind_pert - real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2 + real function DCMIP16_BC_sphum(p,ps,lat, lon) - real, dimension(:,:,:), pointer :: grid, agrid - real, dimension(:,:), pointer :: area, dx, dy, dxc, dyc + real, intent(IN) :: p, ps + real(kind=R_GRID), intent(IN) :: lat, lon + real :: eta - grid => gridstruct%grid - agrid=> gridstruct%agrid + eta = p/ps - area => gridstruct%area - dx => gridstruct%dx - dy => gridstruct%dy - dxc => gridstruct%dxc - dyc => gridstruct%dyc + DCMIP16_BC_sphum = qt + if (p > ptrop) then + DCMIP16_BC_sphum = q0 * exp(-(lat/phiW)**4) * exp(-( (eta-1.)*p0/pw)**2) + endif - psi(:,:) = 1.e25 - psi_b(:,:) = 1.e25 - do j=jsd,jed - do i=isd,ied - psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - & - cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) ) - enddo - enddo - do j=jsd,jed+1 - do i=isd,ied+1 - psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - & - cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) ) - enddo - enddo - - if ( defOnGrid == 1 ) then - do j=jsd,jed+1 - do i=isd,ied - dist = dx(i,j) - vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist - if (dist==0) vc(i,j) = 0. - enddo - enddo - do j=jsd,jed - do i=isd,ied+1 - dist = dy(i,j) - uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist - if (dist==0) uc(i,j) = 0. - enddo - enddo + end function DCMIP16_BC_sphum - - do j=js,je - do i=is,ie+1 - dist = dxc(i,j) - v(i,j) = (psi(i,j)-psi(i-1,j))/dist - if (dist==0) v(i,j) = 0. - enddo - enddo - do j=js,je+1 - do i=is,ie - dist = dyc(i,j) - u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist - if (dist==0) u(i,j) = 0. - enddo - enddo - endif - - end subroutine init_latlon_winds - - subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, nested, & - u,v, ua,va, uc,vc, gridstruct, domain) - -! Input - integer, intent(IN) :: im,jm,km - integer, intent(IN) :: ifirst,ilast - integer, intent(IN) :: jfirst,jlast - integer, intent(IN) :: ng - logical, intent(IN) :: nested - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - - !real , intent(in) :: sinlon(im,jm) - !real , intent(in) :: coslon(im,jm) - !real , intent(in) :: sinl5(im,jm) - !real , intent(in) :: cosl5(im,jm) - -! Output - ! real , intent(inout) :: u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) - ! real , intent(inout) :: v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) - ! real , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) - ! real , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) - ! real , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) - ! real , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) - - real , intent(inout) :: u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) - real , intent(inout) :: v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) - real , intent(inout) :: ua(isd:ied,jsd:jed) !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) - real , intent(inout) :: va(isd:ied,jsd:jed) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) - real , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) - real , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) - -!-------------------------------------------------------------- -! Local - - real :: sinlon(im,jm) - real :: coslon(im,jm) - real :: sinl5(im,jm) - real :: cosl5(im,jm) - - real :: tmp1(jsd:jed+1) - real :: tmp2(jsd:jed) - real :: tmp3(jsd:jed) - - real mag,mag1,mag2, ang,ang1,ang2 - real us, vs, un, vn - integer i, j, k, im2 - integer js1g1 - integer js2g1 - integer js2g2 - integer js2gc - integer js2gc1 - integer js2gcp1 - integer js2gd - integer jn2gc - integer jn1g1 - integer jn1g2 - integer jn2gd - integer jn2gsp1 - - real, pointer, dimension(:,:,:) :: agrid, grid - real, pointer, dimension(:,:) :: area, rarea, fC, f0 - real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 - real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es - real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc + end subroutine DCMIP16_BC - logical, pointer :: cubed_sphere, latlon + subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& + is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, & + pk,peln,pe,pkz,gz,phis,ps,grid,agrid, & + hydrostatic, nwat, adiabatic) - logical, pointer :: have_south_pole, have_north_pole + integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat + real, intent(IN) :: ptop + real, intent(IN), dimension(npz+1) :: ak, bk + real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q + real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w + real, intent(OUT), dimension(is:,js:,1:) :: delz + real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u + real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v + real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk + real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln + real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe + real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz + real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps + real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid + real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid + real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz + logical, intent(IN) :: hydrostatic,adiabatic - integer, pointer :: ntiles_g - real, pointer :: acapN, acapS, globalarea + real, parameter :: zt = 15000 !< m + real, parameter :: q0 = 0.021 !< kg/kg + real, parameter :: qt = 1.e-11 !< kg/kg + real, parameter :: T0 = 302.15 !< K + real, parameter :: Tv0 = 302.15*(1.+0.608*q0) !< K + real, parameter :: Ts = 302.15 !< K + real, parameter :: zq1 = 3000. !< m + real, parameter :: zq2 = 8000. !< m + real, parameter :: lapse = 7.e-3 !< K/m + real, parameter :: Tvt = Tv0 - lapse*zt !< K + real, parameter :: pb = 101500. !< Pa + real, parameter :: ptt = pb*(TvT/Tv0)**(grav/Rdgas/lapse) + real(kind=R_GRID), parameter :: lamp = pi + real(kind=R_GRID), parameter :: phip = pi/18. + real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /) + real, parameter :: dp = 1115. !< Pa + real, parameter :: rp = 282000. !< m + real, parameter :: zp = 7000. !< m + real, parameter :: fc = 2.*OMEGA*sin(phip) - grid => gridstruct%grid - agrid=> gridstruct%agrid + real, parameter :: zconv = 1.e-6 + real, parameter :: rdgrav = rdgas/grav + real, parameter :: rrdgrav = grav/rdgas + real, parameter :: zvir = rvgas/rdgas - 1. - area => gridstruct%area - rarea => gridstruct%rarea + integer :: i,j,k,iter, sphum, cl, cl2, n + real :: p,z,z0,ziter,piter,titer,uu,vv,pl, r + real(kind=R_GRID), dimension(2) :: pa + real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey + real, dimension(is:ie,js:je) :: rc + real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2, rc_u + real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u + real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2, rc_v + real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v - fC => gridstruct%fC - f0 => gridstruct%f0 + !Compute ps, phis, delp, aux pressure variables, Temperature, winds + ! (with or without perturbation), moisture, w, delz - ee1 => gridstruct%ee1 - ee2 => gridstruct%ee2 - ew => gridstruct%ew - es => gridstruct%es - en1 => gridstruct%en1 - en2 => gridstruct%en2 + !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal + ! and meridional winds on both grids, and rotate as needed - dx => gridstruct%dx - dy => gridstruct%dy - dxa => gridstruct%dxa - dya => gridstruct%dya - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - dxc => gridstruct%dxc - dyc => gridstruct%dyc - - cubed_sphere => gridstruct%cubed_sphere - latlon => gridstruct%latlon + !Save r for easy use + do j=js,je + do i=is,ie + rc(i,j) = great_circle_dist(agrid(i,j,:), ppcenter, radius) + enddo + enddo - have_south_pole => gridstruct%have_south_pole - have_north_pole => gridstruct%have_north_pole + !PS + do j=js,je + do i=is,ie + ps(i,j) = pb - dp*exp( -sqrt((rc(i,j)/rp)**3) ) + enddo + enddo - ntiles_g => gridstruct%ntiles_g - acapN => gridstruct%acapN - acapS => gridstruct%acapS - globalarea => gridstruct%globalarea + !delp + do k=1,npz + do j=js,je + do i=is,ie + delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k)) + enddo + enddo + enddo - if (cubed_sphere) then - - call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,im,jm,ng) - if (.not. nested) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.) - call atoc(ua,va,uc,vc,dx,dy,dxa,dya,im,jm,ng, nested, domain, noComm=.true.) - if (.not. nested) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.) - - else ! Lat-Lon - - im2 = im/2 - -! Set loop limits - - js1g1 = jfirst-1 - js2g1 = jfirst-1 - js2g2 = jfirst-2 - js2gc = jfirst-ng - js2gcp1 = jfirst-ng-1 - js2gd = jfirst-ng - jn1g1 = jlast+1 - jn1g2 = jlast+2 - jn2gc = jlast+ng - jn2gd = jlast+ng-1 - jn2gsp1 = jlast+ng-1 - - if (have_south_pole) then - js1g1 = 1 - js2g1 = 2 - js2g2 = 2 - js2gc = 2 - js2gcp1 = 2 ! NG-1 latitudes on S (starting at 2) - js2gd = 2 - endif - if (have_north_pole) then - jn1g1 = jm - jn1g2 = jm - jn2gc = jm-1 ! NG latitudes on N (ending at jm-1) - jn2gd = jm-1 - jn2gsp1 = jm-1 - endif -! -! Treat the special case of ng = 1 -! - if ( ng == 1 .AND. ng > 1 ) THEN - js2gc1 = js2gc - else - js2gc1 = jfirst-ng+1 - if (have_south_pole) js2gc1 = 2 ! NG-1 latitudes on S (starting at 2) - endif + !Pressure variables + do j=js,je + do i=is,ie + pe(i,1,j) = ptop + enddo + do i=is,ie + peln(i,1,j) = log(ptop) + pk(i,j,1) = ptop**kappa + enddo + do k=2,npz+1 + do i=is,ie + pe(i,k,j) = ak(k) + ps (i,j)*bk(k) + enddo + do i=is,ie + pk(i,j,k) = exp(kappa*log(pe(i,k,j))) + peln(i,k,j) = log(pe(i,k,j)) + enddo + enddo + enddo + + do k=1,npz + do j=js,je + do i=is,ie + pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j))) + enddo + enddo + enddo - do k=1,km + !Height: Use Newton's method + !Cell centered + do j=js,je + do i=is,ie + phis(i,j) = 0. + gz(i,j,npz+1) = 0. + enddo + enddo + do k=npz,1,-1 + do j=js,je + do i=is,ie + p = pe(i,k,j) + z = gz(i,j,k+1) + do iter=1,30 + ziter = z + piter = DCMIP16_TC_pressure(ziter,rc(i,j)) + titer = DCMIP16_TC_temperature(ziter,rc(i,j)) + z = ziter + (piter - p)*rdgrav*titer/piter +!!$ !!! DEBUG CODE +!!$ if (is_master() .and. i == is .and. j == js) then +!!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer +!!$ endif +!!$ !!! END DEBUG CODE + if (abs(z - ziter) < zconv) exit + enddo + gz(i,j,k) = z + enddo + enddo + enddo - if ((have_south_pole) .or. (have_north_pole)) then -! Get D-grid V-wind at the poles. - call vpol5(u(1:im,:), v(1:im,:), im, jm, & - coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast ) - call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:)) - endif + !Temperature: Compute from hydro balance + do k=1,npz + do j=js,je + do i=is,ie + pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j)) + enddo + enddo + enddo - call dtoa(u, v, ua, va, dx,dy,dxa,dya,dxc,dyc,im, jm, ng) - if (.not. nested) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.) + !Compute height and temperature for u and v points also, to be able to compute the local winds + !Use temporary 2d arrays for this purpose + do j=js,je+1 + do i=is,ie + call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa) + lat_u(i,j) = pa(2) + lon_u(i,j) = pa(1) + call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1) + call get_latlon_vector(pa,ex,ey) + u1(i,j) = inner_prod(e1,ex) !u components + u2(i,j) = inner_prod(e1,ey) + rc_u(i,j) = great_circle_dist(pa, ppcenter, radius) + gz_u(i,j) = 0. + p_u(i,j) = pb - dp*exp( -sqrt((rc_u(i,j)/rp)**3) ) + peln_u(i,j) = log(p_u(i,j)) + ps_u(i,j) = p_u(i,j) + enddo + enddo + do k=npz,1,-1 + do j=js,je+1 + do i=is,ie + !Pressure (Top of interface) + p = ak(k) + ps_u(i,j)*bk(k) + pl = log(p) + !Height (top of interface); use newton's method + z = gz_u(i,j) !first guess, height of lower level + z0 = z + do iter=1,30 + ziter = z + piter = DCMIP16_TC_pressure(ziter,rc_u(i,j)) + titer = DCMIP16_TC_temperature(ziter,rc_u(i,j)) + z = ziter + (piter - p)*rdgrav*titer/piter + if (abs(z - ziter) < zconv) exit + enddo + !Now compute winds + call DCMIP16_TC_uwind_pert(0.5*(z+z0),rc_u(i,j),lon_u(i,j),lat_u(i,j), uu, vv) + u(i,j,k) = u1(i,j)*uu + u2(i,j)*vv - if ( have_south_pole ) then -! Projection at SP - us = 0. - vs = 0. - do i=1,im2 - us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2) & - + (va(i,2)-va(i+im2,2))*coslon(i,2) - vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2) & - + (va(i+im2,2)-va(i,2))*sinlon(i,2) - enddo - us = us/im - vs = vs/im -! SP - do i=1,im2 - ua(i,1) = -us*sinlon(i,1) - vs*coslon(i,1) - va(i,1) = us*coslon(i,1) - vs*sinlon(i,1) - ua(i+im2,1) = -ua(i,1) - va(i+im2,1) = -va(i,1) - enddo - ua(0 ,1) = ua(im,1) - ua(im+1,1) = ua(1 ,1) - va(im+1,1) = va(1 ,1) - endif + gz_u(i,j) = z + p_u(i,j) = p + peln_u(i,j) = pl + enddo + enddo + enddo - if ( have_north_pole ) then -! Projection at NP - un = 0. - vn = 0. - j = jm-1 - do i=1,im2 - un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j) & - + (va(i+im2,j)-va(i,j))*coslon(i,j) - vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j) & - + (va(i+im2,j)-va(i,j))*sinlon(i,j) - enddo - un = un/im - vn = vn/im -! NP - do i=1,im2 - ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm) - va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm) - ua(i+im2,jm) = -ua(i,jm) - va(i+im2,jm) = -va(i,jm) - enddo - ua(0 ,jm) = ua(im,jm) - ua(im+1,jm) = ua(1 ,jm) - va(im+1,jm) = va(1 ,jm) - endif + do j=js,je + do i=is,ie+1 + call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa) + lat_v(i,j) = pa(2) + lon_v(i,j) = pa(1) + call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2) + call get_latlon_vector(pa,ex,ey) + v1(i,j) = inner_prod(e2,ex) !v components + v2(i,j) = inner_prod(e2,ey) + rc_v(i,j) = great_circle_dist(pa, ppcenter, radius) + gz_v(i,j) = 0. + p_v(i,j) = pb - dp*exp( - sqrt((rc_v(i,j)/rp)**3) ) + peln_v(i,j) = log(p_v(i,j)) + ps_v(i,j) = p_v(i,j) + enddo + enddo + do k=npz,1,-1 + do j=js,je + do i=is,ie+1 + !Pressure (Top of interface) + p = ak(k) + ps_v(i,j)*bk(k) + pl = log(p) + !Height (top of interface); use newton's method + z = gz_v(i,j) !first guess, height of lower level + z0 = z + do iter=1,30 + ziter = z + piter = DCMIP16_TC_pressure(ziter,rc_v(i,j)) + titer = DCMIP16_TC_temperature(ziter,rc_v(i,j)) + z = ziter + (piter - p)*rdgrav*titer/piter + if (abs(z - ziter) < zconv) exit + enddo + !Now compute winds + call DCMIP16_TC_uwind_pert(0.5*(z+z0),rc_v(i,j),lon_v(i,j),lat_v(i,j), uu, vv) + v(i,j,k) = v1(i,j)*uu + v2(i,j)*vv + gz_v(i,j) = z + p_v(i,j) = p + peln_v(i,j) = pl + enddo + enddo + enddo - if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:)) - if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:)) + !Compute moisture and other tracer fields, as desired + do n=1,nq + do k=1,npz + do j=jsd,jed + do i=isd,ied + q(i,j,k,n) = 0. + enddo + enddo + enddo + enddo + if (.not. adiabatic) then + sphum = get_tracer_index (MODEL_ATMOS, 'sphum') + do k=1,npz + do j=js,je + do i=is,ie + z = 0.5*(gz(i,j,k) + gz(i,j,k+1)) + q(i,j,k,sphum) = DCMIP16_TC_sphum(z) + !Convert pt to non-virtual temperature + pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum)) + enddo + enddo + enddo + endif -! A -> C - call atoc(ua, va, uc, vc, dx,dy,dxa,dya,im, jm, ng, nested, domain, noComm=.true.) + !Compute nonhydrostatic variables, if needed + if (.not. hydrostatic) then + do k=1,npz + do j=js,je + do i=is,ie + w(i,j,k) = 0. + delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1) + enddo + enddo + enddo + endif - enddo ! km loop + contains - if (.not. nested) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.) - endif + !Initialize with virtual temperature + real function DCMIP16_TC_temperature(z, r) + real, intent(IN) :: z, r + real :: Tv, term1, term2 - end subroutine d2a2c + if (z > zt) then + DCMIP16_TC_temperature = Tvt + return + endif - subroutine atob_s(qin, qout, npx, npy, dxa, dya, nested, cubed_sphere, altInterp) - integer, intent(IN) :: npx, npy - real , intent(IN) :: qin(isd:ied ,jsd:jed ) !< A-grid field - real , intent(OUT) :: qout(isd:ied+1,jsd:jed+1) !< Output B-grid field - integer, OPTIONAL, intent(IN) :: altInterp - logical, intent(IN) :: nested, cubed_sphere - real, intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya + Tv = Tv0 - lapse*z + term1 = grav*zp*zp* ( 1. - pb/dp * exp( sqrt(r/rp)**3 + (z/zp)**2 ) ) + term2 = 2*rdgas*Tv*z + DCMIP16_TC_temperature = Tv + Tv*( 1./(1 + term2/term1) - 1.) - integer :: i,j,n + end function DCMIP16_TC_temperature - real :: tmp1j(jsd:jed+1) - real :: tmp2j(jsd:jed+1) - real :: tmp3j(jsd:jed+1) - real :: tmp1i(isd:ied+1) - real :: tmp2i(isd:ied+1) - real :: tmp3i(isd:ied+1) - real :: tmpq(isd:ied ,jsd:jed ) - real :: tmpq1(isd:ied+1,jsd:jed+1) - real :: tmpq2(isd:ied+1,jsd:jed+1) + !Initialize with moist air mass + real function DCMIP16_TC_pressure(z, r) - if (present(altInterp)) then + real, intent(IN) :: z, r - tmpq(:,:) = qin(:,:) + if (z <= zt) then + DCMIP16_TC_pressure = pb*exp(grav/(Rdgas*lapse) * log( (Tv0-lapse*z)/Tv0) ) -dp* exp(-sqrt((r/rp)**3) - (z/zp)**2) * & + exp( grav/(Rdgas*lapse) * log( (Tv0-lapse*z)/Tv0) ) + else + DCMIP16_TC_pressure = ptt*exp(grav*(zt-z)/(Rdgas*Tvt)) + endif - if (.not. nested) call fill_corners(tmpq , npx, npy, FILL=XDir, AGRID=.true.) -! ATOC - do j=jsd,jed - call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altInterp) - enddo + end function DCMIP16_TC_pressure - if (.not. nested) call fill_corners(tmpq , npx, npy, FILL=YDir, AGRID=.true.) -! ATOD - do i=isd,ied - tmp1j(jsd:jed) = 0.0 - tmp2j(jsd:jed) = tmpq(i,jsd:jed) - tmp3j(jsd:jed) = dya(i,jsd:jed) - call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altInterp) - tmpq2(i,jsd:jed) = tmp1j(jsd:jed) - enddo + subroutine DCMIP16_TC_uwind_pert(z,r,lon,lat,uu,vv) -! CTOB - do i=isd,ied - tmp1j(:) = tmpq1(i,:) - tmp2j(:) = tmpq1(i,:) - tmp3j(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce - call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altInterp) - tmpq1(i,:) = tmp1j(:) - enddo + real, intent(IN) :: z, r + real(kind=R_GRID), intent(IN) :: lon, lat + real, intent(OUT) :: uu, vv + real :: rfac, Tvrd, vt, fr5, d1, d2, d + real(kind=R_GRID) :: dst, pphere(2) -! DTOB - do j=jsd,jed - tmp1i(:) = tmpq2(:,j) - tmp2i(:) = tmpq2(:,j) - tmp3i(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce - call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altInterp) - tmpq2(:,j) = tmp1i(:) - enddo + if (z > zt) then + uu = 0. + vv = 0. + return + endif -! Average - do j=jsd,jed+1 - do i=isd,ied+1 - qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j)) - enddo - enddo + rfac = sqrt(r/rp)**3 -! Fix Corners - if (cubed_sphere .and. .not. nested) then - i=1 - j=1 - if ( (is==i) .and. (js==j) ) then - qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1)) - endif + fr5 = 0.5*fc*r + Tvrd = (Tv0 - lapse*z)*Rdgas - i=npx - j=1 - if ( (ie+1==i) .and. (js==j) ) then - qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j)) - endif + vt = -fr5 + sqrt( fr5**2 - (1.5 * rfac * Tvrd) / & + ( 1. + 2*Tvrd*z/(grav*zp**2) - pb/dp*exp( rfac + (z/zp)**2) ) ) + + d1 = sin(phip)*cos(lat) - cos(phip)*sin(lat)*cos(lon - lamp) + d2 = cos(phip)*sin(lon - lamp) + d = max(1.e-25,sqrt(d1*d1 + d2*d2)) - i=1 - j=npy - if ( (is==i) .and. (je+1==j) ) then - qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j)) - endif + uu = vt * d1/d + vv = vt * d2/d - i=npx - j=npy - if ( (ie+1==i) .and. (je+1==j) ) then - qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j)) - endif - endif + end subroutine DCMIP16_TC_uwind_pert - else ! altInterp + real function DCMIP16_TC_sphum(z) - do j=js,je+1 - do i=is,ie+1 - qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + & - qin(i ,j) + qin(i ,j-1)) - enddo - enddo + real, intent(IN) :: z - if (.not. nested) then - i=1 - j=1 - if ( (is==i) .and. (js==j) ) then - qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1)) - endif + DCMIP16_TC_sphum = qt + if (z < zt) then + DCMIP16_TC_sphum = q0 * exp(-z/zq1) * exp(-(z/zq2 )**2) + endif - i=npx - j=1 - if ( (ie+1==i) .and. (js==j) ) then - qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j)) - endif + end function DCMIP16_TC_sphum - i=1 - j=npy - if ( (is==i) .and. (je+1==j) ) then - qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j)) - endif + end subroutine DCMIP16_TC - i=npx - j=npy - if ( (ie+1==i) .and. (je+1==j) ) then - qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j)) - endif - endif !not nested +!!$ subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, & +!!$ gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, & +!!$ mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in, bd) +!!$ +!!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) +!!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) +!!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) +!!$ +!!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) +!!$ +!!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) +!!$ real , intent(INOUT) :: pe(is-1:ie+1,npz+1,js-1:je+1) +!!$ real , intent(INOUT) :: pk(is:ie ,js:je ,npz+1) +!!$ real , intent(INOUT) :: peln(is :ie ,npz+1 ,js:je) +!!$ real , intent(INOUT) :: pkz(is:ie ,js:je ,npz ) +!!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) +!!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) +!!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) +!!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) +!!$ real , intent(inout) :: delz(is:,js:,1:) +!!$ real , intent(inout) :: ze0(is:,js:,1:) +!!$ +!!$ real , intent(IN) :: ak(npz+1) +!!$ real , intent(IN) :: bk(npz+1) +!!$ +!!$ integer, intent(IN) :: npx, npy, npz +!!$ integer, intent(IN) :: ng, ncnst +!!$ integer, intent(IN) :: ndims +!!$ integer, intent(IN) :: nregions +!!$ integer,target,intent(IN):: tile_in +!!$ +!!$ real, intent(IN) :: dry_mass +!!$ logical, intent(IN) :: mountain +!!$ logical, intent(IN) :: moist_phys +!!$ logical, intent(IN) :: hybrid_z +!!$ +!!$ type(fv_grid_type), intent(IN), target :: gridstruct +!!$ type(domain2d), intent(IN), target :: domain_in +!!$ +!!$ real, pointer, dimension(:,:,:) :: agrid, grid +!!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0 +!!$ real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 +!!$ real, pointer, dimension(:,:,:,:) :: ew, es +!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc +!!$ +!!$ logical, pointer :: cubed_sphere, latlon +!!$ +!!$ type(domain2d), pointer :: domain +!!$ integer, pointer :: tile +!!$ +!!$ logical, pointer :: have_south_pole, have_north_pole +!!$ +!!$ integer, pointer :: ntiles_g +!!$ real, pointer :: acapN, acapS, globalarea +!!$ +!!$ real(kind=R_GRID) :: p1(2), p2(2) +!!$ real :: r, r0 +!!$ integer :: i,j +!!$ +!!$ agrid => gridstruct%agrid +!!$ grid => gridstruct%grid +!!$ +!!$ area => gridstruct%area +!!$ +!!$ dx => gridstruct%dx +!!$ dy => gridstruct%dy +!!$ dxa => gridstruct%dxa +!!$ dya => gridstruct%dya +!!$ rdxa => gridstruct%rdxa +!!$ rdya => gridstruct%rdya +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ fC => gridstruct%fC +!!$ f0 => gridstruct%f0 +!!$ +!!$ ntiles_g => gridstruct%ntiles_g +!!$ acapN => gridstruct%acapN +!!$ acapS => gridstruct%acapS +!!$ globalarea => gridstruct%globalarea +!!$ +!!$ domain => domain_in +!!$ tile => tile_in +!!$ +!!$ have_south_pole => gridstruct%have_south_pole +!!$ have_north_pole => gridstruct%have_north_pole +!!$ +!!$ do j=jsd,jed+1 +!!$ do i=isd,ied+1 +!!$ fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) & +!!$ +sin(grid(i,j,2))*cos(alpha) ) +!!$ enddo +!!$ enddo +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) & +!!$ +sin(agrid(i,j,2))*cos(alpha) ) +!!$ enddo +!!$ enddo +!!$ +!!$ select case (test_case) +!!$ case ( 1 ) +!!$ +!!$ Ubar = (2.0*pi*radius)/(12.0*86400.0) +!!$ phis = 0.0 +!!$ r0 = radius/3. !RADIUS radius/3. +!!$ p1(1) = 0. +!!$ p1(1) = pi/2. + pi_shift +!!$ p1(2) = 0. +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ p2(1) = agrid(i,j,1) +!!$ p2(2) = agrid(i,j,2) +!!$ r = great_circle_dist( p1, p2, radius ) +!!$ if (r < r0) then +!!$ delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(PI*r/r0)) +!!$ else +!!$ delp(i,j,1) = phis(i,j) +!!$ endif +!!$ enddo +!!$ enddo +!!$ call init_latlon_winds(UBar, u, v, ua, va, uc, vc, 1, gridstruct) +!!$ +!!$ +!!$ +!!$ end select +!!$ +!!$ nullify(grid) +!!$ nullify(agrid) +!!$ +!!$ nullify(area) +!!$ +!!$ nullify(fC) +!!$ nullify(f0) +!!$ +!!$ nullify(dx) +!!$ nullify(dy) +!!$ nullify(dxa) +!!$ nullify(dya) +!!$ nullify(rdxa) +!!$ nullify(rdya) +!!$ nullify(dxc) +!!$ nullify(dyc) +!!$ +!!$ nullify(domain) +!!$ nullify(tile) +!!$ +!!$ nullify(have_south_pole) +!!$ nullify(have_north_pole) +!!$ +!!$ nullify(ntiles_g) +!!$ nullify(acapN) +!!$ nullify(acapS) +!!$ nullify(globalarea) +!!$ +!!$ end subroutine init_latlon +!!$ +!!$ subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct) +!!$ +!!$ ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate +!!$ +!!$ real, intent(INOUT) :: UBar +!!$ real, intent(INOUT) :: u(isd:ied ,jsd:jed+1) +!!$ real, intent(INOUT) :: v(isd:ied+1,jsd:jed ) +!!$ real, intent(INOUT) :: uc(isd:ied+1,jsd:jed ) +!!$ real, intent(INOUT) :: vc(isd:ied ,jsd:jed+1) +!!$ real, intent(INOUT) :: ua(isd:ied ,jsd:jed ) +!!$ real, intent(INOUT) :: va(isd:ied ,jsd:jed ) +!!$ integer, intent(IN) :: defOnGrid +!!$ type(fv_grid_type), intent(IN), target :: gridstruct +!!$ +!!$ real :: p1(2),p2(2),p3(2),p4(2), pt(2) +!!$ real :: e1(3), e2(3), ex(3), ey(3) +!!$ +!!$ real :: dist, r, r0 +!!$ integer :: i,j,k,n +!!$ real :: utmp, vtmp +!!$ +!!$ real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2 +!!$ +!!$ real, dimension(:,:,:), pointer :: grid, agrid +!!$ real, dimension(:,:), pointer :: area, dx, dy, dxc, dyc +!!$ +!!$ grid => gridstruct%grid +!!$ agrid=> gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ dx => gridstruct%dx +!!$ dy => gridstruct%dy +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ psi(:,:) = 1.e25 +!!$ psi_b(:,:) = 1.e25 +!!$ do j=jsd,jed +!!$ do i=isd,ied +!!$ psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - & +!!$ cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) ) +!!$ enddo +!!$ enddo +!!$ do j=jsd,jed+1 +!!$ do i=isd,ied+1 +!!$ psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - & +!!$ cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) ) +!!$ enddo +!!$ enddo +!!$ +!!$ if ( defOnGrid == 1 ) then +!!$ do j=jsd,jed+1 +!!$ do i=isd,ied +!!$ dist = dx(i,j) +!!$ vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist +!!$ if (dist==0) vc(i,j) = 0. +!!$ enddo +!!$ enddo +!!$ do j=jsd,jed +!!$ do i=isd,ied+1 +!!$ dist = dy(i,j) +!!$ uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist +!!$ if (dist==0) uc(i,j) = 0. +!!$ enddo +!!$ enddo +!!$ +!!$ +!!$ do j=js,je +!!$ do i=is,ie+1 +!!$ dist = dxc(i,j) +!!$ v(i,j) = (psi(i,j)-psi(i-1,j))/dist +!!$ if (dist==0) v(i,j) = 0. +!!$ enddo +!!$ enddo +!!$ do j=js,je+1 +!!$ do i=is,ie +!!$ dist = dyc(i,j) +!!$ u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist +!!$ if (dist==0) u(i,j) = 0. +!!$ enddo +!!$ enddo +!!$ endif +!!$ +!!$ end subroutine init_latlon_winds - endif ! altInterp +!!$ subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, bounded_domain, & +!!$ u,v, ua,va, uc,vc, gridstruct, domain, bd) +!!$ +!!$! Input +!!$ integer, intent(IN) :: im,jm,km +!!$ integer, intent(IN) :: ifirst,ilast +!!$ integer, intent(IN) :: jfirst,jlast +!!$ integer, intent(IN) :: ng +!!$ logical, intent(IN) :: bounded_domain +!!$ type(fv_grid_type), intent(IN), target :: gridstruct +!!$ type(domain2d), intent(INOUT) :: domain +!!$ +!!$ !real , intent(in) :: sinlon(im,jm) +!!$ !real , intent(in) :: coslon(im,jm) +!!$ !real , intent(in) :: sinl5(im,jm) +!!$ !real , intent(in) :: cosl5(im,jm) +!!$ +!!$! Output +!!$ ! real , intent(inout) :: u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) +!!$ ! real , intent(inout) :: v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) +!!$ ! real , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) +!!$ ! real , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) +!!$ ! real , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) +!!$ ! real , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) +!!$ +!!$ real , intent(inout) :: u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) +!!$ real , intent(inout) :: v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) +!!$ real , intent(inout) :: ua(isd:ied,jsd:jed) !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) +!!$ real , intent(inout) :: va(isd:ied,jsd:jed) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) +!!$ real , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) +!!$ real , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) +!!$ +!!$!-------------------------------------------------------------- +!!$! Local +!!$ +!!$ real :: sinlon(im,jm) +!!$ real :: coslon(im,jm) +!!$ real :: sinl5(im,jm) +!!$ real :: cosl5(im,jm) +!!$ +!!$ real :: tmp1(jsd:jed+1) +!!$ real :: tmp2(jsd:jed) +!!$ real :: tmp3(jsd:jed) +!!$ +!!$ real mag,mag1,mag2, ang,ang1,ang2 +!!$ real us, vs, un, vn +!!$ integer i, j, k, im2 +!!$ integer js1g1 +!!$ integer js2g1 +!!$ integer js2g2 +!!$ integer js2gc +!!$ integer js2gc1 +!!$ integer js2gcp1 +!!$ integer js2gd +!!$ integer jn2gc +!!$ integer jn1g1 +!!$ integer jn1g2 +!!$ integer jn2gd +!!$ integer jn2gsp1 +!!$ +!!$ real, pointer, dimension(:,:,:) :: agrid, grid +!!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0 +!!$ real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 +!!$ real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es +!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc +!!$ +!!$ logical, pointer :: cubed_sphere, latlon +!!$ +!!$ logical, pointer :: have_south_pole, have_north_pole +!!$ +!!$ integer, pointer :: ntiles_g +!!$ real, pointer :: acapN, acapS, globalarea +!!$ +!!$ grid => gridstruct%grid +!!$ agrid=> gridstruct%agrid +!!$ +!!$ area => gridstruct%area +!!$ rarea => gridstruct%rarea +!!$ +!!$ fC => gridstruct%fC +!!$ f0 => gridstruct%f0 +!!$ +!!$ ee1 => gridstruct%ee1 +!!$ ee2 => gridstruct%ee2 +!!$ ew => gridstruct%ew +!!$ es => gridstruct%es +!!$ en1 => gridstruct%en1 +!!$ en2 => gridstruct%en2 +!!$ +!!$ dx => gridstruct%dx +!!$ dy => gridstruct%dy +!!$ dxa => gridstruct%dxa +!!$ dya => gridstruct%dya +!!$ rdxa => gridstruct%rdxa +!!$ rdya => gridstruct%rdya +!!$ dxc => gridstruct%dxc +!!$ dyc => gridstruct%dyc +!!$ +!!$ cubed_sphere => gridstruct%cubed_sphere +!!$ latlon => gridstruct%latlon +!!$ +!!$ have_south_pole => gridstruct%have_south_pole +!!$ have_north_pole => gridstruct%have_north_pole +!!$ +!!$ ntiles_g => gridstruct%ntiles_g +!!$ acapN => gridstruct%acapN +!!$ acapS => gridstruct%acapS +!!$ globalarea => gridstruct%globalarea +!!$ +!!$ if (cubed_sphere) then +!!$ +!!$ call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,im,jm,ng) +!!$ if (.not. bounded_domain) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.) +!!$ call atoc(ua,va,uc,vc,dx,dy,dxa,dya,im,jm,ng, bounded_domain, domain, noComm=.true.) +!!$ if (.not. bounded_domain) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.) +!!$ +!!$ else ! Lat-Lon +!!$ +!!$ im2 = im/2 +!!$ +!!$! Set loop limits +!!$ +!!$ js1g1 = jfirst-1 +!!$ js2g1 = jfirst-1 +!!$ js2g2 = jfirst-2 +!!$ js2gc = jfirst-ng +!!$ js2gcp1 = jfirst-ng-1 +!!$ js2gd = jfirst-ng +!!$ jn1g1 = jlast+1 +!!$ jn1g2 = jlast+2 +!!$ jn2gc = jlast+ng +!!$ jn2gd = jlast+ng-1 +!!$ jn2gsp1 = jlast+ng-1 +!!$ +!!$ if (have_south_pole) then +!!$ js1g1 = 1 +!!$ js2g1 = 2 +!!$ js2g2 = 2 +!!$ js2gc = 2 +!!$ js2gcp1 = 2 ! NG-1 latitudes on S (starting at 2) +!!$ js2gd = 2 +!!$ endif +!!$ if (have_north_pole) then +!!$ jn1g1 = jm +!!$ jn1g2 = jm +!!$ jn2gc = jm-1 ! NG latitudes on N (ending at jm-1) +!!$ jn2gd = jm-1 +!!$ jn2gsp1 = jm-1 +!!$ endif +!!$! +!!$! Treat the special case of ng = 1 +!!$! +!!$ if ( ng == 1 .AND. ng > 1 ) THEN +!!$ js2gc1 = js2gc +!!$ else +!!$ js2gc1 = jfirst-ng+1 +!!$ if (have_south_pole) js2gc1 = 2 ! NG-1 latitudes on S (starting at 2) +!!$ endif +!!$ +!!$ do k=1,km +!!$ +!!$ if ((have_south_pole) .or. (have_north_pole)) then +!!$! Get D-grid V-wind at the poles. +!!$ call vpol5(u(1:im,:), v(1:im,:), im, jm, & +!!$ coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast ) +!!$ call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:)) +!!$ endif +!!$ +!!$ call dtoa(u, v, ua, va, dx,dy,dxa,dya,dxc,dyc,im, jm, ng) +!!$ if (.not. bounded_domain) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.) +!!$ +!!$ if ( have_south_pole ) then +!!$! Projection at SP +!!$ us = 0. +!!$ vs = 0. +!!$ do i=1,im2 +!!$ us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2) & +!!$ + (va(i,2)-va(i+im2,2))*coslon(i,2) +!!$ vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2) & +!!$ + (va(i+im2,2)-va(i,2))*sinlon(i,2) +!!$ enddo +!!$ us = us/im +!!$ vs = vs/im +!!$! SP +!!$ do i=1,im2 +!!$ ua(i,1) = -us*sinlon(i,1) - vs*coslon(i,1) +!!$ va(i,1) = us*coslon(i,1) - vs*sinlon(i,1) +!!$ ua(i+im2,1) = -ua(i,1) +!!$ va(i+im2,1) = -va(i,1) +!!$ enddo +!!$ ua(0 ,1) = ua(im,1) +!!$ ua(im+1,1) = ua(1 ,1) +!!$ va(im+1,1) = va(1 ,1) +!!$ endif +!!$ +!!$ if ( have_north_pole ) then +!!$! Projection at NP +!!$ un = 0. +!!$ vn = 0. +!!$ j = jm-1 +!!$ do i=1,im2 +!!$ un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j) & +!!$ + (va(i+im2,j)-va(i,j))*coslon(i,j) +!!$ vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j) & +!!$ + (va(i+im2,j)-va(i,j))*sinlon(i,j) +!!$ enddo +!!$ un = un/im +!!$ vn = vn/im +!!$! NP +!!$ do i=1,im2 +!!$ ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm) +!!$ va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm) +!!$ ua(i+im2,jm) = -ua(i,jm) +!!$ va(i+im2,jm) = -va(i,jm) +!!$ enddo +!!$ ua(0 ,jm) = ua(im,jm) +!!$ ua(im+1,jm) = ua(1 ,jm) +!!$ va(im+1,jm) = va(1 ,jm) +!!$ endif +!!$ +!!$ if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:)) +!!$ if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:)) +!!$ +!!$! A -> C +!!$ call atoc(ua, va, uc, vc, dx,dy,dxa,dya,im, jm, ng, bounded_domain, domain, noComm=.true.) +!!$ +!!$ enddo ! km loop +!!$ +!!$ if (.not. bounded_domain) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.) +!!$ endif +!!$ +!!$ +!!$ end subroutine d2a2c +!!$ - end subroutine atob_s -! -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!------------------------------------------------------------------------------- +!!$ subroutine atob_s(qin, qout, npx, npy, dxa, dya, bounded_domain, cubed_sphere, altInterp) +!!$ +!!$! atob_s :: interpolate scalar from the A-Grid to the B-grid +!!$! +!!$ integer, intent(IN) :: npx, npy +!!$ real , intent(IN) :: qin(isd:ied ,jsd:jed ) ! A-grid field +!!$ real , intent(OUT) :: qout(isd:ied+1,jsd:jed+1) ! Output B-grid field +!!$ integer, OPTIONAL, intent(IN) :: altInterp +!!$ logical, intent(IN) :: bounded_domain, cubed_sphere +!!$ real, intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya +!!$ +!!$ integer :: i,j,n +!!$ +!!$ real :: tmp1j(jsd:jed+1) +!!$ real :: tmp2j(jsd:jed+1) +!!$ real :: tmp3j(jsd:jed+1) +!!$ real :: tmp1i(isd:ied+1) +!!$ real :: tmp2i(isd:ied+1) +!!$ real :: tmp3i(isd:ied+1) +!!$ real :: tmpq(isd:ied ,jsd:jed ) +!!$ real :: tmpq1(isd:ied+1,jsd:jed+1) +!!$ real :: tmpq2(isd:ied+1,jsd:jed+1) +!!$ +!!$ if (present(altInterp)) then +!!$ +!!$ tmpq(:,:) = qin(:,:) +!!$ +!!$ if (.not. bounded_domain) call fill_corners(tmpq , npx, npy, FILL=XDir, AGRID=.true.) +!!$! ATOC +!!$ do j=jsd,jed +!!$ call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altInterp) +!!$ enddo +!!$ +!!$ if (.not. bounded_domain) call fill_corners(tmpq , npx, npy, FILL=YDir, AGRID=.true.) +!!$! ATOD +!!$ do i=isd,ied +!!$ tmp1j(jsd:jed) = 0.0 +!!$ tmp2j(jsd:jed) = tmpq(i,jsd:jed) +!!$ tmp3j(jsd:jed) = dya(i,jsd:jed) +!!$ call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altInterp) +!!$ tmpq2(i,jsd:jed) = tmp1j(jsd:jed) +!!$ enddo +!!$ +!!$! CTOB +!!$ do i=isd,ied +!!$ tmp1j(:) = tmpq1(i,:) +!!$ tmp2j(:) = tmpq1(i,:) +!!$ tmp3j(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce +!!$ call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altInterp) +!!$ tmpq1(i,:) = tmp1j(:) +!!$ enddo +!!$ +!!$! DTOB +!!$ do j=jsd,jed +!!$ tmp1i(:) = tmpq2(:,j) +!!$ tmp2i(:) = tmpq2(:,j) +!!$ tmp3i(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce +!!$ call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altInterp) +!!$ tmpq2(:,j) = tmp1i(:) +!!$ enddo +!!$ +!!$! Average +!!$ do j=jsd,jed+1 +!!$ do i=isd,ied+1 +!!$ qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j)) +!!$ enddo +!!$ enddo +!!$ +!!$! Fix Corners +!!$ if (cubed_sphere .and. .not. bounded_domain) then +!!$ i=1 +!!$ j=1 +!!$ if ( (is==i) .and. (js==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1)) +!!$ endif +!!$ +!!$ i=npx +!!$ j=1 +!!$ if ( (ie+1==i) .and. (js==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j)) +!!$ endif +!!$ +!!$ i=1 +!!$ j=npy +!!$ if ( (is==i) .and. (je+1==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j)) +!!$ endif +!!$ +!!$ i=npx +!!$ j=npy +!!$ if ( (ie+1==i) .and. (je+1==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j)) +!!$ endif +!!$ endif +!!$ +!!$ else ! altInterp +!!$ +!!$ do j=js,je+1 +!!$ do i=is,ie+1 +!!$ qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + & +!!$ qin(i ,j) + qin(i ,j-1)) +!!$ enddo +!!$ enddo +!!$ +!!$ if (.not. bounded_domain) then +!!$ i=1 +!!$ j=1 +!!$ if ( (is==i) .and. (js==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1)) +!!$ endif +!!$ +!!$ i=npx +!!$ j=1 +!!$ if ( (ie+1==i) .and. (js==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j)) +!!$ endif +!!$ +!!$ i=1 +!!$ j=npy +!!$ if ( (is==i) .and. (je+1==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j)) +!!$ endif +!!$ +!!$ i=npx +!!$ j=npy +!!$ if ( (ie+1==i) .and. (je+1==j) ) then +!!$ qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j)) +!!$ endif +!!$ endif !not bounded_domain +!!$ +!!$ endif ! altInterp +!!$ +!!$ end subroutine atob_s +!!$! +!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!!$!------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! - subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, nested, domain) +! +! atod :: interpolate from the A-Grid to the D-grid +! + subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, bounded_domain, domain, bd) + + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npx, npy, ng - real , intent(IN) :: uin(isd:ied ,jsd:jed ) !< A-grid u-wind field - real , intent(IN) :: vin(isd:ied ,jsd:jed ) !< A-grid v-wind field - real , intent(OUT) :: uout(isd:ied ,jsd:jed+1) !< D-grid u-wind field - real , intent(OUT) :: vout(isd:ied+1,jsd:jed ) !< D-grid v-wind field - logical, intent(IN) :: nested - real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya - real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc - real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc + real , intent(IN) :: uin(bd%isd:bd%ied ,bd%jsd:bd%jed ) !< A-grid u-wind field + real , intent(IN) :: vin(bd%isd:bd%ied ,bd%jsd:bd%jed ) !< A-grid v-wind field + real , intent(OUT) :: uout(bd%isd:bd%ied ,bd%jsd:bd%jed+1) !< D-grid u-wind field + real , intent(OUT) :: vout(bd%isd:bd%ied+1,bd%jsd:bd%jed ) !< D-grid v-wind field + logical, intent(IN) :: bounded_domain + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya + real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dxc + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dyc type(domain2d), intent(INOUT) :: domain + integer :: i,j - real :: tmp1i(isd:ied+1) - real :: tmp2i(isd:ied) - real :: tmp3i(isd:ied) - real :: tmp1j(jsd:jed+1) - real :: tmp2j(jsd:jed) - real :: tmp3j(jsd:jed) + real :: tmp1i(bd%isd:bd%ied+1) + real :: tmp2i(bd%isd:bd%ied) + real :: tmp3i(bd%isd:bd%ied) + real :: tmp1j(bd%jsd:bd%jed+1) + real :: tmp2j(bd%jsd:bd%jed) + real :: tmp3j(bd%jsd:bd%jed) + + integer :: jsd, jed, isd, ied + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed do j=jsd+1,jed tmp1i(:) = 0.0 @@ -8501,8 +8793,8 @@ subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, nested, call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder) uout(i,:) = tmp1j(:)/dyc(i,:) enddo - call mp_update_dwinds(uout, vout, npx, npy, domain) - if (.not. nested) call fill_corners(uout, vout, npx, npy, VECTOR=.true., DGRID=.true.) + call mp_update_dwinds(uout, vout, npx, npy, domain, bd) + if (.not. bounded_domain) call fill_corners(uout, vout, npx, npy, VECTOR=.true., DGRID=.true.) end subroutine atod ! ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! @@ -8510,24 +8802,41 @@ end subroutine atod !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! - subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng) +! +! dtoa :: interpolate from the D-Grid to the A-grid +! + subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng, bd) + + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npx, npy, ng - real , intent(IN) :: uin(isd:ied ,jsd:jed+1) !< D-grid u-wind field - real , intent(IN) :: vin(isd:ied+1,jsd:jed ) !< D-grid v-wind field - real , intent(OUT) :: uout(isd:ied ,jsd:jed ) !< A-grid u-wind field - real , intent(OUT) :: vout(isd:ied ,jsd:jed ) !< A-grid v-wind field - real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx, dyc - real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy, dxc - real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya + real , intent(IN) :: uin(bd%isd:bd%ied ,bd%jsd:bd%jed+1) !< D-grid u-wind field + real , intent(IN) :: vin(bd%isd:bd%ied+1,bd%jsd:bd%jed ) !< D-grid v-wind field + real , intent(OUT) :: uout(bd%isd:bd%ied ,bd%jsd:bd%jed ) !< A-grid u-wind field + real , intent(OUT) :: vout(bd%isd:bd%ied ,bd%jsd:bd%jed ) !< A-grid v-wind field + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dx, dyc + real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dy, dxc + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya integer :: i,j,n - real :: tmp1i(isd:ied+1) - real :: tmp2i(isd:ied+1) - real :: tmp3i(isd:ied+1) - real :: tmp1j(jsd:jed+1) - real :: tmp2j(jsd:jed+1) - real :: tmp3j(jsd:jed+1) + real :: tmp1i(bd%isd:bd%ied+1) + real :: tmp2i(bd%isd:bd%ied+1) + real :: tmp3i(bd%isd:bd%ied+1) + real :: tmp1j(bd%jsd:bd%jed+1) + real :: tmp2j(bd%jsd:bd%jed+1) + real :: tmp3j(bd%jsd:bd%jed+1) + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed !CLEANUP: replace dxa with rdxa, and dya with rdya; may change numbers. #ifdef VORT_ON @@ -8562,28 +8871,46 @@ end subroutine dtoa !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! - subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, domain, noComm) +! +! atoc :: interpolate from the A-Grid to the C-grid +! + subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, bounded_domain, domain, bd, noComm) + + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npx, npy, ng - real , intent(IN) :: uin(isd:ied ,jsd:jed ) !< A-grid u-wind field - real , intent(IN) :: vin(isd:ied ,jsd:jed ) !< A-grid v-wind field - real , intent(OUT) :: uout(isd:ied+1,jsd:jed ) !< C-grid u-wind field - real , intent(OUT) :: vout(isd:ied ,jsd:jed+1) !< C-grid v-wind field - logical, intent(IN) :: nested + real , intent(IN) :: uin(bd%isd:bd%ied ,bd%jsd:bd%jed ) ! A-grid u-wind field + real , intent(IN) :: vin(bd%isd:bd%ied ,bd%jsd:bd%jed ) ! A-grid v-wind field + real , intent(OUT) :: uout(bd%isd:bd%ied+1,bd%jsd:bd%jed ) ! C-grid u-wind field + real , intent(OUT) :: vout(bd%isd:bd%ied ,bd%jsd:bd%jed+1) ! C-grid v-wind field + logical, intent(IN) :: bounded_domain logical, OPTIONAL, intent(IN) :: noComm - real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx - real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy - real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dx + real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dy + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya type(domain2d), intent(INOUT) :: domain real :: ang1 integer :: i,j,n - real :: tmp1i(isd:ied+1) - real :: tmp2i(isd:ied) - real :: tmp3i(isd:ied) - real :: tmp1j(jsd:jed+1) - real :: tmp2j(jsd:jed) - real :: tmp3j(jsd:jed) + real :: tmp1i(bd%isd:bd%ied+1) + real :: tmp2i(bd%isd:bd%ied) + real :: tmp3i(bd%isd:bd%ied) + real :: tmp1j(bd%jsd:bd%jed+1) + real :: tmp2j(bd%jsd:bd%jed) + real :: tmp3j(bd%jsd:bd%jed) + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed + #if !defined(ALT_INTERP) #ifdef VORT_ON @@ -8629,7 +8956,7 @@ subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, do vout(i,:) = tmp1j(:)/dx(i,:) enddo - if (cubed_sphere .and. .not. nested) then + if (cubed_sphere .and. .not. bounded_domain) then csFac = COS(30.0*PI/180.0) ! apply Corner scale factor for interp on Cubed-Sphere if ( (is==1) .and. (js==1) ) then @@ -8673,7 +9000,7 @@ subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, do else call mpp_update_domains( uout,vout, domain, gridtype=CGRID_NE_PARAM, complete=.true.) endif - if (.not. nested) call fill_corners(uout, vout, npx, npy, VECTOR=.true., CGRID=.true.) + if (.not. bounded_domain) call fill_corners(uout, vout, npx, npy, VECTOR=.true., CGRID=.true.) end subroutine atoc ! @@ -8682,24 +9009,42 @@ end subroutine atoc !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! - subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng) +! +! ctoa :: interpolate from the C-Grid to the A-grid +! + subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng, bd) + + + type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: npx, npy, ng - real , intent(IN) :: uin(isd:ied+1,jsd:jed ) !< C-grid u-wind field - real , intent(IN) :: vin(isd:ied ,jsd:jed+1) !< C-grid v-wind field - real , intent(OUT) :: uout(isd:ied ,jsd:jed ) !< A-grid u-wind field - real , intent(OUT) :: vout(isd:ied ,jsd:jed ) !< A-grid v-wind field - real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc, dy - real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc, dx - real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya + real , intent(IN) :: uin(bd%isd:bd%ied+1,bd%jsd:bd%jed ) !< C-grid u-wind field + real , intent(IN) :: vin(bd%isd:bd%ied ,bd%jsd:bd%jed+1) !< C-grid v-wind field + real , intent(OUT) :: uout(bd%isd:bd%ied ,bd%jsd:bd%jed ) !< A-grid u-wind field + real , intent(OUT) :: vout(bd%isd:bd%ied ,bd%jsd:bd%jed ) !< A-grid v-wind field + real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dxc, dy + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dyc, dx + real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya integer :: i,j - real :: tmp1i(isd:ied+1) - real :: tmp2i(isd:ied+1) - real :: tmp3i(isd:ied+1) - real :: tmp1j(jsd:jed+1) - real :: tmp2j(jsd:jed+1) - real :: tmp3j(jsd:jed+1) + real :: tmp1i(bd%isd:bd%ied+1) + real :: tmp2i(bd%isd:bd%ied+1) + real :: tmp3i(bd%isd:bd%ied+1) + real :: tmp1j(bd%jsd:bd%jed+1) + real :: tmp2j(bd%jsd:bd%jed+1) + real :: tmp3j(bd%jsd:bd%jed+1) + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = bd%is + ie = bd%ie + js = bd%js + je = bd%je + isd = bd%isd + ied = bd%ied + jsd = bd%jsd + jed = bd%jed ! do j=jsd,jed ! do i=isd,ied @@ -8733,7 +9078,12 @@ end subroutine ctoa !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +! +! rotate_winds :: rotate winds from the sphere-to-cube || cube-to-sphere +! subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir) + + integer, intent(IN) :: ndims real , intent(INOUT) :: myU !< u-wind field real , intent(INOUT) :: myV !< v-wind field @@ -8776,15 +9126,16 @@ subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir) end subroutine rotate_winds - subroutine mp_update_dwinds_2d(u, v, npx, npy, domain) + subroutine mp_update_dwinds_2d(u, v, npx, npy, domain, bd) use mpp_parameter_mod, only: DGRID_NE - real , intent(INOUT) :: u(isd:ied ,jsd:jed+1) !< D-grid u-wind field - real , intent(INOUT) :: v(isd:ied+1,jsd:jed ) !< D-grid v-wind field + type(fv_grid_bounds_type), intent(IN) :: bd + real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1) !< D-grid u-wind field + real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ) !< D-grid v-wind field integer, intent(IN) :: npx, npy type(domain2d), intent(INOUT) :: domain call mpp_update_domains( u, v, domain, gridtype=DGRID_NE, complete=.true.) -! if (.not. nested) call fill_corners(u , v , npx, npy, VECTOR=.true., DGRID=.true.) +! if (.not. bounded_domain) call fill_corners(u , v , npx, npy, VECTOR=.true., DGRID=.true.) end subroutine mp_update_dwinds_2d ! @@ -8794,24 +9145,29 @@ end subroutine mp_update_dwinds_2d !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! ! - subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain) + subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain, bd) use mpp_parameter_mod, only: DGRID_NE - real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) !< D-grid u-wind field - real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) !< D-grid v-wind field + type(fv_grid_bounds_type), intent(IN) :: bd + real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) !< D-grid u-wind field + real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) !< D-grid v-wind field integer, intent(IN) :: npx, npy, npz type(domain2d), intent(INOUT) :: domain integer k call mpp_update_domains( u, v, domain, gridtype=DGRID_NE, complete=.true.) ! do k=1,npz -! if (.not. nested) call fill_corners(u(isd:,jsd:,k) , v(isd:,jsd:,k) , npx, npy, VECTOR=.true., DGRID=.true.) +! if (.not. bounded_domain) call fill_corners(u(isd:,jsd:,k) , v(isd:,jsd:,k) , npx, npy, VECTOR=.true., DGRID=.true.) ! enddo end subroutine mp_update_dwinds_3d !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +! +! gsum :: get global sum +! real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile) result (gsum) + integer, intent(IN) :: npx, npy integer, intent(IN) :: ifirst, ilast integer, intent(IN) :: jfirst, jlast @@ -9008,6 +9364,12 @@ end subroutine mp_ghost_ew !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +! +! interp_left_edge_1d :: interpolate to left edge of a cell either +! order = 1 -> Linear average +! order = 2 -> Uniform PPM +! order = 3 -> Non-Uniform PPM +! subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order) integer, intent(in):: ifirst,ilast real, intent(out) :: qout(ifirst:) @@ -9115,8 +9477,11 @@ subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order) end subroutine interp_left_edge_1d !------------------------------------------------------------------------------ !----------------------------------------------------------------------- +!BOP +! subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, & ng_d, ng_s, jfirst, jlast) + ! !INPUT PARAMETERS: integer im !< Total longitudes integer jm !< Total latitudes @@ -9130,6 +9495,18 @@ subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, & ! !INPUT/OUTPUT PARAMETERS: real, intent(inout):: v(im,jfirst-ng_d:jlast+ng_d) +! !DESCRIPTION: +! +! Treat the V winds at the poles. This requires an average +! of the U- and V-winds, weighted by their angles of incidence +! at the pole points. +! +! !REVISION HISTORY: +! +!EOP +!----------------------------------------------------------------------- +!BOC +! ! !LOCAL VARIABLES: integer i, imh