diff --git a/driver/fvGFS/atmosphere.F90 b/driver/fvGFS/atmosphere.F90 index 0fc5ba08e..6cbd71756 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 ! ! @@ -509,7 +509,7 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) ! --- initiate the start for a restarted regional forecast if ( Atm(mytile)%gridstruct%regional .and. Atm(mytile)%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 @@ -1269,7 +1269,7 @@ subroutine atmosphere_get_bottom_layer (Atm_block, DYCORE_Data) rrg = rdgas / grav if (first_time) then - print *, 'calculating slp kr value' + if (mpp_pe() == mpp_root_pe()) print *, 'calculating slp kr value' ! determine 0.8 sigma reference level sigtop = Atm(mytile)%ak(1)/pstd_mks+Atm(mytile)%bk(1) do k = 1, npz @@ -1630,6 +1630,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) first_diag = .false. call timing_off('FV_DIAG') diff --git a/model/fv_arrays.F90 b/model/fv_arrays.F90 index 1e7c6a686..d6a818857 100644 --- a/model/fv_arrays.F90 +++ b/model/fv_arrays.F90 @@ -985,6 +985,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 +1007,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 diff --git a/model/fv_control.F90 b/model/fv_control.F90 index 6a36bd835..25eef2317 100644 --- a/model/fv_control.F90 +++ b/model/fv_control.F90 @@ -331,6 +331,9 @@ module fv_control_mod 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 @@ -670,7 +673,8 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) 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 + do_uni_zfull, adj_mass_vmr, fac_n_spl, fhouri, regional, bc_update_interval, & + regional_bcs_from_gsi, write_restart_with_bcs, nrows_blend namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size #ifdef MULTI_GASES @@ -892,6 +896,12 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) Atm(n)%neststruct%refinement = -1 end if + if (Atm(n)%flagstruct%regional) then + if ( 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 + 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) @@ -1233,6 +1243,9 @@ subroutine setup_pointers(Atm) 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 diff --git a/model/fv_regional_bc.F90 b/model/fv_regional_bc.F90 index 67d207c59..9bd8e2b8a 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 @@ -78,11 +78,12 @@ module fv_regional_mod ,start_regional_restart & ,dump_field & ,current_time_in_seconds & - ,a_step, p_step, k_step, n_step, get_data_source + ,a_step, p_step, k_step, n_step, get_data_source & + ,write_full_fields integer,parameter :: nhalo_data =4 & ,nhalo_model=3 - +! integer, public, parameter :: H_STAGGER = 1 integer, public, parameter :: U_STAGGER = 2 integer, public, parameter :: V_STAGGER = 3 @@ -105,11 +106,37 @@ module fv_regional_mod ! integer, parameter :: iend_nest = 1346 ! integer, parameter :: jend_nest = 1290 + integer,parameter :: nvars_core=7 & !<-- # of prognostic variables in restart file + ,nvars_tracers=8 !<-- # of prognostic variables in restart file + + 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 :: 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 +147,11 @@ module fv_regional_mod logical,save :: north_bc,south_bc,east_bc,west_bc & ,begin_regional_restart=.true. + 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 +170,16 @@ module fv_regional_mod type(fv_regional_BC_variables) :: north, south, east, west end type fv_domain_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 +195,9 @@ module fv_regional_mod type(fv_regional_bc_bounds_type),pointer,save :: regional_bounds + type(vars_3d),dimension(:),allocatable :: fields_core & + ,fields_tracers + 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 +223,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 +232,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 +249,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 +258,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 +313,7 @@ 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 !----------------------------------------------------------------------- !*** Which side(s) of the domain does this task lie on if any? !----------------------------------------------------------------------- @@ -282,18 +336,62 @@ 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 @@ -305,8 +403,28 @@ subroutine setup_regional_BC(Atm & ! 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') + 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') +! +!----------------------------------------------------------------------- +! + 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 + 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 @@ -704,6 +822,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 +834,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 +846,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 +858,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 +877,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 +900,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 +918,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 +936,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 +968,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 +1028,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 @@ -1011,14 +1126,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 +1178,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 +1198,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 +1211,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 ) ! @@ -1113,6 +1232,16 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & ,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 +1256,16 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & enddo ! !----------------------------------------------------------------------- +!*** If the GSI will need a restart file that includes the +!*** fields' boundary rows then create that file and define +!*** its dimensions and variables. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%write_restart_with_bcs)then + call create_restart_with_bcs(Atm) + endif +! +!----------------------------------------------------------------------- ! end subroutine start_regional_cold_start ! @@ -1134,7 +1273,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 +1288,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 @@ -1192,28 +1333,50 @@ subroutine start_regional_restart(Atm & !*** 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 a restart file that includes the +!*** fields' boundary rows after this forecast or forecast +!*** segment completes then create that file and define +!*** its dimensions and variables. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%write_restart_with_bcs)then + call create_restart_with_bcs(Atm) + endif ! !----------------------------------------------------------------------- ! @@ -1354,11 +1517,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 @@ -1383,11 +1549,8 @@ subroutine regional_bc_data(Atm,bc_hour & character(len=6) :: fmt='(i3.3)' ! character(len=50) :: file_name -! - integer,save :: kount1=0,kount2=0 ! character(len=60) :: var_name_root - integer :: nside,nt,index logical :: required ! logical :: call_remap @@ -1403,7 +1566,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') ! !----------------------------------------------------------------------- ! @@ -1411,21 +1573,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). @@ -1442,11 +1614,17 @@ subroutine regional_bc_data(Atm,bc_hour & 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 ! @@ -1485,14 +1663,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 @@ -1560,9 +1739,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 ! @@ -1591,19 +1792,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 @@ -1613,7 +1818,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 @@ -1626,76 +1831,76 @@ subroutine regional_bc_data(Atm,bc_hour & !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- - sides_scalars: do nside=1,4 + sides_scalars: do nside=1,4 !----------------------------------------------------------------------- ! - 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 + if(nside==1)then + if(north_bc)then + call_remap=.true. + side='north' + bc_side_t1=>BC_t1%north + endif endif - endif ! - if(nside==2)then - if(south_bc)then - call_remap=.true. - side='south' - bc_side_t1=>BC_t1%south + if(nside==2)then + if(south_bc)then + call_remap=.true. + side='south' + bc_side_t1=>BC_t1%south + endif 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 + endif endif - endif ! - if(nside==4)then - if(west_bc)then - call_remap=.true. - side='west ' - bc_side_t1=>BC_t1%west + if(nside==4)then + if(west_bc)then + call_remap=.true. + side='west ' + bc_side_t1=>BC_t1%west + endif endif - endif ! - if(call_remap)then - call remap_scalar_nggps_regional_bc(Atm & - ,side & + if(call_remap)then + call remap_scalar_nggps_regional_bc(Atm & + ,side & - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo + ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- + ,is_input & !<-- + ,ie_input & ! Input array + ,js_input & ! index limits. + ,je_input & !<-- - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & + ,klev_in, klev_out & + ,ntracers & + ,ak, bk & - ,ps_input & !<-- - ,t_input & ! BC vbls - ,tracers_input & ! on input - ,w_input & ! model levels - ,zh_input & !<-- + ,ps_input & !<-- + ,t_input & ! BC vbls + ,tracers_input & ! on input + ,w_input & ! model levels + ,zh_input & !<-- - ,phis_reg & !<-- Filtered topography + ,phis_reg & !<-- Filtered topography - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region + ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - ,bc_side_t1 ) !<-- BC vbls on final integration levels + ,bc_side_t1 ) !<-- BC vbls on final integration levels ! - call set_delp_and_tracers(bc_side_t1,Atm%npz,Atm%flagstruct%nwat) + call set_delp_and_tracers(bc_side_t1,Atm%npz,Atm%flagstruct%nwat) ! - endif + endif ! !----------------------------------------------------------------------- - enddo sides_scalars + enddo sides_scalars !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- @@ -1705,43 +1910,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 ! !----------------------------------------------------------------------- @@ -1749,156 +1954,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 ! - 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 + if(call_remap)then ! - 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 + 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 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 +! + 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 - enddo ! - call remap_dwinds_regional_bc(Atm & + 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 & !<-- + ,is_input & !<-- + ,ie_input & ! Index limits for scalars + ,js_input & ! at center of north BC region grid cells. + ,je_input & !<-- - ,is_u & !<-- - ,ie_u & ! Index limits for u component - ,js_u & ! on north edge of BC region grid cells. - ,je_u & !<-- + ,is_u & !<-- + ,ie_u & ! Index limits for u component + ,js_u & ! on north edge of BC region grid cells. + ,je_u & !<-- - ,is_v & !<-- - ,ie_v & ! Index limits for v component - ,js_v & ! on north edge of BC region grid cells. - ,je_v & !<-- + ,is_v & !<-- + ,ie_v & ! Index limits for v component + ,js_v & ! on north edge of BC region grid cells. + ,je_v & !<-- - ,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 + ,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. @@ -1932,6 +2137,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. @@ -1981,17 +2192,295 @@ subroutine regional_bc_data(Atm,bc_hour & !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- ! - subroutine fill_divgd_BC + subroutine fill_BC_for_DA ! !----------------------------------------------------------------------- -!*** For now fill the boundary divergence with zero. -!----------------------------------------------------------------------- - implicit none +!*** 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 +! +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + subroutine fill_divgd_BC +! +!----------------------------------------------------------------------- +!*** For now fill the boundary divergence with zero. +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +! +!-------------------- +!*** Local variables +!-------------------- ! integer :: i,ie0,is0,j,je0,js0,k,nside ! @@ -2421,15 +2910,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 ! @@ -2445,13 +2935,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 ! @@ -2471,9 +2962,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 @@ -2495,6 +2986,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 ! @@ -2511,7 +3003,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 @@ -2534,19 +3026,23 @@ 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 @@ -2560,6 +3056,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 @@ -2570,6 +3067,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 ! @@ -2587,11 +3085,9 @@ subroutine check(status) integer,intent(in) :: 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 ! !----------------------------------------------------------------------- @@ -2697,7 +3193,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 @@ -2755,22 +3250,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 @@ -2834,7 +3329,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. !--------------------------------------------------------------------------------- @@ -2896,7 +3392,6 @@ 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 enddo @@ -2977,7 +3472,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 !----------------------------------------------------------------------- ! @@ -3083,22 +3578,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' !--------------------------------------------------------------------- @@ -3240,10 +3735,11 @@ subroutine set_regional_BCs(delp,delz,w,pt & ,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 !--------------------------------------------------------------------- @@ -3441,11 +3937,22 @@ 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 #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 ! @@ -3475,24 +3982,6 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & 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 ! do nt=1,ntracers do k=1,nz @@ -3563,6 +4052,8 @@ 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 @@ -3613,6 +4104,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 ! @@ -3638,6 +4140,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 ! @@ -3666,6 +4182,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 ! @@ -3698,6 +4231,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 ! @@ -3720,16 +4270,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 ) endif ! !--------------------------------------------------------------------- +! enddo sides -!--------------------------------------------------------------------- ! !--------------------------------------------------------------------- - +! end subroutine regional_boundary_update !--------------------------------------------------------------------- @@ -3801,8 +4354,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) @@ -3840,16 +4392,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 ) !--------------------------------------------------------------------- !*** Update the boundary region of the input array at the given @@ -3867,14 +4422,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 :: rdenom ! real,dimension(lbnd1:ubnd1,lbnd2:ubnd2,1:ubnd_z) :: bc_t0 & !<-- Interpolate between these ,bc_t1 ! two boundary region states. +! + character(len=*),intent(in) :: bc_vbl_name ! !--------------------- !*** Output variables @@ -3889,7 +4453,7 @@ subroutine bc_time_interpolation(array & ! integer :: i,j,k ! - real :: fraction_interval + real :: blend_value,factor_dist,fraction_interval ! !--------------------------------------------------------------------- !********************************************************************* @@ -3915,144 +4479,94 @@ subroutine bc_time_interpolation(array & enddo ! !--------------------------------------------------------------------- - - end subroutine bc_time_interpolation -!--------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!*** 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. !--------------------------------------------------------------------- ! - 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 ) +!----------- +!*** North +!----------- ! -!--------------------------------------------------------------------- -!*** Execute the linear time interpolation between t0 and t1 -!*** generically for any side of the regional domain's boundary -!*** region. -!--------------------------------------------------------------------- - implicit none -!--------------------------------------------------------------------- + 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. ! -!------------------------ -!*** Argument variables -!------------------------ + array(i,j,k)=(1.-factor_dist)*array(i,j,k)+factor_dist*blend_value + enddo + enddo + enddo + endif ! - 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 +!----------- +!*** South +!----------- ! - real,intent(in) :: fraction !<-- Current time is this fraction between t0 ad t1. + 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 ! - type(fv_regional_BC_variables),intent(in) :: t0,t1 !<-- BC variables at time levels t0 and t1. +!---------- +!*** East +!---------- ! - type(fv_atmos_type),intent(inout) :: Atm !<-- The Atm object + 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 ! -!--------------------- -!*** Local variables -!--------------------- + 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. ! - integer :: i,j,k,n,nlayers!,ntracers + factor_dist=exp(-(blend_exp1+blend_exp2*(i-i_bc-1)*rdenom)) !<-- Exponential falloff of blending weights. ! -!--------------------------------------------------------------------- -!********************************************************************* -!--------------------------------------------------------------------- + array(i,j,k)=(1.-factor_dist)*array(i,j,k)+factor_dist*blend_value + enddo + enddo + enddo + endif ! - nlayers =Atm%npz !<-- # of layers in vertical configuration of integration -! ntracers=Atm%ncnst !<-- # of advected tracers +!---------- +!*** 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 ! - k_loop: do k=1,nlayers + 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. ! -!------------- -!*** 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 -! - 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 -! - 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 -! - enddo - enddo -! - do n=1,ntracers -! - 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 -! -!----------- -!*** 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 -! -! - 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 + endif ! !--------------------------------------------------------------------- ! - enddo k_loop -! -!--------------------------------------------------------------------- -! - end subroutine bc_time_interpolation_general + end subroutine bc_time_interpolation ! !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -4781,6 +5295,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) @@ -4855,7 +5377,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)/) ) @@ -4907,7 +5429,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 ) @@ -4953,7 +5475,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)/) ) @@ -4980,6 +5502,755 @@ subroutine dump_field_2d (domain, name, field, isd, ied, jsd, jed, stag) end subroutine dump_field_2d +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + subroutine create_restart_with_bcs(Atm) +! +!----------------------------------------------------------------------- +!*** Create the netcdf files into which full fields of the +!*** restart variables will be written INCLUDING BOUNDARY ROWS +!*** so the GSI can update both the interior and BCs. +!----------------------------------------------------------------------- +! + integer,parameter :: ndims_core=6 & !<-- # of core restart dimensions + ,ndims_tracers=4 !<-- # of tracer restart dimensions +! + type(fv_atmos_type),target,intent(inout) :: Atm !<-- Atm object for the current domain +! + integer :: dimid,n,na,natts & + ,ncid_core,ncid_core_new & + ,ncid_tracers,ncid_tracers_new & + ,nctype,ndims,ngatts,nn,nv_core,nv_tracers,var_id +! + 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 rstart file. +!----------------------------------------------------------------------- +! + 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' +! + fields_core(4)%ptr=>Atm%delz + 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' +! +!----------------------------------------------------------------------- +!*** Also point at the proper tracer arrays and set their names. +!----------------------------------------------------------------------- +! + allocate(fields_tracers(1:nvars_tracers)) +! + lbnd_x_tracers=lbound(Atm%q,1) + ubnd_x_tracers=ubound(Atm%q,1) + lbnd_y_tracers=lbound(Atm%q,2) + ubnd_y_tracers=ubound(Atm%q,2) +! + fields_tracers(1)%ptr=>Atm%q(:,:,:,sphum_index) + fields_tracers(1)%name='sphum' +! + fields_tracers(2)%ptr=>Atm%q(:,:,:,liq_water_index) + fields_tracers(2)%name='liq_wat' +! + fields_tracers(3)%ptr=>Atm%q(:,:,:,ice_water_index) + fields_tracers(3)%name='ice_wat' +! + fields_tracers(4)%ptr=>Atm%q(:,:,:,rain_water_index) + fields_tracers(4)%name='rainwat' +! + fields_tracers(5)%ptr=>Atm%q(:,:,:,snow_water_index) + fields_tracers(5)%name='snowwat' +! + fields_tracers(6)%ptr=>Atm%q(:,:,:,graupel_index) + fields_tracers(6)%name='graupel' +! + fields_tracers(7)%ptr=>Atm%q(:,:,:,o3mr_index) + fields_tracers(7)%name='o3mr' +! + fields_tracers(8)%ptr=>Atm%q(:,:,:,cld_amt_index) + fields_tracers(8)%name='cld_amt' +! +!----------------------------------------------------------------------- +!*** Only one compute task prepares the new restart files. The task +!*** with the highest rank knows the upper bounds of the domain so +!*** it does the work. All other tasks may exit. +!----------------------------------------------------------------------- +! + if(mpp_pe()/=Atm%layout(1)*Atm%layout(2)-1)then + return + endif +! + call check(nf90_create(filename_core_new & + ,cmode=or(nf90_clobber,nf90_64bit_offset) & + ,ncid=ncid_core_new)) +! +!----------------------------------------------------------------------- +!*** Define the output file's dimensions and insert them into the file. +!----------------------------------------------------------------------- +! + dim_lengths_core(1)=Atm%bd%ied+nhalo_model !<-- x + dim_lengths_core(2)=dim_lengths_core(1)+1 !<-- x+1 + dim_lengths_core(3)=Atm%bd%jed+nhalo_model+1 !<-- y+1 + dim_lengths_core(4)=dim_lengths_core(3)-1 !<-- y + dim_lengths_core(5)=Atm%npz !<-- z + dim_lengths_core(6)=nf90_unlimited !<-- time +! + do n=1,ndims_core + call check(nf90_def_dim(ncid_core_new & + ,dim_names_core(n) & + ,dim_lengths_core(n) & + ,dimid)) + enddo +! +!----------------------------------------------------------------------- +!*** The new file's variables must be defined while that file +!*** is still in define mode. Define each of the restart file's +!*** variables in the new file. +!----------------------------------------------------------------------- +! + call check(nf90_open(filename_core,nf90_nowrite,ncid_core)) !<-- The core restart file's ID +! + call check(nf90_inquire(ncid_core,nvariables=nv_core)) !<-- The TOTAL number of core restart file variables +! + do n=1,nv_core + var_id=n + call check(nf90_inquire_variable(ncid_core,var_id,var_name,nctype & !<-- Name and type of this variable + ,ndims,dimids,natts)) !<-- # of dimensions and attributes in this variable +! + call check(nf90_def_var(ncid_core_new,var_name,nctype,dimids(1:ndims),var_id)) !<-- Define the variable in the new file. +! +!----------------------------------------------------------------------- +!*** Copy this variable's attributes to the new core file's +!*** variable. +!----------------------------------------------------------------------- +! + if(natts>0)then + do na=1,natts + call check(nf90_inq_attname(ncid_core,var_id,na,att_name)) !<-- Get the attribute's name and ID from restart. + call check(nf90_copy_att(ncid_core,var_id,att_name,ncid_core_new,var_id)) !<-- Copy to the new file. + enddo + endif +! + enddo +! +!----------------------------------------------------------------------- +!*** Find the number of global attributes in the restart file and +!*** copy them to the new file. +!----------------------------------------------------------------------- +! + call check(nf90_inquire(ncid_core,nattributes=ngatts)) +! + do n=1,ngatts + call check(nf90_inq_attname(ncid_core,nf90_global,n,att_name)) + call check(nf90_copy_att(ncid_core,nf90_global,att_name,ncid_core_new,nf90_global)) + enddo +! +!----------------------------------------------------------------------- +! + call check(nf90_enddef(ncid_core_new)) !<-- Put the output file into data mode. +! +!----------------------------------------------------------------------- +!*** Insert the dimension values. +!----------------------------------------------------------------------- +! + do n=1,ndims_core-1 + allocate(dim_values(1:dim_lengths_core(n))) + do nn=1,dim_lengths_core(n) + dim_values(nn)=nn + enddo + var_id=n + call check(nf90_put_var(ncid_core_new,var_id & + ,dim_values(:) & + ,start=(/1/) & + ,count=(/dim_lengths_core(n)/))) + deallocate(dim_values) + enddo +! + write( 0,*)' nf90_unlimited=',nf90_unlimited + var_id=ndims_core !<-- Time is the final dimension; treat it separately. + allocate(dim_values(1)) + dim_values(1)=1 + call check(nf90_put_var(ncid_core_new,var_id & + ,dim_values(:))) + deallocate(dim_values) +! +!----------------------------------------------------------------------- +! + call check(nf90_close(ncid_core_new)) + call check(nf90_close(ncid_core)) +! +!----------------------------------------------------------------------- +!*** The second file to be handled is the tracer restart file. +!----------------------------------------------------------------------- +! + call check(nf90_create(filename_tracers_new & + ,cmode=or(nf90_clobber,nf90_64bit_offset) & + ,ncid=ncid_tracers_new)) +! +!----------------------------------------------------------------------- +!*** Define the output file's dimensions and insert them into the file. +!----------------------------------------------------------------------- +! + dim_lengths_tracers(1)=Atm%bd%ied+nhalo_model !<-- x + dim_lengths_tracers(2)=Atm%bd%jed+nhalo_model !<-- y + dim_lengths_tracers(3)=Atm%npz !<-- z + dim_lengths_tracers(4)=nf90_unlimited !<-- time +! + do n=1,ndims_tracers + call check(nf90_def_dim(ncid_tracers_new & + ,dim_names_tracers(n) & + ,dim_lengths_tracers(n) & + ,dimid)) + enddo +! +!----------------------------------------------------------------------- +!*** The new file's variables must be defined while that file +!*** is still in define mode. Define each of the restart file's +!*** variables in the new file. +!----------------------------------------------------------------------- +! + call check(nf90_open(filename_tracers,nf90_nowrite,ncid_tracers)) !<-- The tracer restart file's ID +! + call check(nf90_inquire(ncid_tracers,nvariables=nv_tracers)) !<-- The TOTAL number of tracer restart file variables +! + do n=1,nv_tracers + var_id=n + call check(nf90_inquire_variable(ncid_tracers,var_id,var_name,nctype & !<-- Name and type of this variable + ,ndims,dimids,natts)) !<-- # of dimensions and attributes in this variable +! + call check(nf90_def_var(ncid_tracers_new,var_name,nctype,dimids(1:ndims),var_id)) !<-- Define the variable in the new file. +! +!----------------------------------------------------------------------- +!*** Copy this variable's attributes to the new tracers file's +!*** variable. +!----------------------------------------------------------------------- +! + if(natts>0)then + do na=1,natts + call check(nf90_inq_attname(ncid_tracers,var_id,na,att_name)) !<-- Get the attribute's name and ID from restart. + call check(nf90_copy_att(ncid_tracers,var_id,att_name,ncid_tracers_new,var_id)) !<-- Copy to the new file. + enddo + endif +! + enddo +! +!----------------------------------------------------------------------- +!*** Find the number of global attributes in the restart file and +!*** copy them to the new file. +!----------------------------------------------------------------------- +! + call check(nf90_inquire(ncid_tracers,nattributes=ngatts)) +! + do n=1,ngatts + call check(nf90_inq_attname(ncid_tracers,nf90_global,n,att_name)) + call check(nf90_copy_att(ncid_tracers,nf90_global,att_name,ncid_tracers_new,nf90_global)) + enddo +! +!----------------------------------------------------------------------- +! + call check(nf90_enddef(ncid_tracers_new)) !<-- Put the output file into data mode. +! +!----------------------------------------------------------------------- +!*** Insert the dimension values. +!----------------------------------------------------------------------- +! + do n=1,ndims_tracers-1 + allocate(dim_values(1:dim_lengths_tracers(n))) + do nn=1,dim_lengths_tracers(n) + dim_values(nn)=nn + enddo + var_id=n + call check(nf90_put_var(ncid_tracers_new,var_id & + ,dim_values(:) & + ,start=(/1/) & + ,count=(/dim_lengths_tracers(n)/))) + deallocate(dim_values) + enddo +! + var_id=ndims_tracers !<-- Time is the final dimension; treat it separately. + allocate(dim_values(1)) + dim_values(1)=1 + call check(nf90_put_var(ncid_tracers_new,var_id & + ,dim_values(:))) + deallocate(dim_values) +! +!----------------------------------------------------------------------- +! + call check(nf90_close(ncid_tracers_new)) + call check(nf90_close(ncid_tracers)) +! +!----------------------------------------------------------------------- +! + end subroutine create_restart_with_bcs +! +!----------------------------------------------------------------------- +!-------------------------------------------------------------------------------------- +! + 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(1)%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(1)%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,nvars_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 +! +!----------------------------------------------------------------------- +!*** Since we are gathering onto a single task then do so one layer +!*** at a time to avoid potential memory problems for large high +!*** resolution domains. Then that task writes the full data to the +!*** new 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 sensible_temp(istart,iend,jstart,jend,nz & + ,Atm & + ,temp) +! +!--------------------------------------------------------------------- +!*** Convert the special potential temperature in the domain +!*** halo rows to sensible temperature. +!--------------------------------------------------------------------- +! +!------------------------ +!*** Argument variables +!------------------------ +! + integer,intent(in) :: istart,iend,jstart,jend +! + type(fv_atmos_type),intent(inout) :: Atm +! + real,dimension(istart:iend,jstart:jend,1:nz),intent(inout) :: temp +! +!--------------------- +!*** Local variables +!--------------------- +! + integer :: i1,i2,j1,j2,nz +! + real :: rdg +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! + 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 + call compute_halo_t + endif +! + if(south_bc)then + i1=istart + i2=iend + j1=jend-nhalo_model+1 + j2=jend + call compute_halo_t + 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 + call compute_halo_t + 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 + call compute_halo_t + 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)) & + /Atm%delz(i,j,k) + temp(i,j,k)=exp((log(temp(i,j,k))-log(part1)+cappa*log(part2)) & + /(1.-cappa)) + enddo + enddo + enddo +! +!--------------------------------------------------------------------- + end subroutine compute_halo_t +!--------------------------------------------------------------------- +! + end subroutine sensible_temp +! !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- @@ -5164,6 +6435,10 @@ subroutine exch_uv(domain, bd, npz, u, v) end subroutine exch_uv +!--------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!--------------------------------------------------------------------- + subroutine get_data_source(source,regional) ! ! This routine extracts the data source information if it is present in the datafile. @@ -5185,6 +6460,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/tools/external_ic.F90 b/tools/external_ic.F90 index 66157aa5e..c0d416921 100644 --- a/tools/external_ic.F90 +++ b/tools/external_ic.F90 @@ -207,11 +207,12 @@ module external_ic_mod contains - subroutine get_external_ic( Atm, fv_domain, cold_start ) + 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 @@ -288,7 +289,7 @@ subroutine get_external_ic( Atm, fv_domain, cold_start ) #endif elseif ( Atm(1)%flagstruct%nggps_ic ) then call timing_on('NGGPS_IC') - call get_nggps_ic( Atm, fv_domain ) + call get_nggps_ic( Atm, fv_domain, dt_atmos ) call timing_off('NGGPS_IC') elseif ( Atm(1)%flagstruct%ecmwf_ic ) then if( is_master() ) write(*,*) 'Calling get_ecmwf_ic' @@ -442,7 +443,7 @@ 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) + subroutine get_nggps_ic (Atm, fv_domain, dt_atmos ) !>variables read in from 'gfs_ctrl.nc' !> VCOORD - level information @@ -471,6 +472,7 @@ subroutine get_nggps_ic (Atm, fv_domain) 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 @@ -840,14 +842,6 @@ subroutine get_nggps_ic (Atm, fv_domain) 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 @@ -861,7 +855,7 @@ subroutine get_nggps_ic (Atm, fv_domain) if (n==1.and.Atm(1)%flagstruct%regional) then !<-- Select the parent regional domain. - call start_regional_cold_start(Atm(1), ak, bk, levp, & + call start_regional_cold_start(Atm(1), dt_atmos, ak, bk, levp, & is, ie, js, je, & isd, ied, jsd, jed ) endif @@ -1581,13 +1575,13 @@ subroutine get_ecmwf_ic( Atm, fv_domain ) ! 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 +! 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 diff --git a/tools/external_ic.F90_65lyrs b/tools/external_ic.F90_65lyrs new file mode 100644 index 000000000..d525f8419 --- /dev/null +++ b/tools/external_ic.F90_65lyrs @@ -0,0 +1,4287 @@ + +!*********************************************************************** +!* 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, 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 + 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, dt_atmos ) + 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, 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 + 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), dt_atmos, 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 + diff --git a/tools/external_ic.F90_NAM_lyrs b/tools/external_ic.F90_NAM_lyrs new file mode 100644 index 000000000..c0d416921 --- /dev/null +++ b/tools/external_ic.F90_NAM_lyrs @@ -0,0 +1,4279 @@ + +!*********************************************************************** +!* 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, 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 + 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, dt_atmos ) + 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, 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 + 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) + 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), dt_atmos, 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 + diff --git a/tools/fv_eta.F90 b/tools/fv_eta.F90 index 3c49530f8..7697c385c 100644 --- a/tools/fv_eta.F90 +++ b/tools/fv_eta.F90 @@ -753,50 +753,36 @@ subroutine set_eta(km, ks, ptop, ak, bk) 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 / +! 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 @@ -1313,7 +1299,7 @@ subroutine set_eta(km, ks, ptop, ak, bk) enddo case (60) - ks = 37 + ks = 19 do k=1,km+1 ak(k) = a60(k) bk(k) = b60(k) diff --git a/tools/fv_eta.F90_65lyrs b/tools/fv_eta.F90_65lyrs new file mode 100644 index 000000000..3c49530f8 --- /dev/null +++ b/tools/fv_eta.F90_65lyrs @@ -0,0 +1,3093 @@ +!*********************************************************************** +!* 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_eta' contains routine to set up the reference +!! (Eulerian) pressure coordinate + +module fv_eta_mod + +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
Module NameFunctions Included
constants_modkappa, grav, cp_air, rdgas
fv_mp_modis_master
mpp_modmpp_error, FATAL
+ + use constants_mod, only: kappa, grav, cp_air, rdgas + use fv_mp_mod, only: is_master + use mpp_mod, only: FATAL, mpp_error + implicit none + private + public set_eta, set_external_eta, get_eta_level, compute_dz_var, & + compute_dz_L32, compute_dz_L101, set_hybrid_z, compute_dz, & + gw_1d, sm1_edge, hybrid_z_dz + + contains + +!!!NOTE: USE_VAR_ETA not used in fvGFS +#ifdef USE_VAR_ETA + subroutine set_eta(km, ks, ptop, ak, bk) +! 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 + real:: a60(61),b60(61) +! Thfollowing L63 setting is the same as NCEP GFS's L64 except the top +! 3 layers + data a60/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 b60/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.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./ + real, intent(out):: ak(km+1) + real, intent(out):: bk(km+1) + real, intent(out):: ptop ! model top (Pa) + real pint, stretch_fac + integer k + real :: s_rate = -1.0 ! dummy value to not use var_les + + pint = 100.E2 + +!- Notes --------------------------------- +! low-top: ptop = 100. ! ~45 km +! mid-top: ptop = 10. ! ~60 km +! hi -top: ptop = 1. ! ~80 km +!----------------------------------------- + select case (km) + +! Optimal number = 8 * N -1 (for 8 openMP threads) +! 16 * M -1 (for 16 openMP threads) + +#ifdef HIWPP +#ifdef SUPER_K + 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 +#else + case (30) ! For Baroclinic Instability Test + ptop = 2.26e2 + pint = 250.E2 + stretch_fac = 1.03 + case (40) + ptop = 50.e2 ! For super cell test + pint = 300.E2 + stretch_fac = 1.03 + case (50) ! Mountain waves? + ptop = 30.e2 + stretch_fac = 1.025 + case (60) ! For Baroclinic Instability Test +#ifdef GFSL60 + ks = 20 + ptop = a60(1) + pint = a60(ks+1) + do k=1,km+1 + ak(k) = a60(k) + bk(k) = b60(k) + enddo +#else + ptop = 3.e2 +! pint = 250.E2 + pint = 300.E2 ! revised for Moist test + stretch_fac = 1.03 +#endif +#endif + case (64) +!!! ptop = 3.e2 + ptop = 2.0e2 + pint = 300.E2 + stretch_fac = 1.03 +#else +! *Very-low top: for idealized super-cell simulation: + case (50) + ptop = 50.e2 + pint = 250.E2 + stretch_fac = 1.03 + case (60) + ptop = 40.e2 + pint = 250.E2 + stretch_fac = 1.03 + case (90) ! super-duper cell + ptop = 40.e2 + stretch_fac = 1.025 +#endif +! Low-top: + case (31) ! N = 4, M=2 + ptop = 100. + stretch_fac = 1.035 + case (32) ! N = 4, M=2 + ptop = 100. + stretch_fac = 1.035 + case (39) ! N = 5 + ptop = 100. + stretch_fac = 1.035 + case (41) + ptop = 100. + stretch_fac = 1.035 + case (47) ! N = 6, M=3 + ptop = 100. + stretch_fac = 1.035 + case (51) + ptop = 100. + stretch_fac = 1.03 + case (52) ! very low top + ptop = 30.e2 ! for special DPM RCE experiments + stretch_fac = 1.03 +! Mid-top: + case (55) ! N = 7 + ptop = 10. + stretch_fac = 1.035 +! Hi-top: + case (63) ! N = 8, M=4 + ptop = 1. + ! c360 or c384 + stretch_fac = 1.035 + case (71) ! N = 9 + ptop = 1. + stretch_fac = 1.03 + case (79) ! N = 10, M=5 + ptop = 1. + stretch_fac = 1.03 + case (127) ! N = 10, M=5 + ptop = 1. + stretch_fac = 1.03 + case (151) + ptop = 75.e2 + pint = 500.E2 + s_rate = 1.01 + case default + ptop = 1. + stretch_fac = 1.03 + end select + +#ifdef MOUNTAIN_WAVES + call mount_waves(km, ak, bk, ptop, ks, pint) +#else + if (s_rate > 0.) then + call var_les(km, ak, bk, ptop, ks, pint, s_rate) + else + if ( km > 79 ) then + call var_hi2(km, ak, bk, ptop, ks, pint, stretch_fac) + elseif (km==5 .or. km==10 ) then +! Equivalent Shallow Water: for NGGPS, variable-resolution testing + ptop = 500.e2 + ks = 0 + do k=1,km+1 + bk(k) = real(k-1) / real (km) + ak(k) = ptop*(1.-bk(k)) + enddo + else +#ifndef GFSL60 + call var_hi(km, ak, bk, ptop, ks, pint, stretch_fac) +#endif + endif +#endif + endif + + ptop = ak(1) + pint = ak(ks+1) + + 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) + +! 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 + +#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 + +! 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 + +!--------------------- +! 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 + + 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. / + + 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 / + + select case (km) + + case (24) + + ks = 5 + do k=1,km+1 + ak(k) = a24(k) + bk(k) = b24(k) + enddo + + case (26) + + ks = 7 + do k=1,km+1 + ak(k) = a26(k) + bk(k) = b26(k) + 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 (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 (48) + ks = 28 + do k=1,km+1 + ak(k) = a48(k) + bk(k) = b48(k) + enddo + + case (52) + ks = 35 ! pint = 223 + do k=1,km+1 + ak(k) = a52(k) + bk(k) = b52(k) + enddo + + case (54) + ks = 11 ! pint = 109.4 + do k=1,km+1 + ak(k) = a54(k) + bk(k) = b54(k) + enddo + + case (56) + ks = 26 + do k=1,km+1 + ak(k) = a56(k) + bk(k) = b56(k) + enddo + + case (60) + ks = 37 + do k=1,km+1 + ak(k) = a60(k) + bk(k) = b60(k) + enddo + + + 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 + ak(k) = a68(k) + bk(k) = b68(k) + enddo + + case (96) + ks = 27 + do k=1,km+1 + ak(k) = a96(k) + bk(k) = b96(k) + enddo +!<--cjg + + case (100) + ks = 38 + do k=1,km+1 + ak(k) = a100(k) + bk(k) = b100(k) + enddo + + 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 + ak(k) = a125(k) + bk(k) = b125(k) + enddo + case default + +#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 + +!---------------------------------------------------------------- +! 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) + + end subroutine set_eta +#endif + +!>@brief The subroutine 'set_external_eta' sets 'ptop' (model top) and +!! 'ks' (first level of pure pressure coordinates given the coefficients +!! 'ak' and 'bk' + subroutine set_external_eta(ak, bk, ptop, ks) + implicit none + real, intent(in) :: ak(:) + real, intent(in) :: bk(:) + real, intent(out) :: ptop !< model top (Pa) + integer, intent(out) :: ks !< number of pure p layers + !--- local variables + integer :: k + real :: eps = 1.d-7 + + ptop = ak(1) + ks = 1 + do k = 1, size(bk(:)) + if (bk(k).lt.eps) ks = k + enddo + !--- change ks to layers from levels + ks = ks - 1 + if (is_master()) write(6,*) ' ptop & ks ', ptop, ks + + end subroutine set_external_eta + + + subroutine var_les(km, ak, bk, ptop, ks, pint, s_rate) + implicit none + integer, intent(in):: km + real, intent(in):: ptop + real, intent(in):: s_rate !< between [1. 1.1] + real, intent(out):: ak(km+1), bk(km+1) + real, intent(inout):: pint + integer, intent(out):: ks +! Local + real, parameter:: p00 = 1.E5 + real, dimension(km+1):: ze, pe1, peln, eta + real, dimension(km):: dz, s_fac, dlnp, pm, dp, dk + real ztop, t0, dz0, sum1, tmp1 + real ep, es, alpha, beta, gama + real, parameter:: akap = 2./7. +!---- Tunable parameters: + real:: k_inc = 10 !< number of layers from bottom up to near const dz region + real:: s0 = 0.8 !< lowest layer stretch factor +!----------------------- + real:: s_inc + integer k + + pe1(1) = ptop + peln(1) = log(pe1(1)) + pe1(km+1) = p00 + peln(km+1) = log(pe1(km+1)) + + t0 = 273. + ztop = rdgas/grav*t0*(peln(km+1) - peln(1)) + + s_inc = (1.-s0) / real(k_inc) + s_fac(km) = s0 + + do k=km-1, km-k_inc, -1 + s_fac(k) = s_fac(k+1) + s_inc + enddo + + s_fac(km-k_inc-1) = 0.5*(s_fac(km-k_inc) + s_rate) + + do k=km-k_inc-2, 5, -1 + s_fac(k) = s_rate * s_fac(k+1) + enddo + + s_fac(4) = 0.5*(1.1+s_rate)*s_fac(5) + s_fac(3) = 1.1 *s_fac(4) + s_fac(2) = 1.1 *s_fac(3) + s_fac(1) = 1.1 *s_fac(2) + + sum1 = 0. + do k=1,km + sum1 = sum1 + s_fac(k) + enddo + + dz0 = ztop / sum1 + + do k=1,km + dz(k) = s_fac(k) * dz0 + enddo + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! Re-scale dz with the stretched ztop + do k=1,km + dz(k) = dz(k) * (ztop/ze(1)) + enddo + + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo +! ze(1) = ztop + + if ( is_master() ) then + write(*,*) 'var_les: computed model top (m)=', ztop, ' bottom/top dz=', dz(km), dz(1) +! do k=1,km +! write(*,*) k, s_fac(k) +! enddo + endif + + call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 2) + +! Given z --> p + do k=1,km + dz(k) = ze(k) - ze(k+1) + dlnp(k) = grav*dz(k) / (rdgas*t0) + !write(*,*) k, dz(k) + enddo + do k=2,km + peln(k) = peln(k-1) + dlnp(k-1) + pe1(k) = exp(peln(k)) + enddo + + +! 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) + endif + pint = pe1(ks+1) + + 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. + + if ( is_master() ) then + ! write(*,*) 'KS=', ks, 'PINT (mb)=', pint/100. + ! do k=1,km + ! pm(k) = 0.5*(pe1(k)+pe1(k+1))/100. + ! write(*,*) k, pm(k), dz(k) + ! enddo + 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. + write(*,800) (pm(k), k=km,1,-1) + endif + + do k=1,km + dp(k) = (pe1(k+1) - pe1(k))/100. + dk(k) = pe1(k+1)**akap - pe1(k)**akap + enddo + +800 format(1x,5(1x,f9.4)) + + end subroutine var_les + + + + subroutine var_gfs(km, ak, bk, ptop, ks, pint, s_rate) + integer, intent(in):: km + real, intent(in):: ptop + real, intent(in):: s_rate !< between [1. 1.1] + real, intent(out):: ak(km+1), bk(km+1) + real, intent(inout):: pint + integer, intent(out):: ks +! Local + real, parameter:: p00 = 1.E5 + real, dimension(km+1):: ze, pe1, peln, eta + real, dimension(km):: dz, s_fac, dlnp + real ztop, t0, dz0, sum1, tmp1 + real ep, es, alpha, beta, gama +!---- Tunable parameters: + integer:: k_inc = 25 !< number of layers from bottom up to near const dz region + real:: s0 = 0.13 !< lowest layer stretch factor +!----------------------- + real:: s_inc + integer k + + pe1(1) = ptop + peln(1) = log(pe1(1)) + pe1(km+1) = p00 + peln(km+1) = log(pe1(km+1)) + + t0 = 270. + ztop = rdgas/grav*t0*(peln(km+1) - peln(1)) + + s_inc = (1.-s0) / real(k_inc) + s_fac(km) = s0 + + do k=km-1, km-k_inc, -1 + s_fac(k) = s_fac(k+1) + s_inc + enddo + + do k=km-k_inc-1, 9, -1 + s_fac(k) = s_rate * s_fac(k+1) + enddo + s_fac(8) = 0.5*(1.1+s_rate)*s_fac(9) + s_fac(7) = 1.10*s_fac(8) + s_fac(6) = 1.15*s_fac(7) + s_fac(5) = 1.20*s_fac(6) + s_fac(4) = 1.26*s_fac(5) + s_fac(3) = 1.33*s_fac(4) + s_fac(2) = 1.41*s_fac(3) + s_fac(1) = 1.60*s_fac(2) + + sum1 = 0. + do k=1,km + sum1 = sum1 + s_fac(k) + enddo + + dz0 = ztop / sum1 + + do k=1,km + dz(k) = s_fac(k) * dz0 + enddo + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! Re-scale dz with the stretched ztop + do k=1,km + dz(k) = dz(k) * (ztop/ze(1)) + enddo + + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo +! ze(1) = ztop + + if ( is_master() ) then + write(*,*) 'var_gfs: computed model top (m)=', ztop*0.001, ' bottom/top dz=', dz(km), dz(1) +! do k=1,km +! write(*,*) k, s_fac(k) +! enddo + endif + +! call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 3) + +! Given z --> p + do k=1,km + dz(k) = ze(k) - ze(k+1) + dlnp(k) = grav*dz(k) / (rdgas*t0) + enddo + do k=2,km + peln(k) = peln(k-1) + dlnp(k-1) + pe1(k) = exp(peln(k)) + enddo + +! 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(*,*) 'ptop =', ptop + 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 + write(*,*) 'KS=', ks, 'PINT (mb)=', pint/100. + do k=1,km + write(*,*) k, 0.5*(pe1(k)+pe1(k+1))/100., dz(k) + enddo + 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 var_gfs + + subroutine var_hi(km, ak, bk, ptop, ks, pint, s_rate) + integer, intent(in):: km + real, intent(in):: ptop + real, intent(in):: s_rate !< between [1. 1.1] + real, intent(out):: ak(km+1), bk(km+1) + real, intent(inout):: pint + integer, intent(out):: ks +! Local + real, parameter:: p00 = 1.E5 + real, dimension(km+1):: ze, pe1, peln, eta + real, dimension(km):: dz, s_fac, dlnp + real ztop, t0, dz0, sum1, tmp1 + real ep, es, alpha, beta, gama +!---- Tunable parameters: + integer:: k_inc = 15 ! 1.E-8 ) then + pf(1) = (ph(2) - ph(1)) / log(ph(2)/ph(1)) + else + pf(1) = (ph(2) - ph(1)) * kappa/(kappa+1.) + endif + + do k=2,npz + pf(k) = (ph(k+1) - ph(k)) / log(ph(k+1)/ph(k)) + enddo + + end subroutine get_eta_level + + + + subroutine compute_dz(km, ztop, dz) + + integer, intent(in):: km + real, intent(in):: ztop ! try 50.E3 + real, intent(out):: dz(km) +!------------------------------ + real ze(km+1), dzt(km) + integer k + + +! ztop = 30.E3 + dz(1) = ztop / real(km) + dz(km) = 0.5*dz(1) + + do k=2,km-1 + dz(k) = dz(1) + enddo + +! Top: + dz(1) = 2.*dz(2) + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + + if ( is_master() ) then + write(*,*) 'Hybrid_z: dz, zm' + do k=1,km + dzt(k) = 0.5*(ze(k)+ze(k+1)) / 1000. + write(*,*) k, dz(k), dzt(k) + enddo + endif + + end subroutine compute_dz + + subroutine compute_dz_var(km, ztop, dz) + + integer, intent(in):: km + real, intent(in):: ztop ! try 50.E3 + real, intent(out):: dz(km) +!------------------------------ + real, parameter:: s_rate = 1.0 + real ze(km+1) + real s_fac(km) + real sum1, dz0 + integer k + + s_fac(km ) = 0.125 + s_fac(km-1) = 0.20 + s_fac(km-2) = 0.30 + s_fac(km-3) = 0.40 + s_fac(km-4) = 0.50 + s_fac(km-5) = 0.60 + s_fac(km-6) = 0.70 + s_fac(km-7) = 0.80 + s_fac(km-8) = 0.90 + s_fac(km-9) = 1. + + do k=km-10, 9, -1 + s_fac(k) = s_rate * s_fac(k+1) + enddo + + s_fac(8) = 1.05*s_fac(9) + s_fac(7) = 1.1 *s_fac(8) + s_fac(6) = 1.15*s_fac(7) + s_fac(5) = 1.2 *s_fac(6) + s_fac(4) = 1.3 *s_fac(5) + s_fac(3) = 1.4 *s_fac(4) + s_fac(2) = 1.5 *s_fac(3) + s_fac(1) = 1.6 *s_fac(2) + + sum1 = 0. + do k=1,km + sum1 = sum1 + s_fac(k) + enddo + + dz0 = ztop / sum1 + + do k=1,km + dz(k) = s_fac(k) * dz0 + enddo + + ze(1) = ztop + ze(km+1) = 0. + do k=km,2,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! Re-scale dz with the stretched ztop + do k=1,km + dz(k) = dz(k) * (ztop/ze(1)) + enddo + + do k=km,2,-1 + ze(k) = ze(k+1) + dz(k) + enddo + + call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 2) + + do k=1,km + dz(k) = ze(k) - ze(k+1) + enddo + + end subroutine compute_dz_var + + subroutine compute_dz_L32(km, ztop, dz) + + integer, intent(in):: km + real, intent(out):: dz(km) + real, intent(out):: ztop ! try 50.E3 +!------------------------------ + real dzt(km) + real ze(km+1) + real dz0, dz1, dz2 + real z0, z1, z2 + integer k, k0, k1, k2, n + +!------------------- + k2 = 8 + z2 = 30.E3 +!------------------- + k1 = 21 + z1 = 10.0E3 +!------------------- + k0 = 2 + z0 = 0. + dz0 = 75. ! meters +!------------------- +! Treat the surface layer as a special layer + ze(1) = z0 + dz(1) = dz0 + + ze(2) = dz(1) + dz0 = 1.5*dz0 + dz(2) = dz0 + + ze(3) = ze(2) + dz(2) + + dz1 = 2.*(z1-ze(3) - k1*dz0) / (k1*(k1-1)) + + do k=k0+1,k0+k1 + dz(k) = dz0 + (k-k0)*dz1 + ze(k+1) = ze(k) + dz(k) + enddo + + dz0 = dz(k1+k0) + dz2 = 2.*(z2-ze(k0+k1+1)-k2*dz0) / (k2*(k2-1)) + + do k=k0+k1+1,k0+k1+k2 + dz(k) = dz0 + (k-k0-k1)*dz2 + ze(k+1) = ze(k) + dz(k) + enddo + + dz(km) = 2.*dz(km-1) + ztop = ze(km) + dz(km) + ze(km+1) = ze(km) + dz(km) + + call zflip (dz, 1, km) + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! if ( is_master() ) then +! write(*,*) 'Hybrid_z: dz, zm' +! do k=1,km +! dzt(k) = 0.5*(ze(k)+ze(k+1)) / 1000. +! write(*,*) k, dz(k), dzt(k) +! enddo +! endif + + end subroutine compute_dz_L32 + + subroutine compute_dz_L101(km, ztop, dz) + + integer, intent(in):: km ! km==101 + real, intent(out):: dz(km) + real, intent(out):: ztop ! try 30.E3 +!------------------------------ + real ze(km+1) + real dz0, dz1 + real:: stretch_f = 1.16 + integer k, k0, k1 + + k1 = 2 + k0 = 25 + dz0 = 40. ! meters + + ze(km+1) = 0. + + do k=km, k0, -1 + dz(k) = dz0 + ze(k) = ze(k+1) + dz(k) + enddo + + do k=k0+1, k1, -1 + dz(k) = stretch_f * dz(k+1) + ze(k) = ze(k+1) + dz(k) + enddo + + dz(1) = 4.0*dz(2) + ze(1) = ze(2) + dz(1) + ztop = ze(1) + + if ( is_master() ) then + write(*,*) 'Hybrid_z: dz, ze' + do k=1,km + write(*,*) k, 0.001*dz(k), 0.001*ze(k) + enddo +! ztop (km) = 20.2859154 + write(*,*) 'ztop (km) =', ztop * 0.001 + endif + + end subroutine compute_dz_L101 + + subroutine set_hybrid_z(is, ie, js, je, ng, km, ztop, dz, rgrav, hs, ze, dz3) + + integer, intent(in):: is, ie, js, je, ng, km + real, intent(in):: rgrav, ztop + real, intent(in):: dz(km) !< Reference vertical resolution for zs=0 + real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng) + real, intent(inout):: ze(is:ie,js:je,km+1) + real, optional, intent(out):: dz3(is-ng:ie+ng,js-ng:je+ng,km) +! local + logical:: filter_xy = .false. + real, allocatable:: delz(:,:,:) + integer ntimes + real zint + real:: z1(is:ie,js:je) + real:: z(km+1) + real sig, z_rat + integer ks(is:ie,js:je) + integer i, j, k, ks_min, kint + + z(km+1) = 0. + do k=km,1,-1 + z(k) = z(k+1) + dz(k) + enddo + + do j=js,je + do i=is,ie + ze(i,j, 1) = ztop + ze(i,j,km+1) = hs(i,j) * rgrav + enddo + enddo + + do k=2,km + do j=js,je + do i=is,ie + ze(i,j,k) = z(k) + enddo + enddo + enddo + +! Set interface: +#ifndef USE_VAR_ZINT + zint = 12.0E3 + ntimes = 2 + kint = 2 + do k=2,km + if ( z(k)<=zint ) then + kint = k + exit + endif + enddo + + if ( is_master() ) write(*,*) 'Z_coord interface set at k=',kint, ' ZE=', z(kint) + + do j=js,je + do i=is,ie + z_rat = (ze(i,j,kint)-ze(i,j,km+1)) / (z(kint)-z(km+1)) + do k=km,kint+1,-1 + ze(i,j,k) = ze(i,j,k+1) + dz(k)*z_rat + enddo +!-------------------------------------- +! Apply vertical smoother locally to dz +!-------------------------------------- + call sm1_edge(is, ie, js, je, km, i, j, ze, ntimes) + enddo + enddo +#else +! ZINT is a function of local terrain + ntimes = 4 + do j=js,je + do i=is,ie + z1(i,j) = dim(ze(i,j,km+1), 2500.) + 7500. + enddo + enddo + + ks_min = km + do j=js,je + do i=is,ie + do k=km,2,-1 + if ( z(k)>=z1(i,j) ) then + ks(i,j) = k + ks_min = min(ks_min, k) + go to 555 + endif + enddo +555 continue + enddo + enddo + + do j=js,je + do i=is,ie + kint = ks(i,j) + 1 + z_rat = (ze(i,j,kint)-ze(i,j,km+1)) / (z(kint)-z(km+1)) + do k=km,kint+1,-1 + ze(i,j,k) = ze(i,j,k+1) + dz(k)*z_rat + enddo +!-------------------------------------- +! Apply vertical smoother locally to dz +!-------------------------------------- + call sm1_edge(is, ie, js, je, km, i, j, ze, ntimes) + enddo + enddo +#endif + +#ifdef DEV_ETA + if ( filter_xy ) then + allocate (delz(isd:ied, jsd:jed, km) ) + ntimes = 2 + do k=1,km + do j=js,je + do i=is,ie + delz(i,j,k) = ze(i,j,k+1) - ze(i,j,k) + enddo + enddo + enddo + call del2_cubed(delz, 0.2*da_min, npx, npy, km, ntimes) + do k=km,2,-1 + do j=js,je + do i=is,ie + ze(i,j,k) = ze(i,j,k+1) - delz(i,j,k) + enddo + enddo + enddo + deallocate ( delz ) + endif +#endif + if ( present(dz3) ) then + do k=1,km + do j=js,je + do i=is,ie + dz3(i,j,k) = ze(i,j,k+1) - ze(i,j,k) + enddo + enddo + enddo + endif + + end subroutine set_hybrid_z + + + subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes) + integer, intent(in):: is, ie, js, je, km + integer, intent(in):: ntimes, i, j + real, intent(inout):: ze(is:ie,js:je,km+1) +! local: + real, parameter:: df = 0.25 + real dz(km) + real flux(km+1) + integer k, n, k1, k2 + + k2 = km-1 + do k=1,km + dz(k) = ze(i,j,k+1) - ze(i,j,k) + enddo + + do n=1,ntimes + k1 = 2 + (ntimes-n) + + flux(k1 ) = 0. + flux(k2+1) = 0. + do k=k1+1,k2 + flux(k) = df*(dz(k) - dz(k-1)) + enddo + + do k=k1,k2 + dz(k) = dz(k) - flux(k) + flux(k+1) + enddo + enddo + + do k=km,1,-1 + ze(i,j,k) = ze(i,j,k+1) - dz(k) + enddo + + end subroutine sm1_edge + + + + subroutine gw_1d(km, p0, ak, bk, ptop, ztop, pt1) + integer, intent(in):: km + real, intent(in):: p0, ztop + real, intent(inout):: ptop + real, intent(inout):: ak(km+1), bk(km+1) + real, intent(out):: pt1(km) +! Local + logical:: isothermal + real, dimension(km+1):: ze, pe1, pk1 + real, dimension(km):: dz1 + real t0, n2, s0 + integer k + +! Set up vertical coordinare with constant del-z spacing: + isothermal = .false. + t0 = 300. + + if ( isothermal ) then + n2 = grav**2/(cp_air*t0) + else + n2 = 0.0001 + endif + + s0 = grav*grav / (cp_air*n2) + + ze(km+1) = 0. + do k=km,1,-1 + dz1(k) = ztop / real(km) + ze(k) = ze(k+1) + dz1(k) + enddo + +! Given z --> p + do k=1,km+1 + pe1(k) = p0*( (1.-s0/t0) + s0/t0*exp(-n2*ze(k)/grav) )**(1./kappa) + enddo + + ptop = pe1(1) +! if ( is_master() ) write(*,*) 'GW_1D: computed model top (pa)=', ptop + +! Set up "sigma" coordinate + ak(1) = pe1(1) + bk(1) = 0. + do k=2,km + bk(k) = (pe1(k) - pe1(1)) / (pe1(km+1)-pe1(1)) ! bk == sigma + ak(k) = pe1(1)*(1.-bk(k)) + enddo + ak(km+1) = 0. + bk(km+1) = 1. + + do k=1,km+1 + pk1(k) = pe1(k) ** kappa + enddo + +! Compute volume mean potential temperature with hydrostatic eqn: + do k=1,km + pt1(k) = grav*dz1(k) / ( cp_air*(pk1(k+1)-pk1(k)) ) + enddo + + end subroutine gw_1d + + + + subroutine zflip(q, im, km) + integer, intent(in):: im, km + real, intent(inout):: q(im,km) +!--- + integer i, k + real qtmp + + do i = 1, im + do k = 1, (km+1)/2 + qtmp = q(i,k) + q(i,k) = q(i,km+1-k) + q(i,km+1-k) = qtmp + end do + end do + + end subroutine zflip + +end module fv_eta_mod diff --git a/tools/fv_eta.F90_NAM_lyrs b/tools/fv_eta.F90_NAM_lyrs new file mode 100644 index 000000000..7697c385c --- /dev/null +++ b/tools/fv_eta.F90_NAM_lyrs @@ -0,0 +1,3079 @@ +!*********************************************************************** +!* 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_eta' contains routine to set up the reference +!! (Eulerian) pressure coordinate + +module fv_eta_mod + +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
Module NameFunctions Included
constants_modkappa, grav, cp_air, rdgas
fv_mp_modis_master
mpp_modmpp_error, FATAL
+ + use constants_mod, only: kappa, grav, cp_air, rdgas + use fv_mp_mod, only: is_master + use mpp_mod, only: FATAL, mpp_error + implicit none + private + public set_eta, set_external_eta, get_eta_level, compute_dz_var, & + compute_dz_L32, compute_dz_L101, set_hybrid_z, compute_dz, & + gw_1d, sm1_edge, hybrid_z_dz + + contains + +!!!NOTE: USE_VAR_ETA not used in fvGFS +#ifdef USE_VAR_ETA + subroutine set_eta(km, ks, ptop, ak, bk) +! 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 + real:: a60(61),b60(61) +! Thfollowing L63 setting is the same as NCEP GFS's L64 except the top +! 3 layers + data a60/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 b60/0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.00000, 0.00000, 0.00000, & + 0.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./ + real, intent(out):: ak(km+1) + real, intent(out):: bk(km+1) + real, intent(out):: ptop ! model top (Pa) + real pint, stretch_fac + integer k + real :: s_rate = -1.0 ! dummy value to not use var_les + + pint = 100.E2 + +!- Notes --------------------------------- +! low-top: ptop = 100. ! ~45 km +! mid-top: ptop = 10. ! ~60 km +! hi -top: ptop = 1. ! ~80 km +!----------------------------------------- + select case (km) + +! Optimal number = 8 * N -1 (for 8 openMP threads) +! 16 * M -1 (for 16 openMP threads) + +#ifdef HIWPP +#ifdef SUPER_K + 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 +#else + case (30) ! For Baroclinic Instability Test + ptop = 2.26e2 + pint = 250.E2 + stretch_fac = 1.03 + case (40) + ptop = 50.e2 ! For super cell test + pint = 300.E2 + stretch_fac = 1.03 + case (50) ! Mountain waves? + ptop = 30.e2 + stretch_fac = 1.025 + case (60) ! For Baroclinic Instability Test +#ifdef GFSL60 + ks = 20 + ptop = a60(1) + pint = a60(ks+1) + do k=1,km+1 + ak(k) = a60(k) + bk(k) = b60(k) + enddo +#else + ptop = 3.e2 +! pint = 250.E2 + pint = 300.E2 ! revised for Moist test + stretch_fac = 1.03 +#endif +#endif + case (64) +!!! ptop = 3.e2 + ptop = 2.0e2 + pint = 300.E2 + stretch_fac = 1.03 +#else +! *Very-low top: for idealized super-cell simulation: + case (50) + ptop = 50.e2 + pint = 250.E2 + stretch_fac = 1.03 + case (60) + ptop = 40.e2 + pint = 250.E2 + stretch_fac = 1.03 + case (90) ! super-duper cell + ptop = 40.e2 + stretch_fac = 1.025 +#endif +! Low-top: + case (31) ! N = 4, M=2 + ptop = 100. + stretch_fac = 1.035 + case (32) ! N = 4, M=2 + ptop = 100. + stretch_fac = 1.035 + case (39) ! N = 5 + ptop = 100. + stretch_fac = 1.035 + case (41) + ptop = 100. + stretch_fac = 1.035 + case (47) ! N = 6, M=3 + ptop = 100. + stretch_fac = 1.035 + case (51) + ptop = 100. + stretch_fac = 1.03 + case (52) ! very low top + ptop = 30.e2 ! for special DPM RCE experiments + stretch_fac = 1.03 +! Mid-top: + case (55) ! N = 7 + ptop = 10. + stretch_fac = 1.035 +! Hi-top: + case (63) ! N = 8, M=4 + ptop = 1. + ! c360 or c384 + stretch_fac = 1.035 + case (71) ! N = 9 + ptop = 1. + stretch_fac = 1.03 + case (79) ! N = 10, M=5 + ptop = 1. + stretch_fac = 1.03 + case (127) ! N = 10, M=5 + ptop = 1. + stretch_fac = 1.03 + case (151) + ptop = 75.e2 + pint = 500.E2 + s_rate = 1.01 + case default + ptop = 1. + stretch_fac = 1.03 + end select + +#ifdef MOUNTAIN_WAVES + call mount_waves(km, ak, bk, ptop, ks, pint) +#else + if (s_rate > 0.) then + call var_les(km, ak, bk, ptop, ks, pint, s_rate) + else + if ( km > 79 ) then + call var_hi2(km, ak, bk, ptop, ks, pint, stretch_fac) + elseif (km==5 .or. km==10 ) then +! Equivalent Shallow Water: for NGGPS, variable-resolution testing + ptop = 500.e2 + ks = 0 + do k=1,km+1 + bk(k) = real(k-1) / real (km) + ak(k) = ptop*(1.-bk(k)) + enddo + else +#ifndef GFSL60 + call var_hi(km, ak, bk, ptop, ks, pint, stretch_fac) +#endif + endif +#endif + endif + + ptop = ak(1) + pint = ak(ks+1) + + 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) + +! 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 + +#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 + +! 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 + +!--------------------- +! 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 + + 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 / + +! 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./ +#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 / + + select case (km) + + case (24) + + ks = 5 + do k=1,km+1 + ak(k) = a24(k) + bk(k) = b24(k) + enddo + + case (26) + + ks = 7 + do k=1,km+1 + ak(k) = a26(k) + bk(k) = b26(k) + 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 (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 (48) + ks = 28 + do k=1,km+1 + ak(k) = a48(k) + bk(k) = b48(k) + enddo + + case (52) + ks = 35 ! pint = 223 + do k=1,km+1 + ak(k) = a52(k) + bk(k) = b52(k) + enddo + + case (54) + ks = 11 ! pint = 109.4 + do k=1,km+1 + ak(k) = a54(k) + bk(k) = b54(k) + enddo + + case (56) + ks = 26 + do k=1,km+1 + ak(k) = a56(k) + bk(k) = b56(k) + enddo + + case (60) + ks = 19 + do k=1,km+1 + ak(k) = a60(k) + bk(k) = b60(k) + enddo + + + 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 + ak(k) = a68(k) + bk(k) = b68(k) + enddo + + case (96) + ks = 27 + do k=1,km+1 + ak(k) = a96(k) + bk(k) = b96(k) + enddo +!<--cjg + + case (100) + ks = 38 + do k=1,km+1 + ak(k) = a100(k) + bk(k) = b100(k) + enddo + + 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 + ak(k) = a125(k) + bk(k) = b125(k) + enddo + case default + +#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 + +!---------------------------------------------------------------- +! 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) + + end subroutine set_eta +#endif + +!>@brief The subroutine 'set_external_eta' sets 'ptop' (model top) and +!! 'ks' (first level of pure pressure coordinates given the coefficients +!! 'ak' and 'bk' + subroutine set_external_eta(ak, bk, ptop, ks) + implicit none + real, intent(in) :: ak(:) + real, intent(in) :: bk(:) + real, intent(out) :: ptop !< model top (Pa) + integer, intent(out) :: ks !< number of pure p layers + !--- local variables + integer :: k + real :: eps = 1.d-7 + + ptop = ak(1) + ks = 1 + do k = 1, size(bk(:)) + if (bk(k).lt.eps) ks = k + enddo + !--- change ks to layers from levels + ks = ks - 1 + if (is_master()) write(6,*) ' ptop & ks ', ptop, ks + + end subroutine set_external_eta + + + subroutine var_les(km, ak, bk, ptop, ks, pint, s_rate) + implicit none + integer, intent(in):: km + real, intent(in):: ptop + real, intent(in):: s_rate !< between [1. 1.1] + real, intent(out):: ak(km+1), bk(km+1) + real, intent(inout):: pint + integer, intent(out):: ks +! Local + real, parameter:: p00 = 1.E5 + real, dimension(km+1):: ze, pe1, peln, eta + real, dimension(km):: dz, s_fac, dlnp, pm, dp, dk + real ztop, t0, dz0, sum1, tmp1 + real ep, es, alpha, beta, gama + real, parameter:: akap = 2./7. +!---- Tunable parameters: + real:: k_inc = 10 !< number of layers from bottom up to near const dz region + real:: s0 = 0.8 !< lowest layer stretch factor +!----------------------- + real:: s_inc + integer k + + pe1(1) = ptop + peln(1) = log(pe1(1)) + pe1(km+1) = p00 + peln(km+1) = log(pe1(km+1)) + + t0 = 273. + ztop = rdgas/grav*t0*(peln(km+1) - peln(1)) + + s_inc = (1.-s0) / real(k_inc) + s_fac(km) = s0 + + do k=km-1, km-k_inc, -1 + s_fac(k) = s_fac(k+1) + s_inc + enddo + + s_fac(km-k_inc-1) = 0.5*(s_fac(km-k_inc) + s_rate) + + do k=km-k_inc-2, 5, -1 + s_fac(k) = s_rate * s_fac(k+1) + enddo + + s_fac(4) = 0.5*(1.1+s_rate)*s_fac(5) + s_fac(3) = 1.1 *s_fac(4) + s_fac(2) = 1.1 *s_fac(3) + s_fac(1) = 1.1 *s_fac(2) + + sum1 = 0. + do k=1,km + sum1 = sum1 + s_fac(k) + enddo + + dz0 = ztop / sum1 + + do k=1,km + dz(k) = s_fac(k) * dz0 + enddo + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! Re-scale dz with the stretched ztop + do k=1,km + dz(k) = dz(k) * (ztop/ze(1)) + enddo + + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo +! ze(1) = ztop + + if ( is_master() ) then + write(*,*) 'var_les: computed model top (m)=', ztop, ' bottom/top dz=', dz(km), dz(1) +! do k=1,km +! write(*,*) k, s_fac(k) +! enddo + endif + + call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 2) + +! Given z --> p + do k=1,km + dz(k) = ze(k) - ze(k+1) + dlnp(k) = grav*dz(k) / (rdgas*t0) + !write(*,*) k, dz(k) + enddo + do k=2,km + peln(k) = peln(k-1) + dlnp(k-1) + pe1(k) = exp(peln(k)) + enddo + + +! 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) + endif + pint = pe1(ks+1) + + 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. + + if ( is_master() ) then + ! write(*,*) 'KS=', ks, 'PINT (mb)=', pint/100. + ! do k=1,km + ! pm(k) = 0.5*(pe1(k)+pe1(k+1))/100. + ! write(*,*) k, pm(k), dz(k) + ! enddo + 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. + write(*,800) (pm(k), k=km,1,-1) + endif + + do k=1,km + dp(k) = (pe1(k+1) - pe1(k))/100. + dk(k) = pe1(k+1)**akap - pe1(k)**akap + enddo + +800 format(1x,5(1x,f9.4)) + + end subroutine var_les + + + + subroutine var_gfs(km, ak, bk, ptop, ks, pint, s_rate) + integer, intent(in):: km + real, intent(in):: ptop + real, intent(in):: s_rate !< between [1. 1.1] + real, intent(out):: ak(km+1), bk(km+1) + real, intent(inout):: pint + integer, intent(out):: ks +! Local + real, parameter:: p00 = 1.E5 + real, dimension(km+1):: ze, pe1, peln, eta + real, dimension(km):: dz, s_fac, dlnp + real ztop, t0, dz0, sum1, tmp1 + real ep, es, alpha, beta, gama +!---- Tunable parameters: + integer:: k_inc = 25 !< number of layers from bottom up to near const dz region + real:: s0 = 0.13 !< lowest layer stretch factor +!----------------------- + real:: s_inc + integer k + + pe1(1) = ptop + peln(1) = log(pe1(1)) + pe1(km+1) = p00 + peln(km+1) = log(pe1(km+1)) + + t0 = 270. + ztop = rdgas/grav*t0*(peln(km+1) - peln(1)) + + s_inc = (1.-s0) / real(k_inc) + s_fac(km) = s0 + + do k=km-1, km-k_inc, -1 + s_fac(k) = s_fac(k+1) + s_inc + enddo + + do k=km-k_inc-1, 9, -1 + s_fac(k) = s_rate * s_fac(k+1) + enddo + s_fac(8) = 0.5*(1.1+s_rate)*s_fac(9) + s_fac(7) = 1.10*s_fac(8) + s_fac(6) = 1.15*s_fac(7) + s_fac(5) = 1.20*s_fac(6) + s_fac(4) = 1.26*s_fac(5) + s_fac(3) = 1.33*s_fac(4) + s_fac(2) = 1.41*s_fac(3) + s_fac(1) = 1.60*s_fac(2) + + sum1 = 0. + do k=1,km + sum1 = sum1 + s_fac(k) + enddo + + dz0 = ztop / sum1 + + do k=1,km + dz(k) = s_fac(k) * dz0 + enddo + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! Re-scale dz with the stretched ztop + do k=1,km + dz(k) = dz(k) * (ztop/ze(1)) + enddo + + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo +! ze(1) = ztop + + if ( is_master() ) then + write(*,*) 'var_gfs: computed model top (m)=', ztop*0.001, ' bottom/top dz=', dz(km), dz(1) +! do k=1,km +! write(*,*) k, s_fac(k) +! enddo + endif + +! call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 3) + +! Given z --> p + do k=1,km + dz(k) = ze(k) - ze(k+1) + dlnp(k) = grav*dz(k) / (rdgas*t0) + enddo + do k=2,km + peln(k) = peln(k-1) + dlnp(k-1) + pe1(k) = exp(peln(k)) + enddo + +! 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(*,*) 'ptop =', ptop + 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 + write(*,*) 'KS=', ks, 'PINT (mb)=', pint/100. + do k=1,km + write(*,*) k, 0.5*(pe1(k)+pe1(k+1))/100., dz(k) + enddo + 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 var_gfs + + subroutine var_hi(km, ak, bk, ptop, ks, pint, s_rate) + integer, intent(in):: km + real, intent(in):: ptop + real, intent(in):: s_rate !< between [1. 1.1] + real, intent(out):: ak(km+1), bk(km+1) + real, intent(inout):: pint + integer, intent(out):: ks +! Local + real, parameter:: p00 = 1.E5 + real, dimension(km+1):: ze, pe1, peln, eta + real, dimension(km):: dz, s_fac, dlnp + real ztop, t0, dz0, sum1, tmp1 + real ep, es, alpha, beta, gama +!---- Tunable parameters: + integer:: k_inc = 15 ! 1.E-8 ) then + pf(1) = (ph(2) - ph(1)) / log(ph(2)/ph(1)) + else + pf(1) = (ph(2) - ph(1)) * kappa/(kappa+1.) + endif + + do k=2,npz + pf(k) = (ph(k+1) - ph(k)) / log(ph(k+1)/ph(k)) + enddo + + end subroutine get_eta_level + + + + subroutine compute_dz(km, ztop, dz) + + integer, intent(in):: km + real, intent(in):: ztop ! try 50.E3 + real, intent(out):: dz(km) +!------------------------------ + real ze(km+1), dzt(km) + integer k + + +! ztop = 30.E3 + dz(1) = ztop / real(km) + dz(km) = 0.5*dz(1) + + do k=2,km-1 + dz(k) = dz(1) + enddo + +! Top: + dz(1) = 2.*dz(2) + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + + if ( is_master() ) then + write(*,*) 'Hybrid_z: dz, zm' + do k=1,km + dzt(k) = 0.5*(ze(k)+ze(k+1)) / 1000. + write(*,*) k, dz(k), dzt(k) + enddo + endif + + end subroutine compute_dz + + subroutine compute_dz_var(km, ztop, dz) + + integer, intent(in):: km + real, intent(in):: ztop ! try 50.E3 + real, intent(out):: dz(km) +!------------------------------ + real, parameter:: s_rate = 1.0 + real ze(km+1) + real s_fac(km) + real sum1, dz0 + integer k + + s_fac(km ) = 0.125 + s_fac(km-1) = 0.20 + s_fac(km-2) = 0.30 + s_fac(km-3) = 0.40 + s_fac(km-4) = 0.50 + s_fac(km-5) = 0.60 + s_fac(km-6) = 0.70 + s_fac(km-7) = 0.80 + s_fac(km-8) = 0.90 + s_fac(km-9) = 1. + + do k=km-10, 9, -1 + s_fac(k) = s_rate * s_fac(k+1) + enddo + + s_fac(8) = 1.05*s_fac(9) + s_fac(7) = 1.1 *s_fac(8) + s_fac(6) = 1.15*s_fac(7) + s_fac(5) = 1.2 *s_fac(6) + s_fac(4) = 1.3 *s_fac(5) + s_fac(3) = 1.4 *s_fac(4) + s_fac(2) = 1.5 *s_fac(3) + s_fac(1) = 1.6 *s_fac(2) + + sum1 = 0. + do k=1,km + sum1 = sum1 + s_fac(k) + enddo + + dz0 = ztop / sum1 + + do k=1,km + dz(k) = s_fac(k) * dz0 + enddo + + ze(1) = ztop + ze(km+1) = 0. + do k=km,2,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! Re-scale dz with the stretched ztop + do k=1,km + dz(k) = dz(k) * (ztop/ze(1)) + enddo + + do k=km,2,-1 + ze(k) = ze(k+1) + dz(k) + enddo + + call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 2) + + do k=1,km + dz(k) = ze(k) - ze(k+1) + enddo + + end subroutine compute_dz_var + + subroutine compute_dz_L32(km, ztop, dz) + + integer, intent(in):: km + real, intent(out):: dz(km) + real, intent(out):: ztop ! try 50.E3 +!------------------------------ + real dzt(km) + real ze(km+1) + real dz0, dz1, dz2 + real z0, z1, z2 + integer k, k0, k1, k2, n + +!------------------- + k2 = 8 + z2 = 30.E3 +!------------------- + k1 = 21 + z1 = 10.0E3 +!------------------- + k0 = 2 + z0 = 0. + dz0 = 75. ! meters +!------------------- +! Treat the surface layer as a special layer + ze(1) = z0 + dz(1) = dz0 + + ze(2) = dz(1) + dz0 = 1.5*dz0 + dz(2) = dz0 + + ze(3) = ze(2) + dz(2) + + dz1 = 2.*(z1-ze(3) - k1*dz0) / (k1*(k1-1)) + + do k=k0+1,k0+k1 + dz(k) = dz0 + (k-k0)*dz1 + ze(k+1) = ze(k) + dz(k) + enddo + + dz0 = dz(k1+k0) + dz2 = 2.*(z2-ze(k0+k1+1)-k2*dz0) / (k2*(k2-1)) + + do k=k0+k1+1,k0+k1+k2 + dz(k) = dz0 + (k-k0-k1)*dz2 + ze(k+1) = ze(k) + dz(k) + enddo + + dz(km) = 2.*dz(km-1) + ztop = ze(km) + dz(km) + ze(km+1) = ze(km) + dz(km) + + call zflip (dz, 1, km) + + ze(km+1) = 0. + do k=km,1,-1 + ze(k) = ze(k+1) + dz(k) + enddo + +! if ( is_master() ) then +! write(*,*) 'Hybrid_z: dz, zm' +! do k=1,km +! dzt(k) = 0.5*(ze(k)+ze(k+1)) / 1000. +! write(*,*) k, dz(k), dzt(k) +! enddo +! endif + + end subroutine compute_dz_L32 + + subroutine compute_dz_L101(km, ztop, dz) + + integer, intent(in):: km ! km==101 + real, intent(out):: dz(km) + real, intent(out):: ztop ! try 30.E3 +!------------------------------ + real ze(km+1) + real dz0, dz1 + real:: stretch_f = 1.16 + integer k, k0, k1 + + k1 = 2 + k0 = 25 + dz0 = 40. ! meters + + ze(km+1) = 0. + + do k=km, k0, -1 + dz(k) = dz0 + ze(k) = ze(k+1) + dz(k) + enddo + + do k=k0+1, k1, -1 + dz(k) = stretch_f * dz(k+1) + ze(k) = ze(k+1) + dz(k) + enddo + + dz(1) = 4.0*dz(2) + ze(1) = ze(2) + dz(1) + ztop = ze(1) + + if ( is_master() ) then + write(*,*) 'Hybrid_z: dz, ze' + do k=1,km + write(*,*) k, 0.001*dz(k), 0.001*ze(k) + enddo +! ztop (km) = 20.2859154 + write(*,*) 'ztop (km) =', ztop * 0.001 + endif + + end subroutine compute_dz_L101 + + subroutine set_hybrid_z(is, ie, js, je, ng, km, ztop, dz, rgrav, hs, ze, dz3) + + integer, intent(in):: is, ie, js, je, ng, km + real, intent(in):: rgrav, ztop + real, intent(in):: dz(km) !< Reference vertical resolution for zs=0 + real, intent(in):: hs(is-ng:ie+ng,js-ng:je+ng) + real, intent(inout):: ze(is:ie,js:je,km+1) + real, optional, intent(out):: dz3(is-ng:ie+ng,js-ng:je+ng,km) +! local + logical:: filter_xy = .false. + real, allocatable:: delz(:,:,:) + integer ntimes + real zint + real:: z1(is:ie,js:je) + real:: z(km+1) + real sig, z_rat + integer ks(is:ie,js:je) + integer i, j, k, ks_min, kint + + z(km+1) = 0. + do k=km,1,-1 + z(k) = z(k+1) + dz(k) + enddo + + do j=js,je + do i=is,ie + ze(i,j, 1) = ztop + ze(i,j,km+1) = hs(i,j) * rgrav + enddo + enddo + + do k=2,km + do j=js,je + do i=is,ie + ze(i,j,k) = z(k) + enddo + enddo + enddo + +! Set interface: +#ifndef USE_VAR_ZINT + zint = 12.0E3 + ntimes = 2 + kint = 2 + do k=2,km + if ( z(k)<=zint ) then + kint = k + exit + endif + enddo + + if ( is_master() ) write(*,*) 'Z_coord interface set at k=',kint, ' ZE=', z(kint) + + do j=js,je + do i=is,ie + z_rat = (ze(i,j,kint)-ze(i,j,km+1)) / (z(kint)-z(km+1)) + do k=km,kint+1,-1 + ze(i,j,k) = ze(i,j,k+1) + dz(k)*z_rat + enddo +!-------------------------------------- +! Apply vertical smoother locally to dz +!-------------------------------------- + call sm1_edge(is, ie, js, je, km, i, j, ze, ntimes) + enddo + enddo +#else +! ZINT is a function of local terrain + ntimes = 4 + do j=js,je + do i=is,ie + z1(i,j) = dim(ze(i,j,km+1), 2500.) + 7500. + enddo + enddo + + ks_min = km + do j=js,je + do i=is,ie + do k=km,2,-1 + if ( z(k)>=z1(i,j) ) then + ks(i,j) = k + ks_min = min(ks_min, k) + go to 555 + endif + enddo +555 continue + enddo + enddo + + do j=js,je + do i=is,ie + kint = ks(i,j) + 1 + z_rat = (ze(i,j,kint)-ze(i,j,km+1)) / (z(kint)-z(km+1)) + do k=km,kint+1,-1 + ze(i,j,k) = ze(i,j,k+1) + dz(k)*z_rat + enddo +!-------------------------------------- +! Apply vertical smoother locally to dz +!-------------------------------------- + call sm1_edge(is, ie, js, je, km, i, j, ze, ntimes) + enddo + enddo +#endif + +#ifdef DEV_ETA + if ( filter_xy ) then + allocate (delz(isd:ied, jsd:jed, km) ) + ntimes = 2 + do k=1,km + do j=js,je + do i=is,ie + delz(i,j,k) = ze(i,j,k+1) - ze(i,j,k) + enddo + enddo + enddo + call del2_cubed(delz, 0.2*da_min, npx, npy, km, ntimes) + do k=km,2,-1 + do j=js,je + do i=is,ie + ze(i,j,k) = ze(i,j,k+1) - delz(i,j,k) + enddo + enddo + enddo + deallocate ( delz ) + endif +#endif + if ( present(dz3) ) then + do k=1,km + do j=js,je + do i=is,ie + dz3(i,j,k) = ze(i,j,k+1) - ze(i,j,k) + enddo + enddo + enddo + endif + + end subroutine set_hybrid_z + + + subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes) + integer, intent(in):: is, ie, js, je, km + integer, intent(in):: ntimes, i, j + real, intent(inout):: ze(is:ie,js:je,km+1) +! local: + real, parameter:: df = 0.25 + real dz(km) + real flux(km+1) + integer k, n, k1, k2 + + k2 = km-1 + do k=1,km + dz(k) = ze(i,j,k+1) - ze(i,j,k) + enddo + + do n=1,ntimes + k1 = 2 + (ntimes-n) + + flux(k1 ) = 0. + flux(k2+1) = 0. + do k=k1+1,k2 + flux(k) = df*(dz(k) - dz(k-1)) + enddo + + do k=k1,k2 + dz(k) = dz(k) - flux(k) + flux(k+1) + enddo + enddo + + do k=km,1,-1 + ze(i,j,k) = ze(i,j,k+1) - dz(k) + enddo + + end subroutine sm1_edge + + + + subroutine gw_1d(km, p0, ak, bk, ptop, ztop, pt1) + integer, intent(in):: km + real, intent(in):: p0, ztop + real, intent(inout):: ptop + real, intent(inout):: ak(km+1), bk(km+1) + real, intent(out):: pt1(km) +! Local + logical:: isothermal + real, dimension(km+1):: ze, pe1, pk1 + real, dimension(km):: dz1 + real t0, n2, s0 + integer k + +! Set up vertical coordinare with constant del-z spacing: + isothermal = .false. + t0 = 300. + + if ( isothermal ) then + n2 = grav**2/(cp_air*t0) + else + n2 = 0.0001 + endif + + s0 = grav*grav / (cp_air*n2) + + ze(km+1) = 0. + do k=km,1,-1 + dz1(k) = ztop / real(km) + ze(k) = ze(k+1) + dz1(k) + enddo + +! Given z --> p + do k=1,km+1 + pe1(k) = p0*( (1.-s0/t0) + s0/t0*exp(-n2*ze(k)/grav) )**(1./kappa) + enddo + + ptop = pe1(1) +! if ( is_master() ) write(*,*) 'GW_1D: computed model top (pa)=', ptop + +! Set up "sigma" coordinate + ak(1) = pe1(1) + bk(1) = 0. + do k=2,km + bk(k) = (pe1(k) - pe1(1)) / (pe1(km+1)-pe1(1)) ! bk == sigma + ak(k) = pe1(1)*(1.-bk(k)) + enddo + ak(km+1) = 0. + bk(km+1) = 1. + + do k=1,km+1 + pk1(k) = pe1(k) ** kappa + enddo + +! Compute volume mean potential temperature with hydrostatic eqn: + do k=1,km + pt1(k) = grav*dz1(k) / ( cp_air*(pk1(k+1)-pk1(k)) ) + enddo + + end subroutine gw_1d + + + + subroutine zflip(q, im, km) + integer, intent(in):: im, km + real, intent(inout):: q(im,km) +!--- + integer i, k + real qtmp + + do i = 1, im + do k = 1, (km+1)/2 + qtmp = q(i,k) + q(i,k) = q(i,km+1-k) + q(i,km+1-k) = qtmp + end do + end do + + end subroutine zflip + +end module fv_eta_mod diff --git a/tools/fv_restart.F90 b/tools/fv_restart.F90 index 72071cea6..fbe46d676 100644 --- a/tools/fv_restart.F90 +++ b/tools/fv_restart.F90 @@ -165,6 +165,7 @@ module fv_restart_mod use fv_timing_mod, only: timing_on, timing_off 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 @@ -354,7 +355,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ 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)) + call get_external_ic(Atm(n:n), Atm(n)%domain, cold_start_grids(n), dt_atmos) if( is_master() ) write(*,*) 'IC generated from the specified external source' endif @@ -1448,7 +1449,6 @@ subroutine fv_restart_end(Atm, grids_on_this_pe, restart_endfcst) character(len=128):: tracer_name character(len=3):: gn - ntileMe = size(Atm(:)) do n = 1, ntileMe @@ -1523,6 +1523,11 @@ subroutine fv_restart_end(Atm, grids_on_this_pe, restart_endfcst) 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(Atm(1)%flagstruct%write_restart_with_bcs)then + call write_full_fields(Atm) + endif + endif module_is_initialized = .FALSE.