diff --git a/GFDL_tools/fv_diag_column.F90 b/GFDL_tools/fv_diag_column.F90 index 25a3cf008..284277710 100644 --- a/GFDL_tools/fv_diag_column.F90 +++ b/GFDL_tools/fv_diag_column.F90 @@ -381,7 +381,7 @@ subroutine debug_column(pt, delp, delz, u, v, w, q, npz, ncnst, sphum, nwat, zvi write(unit, *) '===================================================================' write(unit, *) flush(unit) - + enddo end subroutine debug_column diff --git a/RELEASE.md b/RELEASE.md index 20ba50f88..c6a71294b 100644 --- a/RELEASE.md +++ b/RELEASE.md @@ -1,3 +1,23 @@ + +# RELEASE NOTES for FV3 202107: Summary + +FV3-202107-public --- 08 July 2021 +Lucas Harris, GFDL lucas.harris@noaa.gov + +This version has been tested against the current SHiELD physics +and with FMS release 2021.02 from https://github.com/NOAA-GFDL/FMS + +This release includes the following: + +- Comprehensive documentation in LaTEX format (FV3 team) +- Default changes to some namelist options and updated inline documentation +- Multiple same-level and telescoping nests for the Regional domain (J Mouallem) +- Updated fms2_io functionality (L Chilutti) +- Revised Regional domain code (K-Y Cheng) +- Reproducibility fixes for global+nests and regional+nests (tested for absolute reproducibility across PE counts, restarts) +- Other updates and general cleanup + + # RELEASE NOTES for FV3 202101: Summary FV3-202101-public --- 22 January 2021 @@ -12,8 +32,8 @@ This release includes the following: - In-line GFDL Microphysics - Fast-timescale Rayleigh damping - Updated namelist documentation -- Implemented multiple same-level and telescoping nests for the global system (from J Mouallem) -- Updated coarse-graining capabilities (from S Clark) +- Implemented multiple same-level and telescoping nests for the global system (J Mouallem) +- Updated coarse-graining capabilities (S Clark) - Re-organized fv_diagnostics, moving the revised fv_diag_column functionality and the declaration of diagnostic IDs to separate files - and other updates and general cleanup @@ -23,6 +43,7 @@ This version of FV3 is described as component of SHiELD in Harris et al. (2020, atmosphere.F90: if using the in-line GFDL microphysics the precipitation rates (available in the structure Atm%inline_mp for rain, ice, snow, and graupel separately) must be passed into the physics and/or land model as appropriate. Here we demonstrate how to do this in SHiELD by copying them into IPD_Data(nb)%Statein%prep (and so on), which are newly defined in the IPD_Data structure within the SHiELD physics. + # RELEASE NOTES for FV3 201912: Summary FV3-201912-public --- 10 January 2020 @@ -33,12 +54,12 @@ and with FMS release candidate 2020.02 from https://github.com/NOAA-GFDL/FMS Includes all of the features of the GFDL Release to EMC, as well as: -- Updated 2017 GFDL Microphysics (from S-J Lin and L Zhou included in GFSv15) -- Updates for GFSv15 ICs (from T Black/J Abeles, EMC) -- Updates to support new nesting capabilities in FMS (from Z Liang) +- Updated 2017 GFDL Microphysics (S-J Lin and L Zhou included in GFSv15) +- Updates for GFSv15 ICs (T Black/J Abeles, EMC) +- Updates to support new nesting capabilities in FMS (Z Liang) - Re-written grid nesting code for efficiency and parallelization - Re-organized fv_eta for improved vertical level selection -- 2018 Stand-alone regional capabilities (from T Black/J Abeles, EMC) +- 2018 Stand-alone regional capabilities (T Black/J Abeles, EMC) - Refactored model front-end (fv_control, fv_restart) - Support for point soundings - And other updates diff --git a/model/a2b_edge.F90 b/model/a2b_edge.F90 index 48229059f..88c54ac96 100644 --- a/model/a2b_edge.F90 +++ b/model/a2b_edge.F90 @@ -463,175 +463,4 @@ real function extrap_corner ( p0, p1, p2, q1, q2 ) end function extrap_corner -!!$#ifdef TEST_VAND2 -!!$ subroutine a2b_ord4(qin, qout, grid, agrid, npx, npy, is, ie, js, je, ng, replace) -!!$! use tp_core_mod, only: copy_corners -!!$ integer, intent(IN):: npx, npy, is, ie, js, je, ng -!!$ real, intent(INOUT):: qin(is-ng:ie+ng,js-ng:je+ng) ! A-grid field -!!$ real, intent(INOUT):: qout(is-ng:ie+ng,js-ng:je+ng) ! Output B-grid field -!!$ real, intent(in) :: grid(is-ng:ie+ng+1,js-ng:je+ng+1,2) -!!$ real, intent(in) :: agrid(is-ng:ie+ng,js-ng:je+ng,2) -!!$ logical, optional, intent(IN):: replace -!!$ real qx(is:ie+1,js-ng:je+ng) -!!$ real qy(is-ng:ie+ng,js:je+1) -!!$ real:: p0(2) -!!$ integer :: i, j -!!$ -!!$ real, pointer, dimension(:,:,:) :: grid, agrid -!!$ real, pointer, dimension(:,:) :: dxa, dya -!!$ -!!$ real, pointer, dimension(:) :: edge_w, edge_e, edge_s, edge_n -!!$ -!!$ edge_w => gridstruct%edge_w -!!$ edge_e => gridstruct%edge_e -!!$ edge_s => gridstruct%edge_s -!!$ edge_n => gridstruct%edge_n -!!$ -!!$ grid => gridstruct%grid -!!$ agrid => gridstruct%agrid -!!$ dxa => gridstruct%dxa -!!$ dya => gridstruct%dya -!!$ -!!$ -!!$ if (gridstruct%grid_type < 3) then -!!$ -!!$!------------------------------------------ -!!$! Copy fields to the phantom corner region: -!!$!------------------------------------------ -!!$! call copy_corners(qin, npx, npy, 1) -!!$ -!!$ do j=js,je+1 -!!$ do i=is,ie+1 -!!$!SW: -!!$ if ( i==1 .and. j==1 ) goto 123 -!!$ if ( i==2 .and. j==1 ) then -!!$ qin(0,-1) = qin(-1,2) -!!$ qin(0, 0) = qin(-1,1) -!!$ endif -!!$ if ( i==1 .and. j==2 ) then -!!$ qin(-1,0) = qin(2,-1) -!!$ qin( 0,0) = qin(1,-1) -!!$ endif -!!$ if ( i==2 .and. j==2 ) then -!!$ qin( 0,0) = qin(4,4) -!!$ endif -!!$!SE: -!!$ if ( i==npx .and. j==1 ) goto 123 -!!$ if ( i==npx-1 .and. j==1 ) then -!!$ qin(npx,-1) = qin(npx+1,2) -!!$ qin(npx, 0) = qin(npx+1,1) -!!$ endif -!!$ if ( i==npx-1 .and. j==2 ) then -!!$ qin(npx,0) = qin(npx-4,4) -!!$ endif -!!$ if ( i==npx .and. j==2 ) then -!!$ qin(npx+1,0) = qin(npx-2,-1) -!!$ qin(npx, 0) = qin(npx-1,-1) -!!$ endif -!!$!NE: -!!$ if ( i==npx .and. j==npy ) goto 123 -!!$ if ( i==npx-1 .and. j==npy-1 ) then -!!$ qin(npx,npy) = qin(npx-4,npy-4) -!!$ endif -!!$ if ( i==npx .and. j==npy-1 ) then -!!$ qin(npx+1,npy) = qin(npx-2,npy+1) -!!$ qin(npx, npy) = qin(npx-1,npy+1) -!!$ endif -!!$ if ( i==npx-1 .and. j==npy ) then -!!$ qin(npx,npy+1) = qin(npx+1,npy-2) -!!$ qin(npx,npy ) = qin(npx+1,npy-1) -!!$ endif -!!$!NW: -!!$ if ( i==1 .and. j==npy ) goto 123 -!!$ if ( i==1 .and. j==npy-1 ) then -!!$ qin(-1,npy) = qin(2,npy+1) -!!$ qin( 0,npy) = qin(1,npy+1) -!!$ endif -!!$ if ( i==2 .and. j==npy-1 ) then -!!$ qin(0,npy) = qin(4,npy-4) -!!$ endif -!!$ if ( i==2 .and. j==npy ) then -!!$ qin(0,npy+1) = qin(-1,npy-2) -!!$ qin(0,npy ) = qin(-1,npy-1) -!!$ endif -!!$ -!!$ qout(i,j) = van2(1, i,j)*qin(i-2,j-2) + van2(2, i,j)*qin(i-1,j-2) + & -!!$ van2(3, i,j)*qin(i ,j-2) + van2(4, i,j)*qin(i+1,j-2) + & -!!$ van2(5, i,j)*qin(i-2,j-1) + van2(6, i,j)*qin(i-1,j-1) + & -!!$ van2(7, i,j)*qin(i ,j-1) + van2(8, i,j)*qin(i+1,j-1) + & -!!$ van2(9, i,j)*qin(i-2,j ) + van2(10,i,j)*qin(i-1,j ) + & -!!$ van2(11,i,j)*qin(i ,j ) + van2(12,i,j)*qin(i+1,j ) + & -!!$ van2(13,i,j)*qin(i-2,j+1) + van2(14,i,j)*qin(i-1,j+1) + & -!!$ van2(15,i,j)*qin(i ,j+1) + van2(16,i,j)*qin(i+1,j+1) -!!$123 continue -!!$ enddo -!!$ enddo -!!$ -!!$! 3-way extrapolation -!!$ if ( gridstruct%sw_corner ) then -!!$ p0(1:2) = grid(1,1,1:2) -!!$ qout(1,1) = (extrap_corner(p0, agrid(1,1,1:2), agrid( 2, 2,1:2), qin(1,1), qin( 2, 2)) + & -!!$ extrap_corner(p0, agrid(0,1,1:2), agrid(-1, 2,1:2), qin(0,1), qin(-1, 2)) + & -!!$ extrap_corner(p0, agrid(1,0,1:2), agrid( 2,-1,1:2), qin(1,0), qin( 2,-1)))*r3 -!!$ -!!$ endif -!!$ if ( gridstruct%se_corner ) then -!!$ p0(1:2) = grid(npx,1,1:2) -!!$ qout(npx,1) = (extrap_corner(p0, agrid(npx-1,1,1:2), agrid(npx-2, 2,1:2), qin(npx-1,1), qin(npx-2, 2)) + & -!!$ extrap_corner(p0, agrid(npx-1,0,1:2), agrid(npx-2,-1,1:2), qin(npx-1,0), qin(npx-2,-1)) + & -!!$ extrap_corner(p0, agrid(npx ,1,1:2), agrid(npx+1, 2,1:2), qin(npx ,1), qin(npx+1, 2)))*r3 -!!$ endif -!!$ if ( gridstruct%ne_corner ) then -!!$ p0(1:2) = grid(npx,npy,1:2) -!!$ qout(npx,npy) = (extrap_corner(p0, agrid(npx-1,npy-1,1:2), agrid(npx-2,npy-2,1:2), qin(npx-1,npy-1), qin(npx-2,npy-2)) + & -!!$ extrap_corner(p0, agrid(npx ,npy-1,1:2), agrid(npx+1,npy-2,1:2), qin(npx ,npy-1), qin(npx+1,npy-2)) + & -!!$ extrap_corner(p0, agrid(npx-1,npy ,1:2), agrid(npx-2,npy+1,1:2), qin(npx-1,npy ), qin(npx-2,npy+1)))*r3 -!!$ endif -!!$ if ( gridstruct%nw_corner ) then -!!$ p0(1:2) = grid(1,npy,1:2) -!!$ qout(1,npy) = (extrap_corner(p0, agrid(1,npy-1,1:2), agrid( 2,npy-2,1:2), qin(1,npy-1), qin( 2,npy-2)) + & -!!$ extrap_corner(p0, agrid(0,npy-1,1:2), agrid(-1,npy-2,1:2), qin(0,npy-1), qin(-1,npy-2)) + & -!!$ extrap_corner(p0, agrid(1,npy, 1:2), agrid( 2,npy+1,1:2), qin(1,npy ), qin( 2,npy+1)))*r3 -!!$ endif -!!$ -!!$ else ! grid_type>=3 -!!$ -!!$!------------------------ -!!$! Doubly periodic domain: -!!$!------------------------ -!!$! X-sweep: PPM -!!$ do j=js-2,je+2 -!!$ do i=is,ie+1 -!!$ qx(i,j) = b1*(qin(i-1,j)+qin(i,j)) + b2*(qin(i-2,j)+qin(i+1,j)) -!!$ enddo -!!$ enddo -!!$! Y-sweep: PPM -!!$ do j=js,je+1 -!!$ do i=is-2,ie+2 -!!$ qy(i,j) = b1*(qin(i,j-1)+qin(i,j)) + b2*(qin(i,j-2)+qin(i,j+1)) -!!$ enddo -!!$ enddo -!!$ -!!$ do j=js,je+1 -!!$ do i=is,ie+1 -!!$ qout(i,j) = 0.5*( a1*(qx(i,j-1)+qx(i,j ) + qy(i-1,j)+qy(i, j)) + & -!!$ a2*(qx(i,j-2)+qx(i,j+1) + qy(i-2,j)+qy(i+1,j)) ) -!!$ enddo -!!$ enddo -!!$ -!!$ endif -!!$ -!!$ if ( present(replace) ) then -!!$ if ( replace ) then -!!$ do j=js,je+1 -!!$ do i=is,ie+1 -!!$ qin(i,j) = qout(i,j) -!!$ enddo -!!$ enddo -!!$ endif -!!$ endif -!!$ -!!$ end subroutine a2b_ord4 -!!$#endif - end module a2b_edge_mod diff --git a/model/boundary.F90 b/model/boundary.F90 index a560d1063..3d59114ce 100644 --- a/model/boundary.F90 +++ b/model/boundary.F90 @@ -542,35 +542,6 @@ subroutine fill_nested_grid_3D(var_nest, var_coarse, ind, wt, istag, jstag, & end subroutine fill_nested_grid_3D -!!$ subroutine nested_grid_BC_mpp_2d(var_nest, nest_domain, ind, wt, istag, jstag, & -!!$ npx, npy, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in) -!!$ -!!$ type(fv_grid_bounds_type), intent(IN) :: bd -!!$ real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag), intent(INOUT) :: var_nest -!!$ real, dimension(isg:ieg+istag,jsg:jeg+jstag), intent(IN) :: var_coarse -!!$ type(nest_domain_type), intent(INOUT) :: nest_domain -!!$ integer, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,2), intent(IN) :: ind -!!$ real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,4), intent(IN) :: wt -!!$ integer, intent(IN) :: istag, jstag, npx, npy, isg, ieg, jsg, jeg -!!$ integer, intent(IN), OPTIONAL :: nstep_in, nsplit_in -!!$ logical, intent(IN), OPTIONAL :: proc_in -!!$ -!!$ real, dimension(bd%isd:bd%ied+istag,bd%jsd:bd%jed+jstag,1) :: var_nest_3d -!!$ -!!$ integer :: i,j -!!$ -!!$ do j=bd%jsd,bd%jed+jstag -!!$ do i=bd%isd,bd%ied+istag -!!$ var_nest_3d(i,j,1) = var_nest(i,j) -!!$ enddo -!!$ enddo -!!$ -!!$ call nested_grid_BC_mpp_3d(var_nest_3d, nest_domain, ind, wt, istag, jstag, & -!!$ npx, npy, 1, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in) -!!$ -!!$ -!!$ end subroutine nested_grid_BC_mpp_2d - subroutine nested_grid_BC_mpp_3d(var_nest, var_coarse, nest_domain, ind, wt, istag, jstag, & npx, npy, npz, bd, isg, ieg, jsg, jeg, nest_level, nstep_in, nsplit_in, proc_in) @@ -1717,11 +1688,6 @@ subroutine nested_grid_BC_recv_scalar(nest_domain, istag, jstag, npz, & integer :: position -!!$ integer :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c -!!$ integer :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c -!!$ integer :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c -!!$ integer :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c - integer :: i,j, k if (istag == 1 .and. jstag == 1) then @@ -2543,7 +2509,7 @@ end subroutine fill_var_coarse subroutine update_coarse_grid_mpp_vector(u_coarse, v_coarse, u_nest, v_nest, nest_domain, dx, dy, area, & bd, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, & - isu, ieu, jsu, jeu, npx, npy, npz, istag_u, jstag_u, istag_v, jstag_v, & + isu, ieu, jsu, jeu, jeu_stag, iev_stag, npx, npy, npz, istag_u, jstag_u, istag_v, jstag_v, & r, nestupdate, upoff, nsponge, & parent_proc, child_proc, parent_grid, nest_level, flags, gridtype) @@ -2553,7 +2519,7 @@ subroutine update_coarse_grid_mpp_vector(u_coarse, v_coarse, u_nest, v_nest, nes type(fv_grid_bounds_type), intent(IN) :: bd integer, intent(IN) :: isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n - integer, intent(IN) :: isu, ieu, jsu, jeu + integer, intent(IN) :: isu, ieu, jsu, jeu, jeu_stag, iev_stag integer, intent(IN) :: istag_u, jstag_u, istag_v, jstag_v integer, intent(IN) :: npx, npy, npz, r, nestupdate, upoff, nsponge real, intent(IN) :: u_nest(is_n:ie_n+istag_u,js_n:je_n+jstag_u,npz) @@ -2614,13 +2580,14 @@ subroutine update_coarse_grid_mpp_vector(u_coarse, v_coarse, u_nest, v_nest, nes s = r/2 !rounds down (since r > 0) qr = r*upoff + nsponge - s - if (parent_proc .and. .not. (ieu < isu .or. jeu < jsu)) then + if (parent_proc .and. .not. (ieu < isu .or. jeu_stag < jsu)) then call fill_var_coarse(u_coarse, coarse_dat_recv_u, isd_p, ied_p, jsd_p, jed_p, & - isu, ieu, jsu, jeu, npx, npy, npz, istag_u, jstag_u, nestupdate, parent_grid) + isu, ieu, jsu, jeu_stag, npx, npy, npz, istag_u, jstag_u, nestupdate, parent_grid) endif - if (parent_proc .and. .not. (ieu < isu .or. jeu < jsu)) then + + if (parent_proc .and. .not. (iev_stag < isu .or. jeu < jsu)) then call fill_var_coarse(v_coarse, coarse_dat_recv_v, isd_p, ied_p, jsd_p, jed_p, & - isu, ieu, jsu, jeu, npx, npy, npz, istag_v, jstag_v, nestupdate, parent_grid) + isu, iev_stag, jsu, jeu, npx, npy, npz, istag_v, jstag_v, nestupdate, parent_grid) endif if (allocated(coarse_dat_recv_u)) deallocate(coarse_dat_recv_u) diff --git a/model/fv_arrays.F90 b/model/fv_arrays.F90 index 1e6d66c60..04301f231 100644 --- a/model/fv_arrays.F90 +++ b/model/fv_arrays.F90 @@ -878,6 +878,11 @@ module fv_arrays_mod integer :: bc_update_interval = 3 !< Default setting for interval (hours) between external regional BC data files. + integer :: nrows_blend = 0 !< # of blending rows in the outer integration domain. + logical :: write_restart_with_bcs = .false. !< Default setting for using DA-updated BC files + logical :: regional_bcs_from_gsi = .false. !< Default setting for writing restart files with boundary rows + + !>Convenience pointers integer, pointer :: grid_number @@ -959,8 +964,12 @@ module fv_arrays_mod integer :: npx_global integer :: upoff = 1 !< currently the same for all variables integer :: isu = -999, ieu = -1000, jsu = -999, jeu = -1000 !< limits of update regions on coarse grid + integer :: jeu_stag = -1000, iev_stag = -1000 !< limits of update regions on coarse grid for staggered variables in j,i + integer :: jeu_stag_boundary = -1000, iev_stag_boundary = -1000 !< BC location + real :: update_blend = 1. !< option for controlling how much "blending" is done during two-way update logical, allocatable :: do_remap_BC(:) + logical, allocatable :: do_remap_BC_level(:) !nest_domain now a global structure defined in fv_mp_mod !type(nest_domain_type) :: nest_domain !Structure holding link from this grid to its parent @@ -1318,7 +1327,7 @@ module fv_arrays_mod !>@details It includes an option to define dummy grids that have scalar and !! small arrays defined as null 3D arrays. subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie_in, js_in, je_in, & - npx_in, npy_in, npz_in, ndims_in, ncnst_in, nq_in, dummy, alloc_2d, ngrids_in) + npx_in, npy_in, npz_in, ndims_in, ntiles_in, ncnst_in, nq_in, dummy, alloc_2d, ngrids_in) !WARNING: Before calling this routine, be sure to have set up the ! proper domain parameters from the namelists (as is done in @@ -1327,7 +1336,7 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie implicit none type(fv_atmos_type), intent(INOUT), target :: Atm integer, intent(IN) :: isd_in, ied_in, jsd_in, jed_in, is_in, ie_in, js_in, je_in - integer, intent(IN) :: npx_in, npy_in, npz_in, ndims_in, ncnst_in, nq_in + integer, intent(IN) :: npx_in, npy_in, npz_in, ndims_in, ntiles_in, ncnst_in, nq_in logical, intent(IN) :: dummy, alloc_2d integer, intent(IN) :: ngrids_in integer:: isd, ied, jsd, jed, is, ie, js, je @@ -1404,22 +1413,6 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie nq_2d= 1 endif -!This should be set up in fv_mp_mod -!!$ Atm%bd%isd = isd_in -!!$ Atm%bd%ied = ied_in -!!$ Atm%bd%jsd = jsd_in -!!$ Atm%bd%jed = jed_in -!!$ -!!$ Atm%bd%is = is_in -!!$ Atm%bd%ie = ie_in -!!$ Atm%bd%js = js_in -!!$ Atm%bd%je = je_in -!!$ -!!$ Atm%bd%isc = Atm%bd%is -!!$ Atm%bd%iec = Atm%bd%ie -!!$ Atm%bd%jsc = Atm%bd%js -!!$ Atm%bd%jec = Atm%bd%je - !Convenience pointers Atm%npx => Atm%flagstruct%npx Atm%npy => Atm%flagstruct%npy @@ -1428,9 +1421,6 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie Atm%ng => Atm%bd%ng -!!$ Atm%npx = npx_in -!!$ Atm%npy = npy_in -!!$ Atm%npz = npz_in Atm%flagstruct%ndims = ndims_in allocate ( Atm%u(isd:ied ,jsd:jed+1,npz) ) @@ -1754,11 +1744,14 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie if( ngrids_in > 1 ) then if (Atm%flagstruct%grid_type < 4) then if (Atm%neststruct%nested) then - allocate(Atm%grid_global(1-Atm%ng:npx_2d +Atm%ng,1-Atm%ng:npy_2d +Atm%ng,2,1)) + allocate(Atm%grid_global(1-Atm%ng:npx_2d +Atm%ng,1-Atm%ng:npy_2d +Atm%ng,2,ntiles_in)) else - allocate(Atm%grid_global(1-Atm%ng:npx_2d +Atm%ng,1-Atm%ng:npy_2d +Atm%ng,2,1:6)) + allocate(Atm%grid_global(1-Atm%ng:npx_2d +Atm%ng,1-Atm%ng:npy_2d +Atm%ng,2,1:ntiles_in)) endif end if + if (Atm%flagstruct%grid_type == 4) then + allocate(Atm%grid_global(1-Atm%ng:npx_2d +Atm%ng,1-Atm%ng:npy_2d +Atm%ng,2,ntiles_in)) + endif endif diff --git a/model/fv_cmp.F90 b/model/fv_cmp.F90 index a6570f718..ddfec99f7 100644 --- a/model/fv_cmp.F90 +++ b/model/fv_cmp.F90 @@ -37,7 +37,7 @@ module fv_cmp_mod private - public fv_sat_adj, qs_init + public fv_sat_adj, qs_init, c_ice, c_liq ! real, parameter :: cp_air = cp_air ! 1004.6, heat capacity of dry air at constant pressure, come from constants_mod real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0, heat capacity of water vapor at constant pressure diff --git a/model/fv_control.F90 b/model/fv_control.F90 index 1ef83618c..2c44ff369 100644 --- a/model/fv_control.F90 +++ b/model/fv_control.F90 @@ -563,7 +563,7 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) Atm(n)%bd%isc, Atm(n)%bd%iec, & Atm(n)%bd%jsc, Atm(n)%bd%jec, & Atm(n)%flagstruct%npx, Atm(n)%flagstruct%npy, Atm(n)%flagstruct%npz, & - Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ncnst, Atm(n)%flagstruct%ncnst-Atm(n)%flagstruct%pnats, & + Atm(n)%flagstruct%ndims, Atm(n)%flagstruct%ntiles, Atm(n)%flagstruct%ncnst, Atm(n)%flagstruct%ncnst-Atm(n)%flagstruct%pnats, & n/=this_grid, n==this_grid, ngrids) !TODO don't need both of the last arguments enddo if ( (Atm(this_grid)%bd%iec-Atm(this_grid)%bd%isc+1).lt.4 .or. (Atm(this_grid)%bd%jec-Atm(this_grid)%bd%jsc+1).lt.4 ) then @@ -594,7 +594,9 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) do n=1,ngrids Atm(this_grid)%neststruct%child_grids(n) = (grid_coarse(n) == this_grid) allocate(Atm(n)%neststruct%do_remap_bc(ngrids)) + allocate(Atm(n)%neststruct%do_remap_bc_level(Atm(n)%neststruct%num_nest_level)) Atm(n)%neststruct%do_remap_bc(:) = .false. + Atm(n)%neststruct%do_remap_bc_level(:) = .false. enddo Atm(this_grid)%neststruct%parent_proc = ANY(Atm(this_grid)%neststruct%child_grids) !ANY(tile_coarse == Atm(this_grid)%global_tile) Atm(this_grid)%neststruct%child_proc = ASSOCIATED(Atm(this_grid)%parent_grid) !this means a nested grid @@ -641,30 +643,8 @@ subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe, p_split) write(*,*) ' ' endif - -!!$ Atm(this_grid)%ts = 300. -!!$ Atm(this_grid)%phis = too_big -!!$ ! The following statements are to prevent the phantom corner regions from -!!$ ! growing instability -!!$ Atm(this_grid)%u = 0. -!!$ Atm(this_grid)%v = 0. -!!$ Atm(this_grid)%ua = too_big -!!$ Atm(this_grid)%va = too_big -!!$ -!!$ Atm(this_grid)%inline_mp%prer = too_big -!!$ Atm(this_grid)%inline_mp%prei = too_big -!!$ Atm(this_grid)%inline_mp%pres = too_big -!!$ Atm(this_grid)%inline_mp%preg = too_big - !Initialize restart call fv_restart_init() -! if ( reset_eta ) then -! do n=1, ntilesMe -! call set_eta(npz, Atm(this_grid)%ks, ptop, Atm(this_grid)%ak, Atm(this_grid)%bk, Atm(this_grid)%flagstruct%npz_type) -! enddo -! if(is_master()) write(*,*) "Hybrid sigma-p coordinate has been reset" -! endif - contains @@ -886,7 +866,7 @@ subroutine read_namelist_fv_grid_nml ! Read Main namelist read (input_nml_file,fv_grid_nml,iostat=ios) ierr = check_nml_error(ios,'fv_grid_nml') - + call write_version_number ( 'FV_CONTROL_MOD', version ) unit = stdlog() write(unit, nml=fv_grid_nml) @@ -947,7 +927,7 @@ subroutine read_namelist_fv_core_nml(Atm) ierr = check_nml_error(ios,'fv_core_nml') ! Reset input_file_nml to default behavior (CHECK do we still need this???) !call read_input_nml - + call write_version_number ( 'FV_CONTROL_MOD', version ) unit = stdlog() write(unit, nml=fv_core_nml) @@ -1058,9 +1038,11 @@ end subroutine read_namelist_fv_core_nml subroutine setup_update_regions - integer :: isu, ieu, jsu, jeu ! update regions + integer :: isu, ieu, jsu, jeu ! update regions for centered variables integer :: isc, jsc, iec, jec integer :: upoff + integer :: isu_stag, jsu_stag, ieu_stag, jeu_stag ! update regions for u + integer :: isv_stag, jsv_stag, iev_stag, jev_stag ! update regions for v isc = Atm(this_grid)%bd%isc jsc = Atm(this_grid)%bd%jsc @@ -1078,19 +1060,65 @@ subroutine setup_update_regions jsu = nest_joffsets(n) jeu = jsu + jcount_coarse(n) - 1 + isu_stag = isu + jsu_stag = jsu + ieu_stag = ieu + jeu_stag = jeu+1 + + isv_stag = isu + jsv_stag = jsu + iev_stag = ieu+1 + jev_stag = jeu + !update offset adjustment isu = isu + upoff ieu = ieu - upoff jsu = jsu + upoff jeu = jeu - upoff - !restriction to current domain -!!$ !!! DEBUG CODE -!!$ if (Atm(this_grid)%flagstruct%fv_debug) then -!!$ write(*,'(I, A, 4I)') mpp_pe(), 'SETUP_UPDATE_REGIONS : ', isu, jsu, ieu, jeu -!!$ write(*,'(I, A, 4I)') mpp_pe(), 'SETUP_UPDATE_REGIONS 2: ', isc, jsc, iec, jsc -!!$ endif -!!$ !!! END DEBUG CODE + isu_stag = isu_stag + upoff + ieu_stag = ieu_stag - upoff + jsu_stag = jsu_stag + upoff + jeu_stag = jeu_stag - upoff + + isv_stag = isv_stag + upoff + iev_stag = iev_stag - upoff + jsv_stag = jsv_stag + upoff + jev_stag = jev_stag - upoff + +! Absolute boundary for the staggered point update region on the parent. +! This is used in remap_uv to control the update of the last staggered point +! when the the update region coincides with a pe domain to avoid cross-restart repro issues + + Atm(n)%neststruct%jeu_stag_boundary = jeu_stag + Atm(n)%neststruct%iev_stag_boundary = iev_stag + + if (isu > iec .or. ieu < isc .or. & + jsu > jec .or. jeu < jsc ) then + isu = -999 ; jsu = -999 ; ieu = -1000 ; jeu = -1000 + else + isu = max(isu,isc) ; jsu = max(jsu,jsc) + ieu = min(ieu,iec) ; jeu = min(jeu,jec) + endif + +! Update region for staggered quantity to avoid cross repro issues when the pe domain boundary +! coincide with the nest. Basically write the staggered update on compute domains + + if (isu_stag > iec .or. ieu_stag < isc .or. & + jsu_stag > jec .or. jeu_stag < jsc ) then + isu_stag = -999 ; jsu_stag = -999 ; ieu_stag = -1000 ; jeu_stag = -1000 + else + isu_stag = max(isu_stag,isc) ; jsu_stag = max(jsu_stag,jsc) + ieu_stag = min(ieu_stag,iec) ; jeu_stag = min(jeu_stag,jec) + endif + + if (isv_stag > iec .or. iev_stag < isc .or. & + jsv_stag > jec .or. jev_stag < jsc ) then + isv_stag = -999 ; jsv_stag = -999 ; iev_stag = -1000 ; jev_stag = -1000 + else + isv_stag = max(isv_stag,isc) ; jsv_stag = max(jsv_stag,jsc) + iev_stag = min(iev_stag,iec) ; jev_stag = min(jev_stag,jec) + endif if (isu > iec .or. ieu < isc .or. & jsu > jec .or. jeu < jsc ) then isu = -999 ; jsu = -999 ; ieu = -1000 ; jeu = -1000 @@ -1098,15 +1126,23 @@ subroutine setup_update_regions isu = max(isu,isc) ; jsu = max(jsu,jsc) ieu = min(ieu,iec) ; jeu = min(jeu,jec) endif -!!$ !!! DEBUG CODE -!!$ if (Atm(this_grid)%flagstruct%fv_debug) & -!!$ write(*,'(I, A, 4I)') mpp_pe(), 'SETUP_UPDATE_REGIONS 3: ', isu, jsu, ieu, jeu -!!$ !!! END DEBUG CODE + + ! lump indices + isu=max(isu, isu_stag, isv_stag) + jsu=max(jsu, jsu_stag, jsv_stag) + jeu_stag=max(jeu, jeu_stag) + jev_stag=max(jeu, jev_stag) + ieu_stag=max(ieu ,ieu_stag) + iev_stag=max(ieu ,iev_stag) Atm(n)%neststruct%isu = isu - Atm(n)%neststruct%ieu = ieu + Atm(n)%neststruct%ieu = ieu_stag Atm(n)%neststruct%jsu = jsu - Atm(n)%neststruct%jeu = jeu + Atm(n)%neststruct%jeu = jev_stag + + Atm(n)%neststruct%jeu_stag = jeu_stag + Atm(n)%neststruct%iev_stag = iev_stag + endif enddo diff --git a/model/fv_dynamics.F90 b/model/fv_dynamics.F90 index 2a502e117..8a36a96d7 100644 --- a/model/fv_dynamics.F90 +++ b/model/fv_dynamics.F90 @@ -227,7 +227,14 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, reg_bc_update_time=current_time_in_seconds call set_regional_BCs & !<-- Insert values into the boundary region valid for the start of this large timestep. - (delp,delz,w,pt,q_con,cappa,q,u,v,uc,vc, bd, npz, ncnst, reg_bc_update_time ) + (delp,delz,w,pt & +#ifdef USE_COND + ,q_con & +#endif +#ifdef MOIST_CAPPA + ,cappa & +#endif + ,q,u,v,uc,vc, bd, npz, reg_bc_update_time ) call timing_off('Regional_BCs') endif diff --git a/model/fv_nesting.F90 b/model/fv_nesting.F90 index ae7ddf4a3..788e13fe9 100644 --- a/model/fv_nesting.F90 +++ b/model/fv_nesting.F90 @@ -219,7 +219,7 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & delz_buf, nnest) endif #endif - if (neststruct%do_remap_BC(flagstruct%grid_number)) then + if (neststruct%do_remap_BC_level(nest_level)) then call nested_grid_BC_recv(global_nest_domain, npz_coarse+1, bd, & pe_u_buf, pe_v_buf, nnest, gridtype=DGRID_NE) call nested_grid_BC_recv(global_nest_domain, 1, 1, npz_coarse+1, bd, & @@ -251,7 +251,7 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & endif #endif - if (any(neststruct%do_remap_BC)) then + if (neststruct%do_remap_BC_level(nest_level)) then !Compute and send staggered pressure !u points @@ -358,13 +358,6 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & neststruct%delp_BC, delp_buf, pd_in=do_pd) endif -!!$ do n=1,ncnst -!!$ call nested_grid_BC_save_proc(global_nest_domain, & -!!$ neststruct%ind_h, neststruct%wt_h, 0, 0, npx, npy, npz_coarse, bd, & -!!$ lag_BC, q_buf(n), pd_in=do_pd) -!!$ !This remapping appears to have some trouble with rounding error random noise -!!$ call remap_BC(pe_lag_BC, pe_eul_BC, lag_BC, neststruct%q_BC(n), npx, npy, npz, npz_coarse, bd, 0, 0, 0, flagstruct%kord_tr, 'q') -!!$ enddo #ifndef SW_DYNAMICS if (neststruct%do_remap_BC(flagstruct%grid_number)) then @@ -535,10 +528,6 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & call nested_grid_BC_apply_intT(w, & 0, 0, npx, npy, npz, bd, 1., 1., & neststruct%w_BC, bctype=neststruct%nestbctype ) - !Removed halo from delz --- BCs now directly applied in nh_BC --- lmh june 2018 -!!$ call nested_grid_BC_apply_intT(delz, & -!!$ 0, 0, npx, npy, npz, bd, 1., 1., & -!!$ neststruct%delz_BC, bctype=neststruct%nestbctype ) endif #ifdef USE_COND call nested_grid_BC_apply_intT(q_con, & @@ -563,11 +552,6 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & call nested_grid_BC_apply_intT(uc, & 1, 0, npx, npy, npz, bd, 1., 1., & neststruct%uc_BC, bctype=neststruct%nestbctype ) - !!!NOTE: Divg not available here but not needed - !!! until dyn_core anyway. -!!$ call nested_grid_BC_apply_intT(divg, & -!!$ 1, 1, npx, npy, npz, bd, 1., 1., & -!!$ neststruct%divg_BC, bctype=neststruct%nestbctype ) !Update domains needed for Rayleigh damping if (.not. flagstruct%hydrostatic) call mpp_update_domains(w, domain) @@ -584,16 +568,6 @@ subroutine setup_nested_grid_BCs(npx, npy, npz, zvir, ncnst, & flagstruct%make_nh= .false. endif - !Unnecessary? -!!$ if ( neststruct%nested .and. .not. neststruct%divg_BC%initialized) then -!!$ neststruct%divg_BC%east_t0 = neststruct%divg_BC%east_t1 -!!$ neststruct%divg_BC%west_t0 = neststruct%divg_BC%west_t1 -!!$ neststruct%divg_BC%north_t0 = neststruct%divg_BC%north_t1 -!!$ neststruct%divg_BC%south_t0 = neststruct%divg_BC%south_t1 -!!$ neststruct%divg_BC%initialized = .true. -!!$ endif - - call mpp_sync_self end subroutine setup_nested_grid_BCs @@ -629,7 +603,7 @@ subroutine set_physics_BCs(ps, u_dt, v_dt, flagstruct, gridstruct, neststruct, n do nest_level=1,neststruct%num_nest_level if (gridstruct%nested .AND. neststruct%nlevel==nest_level) then - if (neststruct%do_remap_BC(flagstruct%grid_number)) then + if (neststruct%do_remap_BC_level(nest_level)) then npz_coarse = neststruct%parent_grid%npz @@ -640,21 +614,24 @@ subroutine set_physics_BCs(ps, u_dt, v_dt, flagstruct, gridstruct, neststruct, n npx, npy, bd, 1, npx-1, 1, npy-1) call nested_grid_BC_recv(global_nest_domain, npz_coarse, bd, u_dt_buf, v_dt_buf, nnest, gridtype=AGRID) - call allocate_fv_nest_BC_type(pe_src_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse+1,ng,0,0,0,.false.) - call allocate_fv_nest_BC_type(pe_dst_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1,ng,0,0,0,.false.) + if (neststruct%do_remap_BC(flagstruct%grid_number)) then - call copy_ps_BC(ps, pe_src_BC, npx, npy, npz_coarse, 0, 0, bd) - call setup_eul_pe_BC(pe_src_BC, pe_dst_BC, ak, bk, npx, npy, npz, npz_coarse, 0, 0, bd, & - make_src_in=.true., ak_src=neststruct%parent_grid%ak, bk_src=neststruct%parent_grid%bk) + call allocate_fv_nest_BC_type(pe_src_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz_coarse+1,ng,0,0,0,.false.) + call allocate_fv_nest_BC_type(pe_dst_BC, is,ie,js,je,isd,ied,jsd,jed,npx,npy,npz+1,ng,0,0,0,.false.) - !Note that iv=-1 is used for remapping winds, which sets the lower reconstructed values to 0 if - ! there is a 2dx signal. Is this the best for **tendencies** though?? Probably not---so iv=1 here - call set_BC_direct( pe_src_BC, pe_dst_BC, u_dt_buf, u_dt, neststruct, npx, npy, npz, npz_coarse, ng, bd, 0, 0, 1, flagstruct%kord_mt) - call set_BC_direct( pe_src_BC, pe_dst_BC, v_dt_buf, v_dt, neststruct, npx, npy, npz, npz_coarse, ng, bd, 0, 0, 1, flagstruct%kord_mt) + call copy_ps_BC(ps, pe_src_BC, npx, npy, npz_coarse, 0, 0, bd) + call setup_eul_pe_BC(pe_src_BC, pe_dst_BC, ak, bk, npx, npy, npz, npz_coarse, 0, 0, bd, & + make_src_in=.true., ak_src=neststruct%parent_grid%ak, bk_src=neststruct%parent_grid%bk) - call deallocate_fv_nest_BC_type(pe_src_BC) - call deallocate_fv_nest_BC_type(pe_dst_BC) + !Note that iv=-1 is used for remapping winds, which sets the lower reconstructed values to 0 if + ! there is a 2dx signal. Is this the best for **tendencies** though?? Probably not---so iv=1 here + call set_BC_direct( pe_src_BC, pe_dst_BC, u_dt_buf, u_dt, neststruct, npx, npy, npz, npz_coarse, ng, bd, 0, 0, 1, flagstruct%kord_mt) + call set_BC_direct( pe_src_BC, pe_dst_BC, v_dt_buf, v_dt, neststruct, npx, npy, npz, npz_coarse, ng, bd, 0, 0, 1, flagstruct%kord_mt) + call deallocate_fv_nest_BC_type(pe_src_BC) + call deallocate_fv_nest_BC_type(pe_dst_BC) + + endif else call nested_grid_BC(u_dt, v_dt, dum, dum, global_nest_domain, neststruct%ind_h, neststruct%ind_h, & neststruct%wt_h, neststruct%wt_h, 0, 0, 0, 0, npx, npy, npz, bd, 1, npx-1, 1, npy-1, nnest, gridtype=AGRID) @@ -663,7 +640,7 @@ subroutine set_physics_BCs(ps, u_dt, v_dt, flagstruct, gridstruct, neststruct, n endif if (ANY (neststruct%child_grids) .AND. neststruct%nlevel==nest_level-1) then - if (any(neststruct%do_remap_BC)) & + if (neststruct%do_remap_BC_level(nest_level)) & call nested_grid_BC(ps, global_nest_domain, 0, 0, nnest+1) call nested_grid_BC_send(u_dt, v_dt, global_nest_domain, nnest+1, gridtype=AGRID) endif @@ -891,23 +868,6 @@ subroutine setup_eul_delp_BC_k(delplagBC, delpeulBC, pelagBC, peeulBC, ptop_src, enddo enddo -!!$!!! DEBUG CODE -!!$ !If more than a few percent difference then log the error -!!$ do k=1,npz -!!$ do j=jstart,jend -!!$ do i=istart,iend -!!$ if (delpeulBC(i,j,k) <= 0.) then -!!$ write(errstring,'(3I5, 3(2x, G))'), i, j, k, pelagBC(i,j,k), peeulBC(i,j,k) -!!$ call mpp_error(WARNING, ' Invalid pressure BC at '//errstring) -!!$ else if (abs( peeulBC(i,j,k) - pelagBC(i,j,k)) > 100.0 ) then -!!$ write(errstring,'(3I5, 3(2x, G))'), i, j, k, pelagBC(i,j,k), peeulBC(i,j,k) -!!$ call mpp_error(WARNING, ' Remap BC: pressure deviation at '//errstring) -!!$ endif -!!$ enddo -!!$ enddo -!!$ enddo -!!$!!! END DEBUG CODE - end subroutine setup_eul_delp_BC_k subroutine copy_ps_BC(ps, pe_BC, npx, npy, npz, istag, jstag, bd) @@ -1212,24 +1172,12 @@ subroutine remap_BC_k(pe_lagBC, pe_eulBC, var_lagBC, var_eulBC, isd_BC, ied_BC, do k=1,npz_coarse+1 do i=istart,iend -!!$!!! DEBUG CODE -!!$ if (pe_lagBC(i,j,k) <= 0.) then -!!$ write(errstring,'(3I5, 2x, G)'), i, j, k, pe_lagBC(i,j,k) -!!$ call mpp_error(WARNING, ' Remap BC: invalid pressure at at '//errstring) -!!$ endif -!!$!!! END DEBUG CODE peln_lag(i,k) = log(pe_lagBC(i,j,k)) enddo enddo do k=1,npz+1 do i=istart,iend -!!$!!! DEBUG CODE -!!$ if (pe_lagBC(i,j,k) <= 0.) then -!!$ write(errstring,'(3I5, 2x, G)'), i, j, k, pe_lagBC(i,j,k) -!!$ call mpp_error(WARNING, ' Remap BC: invalid pressure at at '//errstring) -!!$ endif -!!$!!! END DEBUG CODE peln_eul(i,k) = log(pe_eulBC(i,j,k)) enddo enddo @@ -1331,12 +1279,6 @@ subroutine compute_specific_volume_BC_k(delpBC, delzBC, isd_BC, ied_BC, istart, do j=jstart,jend do i=istart,iend delzBC(i,j,k) = -delzBC(i,j,k)/delpBC(i,j,k) -!!$!!! DEBUG CODE -!!$ if (delzBC(i,j,k) <= 0. ) then -!!$ write(errstring,'(3I5, 2(2x, G))'), i, j, k, delzBC(i,j,k), delpBC(i,j,k) -!!$ call mpp_error(WARNING, ' Remap BC (sfc volume): invalid delz at '//errstring) -!!$ endif -!!$!!! END DEBUG CODE end do end do end do @@ -1357,12 +1299,6 @@ subroutine compute_delz_BC_k(delpBC, delzBC, isd_BC, ied_BC, istart, iend, jstar do j=jstart,jend do i=istart,iend delzBC(i,j,k) = -delzBC(i,j,k)*delpBC(i,j,k) -!!$!!! DEBUG CODE -!!$ if (delzBC(i,j,k) >=0. ) then -!!$ write(errstring,'(3I5, 2(2x, G))'), i, j, k, delzBC(i,j,k), delpBC(i,j,k) -!!$ call mpp_error(WARNING, ' Remap BC (compute delz): invalid delz at '//errstring) -!!$ endif -!!$!!! END DEBUG CODE end do end do end do @@ -1654,10 +1590,6 @@ subroutine setup_pt_NH_BC_k(ptBC,sphumBC,delpBC,delzBC, & rdg = -rdgas / grav cv_air = cp_air - rdgas -!!$!!! DEBUG CODE -!!$ write(*, '(A, 7I5)') 'setup_pt_NH_BC_k', mpp_pe(), isd, ied, istart, iend, lbound(ptBC,1), ubound(ptBC,1) -!!$!!! END DEBUG CODE - !$OMP parallel do default(none) shared(istart,iend,jstart,jend,npz,zvir,ptBC,sphumBC,delpBC,delzBC,liq_watBC,rainwatBC,ice_watBC,snowwatBC,graupelBC, & #ifdef USE_COND !$OMP q_conBC, & @@ -2259,14 +2191,14 @@ subroutine twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir, Time, this_grid) Atm(n)%pt, Atm(n)%delp, Atm(n)%q, & Atm(n)%pe, Atm(n)%pkz, Atm(n)%delz, Atm(n)%ps, Atm(n)%ptop, Atm(n)%ak, Atm(n)%bk, & Atm(n)%gridstruct, Atm(n)%flagstruct, Atm(n)%neststruct, Atm(n)%domain, & - Atm(n)%parent_grid, Atm(n)%bd, atm(n)%neststruct%nlevel, .false.) + Atm(n)%parent_grid, Atm(n)%bd, .false.) elseif (n==this_grid .or. Atm(this_grid)%neststruct%nlevel==Atm(n)%neststruct%nlevel) then call twoway_nest_update(Atm(this_grid)%npx, Atm(this_grid)%npy, Atm(this_grid)%npz, zvir, & Atm(this_grid)%ncnst, sphum, Atm(this_grid)%u, Atm(this_grid)%v, Atm(this_grid)%w, & Atm(this_grid)%pt, Atm(this_grid)%delp, Atm(this_grid)%q, & Atm(this_grid)%pe, Atm(this_grid)%pkz, Atm(this_grid)%delz, Atm(this_grid)%ps, Atm(this_grid)%ptop, Atm(this_grid)%ak, Atm(this_grid)%bk, & Atm(this_grid)%gridstruct, Atm(this_grid)%flagstruct, Atm(this_grid)%neststruct, Atm(this_grid)%domain, & - Atm(this_grid)%parent_grid, Atm(this_grid)%bd, atm(this_grid)%neststruct%nlevel, .false.) + Atm(this_grid)%parent_grid, Atm(this_grid)%bd, .false.) endif endif @@ -2299,12 +2231,12 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & u, v, w, pt, delp, q, & pe, pkz, delz, ps, ptop, ak, bk, & gridstruct, flagstruct, neststruct, & - domain, parent_grid, bd, grid_number, conv_theta_in) + domain, parent_grid, bd, conv_theta_in) real, intent(IN) :: zvir, ptop, ak(npz+1), bk(npz+1) integer, intent(IN) :: npx, npy, npz - integer, intent(IN) :: ncnst, sphum, grid_number + integer, intent(IN) :: ncnst, sphum logical, intent(IN), OPTIONAL :: conv_theta_in type(fv_grid_bounds_type), intent(IN) :: bd @@ -2413,123 +2345,6 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & !!! RENORMALIZATION UPDATE OPTION if (neststruct%nestupdate /= 3 .and. neststruct%nestupdate /= 7 .and. neststruct%nestupdate /= 8) then -!!$ allocate(qdp_coarse(isd_p:ied_p,jsd_p:jed_p,npz)) -!!$ if (parent_grid%flagstruct%nwat > 0) then -!!$ allocate(q_diff(isd_p:ied_p,jsd_p:jed_p,npz)) -!!$ q_diff = 0. -!!$ endif -!!$ -!!$ do n=1,parent_grid%flagstruct%nwat -!!$ -!!$ qdp_coarse = 0. -!!$ if (neststruct%child_proc) then -!!$ do k=1,npz -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ qdp(i,j,k) = q(i,j,k,n)*delp(i,j,k) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ else -!!$ qdp = 0. -!!$ endif -!!$ -!!$ if (parent_grid%neststruct%parent_proc) then -!!$ !Add up ONLY region being replaced by nested grid -!!$ do k=1,npz -!!$ do j=jsu,jeu -!!$ do i=isu,ieu -!!$ qdp_coarse(i,j,k) = parent_grid%q(i,j,k,n)*parent_grid%delp(i,j,k) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ call level_sum(qdp_coarse, parent_grid%gridstruct%area, parent_grid%domain, & -!!$ parent_grid%bd, npz, L_sum_b) -!!$ else -!!$ qdp_coarse = 0. -!!$ endif -!!$ if (parent_grid%neststruct%parent_proc) then -!!$ if (n <= parent_grid%flagstruct%nwat) then -!!$ do k=1,npz -!!$ do j=jsu,jeu -!!$ do i=isu,ieu -!!$ q_diff(i,j,k) = q_diff(i,j,k) - qdp_coarse(i,j,k) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ endif -!!$ endif -!!$ -!!$ call mpp_update_domains(qdp, domain) -!!$ call update_coarse_grid(var_src, qdp, global_nest_domain, & -!!$ gridstruct%dx, gridstruct%dy, gridstruct%area, & -!!$ bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & -!!$ neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & -!!$ npx, npy, npz, 0, 0, & -!!$ neststruct%refinement, neststruct%nestupdate, upoff, 0, & -!!$ parent_grid%neststruct%parent_proc, neststruct%child_proc, parent_grid) -!!$ if (parent_grid%neststruct%parent_proc) call remap_up_k(ps0, parent_grid%ps, & -!!$ ak, bk, parent_grid%ak, parent_grid%bk, var_src, qdp_coarse, & -!!$ parent_grid%bd, neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & -!!$ 0, 0, npz, parent_grid%npz, 0, parent_grid%flagstruct%kord_tr, blend_wt, log_pe=.false.) -!!$ -!!$ call mpp_sync!self -!!$ -!!$ if (parent_grid%neststruct%parent_proc) then -!!$ call level_sum(qdp_coarse, parent_grid%gridstruct%area, parent_grid%domain, & -!!$ parent_grid%bd, npz, L_sum_a) -!!$ do k=1,npz -!!$ if (L_sum_a(k) > 0.) then -!!$ fix = L_sum_b(k)/L_sum_a(k) -!!$ do j=jsu,jeu -!!$ do i=isu,ieu -!!$ !Normalization mass fixer -!!$ parent_grid%q(i,j,k,n) = qdp_coarse(i,j,k)*fix -!!$ enddo -!!$ enddo -!!$ endif -!!$ enddo -!!$ if (n == 1) sphum_ll_fix = 1. - fix -!!$ endif -!!$ if (parent_grid%neststruct%parent_proc) then -!!$ if (n <= parent_grid%flagstruct%nwat) then -!!$ do k=1,npz -!!$ do j=jsu,jeu -!!$ do i=isu,ieu -!!$ q_diff(i,j,k) = q_diff(i,j,k) + parent_grid%q(i,j,k,n) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ endif -!!$ endif -!!$ -!!$ end do -!!$ -!!$ if (parent_grid%neststruct%parent_proc) then -!!$ if (parent_grid%flagstruct%nwat > 0) then -!!$ do k=1,npz -!!$ do j=jsu,jeu -!!$ do i=isu,ieu -!!$ parent_grid%delp(i,j,k) = parent_grid%delp(i,j,k) + q_diff(i,j,k) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ do n=1,parent_grid%flagstruct%nwat -!!$ do k=1,npz -!!$ do j=jsu,jeu -!!$ do i=isu,ieu -!!$ parent_grid%q(i,j,k,n) = parent_grid%q(i,j,k,n)/parent_grid%delp(i,j,k) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ deallocate(qdp_coarse) -!!$ if (allocated(q_diff)) deallocate(q_diff) - endif !!! END RENORMALIZATION UPDATE @@ -2609,9 +2424,6 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & !Updating for delz not yet implemented; ! may need to think very carefully how one would do this!!! ! consider updating specific volume instead? -!!$ call update_coarse_grid(parent_grid%delz, delz, global_nest_domain, & -!!$ bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, npz, 0, 0, & -!!$ neststruct%refinement, neststruct%nestupdate, upoff, 0, parent_grid%neststruct%parent_proc, neststruct%child_proc) end if @@ -2623,11 +2435,15 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & allocate(v_src(isd_p:ied_p+1,jsd_p:jed_p,npz)) u_src = -999. v_src = -999. + +!the domain setup by setup_region in fv_control include the staggered points, however +!0,1,1,0 is still needed for mpp_update_nest_coarse to work correctly between the parent and nest +!fill coarse only need the region deffined in fv_control call update_coarse_grid(u_src, v_src, u, v, global_nest_domain, & gridstruct%dx, gridstruct%dy, gridstruct%area, & bd, isd_p, ied_p, jsd_p, jed_p, isd, ied, jsd, jed, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & - npx, npy, npz, 0, 1, 1, 0, & + neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, neststruct%jeu_stag, neststruct%iev_stag,& + npx, npy, npz, 0, 1,1, 0, & neststruct%refinement, neststruct%nestupdate, upoff, 0, & parent_grid%neststruct%parent_proc, neststruct%child_proc, parent_grid, neststruct%nlevel, gridtype=DGRID_NE) @@ -2669,6 +2485,7 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & end do end do end do + call mpp_update_domains(ps, domain, complete=.true.) endif call update_coarse_grid(ps0, ps, global_nest_domain, & @@ -2709,15 +2526,6 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & end do end do end if -!!$!!!! DEBUG CODE -!!$ do k=1,parent_grid%npz -!!$ write(mpp_pe()+3000,*) 'k = ', k, parent_grid%ak(k), parent_grid%bk(k) -!!$ enddo -!!$ write(mpp_pe()+3000,*) -!!$ do k=1,npz -!!$ write(mpp_pe()+3000,*) 'k = ', k, ak(k), bk(k) -!!$ enddo -!!$!!!! END DEBUG CODE call update_remap_tqw(parent_grid%npz, parent_grid%ak, parent_grid%bk, & parent_grid%ps, & @@ -2742,12 +2550,13 @@ subroutine twoway_nest_update(npx, npy, npz, zvir, ncnst, sphum, & end do end if - call update_remap_uv(parent_grid%npz, parent_grid%ak, parent_grid%bk, & + call update_remap_uv(parent_grid%npz, parent_grid%ak, parent_grid%bk, & parent_grid%ps, parent_grid%u, parent_grid%v, & npz, ak, bk, ps0, u_src, v_src, & parent_grid%flagstruct%kord_mt, & isc_p, iec_p, jsc_p, jec_p, isd_p, ied_p, jsd_p, jed_p, parent_grid%ptop, & - neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, blend_wt) + neststruct%isu, neststruct%ieu, neststruct%jsu, neststruct%jeu, & + neststruct%jeu_stag, neststruct%iev_stag, neststruct%jeu_stag_boundary, neststruct%iev_stag_boundary, blend_wt) endif !parent_grid%neststruct%parent_proc @@ -2823,13 +2632,6 @@ subroutine remap_up_k(ps_src, ps_dst, ak_src, bk_src, ak_dst, bk_dst, var_src, v if (iend < istart) return if (jend < jstart) return -!!$!!!! DEBUG CODE -!!$ write(debug_unit,*) bd%isd,bd%ied,bd%jsd,bd%jed -!!$ write(debug_unit,*) istart,iend,jstart,jend,istag,jstag -!!$ write(debug_unit,*) -!!$!!! END DEBUG CODE - - !Compute Eulerian pressures !NOTE: assumes that istag + jstag <= 1 if (istag > 0) then @@ -3137,7 +2939,7 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, & kmd, ak_src, bk_src, ps_src, u_src, v_src, & kord_mt, & is, ie, js, je, isd, ied, jsd, jed, ptop, & - istart, iend, jstart, jend, blend_wt) + istart, iend, jstart, jend, jeu_stag,iev_stag,ju_end_boundary,iv_end_boundary, blend_wt) integer, intent(in):: npz real, intent(in):: ak_dst(npz+1), bk_dst(npz+1), blend_wt(npz) real, intent(in):: ps_dst(isd:ied,jsd:jed) @@ -3153,6 +2955,8 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, & real, intent(IN) :: ptop integer, intent(in) :: is, ie, js, je, isd, ied, jsd, jed integer, intent(IN) :: istart, iend, jstart, jend + integer, intent(IN) :: iev_stag, jeu_stag + integer, intent(IN) :: ju_end_boundary, iv_end_boundary ! ! local: real, dimension(is:ie+1,kmd+1):: pe0 @@ -3160,19 +2964,25 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, & real, dimension(is:ie+1,kmd):: qt real, dimension(is:ie+1,npz):: qn1 integer i,j,k + integer jend_u, iend_v real :: wt1, wt2 !This line to check if the update region is correctly defined or not is ! IMPORTANT. Sometimes one or the other pair of limits will give a ! non-empty loop, even though no data was transferred! - if (istart > iend .or. jstart > jend) return + + if (.not. (istart > iend .or. jstart > jeu_stag)) then + +!set the last index to not go past the stag boundary set in setup_update_regions +!to avoid cross-restart repro issue when the update region northern boundary coincides with a pe domain boundary + jend_u=min(jeu_stag, ju_end_boundary-1) !------ ! map u !------ -!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,npz,ak_src,bk_src,ps_src,u_src,v_src,ptop,kord_mt,istart,iend,jstart,jend,blend_wt) & +!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,npz,ak_src,bk_src,ps_src,u_src,v_src,ptop,kord_mt,istart,iend,jstart,jend_u,blend_wt) & !$OMP private(pe0,pe1,qt,qn1,wt1,wt2) - do j=jstart,jend+1 + do j=jstart,jend_u+1 !------ ! Data !------ @@ -3209,18 +3019,25 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, & enddo end do + endif + + if (.not. (istart > iev_stag .or. jstart > jend)) then + +!set the last index to not go past the stag boundary set in setup_update_regions +!to avoid cross-restart repro issue when the update region eastern boundary coincides with a pe domain boundary + iend_v=min(iev_stag, iv_end_boundary-1) !------ ! map v !------ -!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,ak_src,bk_src,ps_src,npz,u_src,v_src,ptop,istart,iend,jstart,jend,blend_wt) & +!$OMP parallel do default(none) shared(js,je,kmd,is,ie,ak_dst,bk_dst,ps_dst,u_dst,v_dst,ak_src,bk_src,ps_src,npz,u_src,v_src,ptop,istart,iend_v,jstart,jend,blend_wt) & !$OMP private(pe0,pe1,qt,qn1,wt1,wt2) do j=jstart,jend !------ ! Data !------ do k=1,kmd+1 - do i=istart,iend+1 + do i=istart,iend_v+1 pe0(i,k) = ak_src(k) + bk_src(k)*0.5*(ps_src(i,j)+ps_src(i-1,j)) enddo enddo @@ -3228,7 +3045,7 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, & ! Model !------ do k=1,npz+1 - do i=istart,iend+1 + do i=istart,iend_v+1 pe1(i,k) = ak_dst(k) + bk_dst(k)*0.5*(ps_dst(i,j)+ps_dst(i-1,j)) enddo enddo @@ -3237,21 +3054,21 @@ subroutine update_remap_uv(npz, ak_dst, bk_dst, ps_dst, u_dst, v_dst, & !------ qt = 0. do k=1,kmd - do i=istart,iend+1 + do i=istart,iend_v+1 qt(i,k) = v_src(i,j,k) enddo enddo qn1 = 0. - call mappm(kmd, pe0(istart:iend+1,:), qt(istart:iend+1,:), npz, pe1(istart:iend+1,:), qn1(istart:iend+1,:), istart,iend+1, -1, 8, ptop) + call mappm(kmd, pe0(istart:iend_v+1,:), qt(istart:iend_v+1,:), npz, pe1(istart:iend_v+1,:), qn1(istart:iend_v+1,:), istart,iend_v+1, -1, 8, ptop) do k=1,npz wt1 = blend_wt(k) wt2 = 1. - wt1 - do i=istart,iend+1 + do i=istart,iend_v+1 v_dst(i,j,k) = qn1(i,k)*wt1 + v_dst(i,j,k)*wt2 !Does this kill OMP??? enddo enddo end do - + endif end subroutine update_remap_uv diff --git a/model/fv_regional_bc.F90 b/model/fv_regional_bc.F90 index ea28ebe2a..6868a709b 100644 --- a/model/fv_regional_bc.F90 +++ b/model/fv_regional_bc.F90 @@ -21,6 +21,7 @@ module fv_regional_mod + use netcdf use mpp_domains_mod, only: domain2d use mpp_domains_mod, only: domain1D, mpp_get_domain_components, & mpp_get_global_domain, & @@ -33,13 +34,14 @@ 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 fms2_io_mod, only: open_file, close_file, register_axis, & register_variable_attribute, & register_global_attribute, read_data, & register_field, FmsNetcdfFile_t, & - FmsNetcdfDomainFile_t, write_data - use tracer_manager_mod,only: get_tracer_index + FmsNetcdfDomainFile_t, write_data, & + get_global_attribute, global_att_exists + use tracer_manager_mod,only: get_tracer_index,get_tracer_names use field_manager_mod, only: MODEL_ATMOS use time_manager_mod, only: get_time & ,operator(-),operator(/) & @@ -57,12 +59,16 @@ module fv_regional_mod use fv_grid_utils_mod, only: g_sum,mid_pt_sphere,get_unit_vect2 & ,get_latlon_vector,inner_prod & ,cell_center2 - use fv_mapz_mod, only: mappm, moist_cp, moist_cv, map_scalar + use fv_mapz_mod, only: mappm, moist_cp, moist_cv use fv_mp_mod, only: is_master, mp_reduce_min, mp_reduce_max use fv_fill_mod, only: fillz use fv_eta_mod, only: get_eta_level use fms_mod, only: check_nml_error use boundary_mod, only: fv_nest_BC_type_3D + use fv_cmp_mod, only: c_liq, c_ice + use sim_nc_mod, only: open_ncfile, close_ncfile, get_ncdim1 + + implicit none private @@ -77,17 +83,18 @@ module fv_regional_mod ,regional_bc_t1_to_t0 & ,regional_boundary_update & ,next_time_to_read_bcs & - ,set_regional_BCs & + ,set_regional_BCs & ,setup_regional_BC & ,start_regional_cold_start & ,start_regional_restart & ,dump_field & ,current_time_in_seconds & - ,a_step, p_step, k_step, n_step - - integer,parameter :: nhalo_data =4 & + ,a_step, p_step, k_step, n_step, get_data_source & + ,write_full_fields + integer,parameter :: bc_time_interval=3 & + ,nhalo_data =4 & ,nhalo_model=3 - +! integer, public, parameter :: H_STAGGER = 1 integer, public, parameter :: U_STAGGER = 2 integer, public, parameter :: V_STAGGER = 3 @@ -111,15 +118,38 @@ module fv_regional_mod ! integer, parameter :: iend_nest = 1346 ! integer, parameter :: jend_nest = 1290 + integer,parameter :: nvars_core=7 & !<-- # of prognostic variables in core restart file + ,ndims_core=6 & !<-- # of core restart dimensions + ,ndims_tracers=4 !<-- # of tracer restart dimensions +! + real,parameter :: blend_exp1=0.5,blend_exp2=10. !<-- Define the exponential dropoff of weights + ! for prescribed external values in the + ! blending rows inside the domain boundary. real :: current_time_in_seconds - integer :: bc_time_interval - integer,save :: ncid,next_time_to_read_bcs,npz,ntracers - - !Locations of tracer vbls in the tracers array - integer,save :: o3mr_index, liq_wat_index, sphum_index - integer,save :: ice_wat_index, rainwat_index, snowwat_index, graupel_index +! + integer,save :: isd_mod,ied_mod,jsd_mod,jed_mod +! + integer,save :: ncid,next_time_to_read_bcs,nfields_tracers & + ,npz,ntracers +! + integer,save :: k_split,n_split +! integer,save :: bc_hour, ntimesteps_per_bc_update - +! + integer,save :: cld_amt_index & !<-- + ,graupel_index & ! + ,ice_water_index & ! Locations of + ,liq_water_index & ! tracer vbls + ,o3mr_index & ! in the tracers + ,rain_water_index & ! array. + ,snow_water_index & ! + ,sphum_index !<-- +! + integer,save :: lbnd_x_tracers,lbnd_y_tracers & !<-- Local lower bounds of x,y for tracer arrays + ,ubnd_x_tracers,ubnd_y_tracers !<-- Local upper bounds of x,y for tracer arrays +! + integer,save :: nrows_blend !<-- # of blending rows in the BC data files. +! real(kind=R_GRID),dimension(:,:,:),allocatable :: agrid_reg & !<-- Lon/lat of cell centers ,grid_reg !<-- Lon/lat of cell corners @@ -130,6 +160,13 @@ module fv_regional_mod logical,save :: north_bc,south_bc,east_bc,west_bc & ,begin_regional_restart=.true. + logical,dimension(:),allocatable,save :: blend_this_tracer + + character(len=50) :: filename_core='INPUT/fv_core.res.temp.nc' + character(len=50) :: filename_core_new='RESTART/fv_core.res.tile1_new.nc' + character(len=50) :: filename_tracers='INPUT/fv_tracer.res.temp.nc' + character(len=50) :: filename_tracers_new='RESTART/fv_tracer.res.tile1_new.nc' + type fv_regional_BC_variables real,dimension(:,:,:),allocatable :: delp_BC, divgd_BC, u_BC, v_BC, uc_BC, vc_BC real,dimension(:,:,:,:),allocatable :: q_BC @@ -148,6 +185,20 @@ module fv_regional_mod type(fv_regional_BC_variables) :: north, south, east, west end type fv_domain_sides + type single_vbl3D_sides + real,dimension(:,:,:),pointer :: north, south, east, west + end type single_vbl3D_sides + + type vars_2d + real,dimension(:,:),pointer :: ptr + character(len=10) :: name + end type vars_2d + + type vars_3d + real,dimension(:,:,:),pointer :: ptr + character(len=10) :: name + end type vars_3d + type(fv_domain_sides),target,save :: BC_t0, BC_t1 !<-- Boundary values for all BC variables at successive times from the regional BC file type(fv_regional_BC_variables),pointer,save :: bc_north_t0 & @@ -159,22 +210,26 @@ module fv_regional_mod ,bc_west_t1 & ,bc_east_t1 + type(fv_regional_BC_variables),pointer :: bc_side_t0,bc_side_t1 + type(fv_regional_bc_bounds_type),pointer,save :: regional_bounds + type(vars_3d),dimension(:),allocatable :: fields_core & + ,fields_tracers type(fv_nest_BC_type_3D), public :: delz_regBC ! lmh + + type(single_vbl3D_sides) :: delz_auxiliary !<-- Boundary delz that follows integration through forecast time. + integer :: ns = 0 ! lmh real,parameter :: tice=273.16 & ,t_i0=15. - !real, parameter :: c_liq = 4185.5 ! gfdl: heat capacity of liquid at 15 deg c - !real, parameter :: c_ice = 1972.0 ! gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4218.0 ! gfdl: heat capacity of liquid at 0 deg c - real, parameter :: c_ice = 2106.0 ! gfdl: heat capacity of ice at 0 deg c real, parameter :: zvir = rvgas/rdgas - 1. & ,cv_air = cp_air - rdgas & ,cv_vap = cp_vapor - rvgas real,dimension(:),allocatable :: dum1d, pref + character(len=100) :: grid_data='grid.tile7.halo4.nc' & ,oro_data ='oro_data.tile7.halo4.nc' @@ -190,8 +245,11 @@ module fv_regional_mod module procedure dump_field_2d end interface dump_field - integer :: a_step, p_step, k_step, n_step + integer,save :: bc_update_interval, nrows_blend_user + integer :: a_step, p_step, k_step, n_step +! + logical :: data_source_fv3gfs contains !----------------------------------------------------------------------- @@ -220,9 +278,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 ! !----------------------------------------------------------------------- !*********************************************************************** @@ -264,13 +328,17 @@ subroutine setup_regional_BC(Atm & ! !----------------------------------------------------------------------- ! - bc_time_interval = Atm%flagstruct%bc_update_interval ! kyc: set up bc_time_interval according to the namelist - north_bc=.false. south_bc=.false. east_bc =.false. west_bc =.false. ! +! write(0,*)' enter setup_regional_BC isd=',isd,' ied=',ied,' jsd=',jsd,' jed=',jed + isd_mod=isd + ied_mod=ied + jsd_mod=jsd + jed_mod=jed +! !----------------------------------------------------------------------- !*** Which side(s) of the domain does this task lie on if any? !----------------------------------------------------------------------- @@ -291,37 +359,87 @@ subroutine setup_regional_BC(Atm & west_bc=.true. endif ! - 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. + bc_update_interval=Atm%flagstruct%bc_update_interval +! + k_split=Atm%flagstruct%k_split + n_split=Atm%flagstruct%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 !<-- # of advected tracers - npz=Atm%npz !<-- # of layers in vertical configuration of integration - klev_out=npz + nrows_blend_user=Atm%flagstruct%nrows_blend !<-- # of blending rows the user wnats to apply. ! - regional_bounds=>Atm%regional_bc_bounds + call check(nf90_inq_dimid(ncid,'halo',dimid)) !<-- ID of the halo dimension. + call check(nf90_inquire_dimension(ncid,dimid,len=nrows_bc_data)) !<-- Total # of rows of BC data (bndry + blending) +! + nrows_blend_in_data=nrows_bc_data-nhalo_data !<-- # of blending rows in the BC files. +! + if(nrows_blend_user>nrows_blend_in_data)then !<-- User wants more blending rows than are in the BC file. + write(char2_1,'(I2.2)')nrows_blend_user + write(char2_2,'(I2.2)')nrows_blend_in_data + call mpp_error(FATAL,'User wants to use '//char2_1//' blending rows but only '//char2_2//' blending rows are in the BC file!') + else + nrows_blend=nrows_blend_in_data !<-- # of blending rows in the BC files. + endif +! + call check(nf90_close(ncid)) !<-- Close the BC file for now. ! !----------------------------------------------------------------------- !*** Compute the index limits within the boundary region on each !*** side of the domain for both scalars and winds. Since the !*** domain does not move then the computations need to be done -!*** only once. Likewise find and save the locations of the -!*** available tracers in the tracers array. +!*** only once. !----------------------------------------------------------------------- ! call compute_regional_bc_indices(Atm%regional_bc_bounds) ! - liq_wat_index=get_tracer_index(MODEL_ATMOS, 'liq_wat') - o3mr_index =get_tracer_index(MODEL_ATMOS, 'o3mr') - sphum_index =get_tracer_index(MODEL_ATMOS, 'sphum') - ice_wat_index=get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat_index=get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat_index=get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel_index=get_tracer_index(MODEL_ATMOS, 'graupel') +!----------------------------------------------------------------------- +! + if(.not.(north_bc.or.south_bc.or.east_bc.or.west_bc))then + return !<-- This task is not on the domain boundary so exit. + endif +! +!----------------------------------------------------------------------- +! +! ntracers=Atm%ncnst - Atm%flagstruct%dnats !<-- # of advected tracers + ntracers=Atm%ncnst !<-- Total # of tracers + npz=Atm%npz !<-- # of layers in vertical configuration of integration + klev_out=npz +! + regional_bounds=>Atm%regional_bc_bounds ! !----------------------------------------------------------------------- !*** Allocate the objects that will hold the boundary variables @@ -353,7 +471,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_north_uvw & ,klev_out & ,ntracers & - ,BC_t1%north ) + ,BC_t1%north & + ,delz_auxiliary%north ) ! call allocate_regional_BC_arrays('north' & ,north_bc,south_bc & @@ -397,7 +516,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_south_uvw & ,klev_out & ,ntracers & - ,BC_t1%south ) + ,BC_t1%south & + ,delz_auxiliary%south ) ! call allocate_regional_BC_arrays('south' & ,north_bc,south_bc & @@ -441,7 +561,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_east_uvw & ,klev_out & ,ntracers & - ,BC_t1%east ) + ,BC_t1%east & + ,delz_auxiliary%east ) ! call allocate_regional_BC_arrays('east ' & ,north_bc,south_bc & @@ -485,7 +606,8 @@ subroutine setup_regional_BC(Atm & ,Atm%regional_bc_bounds%je_west_uvw & ,klev_out & ,ntracers & - ,BC_t1%west ) + ,BC_t1%west & + ,delz_auxiliary%west ) ! call allocate_regional_BC_arrays('west ' & ,north_bc,south_bc & @@ -555,7 +677,7 @@ subroutine setup_regional_BC(Atm & i_end =ied j_start=jsd if(.not.Atm%flagstruct%warm_start)then !<-- NOT a restarted run. - j_end =jsd+nhalo_model-1 + j_end=jsd+nhalo_model-1 else !<-- A restarted run. j_end=jsd+nhalo_model+1 endif @@ -571,7 +693,7 @@ subroutine setup_regional_BC(Atm & i_end =ied j_end =jed if(.not.Atm%flagstruct%warm_start)then !<-- NOT a restarted run. - j_start=jed-nhalo_model+1 + j_start=jed-nhalo_model+1 else !<-- A restarted run. j_start=jed-nhalo_model-1 endif @@ -611,6 +733,24 @@ subroutine setup_regional_BC(Atm & enddo enddo endif +! + sphum_index = get_tracer_index(MODEL_ATMOS, 'sphum') + liq_water_index = get_tracer_index(MODEL_ATMOS, 'liq_wat') + ice_water_index = get_tracer_index(MODEL_ATMOS, 'ice_wat') + rain_water_index = get_tracer_index(MODEL_ATMOS, 'rainwat') + snow_water_index = get_tracer_index(MODEL_ATMOS, 'snowwat') + graupel_index = get_tracer_index(MODEL_ATMOS, 'graupel') + cld_amt_index = get_tracer_index(MODEL_ATMOS, 'cld_amt') + o3mr_index = get_tracer_index(MODEL_ATMOS, 'o3mr') +! write(0,*)' setup_regional_bc' +! write(0,*)' sphum_index=',sphum_index +! write(0,*)' liq_water_index=',liq_water_index +! write(0,*)' ice_water_index=',ice_water_index +! write(0,*)' rain_water_index=',rain_water_index +! write(0,*)' snow_water_index=',snow_water_index +! write(0,*)' graupel_index=',graupel_index +! write(0,*)' cld_amt_index=',cld_amt_index +! write(0,*)' o3mr_index=',o3mr_index ! !----------------------------------------------------------------------- !*** When nudging of specific humidity is selected then we need a @@ -721,6 +861,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 @@ -730,11 +873,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 ! !----------- @@ -742,11 +885,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 ! !---------- @@ -754,18 +897,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 ! !---------- @@ -773,18 +916,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 ! !----------------------------------------------------------------------- @@ -796,19 +939,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 ! !----------- @@ -816,18 +957,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 ! !---------- @@ -835,33 +975,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 ! !---------- @@ -869,33 +1007,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 ! !----------------------------------------------------------------------- @@ -931,14 +1067,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 @@ -948,8 +1085,6 @@ subroutine read_regional_lon_lat i_start_data=2*(isd+nhalo_model)-1 j_start_data=2*(jsd+nhalo_model)-1 ! -! write(0,11110)i_start_data,j_start_data -11110 format(' i_start_data=',i5,' j_start_data=',i5) !--------------- !*** Longitude !--------------- @@ -1011,7 +1146,6 @@ subroutine read_regional_filtered_topo !----------------------------------------------------------------------- !*** Read the filtered topography including the extra outer row. !----------------------------------------------------------------------- - use netcdf !----------------------------------------------------------------------- implicit none !----------------------------------------------------------------------- @@ -1029,14 +1163,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. @@ -1112,6 +1247,16 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +!*** Get the source of the input data +!----------------------------------------------------------------------- +! + if (Atm%flagstruct%hrrrv3_ic) then + data_source_fv3gfs = .TRUE. + else + call get_data_source(data_source_fv3gfs,Atm%flagstruct%regional) + endif ! call setup_regional_BC(Atm & ,isd, ied, jsd, jed & @@ -1130,11 +1275,21 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & enddo call regional_bc_t1_to_t0(BC_t1, BC_t0 & ! - ,Atm%npz & !<-- Move BC t1 data - ,Atm%ncnst & ! to t0. + ,Atm%npz & !<-- Move BC t1 data to t0. + ,ntracers & ,Atm%regional_bc_bounds ) ! ! - bc_hour=bc_hour+bc_time_interval + 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 @@ -1146,7 +1301,6 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & Atm%ps(i,j) = ps0(i,j) enddo enddo -! ! allocate (ak_in(1:levp+1)) !<-- Save the input vertical structure for allocate (bk_in(1:levp+1)) ! remapping BC updates during the forecast. @@ -1156,9 +1310,19 @@ subroutine start_regional_cold_start(Atm, ak, bk, levp & enddo ! !----------------------------------------------------------------------- +!*** If the GSI will need restart files that includes the +!*** fields' boundary rows. Those files were already created. +!*** Prepare the objects that hold their variables' names and +!*** values. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%write_restart_with_bcs)then + call prepare_full_fields(Atm) + endif +! +!----------------------------------------------------------------------- ! end subroutine start_regional_cold_start - ! !----------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1179,6 +1343,7 @@ subroutine start_regional_restart(Atm & !------------------------ ! type(fv_atmos_type),intent(inout) :: Atm !<-- Atm object for the current domain +! ! integer ,intent(in) :: isc,iec,jsc,jec & !<-- Integration limits of task subdomain ,isd,ied,jsd,jed !<-- Memory limits of task subdomain @@ -1199,6 +1364,8 @@ subroutine start_regional_restart(Atm & integer :: nt_checker = 0 namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds & ,checker_tr, nt_checker + ! variables for reading the dimension from the gfs_ctrl + integer ncid, levsp !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- @@ -1213,39 +1380,85 @@ subroutine start_regional_restart(Atm & write(0,11011)ierr 11011 format(' start_regional_restart failed to read external_ic_nml ierr=',i3) endif + +!--- read in ak and bk from the control file using fms_io read_data --- + call open_ncfile( 'INPUT/gfs_ctrl.nc', ncid ) ! open the file + call get_ncdim1( ncid, 'levsp', levsp ) + call close_ncfile( ncid ) + + levp = levsp-1 +! +!----------------------------------------------------------------------- +!*** Get the source of the input data. +!----------------------------------------------------------------------- +! + if (Atm%flagstruct%hrrrv3_ic) then + data_source_fv3gfs = .TRUE. + else + call get_data_source(data_source_fv3gfs,Atm%flagstruct%regional) + endif ! !----------------------------------------------------------------------- !*** Preliminary setup for the forecast. !----------------------------------------------------------------------- ! - call setup_regional_BC(Atm & - ,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. - allocate(pes(mpp_npes())) - call mpp_get_current_pelist(pes) - if (open_file(Grid_input, 'INPUT/gfs_ctrl.nc', "read", pelist=pes)) then - call read_data(Grid_input,'vcoord',wk2) - call close_file(Grid_input) - endif - deallocate(pes) - 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.) + call setup_regional_BC(Atm & + ,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. + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + if (Atm%flagstruct%hrrrv3_ic) then + if (open_file(Grid_input, 'INPUT/hrrr_ctrl.nc', "read", pelist=pes)) then + call read_data(Grid_input,'vcoord',wk2) + call close_file(Grid_input) + endif + else + if (open_file(Grid_input, 'INPUT/gfs_ctrl.nc', "read", pelist=pes)) then + call read_data(Grid_input,'vcoord',wk2) + call close_file(Grid_input) + endif + endif + deallocate(pes) + ak_in(1:levp+1) = wk2(1:levp+1,1) + ak_in(1) = max(1.e-9, ak_in(1)) + bk_in(1:levp+1) = wk2(1:levp+1,2) + deallocate(wk2) + bc_hour=nint(current_time_in_seconds/3600.) ! !----------------------------------------------------------------------- !*** Fill time level t1 from the BC file at the restart time. !----------------------------------------------------------------------- ! - call regional_bc_data(Atm, bc_hour & - ,isc, iec, jsc, jec & - ,isd, ied, jsd, jed & - ,ak_in, bk_in ) + call regional_bc_data(Atm, bc_hour & + ,isc, iec, jsc, jec & + ,isd, ied, jsd, jed & + ,ak_in, bk_in ) +! +!----------------------------------------------------------------------- +!*** If this is a DA run and the first BC file was updated by +!*** the GSI then that file was read differently in the preceding +!*** call to subroutine regional_bc_data. Now reset the gsi +!*** flag so that all subsequent BC files are read normally. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%regional_bcs_from_gsi)then + Atm%flagstruct%regional_bcs_from_gsi=.false. + endif +! +!----------------------------------------------------------------------- +!*** If the GSI will need restart files that include the +!*** fields' boundary rows after this forecast or forecast +!*** segment completes then prepare the objects that will +!*** hold their variables' names and values. +!----------------------------------------------------------------------- +! + if(Atm%flagstruct%write_restart_with_bcs)then + call prepare_full_fields(Atm) + endif ! !----------------------------------------------------------------------- ! @@ -1272,7 +1485,7 @@ subroutine read_new_bc_data(Atm, Time, Time_step_atmos, p_split & type(fv_atmos_type),intent(inout) :: Atm !<-- Atm object for the current domain type(time_type),intent(in) :: Time !<-- Current forecast time type (time_type),intent(in) :: Time_step_atmos !<-- Large (physics) timestep -! + integer,intent(in) :: isd,ied,jsd,jed & !<-- Memory limits of task subdomain ,p_split ! @@ -1297,7 +1510,7 @@ subroutine read_new_bc_data(Atm, Time, Time_step_atmos, p_split & dt_atmos = real(sec) ! if(atmos_time_step==0.or.Atm%flagstruct%warm_start)then - ntimesteps_per_bc_update=nint(Atm%flagstruct%bc_update_interval*3600./(dt_atmos/real(abs(p_split)))) + ntimesteps_per_bc_update=nint(bc_update_interval*3600./(dt_atmos/real(abs(p_split)))) endif ! if(atmos_time_step+1>=ntimesteps_per_bc_update.and.mod(atmos_time_step,ntimesteps_per_bc_update)==0 & @@ -1305,7 +1518,7 @@ subroutine read_new_bc_data(Atm, Time, Time_step_atmos, p_split & Atm%flagstruct%warm_start.and.begin_regional_restart)then ! begin_regional_restart=.false. - bc_hour=bc_hour+Atm%flagstruct%bc_update_interval + bc_hour=bc_hour+bc_update_interval ! !----------------------------------------------------------------------- !*** Transfer the time level t1 data to t0. @@ -1313,7 +1526,7 @@ subroutine read_new_bc_data(Atm, Time, Time_step_atmos, p_split & ! call regional_bc_t1_to_t0(BC_t1, BC_t0 & ,Atm%npz & - ,Atm%ncnst & + ,ntracers & ,Atm%regional_bc_bounds ) ! !----------------------------------------------------------------------- @@ -1344,7 +1557,6 @@ subroutine regional_bc_data(Atm,bc_hour & !----------------------------------------------------------------------- !*** Regional boundary data is obtained from the external BC file. !----------------------------------------------------------------------- - use netcdf !----------------------------------------------------------------------- implicit none !----------------------------------------------------------------------- @@ -1387,14 +1599,17 @@ 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,w_input,zh_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 - real,dimension(:,:,:),allocatable :: pt_input real,dimension(:,:,:,:),allocatable :: tracers_input ! real(kind=R_GRID), dimension(2):: p1, p2, p3, p4 @@ -1412,6 +1627,7 @@ subroutine regional_bc_data(Atm,bc_hour & logical,save :: computed_regional_bc_indices=.false. ! character(len=3) :: int_to_char + character(len=5) :: side character(len=6) :: fmt='(i3.3)' ! character(len=50) :: file_name @@ -1419,6 +1635,12 @@ subroutine regional_bc_data(Atm,bc_hour & integer,save :: kount1=0,kount2=0 integer :: istart, iend, jstart, jend integer :: npx, npy +! + character(len=60) :: var_name_root + logical :: required +! + logical :: call_remap +! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- @@ -1437,21 +1659,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). @@ -1464,24 +1696,25 @@ subroutine regional_bc_data(Atm,bc_hour & ie_input=ie+nhalo_data js_input=js-nhalo_data je_input=je+nhalo_data -! npx = Atm%npx npy = Atm%npy ! - allocate( ps_input(is_input:ie_input,js_input:je_input,1)) ; ps_input=real_snan !<-- Sfc pressure - allocate( 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 -! - allocate(tracers_input(is_input:ie_input,js_input:je_input,klev_in,ntracers)) !; tracers_input=real_snan - tracers_input=0. ! Temporary fix - - if (Atm%flagstruct%hrrrv3_ic) then - allocate( pt_input(is_input:ie_input,js_input:je_input,1:klev_in)) ; pt_input=real_snan + 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(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 ! !----------------------------------------------------------------------- !*** Extract each variable from the regional BC file. The final @@ -1493,90 +1726,81 @@ subroutine regional_bc_data(Atm,bc_hour & !------------------ ! nlev=1 + var_name_root='ps' call read_regional_bc_file(is_input,ie_input,js_input,je_input & ,nlev & ,ntracers & ! ,Atm%regional_bc_bounds & - ,'ps ' & + ,var_name_root & ,array_3d=ps_input ) !<-- ps is 2D but for simplicity here use a 3rd dim of 1 -! -!!!!! NOTE !!!!!!! NEED TO FILL IN OTHER TRACERS WITH *****ZEROES****** if not present -!----------------------- -!*** Specific humidity -!----------------------- -! - nlev=klev_in - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'sphum ' & - ,array_4d=tracers_input & - ,tlev=sphum_index ) -! -!------------------ -!*** Liquid water -!------------------ -! - nlev=klev_in - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'liq_wat' & - ,array_4d=tracers_input & - ,tlev=liq_wat_index ) - -! -!------------------ -!*** Ozone -!------------------ -! - nlev=klev_in - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'o3mr ' & - ,array_4d=tracers_input & - ,tlev=o3mr_index ) - - ! !----------------------- !*** Vertical velocity !----------------------- ! nlev=klev_in + var_name_root='w' call read_regional_bc_file(is_input,ie_input,js_input,je_input & ,nlev & ,ntracers & ! ,Atm%regional_bc_bounds & - ,'w ' & + ,var_name_root & ,array_3d=w_input) ! !----------------------- !*** Interface heights !----------------------- ! - nlev=klev_in+1 - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'zh ' & - ,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 +!-------------------------- +! + if (Atm%flagstruct%hrrrv3_ic) then + + nlev=klev_in + var_name_root='pt ' + call read_regional_bc_file(is_input,ie_input,js_input,je_input & + ,nlev & + ,ntracers & +! ,Atm%regional_bc_bounds & + ,var_name_root & + ,array_3d=t_input) + + + else + if (data_source_fv3gfs) then + nlev=klev_in + var_name_root='t' + call read_regional_bc_file(is_input,ie_input,js_input,je_input & + ,nlev & + ,ntracers & +! ,Atm%regional_bc_bounds & + ,var_name_root & + ,array_3d=t_input) + endif + endif ! !----------------------------- !*** U component south/north !----------------------------- ! nlev=klev_in + var_name_root='u_s' call read_regional_bc_file(is_input,ie_input,js_input,je_input & ,nlev & ,ntracers & ! ,Atm%regional_bc_bounds & - ,'u_s ' & + ,var_name_root & ,array_3d=u_s_input) ! !----------------------------- @@ -1584,11 +1808,12 @@ subroutine regional_bc_data(Atm,bc_hour & !----------------------------- ! nlev=klev_in + var_name_root='v_s' call read_regional_bc_file(is_input,ie_input,js_input,je_input & ,nlev & ,ntracers & ! ,Atm%regional_bc_bounds & - ,'v_s ' & + ,var_name_root & ,array_3d=v_s_input) ! !--------------------------- @@ -1596,11 +1821,12 @@ subroutine regional_bc_data(Atm,bc_hour & !--------------------------- ! nlev=klev_in + var_name_root='u_w' call read_regional_bc_file(is_input,ie_input,js_input,je_input & ,nlev & ,ntracers & ! ,Atm%regional_bc_bounds & - ,'u_w ' & + ,var_name_root & ,array_3d=u_w_input) ! !--------------------------- @@ -1608,102 +1834,83 @@ subroutine regional_bc_data(Atm,bc_hour & !--------------------------- ! nlev=klev_in + var_name_root='v_w' call read_regional_bc_file(is_input,ie_input,js_input,je_input & ,nlev & ,ntracers & ! ,Atm%regional_bc_bounds & - ,'v_w ' & + ,var_name_root & ,array_3d=v_w_input) ! - - -if (Atm%flagstruct%hrrrv3_ic) then -! -!----------------------- -!*** Virtual temp. -!----------------------- +!----------------------------------------------------------------------- +!*** 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 - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'pt ' & - ,array_3d=pt_input) ! - +!----------------------------------------------------------------------- +!*** Read the tracers specified in the field_table. If they are not +!*** in the input data then print a warning and set them to 0 in the +!*** boundary. Some tracers are mandatory to have, because they are +!*** used later for calculating virtual potential temperature etc. +!----------------------------------------------------------------------- ! -!------------------ -!*** Ice water -!------------------ + do nt = 1, ntracers + call get_tracer_names(MODEL_ATMOS, nt, var_name_root) + index= get_tracer_index(MODEL_ATMOS,trim(var_name_root)) + if (index==liq_water_index .or. index==sphum_index) then + required = .true. + else + required = .false. + endif + call read_regional_bc_file(is_input,ie_input,js_input,je_input & + ,nlev & + ,ntracers & + ,var_name_root & + ,array_4d=tracers_input & + ,tlev=index & + ,required=required ) + enddo ! - nlev=klev_in - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'ice_wat' & - ,array_4d=tracers_input & - ,tlev=ice_wat_index ) - +!----------------------------------------------------------------------- +!*** 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. +!----------------------------------------------------------------------- ! -!------------------ -!*** Rain water -!------------------ -! - nlev=klev_in - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'rainwat' & - ,array_4d=tracers_input & - ,tlev=rainwat_index ) - - -! -!------------------ -!*** Snow water -!------------------ + data_to_BC: if(Atm%flagstruct%regional_bcs_from_gsi)then !<-- Fill BC arrays directly from the BC file data ! - nlev=klev_in - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'snowwat' & - ,array_4d=tracers_input & - ,tlev=snowwat_index ) - +!----------------------------------------------------------------------- ! -!------------------ -!*** Graupel water -!------------------ + call fill_BC_for_DA ! - nlev=klev_in - call read_regional_bc_file(is_input,ie_input,js_input,je_input & - ,nlev & - ,ntracers & -! ,Atm%regional_bc_bounds & - ,'graupel' & - ,array_4d=tracers_input & - ,tlev=graupel_index ) - -endif !----------------------------------------------------------------------- -!*** 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. -!----------------------------------------------------------------------- -! -! do j=jsd,jed -! do i=isd,ied -! Atm%ps(i,j)=ps(i,j) -! enddo -! enddo ! -! 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 @@ -1713,7 +1920,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 @@ -1729,387 +1936,232 @@ subroutine regional_bc_data(Atm,bc_hour & ! code or elsewhere in FMS. North <--> South, East <--> West, and ! North and South always span [isd-1 , ied+1] while East and West do not ! go into the outermost corners (so the they span [1, je], always.) +!----------------------------------------------------------------------- + sides_scalars: do nside=1,4 +!----------------------------------------------------------------------- !----------- !*** North !----------- ! - if(north_bc)then - - if (Atm%flagstruct%hrrrv3_ic) then - call remap_scalar_regional_bc_nh(Atm & - ,'north' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,pt_input & - ,zh_input & !<-- - - ,phis_reg & !<-- Filtered topography - - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - - ,BC_t1%north ) !<-- North BC vbls on final integration levels - else - - call remap_scalar_nggps_regional_bc(Atm & - ,'north' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,zh_input & !<-- - - ,phis_reg & !<-- Filtered topography - - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - - ,BC_t1%north ) !<-- North BC vbls on final integration levels - - endif - - if (is == 1) then - istart = 1 - else - istart = isd - endif - if (ie == npx-1) then - iend = npx-1 - else - iend = ied - endif - - do k=1,npz - do j=jsd,0 - do i=istart,iend - delz_regBC%south_t1(i,j,k) = BC_t1%north%delz_BC(i,j,k) - delz_regBC%south_t0(i,j,k) = BC_t0%north%delz_BC(i,j,k) - enddo - enddo - enddo - - ! North, south include all corners - if (is == 1) then - do k=1,npz - do j=jsd,0 - do i=isd,0 - delz_regBC%west_t1(i,j,k) = BC_t1%north%delz_BC(i,j,k) - delz_regBC%west_t0(i,j,k) = BC_t0%north%delz_BC(i,j,k) - enddo - enddo - enddo - endif - - if (ie == npx-1) then - do k=1,npz - do j=jsd,0 - do i=npx,ied - delz_regBC%east_t1(i,j,k) = BC_t1%north%delz_BC(i,j,k) - delz_regBC%east_t0(i,j,k) = BC_t0%north%delz_BC(i,j,k) - enddo - enddo - enddo - endif -! - endif -! -!----------- -!*** South -!----------- -! - if(south_bc)then + call_remap=.false. ! - - if (Atm%flagstruct%hrrrv3_ic) then - call remap_scalar_regional_bc_nh(Atm & - ,'south' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,pt_input & - ,zh_input & !<-- - - ,phis_reg & !<-- Filtered topography - - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - - ,BC_t1%south ) !<-- North BC vbls on final integration levels - else - - call remap_scalar_nggps_regional_bc(Atm & - ,'south' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,zh_input & !<-- - - ,phis_reg & !<-- Filtered topography - - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - - ,BC_t1%south ) !<-- North BC vbls on final integration levels - + if(nside==1)then + if(north_bc)then + call_remap=.true. + side='north' + bc_side_t1=>BC_t1%north + bc_side_t0=>BC_t0%north endif - - + endif ! - - if (is == 1) then - istart = 1 - else - istart = isd - endif - if (ie == npx-1) then - iend = npx-1 - else - iend = ied - endif - - do k=1,npz - do j=npy,jed - do i=istart,iend - delz_regBC%north_t1(i,j,k) = BC_t1%south%delz_BC(i,j,k) - delz_regBC%north_t0(i,j,k) = BC_t0%south%delz_BC(i,j,k) - enddo - enddo - enddo - - ! North, south include all corners - if (is == 1) then - do k=1,npz - do j=npy,jed - do i=isd,0 - delz_regBC%west_t1(i,j,k) = BC_t1%south%delz_BC(i,j,k) - delz_regBC%west_t0(i,j,k) = BC_t0%south%delz_BC(i,j,k) - enddo - enddo - enddo + if(nside==2)then + if(south_bc)then + call_remap=.true. + side='south' + bc_side_t1=>BC_t1%south + bc_side_t0=>BC_t0%south endif - - if (ie == npx-1) then - do k=1,npz - do j=npy,jed - do i=npx,ied - delz_regBC%east_t1(i,j,k) = BC_t1%south%delz_BC(i,j,k) - delz_regBC%east_t0(i,j,k) = BC_t0%south%delz_BC(i,j,k) - enddo - enddo - enddo - endif - endif -! -!---------- -!*** East -!---------- -! - if(east_bc)then + endif ! - - if (Atm%flagstruct%hrrrv3_ic) then - call remap_scalar_regional_bc_nh(Atm & - ,'east ' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,pt_input & - ,zh_input & !<-- - - ,phis_reg & !<-- Filtered topography - - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - - ,BC_t1%east ) !<-- North BC vbls on final integration levels - else - - call remap_scalar_nggps_regional_bc(Atm & - ,'east ' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,zh_input & !<-- - - ,phis_reg & !<-- Filtered topography - - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - - ,BC_t1%east ) !<-- North BC vbls on final integration levels - + if(nside==3)then + if(east_bc)then + call_remap=.true. + side='east ' + bc_side_t1=>BC_t1%east + bc_side_t0=>BC_t0%east + endif endif ! - if (js == 1) then - jstart = 1 - else - jstart = jsd - endif - if (je == npy-1) then - jend = je - else - jend = jed + if(nside==4)then + if(west_bc)then + call_remap=.true. + side='west ' + bc_side_t1=>BC_t1%west + bc_side_t0=>BC_t0%west endif - - - do k=1,npz - do j=jstart,jend - do i=isd,0 - delz_regBC%west_t1(i,j,k) = BC_t1%east%delz_BC(i,j,k) - delz_regBC%west_t0(i,j,k) = BC_t0%east%delz_BC(i,j,k) - enddo - enddo - enddo - - endif -! -!---------- -!*** West -!---------- -! - if(west_bc)then + endif ! - if (Atm%flagstruct%hrrrv3_ic) then - call remap_scalar_regional_bc_nh(Atm & - ,'west ' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- - - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & - - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,pt_input & - ,zh_input & !<-- + if(call_remap)then + call remap_scalar_nggps_regional_bc(Atm & + ,side & + + ,isd,ied,jsd,jed & !<-- Atm array indices w/halo + + ,is_input & !<-- + ,ie_input & ! Input array + ,js_input & ! index limits. + ,je_input & !<-- + + ,klev_in, klev_out & + ,ntracers & + ,ak, bk & + + ,ps_input & !<-- + ,t_input & ! BC vbls + ,tracers_input & ! on input + ,w_input & ! model levels + ,zh_input & !<-- + + ,phis_reg & !<-- Filtered topography + + ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region + + ,bc_side_t1 ) !<-- BC vbls on final integration levels +! + call set_delp_and_tracers(bc_side_t1,Atm%npz,Atm%flagstruct%nwat) +! + if(nside==1)then + if(north_bc)then + if (is == 1) then + istart = 1 + else + istart = isd + endif + if (ie == npx-1) then + iend = npx-1 + else + iend = ied + endif + + do k=1,npz + do j=jsd,0 + do i=istart,iend + delz_regBC%south_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%south_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo - ,phis_reg & !<-- Filtered topography - - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region - - ,BC_t1%west ) !<-- North BC vbls on final integration levels - else - - call remap_scalar_nggps_regional_bc(Atm & - ,'west ' & - - ,isd,ied,jsd,jed & !<-- Atm array indices w/halo - - ,is_input & !<-- - ,ie_input & ! Input array - ,js_input & ! index limits. - ,je_input & !<-- + ! North, south include all corners + if (is == 1) then + do k=1,npz + do j=jsd,0 + do i=isd,0 + delz_regBC%west_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%west_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + + if (ie == npx-1) then + do k=1,npz + do j=jsd,0 + do i=npx,ied + delz_regBC%east_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%east_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif + endif - ,klev_in, klev_out & - ,ntracers & - ,ak, bk & + if(nside==2)then + if(south_bc)then + if (is == 1) then + istart = 1 + else + istart = isd + endif + if (ie == npx-1) then + iend = npx-1 + else + iend = ied + endif + + do k=1,npz + do j=npy,jed + do i=istart,iend + delz_regBC%north_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%north_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo - ,ps_input & !<-- - ,tracers_input & ! BC vbls on - ,w_input & ! input model levels - ,zh_input & !<-- + ! North, south include all corners + if (is == 1) then + do k=1,npz + do j=npy,jed + do i=isd,0 + delz_regBC%west_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%west_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + + + if (ie == npx-1) then + do k=1,npz + do j=npy,jed + do i=npx,ied + delz_regBC%east_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%east_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif + endif - ,phis_reg & !<-- Filtered topography +! - ,ps_reg & !<-- Derived FV3 psfc in regional domain boundary region + if(nside==3)then + if(east_bc)then + if (js == 1) then + jstart = 1 + else + jstart = jsd + endif + if (je == npy-1) then + jend = je + else + jend = jed + endif + + + do k=1,npz + do j=jstart,jend + do i=isd,0 + delz_regBC%west_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%west_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif - ,BC_t1%west ) !<-- North BC vbls on final integration levels + if(nside==4)then + if(west_bc)then + if (js == 1) then + jstart = 1 + else + jstart = jsd + endif + if (je == npy-1) then + jend = je + else + jend = jed + endif + + + do k=1,npz + do j=jstart,jend + do i=npx,ied + delz_regBC%east_t1(i,j,k) = bc_side_t1%delz_BC(i,j,k) + delz_regBC%east_t0(i,j,k) = bc_side_t0%delz_BC(i,j,k) + enddo + enddo + enddo + endif + endif - endif + endif ! - if (js == 1) then - jstart = 1 - else - jstart = jsd - endif - if (je == npy-1) then - jend = je - else - jend = jed - endif - - do k=1,npz - do j=jstart,jend - do i=npx,ied - delz_regBC%east_t1(i,j,k) = BC_t1%west%delz_BC(i,j,k) - delz_regBC%east_t0(i,j,k) = BC_t0%west%delz_BC(i,j,k) - enddo - enddo - enddo - endif +!----------------------------------------------------------------------- + enddo sides_scalars +!----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Now that we have the pressure throughout the boundary region @@ -2118,412 +2170,210 @@ 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 ! - if(north_bc)then +!----------------------------------------------------------------------- +!*** Loop through the four sides of the domain. +!----------------------------------------------------------------------- ! - 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 -! - allocate(ud(is_u:ie_u,js_u:je_u,1:nlev)) ; ud=real_snan - allocate(vd(is_v:ie_v,js_v:je_v,1:nlev)) ; vd=real_snan - allocate(vc(is_u:ie_u,js_u:je_u,1:nlev)) ; vc=real_snan - allocate(uc(is_v:ie_v,js_v:je_v,1:nlev)) ; uc=real_snan -! - do k=1,nlev - do j=js_u,je_u - do i=is_u,ie_u - if (Atm%flagstruct%hrrrv3_ic) then - ud(i,j,k) = u_s_input(i,j,k) - vc(i,j,k) = v_s_input(i,j,k) - else - 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) +!----------------------------------------------------------------------- + sides_winds: do nside=1,4 +!----------------------------------------------------------------------- +! + 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 endif - enddo - enddo + endif ! - do j=js_v,je_v - do i=is_v,ie_v - if (Atm%flagstruct%hrrrv3_ic) then - vd(i,j,k) = v_w_input(i,j,k) - uc(i,j,k) = u_w_input(i,j,k) - else - p1(:) = grid_reg(i,j ,1:2) - p2(:) = grid_reg(i,j+1,1:2) + 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 +! + 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_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 +! + 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_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 +! + 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 +! + do k=1,nlev + do j=js_u,je_u + do i=is_u,ie_u + if (Atm%flagstruct%hrrrv3_ic) then + ud(i,j,k) = u_s_input(i,j,k) + vc(i,j,k) = v_s_input(i,j,k) + else + 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) - endif + 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) + endif + enddo + enddo +! + do j=js_v,je_v + do i=is_v,ie_v + if (Atm%flagstruct%hrrrv3_ic) then + vd(i,j,k) = v_w_input(i,j,k) + uc(i,j,k) = u_w_input(i,j,k) + else + 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) + endif + enddo + 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_t1%north ) !<-- 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 ! !----------------------------------------------------------------------- -!*** Transform the D-grid wind components on the south side of -!*** the regional domain then remap them from the input levels -!*** to the integration levels. -!----------------------------------------------------------------------- -! - if(south_bc)then -! - 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 -! - allocate(ud(is_u:ie_u,js_u:je_u,1:nlev)) ; ud=real_snan - allocate(vd(is_v:ie_v,js_v:je_v,1:nlev)) ; vd=real_snan - allocate(vc(is_u:ie_u,js_u:je_u,1:nlev)) ; vc=real_snan - allocate(uc(is_v:ie_v,js_v:je_v,1:nlev)) ; uc=real_snan -! - do k=1,nlev - do j=js_u,je_u - do i=is_u,ie_u - if (Atm%flagstruct%hrrrv3_ic) then - ud(i,j,k) = u_s_input(i,j,k) - vc(i,j,k) = v_s_input(i,j,k) - else - 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) - endif - enddo - enddo -! - do j=js_v,je_v - do i=is_v,ie_v - if (Atm%flagstruct%hrrrv3_ic) then - vd(i,j,k) = v_w_input(i,j,k) - uc(i,j,k) = u_w_input(i,j,k) - else - 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) - endif - enddo - enddo - enddo -! - call remap_dwinds_regional_bc(Atm & - - ,is_input & !<-- - ,ie_input & ! Index limits for scalars - ,js_input & ! at center of south BC region grid cells. - ,je_input & !<-- - - ,is_u & !<-- - ,ie_u & ! Index limits for u component - ,js_u & ! on south edge of BC region grid cells. - ,je_u & !<-- - - ,is_v & !<-- - ,ie_v & ! Index limits for v component - ,js_v & ! on south 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_t1%south ) !<-- South BC vbls on final integration levels -! - deallocate(ud,vd,uc,vc) -! - endif -! -!----------------------------------------------------------------------- -!*** Transform the D-grid wind components on the east side of -!*** the regional domain then remap them from the input levels -!*** to the integration levels. + enddo sides_winds !----------------------------------------------------------------------- ! - if(east_bc)then -! - 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 -! - allocate(ud(is_u:ie_u,js_u:je_u,1:nlev)) ; ud=real_snan - allocate(vd(is_v:ie_v,js_v:je_v,1:nlev)) ; vd=real_snan - allocate(vc(is_u:ie_u,js_u:je_u,1:nlev)) ; vc=real_snan - allocate(uc(is_v:ie_v,js_v:je_v,1:nlev)) ; uc=real_snan -! - do k=1,nlev - do j=js_u,je_u - do i=is_u,ie_u - if (Atm%flagstruct%hrrrv3_ic) then - ud(i,j,k) = u_s_input(i,j,k) - vc(i,j,k) = v_s_input(i,j,k) - else - 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) - endif - enddo - enddo -! - do j=js_v,je_v - do i=is_v,ie_v - if (Atm%flagstruct%hrrrv3_ic) then - vd(i,j,k) = v_w_input(i,j,k) - uc(i,j,k) = u_w_input(i,j,k) - else - 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) - endif - enddo - enddo - enddo -! - call remap_dwinds_regional_bc(Atm & - - ,is_input & !<-- - ,ie_input & ! Index limits for scalars - ,js_input & ! at center of east BC region grid cells. - ,je_input & !<-- - - ,is_u & !<-- - ,ie_u & ! Index limits for u component - ,js_u & ! on east edge of BC region grid cells. - ,je_u & !<-- - - ,is_v & !<-- - ,ie_v & ! Index limits for v component - ,js_v & ! on east 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_t1%east ) !<-- East BC vbls on final integration levels -! - deallocate(ud,vd,uc,vc) -! - endif -! -!----------------------------------------------------------------------- -!*** Transform the D-grid wind components on the west side of -!*** the regional domain then remap them from the input levels -!*** to the integration levels. -!----------------------------------------------------------------------- -! - if(west_bc)then -! - 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 -! - allocate(ud(is_u:ie_u,js_u:je_u,1:nlev)) ; ud=real_snan - allocate(vd(is_v:ie_v,js_v:je_v,1:nlev)) ; vd=real_snan - allocate(vc(is_u:ie_u,js_u:je_u,1:nlev)) ; vc=real_snan - allocate(uc(is_v:ie_v,js_v:je_v,1:nlev)) ; uc=real_snan -! - do k=1,nlev - do j=js_u,je_u - do i=is_u,ie_u - if (Atm%flagstruct%hrrrv3_ic) then - ud(i,j,k) = u_s_input(i,j,k) - vc(i,j,k) = v_s_input(i,j,k) - else - 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) - endif - enddo - enddo -! - do j=js_v,je_v - do i=is_v,ie_v - if (Atm%flagstruct%hrrrv3_ic) then - vd(i,j,k) = v_w_input(i,j,k) - uc(i,j,k) = u_w_input(i,j,k) - else - 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) - endif - enddo - enddo - enddo -! - call remap_dwinds_regional_bc(Atm & - - ,is_input & !<-- - ,ie_input & ! Index limits for scalars - ,js_input & ! at center of west BC region grid cells. - ,je_input & !<-- - - ,is_u & !<-- - ,ie_u & ! Index limits for u component - ,js_u & ! on west edge of BC region grid cells. - ,je_u & !<-- - - ,is_v & !<-- - ,ie_v & ! Index limits for v component - ,js_v & ! on west 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_t1%west ) !<-- West BC vbls on final integration levels -! - deallocate(ud,vd,uc,vc) -! - endif + endif data_to_BC ! !----------------------------------------------------------------------- !*** Close the boundary file. !----------------------------------------------------------------------- ! call check(nf90_close(ncid)) -! write(0,*)' closed BC netcdf file' ! !----------------------------------------------------------------------- !*** Deallocate working arrays. @@ -2533,6 +2383,9 @@ subroutine regional_bc_data(Atm,bc_hour & if(allocated(ps_input))then deallocate(ps_input) endif + if(allocated(t_input))then + deallocate(t_input) + endif if(allocated(zh_input))then deallocate(zh_input) endif @@ -2554,8 +2407,11 @@ subroutine regional_bc_data(Atm,bc_hour & if(allocated(v_w_input))then deallocate(v_w_input) endif - if(allocated(pt_input))then - deallocate(pt_input) + if(allocated(delp_input))then + deallocate(delp_input) + endif + if(allocated(delz_input))then + deallocate(delz_input) endif ! !----------------------------------------------------------------------- @@ -2568,7 +2424,9 @@ subroutine regional_bc_data(Atm,bc_hour & !*** Fill the total condensate in the regional boundary array. !----------------------------------------------------------------------- ! +#ifdef USE_COND call fill_q_con_BC +#endif ! !----------------------------------------------------------------------- !*** Fill moist kappa in the regional domain boundary array. @@ -2583,8 +2441,7 @@ subroutine regional_bc_data(Atm,bc_hour & !*** FV3's modified virtual potential temperature. !----------------------------------------------------------------------- ! - call convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & - ,sphum_index,liq_wat_index ) + call convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) ! !----------------------------------------------------------------------- !*** If nudging of the specific humidity has been selected then @@ -2604,103 +2461,288 @@ 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,ie,is,j,je,js,k + 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_north=lbound(BC_t1%north%divgd_BC,1) - ie_north=ubound(BC_t1%north%divgd_BC,1) - js_north=lbound(BC_t1%north%divgd_BC,2) - je_north=ubound(BC_t1%north%divgd_BC,2) + 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 k=1,klev_out - do j=js_north,je_north - do i=is_north,ie_north - BC_t1%north%divgd_BC(i,j,k)=0. - 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_south=lbound(BC_t1%south%divgd_BC,1) - ie_south=ubound(BC_t1%south%divgd_BC,1) - js_south=lbound(BC_t1%south%divgd_BC,2) - je_south=ubound(BC_t1%south%divgd_BC,2) + 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_out - do j=js_south,je_south - do i=is_south,ie_south - BC_t1%south%divgd_BC(i,j,k)=0. - enddo - enddo + 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_east=lbound(BC_t1%east%divgd_BC,1) - ie_east=ubound(BC_t1%east%divgd_BC,1) - js_east=lbound(BC_t1%east%divgd_BC,2) - je_east=ubound(BC_t1%east%divgd_BC,2) + 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_out - do j=js_east,je_east - do i=is_east,ie_east - BC_t1%east%divgd_BC(i,j,k)=0. - enddo - enddo + 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_west=lbound(BC_t1%west%divgd_BC,1) - ie_west=ubound(BC_t1%west%divgd_BC,1) - js_west=lbound(BC_t1%west%divgd_BC,2) - je_west=ubound(BC_t1%west%divgd_BC,2) + 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_out - do j=js_west,je_west - do i=is_west,ie_west - BC_t1%west%divgd_BC(i,j,k)=0. - enddo - enddo + 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_divgd_BC + end subroutine fill_BC_for_DA ! !----------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- ! - subroutine fill_q_con_BC + subroutine fill_divgd_BC ! !----------------------------------------------------------------------- -!*** For now fill the total condensate in the boundary regiona -!*** with only the liquid water content. +!*** For now fill the boundary divergence with zero. !----------------------------------------------------------------------- implicit none !----------------------------------------------------------------------- @@ -2709,161 +2751,251 @@ subroutine fill_q_con_BC !*** Local variables !-------------------- ! - integer :: i,ie,is,j,je,js,k + integer :: i,ie0,is0,j,je0,js0,k,nside +! + logical :: call_set ! -#ifdef USE_COND !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! - if(north_bc)then -! - is_north=lbound(BC_t1%north%q_con_BC,1) - ie_north=ubound(BC_t1%north%q_con_BC,1) - js_north=lbound(BC_t1%north%q_con_BC,2) - je_north=ubound(BC_t1%north%q_con_BC,2) +!----------------------------------------------------------------------- +!*** Loop through the four sides. +!----------------------------------------------------------------------- ! - do k=1,klev_out - do j=js_north,je_north - do i=is_north,ie_north - BC_t1%north%q_con_BC(i,j,k)=BC_t1%north%q_BC(i,j,k,liq_wat_index) - enddo - enddo - enddo + do nside=1,4 ! - endif - - if(south_bc)then + call_set=.false. ! - is_south=lbound(BC_t1%south%q_con_BC,1) - ie_south=ubound(BC_t1%south%q_con_BC,1) - js_south=lbound(BC_t1%south%q_con_BC,2) - je_south=ubound(BC_t1%south%q_con_BC,2) + if(nside==1)then + if(north_bc)then + call_set=.true. + bc_side_t1=>BC_t1%north + is0=lbound(BC_t1%north%divgd_BC,1) + ie0=ubound(BC_t1%north%divgd_BC,1) + js0=lbound(BC_t1%north%divgd_BC,2) + je0=ubound(BC_t1%north%divgd_BC,2) + endif + endif ! - do k=1,klev_out - do j=js_south,je_south - do i=is_south,ie_south - BC_t1%south%q_con_BC(i,j,k)=BC_t1%south%q_BC(i,j,k,liq_wat_index) - enddo - enddo - enddo - endif + if(nside==2)then + if(south_bc)then + call_set=.true. + bc_side_t1=>BC_t1%south + is0=lbound(BC_t1%south%divgd_BC,1) + ie0=ubound(BC_t1%south%divgd_BC,1) + js0=lbound(BC_t1%south%divgd_BC,2) + je0=ubound(BC_t1%south%divgd_BC,2) + endif + endif ! - if(east_bc)then + if(nside==3)then + if(east_bc)then + call_set=.true. + bc_side_t1=>BC_t1%east + is0=lbound(BC_t1%east%divgd_BC,1) + ie0=ubound(BC_t1%east%divgd_BC,1) + js0=lbound(BC_t1%east%divgd_BC,2) + je0=ubound(BC_t1%east%divgd_BC,2) + endif + endif ! - is_east=lbound(BC_t1%east%q_con_BC,1) - ie_east=ubound(BC_t1%east%q_con_BC,1) - js_east=lbound(BC_t1%east%q_con_BC,2) - je_east=ubound(BC_t1%east%q_con_BC,2) + if(nside==4)then + if(west_bc)then + call_set=.true. + bc_side_t1=>BC_t1%west + is0=lbound(BC_t1%west%divgd_BC,1) + ie0=ubound(BC_t1%west%divgd_BC,1) + js0=lbound(BC_t1%west%divgd_BC,2) + je0=ubound(BC_t1%west%divgd_BC,2) + endif + endif ! - do k=1,klev_out - do j=js_east,je_east - do i=is_east,ie_east - BC_t1%east%q_con_BC(i,j,k)=BC_t1%east%q_BC(i,j,k,liq_wat_index) - enddo + if(call_set)then + do k=1,klev_out + do j=js0,je0 + do i=is0,ie0 + bc_side_t1%divgd_BC(i,j,k)=0. + enddo + enddo enddo - enddo -! - endif - - if(west_bc)then -! - is_west=lbound(BC_t1%west%q_con_BC,1) - ie_west=ubound(BC_t1%west%q_con_BC,1) - js_west=lbound(BC_t1%west%q_con_BC,2) - je_west=ubound(BC_t1%west%q_con_BC,2) + endif ! - do k=1,klev_out - do j=js_west,je_west - do i=is_west,ie_west - BC_t1%west%q_con_BC(i,j,k)=BC_t1%west%q_BC(i,j,k,liq_wat_index) - enddo - enddo - enddo - endif + enddo ! !----------------------------------------------------------------------- ! -#endif USE_COND - end subroutine fill_q_con_BC + end subroutine fill_divgd_BC ! !----------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- ! - subroutine fill_cappa_BC +#ifdef USE_COND + subroutine fill_q_con_BC ! !----------------------------------------------------------------------- -!*** Compute cappa in the regional domain boundary area following -!*** Zhao-Carr microphysics. +!*** For now fill the total condensate in the boundary regiona +!*** with only the liquid water content. !----------------------------------------------------------------------- implicit none !----------------------------------------------------------------------- ! -!--------------------- +!-------------------- !*** Local variables -!--------------------- +!-------------------- ! - integer :: i1,i2,j1,j2 + integer :: i,ie0,is0,j,je0,js0,k,nside ! - real,dimension(:,:,:),pointer :: cappa,temp,liq_wat,sphum + logical :: call_set ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! +!----------------------------------------------------------------------- +!*** Loop through the four sides. +!----------------------------------------------------------------------- +! + do nside=1,4 + call_set=.false. +! + if(nside==1)then + if(north_bc)then + call_set=.true. + bc_side_t1=>BC_t1%north + is0=lbound(BC_t1%north%q_con_BC,1) + ie0=ubound(BC_t1%north%q_con_BC,1) + js0=lbound(BC_t1%north%q_con_BC,2) + je0=ubound(BC_t1%north%q_con_BC,2) + endif + endif +! + if(nside==2)then + if(south_bc)then + call_set=.true. + bc_side_t1=>BC_t1%south + is0=lbound(BC_t1%south%q_con_BC,1) + ie0=ubound(BC_t1%south%q_con_BC,1) + js0=lbound(BC_t1%south%q_con_BC,2) + je0=ubound(BC_t1%south%q_con_BC,2) + endif + endif +! + if(nside==3)then + if(east_bc)then + call_set=.true. + bc_side_t1=>BC_t1%east + is0=lbound(BC_t1%east%q_con_BC,1) + ie0=ubound(BC_t1%east%q_con_BC,1) + js0=lbound(BC_t1%east%q_con_BC,2) + je0=ubound(BC_t1%east%q_con_BC,2) + endif + endif +! + if(nside==4)then + if(west_bc)then + call_set=.true. + bc_side_t1=>BC_t1%west + is0=lbound(BC_t1%west%q_con_BC,1) + ie0=ubound(BC_t1%west%q_con_BC,1) + js0=lbound(BC_t1%west%q_con_BC,2) + je0=ubound(BC_t1%west%q_con_BC,2) + endif + endif +! + if(call_set)then + do k=1,klev_out + do j=js0,je0 + do i=is0,ie0 + bc_side_t1%q_con_BC(i,j,k)=bc_side_t1%q_BC(i,j,k,liq_water_index) + enddo + enddo + enddo + endif +! + enddo +! +!----------------------------------------------------------------------- +! + end subroutine fill_q_con_BC +#endif +! +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! #ifdef MOIST_CAPPA - if(north_bc)then - i1=lbound(BC_t1%north%cappa_BC,1) - i2=ubound(BC_t1%north%cappa_BC,1) - j1=lbound(BC_t1%north%cappa_BC,2) - j2=ubound(BC_t1%north%cappa_BC,2) - cappa =>BC_t1%north%cappa_BC - temp =>BC_t1%north%pt_BC - liq_wat=>BC_t1%north%q_BC(:,:,:,liq_wat_index) - sphum =>BC_t1%north%q_BC(:,:,:,sphum_index) - call compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) - endif + subroutine fill_cappa_BC ! - if(south_BC)then - i1=lbound(BC_t1%south%cappa_BC,1) - i2=ubound(BC_t1%south%cappa_BC,1) - j1=lbound(BC_t1%south%cappa_BC,2) - j2=ubound(BC_t1%south%cappa_BC,2) - cappa =>BC_t1%south%cappa_BC - temp =>BC_t1%south%pt_BC - liq_wat=>BC_t1%south%q_BC(:,:,:,liq_wat_index) - sphum =>BC_t1%south%q_BC(:,:,:,sphum_index) - call compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) - endif +!----------------------------------------------------------------------- +!*** Compute cappa in the regional domain boundary area following +!*** Zhao-Carr microphysics. +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- ! - if(east_bc)then - i1=lbound(BC_t1%east%cappa_BC,1) - i2=ubound(BC_t1%east%cappa_BC,1) - j1=lbound(BC_t1%east%cappa_BC,2) - j2=ubound(BC_t1%east%cappa_BC,2) - cappa =>BC_t1%east%cappa_BC - temp =>BC_t1%east%pt_BC - liq_wat=>BC_t1%east%q_BC(:,:,:,liq_wat_index) - sphum =>BC_t1%east%q_BC(:,:,:,sphum_index) - call compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) - endif +!--------------------- +!*** Local variables +!--------------------- ! - if(west_bc)then - i1=lbound(BC_t1%west%cappa_BC,1) - i2=ubound(BC_t1%west%cappa_BC,1) - j1=lbound(BC_t1%west%cappa_BC,2) - j2=ubound(BC_t1%west%cappa_BC,2) - cappa =>BC_t1%west%cappa_BC - temp =>BC_t1%west%pt_BC - liq_wat=>BC_t1%west%q_BC(:,:,:,liq_wat_index) - sphum =>BC_t1%west%q_BC(:,:,:,sphum_index) - call compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) - endif + integer :: i1,i2,j1,j2,nside +! + real,dimension(:,:,:),pointer :: cappa,temp,liq_wat,sphum +! + logical :: call_compute +! +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! + do nside=1,4 + call_compute=.false. +! + if(nside==1)then + if(north_bc)then + call_compute=.true. + bc_side_t1=>BC_t1%north + endif + endif +! + if(nside==2)then + if(south_bc)then + call_compute=.true. + bc_side_t1=>BC_t1%south + endif + endif +! + if(nside==3)then + if(east_bc)then + call_compute=.true. + bc_side_t1=>BC_t1%east + endif + endif +! + if(nside==4)then + if(west_bc)then + call_compute=.true. + bc_side_t1=>BC_t1%west + endif + endif +! + if(call_compute)then + i1=lbound(bc_side_t1%cappa_BC,1) + i2=ubound(bc_side_t1%cappa_BC,1) + j1=lbound(bc_side_t1%cappa_BC,2) + j2=ubound(bc_side_t1%cappa_BC,2) + cappa =>bc_side_t1%cappa_BC + temp =>bc_side_t1%pt_BC + liq_wat=>bc_side_t1%q_BC(:,:,:,liq_water_index) + sphum =>bc_side_t1%q_BC(:,:,:,sphum_index) + call compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) + endif +! + enddo ! !----------------------------------------------------------------------- ! -#endif MOIST_CAPPA end subroutine fill_cappa_BC ! !----------------------------------------------------------------------- @@ -2876,17 +3008,14 @@ subroutine compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) implicit none !----------------------------------------------------------------------- ! -!--------------------- -!*** Input variables -!--------------------- +!------------------------ +!*** Argument variables +!------------------------ ! integer,intent(in) :: i1,i2,j1,j2 ! - real,dimension(i1:i2,j1:j2,1:npz) :: cappa,temp,liq_wat,sphum -! -!---------------------- -!*** Output variables -!---------------------- + real,dimension(i1:i2,j1:j2,1:npz),intent(in) :: temp,liq_wat,sphum + real,dimension(i1:i2,j1:j2,1:npz),intent(inout) :: cappa ! !--------------------- !*** Local variables @@ -2919,7 +3048,7 @@ subroutine compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) ql=qd-qs qv=max(0.,sphum(i,j,k)) cvm=(1.-(qv+qd))*cv_air + qv*cv_vap + ql*c_liq + qs*c_ice - ! +! cappa(i,j,k)=rdgas/(rdgas+cvm/(1.+zvir*sphum(i,j,k))) ! enddo @@ -2929,12 +3058,12 @@ subroutine compute_cappa(i1,i2,j1,j2,cappa,temp,liq_wat,sphum) !----------------------------------------------------------------------- ! end subroutine compute_cappa +#endif ! !----------------------------------------------------------------------- ! end subroutine regional_bc_data - !----------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !----------------------------------------------------------------------- @@ -2945,12 +3074,12 @@ subroutine read_regional_bc_file(is_input,ie_input & ,var_name_root & ,array_3d & ,array_4d & - ,tlev ) + ,tlev & + ,required ) !----------------------------------------------------------------------- !*** Read the boundary data from the external file generated by !*** chgres. !----------------------------------------------------------------------- - use netcdf !----------------------------------------------------------------------- implicit none !----------------------------------------------------------------------- @@ -2968,7 +3097,8 @@ subroutine read_regional_bc_file(is_input,ie_input & ! integer,intent(in),optional :: tlev !<-- Position of current tracer among all of them ! - character(len= 7),intent(in) :: var_name_root !<-- Root of variable name in the boundary file + character(len=*),intent(in) :: var_name_root !<-- Root of variable name in the boundary file + logical,intent(in),optional :: required ! !------------ !*** Output @@ -2988,112 +3118,41 @@ subroutine read_regional_bc_file(is_input,ie_input & ,j_count,j_start_array,j_start_data,j_end_array ! integer :: dim_id,nctype,ndims,var_id + integer :: nside,status ! character(len=5) :: dim_name_x & !<-- Dimension names in ,dim_name_y ! the BC file ! - character(len=20) :: var_name !<-- Variable name in the boundary NetCDF file + character(len=80) :: var_name !<-- Variable name in the boundary NetCDF file ! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- + logical :: call_get_var,is_root_pe + logical :: required_local ! !----------------------------------------------------------------------- -!*** Set the dimension information for the given side of the domain. +!*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- -!*** First consider the north and south sides of the regional domain. -!*** Take care of the dimensions' names, IDs, and lengths. +!*** Process optional argument required, default value is .true. !----------------------------------------------------------------------- ! - if(north_bc)then -! - dim_name_x='lon' - if(var_name_root=='u_w'.or.var_name_root=='v_w')then - dim_name_x='lonp' !<-- Wind components on west/east sides of cells - endif -! - call check(nf90_inq_dimid(ncid,dim_name_x,dim_id)) !<-- Obtain the dimension ID of the x coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=lon)) !<-- # of points in the x dimension (lon) -! - dim_name_y='halo' - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - dim_name_y='halop' !<-- Wind components on south/north sides of cells - endif + if(present(required)) then + required_local=required + else + required_local=.true. + endif ! - call check(nf90_inq_dimid(ncid,dim_name_y,dim_id)) !<-- Obtain the dimension ID of the y coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=halo)) !<-- # of points in the y dimension (halo) + is_root_pe=(mpp_pe()==mpp_root_pe()) ! !----------------------------------------------------------------------- -!*** Construct the variable's name in the NetCDF file and set -!*** the start locations and point counts for the data file and -!*** for the BC arrays being filled. The input array begins -!*** receiving data at (i_start_array,j_start_array), etc. -!*** The read of the data for the given input array begins at -!*** (i_start_data,j_start_data) and encompasses i_count by -!*** j_count datapoints in each direction. +!*** Loop through the four sides of the domain. !----------------------------------------------------------------------- -! - var_name=trim(var_name_root)//"_bottom" -! - i_start_array=is_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 - else - j_end_array =js_input+nhalo_data-1 - endif -! - i_start_data=i_start_array+nhalo_data !<-- File data begins at 1. - i_count=i_end_array-i_start_array+1 - j_start_data=1 - j_count=j_end_array-j_start_array+1 ! !----------------------------------------------------------------------- -!*** Fill this task's subset of north boundary data for -!*** this 3-D or 4-D variable. + sides: do nside=1,4 !----------------------------------------------------------------------- ! - call check(nf90_inq_varid(ncid,var_name,var_id)) !<-- Get this variable's ID. -! - if(present(array_4d))then !<-- 4-D variable - call check(nf90_get_var(ncid,var_id & - ,array_4d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,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. -! - else !<-- 3-D variable - call check(nf90_get_var(ncid,var_id & - ,array_3d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,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 ! north_bc -! - if(south_bc)then -! - dim_name_x='lon' - if(var_name_root=='u_w'.or.var_name_root=='v_w')then - dim_name_x='lonp' !<-- Wind components on west/east sides of cells - endif -! - call check(nf90_inq_dimid(ncid,dim_name_x,dim_id)) !<-- Obtain the dimension ID of the x coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=lon)) !<-- # of points in the x dimension (lon) -! - dim_name_y='halo' - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - dim_name_y='halop' !<-- Wind components on south/north sides of cells - endif -! - call check(nf90_inq_dimid(ncid,dim_name_y,dim_id)) !<-- Obtain the dimension ID of the y coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=halo)) !<-- # of points in the y dimension (halo) + call_get_var=.false. ! !----------------------------------------------------------------------- !*** Construct the variable's name in the NetCDF file and set @@ -3105,227 +3164,185 @@ subroutine read_regional_bc_file(is_input,ie_input & !*** j_count datapoints in each direction. !----------------------------------------------------------------------- ! - var_name=trim(var_name_root)//"_top" -! - i_start_array=is_input - i_end_array =ie_input - j_start_array=je_input-nhalo_data+1 - j_end_array =je_input +!----------- +!*** North +!----------- ! - i_start_data=i_start_array+nhalo_data !<-- File data begins at 1. - i_count=i_end_array-i_start_array+1 - j_start_data=1 - j_count=j_end_array-j_start_array+1 + if(nside==1)then + if(north_bc)then + call_get_var=.true. ! -!----------------------------------------------------------------------- -!*** Fill this task's subset of south boundary data for -!*** this 3-D or 4-D variable. -!----------------------------------------------------------------------- + var_name=trim(var_name_root)//"_bottom" ! - call check(nf90_inq_varid(ncid,var_name,var_id)) !<-- Get this variable's ID. + i_start_array=is_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+nrows_blend + else + j_end_array=js_input+nhalo_data+nrows_blend-1 + endif ! - if(present(array_4d))then !<-- 4-D variable - call check(nf90_get_var(ncid,var_id & - ,array_4d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,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. + 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 ! - else !<-- 3-D variable - call check(nf90_get_var(ncid,var_id & - ,array_3d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,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 ! - endif ! south_bc +!----------- +!*** South +!----------- ! -!----------------------------------------------------------------------- -!*** Now consider the east and west sides of the regional domain. -!*** Take care of the dimensions' names, IDs, and lengths. -!----------------------------------------------------------------------- + if(nside==2)then + if(south_bc)then + call_get_var=.true. ! - if(east_bc)then + var_name=trim(var_name_root)//"_top" ! - dim_name_x='halo' - if(var_name_root=='u_w'.or.var_name_root=='v_w')then - dim_name_x='halop' !<-- Wind components on west/east sides of cells - endif + i_start_array=is_input + i_end_array =ie_input + j_start_array=je_input-nhalo_data-nrows_blend+1 + j_end_array =je_input ! - call check(nf90_inq_dimid(ncid,dim_name_x,dim_id)) !<-- Obtain the dimension ID of the x coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=halo)) !<-- # of points in the x dimension (halo) + 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 ! - dim_name_y='lat' - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - dim_name_y='latm' !<-- Wind components on south/north sides of cells + endif + endif ! -!----------------------------------------------------------------------- -!*** Note that latm=lat-1. The reason the y extent of u_s and v_s -!*** is 1 less than the regular y extent of the west/east sides is -!*** that the north/south pieces of data for those variables already -!*** includes the values on both the south and north ends of the -!*** west and east sides which reduces the total number of values -!*** of u_s and v_s by 1. -!----------------------------------------------------------------------- +!---------- +!*** East +!---------- ! - endif + if(nside==3)then + if(east_bc)then + call_get_var=.true. ! - call check(nf90_inq_dimid(ncid,dim_name_y,dim_id)) !<-- Obtain the dimension ID of the y coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=lat)) !<-- # of points in the y dimension (lat) + var_name=trim(var_name_root)//"_left" ! -!----------------------------------------------------------------------- -!*** Construct the variable's name in the NetCDF file and set -!*** the start locations and point counts in the data file and -!*** in the BC arrays being filled. -!----------------------------------------------------------------------- + j_start_array=js_input + j_end_array =je_input ! - j_start_array=js_input - j_end_array =je_input + i_start_array=is_input ! - var_name=trim(var_name_root)//"_left" + if(trim(var_name_root)=='u_w'.or.trim(var_name_root)=='v_w')then + i_end_array=is_input+nhalo_data+nrows_blend + else + i_end_array=is_input+nhalo_data+nrows_blend-1 + endif ! - i_start_array=is_input + if(north_bc)then + if(trim(var_name_root)=='u_s'.or.trim(var_name_root)=='v_s')then + j_start_array=js_input+nhalo_data+1 + else + j_start_array=js_input+nhalo_data + endif + endif + if(south_bc)then + j_end_array =je_input-nhalo_data + endif ! - if(var_name_root=='u_w'.or.var_name_root=='v_w')then - i_end_array=is_input+nhalo_data - else - i_end_array=is_input+nhalo_data-1 - endif + i_start_data=1 + i_count=i_end_array-i_start_array+1 + if(trim(var_name_root)=='u_s'.or.trim(var_name_root)=='v_s')then + j_start_data=j_start_array-1 + else + j_start_data=j_start_array + endif + j_count=j_end_array-j_start_array+1 ! - if(north_bc)then - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - j_start_array=js_input+nhalo_data+1 - else - j_start_array=js_input+nhalo_data endif endif - if(south_bc)then - j_end_array =je_input-nhalo_data - endif -! - i_start_data=1 - i_count=i_end_array-i_start_array+1 - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - j_start_data=j_start_array-1 - else - j_start_data=j_start_array - endif - j_count=j_end_array-j_start_array+1 ! -!----------------------------------------------------------------------- -!*** Fill this task's subset of east boundary data. -!----------------------------------------------------------------------- -! - call check(nf90_inq_varid(ncid,var_name,var_id)) !<-- Get this variable's ID. -! - if(present(array_4d))then !<-- 4-D variable - call check(nf90_get_var(ncid,var_id & - ,array_4d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,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. +!---------- +!*** West +!---------- ! - else !<-- 3-D variable - call check(nf90_get_var(ncid,var_id & - ,array_3d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,1:nlev) & - ,start=(/i_start_data,j_start_data/) & !<-- Start reading the data array here. - ,count=(/i_count,j_count,nlev/))) !<-- Extent of data to read in each dimension. - endif + if(nside==4)then + if(west_bc)then + call_get_var=.true. ! - endif ! east_bc + var_name=trim(var_name_root)//"_right" ! - if(west_bc)then + j_start_array=js_input + j_end_array =je_input ! - dim_name_x='halo' - if(var_name_root=='u_w'.or.var_name_root=='v_w')then - dim_name_x='halop' !<-- Wind components on west/east sides of cells - endif + i_start_array=ie_input-nhalo_data-nrows_blend+1 + i_end_array=ie_input ! - call check(nf90_inq_dimid(ncid,dim_name_x,dim_id)) !<-- Obtain the dimension ID of the x coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=halo)) !<-- # of points in the x dimension (halo) + if(north_bc)then + if(trim(var_name_root)=='u_s'.or.trim(var_name_root)=='v_s')then + j_start_array=js_input+nhalo_data+1 + else + j_start_array=js_input+nhalo_data + endif + endif ! - dim_name_y='lat' - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - dim_name_y='latm' !<-- Wind components on south/north sides of cells + if(south_bc)then + j_end_array =je_input-nhalo_data + endif ! -!----------------------------------------------------------------------- -!*** Note that latm=lat-1. The reason the y extent of u_s and v_s -!*** is 1 less than the regular y extent of the west/east sides is -!*** that the north/south pieces of data for those variables already -!*** includes the values on both the south and north ends of the -!*** west and east sides which reduces the total number of values -!*** of u_s and v_s by 1. -!----------------------------------------------------------------------- + i_start_data=1 + i_count=i_end_array-i_start_array+1 + if(trim(var_name_root)=='u_s'.or.trim(var_name_root)=='v_s')then + j_start_data=j_start_array-1 + else + j_start_data=j_start_array + endif + j_count=j_end_array-j_start_array+1 ! + endif endif -! - call check(nf90_inq_dimid(ncid,dim_name_y,dim_id)) !<-- Obtain the dimension ID of the y coordinate. - call check(nf90_inquire_dimension(ncid,dim_id,len=lat)) !<-- # of points in the y dimension (lat) ! !----------------------------------------------------------------------- -!*** Construct the variable's name in the NetCDF file and set -!*** the start locations and point counts in the data file and -!*** in the BC arrays being filled. +!*** Fill this task's subset of boundary data for this 3-D +!*** 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. !----------------------------------------------------------------------- ! - j_start_array=js_input - j_end_array =je_input -! - var_name=trim(var_name_root)//"_right" -! - i_start_array=ie_input-nhalo_data+1 - i_end_array=ie_input -! - if(north_bc)then - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - j_start_array=js_input+nhalo_data+1 - else - j_start_array=js_input+nhalo_data - endif - endif - if(south_bc)then - j_end_array =je_input-nhalo_data - endif + if(call_get_var)then + if (present(array_4d)) then !<-- 4-D variable + status=nf90_inq_varid(ncid,trim(var_name),var_id) !<-- Get this variable's ID. + if (required_local) then + call check(status) + endif + if (status /= nf90_noerr) then + if (east_bc.and.is_master()) write(0,*)' WARNING: Tracer ',trim(var_name),' not in input file' + array_4d(:,:,:,tlev)=0. !<-- Tracer not in input so set to zero in boundary. ! - i_start_data=1 - i_count=i_end_array-i_start_array+1 - if(var_name_root=='u_s'.or.var_name_root=='v_s')then - j_start_data=j_start_array-1 - else - j_start_data=j_start_array - endif - j_count=j_end_array-j_start_array+1 + blend_this_tracer(tlev)=.false. !<-- Tracer not in input so do not apply blending. ! -!----------------------------------------------------------------------- -!*** Fill this task's subset of east or west boundary data. -!----------------------------------------------------------------------- + else + call check(nf90_get_var(ncid,var_id & + ,array_4d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. + ,j_start_array:j_end_array & + ,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. ! - call check(nf90_inq_varid(ncid,var_name,var_id)) !<-- Get this variable's ID. + endif ! - if(present(array_4d))then !<-- 4-D variable - call check(nf90_get_var(ncid,var_id & - ,array_4d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,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. + else !<-- 3-D variable + call check(nf90_inq_varid(ncid,trim(var_name),var_id)) !<-- Get this variable's ID. + call check(nf90_get_var(ncid,var_id & + ,array_3d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. + ,j_start_array:j_end_array & + ,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. ! - else !<-- 3-D variable - call check(nf90_get_var(ncid,var_id & - ,array_3d(i_start_array:i_end_array & !<-- Fill this task's domain boundary halo. - ,j_start_array:j_end_array & - ,1:nlev) & - ,start=(/i_start_data,j_start_data/) & !<-- Start reading the data array here. - ,count=(/i_count,j_count,nlev/))) !<-- Extent of data to read in each dimension. + endif endif ! - endif ! west_bc + enddo sides ! !----------------------------------------------------------------------- ! @@ -3336,13 +3353,13 @@ end subroutine read_regional_bc_file !----------------------------------------------------------------------- ! subroutine check(status) - use netcdf integer,intent(in) :: status ! if(status /= nf90_noerr) then write(0,*)' check netcdf status=',status call mpp_error(FATAL, ' NetCDF error ' // trim(nf90_strerror(status))) endif +! end subroutine check ! !----------------------------------------------------------------------- @@ -3357,7 +3374,8 @@ subroutine allocate_regional_BC_arrays(side & ,is_we,ie_we,js_we,je_we & ,klev & ,ntracers & - ,BC_side ) + ,BC_side & + ,delz_side ) ! !----------------------------------------------------------------------- implicit none @@ -3378,6 +3396,8 @@ subroutine allocate_regional_BC_arrays(side & logical,intent(in) :: north_bc,south_bc,east_bc,west_bc !<-- Which sides is this task on? ! type(fv_regional_BC_variables),intent(out) :: BC_side +! + real,dimension(:,:,:),pointer,intent(inout),optional :: delz_side !<-- Boundary delz that follows integration through time. ! !--------------------------------------------------------------------- !********************************************************************* @@ -3388,442 +3408,60 @@ subroutine allocate_regional_BC_arrays(side & endif ! allocate(BC_side%delp_BC (is_0:ie_0,js_0:je_0,klev)) ; BC_side%delp_BC=real_snan + allocate(BC_side%divgd_BC(is_we:ie_we,js_sn:je_sn,klev)) ; BC_side%divgd_BC=real_snan ! allocate(BC_side%q_BC (is_0:ie_0,js_0:je_0,1:klev,1:ntracers)) ; BC_side%q_BC=real_snan +! + if(.not.allocated(blend_this_tracer))then + allocate(blend_this_tracer(1:ntracers)) + blend_this_tracer=.true. !<-- Start with blending all tracers. + endif ! #ifndef SW_DYNAMICS allocate(BC_side%pt_BC (is_0:ie_0,js_0:je_0,klev)) ; BC_side%pt_BC=real_snan allocate(BC_side%w_BC (is_0:ie_0,js_0:je_0,klev)) ; BC_side%w_BC=real_snan allocate(BC_side%delz_BC (is_0:ie_0,js_0:je_0,klev)) ; BC_side%delz_BC=real_snan + if(present(delz_side))then + if(.not.associated(delz_side))then + allocate(delz_side (is_0:ie_0,js_0:je_0,klev)) ; delz_side=real_snan + endif + endif #ifdef USE_COND allocate(BC_side%q_con_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%q_con_BC=real_snan -#ifdef MOIST_CAPPA - allocate(BC_side%cappa_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%cappa_BC=real_snan -#endif -#endif -#endif -! -!-------------------- -!*** Wind components -!-------------------- -! -!** D-grid u, C-grid v -! - allocate(BC_side%u_BC (is_sn:ie_sn, js_sn:je_sn, klev)) ; BC_side%u_BC=real_snan - allocate(BC_side%vc_BC(is_sn:ie_sn, js_sn:je_sn, klev)) ; BC_side%vc_BC=real_snan -! -!** C-grid u, D-grid v -! - allocate(BC_side%uc_BC(is_we:ie_we, js_we:je_we, klev)) ; BC_side%uc_BC=real_snan - allocate(BC_side%v_BC (is_we:ie_we, js_we:je_we, klev)) ; BC_side%v_BC=real_snan - allocate(BC_side%divgd_BC(is_we:ie_we,js_sn:je_sn,klev)) ; BC_side%divgd_BC=real_snan -! -!--------------------------------------------------------------------- -! - end subroutine allocate_regional_BC_arrays -! -!--------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!--------------------------------------------------------------------- - -subroutine remap_scalar_nggps_regional_bc(Atm & - ,side & - ,isd,ied,jsd,jed & - ,is_bc,ie_bc,js_bc,je_bc & - ,km, npz, ncnst, ak0, bk0 & - ,psc, qa, omga, zh & - ,phis_reg & - ,ps & - ,BC_side ) - - type(fv_atmos_type), intent(inout) :: Atm - integer, intent(in):: isd,ied,jsd,jed !<-- index limits of the Atm arrays w/halo=nhalo_model - integer, intent(in):: is_bc,ie_bc,js_bc,je_bc !<-- index limits of working arrays on boundary task subdomains (halo=nhalo_data) - integer, intent(in):: km & !<-- # of levels in 3-D input variables - ,npz & !<-- # of levels in final 3-D integration variables - ,ncnst !<-- # of tracer variables - real, intent(in):: ak0(km+1), bk0(km+1) - real, intent(in), dimension(is_bc:ie_bc,js_bc:je_bc):: psc - 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 - type(fv_regional_BC_variables),intent(inout) :: BC_side !<-- The BC variables on a domain side at the final integration levels. - -! local: -! - real, dimension(:,:),allocatable :: pe0 - real, dimension(:,:),allocatable :: qn1 - real, dimension(:,:),allocatable :: dp2 - real, dimension(:,:),allocatable :: pe1 - real, dimension(:,:),allocatable :: qp -! - real wk(is_bc:ie_bc,js_bc:je_bc) - real, dimension(is_bc:ie_bc,js_bc:je_bc):: phis - -!!! High-precision - real(kind=R_GRID), dimension(is_bc:ie_bc,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(is_bc:ie_bc,km+1):: pn0 - real(kind=R_GRID):: pst -!!! High-precision - integer i,ie,is,je,js,k,l,m, k2,iq - integer sphum, o3mr, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt -! -!--------------------------------------------------------------------------------- -! - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') - cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') - o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') - - k2 = max(10, km/2) - - if (mpp_pe()==1) then - print *, 'sphum = ', sphum - print *, 'clwmr = ', liq_wat - print *, ' o3mr = ', o3mr - print *, 'ncnst = ', ncnst - endif - - if ( sphum/=1 ) then - call mpp_error(FATAL,'SPHUM must be 1st tracer') - endif -! -!--------------------------------------------------------------------------------- -!*** First compute over the extended boundary regions with halo=nhalo_data. -!*** This is needed to obtain pressures that will surround the wind points. -!--------------------------------------------------------------------------------- -! - is=is_bc - if(side=='west')then - is=ie_bc-nhalo_data+1 - endif -! - ie=ie_bc - if(side=='east')then - ie=is_bc+nhalo_data-1 - endif -! - js=js_bc - if(side=='south')then - js=je_bc-nhalo_data+1 - endif -! - je=je_bc - if(side=='north')then - je=js_bc+nhalo_data-1 - endif -! - - allocate(pe0(is:ie,km+1)) ; pe0=real_snan - allocate(qn1(is:ie,npz)) ; qn1=real_snan - allocate(dp2(is:ie,npz)) ; dp2=real_snan - allocate(pe1(is:ie,npz+1)) ; pe1=real_snan - allocate(qp (is:ie,km)) ; qp=real_snan -! -!--------------------------------------------------------------------------------- - jloop1: do 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( phis_reg(i,j).le.gz(k) .and. phis_reg(i,j).ge.gz(k+1) ) then - pst = pn(k) + (pn(k+1)-pn(k))*(gz(k)-phis_reg(i,j))/(gz(k)-gz(k+1)) - go to 123 - endif - enddo - 123 ps(i,j) = exp(pst) - - enddo ! i-loop - -!--------------------------------------------------------------------------------- - enddo jloop1 -!--------------------------------------------------------------------------------- - -!--------------------------------------------------------------------------------- -!*** Transfer values from the expanded boundary array for sfc pressure into -!*** the Atm object. -!--------------------------------------------------------------------------------- -! - is=lbound(Atm%ps,1) - ie=ubound(Atm%ps,1) - js=lbound(Atm%ps,2) - je=ubound(Atm%ps,2) -! - do j=js,je - do i=is,ie - Atm%ps(i,j)=ps(i,j) - enddo - enddo -! -!--------------------------------------------------------------------------------- -!*** Now compute over the normal boundary regions with halo=nhalo_model. -!*** 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. -!--------------------------------------------------------------------------------- -! - is=lbound(BC_side%delp_BC,1) - ie=ubound(BC_side%delp_BC,1) - js=lbound(BC_side%delp_BC,2) - je=ubound(BC_side%delp_BC,2) -! -!--------------------------------------------------------------------------------- - jloop2: do 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 - 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(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) - BC_side%delp_BC(i,j,k) = dp2(i,k) - enddo - enddo - -! Need to set unassigned tracers to 0?? -! map shpum, o3mr, liq_wat 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 - BC_side%q_BC(i,j,k,iq) = qn1(i,k) - enddo - enddo - enddo - -!--------------------------------------------------- -! Retrieve temperature using GFS geopotential height -!--------------------------------------------------- -! - i_loop: 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) = phis_reg(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 - -!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -!xxx DO WE NEED Atm%peln to have values in the boundary region? -!xxx FOR NOW COMMENT IT OUT. -!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -!xxx do k=1,npz+1 -!xxx Atm%peln(i,k,j) = pn1(i,k) -!xxx enddo - -! Compute true temperature using hydrostatic balance - do k=1,npz - BC_side%pt_BC(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*(1.+zvir*BC_side%q_BC(i,j,k,sphum)) ) - enddo - - if ( .not. Atm%flagstruct%hydrostatic ) then - do k=1,npz - BC_side%delz_BC(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 ( Atm%flagstruct%nwat .eq. 6 ) then - do k=1,npz - do i=is,ie - qn1(i,k) = BC_side%q_BC(i,j,k,liq_wat) - BC_side%q_BC(i,j,k,rainwat) = 0. - BC_side%q_BC(i,j,k,snowwat) = 0. - BC_side%q_BC(i,j,k,graupel) = 0. - if (cld_amt .gt. 0) BC_side%q_BC(i,j,k,cld_amt) = 0. - if ( BC_side%pt_BC(i,j,k) > 273.16 ) then ! > 0C all liq_wat - BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k) - BC_side%q_BC(i,j,k,ice_wat) = 0. -#ifdef ORIG_CLOUDS_PART - else if ( BC_side%pt_BC(i,j,k) < 258.16 ) then ! < -15C all ice_wat - BC_side%q_BC(i,j,k,liq_wat) = 0. - BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - else ! between -15~0C: linear interpolation - BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k)*((BC_side%pt_BC(i,j,k)-258.16)/15.) - BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - BC_side%q_BC(i,j,k,liq_wat) - endif -#else - else if ( BC_side%pt_BC(i,j,k) < 233.16 ) then ! < -40C all ice_wat - BC_side%q_BC(i,j,k,liq_wat) = 0. - BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - else - if ( k.eq.1 ) then ! between [-40,0]: linear interpolation - BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k)*((BC_side%pt_BC(i,j,k)-233.16)/40.) - BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - BC_side%q_BC(i,j,k,liq_wat) - else - if (BC_side%pt_BC(i,j,k)<258.16 .and. BC_side%q_BC(i,j,k-1,ice_wat)>1.e-5 ) then - BC_side%q_BC(i,j,k,liq_wat) = 0. - BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - else ! between [-40,0]: linear interpolation - BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k)*((BC_side%pt_BC(i,j,k)-233.16)/40.) - BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - BC_side%q_BC(i,j,k,liq_wat) - endif - endif - endif -#endif - call mp_auto_conversion(BC_side%q_BC(i,j,k,liq_wat), BC_side%q_BC(i,j,k,rainwat), & - BC_side%q_BC(i,j,k,ice_wat), BC_side%q_BC(i,j,k,snowwat) ) - enddo - enddo - endif - -!------------------------------------------------------------- -! 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) - do k=1,npz - do i=is,ie - BC_side%w_BC(i,j,k) = qn1(i,k)/BC_side%delp_BC(i,j,k)*BC_side%delz_BC(i,j,k) - enddo - enddo - endif - - 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.) - 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) - - 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) - if (is_master()) write(*,*) 'done remap_scalar_nggps_regional_bc' -!--------------------------------------------------------------------- - - end subroutine remap_scalar_nggps_regional_bc - -!--------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +#ifdef MOIST_CAPPA + allocate(BC_side%cappa_BC(is_0:ie_0,js_0:je_0,klev)) ; BC_side%cappa_BC=real_snan +#endif +#endif +#endif +! +!-------------------- +!*** Wind components +!-------------------- +! +!** D-grid u, C-grid v +! + allocate(BC_side%u_BC (is_sn:ie_sn, js_sn:je_sn, klev)) ; BC_side%u_BC=real_snan + allocate(BC_side%vc_BC(is_sn:ie_sn, js_sn:je_sn, klev)) ; BC_side%vc_BC=real_snan +! +!** C-grid u, D-grid v +! + allocate(BC_side%uc_BC(is_we:ie_we, js_we:je_we, klev)) ; BC_side%uc_BC=real_snan + allocate(BC_side%v_BC (is_we:ie_we, js_we:je_we, klev)) ; BC_side%v_BC=real_snan +! !--------------------------------------------------------------------- - +! + end subroutine allocate_regional_BC_arrays +! !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- -subroutine remap_scalar_regional_bc_nh(Atm & +subroutine remap_scalar_nggps_regional_bc(Atm & ,side & ,isd,ied,jsd,jed & ,is_bc,ie_bc,js_bc,je_bc & ,km, npz, ncnst, ak0, bk0 & - ,psc, qa, w, pt, zh & + ,psc, t_in, qa, omga, zh & ,phis_reg & ,ps & ,BC_side ) @@ -3836,10 +3474,10 @@ subroutine remap_scalar_regional_bc_nh(Atm & ,ncnst !<-- # of tracer variables real, intent(in):: ak0(km+1), bk0(km+1) real, intent(in), dimension(is_bc:ie_bc,js_bc:je_bc):: psc - real, intent(in), dimension(is_bc:ie_bc,js_bc:je_bc,km):: w, pt + real, intent(in), dimension(is_bc:ie_bc,js_bc:je_bc,km):: t_in + 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 - 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 @@ -3863,19 +3501,19 @@ subroutine remap_scalar_regional_bc_nh(Atm & real(kind=R_GRID), dimension(is_bc:ie_bc,km+1):: pn0 real(kind=R_GRID):: pst !!! High-precision - integer i,ie,is,je,js,k,l,m, k2,iq + integer i,ie,is,j,je,js,k,l,m, k2,iq integer sphum, o3mr, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt ! !--------------------------------------------------------------------------------- ! - sphum = get_tracer_index(MODEL_ATMOS, 'sphum') - liq_wat = get_tracer_index(MODEL_ATMOS, 'liq_wat') - ice_wat = get_tracer_index(MODEL_ATMOS, 'ice_wat') - rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') - snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') - graupel = get_tracer_index(MODEL_ATMOS, 'graupel') - cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') - o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') + sphum = sphum_index + liq_wat = liq_water_index + ice_wat = ice_water_index + rainwat = rain_water_index + snowwat = snow_water_index + graupel = graupel_index + cld_amt = cld_amt_index + o3mr = o3mr_index k2 = max(10, km/2) @@ -3884,6 +3522,7 @@ subroutine remap_scalar_regional_bc_nh(Atm & print *, 'clwmr = ', liq_wat print *, ' o3mr = ', o3mr print *, 'ncnst = ', ncnst + print *, 'ntracers = ', ntracers endif if ( sphum/=1 ) then @@ -3897,25 +3536,24 @@ subroutine remap_scalar_regional_bc_nh(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 allocate(qn1(is:ie,npz)) ; qn1=real_snan allocate(dp2(is:ie,npz)) ; dp2=real_snan @@ -3977,7 +3615,8 @@ subroutine remap_scalar_regional_bc_nh(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. !--------------------------------------------------------------------------------- @@ -4016,9 +3655,10 @@ subroutine remap_scalar_regional_bc_nh(Atm & enddo enddo -! Need to set unassigned tracers to 0?? ! map shpum, o3mr, liq_wat tracers do iq=1,ncnst +! if (iq == sphum .or. iq == liq_wat .or. iq == o3mr) then ! only remap if the data is already set + if (iq /= cld_amt) then ! don't remap cld_amt do k=1,km do i=is,ie qp(i,k) = qa(i,j,k,iq) @@ -4028,7 +3668,7 @@ subroutine remap_scalar_regional_bc_nh(Atm & 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) + call fillq(ie-is+1, npz, 1, qn1, dp2) else call fillz(ie-is+1, npz, 1, qn1, dp2) endif @@ -4038,76 +3678,66 @@ subroutine remap_scalar_regional_bc_nh(Atm & BC_side%q_BC(i,j,k,iq) = qn1(i,k) enddo enddo - enddo - -! map virtual temperature - - do k=1,km - do i=is,ie - qp(i,k) = pt(i,j,k) - enddo - enddo - call mappm(km, log(pe0), qp, npz, log(pe1), qn1, is,ie, 2, 4, Atm%ptop) - do k=1,npz - do i=is,ie - BC_side%pt_BC(i,j,k) = qn1(i,k) + else + ! Initialize cld_amt + do k=1,npz + do i=is,ie + BC_side%q_BC(i,j,k,iq) = 0. + enddo enddo + endif enddo -! call map_scalar(km, REAL(pn0), pt, pt(is:,j,km), & -! npz, REAL(pn1), BC_side%pt_BC, & -! is, ie, j, is_bc, ie_bc, js_bc, je_bc, 1, 8, 184.) - !--------------------------------------------------- ! Retrieve temperature using GFS geopotential height !--------------------------------------------------- ! - i_loop: do i=is,ie + i_loop: 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 + 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=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 + 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) = phis_reg(i,j) + gz_fv(npz+1) = phis_reg(i,j) - m = 1 + m = 1 - do k=1,npz + 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 + 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 + 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 + 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 +555 m = l + enddo !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx !xxx DO WE NEED Atm%peln to have values in the boundary region? @@ -4117,79 +3747,150 @@ subroutine remap_scalar_regional_bc_nh(Atm & !xxx Atm%peln(i,k,j) = pn1(i,k) !xxx enddo +! Compute true temperature using hydrostatic balance if not read from input. + if ( .not. data_source_fv3gfs ) then + do k=1,npz + BC_side%pt_BC(i,j,k) = (gz_fv(k)-gz_fv(k+1))/( rdgas*(pn1(i,k+1)-pn1(i,k))*(1.+zvir*BC_side%q_BC(i,j,k,sphum)) ) + enddo + endif - - - if ( .not. Atm%flagstruct%hydrostatic ) then - do k=1,npz + if ( .not. Atm%flagstruct%hydrostatic ) then + do k=1,npz BC_side%delz_BC(i,j,k) = (gz_fv(k+1) - gz_fv(k)) / grav - enddo - endif + enddo + endif - enddo i_loop + enddo i_loop !----------------------------------------------------------------------- -! seperate cloud water and cloud ice +! separate cloud water and cloud ice ! From Jan-Huey Chen's HiRAM code !----------------------------------------------------------------------- - +! +! If the source is FV3GFS GAUSSIAN NEMSIO/NETCDF and GRIB2 FILE then all the tracers are in the boundary files +! and will be read in. +! If the source is from old GFS or operational GSM then the tracers will be fixed in the boundaries +! and may not provide a very good result +! + if ( .not. data_source_fv3gfs ) then if ( Atm%flagstruct%nwat .eq. 6 ) then do k=1,npz do i=is,ie - + qn1(i,k) = BC_side%q_BC(i,j,k,liq_wat) + BC_side%q_BC(i,j,k,rainwat) = 0. + BC_side%q_BC(i,j,k,snowwat) = 0. + BC_side%q_BC(i,j,k,graupel) = 0. + BC_side%q_BC(i,j,k,cld_amt) = 0. + if ( BC_side%pt_BC(i,j,k) > 273.16 ) then ! > 0C all liq_wat + BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k) + BC_side%q_BC(i,j,k,ice_wat) = 0. +#ifdef ORIG_CLOUDS_PART + else if ( BC_side%pt_BC(i,j,k) < 258.16 ) then ! < -15C all ice_wat + BC_side%q_BC(i,j,k,liq_wat) = 0. + BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) + else ! between -15~0C: linear interpolation + BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k)*((BC_side%pt_BC(i,j,k)-258.16)/15.) + BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - BC_side%q_BC(i,j,k,liq_wat) + endif +#else + else if ( BC_side%pt_BC(i,j,k) < 233.16 ) then ! < -40C all ice_wat + BC_side%q_BC(i,j,k,liq_wat) = 0. + BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) + else + if ( k.eq.1 ) then ! between [-40,0]: linear interpolation + BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k)*((BC_side%pt_BC(i,j,k)-233.16)/40.) + BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - BC_side%q_BC(i,j,k,liq_wat) + else + if (BC_side%pt_BC(i,j,k)<258.16 .and. BC_side%q_BC(i,j,k-1,ice_wat)>1.e-5 ) then + BC_side%q_BC(i,j,k,liq_wat) = 0. + BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) + else ! between [-40,0]: linear interpolation + BC_side%q_BC(i,j,k,liq_wat) = qn1(i,k)*((BC_side%pt_BC(i,j,k)-233.16)/40.) + BC_side%q_BC(i,j,k,ice_wat) = qn1(i,k) - BC_side%q_BC(i,j,k,liq_wat) + endif + endif + endif +#endif call mp_auto_conversion(BC_side%q_BC(i,j,k,liq_wat), BC_side%q_BC(i,j,k,rainwat), & BC_side%q_BC(i,j,k,ice_wat), BC_side%q_BC(i,j,k,snowwat) ) enddo enddo endif - + endif ! data source /= FV3GFS GAUSSIAN NEMSIO/NETCDF and GRIB2 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) = w(i,j,k) + qp(i,k) = omga(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 + + call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4, Atm%ptop) + + if ( data_source_fv3gfs ) then + do k=1,npz + do i=is,ie BC_side%w_BC(i,j,k) = qn1(i,k) - enddo - enddo + enddo + enddo +!------------------------------ +! Remap input T linearly in p. +!------------------------------ + do k=1,km + do i=is,ie + qp(i,k) = t_in(i,j,k) + enddo + enddo + + call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, 2, 4, Atm%ptop) + + do k=1,npz + do i=is,ie + BC_side%pt_BC(i,j,k) = qn1(i,k) + enddo + enddo + + else !<-- datasource /= 'FV3GFS GAUSSIAN NEMSIO/NETCDF and GRIB2 FILE' + do k=1,npz + do i=is,ie + BC_side%w_BC(i,j,k) = qn1(i,k)/BC_side%delp_BC(i,j,k)*BC_side%delz_BC(i,j,k) + enddo + enddo + endif + endif !.not. Atm%flagstruct%hydrostatic 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 -!call 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 -!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_regional_bc_nh' +! 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' !--------------------------------------------------------------------- - end subroutine remap_scalar_regional_bc_nh - - -!--------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!--------------------------------------------------------------------- + end subroutine remap_scalar_nggps_regional_bc !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -4314,18 +4015,24 @@ end subroutine remap_dwinds_regional_bc !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- - subroutine set_regional_BCs(delp,delz,w & - ,pt,q_con,cappa & + subroutine set_regional_BCs(delp,delz,w,pt & +#ifdef USE_COND + ,q_con & +#endif +#ifdef MOIST_CAPPA + ,cappa & +#endif ,q & ,u,v,uc,vc & - ,bd, nlayers, ntracers & + ,bd, nlayers & ,fcst_time ) ! !--------------------------------------------------------------------- -!*** Select the given variable's boundary data at the two +!*** Select the boundary variables' boundary data at the two !*** bracketing time levels and apply them to the updating -!*** of the variable's boundary region at the appropriate -!*** forecast time. +!*** of the variables' boundary regions at the appropriate +!*** forecast time. This is done at the beginning of every +!*** large timestep in fv_dynamics. !--------------------------------------------------------------------- implicit none !--------------------------------------------------------------------- @@ -4334,7 +4041,7 @@ subroutine set_regional_BCs(delp,delz,w & !*** Input variables !-------------------- ! - integer,intent(in) :: nlayers, ntracers + integer,intent(in) :: nlayers ! real,intent(in) :: fcst_time !<-- Current forecast time (sec) ! @@ -4348,15 +4055,19 @@ subroutine set_regional_BCs(delp,delz,w & delp & ,pt ! - real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: q_con,w - real,dimension(bd%is:, bd%js:, 1:),intent(out) :: delz + real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: w + real,dimension(bd%is:,bd%js:,1:),intent(out) :: delz +#ifdef USE_COND + real,dimension(bd%isd:,bd%jsd:,1:),intent(out) :: q_con +#endif + ! real,dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz,ntracers),intent(out) :: q ! #ifdef MOIST_CAPPA real,dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz),intent(out) :: cappa -#else - real,dimension(bd%isd:bd%isd,bd%jsd:bd%jsd,1),intent(out) :: cappa +!#else +! real,dimension(isd:isd,jsd:jsd,1),intent(out) :: cappa #endif ! real,dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz),intent(out) :: u,vc @@ -4378,25 +4089,26 @@ subroutine set_regional_BCs(delp,delz,w & !*** time level 0 to time level 1. !--------------------------------------------------------------------- ! - fraction_interval=mod(fcst_time,(bc_time_interval*3600.))/(bc_time_interval*3600.) + fraction_interval=mod(fcst_time,(bc_update_interval*3600.)) & + /(bc_update_interval*3600.) ! !--------------------------------------------------------------------- ! - if(north_bc)then !north BC is really our SOUTH bc ?!? + if(north_bc)then call bc_values_into_arrays(BC_t0%north,BC_t1%north & - ,'north' & !side - ,bd%isd & !i1 - ,bd%ied & !i2 - ,bd%jsd & !j1 - ,bd%js-1 & !j2 - ,bd%isd & !i1_uvs - ,bd%ied & !i2_uvs - ,bd%jsd & !j1_uvs - ,bd%js-1 & !j2_uvs - ,bd%isd & !i1_uvw - ,bd%ied+1 & !i2_uvw - ,bd%jsd & !j1_uvw - ,bd%js-1) !j2_uvw + ,'north' & + ,bd%isd & + ,bd%ied & + ,bd%jsd & + ,bd%js-1 & + ,bd%isd & + ,bd%ied & + ,bd%jsd & + ,bd%js-1 & + ,bd%isd & + ,bd%ied+1 & + ,bd%jsd & + ,bd%js-1) endif ! if(south_bc)then @@ -4488,6 +4200,8 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & ! integer :: i,ie,j,je,jend,jend_uvs,jend_uvw & ,jstart,jstart_uvs,jstart_uvw,k,nt,nz +! + real,dimension(:,:,:),pointer :: delz_ptr ! !--------------------------------------------------------------------- !********************************************************************* @@ -4509,6 +4223,17 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & jend_uvs=j2_uvs+nhalo_model jend_uvw=j2_uvw+nhalo_model endif +! + select case (trim(side)) + case ('north') + delz_ptr=>delz_auxiliary%north + case ('south') + delz_ptr=>delz_auxiliary%south + case ('east') + delz_ptr=>delz_auxiliary%east + case ('west') + delz_ptr=>delz_auxiliary%west + end select ! do k=1,nlayers do j=jstart,jend @@ -4519,11 +4244,25 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & pt(i,j,k)=side_t0%pt_BC(i,j,k) & +(side_t1%pt_BC(i,j,k)-side_t0%pt_BC(i,j,k)) & *fraction_interval +! delz(i,j,k)=side_t0%delz_BC(i,j,k) & +! +(side_t1%delz_BC(i,j,k)-side_t0%delz_BC(i,j,k)) & +! *fraction_interval + delz_ptr(i,j,k)=side_t0%delz_BC(i,j,k) & + +(side_t1%delz_BC(i,j,k)-side_t0%delz_BC(i,j,k)) & + *fraction_interval #ifdef MOIST_CAPPA cappa(i,j,k)=side_t0%cappa_BC(i,j,k) & +(side_t1%cappa_BC(i,j,k)-side_t0%cappa_BC(i,j,k)) & *fraction_interval #endif +#ifdef USE_COND + q_con(i,j,k)=side_t0%q_con_BC(i,j,k) & + +(side_t1%q_con_BC(i,j,k)-side_t0%q_con_BC(i,j,k)) & + *fraction_interval +#endif + w(i,j,k)=side_t0%w_BC(i,j,k) & + +(side_t1%w_BC(i,j,k)-side_t0%w_BC(i,j,k)) & + *fraction_interval enddo enddo ! @@ -4553,24 +4292,6 @@ subroutine bc_values_into_arrays(side_t0,side_t1 & ie=min(ubound(side_t0%w_BC,1),ubound(w,1)) je=min(ubound(side_t0%w_BC,2),ubound(w,2)) nz=ubound(w,3) -! - do 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 @@ -4641,10 +4362,15 @@ subroutine regional_boundary_update(array & !--------------------- ! integer :: i1,i2,j1,j2 !<-- Horizontal limits of region updated. + integer :: i_bc,j_bc !<-- Innermost bndry index (anchor point for blending) + integer :: i1_blend,i2_blend,j1_blend,j2_blend !<-- Limits of updated blending region. integer :: lbnd1,ubnd1,lbnd2,ubnd2 !<-- Horizontal limits of BC update arrays. integer :: iq !<-- Tracer index + integer :: nside ! real,dimension(:,:,:),pointer :: bc_t0,bc_t1 !<-- Boundary data at the two bracketing times. +! + logical :: blend,call_interp ! !--------------------------------------------------------------------- !********************************************************************* @@ -4654,167 +4380,233 @@ subroutine regional_boundary_update(array & return endif ! + blend=.true. iq=0 if(present(index4))then iq=index4 + blend=blend_this_tracer(iq) endif ! !--------------------------------------------------------------------- -!*** Get the pointers pointing at the boundary arrays holding the -!*** two time levels of the given prognostic array's boundary region -!*** then update the boundary points. -!*** Start with tasks on the north or south side of the domain. +!*** Loop through the sides of the domain and find the limits +!*** of the region to update in the boundary. !--------------------------------------------------------------------- ! - if(north_bc)then +!--------------------------------------------------------------------- + sides: do nside=1,4 +!--------------------------------------------------------------------- ! - call retrieve_bc_variable_data(bc_vbl_name & -! ,BC_t0%north,BC_t1%north & - ,bc_north_t0,bc_north_t1 & !<-- Boundary data objects - ,bc_t0,bc_t1 & !<-- Pointer to boundary arrays - ,lbnd1,ubnd1,lbnd2,ubnd2 & !<-- Bounds of the boundary data objects - ,iq ) -!----------------------------------------------------- -!*** Limits of the region to update in the boundary. -!----------------------------------------------------- -! - i1=isd - i2=ied - if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v'.or.trim(bc_vbl_name)=='divgd')then - i2=ied+1 - endif + call_interp=.false. +! +!----------- +!*** North +!----------- ! - j1=jsd - j2=js-1 + if(nside==1)then + if(north_bc)then + call_interp=.true. + bc_side_t0=>bc_north_t0 + bc_side_t1=>bc_north_t1 ! - call 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_time_interval ) + i1=isd + i2=ied + if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v'.or.trim(bc_vbl_name)=='divgd')then + i2=ied+1 + endif ! - endif + j1=jsd + j2=js-1 ! - if(south_bc)then + i1_blend=is + i2_blend=ie + if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v'.or.trim(bc_vbl_name)=='divgd')then + i2_blend=ie+1 + endif + j1_blend=js + j2_blend=js+nrows_blend_user-1 + i_bc=-9e9 + j_bc=j2 ! - call retrieve_bc_variable_data(bc_vbl_name & -! ,BC_t0%south,BC_t1%south & - ,bc_south_t0,bc_south_t1 & !<-- Boundary data objects - ,bc_t0,bc_t1 & !<-- Pointer to boundary arrays - ,lbnd1,ubnd1,lbnd2,ubnd2 & !<-- Bounds of the boundary data objects - ,iq ) -!----------------------------------------------------- -!*** Limits of the region to update in the boundary. -!----------------------------------------------------- -! - i1=isd - i2=ied - if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v'.or.trim(bc_vbl_name)=='divgd')then - i2=ied+1 + endif endif ! - j1=je+1 - j2=jed - if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='divgd')then - j1=je+2 - j2=jed+1 +!----------- +!*** South +!----------- +! + if(nside==2)then + if(south_bc)then + call_interp=.true. + bc_side_t0=>bc_south_t0 + bc_side_t1=>bc_south_t1 +! + i1=isd + i2=ied + if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v'.or.trim(bc_vbl_name)=='divgd')then + i2=ied+1 + endif +! + j1=je+1 + j2=jed + if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='divgd')then + 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'.or.trim(bc_vbl_name)=='divgd')then + i2_blend=ie+1 + endif + j2_blend=je + if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='divgd')then + j2_blend=je+1 + endif + j1_blend=j2_blend-nrows_blend_user+1 + i_bc=-9e9 + j_bc=j1 +! + endif endif ! - call 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_time_interval ) +!---------- +!*** East +!---------- +! + if(nside==3)then + if(east_bc)then + call_interp=.true. + bc_side_t0=>bc_east_t0 + bc_side_t1=>bc_east_t1 ! - endif + j1=jsd + j2=jed ! -!--------------------------------------------------------------------- -!*** Now update the west and east sides of the domain. -!--------------------------------------------------------------------- - if(east_bc)then +! CHJ --- s --- + if(trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='divgd')then + j2=jed+1 + endif +! CHJ --- e --- + + i1=isd + i2=is-1 +! + if(north_bc)then + j1=js + endif + if(south_bc)then + j2=je + if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='divgd')then + 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'.or.trim(bc_vbl_name)=='divgd')then + j2_blend=j2_blend+1 + endif + i_bc=i2 + j_bc=-9e9 +! + endif + endif +! +!---------- +!*** West +!---------- ! - call retrieve_bc_variable_data(bc_vbl_name & -! ,BC_t0%east,BC_t1%east & - ,bc_east_t0,bc_east_t1 & !<-- Boundary data objects - ,bc_t0,bc_t1 & !<-- Pointer to boundary arrays - ,lbnd1,ubnd1,lbnd2,ubnd2 & !<-- Bounds of the boundary data objects - ,iq ) -!----------------------------------------------------- -!*** Limits of the region to update in the boundary. -!----------------------------------------------------- + if(nside==4)then + if(west_bc)then + call_interp=.true. + bc_side_t0=>bc_west_t0 + bc_side_t1=>bc_west_t1 ! - j1=jsd - j2=jed + j1=jsd + j2=jed + +! CHJ --- s --- + if(trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='divgd')then + j2=jed+1 + endif +! CHJ --- e --- + + i1=ie+1 + i2=ied + if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v'.or.trim(bc_vbl_name)=='divgd')then + i1=ie+2 + i2=ied+1 + endif +! + if(north_bc)then + j1=js + endif + if(south_bc)then + j2=je + if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='divgd')then + j2=je+1 + endif + endif ! - i1=isd - i2=is-1 + 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'.or.trim(bc_vbl_name)=='divgd')then + j2_blend=j2_blend+1 + endif + i_bc=i1 + j_bc=-9e9 ! - if(north_bc)then - j1=js - endif - if(south_bc)then - j2=je - if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='divgd')then - j2=je+1 endif endif ! - call 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_time_interval ) - endif ! east_bc -! - if(west_bc)then +!--------------------------------------------------------------------- +!*** Get the pointers pointing at the boundary arrays holding the +!*** two time levels of the given prognostic array's boundary region +!*** then update the boundary points. +!--------------------------------------------------------------------- ! - call retrieve_bc_variable_data(bc_vbl_name & -! ,BC_t0%west,BC_t1%west & - ,bc_west_t0,bc_west_t1 & !<-- Boundary data objects - ,bc_t0,bc_t1 & !<-- Pointer to boundary arrays - ,lbnd1,ubnd1,lbnd2,ubnd2 & !<-- Bounds of the boundary data objects - ,iq ) -!----------------------------------------------------- -!*** Limits of the region to update in the boundary. -!----------------------------------------------------- -! - j1=jsd - j2=jed -! - i1=ie+1 - i2=ied - if(trim(bc_vbl_name)=='uc'.or.trim(bc_vbl_name)=='v'.or.trim(bc_vbl_name)=='divgd')then - i1=ie+2 - i2=ied+1 + if(call_interp)then +! + call retrieve_bc_variable_data(bc_vbl_name & + ,bc_side_t0,bc_side_t1 & !<-- Boundary data objects + ,bc_t0,bc_t1 & !<-- Pointer to boundary arrays + ,lbnd1,ubnd1,lbnd2,ubnd2 & !<-- Bounds of the boundary data objects + ,iq ) +! + call bc_time_interpolation(array & + ,lbnd_x,ubnd_x,lbnd_y,ubnd_y,ubnd_z & + ,bc_t0,bc_t1 & + ,lbnd1,ubnd1,lbnd2,ubnd2 & + ,i1,i2,j1,j2 & + ,is,ie,js,je & + ,fcst_time & + ,bc_update_interval & + ,i1_blend,i2_blend,j1_blend,j2_blend & + ,i_bc,j_bc,nside,bc_vbl_name,blend ) endif ! - if(north_bc)then - j1=js - endif - if(south_bc)then - j2=je - if(trim(bc_vbl_name)=='u'.or.trim(bc_vbl_name)=='vc'.or.trim(bc_vbl_name)=='divgd')then - j2=je+1 - endif - endif +!--------------------------------------------------------------------- ! - call 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_time_interval ) - endif ! west_bc + enddo sides ! !--------------------------------------------------------------------- - +! end subroutine regional_boundary_update !--------------------------------------------------------------------- @@ -4874,20 +4666,19 @@ subroutine retrieve_bc_variable_data(bc_vbl_name & case ('divgd') bc_t0=>bc_side_t0%divgd_BC bc_t1=>bc_side_t1%divgd_BC -#ifdef USE_COND #ifdef MOIST_CAPPA case ('cappa') bc_t0=>bc_side_t0%cappa_BC bc_t1=>bc_side_t1%cappa_BC #endif +#ifdef USE_COND case ('q_con') bc_t0=>bc_side_t0%q_con_BC bc_t1=>bc_side_t1%q_con_BC #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) @@ -4925,16 +4716,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_time_interval ) + subroutine bc_time_interpolation(array & + ,lbnd_x, ubnd_x & + ,lbnd_y, ubnd_y & + ,ubnd_z & + ,bc_t0, bc_t1 & + ,lbnd1, ubnd1 & + ,lbnd2, ubnd2 & + ,i1,i2,j1,j2 & + ,is,ie,js,je & + ,fcst_time & + ,bc_update_interval & + ,i1_blend,i2_blend,j1_blend,j2_blend & + ,i_bc,j_bc,nside,bc_vbl_name,blend ) !--------------------------------------------------------------------- !*** Update the boundary region of the input array at the given @@ -4952,14 +4746,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) :: bc_time_interval !<-- Time (hours) between BC data states + integer,intent(in) :: is,ie,js,je !<-- Min/Max index limits on task's computational subdomain +! + integer,intent(in) :: bc_update_interval !<-- Time (hours) between BC data states ! real,intent(in) :: fcst_time !<-- Current forecast time (sec) ! - real,dimension(lbnd1:ubnd1,lbnd2:ubnd2,1:ubnd_z) :: bc_t0 & !<-- Interpolate between these - ,bc_t1 ! two boundary region states. + real,dimension(lbnd1:ubnd1,lbnd2:ubnd2,1:ubnd_z),intent(in) :: bc_t0 & !<-- Interpolate between these + ,bc_t1 ! two boundary region states. +! + character(len=*),intent(in) :: bc_vbl_name +! + logical,intent(in) :: blend !<-- Can blending be applied to this variable? ! !--------------------- !*** Output variables @@ -4974,7 +4777,7 @@ subroutine bc_time_interpolation(array & ! integer :: i,j,k ! - real :: fraction_interval + real :: blend_value,factor_dist,fraction_interval,rdenom ! !--------------------------------------------------------------------- !********************************************************************* @@ -4985,7 +4788,8 @@ subroutine bc_time_interpolation(array & !*** time level 0 to time level 1. !--------------------------------------------------------------------- ! - fraction_interval=mod(fcst_time,(bc_time_interval*3600.))/(bc_time_interval*3600.) + fraction_interval=mod(fcst_time,(bc_update_interval*3600.)) & + /(bc_update_interval*3600.) ! !--------------------------------------------------------------------- ! @@ -4999,494 +4803,308 @@ subroutine bc_time_interpolation(array & enddo ! !--------------------------------------------------------------------- - - end subroutine bc_time_interpolation -!--------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!--------------------------------------------------------------------- -! - 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 ) -! -!--------------------------------------------------------------------- -!*** Execute the linear time interpolation between t0 and t1 -!*** generically for any side of the regional domain's boundary -!*** region. -!--------------------------------------------------------------------- - implicit none -!--------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - integer,intent(in) :: is,ie,js,je & !<-- Index limits for centers of grid cells - ,is_s,ie_s,js_s,je_s & !<-- Index limits for south/north edges of grid cells - ,is_w,ie_w,js_w,je_w !<-- Index limits for west/east edges of grid cells -! - real,intent(in) :: fraction !<-- Current time is this fraction between t0 ad t1. -! - type(fv_regional_BC_variables),intent(in) :: t0,t1 !<-- BC variables at time levels t0 and t1. -! - type(fv_atmos_type),intent(inout) :: Atm !<-- The Atm object -! -!--------------------- -!*** Local variables -!--------------------- -! - integer :: i,j,k,n,nlayers,ntracers -! -!--------------------------------------------------------------------- -!********************************************************************* -!--------------------------------------------------------------------- -! - nlayers =Atm%npz !<-- # of layers in vertical configuration of integration - ntracers=Atm%ncnst !<-- # of advected tracers -! -!--------------------------------------------------------------------- -! - k_loop: do k=1,nlayers -! -!--------------------------------------------------------------------- -! -!------------- -!*** Scalars -!------------- -! - do j=js,je - do i=is,ie -! - Atm%delp(i,j,k)=t0%delp_BC(i,j,k) & !<-- Update layer pressure thickness. - +(t1%delp_BC(i,j,k)-t0%delp_BC(i,j,k)) & - *fraction -! -#ifndef SW_DYNAMICS - Atm%delz(i,j,k)=t0%delz_BC(i,j,k) & !<-- Update layer height thickness. - +(t1%delz_BC(i,j,k)-t0%delz_BC(i,j,k)) & - *fraction -! - 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 - 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 -! -!--------------------------------------------------------------------- -! - enddo k_loop -! -!--------------------------------------------------------------------- -! - end subroutine bc_time_interpolation_general -! -!--------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!--------------------------------------------------------------------- -! - subroutine regional_bc_t1_to_t0(BC_t1,BC_t0 & - ,nlev,ntracers,bnds ) -! -!--------------------------------------------------------------------- -!*** BC data has been read into the time level t1 object. Now -!*** move the t1 data into the t1 object before refilling t1 -!*** with the next data from the BC file. -!--------------------------------------------------------------------- - implicit none +!*** If this tracer is not in the external BC file then it will not +!*** be blended. !--------------------------------------------------------------------- ! -!------------------------ -!*** Argument variables -!------------------------ -! - integer,intent(in) :: nlev & !<-- # of model layers. - ,ntracers !<-- # of advected tracers -! - type(fv_regional_bc_bounds_type),intent(in) :: bnds !<-- Index limits for all types of vbls in boundary region -! - type(fv_domain_sides),intent(in) :: BC_t1 -! - type(fv_domain_sides),intent(inout) :: BC_t0 -! -!--------------------- -!*** Local variables -!--------------------- -! - integer :: i,ie,is,j,je,js,k,n + if(.not.blend)then + return + endif ! !--------------------------------------------------------------------- -!********************************************************************* +!*** 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. !--------------------------------------------------------------------- ! !----------- !*** North !----------- -! - if(north_bc)then -! - is=bnds%is_north !<-- - ie=bnds%ie_north ! North BC index limits - js=bnds%js_north ! for centers of grid cells - je=bnds%je_north !<-- -! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%north%delp_BC(i,j,k)=BC_t1%north%delp_BC(i,j,k) - enddo - enddo - enddo -! - do n=1,ntracers - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%north%q_BC(i,j,k,n)=BC_t1%north%q_BC(i,j,k,n) - enddo - enddo - enddo - enddo -! - do k=1,nlev - do j=js,je - do i=is,ie -#ifndef SW_DYNAMICS - BC_t0%north%w_BC(i,j,k) =BC_t1%north%w_BC(i,j,k) - BC_t0%north%pt_BC(i,j,k) =BC_t1%north%pt_BC(i,j,k) - BC_t0%north%delz_BC(i,j,k)=BC_t1%north%delz_BC(i,j,k) -#ifdef USE_COND - BC_t0%north%q_con_BC(i,j,k)=BC_t1%north%q_con_BC(i,j,k) -#ifdef MOIST_CAPPA - BC_t0%north%cappa_BC(i,j,k)=BC_t1%north%cappa_BC(i,j,k) -#endif -#endif -#endif - enddo - enddo - enddo -! - is=bnds%is_north_uvs !<-- - ie=bnds%ie_north_uvs ! North BC index limits - js=bnds%js_north_uvs ! for winds on N/S sides of grid cells. - je=bnds%je_north_uvs !<-- -! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%north%u_BC(i,j,k) =BC_t1%north%u_BC(i,j,k) - BC_t0%north%vc_BC(i,j,k)=BC_t1%north%vc_BC(i,j,k) - enddo - enddo - enddo -! - is=bnds%is_north_uvw !<-- - ie=bnds%ie_north_uvw ! North BC index limits - js=bnds%js_north_uvw ! for winds on E/W sides of grid cells. - je=bnds%je_north_uvw !<-- -! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%north%v_BC(i,j,k) =BC_t1%north%v_BC(i,j,k) - BC_t0%north%uc_BC(i,j,k)=BC_t1%north%uc_BC(i,j,k) - enddo - enddo - enddo -! - BC_t0%north%divgd_BC =0. ! TEMPORARY - endif -! -!----------- -!*** South -!----------- -! - if(south_bc)then -! - is=bnds%is_south !<-- - ie=bnds%ie_south ! South BC index limits - js=bnds%js_south ! for centers of grid cells - je=bnds%je_south !<-- -! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%south%delp_BC(i,j,k)=BC_t1%south%delp_BC(i,j,k) - enddo - enddo - enddo -! - do n=1,ntracers - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%south%q_BC(i,j,k,n)=BC_t1%south%q_BC(i,j,k,n) - enddo - enddo - enddo - enddo -! - do k=1,nlev - do j=js,je - do i=is,ie -#ifndef SW_DYNAMICS - BC_t0%south%w_BC(i,j,k) =BC_t1%south%w_BC(i,j,k) - BC_t0%south%pt_BC(i,j,k) =BC_t1%south%pt_BC(i,j,k) - BC_t0%south%delz_BC(i,j,k)=BC_t1%south%delz_BC(i,j,k) -#ifdef USE_COND - BC_t0%south%q_con_BC(i,j,k)=BC_t1%south%q_con_BC(i,j,k) -#ifdef MOIST_CAPPA - BC_t0%south%cappa_BC(i,j,k)=BC_t1%south%cappa_BC(i,j,k) -#endif -#endif -#endif - enddo - enddo - enddo -! - is=bnds%is_south_uvs !<-- - ie=bnds%ie_south_uvs ! South BC index limits - js=bnds%js_south_uvs ! for winds on N/S sides of grid cells. - je=bnds%je_south_uvs !<-- -! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%south%u_BC(i,j,k) =BC_t1%south%u_BC(i,j,k) - BC_t0%south%vc_BC(i,j,k)=BC_t1%south%vc_BC(i,j,k) - enddo - enddo - enddo -! - is=bnds%is_south_uvw !<-- - ie=bnds%ie_south_uvw ! South BC index limits - js=bnds%js_south_uvw ! for winds on E/W sides of grid cells. - je=bnds%je_south_uvw !<-- -! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%south%v_BC(i,j,k) =BC_t1%south%v_BC(i,j,k) - BC_t0%south%uc_BC(i,j,k)=BC_t1%south%uc_BC(i,j,k) - enddo - enddo - enddo -! - BC_t0%south%divgd_BC =0. ! TEMPORARY - endif -! -!---------- -!*** East -!---------- -! - if(east_bc)then -! - is=bnds%is_east !<-- - ie=bnds%ie_east ! East BC index limits - js=bnds%js_east ! for centers of grid cells - je=bnds%je_east !<-- -! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%east%delp_BC(i,j,k)=BC_t1%east%delp_BC(i,j,k) - enddo - enddo - enddo -! - do n=1,ntracers - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%east%q_BC(i,j,k,n)=BC_t1%east%q_BC(i,j,k,n) - enddo - enddo - enddo - enddo -! - do k=1,nlev - do j=js,je - do i=is,ie -#ifndef SW_DYNAMICS - BC_t0%east%w_BC(i,j,k) =BC_t1%east%w_BC(i,j,k) - BC_t0%east%pt_BC(i,j,k) =BC_t1%east%pt_BC(i,j,k) - BC_t0%east%delz_BC(i,j,k)=BC_t1%east%delz_BC(i,j,k) -#ifdef USE_COND - BC_t0%east%q_con_BC(i,j,k)=BC_t1%east%q_con_BC(i,j,k) -#ifdef MOIST_CAPPA - BC_t0%east%cappa_BC(i,j,k)=BC_t1%east%cappa_BC(i,j,k) -#endif -#endif -#endif - enddo +! + 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. +! + array(i,j,k)=(1.-factor_dist)*array(i,j,k)+factor_dist*blend_value + enddo enddo enddo + endif ! - is=bnds%is_east_uvs !<-- - ie=bnds%ie_east_uvs ! East BC index limits - js=bnds%js_east_uvs ! for winds on N/S sides of grid cells. - je=bnds%je_east_uvs !<-- +!----------- +!*** South +!----------- ! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%east%u_BC(i,j,k) =BC_t1%east%u_BC(i,j,k) - BC_t0%east%vc_BC(i,j,k)=BC_t1%east%vc_BC(i,j,k) - enddo + 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 ! - is=bnds%is_east_uvw !<-- - ie=bnds%ie_east_uvw ! East BC index limits - js=bnds%js_east_uvw ! for winds on E/W sides of grid cells. - je=bnds%je_east_uvw !<-- +!---------- +!*** East +!---------- ! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%east%v_BC(i,j,k) =BC_t1%east%v_BC(i,j,k) - BC_t0%east%uc_BC(i,j,k)=BC_t1%east%uc_BC(i,j,k) - enddo + 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 +! + 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-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 -! - BC_t0%east%divgd_BC =0. ! TEMPORARY endif ! !---------- !*** West !---------- ! - if(west_bc)then + 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 ! - is=bnds%is_west !<-- - ie=bnds%ie_west ! West BC index limits - js=bnds%js_west ! for centers of grid cells - je=bnds%je_west !<-- + blend_value=bc_t0(i,j,k) & !<-- Blend data interpolated + +(bc_t1(i,j,k)-bc_t0(i,j,k))*fraction_interval ! between t0 and t1. ! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%west%delp_BC(i,j,k)=BC_t1%west%delp_BC(i,j,k) - enddo + factor_dist=exp(-(blend_exp1+blend_exp2*(i_bc-i-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 ! - do n=1,ntracers +!--------------------------------------------------------------------- +! + end subroutine bc_time_interpolation +! +!--------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!--------------------------------------------------------------------- +! + subroutine regional_bc_t1_to_t0(BC_t1,BC_t0 & + ,nlev,ntracers,bnds ) +! +!--------------------------------------------------------------------- +!*** BC data has been read into the time level t1 object. Now +!*** move the t1 data into the t1 object before refilling t1 +!*** with the next data from the BC file. +!--------------------------------------------------------------------- + implicit none +!--------------------------------------------------------------------- +! +!------------------------ +!*** Argument variables +!------------------------ +! + integer,intent(in) :: nlev & !<-- # of model layers. + ,ntracers !<-- # of advected tracers +! + type(fv_regional_bc_bounds_type),intent(in) :: bnds !<-- Index limits for all types of vbls in boundary region +! + type(fv_domain_sides),target,intent(in) :: BC_t1 +! + type(fv_domain_sides),target,intent(inout) :: BC_t0 +! +!--------------------- +!*** Local variables +!--------------------- +! + integer :: i,ie_c,ie_s,ie_w,is_c,is_s,is_w & + ,j,je_c,je_s,je_w,js_c,js_s,js_w & + ,k,n,nside +! + logical :: move +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! +!--------------------------------------------------------------------- +!*** Loop through the four sides of the domain. +!--------------------------------------------------------------------- +! + sides: do nside=1,4 +! + move=.false. +! + if(nside==1)then + if(north_bc)then + move=.true. + bc_side_t0=>BC_t0%north + bc_side_t1=>BC_t1%north +! + is_c=bnds%is_north !<-- + ie_c=bnds%ie_north ! North BC index limits + js_c=bnds%js_north ! for centers of grid cells. + je_c=bnds%je_north !<-- +! + is_s=bnds%is_north_uvs !<-- + ie_s=bnds%ie_north_uvs ! North BC index limits + js_s=bnds%js_north_uvs ! for winds on N/S sides of grid cells. + je_s=bnds%je_north_uvs !<-- +! + is_w=bnds%is_north_uvw !<-- + ie_w=bnds%ie_north_uvw ! North BC index limits + js_w=bnds%js_north_uvw ! for winds on E/W sides of grid cells. + je_w=bnds%je_north_uvw !<-- + endif + endif +! + if(nside==2)then + if(south_bc)then + move=.true. + bc_side_t0=>BC_t0%south + bc_side_t1=>BC_t1%south +! + is_c=bnds%is_south !<-- + ie_c=bnds%ie_south ! South BC index limits + js_c=bnds%js_south ! for centers of grid cells. + je_c=bnds%je_south !<-- +! + is_s=bnds%is_south_uvs !<-- + ie_s=bnds%ie_south_uvs ! South BC index limits + js_s=bnds%js_south_uvs ! for winds on N/S sides of grid cells. + je_s=bnds%je_south_uvs !<-- +! + is_w=bnds%is_south_uvw !<-- + ie_w=bnds%ie_south_uvw ! South BC index limits + js_w=bnds%js_south_uvw ! for winds on E/W sides of grid cells. + je_w=bnds%je_south_uvw !<-- + endif + endif +! + if(nside==3)then + if(east_bc)then + move=.true. + bc_side_t0=>BC_t0%east + bc_side_t1=>BC_t1%east +! + is_c=bnds%is_east !<-- + ie_c=bnds%ie_east ! East BC index limits + js_c=bnds%js_east ! for centers of grid cells. + je_c=bnds%je_east !<-- +! + is_s=bnds%is_east_uvs !<-- + ie_s=bnds%ie_east_uvs ! East BC index limits + js_s=bnds%js_east_uvs ! for winds on N/S sides of grid cells. + je_s=bnds%je_east_uvs !<-- +! + is_w=bnds%is_east_uvw !<-- + ie_w=bnds%ie_east_uvw ! East BC index limits + js_w=bnds%js_east_uvw ! for winds on E/W sides of grid cells. + je_w=bnds%je_east_uvw !<-- + endif + endif +! + if(nside==4)then + if(west_bc)then + move=.true. + bc_side_t0=>BC_t0%west + bc_side_t1=>BC_t1%west +! + is_c=bnds%is_west !<-- + ie_c=bnds%ie_west ! West BC index limits + js_c=bnds%js_west ! for centers of grid cells. + je_c=bnds%je_west !<-- +! + is_s=bnds%is_west_uvs !<-- + ie_s=bnds%ie_west_uvs ! West BC index limits + js_s=bnds%js_west_uvs ! for winds on N/S sides of grid cells. + je_s=bnds%je_west_uvs !<-- +! + is_w=bnds%is_west_uvw !<-- + ie_w=bnds%ie_west_uvw ! West BC index limits + js_w=bnds%js_west_uvw ! for winds on E/W sides of grid cells. + je_w=bnds%je_west_uvw !<-- + endif + endif +! + if(move)then do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%west%q_BC(i,j,k,n)=BC_t1%west%q_BC(i,j,k,n) + do j=js_c,je_c + do i=is_c,ie_c + bc_side_t0%delp_BC(i,j,k) =bc_side_t1%delp_BC(i,j,k) enddo enddo enddo - enddo ! - do k=1,nlev - do j=js,je - do i=is,ie + do n=1,ntracers + do k=1,nlev + do j=js_c,je_c + do i=is_c,ie_c + bc_side_t0%q_BC(i,j,k,n)=bc_side_t1%q_BC(i,j,k,n) + enddo + enddo + enddo + enddo +! + do k=1,nlev + do j=js_c,je_c + do i=is_c,ie_c #ifndef SW_DYNAMICS - BC_t0%west%w_BC(i,j,k) =BC_t1%west%w_BC(i,j,k) - BC_t0%west%pt_BC(i,j,k) =BC_t1%west%pt_BC(i,j,k) - BC_t0%west%delz_BC(i,j,k)=BC_t1%west%delz_BC(i,j,k) + bc_side_t0%w_BC(i,j,k) =bc_side_t1%w_BC(i,j,k) + bc_side_t0%pt_BC(i,j,k) =bc_side_t1%pt_BC(i,j,k) + bc_side_t0%delz_BC(i,j,k) =bc_side_t1%delz_BC(i,j,k) #ifdef USE_COND - BC_t0%west%q_con_BC(i,j,k)=BC_t1%west%q_con_BC(i,j,k) + bc_side_t0%q_con_BC(i,j,k)=bc_side_t1%q_con_BC(i,j,k) #ifdef MOIST_CAPPA - BC_t0%west%cappa_BC(i,j,k)=BC_t1%west%cappa_BC(i,j,k) + bc_side_t0%cappa_BC(i,j,k)=bc_side_t1%cappa_BC(i,j,k) #endif #endif #endif + enddo + enddo enddo - enddo - enddo ! - is=bnds%is_west_uvs !<-- - ie=bnds%ie_west_uvs ! West BC index limits - js=bnds%js_west_uvs ! for winds on N/S sides of grid cells. - je=bnds%je_west_uvs !<-- + do k=1,nlev + do j=js_s,je_s + do i=is_s,ie_s + bc_side_t0%u_BC(i,j,k) =bc_side_t1%u_BC(i,j,k) + bc_side_t0%vc_BC(i,j,k)=bc_side_t1%vc_BC(i,j,k) + enddo + enddo + + do j=js_s,je_s + do i=is_w,ie_w + bc_side_t0%divgd_BC(i,j,k)=bc_side_t1%divgd_BC(i,j,k) + enddo + enddo ! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%west%u_BC(i,j,k) =BC_t1%west%u_BC(i,j,k) - BC_t0%west%vc_BC(i,j,k)=BC_t1%west%vc_BC(i,j,k) - enddo + do j=js_w,je_w + do i=is_w,ie_w + bc_side_t0%v_BC(i,j,k) =bc_side_t1%v_BC(i,j,k) + bc_side_t0%uc_BC(i,j,k)=bc_side_t1%uc_BC(i,j,k) + enddo + enddo enddo - enddo -! - is=bnds%is_west_uvw !<-- - ie=bnds%ie_west_uvw ! West BC index limits - js=bnds%js_west_uvw ! for winds on E/W sides of grid cells. - je=bnds%je_west_uvw !<-- ! - do k=1,nlev - do j=js,je - do i=is,ie - BC_t0%west%v_BC(i,j,k) =BC_t1%west%v_BC(i,j,k) - BC_t0%west%uc_BC(i,j,k)=BC_t1%west%uc_BC(i,j,k) - enddo - enddo - enddo + endif ! - BC_t0%west%divgd_BC =0. ! TEMPORARY - endif + enddo sides ! !--------------------------------------------------------------------- ! @@ -5496,8 +5114,7 @@ end subroutine regional_bc_t1_to_t0 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- ! - subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & - ,sphum,liq_wat ) + subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz) ! !----------------------------------------------------------------------- !*** Convert the incoming sensible temperature to virtual potential @@ -5506,13 +5123,11 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & implicit none !----------------------------------------------------------------------- ! -!--------------------- -!*** Input arguments -!--------------------- +!------------------------ +!*** Argument variables +!------------------------ ! integer,intent(in) :: isd,ied,jsd,jed,npz -! - integer,intent(in) :: liq_wat,sphum ! !--------------------- !*** Local variables @@ -5522,7 +5137,13 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & ! real :: rdg ! - real,dimension(:,:,:),pointer :: cappa,delp,delz,pt,q_con + real,dimension(:,:,:),pointer :: delp,delz,pt +#ifdef USE_COND + real,dimension(:,:,:),pointer :: q_con +#endif +#ifdef MOIST_CAPPA + real,dimension(:,:,:),pointer ::cappa +#endif ! real,dimension(:,:,:,:),pointer :: q ! @@ -5542,13 +5163,13 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & j1=regional_bounds%js_north j2=regional_bounds%je_north q =>BC_t1%north%q_BC - delp =>BC_t1%north%delp_BC - delz =>BC_t1%north%delz_BC #ifdef USE_COND q_con=>BC_t1%north%q_con_BC +#endif + delp =>BC_t1%north%delp_BC + delz =>BC_t1%north%delz_BC #ifdef MOIST_CAPPA cappa=>BC_t1%north%cappa_BC -#endif #endif pt =>BC_t1%north%pt_BC call compute_vpt !<-- Compute the virtual potential temperature. @@ -5560,13 +5181,13 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & j1=regional_bounds%js_south j2=regional_bounds%je_south q =>BC_t1%south%q_BC - delp =>BC_t1%south%delp_BC - delz =>BC_t1%south%delz_BC #ifdef USE_COND q_con=>BC_t1%south%q_con_BC +#endif + delp =>BC_t1%south%delp_BC + delz =>BC_t1%south%delz_BC #ifdef MOIST_CAPPA cappa=>BC_t1%south%cappa_BC -#endif #endif pt =>BC_t1%south%pt_BC call compute_vpt !<-- Compute the virtual potential temperature. @@ -5578,13 +5199,13 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & j1=regional_bounds%js_east j2=regional_bounds%je_east q =>BC_t1%east%q_BC - delp =>BC_t1%east%delp_BC - delz =>BC_t1%east%delz_BC #ifdef USE_COND q_con=>BC_t1%east%q_con_BC +#endif + delp =>BC_t1%east%delp_BC + delz =>BC_t1%east%delz_BC #ifdef MOIST_CAPPA cappa=>BC_t1%east%cappa_BC -#endif #endif pt =>BC_t1%east%pt_BC call compute_vpt !<-- Compute the virtual potential temperature. @@ -5596,13 +5217,13 @@ subroutine convert_to_virt_pot_temp(isd,ied,jsd,jed,npz & j1=regional_bounds%js_west j2=regional_bounds%je_west q =>BC_t1%west%q_BC - delp =>BC_t1%west%delp_BC - delz =>BC_t1%west%delz_BC #ifdef USE_COND q_con=>BC_t1%west%q_con_BC +#endif + delp =>BC_t1%west%delp_BC + delz =>BC_t1%west%delz_BC #ifdef MOIST_CAPPA cappa=>BC_t1%west%cappa_BC -#endif #endif pt =>BC_t1%west%pt_BC call compute_vpt !<-- Compute the virtual potential temperature. @@ -5636,11 +5257,11 @@ subroutine compute_vpt ! do j=j1,j2 do i=i1,i2 - dp1 = zvir*q(i,j,k,sphum) + dp1 = zvir*q(i,j,k,sphum_index) #ifdef USE_COND #ifdef MOIST_CAPPA - cvm=(1.-q(i,j,k,sphum)+q_con(i,j,k))*cv_air & - +q(i,j,k,sphum)*cv_vap+q(i,j,k,liq_wat)*c_liq + cvm=(1.-q(i,j,k,sphum_index)+q_con(i,j,k))*cv_air & + +q(i,j,k,sphum_index)*cv_vap+q(i,j,k,liq_water_index)*c_liq pkz=exp(cappa(i,j,k)*log(rdg*delp(i,j,k)*pt(i,j,k) & *(1.+dp1)*(1.-q_con(i,j,k))/delz(i,j,k))) #else @@ -6004,8 +5625,22 @@ 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) +! call dump_field(Atm(1)%domain,"atm_phis", Atm(1)%phis, isd, ied, jsd, jed, stag=H_STAGGER) + type(domain2d), intent(INOUT) :: domain character(len=*), intent(IN) :: name real, dimension(isd:ied,jsd:jed,1:nlev), intent(INOUT) :: field @@ -6121,6 +5756,7 @@ subroutine dump_field_3d (domain, name, field, isd, ied, jsd, jed, nlev, stag) call close_file(fileobj) endif + end subroutine dump_field_3d subroutine dump_field_2d (domain, name, field, isd, ied, jsd, jed, stag) @@ -6149,7 +5785,7 @@ subroutine dump_field_2d (domain, name, field, isd, ied, jsd, jed, stag) dim_names_3d(3) = "lev" 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_compute_domain( domain, is, ie, js, je ) call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=npx, ysize=npy, position=CENTER ) @@ -6234,6 +5870,669 @@ subroutine dump_field_2d (domain, name, field, isd, ied, jsd, jed, stag) end subroutine dump_field_2d +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + subroutine prepare_full_fields(Atm) +! +!----------------------------------------------------------------------- +!*** Prepare the objects that will hold the names and values of +!*** the core and tracer fields to be written into the expanded +!*** restart files that include the boundary rows so the GSI +!*** can update both the interior and BCs. +!----------------------------------------------------------------------- +! +!------------------------ +!*** Argument variables +!------------------------ +! + type(fv_atmos_type),target,intent(inout) :: Atm !<-- Atm object for the current domain +! +!--------------------- +!*** Local variables +!--------------------- +! + integer :: index,istat,n & + ,ncid_core_new & + ,ncid_tracers_new & + ,ndims,nkount,nv_core,nv_tracers & + ,var_id +! + integer :: lbnd1,lbnd2,lbnd3,ubnd1,ubnd2,ubnd3 +! + integer,dimension(ndims_core) :: dim_lengths_core +! + integer,dimension(ndims_tracers) :: dim_lengths_tracers +! + integer,dimension(1:4) :: dimids=(/0,0,0,0/) +! + real,dimension(:),allocatable :: dim_values +! + character(len=50) :: att_name,var_name +! + character(len=9),dimension(ndims_core) :: dim_names_core=(/ & + 'xaxis_1' & + ,'xaxis_2' & + ,'yaxis_1' & + ,'yaxis_2' & + ,'zaxis_1' & + ,'Time ' & + /) +! + character(len=9),dimension(ndims_tracers) :: dim_names_tracers=(/ & + 'xaxis_1' & + ,'yaxis_1' & + ,'zaxis_1' & + ,'Time ' & + /) +! +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +!*** The first file to be handled is the core restart file. +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +!*** All tasks are given pointers into the model data that will +!*** be written to the new restart file. The following are the +!*** prognostic variables in the core restart file. Note that +!*** we must add the halo region back into DZ since we need the +!*** domain boundary points for all the fields. +!----------------------------------------------------------------------- +! + allocate(fields_core(1:nvars_core)) +! + fields_core(1)%ptr=>Atm%u + fields_core(1)%name='u' +! + fields_core(2)%ptr=>Atm%v + fields_core(2)%name='v' +! + fields_core(3)%ptr=>Atm%w + fields_core(3)%name='W' +! + lbnd1=lbound(Atm%delz,1) + ubnd1=ubound(Atm%delz,1) + lbnd2=lbound(Atm%delz,2) + ubnd2=ubound(Atm%delz,2) + lbnd3=1 + ubnd3=ubound(Atm%delz,3) + allocate(fields_core(4)%ptr(lbnd1-nhalo_model:ubnd1+nhalo_model & + ,lbnd2-nhalo_model:ubnd2+nhalo_model & + ,lbnd3:ubnd3)) + fields_core(4)%name='DZ' +! + fields_core(5)%ptr=>Atm%pt + fields_core(5)%name='T' +! + fields_core(6)%ptr=>Atm%delp + fields_core(6)%name='delp' +! + allocate(fields_core(7)%ptr(lbound(Atm%phis,1):ubound(Atm%phis,1) & + ,lbound(Atm%phis,2):ubound(Atm%phis,2) & + ,1:1)) + fields_core(7)%ptr(:,:,1)=Atm%phis(:,:) !<-- For generality treat the 2-D phis as 3-D + fields_core(7)%name='phis' +! +!----------------------------------------------------------------------- +!*** We need to point at the tracers in the model's tracer array. +!*** Those tracers depend on the physics that was selected so they +!*** cannot be pre-specified like the variables in the core restart +!*** file were. Read them from the expanded tracer restart file +!*** that was created prior to the start for the forecast. +!----------------------------------------------------------------------- +! + call check(nf90_open(path=filename_tracers_new & !<-- The expanded tracer restart file. + ,mode=nf90_nowrite & !<-- File access. + ,ncid=ncid_tracers_new )) !<-- The expanded tracer restart file's ID +! + call check(nf90_inquire(ncid =ncid_tracers_new & !<-- The expanded tracer restart file's ID. + ,nvariables=nv_tracers )) !<-- The TOTAL number of tracer restart file variables. +! + nfields_tracers=nv_tracers-ndims_tracers !<-- # of 3-D tracer fields + allocate(fields_tracers(1:nfields_tracers),stat=istat) + if(istat/=0)then + call mpp_error(FATAL,' Failed to allocate fields_tracers.') + else + if(is_master())then + write(0,33012)nfields_tracers +33012 format(' Allocated fields_tracers(1:',i3,')') + endif + endif + nkount=0 +! + do n=1,nv_tracers + var_id=n + call check(nf90_inquire_variable(ncid =ncid_tracers_new & !<-- The file's ID. + ,varid=var_id & !<-- The variable's ID. + ,name =var_name )) !<-- The variable's name. +! + if(n>ndims_tracers)then + nkount=nkount+1 + fields_tracers(nkount)%name=trim(var_name) + index=get_tracer_index(MODEL_ATMOS, trim(var_name)) + fields_tracers(nkount)%ptr=>Atm%q(:,:,:, index) + endif +! + enddo +! +!----------------------------------------------------------------------- +! + call check(nf90_close(ncid_tracers_new)) +! +!----------------------------------------------------------------------- +! + end subroutine prepare_full_fields +! +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + subroutine write_full_fields(Atm) +! +!----------------------------------------------------------------------- +!*** Write out full fields of the primary restart variables +!*** INCLUDING BOUNDARY ROWS so the GSI can include BCs in its +!*** update. This is done in a restart look-alike file. +!----------------------------------------------------------------------- +! + type(fv_atmos_type), intent(inout), target :: Atm +! + integer :: count_i,count_j + integer :: iend,istart,jend,jstart,kend,kstart,nz + integer :: iend_ptr,istart_ptr,jend_ptr,jstart_ptr + integer :: iend_g,istart_g,jend_g,jstart_g + integer :: ieg,iext,isg,jeg,jext,jsg,k + integer :: n,ncid_core_new,ncid_tracers_new,nv,var_id + integer :: halo +! + integer,dimension(:),allocatable :: pelist +! + real,dimension(:,:,:),allocatable :: global_field + real,dimension(:,:,:),pointer :: field_3d +! + character(len=10) :: var_name +! + logical :: is_root_pe +! +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! + allocate( pelist(mpp_npes()) ) + call mpp_get_current_pelist(pelist) +! write(0,*)' pelist=',pelist +! + halo=nhalo_model +! + is_root_pe = (mpp_pe()==mpp_root_pe()) + if(is_root_pe)then + call check(nf90_open(filename_core_new,nf90_write,ncid_core_new)) !<-- Open the new netcdf file + write(0,*)' Opened core restart with BCs: ',trim(filename_core_new) + endif +! +!----------------------------------------------------------------------- +!*** Save the global limits of the domain and its vertical extent. +!----------------------------------------------------------------------- +! + call mpp_get_global_domain (Atm%domain, isg, ieg, jsg, jeg, position=CENTER ) +! +!----------------------------------------------------------------------- +!*** Begin with the core restart file. +!*** Loop through that file's prognostic variables. +!----------------------------------------------------------------------- +! + vbls_core: do nv=1,nvars_core +! + var_name=fields_core(nv)%name + if(is_root_pe)then + call check(nf90_inq_varid(ncid_core_new,var_name,var_id)) !<-- Get this variable's ID + endif +! +!----------------------------------------------------------------------- +!*** What is the full domain extent of this variable including +!*** boundary rows? +!----------------------------------------------------------------------- +! + iext=0 + jext=0 + if(var_name=='u'.or.var_name=='vc')then + jext=1 + endif + if(var_name=='v'.or.var_name=='uc')then + iext=1 + endif +! + call mpp_get_global_domain (atm%domain, isg, ieg, jsg, jeg, position=CENTER ) + istart_g=isg-halo + iend_g =ieg+halo+iext + jstart_g=jsg-halo + jend_g =jeg+halo+jext +! + count_i=iend_g-istart_g+1 + count_j=jend_g-jstart_g+1 +! + nz=size(fields_core(nv)%ptr,3) +! + allocate( global_field(istart_g:iend_g, jstart_g:jend_g, 1:nz) ) +! +!----------------------------------------------------------------------- +!*** What is the local extent of the variable on the task subdomain? +!*** We must exclude inner halo data since the data is not updated +!*** there in some of the variables. Of course the outer halo data +!*** around the domain boundary is included. +!----------------------------------------------------------------------- +! + istart=lbound(fields_core(nv)%ptr,1) + if(istart>1)then + istart=istart+halo + endif +! + iend =ubound(fields_core(nv)%ptr,1) + if(iend1)then + jstart=jstart+halo + endif +! + jend =ubound(fields_core(nv)%ptr,2) + if(jend1)then + istart=istart+halo + endif +! + iend =ubnd_x_tracers + if(iend1)then + jstart=jstart+halo + endif +! + jend =ubnd_y_tracers + if(jend Atm%q(:,:,:,sphum_index) rather than as was done +!*** for the core arrays which was ptr => Atm%u . +!----------------------------------------------------------------------- +! + istart_ptr=halo+1 + iend_ptr =ubnd_x_tracers-lbnd_x_tracers+1-halo + jstart_ptr=halo+1 + jend_ptr =ubnd_y_tracers-lbnd_y_tracers+1-halo +! + if(north_bc)then + jstart_ptr=1 + endif + if(south_bc)then + jend_ptr=ubnd_y_tracers-lbnd_y_tracers+1 + endif + if(east_bc)then + istart_ptr=1 + endif + if(west_bc)then + iend_ptr=ubnd_x_tracers-lbnd_x_tracers+1 + endif +! +!----------------------------------------------------------------------- +!*** Loop through that file's prognostic tracers. +!----------------------------------------------------------------------- +! + vbls_tracers: do nv=1,nfields_tracers +! + var_name=fields_tracers(nv)%name + if(is_root_pe)then + call check(nf90_inq_varid(ncid_tracers_new,var_name,var_id)) !<-- Get this variable's ID + endif +! +!----------------------------------------------------------------------- +!*** Gather onto a single task one layer at a time. That task +!*** writes the full data to the new larger restart file. +!----------------------------------------------------------------------- +! + do k=1,nz + call mpp_gather(istart,iend,jstart,jend & + ,pelist, fields_tracers(nv)%ptr(istart_ptr:iend_ptr,jstart_ptr:jend_ptr,k) & + ,global_field(:,:,k), is_root_pe, halo, halo) +! + if(is_root_pe)then + call check(nf90_put_var(ncid_tracers_new,var_id & + ,global_field(:,:,k) & + ,start=(/1,1,k/) & + ,count=(/count_i,count_j,1/))) + endif + enddo +! + enddo vbls_tracers +! + deallocate(global_field) +! + if(is_root_pe)then + call check(nf90_close(ncid_tracers_new)) + endif +! +!--------------------------------------------------------------------- + end subroutine write_full_fields +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +! + subroutine apply_delz_boundary(istart,iend,jstart,jend,nz & + ,Atm & + ,name & + ,field) +! +!--------------------------------------------------------------------- +!*** Use the current boundary values of delz to convert the +!*** boundary potential temperature to sensible temperature +!*** and to fill in the boundary rows of the 3D delz array. +!--------------------------------------------------------------------- +! +!------------------------ +!*** Argument variables +!------------------------ +! + integer,intent(in) :: istart,iend,jstart,jend +! + character(len=*),intent(in) :: name +! + type(fv_atmos_type),intent(inout) :: Atm +! + real,dimension(istart:iend,jstart:jend,1:nz),intent(inout) :: field +! +!--------------------- +!*** Local variables +!--------------------- +! + integer :: i1,i2,j1,j2,nz + integer :: lbnd1,lbnd2,ubnd1,ubnd2,i,j,k +! + real :: rdg +! + real,dimension(:,:,:),pointer :: delz_ptr +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! +!fill interior delz points before dealing with boundaries +! +!--------------------------------------------------------------------- +!*** Fill the interior of the full delz array using Atm%delz +!*** which does not have a boundary. +!--------------------------------------------------------------------- +! + if (trim(name)=='DZ') then + lbnd1=lbound(Atm%delz,1) + ubnd1=ubound(Atm%delz,1) + lbnd2=lbound(Atm%delz,2) + ubnd2=ubound(Atm%delz,2) +! + do k=1,nz + do j=lbnd2,ubnd2 + do i=lbnd1,ubnd1 + field(i,j,k)=Atm%delz(i,j,k) + enddo + enddo + enddo + endif +! + if(.not.(north_bc.or.south_bc.or.east_bc.or.west_bc))then + return !<-- Tasks not on the boundary may exit. + endif +! + rdg=-rdgas/grav +! +!--------------------------------------------------------------------- +! + if(north_bc)then + i1=istart + i2=iend + j1=jstart + j2=jstart+nhalo_model-1 + delz_ptr=>delz_auxiliary%north +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! + if(south_bc)then + i1=istart + i2=iend + j1=jend-nhalo_model+1 + j2=jend + delz_ptr=>delz_auxiliary%south +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! + if(east_bc)then + i1=istart + i2=istart+nhalo_model-1 + j1=jstart + j2=jend + if(north_bc)then + j1=jstart+nhalo_model + elseif(south_bc)then + j2=jend-nhalo_model + endif + delz_ptr=>delz_auxiliary%east +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! + if(west_bc)then + i1=iend-nhalo_model+1 + i2=iend + j1=jstart + j2=jend + if(north_bc)then + j1=jstart+nhalo_model + elseif(south_bc)then + j2=jend-nhalo_model + endif + delz_ptr=>delz_auxiliary%west +! + if(trim(name)=='T')then + call compute_halo_t + elseif(trim(name)=='DZ')then + call fill_delz + endif +! + endif +! +!--------------------------------------------------------------------- + contains +!--------------------------------------------------------------------- +! + subroutine compute_halo_t +! +!--------------------------------------------------------------------- +! + integer :: i,j,k +! + real :: cappa,cvm,dp1,part1,part2 +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! + do k=1,nz + do j=j1,j2 + do i=i1,i2 + dp1 = zvir*Atm%q(i,j,k,sphum_index) + cvm=(1.-Atm%q(i,j,k,sphum_index)+Atm%q_con(i,j,k))*cv_air & + +Atm%q(i,j,k,sphum_index)*cv_vap & + +Atm%q(i,j,k,liq_water_index)*c_liq + cappa=rdgas/(rdgas+cvm/(1.+dp1)) +! + part1=(1.+dp1)*(1.-Atm%q_con(i,j,k)) + part2=rdg*Atm%delp(i,j,k)*(1.+dp1)*(1.-Atm%q_con(i,j,k)) & + /delz_ptr(i,j,k) + field(i,j,k)=exp((log(field(i,j,k))-log(part1)+cappa*log(part2)) & + /(1.-cappa)) + enddo + enddo + enddo +! +!--------------------------------------------------------------------- + end subroutine compute_halo_t +!--------------------------------------------------------------------- +! + subroutine fill_delz +! +!--------------------------------------------------------------------- +! + integer :: i,j,k + integer :: lbnd1,lbnd2,ubnd1,ubnd2 +! +!--------------------------------------------------------------------- +!********************************************************************* +!--------------------------------------------------------------------- +! +!--------------------------------------------------------------------- +!*** Now fill the boundary rows using data from the BC files. +!--------------------------------------------------------------------- +! + do k=1,nz + do j=j1,j2 + do i=i1,i2 + field(i,j,k)=delz_ptr(i,j,k) + enddo + enddo + enddo +! +!--------------------------------------------------------------------- + end subroutine fill_delz +!--------------------------------------------------------------------- +! + end subroutine apply_delz_boundary +! !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- @@ -6249,8 +6548,7 @@ subroutine exch_uv(domain, bd, npz, u, v) real, intent(inout) :: u (bd%isd:bd%ied ,bd%jsd:bd%jed+1,1:npz) real, intent(inout) :: v (bd%isd:bd%ied+1,bd%jsd:bd%jed ,1:npz) - integer,parameter :: ibufexch=2500000 - real,dimension(ibufexch) :: buf1,buf2,buf3,buf4 + real, dimension(:), allocatable :: buf1,buf2,buf3,buf4 integer :: ihandle1,ihandle2,ihandle3,ihandle4 integer,dimension(MPI_STATUS_SIZE) :: istat integer :: ic, i, j, k, is, ie, js, je @@ -6259,7 +6557,6 @@ subroutine exch_uv(domain, bd, npz, u, v) integer :: mype integer :: north_pe, south_pe, east_pe, west_pe - mype = mpp_pe() call mpp_get_neighbor_pe( domain, NORTH, north_pe) call mpp_get_neighbor_pe( domain, SOUTH, south_pe) @@ -6276,18 +6573,33 @@ subroutine exch_uv(domain, bd, npz, u, v) js=bd%js je=bd%je + ! The size of these buffers must match the number of indices + ! required below to send/receive the data. In particular, + ! buf1 and buf4 must be of the same size (sim. for buf2 and buf3). + ! Changes to the code below should be tested with debug flags + ! enabled (out-of-bounds reads/writes). + allocate(buf1(1:24*npz)) + allocate(buf2(1:36*npz)) + allocate(buf3(1:36*npz)) + allocate(buf4(1:24*npz)) + ! FIXME: MPI_COMM_WORLD +#ifdef OVERLOAD_R4 +#define _DYN_MPI_REAL MPI_REAL +#else +#define _DYN_MPI_REAL MPI_DOUBLE_PRECISION +#endif ! Receive from north if( north_pe /= NULL_PE )then - call MPI_Irecv(buf1,ibufexch,MPI_REAL,north_pe,north_pe & + call MPI_Irecv(buf1,size(buf1),_DYN_MPI_REAL,north_pe,north_pe & ,MPI_COMM_WORLD,ihandle1,irecv) endif ! Receive from south if( south_pe /= NULL_PE )then - call MPI_Irecv(buf2,ibufexch,MPI_REAL,south_pe,south_pe & + call MPI_Irecv(buf2,size(buf2),_DYN_MPI_REAL,south_pe,south_pe & ,MPI_COMM_WORLD,ihandle2,irecv) endif @@ -6317,9 +6629,10 @@ subroutine exch_uv(domain, bd, npz, u, v) buf3(ic)=v(i,j,k) enddo enddo - enddo - call MPI_Issend(buf3,ic,MPI_REAL,north_pe,mype & + if (ic/=size(buf2).or.ic/=size(buf3)) & + call mpp_error(FATAL,'Buffer sizes buf2 and buf3 in routine exch_uv do not match actual message size') + call MPI_Issend(buf3,size(buf3),_DYN_MPI_REAL,north_pe,mype & ,MPI_COMM_WORLD,ihandle3,isend) endif @@ -6351,7 +6664,9 @@ subroutine exch_uv(domain, bd, npz, u, v) enddo enddo - call MPI_Issend(buf4,ic,MPI_REAL,south_pe,mype & + if (ic/=size(buf1).or.ic/=size(buf4)) & + call mpp_error(FATAL,'Buffer sizes buf1 and buf4 in routine exch_uv do not match actual message size') + call MPI_Issend(buf4,size(buf4),_DYN_MPI_REAL,south_pe,mype & ,MPI_COMM_WORLD,ihandle4,isend) endif @@ -6417,8 +6732,147 @@ subroutine exch_uv(domain, bd, npz, u, v) enddo endif + deallocate(buf1) + deallocate(buf2) + deallocate(buf3) + deallocate(buf4) + end subroutine exch_uv +!--------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!--------------------------------------------------------------------- + + subroutine get_data_source(data_source_fv3gfs,regional) +! +! This routine extracts the data source information if it is present in the datafile. +! + logical, intent(in):: regional + logical, intent(out):: data_source_fv3gfs + + character (len=80) :: source + logical :: lstatus + type(FmsNetcdfFile_t) :: Gfs_data + integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist +! +! Use the fms call here so we can actually get the return code value. +! The term 'source' is specified by 'chgres_cube' +! + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + if (regional) then + if (open_file(Gfs_data , 'INPUT/gfs_data.nc', "read", pelist=pes)) then + lstatus = global_att_exists(Gfs_data, "source") + if(lstatus) call get_global_attribute(Gfs_data, "source", source) + call close_file(Gfs_data) + endif + else + if (open_file(Gfs_data , 'INPUT/gfs_data.tile1.nc', "read", pelist=pes)) then + lstatus = global_att_exists(Gfs_data, "source") + if(lstatus) call get_global_attribute(Gfs_data, "source", source) + call close_file(Gfs_data) + endif + endif + deallocate(pes) + if (.not. lstatus) then + if (mpp_pe() == 0) write(0,*) 'INPUT source not found ',lstatus,' set source=No Source Attribute' + source='No Source Attribute' + endif + if (mpp_pe()==0) write(*,*) 'INPUT gfs_data source string=',source + +! Logical flag for fv3gfs nemsio/netcdf/grib2 -------- + if ( trim(source)=='FV3GFS GAUSSIAN NEMSIO FILE' .or. & + trim(source)=='FV3GFS GAUSSIAN NETCDF FILE' .or. & + trim(source)=='FV3GFS GRIB2 FILE' ) then + data_source_fv3gfs = .TRUE. + else + data_source_fv3gfs = .FALSE. + endif + if (mpp_pe()==0) write(*,*) 'data_source_fv3gfs=',data_source_fv3gfs + + 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 +! and remove it from the tracers +! + integer :: npz,nwat + type(fv_regional_BC_variables),intent(inout) :: BC_side !<-- The BC variables on a domain side at the final integration levels. +! +! local variables +! + integer :: k, j, i, iq, is, ie, js, je + integer :: liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt + real :: qt, wt, m_fac + + is=lbound(BC_side%delp_BC,1) + ie=ubound(BC_side%delp_BC,1) + js=lbound(BC_side%delp_BC,2) + je=ubound(BC_side%delp_BC,2) +! + 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') +! + source: if ( data_source_fv3gfs ) then +! +! if (cld_amt > 0) BC_side%q_BC(:,:,:,cld_amt) = 0.0 ! Moorthi + do k=1,npz + do j=js,je + do i=is,ie + wt = BC_side%delp_BC(i,j,k) + if ( nwat == 6 ) then + qt = wt*(1. + BC_side%q_BC(i,j,k,liq_wat) + & + BC_side%q_BC(i,j,k,ice_wat) + & + BC_side%q_BC(i,j,k,rainwat) + & + BC_side%q_BC(i,j,k,snowwat) + & + BC_side%q_BC(i,j,k,graupel)) + else ! all other values of nwat + qt = wt*(1. + sum(BC_side%q_BC(i,j,k,2:nwat))) + endif +!--- Adjust delp with tracer mass. + BC_side%delp_BC(i,j,k) = qt + enddo + enddo + enddo +! + else source ! This else block is for all sources other than FV3GFS GAUSSIAN NEMSIO/NETCDF and GRIB2 FILE +! +! 20160928: Adjust the mixing ratios consistently... + do k=1,npz + do j=js,je + do i=is,ie + wt = BC_side%delp_BC(i,j,k) + if ( nwat == 6 ) then + qt = wt*(1. + BC_side%q_BC(i,j,k,liq_wat) + & + BC_side%q_BC(i,j,k,ice_wat) + & + BC_side%q_BC(i,j,k,rainwat) + & + BC_side%q_BC(i,j,k,snowwat) + & + BC_side%q_BC(i,j,k,graupel)) + else ! all other values of nwat + qt = wt*(1. + sum(BC_side%q_BC(i,j,k,2:nwat))) + endif + m_fac = wt / qt + do iq=1,ntracers + BC_side%q_BC(i,j,k,iq) = m_fac * BC_side%q_BC(i,j,k,iq) + enddo + BC_side%delp_BC(i,j,k) = qt + enddo + enddo + enddo +! + endif source +! + end subroutine set_delp_and_tracers + !--------------------------------------------------------------------- !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--------------------------------------------------------------------- diff --git a/model/fv_sg.F90 b/model/fv_sg.F90 index f1f5ee4c5..b6bf503f8 100644 --- a/model/fv_sg.F90 +++ b/model/fv_sg.F90 @@ -1531,9 +1531,6 @@ subroutine prt_negative(qname, q, is, ie, js, je, n_g, km, threshold) do j=js,je do i=is,ie qmin = min(qmin, q(i,j,k)) -!!$ if (q(i,j,k) < threshold) then -!!$ print*, mpp_pe(), " Negative found in ", trim(qname), i, j, k, q(i,j,k) -!!$ endif enddo enddo enddo diff --git a/model/sw_core.F90 b/model/sw_core.F90 index edde55714..b98c5c82d 100644 --- a/model/sw_core.F90 +++ b/model/sw_core.F90 @@ -1840,26 +1840,6 @@ subroutine divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, flagstruct, enddo enddo -!!$ !Edges -!!$ -!!$ !West, East -!!$ do j=jsd+1,jed -!!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j) -!!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j) -!!$ end do -!!$ -!!$ !North, South -!!$ do i=isd+1,ied -!!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd) -!!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed) -!!$ end do -!!$ -!!$ !Corners (just use next corner value) -!!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1) -!!$ divg_d(isd,jed+1) = divg_d(isd+1,jed) -!!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1) -!!$ divg_d(ied+1,jed+1) = divg_d(ied,jed) - endif diff --git a/tools/coarse_grained_restart_files.F90 b/tools/coarse_grained_restart_files.F90 index c94bcf6bf..ce6297752 100644 --- a/tools/coarse_grained_restart_files.F90 +++ b/tools/coarse_grained_restart_files.F90 @@ -213,14 +213,14 @@ subroutine register_fv_core_coarse(hydrostatic, hybrid_z, & call register_restart_field(restart%fv_core_coarse, & 'v', restart%v, dim_names_4d2) endif - + if (write_coarse_agrid_vel_rst) then call register_restart_field(restart%fv_core_coarse, & 'ua', restart%ua, dim_names_4d3) call register_restart_field(restart%fv_core_coarse, & 'va', restart%va, dim_names_4d3) endif - + if (.not. hydrostatic) then call register_restart_field(restart%fv_core_coarse, & 'W', restart%w, dim_names_4d3, is_optional=.true.) diff --git a/tools/external_ic.F90 b/tools/external_ic.F90 index 7db34ee42..b7432ca0b 100644 --- a/tools/external_ic.F90 +++ b/tools/external_ic.F90 @@ -18,6 +18,7 @@ !* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** + #ifdef OVERLOAD_R4 #define _GET_VAR1 get_var1_real #else @@ -31,7 +32,8 @@ module external_ic_mod use fms2_io_mod, only: file_exists, open_file, close_file, read_data, variable_exists, & get_variable_size, get_global_attribute, global_att_exists, & FmsNetcdfFile_t, FmsNetcdfDomainFile_t, read_restart, & - register_restart_field, register_axis + register_restart_field, register_axis, get_dimension_size, & + get_variable_dimension_names, get_variable_num_dimensions use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe use mpp_mod, only: stdlog, input_nml_file, mpp_npes, mpp_get_current_pelist use mpp_parameter_mod, only: AGRID_PARAM=>AGRID @@ -46,7 +48,7 @@ module external_ic_mod 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 + use fv_regional_mod, only: dump_field, H_STAGGER, U_STAGGER, V_STAGGER, get_data_source use fv_mp_mod, only: is_master, fill_corners, YDir, mp_reduce_min, mp_reduce_max use fv_regional_mod, only: start_regional_cold_start use fv_surf_map_mod, only: surfdrv, FV3_zs_filter @@ -73,8 +75,7 @@ module external_ic_mod real, parameter:: zvir = rvgas/rdgas - 1. real(kind=R_GRID), parameter :: cnst_0p20=0.20d0 real :: deg2rad - character (len = 80) :: source - character(len=27), parameter :: source_fv3gfs = 'FV3GFS GAUSSIAN NEMSIO FILE' + logical :: source_fv3gfs ! version number of this module ! Include variable "version" to be written to log file. @@ -98,7 +99,7 @@ subroutine get_external_ic( Atm, fv_domain, cold_start ) integer :: is, ie, js, je integer :: isd, ied, jsd, jed, ng - integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, o3mr + integer :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, o3mr, sgs_tke, cld_amt is = Atm%bd%is ie = Atm%bd%ie @@ -191,6 +192,8 @@ subroutine get_external_ic( Atm, fv_domain, cold_start ) snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') graupel = get_tracer_index(MODEL_ATMOS, 'graupel') o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') + sgs_tke = get_tracer_index(MODEL_ATMOS, 'sgs_tke') + cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') if ( liq_wat > 0 ) & call prt_maxmin('liq_wat', Atm%q(:,:,:,liq_wat), is, ie, js, je, ng, Atm%npz, 1.) if ( ice_wat > 0 ) & @@ -203,16 +206,12 @@ subroutine get_external_ic( Atm, fv_domain, cold_start ) call prt_maxmin('graupel', Atm%q(:,:,:,graupel), is, ie, js, je, ng, Atm%npz, 1.) if ( o3mr > 0 ) & call prt_maxmin('O3MR', Atm%q(:,:,:,o3mr), is, ie, js, je, ng, Atm%npz, 1.) + if ( sgs_tke > 0 ) & + call prt_maxmin('sgs_tke', Atm%q(:,:,:,sgs_tke), is, ie, js, je, ng, Atm%npz, 1.) + if ( cld_amt > 0 ) & + call prt_maxmin('cld_amt', Atm%q(:,:,:,cld_amt), is, ie, js, je, ng, Atm%npz, 1.) endif -!Now in fv_restart -!!$ call p_var(Atm%npz, is, ie, js, je, Atm%ak(1), ptop_min, & -!!$ Atm%delp, Atm%delz, Atm%pt, Atm%ps, & -!!$ Atm%pe, Atm%peln, Atm%pk, Atm%pkz, & -!!$ kappa, Atm%q, ng, Atm%ncnst, Atm%gridstruct%area_64, Atm%flagstruct%dry_mass, & -!!$ Atm%flagstruct%adjust_dry_mass, Atm%flagstruct%mountain, Atm%flagstruct%moist_phys, & -!!$ Atm%flagstruct%hydrostatic, Atm%flagstruct%nwat, Atm%domain, Atm%flagstruct%adiabatic, Atm%flagstruct%make_nh) - end subroutine get_external_ic @@ -320,6 +319,7 @@ subroutine get_nggps_ic (Atm, fv_domain) type(FmsNetcdfDomainFile_t) :: ORO_restart, SFC_restart, GFS_restart type(FmsNetcdfFile_t) :: Gfs_ctl integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist + character(len=8), allocatable :: dim_names_alloc(:) character(len=8), dimension(2) :: dim_names_2d character(len=8), dimension(3) :: dim_names_3d, dim_names_3d2, dim_names_3d3, dim_names_3d4 character(len=6) :: stile_name @@ -338,7 +338,7 @@ subroutine get_nggps_ic (Atm, fv_domain) character(len=1) :: tile_num 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:: i,j,k,nts, ks, naxis_dims integer:: liq_wat, ice_wat, rainwat, snowwat, graupel, tke, ntclamt namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds, & checker_tr, nt_checker @@ -391,6 +391,8 @@ subroutine get_nggps_ic (Atm, fv_domain) if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes) ) then !--- read in the number of tracers in the NCEP NGGPS ICs call read_data (Gfs_ctl, 'ntrac', ntrac) +!--- read in the number of levp + call get_dimension_size(Gfs_ctl, 'levsp', levsp) call close_file(Gfs_ctl) else call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: file '//trim(fn_gfs_ctl)//' for NGGPS IC does not exist') @@ -403,23 +405,16 @@ subroutine get_nggps_ic (Atm, fv_domain) ! - call get_data_source(source,Atm%flagstruct%regional) + call get_data_source(source_fv3gfs,Atm%flagstruct%regional) -!--- read in the number of levp - call open_ncfile(fn_gfs_ctl, ncid ) ! open the file - call get_ncdim1( ncid, 'levsp', levsp ) - call close_ncfile( ncid ) - -! read in gfs_data. If levp = 66, read only the lowest 65 level - if (levsp .eq. 66) then - call mpp_error(NOTE,'==> External_ic::get_nggps_ic: Correcting BAD IC') - call read_gfs_data_bad() - else - call mpp_error(NOTE,'==> External_ic::get_nggps_ic: Reading properly processed IC') - call read_gfs_data_original() - endif + levp = levsp-1 + +! read in GFS IC + call mpp_error(NOTE,'==> External_ic::get_nggps_ic: Reading processed IC') + call mpp_error(NOTE,'==> External_ic::get_nggps_ic: IC has ', levp ,' levels' ) + call read_gfs_ic() !!! If a nested grid, save the filled coarse-grid topography for blending if (Atm%neststruct%nested) then allocate(phis_coarse(isd:ied,jsd:jed)) @@ -430,23 +425,27 @@ subroutine get_nggps_ic (Atm, fv_domain) enddo endif - ! set dimensions for register restart - dim_names_2d(1) = "lat" - dim_names_2d(2) = "lon" - !--- read in surface temperature (k) and land-frac ! surface skin temperature if( open_file(SFC_restart, fn_sfc_ics, "read", Atm%domain, is_restart=.true., dont_add_res_to_filename=.true.) ) then - call register_axis(SFC_restart, "lat", "y") - call register_axis(SFC_restart, "lon", "x") - call register_restart_field(SFC_restart, 'tsea', Atm%ts, dim_names_2d) + naxis_dims = get_variable_num_dimensions(SFC_restart, 'tsea') + allocate (dim_names_alloc(naxis_dims)) + call get_variable_dimension_names(SFC_restart, 'tsea', dim_names_alloc) + call register_axis(SFC_restart, dim_names_alloc(2), "y") + call register_axis(SFC_restart, dim_names_alloc(1), "x") + call register_restart_field(SFC_restart, 'tsea', Atm%ts, dim_names_alloc) call read_restart(SFC_restart) call close_file(SFC_restart) + deallocate (dim_names_alloc) else 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') + ! set dimensions for register restart + dim_names_2d(1) = "lat" + dim_names_2d(2) = "lon" + ! terrain surface height -- (needs to be transformed into phis = zs*grav) if( open_file(ORO_restart, fn_oro_ics, "read", Atm%domain, is_restart=.true., dont_add_res_to_filename=.true.) ) then call register_axis(ORO_restart, "lat", "y") @@ -505,15 +504,6 @@ subroutine get_nggps_ic (Atm, fv_domain) Atm%ak(1:npz+1) = ak(itoa:levp+1) Atm%bk(1:npz+1) = bk(itoa:levp+1) call set_external_eta (Atm%ak, Atm%bk, Atm%ptop, Atm%ks) -!!$ else -!!$ if ( (npz == 63 .or. npz == 64) .and. len(trim(Atm%flagstruct%npz_type)) == 0 ) then -!!$ if (is_master()) print*, 'Using default GFS levels' -!!$ Atm%ak(:) = ak_sj(:) -!!$ Atm%bk(:) = bk_sj(:) -!!$ Atm%ptop = Atm%ak(1) -!!$ else -!!$ call set_eta(npz, ks, Atm%ptop, Atm%ak, Atm%bk, Atm%flagstruct%npz_type) -!!$ endif endif ! call vertical remapping algorithms if(is_master()) write(*,*) 'GFS ak(1)=', ak(1), ' ak(2)=', ak(2) @@ -644,7 +634,7 @@ subroutine get_nggps_ic (Atm, fv_domain) snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') graupel = get_tracer_index(MODEL_ATMOS, 'graupel') ntclamt = get_tracer_index(MODEL_ATMOS, 'cld_amt') - if (trim(source) == source_fv3gfs) then + if (source_fv3gfs) then do k=1,npz do j=js,je do i=is,ie @@ -719,13 +709,13 @@ subroutine get_nggps_ic (Atm, fv_domain) deallocate (bk) deallocate (ps) deallocate (q ) - if (trim(source) == source_fv3gfs) deallocate (temp) + if (source_fv3gfs) deallocate (temp) deallocate (omga) contains - subroutine read_gfs_data_original() + subroutine read_gfs_ic() ! !--- read in ak and bk from the gfs control file using fms_io read_data --- ! @@ -752,7 +742,7 @@ subroutine read_gfs_data_original() 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) ) - if (trim(source) == source_fv3gfs) allocate (temp(is:ie,js:je,1:levp)) + if (source_fv3gfs) allocate (temp(is:ie,js:je,1:levp)) ! initialize dim_names for register restart dim_names_3d(1) = "lev" @@ -790,7 +780,7 @@ subroutine read_gfs_data_original() call register_restart_field(GFS_restart, 'zh', zh, dim_names_3d4) ! real temperature (K) - if (trim(source) == source_fv3gfs) call register_restart_field(GFS_restart, 't', temp, dim_names_3d3, is_optional=.true.) + if (source_fv3gfs) call register_restart_field(GFS_restart, 't', temp, dim_names_3d3, is_optional=.true.) ! prognostic tracers do nt = 1, ntracers @@ -807,117 +797,7 @@ subroutine read_gfs_data_original() endif call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using tiled data file '//trim(fn_gfs_ics)//' for NGGPS IC') - endsubroutine read_gfs_data_original - - - subroutine read_gfs_data_bad() - ! local variables for reading the gfs_data - real, dimension(:), allocatable:: ak_tmp, bk_tmp - real, dimension(:,:), allocatable:: wk2_tmp - real, dimension(:,:,:), allocatable:: u_w_tmp, v_w_tmp, u_s_tmp, v_s_tmp, omga_tmp, temp_tmp, zh_tmp - real, dimension(:,:,:,:), allocatable:: q_tmp - - allocate (wk2_tmp(levsp,2)) - allocate (zh_tmp(is:ie,js:je,levsp)) - allocate (omga_tmp(is:ie,js:je,levsp-1)) - allocate (q_tmp (is:ie,js:je,levsp-1,ntracers)) - allocate ( u_w_tmp(is:ie+1, js:je, 1:levsp-1) ) - allocate ( v_w_tmp(is:ie+1, js:je, 1:levsp-1) ) - allocate ( u_s_tmp(is:ie, js:je+1, 1:levsp-1) ) - allocate ( v_s_tmp(is:ie, js:je+1, 1:levsp-1) ) - allocate (temp_tmp(is:ie,js:je,1:levsp-1)) - - - allocate (ps(is:ie,js:je)) - - allocate (ak(levp+1)) - allocate (bk(levp+1)) - allocate (zh(is:ie,js:je,levp+1)) - 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,1:levp)) - - ! - !--- read in ak and bk from the gfs control file using fms_io read_data --- - ! - ! put the lowest 64 levels into ak and bk - allocate(pes(mpp_npes())) - call mpp_get_current_pelist(pes) - if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes) ) then - call read_data(Gfs_ctl,'vcoord',wk2_tmp) - ak(1:levp+1) = wk2_tmp(2:levsp,1) - bk(1:levp+1) = wk2_tmp(2:levsp,2) - - deallocate (wk2_tmp) - call close_file(Gfs_ctl) - endif - deallocate(pes) - - ! surface pressure (Pa) - - if( open_file(GFS_restart, fn_gfs_ics, "read", Atm%domain, is_restart=.true., dont_add_res_to_filename=.true.) ) then - call register_axis(GFS_restart, "lat", "y") - call register_axis(GFS_restart, "lon", "x") - call register_axis(GFS_restart, "lonp", "x", domain_position=east) - call register_axis(GFS_restart, "latp", "y", domain_position=north) - call register_axis(GFS_restart, "lev", size(u_w_tmp,3)) - call register_axis(GFS_restart, "levp", size(zh_tmp,3)) - - - - call register_restart_field(GFS_restart, 'ps', ps, dim_names_2d) - ! D-grid west face tangential wind component (m/s) - call register_restart_field(GFS_restart, 'u_w', u_w_tmp, dim_names_3d) - ! D-grid west face normal wind component (m/s) - call register_restart_field(GFS_restart, 'v_w', v_w_tmp, dim_names_3d) - ! D-grid south face tangential wind component (m/s) - call register_restart_field(GFS_restart, 'u_s', u_s_tmp, dim_names_3d2) - ! D-grid south face normal wind component (m/s) - call register_restart_field(GFS_restart, 'v_s', v_s_tmp, dim_names_3d2) - ! vertical velocity 'omega' (Pa/s) - call register_restart_field(GFS_restart, 'w', omga_tmp, dim_names_3d3) - ! GFS grid height at edges (including surface height) - call register_restart_field(GFS_restart, 'zh', zh_tmp, dim_names_3d4) - ! real temperature (K) - call register_restart_field(GFS_restart, 't', temp_tmp, dim_names_3d3, is_optional=.true.) - - ! Prognostic tracers - do nt = 1, ntracers - call get_tracer_names(MODEL_ATMOS, nt, tracer_name) - call register_restart_field(GFS_restart, trim(tracer_name), q_tmp(:,:,:,nt), dim_names_3d3, is_optional=.true.) - enddo - - - ! read in the gfs_data and free the restart type to be re-used by the nest - call read_restart(GFS_restart) - call close_file(GFS_restart) - else - 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') - - ! extract and return the lowest 64 levels of data - do nt = 1, ntracers - q(is:ie,js:je,1:levp,nt) = q_tmp(is:ie,js:je,2:levsp-1,nt) - enddo - - zh (is:ie,js:je,1:levp+1) = zh_tmp(is:ie,js:je,2:levsp) - omga(is:ie,js:je,1:levp) = omga_tmp(is:ie,js:je,2:levsp-1) - - u_w(is:ie+1, js:je, 1:levp) = u_w_tmp(is:ie+1, js:je, 2:levsp-1) - v_w(is:ie+1, js:je, 1:levp) = v_w_tmp(is:ie+1, js:je, 2:levsp-1) - u_s(is:ie, js:je+1, 1:levp) = u_s_tmp(is:ie, js:je+1, 2:levsp-1) - v_s(is:ie, js:je+1, 1:levp) = v_s_tmp(is:ie, js:je+1, 2:levsp-1) - temp(is:ie,js:je,1:levp) = temp_tmp(is:ie,js:je,1:levsp-1) - - deallocate(u_w_tmp, v_w_tmp, u_s_tmp, v_s_tmp, omga_tmp, zh_tmp, temp_tmp, q_tmp) - - - endsubroutine read_gfs_data_bad + endsubroutine read_gfs_ic end subroutine get_nggps_ic @@ -987,6 +867,8 @@ subroutine get_hrrr_ic (Atm, fv_domain) integer:: liq_wat, ice_wat, rainwat, snowwat, graupel, tke, ntclamt namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds, & checker_tr, nt_checker + ! variables for reading the dimension from the hrrr_ctrl + integer ncid, levsp call mpp_error(NOTE,'Using external_IC::get_hrrr_ic which is valid only for data which has been & &horizontally interpolated to the current lambert grid') @@ -1029,6 +911,10 @@ subroutine get_hrrr_ic (Atm, fv_domain) &than defined in field_table '//trim(fn_hrr_ctl)//' for HRRR IC') !--- read in ak and bk from the HRRR control file using fms_io read_data --- + call get_dimension_size(Hrr_ctl, 'levsp', levsp) + + levp = levsp-1 + allocate (wk2(levp+1,2)) allocate (ak(levp+1)) allocate (bk(levp+1)) @@ -1054,24 +940,13 @@ subroutine get_hrrr_ic (Atm, fv_domain) allocate ( v_s(is:ie, js:je+1, 1:levp) ) - !!! If a nested grid, save the filled coarse-grid topography for blending - if (Atm%neststruct%nested) then - allocate(phis_coarse(isd:ied,jsd:jed)) - do j=jsd,jed - do i=isd,ied - phis_coarse(i,j) = Atm%phis(i,j) - enddo - enddo - endif - ! set dimensions for register restart - dim_names_2d(1) = "lat" - dim_names_2d(2) = "lon" !--- read in surface temperature (k) and land-frac ! surface skin temperature if( open_file(SFC_restart, fn_sfc_ics, "read", Atm%domain, is_restart=.true., dont_add_res_to_filename=.true.) ) then - call register_axis(SFC_restart, "lat", "y") - call register_axis(SFC_restart, "lon", "x") + call get_variable_dimension_names(SFC_restart, 'tsea', dim_names_2d) + call register_axis(SFC_restart, dim_names_2d(2), "y") + call register_axis(SFC_restart, dim_names_2d(1), "x") call register_restart_field(SFC_restart, 'tsea', Atm%ts, dim_names_2d) call read_restart(SFC_restart) call close_file(SFC_restart) @@ -1080,6 +955,10 @@ subroutine get_hrrr_ic (Atm, fv_domain) endif call mpp_error(NOTE,'==> External_ic::get_hrrr_ic: using tiled data file '//trim(fn_sfc_ics)//' for HRRR IC') + ! set dimensions for register restart + dim_names_2d(1) = "lat" + dim_names_2d(2) = "lon" + ! terrain surface height -- (needs to be transformed into phis = zs*grav) if( open_file(ORO_restart, fn_oro_ics, "read", Atm%domain, is_restart=.true., dont_add_res_to_filename=.true.) ) then call register_axis(ORO_restart, "lat", "y") @@ -1096,9 +975,6 @@ subroutine get_hrrr_ic (Atm, fv_domain) ! land-frac call register_restart_field(ORO_restart, 'land_frac', oro_g, dim_names_2d) call mpp_update_domains(oro_g, Atm%domain) - if (Atm%neststruct%nested) then - call extrapolation_BC(oro_g, 0, 0, Atm%npx, Atm%npy, Atm%bd, .true.) - endif endif if ( Atm%flagstruct%fv_land ) then @@ -1185,6 +1061,10 @@ subroutine get_hrrr_ic (Atm, fv_domain) if(is_master()) write(*,*) 'HRRR ak(1)=', ak(1), ' ak(2)=', ak(2) ak(1) = max(1.e-9, ak(1)) + + ! this is necessary to remap temperature and w correctly + source_fv3gfs = .True. + !*** 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 @@ -1201,7 +1081,7 @@ subroutine get_hrrr_ic (Atm, fv_domain) ! !*** Remap the variables in the compute domain. ! - call remap_scalar_nh(Atm, levp, npz, ntracers, ak, bk, ps, q, zh, w, t) + call remap_scalar(Atm, levp, npz, ntracers, ak, bk, ps, q, zh, w, t) allocate ( ud(is:ie, js:je+1, 1:levp) ) allocate ( vd(is:ie+1,js:je, 1:levp) ) @@ -1230,18 +1110,6 @@ subroutine get_hrrr_ic (Atm, fv_domain) deallocate ( ud ) deallocate ( vd ) - if (Atm%neststruct%nested) then - if (is_master()) write(*,*) 'Blending nested and coarse grid topography' - npx = Atm%npx - npy = Atm%npy - do j=jsd,jed - do i=isd,ied - wt = max(0.,min(1.,real(5 - min(i,j,npx-i,npy-j,5))/5. )) - Atm%phis(i,j) = (1.-wt)*Atm%phis(i,j) + wt*phis_coarse(i,j) - enddo - enddo - endif - !!! Perform terrain smoothing, if desired if ( Atm%flagstruct%full_zs_filter ) then @@ -1282,17 +1150,6 @@ subroutine get_hrrr_ic (Atm, fv_domain) endif - if ( Atm%neststruct%nested .and. ( Atm%flagstruct%n_zs_filter > 0 .or. Atm%flagstruct%full_zs_filter ) ) then - npx = Atm%npx - npy = Atm%npy - do j=jsd,jed - do i=isd,ied - wt = max(0.,min(1.,real(5 - min(i,j,npx-i,npy-j,5))/5. )) - Atm%phis(i,j) = (1.-wt)*Atm%phis(i,j) + wt*phis_coarse(i,j) - enddo - enddo - deallocate(phis_coarse) - endif call mpp_update_domains( Atm%phis, Atm%domain, complete=.true. ) @@ -1930,7 +1787,7 @@ subroutine get_ecmwf_ic( Atm, fv_domain ) logical:: found integer :: is, ie, js, je integer :: isd, ied, jsd, jed - integer :: sphum, o3mr, liq_wat, ice_wat, rainwat, snowwat, graupel + integer :: sphum, o3mr, liq_wat, ice_wat, rainwat, snowwat, graupel, sgs_tke, cld_amt real:: wt, qt, m_fac real(kind=8) :: scale_value, offset, ptmp real(kind=R_GRID), dimension(2):: p1, p2, p3 @@ -1973,32 +1830,27 @@ subroutine get_ecmwf_ic( Atm, fv_domain ) snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') graupel = get_tracer_index(MODEL_ATMOS, 'graupel') o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') - - if (is_master()) then - print *, 'sphum = ', sphum - print *, 'liq_wat = ', liq_wat - if ( Atm%flagstruct%nwat .eq. 6 ) then - print *, 'rainwat = ', rainwat - print *, 'iec_wat = ', ice_wat - print *, 'snowwat = ', snowwat - print *, 'graupel = ', graupel - endif - print *, ' o3mr = ', o3mr - endif - + sgs_tke = get_tracer_index(MODEL_ATMOS, 'sgs_tke') + cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') + + !if (is_master()) then + ! print *, 'sphum = ', sphum + ! print *, 'liq_wat = ', liq_wat + ! if ( Atm%flagstruct%nwat .eq. 6 ) then + ! print *, 'rainwat = ', rainwat + ! print *, 'iec_wat = ', ice_wat + ! print *, 'snowwat = ', snowwat + ! print *, 'graupel = ', graupel + ! endif + ! print *, ' o3mr = ', o3mr + ! print *, ' sgs_tke = ', sgs_tke + ! print *, ' cld_amt = ', cld_amt + !endif ! Set up model's ak and bk if (Atm%flagstruct%external_eta) then call set_external_eta (Atm%ak, Atm%bk, Atm%ptop, Atm%ks) endif -!!$ if ( (npz == 64 .or. npz == 63) .and. len(trim(Atm%flagstruct%npz_type)) == 0 ) then -!!$ if (is_master()) print*, 'Using default GFS levels' -!!$ Atm%ak(:) = ak_sj(:) -!!$ Atm%bk(:) = bk_sj(:) -!!$ Atm%ptop = Atm%ak(1) -!!$ else -!!$ call set_eta(npz, ks, Atm%ptop, Atm%ak, Atm%bk, Atm%flagstruct%npz_type) -!!$ endif !!! If a nested grid, add "nestXX.tileX" to the filename if (Atm%neststruct%nested) then @@ -2090,6 +1942,12 @@ subroutine get_ecmwf_ic( Atm, fv_domain ) if(is_master()) write(*,*) fname if(is_master()) write(*,*) ' ECMWF IC dimensions:', tsize + if(is_master()) write(*,*) ' NOTE: The amount of EC IC data read from disk depends on ' + if(is_master()) write(*,*) ' the latitudinal extent of a processor decomposition.' + if(is_master()) write(*,*) ' This could potentially be memory-intensive. If the ' + if(is_master()) write(*,*) ' model crashes reading in the ICs try using more' + if(is_master()) write(*,*) ' processor cores, at least to create the initial' + if(is_master()) write(*,*) ' conditions.' allocate ( lon(im) ) allocate ( lat(jm) ) @@ -2507,6 +2365,27 @@ subroutine get_ecmwf_ic( Atm, fv_domain ) enddo #endif + if (cld_amt > 0) then + do k=1,npz + do j=js,je + do i=is,ie + Atm%q(i,j,k,cld_amt) = 0.0 ! Moorthi + enddo + enddo + enddo + endif + + if (sgs_tke > 0) then + do k=1,npz + do j=js,je + do i=is,ie + !pe1 = Atm%ak(k+1) + Atm%bk(k+1)*Atm%ps(i,j) + Atm%q(i,j,k,sgs_tke) = 0.02 ! 1.*exp(-(Atm%ps(i,j) - pe1)**2) + enddo + enddo + enddo + endif + deallocate ( ak0, bk0 ) ! deallocate ( psc ) deallocate ( psc_r8 ) @@ -2837,303 +2716,6 @@ subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & end subroutine remap_coef - - subroutine remap_scalar_nh(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, w, t) - 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):: w, t - 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, o3mr, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt - 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') - o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') - - if (mpp_pe()==1) then - print *, 'In remap_scalar:' - print *, 'ncnst = ', ncnst - print *, 'nwat = ', Atm%flagstruct%nwat - 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 - - if ( sphum/=1 ) then - call mpp_error(FATAL,'SPHUM must be 1st tracer') - endif - - k2 = max(10, km/2) - -#ifdef USE_GFS_ZS - Atm%phis(is:ie,js:je) = zh(is:ie,js:je,km+1)*grav -#endif - - if (Atm%flagstruct%ecmwf_ic) then - if (cld_amt .gt. 0) Atm%q(i,j,k,cld_amt) = 0. - endif - -!$OMP parallel do default(none) & -!$OMP shared(sphum,liq_wat,rainwat,ice_wat,snowwat,graupel,& -!$OMP cld_amt,ncnst,npz,is,ie,js,je,km,k2,ak0,bk0,psc,zh,w,t,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 - - do k=1,km - do i=is,ie - qp(i,k) = t(i,j,k) - enddo - enddo - call mappm(km, log(pe0), qp, npz, log(pe1), qn1, is,ie, 2, 4, Atm%ptop) - do k=1,npz - do i=is,ie - atm%pt(i,j,k) = qn1(i,k) - enddo - enddo - -!--------------------------------------------------- -! Retrive temperature using geopotential height from external data -!--------------------------------------------------- - do i=is,ie -! Make sure FV3 top is lower than GFS; can not do extrapolation above the top at this point - if ( pn1(i,1) .lt. pn0(i,1) ) then - call mpp_error(FATAL,'FV3 top higher than external data') - endif - - do k=1,km+1 - pn(k) = pn0(i,k) - gz(k) = zh(i,j,k)*grav - enddo -!------------------------------------------------- - do k=km+2, km+k2 - l = 2*(km+1) - k - gz(k) = 2.*gz(km+1) - gz(l) - pn(k) = 2.*pn(km+1) - pn(l) - enddo -!------------------------------------------------- - - gz_fv(npz+1) = Atm%phis(i,j) - - m = 1 - - do k=1,npz -! Searching using FV3 log(pe): pn1 -#ifdef USE_ISOTHERMO - do l=m,km - if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then - gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) - goto 555 - elseif ( pn1(i,k) .gt. pn(km+1) ) then -! Isothermal under ground; linear in log-p extra-polation - gz_fv(k) = gz(km+1) + (gz_fv(npz+1)-gz(km+1))*(pn1(i,k)-pn(km+1))/(pn1(i,npz+1)-pn(km+1)) - goto 555 - endif - enddo -#else - do l=m,km+k2-1 - if ( (pn1(i,k).le.pn(l+1)) .and. (pn1(i,k).ge.pn(l)) ) then - gz_fv(k) = gz(l) + (gz(l+1)-gz(l))*(pn1(i,k)-pn(l))/(pn(l+1)-pn(l)) - goto 555 - endif - enddo -#endif -555 m = l - enddo - - do k=1,npz+1 - Atm%peln(i,k,j) = pn1(i,k) - enddo - - 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 - - - do k=1,npz - do i=is,ie - - 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 - - -!------------------------------------------------------------- -! map omega or w -!------- ------------------------------------------------------ - if ( (.not. Atm%flagstruct%hydrostatic) .and. (.not. Atm%flagstruct%ncep_ic) ) then - do k=1,km - do i=is,ie - qp(i,k) = w(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) - enddo - enddo - endif - -5000 continue - -! Add some diagnostics: - if (.not. Atm%flagstruct%hydrostatic) call p_maxmin('delz_model', Atm%delz, is, ie, js, je, npz, 1.) - call p_maxmin('sphum_model', Atm%q(is:ie,js:je,1:npz,sphum), is, ie, js, je, npz, 1.) - call p_maxmin('liq_wat_model', Atm%q(is:ie,js:je,1:npz,liq_wat), is, ie, js, je, npz, 1.) - call p_maxmin('ice_wat_model', Atm%q(is:ie,js:je,1:npz,ice_wat), is, ie, js, je, npz, 1.) - call p_maxmin('rainwat_model', Atm%q(is:ie,js:je,1:npz,rainwat), is, ie, js, je, npz, 1.) - call p_maxmin('snowwat_model', Atm%q(is:ie,js:je,1:npz,snowwat), is, ie, js, je, npz, 1.) - call p_maxmin('graupel_model', Atm%q(is:ie,js:je,1:npz,graupel), is, ie, js, je, npz, 1.) - call p_maxmin('cld_amt_model', Atm%q(is:ie,js:je,1:npz,cld_amt), is, ie, js, je, npz, 1.) - call p_maxmin('PS_model (mb)', Atm%ps(is:ie,js:je), is, ie, js, je, 1, 0.01) - call p_maxmin('PT_model', Atm%pt(is:ie,js:je,1:npz), is, ie, js, je, npz, 1.) - call pmaxmn('ZS_model', Atm%phis(is:ie,js:je)/grav, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) - call pmaxmn('ZS_data', zh(is:ie,js:je,km+1), is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) - do j=js,je - do i=is,ie - wk(i,j) = Atm%phis(i,j)/grav - zh(i,j,km+1) - ! if ((wk(i,j) > 1800.).or.(wk(i,j)<-1600.)) then - ! print *,' ' - ! print *, 'Diff = ', wk(i,j), 'Atm%phis =', Atm%phis(i,j)/grav, 'zh = ', zh(i,j,km+1) - ! print *, 'lat = ', Atm%gridstruct%agrid(i,j,2)/deg2rad, 'lon = ', Atm%gridstruct%agrid(i,j,1)/deg2rad - ! endif - enddo - enddo - call pmaxmn('ZS_diff (m)', wk, is, ie, js, je, 1, 1., Atm%gridstruct%area_64, Atm%domain) - - - 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_nh' - - end subroutine remap_scalar_nh - - subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) type(fv_atmos_type), intent(inout) :: Atm integer, intent(in):: km, npz, ncnst @@ -3157,7 +2739,7 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) real(kind=R_GRID):: pst !!! High-precision integer i,j,k,l,m, k2,iq - integer sphum, o3mr, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt + integer sphum, o3mr, liq_wat, ice_wat, rainwat, snowwat, graupel, cld_amt, sgs_tke integer :: is, ie, js, je is = Atm%bd%is @@ -3173,6 +2755,7 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) graupel = get_tracer_index(MODEL_ATMOS, 'graupel') cld_amt = get_tracer_index(MODEL_ATMOS, 'cld_amt') o3mr = get_tracer_index(MODEL_ATMOS, 'o3mr') + sgs_tke = get_tracer_index(MODEL_ATMOS, 'sgs_tke') if (mpp_pe()==1) then print *, 'In remap_scalar:' @@ -3186,6 +2769,9 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) print *, 'snowwat = ', snowwat print *, 'graupel = ', graupel endif + print *, 'o3mr = ', o3mr + print *, 'sgs_tke = ', sgs_tke + print *, 'cld_amt = ', cld_amt endif if ( sphum/=1 ) then @@ -3198,12 +2784,8 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) Atm%phis(is:ie,js:je) = zh(is:ie,js:je,km+1)*grav #endif - if (Atm%flagstruct%ecmwf_ic) then - if (cld_amt .gt. 0) Atm%q(i,j,k,cld_amt) = 0. - endif - !$OMP parallel do default(none) & -!$OMP shared(sphum,liq_wat,rainwat,ice_wat,snowwat,graupel,source,& +!$OMP shared(sphum,liq_wat,rainwat,ice_wat,snowwat,graupel,source_fv3gfs,& !$OMP cld_amt,ncnst,npz,is,ie,js,je,km,k2,ak0,bk0,psc,zh,omga,qa,Atm,z500,t_in) & !$OMP private(l,m,pst,pn,gz,pe0,pn0,pe1,pn1,dp2,qp,qn1,gz_fv) @@ -3348,7 +2930,7 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) !---------------------------------------------------- ! Compute true temperature using hydrostatic balance !---------------------------------------------------- - if (trim(source) /= source_fv3gfs .or. .not. present(t_in)) then + if (.not. source_fv3gfs .or. .not. present(t_in)) then 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)) ) @@ -3380,7 +2962,7 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) ! seperate cloud water and cloud ice from Jan-Huey Chen's HiRAM code ! only use for NCEP IC and GFDL microphy !----------------------------------------------------------------------- - if (trim(source) /= source_fv3gfs) then + if (.not. source_fv3gfs) then if ((Atm%flagstruct%nwat .eq. 3 .or. Atm%flagstruct%nwat .eq. 6) .and. & (Atm%flagstruct%ncep_ic .or. Atm%flagstruct%nggps_ic)) then do k=1,npz @@ -3398,15 +2980,6 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) 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 @@ -3452,7 +3025,7 @@ subroutine remap_scalar(Atm, km, npz, ncnst, ak0, bk0, psc, qa, zh, omga, t_in) enddo enddo call mappm(km, pe0, qp, npz, pe1, qn1, is,ie, -1, 4, Atm%ptop) - if (trim(source) == source_fv3gfs) then + if (source_fv3gfs) then do k=1,npz do i=is,ie atm%w(i,j,k) = qn1(i,k) @@ -4534,40 +4107,6 @@ subroutine get_staggered_grid( is, ie, js, je, isd, ied, jsd, jed, pt_b, pt_c, p end subroutine get_staggered_grid - subroutine get_data_source(source,regional) -! -! This routine extracts the data source information if it is present in the datafile. -! - character (len = 80) :: source - integer :: ncids,sourceLength - logical :: lstatus,regional - type(FmsNetcdfFile_t) :: Gfs_data - integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist -! -! Use the fms call here so we can actually get the return code value. -! - allocate(pes(mpp_npes())) - call mpp_get_current_pelist(pes) - if (regional) then - if (open_file(Gfs_data , 'INPUT/gfs_data.nc', "read", pelist=pes)) then - lstatus = global_att_exists(Gfs_data, "source") - if(lstatus) call get_global_attribute(Gfs_data, "source", source) - call close_file(Gfs_data) - endif - else - if (open_file(Gfs_data , 'INPUT/gfs_data.tile1.nc', "read", pelist=pes)) then - lstatus = global_att_exists(Gfs_data, "source") - if(lstatus) call get_global_attribute(Gfs_data, "source", source) - call close_file(Gfs_data) - endif - endif - deallocate(pes) - if (.not. lstatus) then - if (mpp_pe() == 0) write(0,*) 'INPUT source not found ',lstatus,' set source=No Source Attribute' - source='No Source Attribute' - endif - end subroutine get_data_source - end module external_ic_mod diff --git a/tools/fv_diagnostics.F90 b/tools/fv_diagnostics.F90 index bcf064352..f5f98a229 100644 --- a/tools/fv_diagnostics.F90 +++ b/tools/fv_diagnostics.F90 @@ -791,11 +791,6 @@ subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref) 'layer-averaged temperature tendency from physics', 'K/s', missing_value=missing_value ) if (id_t_dt_phys_plev_ave > 0 .and. .not. allocated(Atm(n)%phys_diag%phys_t_dt) ) allocate(Atm(n)%phys_diag%phys_t_dt(isc:iec,jsc:jec,npz)) ! flag for calculation of geopotential -!!$ if ( all(id_h(minloc(abs(levs-10)))>0) .or. all(id_h(minloc(abs(levs-50)))>0) .or. & -!!$ all(id_h(minloc(abs(levs-100)))>0) .or. all(id_h(minloc(abs(levs-200)))>0) .or. & -!!$ all(id_h(minloc(abs(levs-250)))>0) .or. all(id_h(minloc(abs(levs-300)))>0) .or. & -!!$ all(id_h(minloc(abs(levs-500)))>0) .or. all(id_h(minloc(abs(levs-700)))>0) .or. & -!!$ all(id_h(minloc(abs(levs-850)))>0) .or. all(id_h(minloc(abs(levs-1000)))>0).or. & if ( any(id_h > 0) .or. id_h_plev>0 .or. id_hght3d>0) then id_any_hght = 1 else @@ -1877,36 +1872,6 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) endif - - -!!$ if ( id_srh > 0 ) then -!!$ call helicity_relative(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, & -!!$ Atm(n)%ua, Atm(n)%va, Atm(n)%delz, Atm(n)%q, & -!!$ Atm(n)%flagstruct%hydrostatic, Atm(n)%pt, Atm(n)%peln, Atm(n)%phis, grav, 0., 3.e3) -!!$ used = send_data ( id_srh, a2, Time ) -!!$ if(prt_minmax) then -!!$ do j=jsc,jec -!!$ do i=isc,iec -!!$ tmp = rad2deg * Atm(n)%gridstruct%agrid(i,j,1) -!!$ tmp2 = rad2deg * Atm(n)%gridstruct%agrid(i,j,2) -!!$ if ( tmp2<25. .or. tmp2>50. & -!!$ .or. tmp<235. .or. tmp>300. ) then -!!$ a2(i,j) = 0. -!!$ endif -!!$ enddo -!!$ enddo -!!$ call prt_maxmin('SRH over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.) -!!$ endif -!!$ endif - -!!$ if ( id_srh25 > 0 ) then -!!$ call helicity_relative(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, & -!!$ Atm(n)%ua, Atm(n)%va, Atm(n)%delz, Atm(n)%q, & -!!$ Atm(n)%flagstruct%hydrostatic, Atm(n)%pt, Atm(n)%peln, Atm(n)%phis, grav, 2.e3, 5.e3) -!!$ used = send_data ( id_srh25, a2, Time ) -!!$ endif - - ! Relative Humidity if ( id_rh > 0 ) then ! Compute FV mean pressure @@ -2739,8 +2704,6 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) a2(i,j) = missing_value3 var1(i,j) = missing_value3 var2(i,j) = missing_value2 -!!$ a2(i,j) = Atm(n)%pt(i,j,k) -!!$ var1(i,j) = 0.01*Atm(n)%pe(i,k+1,j) ! surface pressure endif enddo enddo @@ -6011,65 +5974,6 @@ subroutine getcape( nk , p , t , dz, q, the, cape , cin, source_in ) ENDIF if(debug_level.ge.100) print *,' kmin,maxthe = ',kmin,maxthe -!!$ ELSEIF(source.eq.3)THEN -!!$ ! use mixed layer -!!$ -!!$ IF( dz(nk).gt.ml_depth )THEN -!!$ ! the second level is above the mixed-layer depth: just use the -!!$ ! lowest level -!!$ -!!$ avgth = th(nk) -!!$ avgqv = q(nk) -!!$ kmin = nk -!!$ -!!$ ELSEIF( z(1).lt.ml_depth )THEN -!!$ ! the top-most level is within the mixed layer: just use the -!!$ ! upper-most level (not -!!$ -!!$ avgth = th(1) -!!$ avgqv = q(1) -!!$ kmin = 1 -!!$ -!!$ ELSE -!!$ ! calculate the mixed-layer properties: -!!$ -!!$ avgth = 0.0 -!!$ avgqv = 0.0 -!!$ k = nk-1 -!!$ if(debug_level.ge.100) print *,' ml_depth = ',ml_depth -!!$ if(debug_level.ge.100) print *,' k,z,th,q:' -!!$ if(debug_level.ge.100) print *,nk,z(nk),th(nk),q(nk) -!!$ -!!$ do while( (z(k).le.ml_depth) .and. (k.ge.1) ) -!!$ -!!$ if(debug_level.ge.100) print *,k,z(k),th(k),q(k) -!!$ -!!$ avgth = avgth + dz(k)*th(k) -!!$ avgqv = avgqv + dz(k)*q(k) -!!$ -!!$ k = k - 1 -!!$ -!!$ enddo -!!$ -!!$ th2 = th(k+1)+(th(k)-th(k+1))*(ml_depth-z(k-1))/dz(k) -!!$ qv2 = q(k+1)+( q(k)- q(k+1))*(ml_depth-z(k-1))/dz(k) -!!$ -!!$ if(debug_level.ge.100) print *,999,ml_depth,th2,qv2 -!!$ -!!$ avgth = avgth + 0.5*(ml_depth-z(k-1))*(th2+th(k-1)) -!!$ avgqv = avgqv + 0.5*(ml_depth-z(k-1))*(qv2+q(k-1)) -!!$ -!!$ if(debug_level.ge.100) print *,k,z(k),th(k),q(k) -!!$ -!!$ avgth = avgth/ml_depth -!!$ avgqv = avgqv/ml_depth -!!$ -!!$ kmin = nk -!!$ -!!$ ENDIF -!!$ -!!$ if(debug_level.ge.100) print *,avgth,avgqv - ELSE print * @@ -6284,19 +6188,6 @@ subroutine getcape( nk , p , t , dz, q, the, cape , cin, source_in ) return end subroutine getcape -!!$ subroutine divg_diagnostics(divg, ..., idiag, bd, npz,gridstruct%area_64, domain, fv_time)) -!!$ real, INPUT(IN) :: divg(bd%isd:bd%ied,bd%jsd:bd%jed,npz) -!!$ .... -!!$ -!!$ if (id_divg>0) then -!!$ used = send_data(id_divg, divg, fv_time) -!!$ -!!$ endif -!!$ -!!$ -!!$ if(flagstruct%fv_debug) call prt_mxm('divg', dp1, is, ie, js, je, 0, npz, 1.,gridstruct%area_64, domain) -!!$ end subroutine divg_diagnostics -!!$ !----------------------------------------------------------------------- !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !----------------------------------------------------------------------- diff --git a/tools/fv_grid_tools.F90 b/tools/fv_grid_tools.F90 index d1087b918..7fdd84e1d 100644 --- a/tools/fv_grid_tools.F90 +++ b/tools/fv_grid_tools.F90 @@ -29,11 +29,11 @@ module fv_grid_tools_mod spherical_linear_interpolation, big_number use fv_timing_mod, only: timing_on, timing_off use fv_mp_mod, only: is_master, fill_corners, XDir, YDir - use fv_mp_mod, only: mp_gather, mp_bcst, mp_reduce_max, mp_stop, grids_master_procs + use fv_mp_mod, only: mp_bcst, mp_reduce_max, mp_stop, grids_master_procs use sorted_index_mod, only: sorted_inta, sorted_intb use mpp_mod, only: mpp_error, FATAL, get_unit, mpp_chksum, mpp_pe, stdout, & mpp_send, mpp_recv, mpp_sync_self, EVENT_RECV, mpp_npes, & - mpp_sum, mpp_max, mpp_min, mpp_root_pe, mpp_broadcast + mpp_sum, mpp_max, mpp_min, mpp_root_pe, mpp_broadcast, mpp_gather use mpp_domains_mod, only: mpp_update_domains, mpp_get_boundary, & mpp_get_ntile_count, mpp_get_pelist, & mpp_get_compute_domains, mpp_global_field, & @@ -85,7 +85,7 @@ subroutine read_grid(Atm, grid_file, ndims, nregions, ng) integer, intent(IN) :: nregions integer, intent(IN) :: ng - type(FmsNetcdfFile_t) :: Grid_input + type(FmsNetcdfFile_t) :: Grid_input real, allocatable, dimension(:,:) :: tmpx, tmpy real(kind=R_GRID), pointer, dimension(:,:,:) :: grid character(len=128) :: units = "" @@ -502,6 +502,7 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, integer :: is, ie, js, je integer :: isd, ied, jsd, jed integer :: istart, iend, jstart, jend + integer :: isection_s, isection_e, jsection_s, jsection_e is = Atm%bd%is ie = Atm%bd%ie @@ -605,6 +606,41 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, else if( trim(grid_file) == 'INPUT/grid_spec.nc' .or. Atm%flagstruct%grid_type < 0 ) then call read_grid(Atm, grid_file, ndims, nregions, ng) + + ! Here if we are reading from grid_spec and the grid has a nest we need to assemble + ! the global grid array 'grid_global' to be sent at the end of this routine to the nest + if (ANY(Atm%neststruct%child_grids)) then + grid_global(:,:,:,1)=-99999 + isection_s = is + isection_e = ie + jsection_s = js + jsection_e = je + + if ( isd < 0 ) isection_s = isd + if ( ied > npx-1 ) isection_e = ied + if ( jsd < 0 ) jsection_s = jsd + if ( jed > npy-1 ) jsection_e = jed + ! if there is a nest, we need to setup grid_global on pe master + ! to send it to the nest at the end of init_grid + call mpp_gather(isection_s,isection_e,jsection_s,jsection_e,atm%pelist, & + grid(isection_s:isection_e,jsection_s:jsection_e,1),grid_global(1-ng:npx+ng,1-ng:npy+ng,1,1),is_master(),ng,ng) + call mpp_gather(isection_s,isection_e,jsection_s,jsection_e,atm%pelist, & + grid(isection_s:isection_e,jsection_s:jsection_e,2),grid_global(1-ng:npx+ng,1-ng:npy+ng,2,1),is_master(),ng,ng) + !do we need the haloes?! + !do j=jsd,jed + !do i=isd,ied + !grid_global(i,j,1,1)=grid(i,j,1) + !grid_global(i,j,2,1)=grid(i,j,2) + !enddo + !enddo + !do j=1,npy + !do i=1,npx + !call mpp_max(grid_global(i,j,1,1),atm%pelist) + !call mpp_max(grid_global(i,j,2,1),atm%pelist) + !enddo + !enddo + endif + else if (Atm%flagstruct%grid_type>=0) call gnomonic_grids(Atm%flagstruct%grid_type, npx-1, xs, ys) @@ -1093,9 +1129,6 @@ subroutine init_grid(Atm, grid_name, grid_file, npx, npy, npz, ndims, nregions, if (Atm%neststruct%child_grids(n) .and. is_master()) then !need to get tile_coarse AND determine local number for tile if (ntiles_g > 1) then ! coarse grid only!! -!!$ !!! DEBUG CODE -!!$ print*, 'SENDING GRID_GLOBAL: ', mpp_pe(), tile_coarse(n), grids_master_procs(n), grid_global(1,npy,:,tile_coarse(n)) -!!$ !!! END DEBUG CODE call mpp_send(grid_global(:,:,:,tile_coarse(n)), & size(grid_global)/Atm%flagstruct%ntiles,grids_master_procs(n)) else @@ -1641,26 +1674,11 @@ subroutine setup_aligned_nest(Atm) call mpp_recv(p_grid( isg-ng:ieg+1+ng, jsg-ng:jeg+1+ng,1:2), size(p_grid( isg-ng:ieg+1+ng, jsg-ng:jeg+1+ng,1:2)), & Atm%parent_grid%pelist(1)) -!!$ !!!! DEBUG CODE -!!$ print*, 'RECEIVING GRID GLOBAL: ', mpp_pe(), Atm%parent_grid%pelist(1), p_grid(1,jeg+1,:) -!!$ !!!! END DEBUG CODE - endif call mpp_broadcast( p_grid(isg-ng:ieg+ng+1, jsg-ng:jeg+ng+1, :), & (ieg-isg+2+2*ng)*(jeg-jsg+2+2*ng)*ndims, mpp_root_pe() ) - !NOTE : Grid now allowed to lie outside of parent - !Check that the grid does not lie outside its parent - !3aug15: allows halo of nest to lie within halo of coarse grid. -!!$ ! NOTE: will this then work with the mpp_update_nest_fine? -!!$ if ( joffset + floor( real(1-ng) / real(refinement) ) < 1-ng .or. & -!!$ ioffset + floor( real(1-ng) / real(refinement) ) < 1-ng .or. & -!!$ joffset + floor( real(npy+ng) / real(refinement) ) > Atm%parent_grid%npy+ng .or. & -!!$ ioffset + floor( real(npx+ng) / real(refinement) ) > Atm%parent_grid%npx+ng ) then -!!$ call mpp_error(FATAL, 'nested grid lies outside its parent') -!!$ end if - ! Generate grid global and parent_grid indices ! Grid global only needed in case we create a new child nest on-the-fly? !TODO If reading in grid from disk then simply mpp_GATHER grid global from local grid arrays @@ -1759,10 +1777,6 @@ subroutine setup_aligned_nest(Atm) if (imod < refinement/2) then -!!$ !!! DEBUG CODE -!!$ if (ic /= ic) print*, gid, ' Bad ic ', i, j -!!$ print*, i, j, ic -!!$ !!! END DEBUG CODE ind_h(i,j,1) = ic - 1 else ind_h(i,j,1) = ic @@ -1811,9 +1825,6 @@ subroutine setup_aligned_nest(Atm) ind_u(i,j,1) = ic #else if (imod < refinement/2) then -!!$ !!! DEBUG CODE -!!$ print*, i, j, ic -!!$ !!! END DEBUG CODE ind_u(i,j,1) = ic - 1 else ind_u(i,j,1) = ic @@ -2432,33 +2443,6 @@ subroutine grid_area(nx, ny, ndims, nregions, bounded_domain, gridstruct, domain enddo enddo -!!$ allocate( p_R8(nx-1,ny-1,ntiles_g) ) ! this is a "global" array -!!$ do j=js,je -!!$ do i=is,ie -!!$ p_R8(i,j,tile) = area(i,j) -!!$ enddo -!!$ enddo -!!$ call mp_gather(p_R8, is,ie, js,je, nx-1, ny-1, ntiles_g) -!!$ if (is_master()) then -!!$ globalarea = 0.0 -!!$ do n=1,ntiles_g -!!$ do j=1,ny-1 -!!$ do i=1,nx-1 -!!$ globalarea = globalarea + p_R8(i,j,n) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ call mpp_broadcast(globalarea, mpp_root_pe()) -!!$ -!!$ deallocate( p_R8 ) -!!$ -!!$ call mp_reduce_max(maxarea) -!!$ minarea = -minarea -!!$ call mp_reduce_max(minarea) -!!$ minarea = -minarea - globalarea = mpp_global_sum(domain, area) maxarea = mpp_global_max(domain, area) minarea = mpp_global_min(domain, area) diff --git a/tools/fv_io.F90 b/tools/fv_io.F90 index 03724f9e5..dda77f379 100644 --- a/tools/fv_io.F90 +++ b/tools/fv_io.F90 @@ -187,7 +187,7 @@ end subroutine fv_io_register_axis ! subroutine fv_io_register_restart(Atm) - type(fv_atmos_type), intent(inout) :: Atm + type(fv_atmos_type), intent(inout) :: Atm character(len=64) :: tracer_name character(len=8), dimension(1) :: dim_names character(len=8), dimension(2) :: dim_names_2d @@ -219,7 +219,7 @@ subroutine fv_io_register_restart(Atm) dim_names_4d2(2) = "yaxis_2" dim_names_4d3 = dim_names_4d dim_names_4d3(2) = "yaxis_2" - + ntprog = size(Atm%q,4) ntdiag = size(Atm%qdiag,4) ntracers = ntprog+ntdiag @@ -696,21 +696,12 @@ subroutine fv_io_register_nudge_restart(Atm) ! use_ncep_sst may not be initialized at this point? call mpp_error(NOTE, 'READING FROM SST_restart DISABLED') -!!$ if ( use_ncep_sst .or. Atm(1)%flagstruct%nudge .or. Atm(1)%flagstruct%ncep_ic ) then -!!$ if ( Atm(1)%nudge .or. Atm(1)%ncep_ic ) then -!!$ fname = 'sst_ncep.res.nc' -!!$ id_restart = register_restart_field(Atm(1)%SST_restart, fname, 'sst_ncep', sst_ncep) -!!$ id_restart = register_restart_field(Atm(1)%SST_restart, fname, 'sst_anom', sst_anom) -!!$ endif end subroutine fv_io_register_nudge_restart ! NAME="fv_io_register_nudge_restart" - - - !##################################################################### ! ! @@ -730,11 +721,6 @@ subroutine fv_io_write_restart(Atm, timestamp) integer, allocatable, dimension(:) :: pes !< Array of the pes in the current pelist fv_domain = Atm%domain -!!$ if ( use_ncep_sst .or. Atm%flagstruct%nudge .or. Atm%flagstruct%ncep_ic ) then -!!$ call mpp_error(NOTE, 'READING FROM SST_RESTART DISABLED') -!!$ !call save_restart(Atm%SST_restart, timestamp) -!!$ endif - if ( (use_ncep_sst .or. Atm%flagstruct%nudge) .and. .not. Atm%gridstruct%nested ) then !call save_restart(Atm%SST_restart, timestamp) endif @@ -1223,9 +1209,9 @@ subroutine fv_io_write_BCs(Atm, timestamp) Atm%neststruct%BCfile_sw_is_open = open_file(Atm%neststruct%BCfile_sw, fname_sw, "overwrite", is_restart=.true., pelist=all_pelist) Atm%neststruct%BCfile_ne_is_open = open_file(Atm%neststruct%BCfile_ne, fname_ne, "overwrite", is_restart=.true., pelist=all_pelist) - call fv_io_register_restart_BCs(Atm) + call fv_io_register_restart_BCs(Atm) - if (Atm%neststruct%BCfile_sw_is_open) then + if (Atm%neststruct%BCfile_sw_is_open) then call write_restart_bc(Atm%neststruct%BCfile_sw) call close_file(Atm%neststruct%BCfile_sw) endif @@ -1257,9 +1243,9 @@ subroutine fv_io_read_BCs(Atm) Atm%neststruct%BCfile_sw_is_open = open_file(Atm%neststruct%BCfile_sw, fname_sw, "read", is_restart=.true., pelist=all_pelist) Atm%neststruct%BCfile_ne_is_open = open_file(Atm%neststruct%BCfile_ne, fname_ne, "read", is_restart=.true., pelist=all_pelist) - call fv_io_register_restart_BCs(Atm) + call fv_io_register_restart_BCs(Atm) - if (Atm%neststruct%BCfile_sw_is_open) then + if (Atm%neststruct%BCfile_sw_is_open) then call read_restart_bc(Atm%neststruct%BCfile_sw) call close_file(Atm%neststruct%BCfile_sw) endif diff --git a/tools/fv_mp_mod.F90 b/tools/fv_mp_mod.F90 index fb7dcef0c..79eb259ef 100644 --- a/tools/fv_mp_mod.F90 +++ b/tools/fv_mp_mod.F90 @@ -923,17 +923,6 @@ subroutine switch_current_Atm(new_Atm, switch_domain) call mpp_error(FATAL, "switch_current_Atm depreciated. call set_domain instead.") -!!$ if (debug .AND. (gid==masterproc)) print*, 'SWITCHING ATM STRUCTURES', new_Atm%grid_number -!!$ if (present(switch_domain)) then -!!$ swD = switch_domain -!!$ else -!!$ swD = .true. -!!$ end if -!!$ if (swD) call switch_current_domain(new_Atm%domain, new_Atm%domain_for_coupler) - -!!$ if (debug .AND. (gid==masterproc)) WRITE(*,'(A, 6I5)') 'NEW GRID DIMENSIONS: ', & -!!$ isd, ied, jsd, jed, new_Atm%npx, new_Atm%npy - end subroutine switch_current_Atm !------------------------------------------------------------------------------- diff --git a/tools/fv_restart.F90 b/tools/fv_restart.F90 index 115a3762c..e6a9e41ff 100644 --- a/tools/fv_restart.F90 +++ b/tools/fv_restart.F90 @@ -40,7 +40,7 @@ module fv_restart_mod use init_hydro_mod, only: p_var use mpp_domains_mod, only: mpp_update_domains, domain2d, DGRID_NE use mpp_mod, only: mpp_chksum, stdout, mpp_error, FATAL, NOTE - use mpp_mod, only: get_unit, mpp_sum, mpp_broadcast + use mpp_mod, only: get_unit, mpp_sum, mpp_broadcast, mpp_max, mpp_npes use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_set_current_pelist use test_cases_mod, only: alpha, init_case, init_double_periodic!, init_latlon use fv_mp_mod, only: is_master, mp_reduce_min, mp_reduce_max, corners_YDir => YDir, fill_corners, tile_fine, global_nest_domain @@ -122,7 +122,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ character(len=6) :: gnn integer :: npts, sphum - integer, allocatable :: pelist(:), smoothed_topo(:) + integer, allocatable :: pelist(:), global_pelist(:), smoothed_topo(:) real :: sumpertn real :: zvir @@ -131,6 +131,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ logical :: do_read_restart_bc = .false. integer, allocatable :: ideal_test_case(:), new_nest_topo(:) integer :: nest_level + integer, allocatable :: BC_remap_level(:) rgrav = 1. / grav @@ -160,10 +161,6 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ ntprog = size(Atm(n)%q,4) ntdiag = size(Atm(n)%qdiag,4) -!!$ if (is_master()) then -!!$ print*, 'FV_RESTART: ', n, cold_start_grids(n) -!!$ endif - !1. sort out restart, external_ic, and cold-start (idealized) if (Atm(n)%neststruct%nested) then write(fname, '(A, I2.2, A)') 'INPUT/fv_core.res.nest', Atm(n)%grid_number, '.nc' @@ -213,6 +210,27 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ call fill_nested_grid_topo(Atm(n), n==this_grid) endif +! This sets the nest BCs. Ideally, it should be done outside of this loop but +! it is moved here -before ex_ic- to avoid repro issues on the nest + do nest_level=1,Atm(this_grid)%neststruct%num_nest_level + + if (Atm(this_grid)%neststruct%nested .AND. Atm(this_grid)%neststruct%nlevel==nest_level)then + call nested_grid_BC(Atm(this_grid)%ps, Atm(this_grid)%parent_grid%ps, global_nest_domain, & + Atm(this_grid)%neststruct%ind_h, Atm(this_grid)%neststruct%wt_h, 0, 0, & + Atm(this_grid)%npx, Atm(this_grid)%npy, Atm(this_grid)%bd, 1, Atm(this_grid)%npx-1, 1,& + Atm(this_grid)%npy-1,nest_level=Atm(this_grid)%neststruct%nlevel) + call nested_grid_BC(Atm(this_grid)%phis, Atm(this_grid)%parent_grid%phis, global_nest_domain, & + Atm(this_grid)%neststruct%ind_h, Atm(this_grid)%neststruct%wt_h, 0, 0, & + Atm(this_grid)%npx, Atm(this_grid)%npy, Atm(this_grid)%bd, 1, Atm(this_grid)%npx-1, 1, & + Atm(this_grid)%npy-1,nest_level=Atm(this_grid)%neststruct%nlevel) + endif + + if (ANY (Atm(this_grid)%neststruct%child_grids) .AND. Atm(this_grid)%neststruct%nlevel==nest_level-1) then + call nested_grid_BC(Atm(this_grid)%ps, global_nest_domain, 0, 0, nest_level=Atm(this_grid)%neststruct%nlevel+1) + call nested_grid_BC(Atm(this_grid)%phis, global_nest_domain, 0, 0, nest_level=Atm(this_grid)%neststruct%nlevel+1) + endif + + enddo endif endif @@ -368,11 +386,6 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ !Currently even though we do fill in the nested-grid IC from ! init_case or external_ic we appear to overwrite it using ! coarse-grid data -!!$ if (Atm(n)%neststruct%nested) then -!!$ if (.not. Atm(n)%flagstruct%external_ic .and. .not. Atm(n)%flagstruct%nggps_ic .and. grid_type < 4 ) then -!!$ call fill_nested_grid_data(Atm(n:n)) -!!$ endif -!!$ end if ! endif !end cold_start check @@ -434,34 +447,45 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ end do !break cycling loop to finish nesting setup -!Send data to nests per levels - do nest_level=1,Atm(this_grid)%neststruct%num_nest_level - - if (Atm(this_grid)%neststruct%nested .AND. Atm(this_grid)%neststruct%nlevel==nest_level)then - call nested_grid_BC(Atm(this_grid)%ps, Atm(this_grid)%parent_grid%ps, global_nest_domain, & - Atm(this_grid)%neststruct%ind_h, Atm(this_grid)%neststruct%wt_h, 0, 0, & - Atm(this_grid)%npx, Atm(this_grid)%npy, Atm(this_grid)%bd, 1, Atm(this_grid)%npx-1, 1,& - Atm(this_grid)%npy-1,nest_level=Atm(this_grid)%neststruct%nlevel) - call nested_grid_BC(Atm(this_grid)%phis, Atm(this_grid)%parent_grid%phis, global_nest_domain, & - Atm(this_grid)%neststruct%ind_h, Atm(this_grid)%neststruct%wt_h, 0, 0, & - Atm(this_grid)%npx, Atm(this_grid)%npy, Atm(this_grid)%bd, 1, Atm(this_grid)%npx-1, 1, & - Atm(this_grid)%npy-1,nest_level=Atm(this_grid)%neststruct%nlevel) + ! The following section is simply to set up the logical do_remap_BC_level + ! do_remap_BC_level is true if the BCs of any grid need remapping at a certain nest level + ! This is to accomodate the BC communications in fv_nesting which is done by level + ! and does not mean that all nests at a certain level are undergoing a BC remapping + ! remapping is actually happening when do_remap_BC=.true. + if (ntileMe>1) then + if (.not. allocated (BC_remap_level))then + allocate (BC_remap_level(Atm(this_grid)%neststruct%num_nest_level)) + BC_remap_level(:)=0 endif - if (ANY (Atm(this_grid)%neststruct%child_grids) .AND. Atm(this_grid)%neststruct%nlevel==nest_level-1) then - call nested_grid_BC(Atm(this_grid)%ps, global_nest_domain, 0, 0, nest_level=Atm(this_grid)%neststruct%nlevel+1) - call nested_grid_BC(Atm(this_grid)%phis, global_nest_domain, 0, 0, nest_level=Atm(this_grid)%neststruct%nlevel+1) - endif + do nest_level=1,Atm(this_grid)%neststruct%num_nest_level + if (Atm(this_grid)%neststruct%nlevel==nest_level .AND. (Atm(this_grid)%neststruct%do_remap_BC(this_grid))) then + BC_remap_level(nest_level) = 1 + endif + enddo - enddo + call mpp_set_current_pelist() !global + + if (.not. allocated (global_pelist)) allocate(global_pelist(mpp_npes())) + call mpp_get_current_pelist(global_pelist) + call mpp_max(BC_remap_level,ntileme,global_pelist) + call mpp_set_current_pelist(pelist) + do nest_level=1,Atm(this_grid)%neststruct%num_nest_level + Atm(this_grid)%neststruct%do_remap_BC_level(nest_level) = (BC_remap_level(nest_level) == 1 ) + enddo + endif + + ! Topo twoway update do n = ntileMe,1,-1 - if (new_nest_topo(n) > 0) then - if (Atm(n)%parent_grid%grid_number==this_grid) then !only parent?! - call twoway_topo_update(Atm(n), n==this_grid) - elseif (n==this_grid .or. Atm(this_grid)%neststruct%nlevel==Atm(n)%neststruct%nlevel) then - call twoway_topo_update(Atm(this_grid), n==this_grid) + if (atm(n)%neststruct%twowaynest) then + if (new_nest_topo(n) > 0) then + if (Atm(n)%parent_grid%grid_number==this_grid) then !only parent?! + call twoway_topo_update(Atm(n), n==this_grid) + elseif (n==this_grid .or. Atm(this_grid)%neststruct%nlevel==Atm(n)%neststruct%nlevel) then + call twoway_topo_update(Atm(this_grid), n==this_grid) + endif endif endif end do @@ -728,8 +752,6 @@ subroutine fill_nested_grid_topo(Atm, proc_in) process = .true. endif -!!$ if (.not. Atm%neststruct%nested) return - call mpp_get_global_domain( Atm%parent_grid%domain, & isg, ieg, jsg, jeg) call mpp_get_data_domain( Atm%parent_grid%domain, & @@ -1142,12 +1164,10 @@ subroutine twoway_topo_update(Atm, proc_in) type(fv_atmos_type), intent(INOUT) :: Atm logical, intent(IN), OPTIONAL :: proc_in - real, allocatable :: g_dat(:,:,:), pt_coarse(:,:,:) integer :: i,j,k,nq, sphum, ncnst, istart, iend, npz integer :: isc, iec, jsc, jec, isd, ied, jsd, jed integer :: isd_p, ied_p, jsd_p, jed_p, isc_p, iec_p, jsc_p, jec_p integer :: isg, ieg, jsg,jeg, npx_p, npy_p - integer :: isg_n, ieg_n, jsg_n, jeg_n, npx_n, npy_n real zvir integer :: p , sending_proc @@ -1184,7 +1204,7 @@ subroutine twoway_topo_update(Atm, proc_in) !NOW: what we do is to update the nested-grid terrain to the coarse grid, !to ensure consistency between the two grids. if ( process ) call mpp_update_domains(Atm%phis, Atm%domain, complete=.true.) - if (Atm%neststruct%twowaynest) then + ! if (Atm%neststruct%twowaynest) then if (ANY(Atm%parent_grid%pelist == mpp_pe()) .or. Atm%neststruct%child_proc) then call update_coarse_grid(Atm%parent_grid%phis, & Atm%phis, global_nest_domain, & @@ -1203,21 +1223,10 @@ subroutine twoway_topo_update(Atm, proc_in) if (ANY(Atm%parent_grid%pelist == mpp_pe())) call mpp_update_domains(Atm%parent_grid%phis, Atm%parent_grid%domain) end if - end if + ! end if #ifdef SW_DYNAMICS -!!$ !ps: first level only -!!$ !This is only valid for shallow-water simulations -!!$ if (process) then -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ -!!$ Atm%ps(i,j) = Atm%delp(i,j,1)/grav -!!$ -!!$ end do -!!$ end do -!!$ endif #else !Reset p_var after updating topography if (process) call p_var(npz, isc, iec, jsc, jec, Atm%ptop, ptop_min, Atm%delp, & diff --git a/tools/init_hydro.F90 b/tools/init_hydro.F90 index 8bcc995c5..ca472c460 100644 --- a/tools/init_hydro.F90 +++ b/tools/init_hydro.F90 @@ -392,20 +392,6 @@ subroutine hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, & enddo enddo -!!$ do k=2,km -!!$ do i=is,ie -!!$ if ( ph(i,k-1) <= p1 ) then -!!$! Isothermal -!!$ gz(i,k) = gz(i,k-1) + (rdgas*t1)*log(ph(i,k-1)/ph(i,k)) -!!$ else -!!$! Constant lapse rate region (troposphere) -!!$ !gz(i,k) = (hs(i,j)+c0)/(ph(i,k)/ps(i,j))**(a0*rdgas) - c0 -!!$ gz(i,k) = (hs(i,j)+c0)/(ph(i,k)/ps(i,j))**(a0*rdgas) - c0 -!!$ endif -!!$ enddo -!!$ enddo - !bottom-up - do k=km,2,-1 do i=is,ie if (ph(i,k) <= p1) then diff --git a/tools/test_cases.F90 b/tools/test_cases.F90 index e162f536b..d61d558e1 100644 --- a/tools/test_cases.F90 +++ b/tools/test_cases.F90 @@ -907,11 +907,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, initWindsCase=initWindsCase1 case(2) #ifdef TEST_TRACER -!!$ do j=js2,je2 -!!$ do i=is2,ie2 -!!$ q(i,j,1,:) = 1.e-3*cos(agrid(i,j,2))!*(1.+cos(agrid(i,j,1))) -!!$ enddo -!!$ enddo gh0 = 1.0e-6 r0 = radius/3. !RADIUS radius/3. p1(2) = 35./180.*pi !0. @@ -1312,10 +1307,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, ! Initiate the westerly-wind-burst: ubar = soliton_Umax r0 = soliton_size -!!$ ubar = 200. ! maxmium wind speed (m/s) -!!$ r0 = 250.e3 -!!$ ubar = 50. ! maxmium wind speed (m/s) -!!$ r0 = 750.e3 ! #1 1: westerly p0(1) = pi*0.5 p0(2) = 0. @@ -1468,10 +1459,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, ! Initiate the westerly-wind-burst: ubar = soliton_Umax r0 = soliton_size -!!$ ubar = 200. ! maxmium wind speed (m/s) -!!$ r0 = 250.e3 -!!$ ubar = 50. ! maxmium wind speed (m/s) -!!$ r0 = 750.e3 p0(1) = pi*0.5 p0(2) = 0. @@ -2471,9 +2458,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, case (1) !DCMIP 11 !Need to set up pressure arrays -!!$ p00 = 1.e5 -!!$ ps = p00 -!!$ phis = 0. !NOTE: since we have an isothermal atmosphere and specify constant height-thickness layers we will disregard ak and bk and specify the initial pressures in a different way @@ -2687,8 +2671,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, ! pt(i,j,k), phis(i,j), ps(i,j), dum6, q(i,j,k,1)) delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j) !Analytic point-value -!!$ ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j)) -!!$ pt(i,j,k) = t00*(ptmp/p00)**exponent !ANalytic layer-mean pt(i,j,k) = -grav*t00*p00/(rdgas*gamma + grav)/delp(i,j,k) * & ( (pe(i,k,j)/p00)**(exponent+1.) - (pe(i,k+1,j)/p00)**(exponent+1.) ) @@ -2792,16 +2774,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, vtmp = 8.5*tanh(zm/1000.) ubar = utmp - 8.5 vbar = vtmp - 4.25 -!!$ ! SRH = 45 -!!$ utmp = 16.0*(1.+tanh(zm/2000. - 1.4)) -!!$ vtmp = 8.5*tanh(zm/1000.) -!!$ ubar = utmp - 10. -!!$ vbar = vtmp - 4.25 -!!$ ! SRH = 27 (really) -!!$ utmp = 0.5*us0*(1.+tanh((zm-3500.)/2000.)) -!!$ vtmp = 8.*tanh(zm/1000.) -!!$ ubar = utmp - 10. -!!$ vbar = vtmp - 4. endif if( is_master() ) then @@ -3352,13 +3324,6 @@ subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, ! Initiate the westerly-wind-burst: ubar = soliton_Umax r0 = soliton_size -!!$ if (test_case == 46) then -!!$ ubar = 200. -!!$ r0 = 250.e3 -!!$ else -!!$ ubar = 50. ! Initial maxmium wind speed (m/s) -!!$ r0 = 500.e3 -!!$ endif p0(1) = pi*0.5 p0(2) = 0. @@ -4506,469 +4471,6 @@ subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, end subroutine case51_forcing -!!$!------------------------------------------------------------------------------- -!!$! -!!$! get_stats :: get L-1, L-2, and L-inf norms and other stats as defined -!!$! in Williamson, 1994 (p.16) -!!$ subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, & -!!$ uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions, & -!!$ gridstruct, stats_lun, consv_lun, monitorFreq, tile, & -!!$ domain, bounded_domain, bd) -!!$ type(fv_grid_bounds_type), intent(IN) :: bd -!!$ integer, intent(IN) :: nt, maxnt -!!$ real , intent(IN) :: dt, dtout, ndays -!!$ real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) -!!$ real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) -!!$ real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) -!!$ real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) -!!$ real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst) -!!$ real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed ) -!!$ real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed ) -!!$ real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) -!!$ real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) -!!$ real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) -!!$ real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz) -!!$ integer, intent(IN) :: npx, npy, npz, ncnst, tile -!!$ integer, intent(IN) :: ndims -!!$ integer, intent(IN) :: nregions -!!$ integer, intent(IN) :: stats_lun -!!$ integer, intent(IN) :: consv_lun -!!$ integer, intent(IN) :: monitorFreq -!!$ type(fv_grid_type), target :: gridstruct -!!$ type(domain2d), intent(INOUT) :: domain -!!$ logical, intent(IN) :: bounded_domain -!!$ -!!$ real :: L1_norm -!!$ real :: L2_norm -!!$ real :: Linf_norm -!!$ real :: pmin, pmin1, uamin1, vamin1 -!!$ real :: pmax, pmax1, uamax1, vamax1 -!!$ real(kind=4) :: arr_r4(5) -!!$ real :: tmass0, tvort0, tener0, tKE0 -!!$ real :: tmass, tvort, tener, tKE -!!$ real :: temp(bd%is:bd%ie,bd%js:bd%je) -!!$ integer :: i0, j0, k0, n0 -!!$ integer :: i, j, k, n, iq -!!$ -!!$ real :: psmo, Vtx, p, w_p, p0 -!!$ real :: x1,y1,z1,x2,y2,z2,ang -!!$ -!!$ real :: p1(2), p2(2), p3(2), r, r0, dist, heading -!!$ -!!$ real :: uc0(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) -!!$ real :: vc0(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) -!!$ -!!$ real :: myDay -!!$ integer :: myRec -!!$ -!!$ real, save, allocatable, dimension(:,:,:) :: u0, v0 -!!$ real :: up(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz) -!!$ real :: vp(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz) -!!$ -!!$ real, dimension(:,:,:), pointer :: grid, agrid -!!$ real, dimension(:,:), pointer :: area, f0, dx, dy, dxa, dya, dxc, dyc -!!$ -!!$ integer :: is, ie, js, je -!!$ integer :: isd, ied, jsd, jed -!!$ -!!$ is = bd%is -!!$ ie = bd%ie -!!$ js = bd%js -!!$ je = bd%je -!!$ isd = bd%isd -!!$ ied = bd%ied -!!$ jsd = bd%jsd -!!$ jed = bd%jed -!!$ -!!$ grid => gridstruct%grid -!!$ agrid=> gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ f0 => gridstruct%f0 -!!$ -!!$ dx => gridstruct%dx -!!$ dy => gridstruct%dy -!!$ dxa => gridstruct%dxa -!!$ dya => gridstruct%dya -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ !!! DEBUG CODE -!!$ if (nt == 0 .and. is_master()) print*, 'INITIALIZING GET_STATS' -!!$ !!! END DEBUG CODE -!!$ -!!$ myDay = ndays*((FLOAT(nt)/FLOAT(maxnt))) -!!$ -!!$#if defined(SW_DYNAMICS) -!!$ if (test_case==0) then -!!$ phi0 = 0.0 -!!$ do j=js,je -!!$ do i=is,ie -!!$ x1 = agrid(i,j,1) -!!$ y1 = agrid(i,j,2) -!!$ z1 = radius -!!$ p = p0_c0 * cos(y1) -!!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) -!!$ w_p = 0.0 -!!$ if (p /= 0.0) w_p = Vtx/p -!!$ ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) -!!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) -!!$ enddo -!!$ enddo -!!$ elseif (test_case==1) then -!!$! Get Current Height Field "Truth" -!!$ p1(1) = pi/2. + pi_shift -!!$ p1(2) = 0. -!!$ p2(1) = 3.*pi/2. + pi_shift -!!$ p2(2) = 0. -!!$ r0 = radius/3. !RADIUS 3. -!!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) -!!$ heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha -!!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3) -!!$ phi0 = 0.0 -!!$ do j=js,je -!!$ do i=is,ie -!!$ p2(1) = agrid(i,j,1) -!!$ p2(2) = agrid(i,j,2) -!!$ r = great_circle_dist( p3, p2, radius ) -!!$ if (r < r0) then -!!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) -!!$ else -!!$ phi0(i,j,1) = phis(i,j) -!!$ endif -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$! Get Height Field Stats -!!$ call pmxn(delp(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0) -!!$ pmin1=pmin1/Grav -!!$ pmax1=pmax1/Grav -!!$ if (test_case <= 2) then -!!$ call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, & -!!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) -!!$ pmin=pmin/Grav -!!$ pmax=pmax/Grav -!!$ arr_r4(1) = pmin1 -!!$ arr_r4(2) = pmax1 -!!$ arr_r4(3) = L1_norm -!!$ arr_r4(4) = L2_norm -!!$ arr_r4(5) = Linf_norm -!!$ !if (is_master()) write(stats_lun,rec=(nt)*2 + 1) arr_r4 -!!$ else -!!$ arr_r4(1) = pmin1 -!!$ arr_r4(2) = pmax1 -!!$ arr_r4(3:5) = 0. -!!$ pmin = 0. -!!$ pmax = 0. -!!$ L1_norm = 0. -!!$ L2_norm = 0. -!!$ Linf_norm = 0. -!!$ endif -!!$ -!!$ 200 format(i6.6,A,i6.6,A,e21.14) -!!$ 201 format(' ',A,e21.14,' ',e21.14) -!!$ 202 format(' ',A,i4.4,'x',i4.4,'x',i4.4) -!!$ -!!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0 ) then -!!$ write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay -!!$ write(*,201) 'Height MAX : ', pmax1 -!!$ write(*,201) 'Height MIN : ', pmin1 -!!$ write(*,202) 'HGT MAX location : ', i0, j0, n0 -!!$ if (test_case <= 2) then -!!$ write(*,201) 'Height L1_norm : ', L1_norm -!!$ write(*,201) 'Height L2_norm : ', L2_norm -!!$ write(*,201) 'Height Linf_norm : ', Linf_norm -!!$ endif -!!$ endif -!!$ -!!$! Get UV Stats -!!$ call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) -!!$ call pmxn(ua(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0) -!!$ if (test_case <= 2) then -!!$ call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, & -!!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile) -!!$ endif -!!$ arr_r4(1) = pmin1 -!!$ arr_r4(2) = pmax1 -!!$ arr_r4(3) = L1_norm -!!$ arr_r4(4) = L2_norm -!!$ arr_r4(5) = Linf_norm -!!$ !if (is_master()) write(stats_lun,rec=(nt)*2 + 2) arr_r4 -!!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then -!!$ write(*,201) 'UV MAX : ', pmax1 -!!$ write(*,201) 'UV MIN : ', pmin1 -!!$ write(*,202) 'UV MAX location : ', i0, j0, n0 -!!$ if (test_case <= 2) then -!!$ write(*,201) 'UV L1_norm : ', L1_norm -!!$ write(*,201) 'UV L2_norm : ', L2_norm -!!$ write(*,201) 'UV Linf_norm : ', Linf_norm -!!$ endif -!!$ endif -!!$#else -!!$ -!!$ 200 format(i6.6,A,i6.6,A,e10.4) -!!$ 201 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4) -!!$ 202 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4) -!!$ 203 format(' ',A,i3.3,A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4) -!!$ -!!$ if(is_master()) write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay -!!$ -!!$! Surface Pressure -!!$ psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ if(is_master()) write(*,*) ' Total surface pressure =', 0.01*psmo -!!$ call pmxn(ps, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ if (is_master()) then -!!$ write(*,201) 'PS MAX|MIN : ', 0.01*pmax, 0.01*pmin, i0, j0, n0 -!!$ endif -!!$ -!!$! Get PT Stats -!!$ pmax1 = -1.e25 -!!$ pmin1 = 1.e25 -!!$ i0=-999 -!!$ j0=-999 -!!$ k0=-999 -!!$ n0=-999 -!!$ do k=1,npz -!!$ call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ pmin1 = min(pmin, pmin1) -!!$ pmax1 = max(pmax, pmax1) -!!$ if (pmax1 == pmax) k0 = k -!!$ enddo -!!$ if (is_master()) then -!!$ write(*,201) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 -!!$ endif -!!$ -!!$#if defined(DEBUG_TEST_CASES) -!!$ if(is_master()) write(*,*) ' ' -!!$ do k=1,npz -!!$ pmax1 = -1.e25 -!!$ pmin1 = 1.e25 -!!$ i0=-999 -!!$ j0=-999 -!!$ k0=-999 -!!$ n0=-999 -!!$ call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ pmin1 = min(pmin, pmin1) -!!$ pmax1 = max(pmax, pmax1) -!!$ if (is_master()) then -!!$ write(*,202) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k, n0, 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) ) -!!$ endif -!!$ enddo -!!$ if(is_master()) write(*,*) ' ' -!!$#endif -!!$ -!!$! Get DELP Stats -!!$ pmax1 = -1.e25 -!!$ pmin1 = 1.e25 -!!$ i0=-999 -!!$ j0=-999 -!!$ k0=-999 -!!$ n0=-999 -!!$ do k=1,npz -!!$ call pmxn(delp(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ pmin1 = min(pmin, pmin1) -!!$ pmax1 = max(pmax, pmax1) -!!$ if (pmax1 == pmax) k0 = k -!!$ enddo -!!$ if (is_master()) then -!!$ write(*,201) 'Delp MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 -!!$ endif -!!$ -!!$! Get UV Stats -!!$ uamax1 = -1.e25 -!!$ uamin1 = 1.e25 -!!$ i0=-999 -!!$ j0=-999 -!!$ k0=-999 -!!$ n0=-999 -!!$ do k=1,npz -!!$ call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, bd%ng) -!!$ call pmxn(ua(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ uamin1 = min(pmin, uamin1) -!!$ uamax1 = max(pmax, uamax1) -!!$ if (uamax1 == pmax) k0 = k -!!$ enddo -!!$ if (is_master()) then -!!$ write(*,201) 'U MAX|MIN : ', uamax1, uamin1, i0, j0, k0, n0 -!!$ endif -!!$ -!!$ vamax1 = -1.e25 -!!$ vamin1 = 1.e25 -!!$ i0=-999 -!!$ j0=-999 -!!$ k0=-999 -!!$ n0=-999 -!!$ do k=1,npz -!!$ call pmxn(va(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ vamin1 = min(pmin, vamin1) -!!$ vamax1 = max(pmax, vamax1) -!!$ if (vamax1 == pmax) k0 = k -!!$ enddo -!!$ if (is_master()) then -!!$ write(*,201) 'V MAX|MIN : ', vamax1, vamin1, i0, j0, k0, n0 -!!$ endif -!!$ -!!$! Get Q Stats -!!$ pmax1 = -1.e25 -!!$ pmin1 = 1.e25 -!!$ i0=-999 -!!$ j0=-999 -!!$ k0=-999 -!!$ n0=-999 -!!$ do k=1,npz -!!$ call pmxn(q(isd,jsd,k,1), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ pmin1 = min(pmin, pmin1) -!!$ pmax1 = max(pmax, pmax1) -!!$ if (pmax1 == pmax) k0 = k -!!$ enddo -!!$ if (is_master()) then -!!$ write(*,201) 'Q MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 -!!$ endif -!!$ -!!$! Get tracer Stats -!!$ do iq=2,ncnst -!!$ pmax1 = -1.e25 -!!$ pmin1 = 1.e25 -!!$ i0=-999 -!!$ j0=-999 -!!$ k0=-999 -!!$ n0=-999 -!!$ do k=1,npz -!!$ call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ pmin1 = min(pmin, pmin1) -!!$ pmax1 = max(pmax, pmax1) -!!$ if (pmax1 == pmax) k0 = k -!!$ enddo -!!$ if (is_master()) then -!!$ write(*,203) 'TR',iq-1,' MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0 -!!$ endif -!!$ enddo -!!$ -!!$#endif -!!$ -!!$ if (test_case == 12) then -!!$! Get UV Stats -!!$ call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, & -!!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) -!!$ if (is_master()) then -!!$ write(*,201) 'UV(850) L1_norm : ', L1_norm -!!$ write(*,201) 'UV(850) L2_norm : ', L2_norm -!!$ write(*,201) 'UV(850) Linf_norm : ', Linf_norm -!!$ endif -!!$ endif -!!$ -!!$ tmass = 0.0 -!!$ tKE = 0.0 -!!$ tener = 0.0 -!!$ tvort = 0.0 -!!$#if defined(SW_DYNAMICS) -!!$ do k=1,1 -!!$#else -!!$ do k=1,npz -!!$#endif -!!$! Get conservation Stats -!!$ -!!$! Conservation of Mass -!!$ temp(:,:) = delp(is:ie,js:je,k) -!!$ tmass0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ tmass = tmass + tmass0 -!!$ -!!$ !if (.not. allocated(u0, v0)) then -!!$ if (nt == 0) then -!!$ allocate(u0(isd:ied,jsd:jed+1,npz)) -!!$ allocate(v0(isd:ied+1,jsd:jed,npz)) -!!$ u0 = u -!!$ v0 = v -!!$ endif -!!$ -!!$ !! UA is the PERTURBATION now -!!$ up = u - u0 -!!$ vp = v - v0 -!!$ -!!$ call dtoa(up(isd,jsd,k), vp(isd,jsd,k), ua, va, dx,dy, dxa, dya, dxc, dyc, npx, npy, bd%ng) -!!$ call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),dx,dy,dxa,dya,npx,npy,bd%ng,bounded_domain, domain, noComm=.true.) -!!$! Conservation of Kinetic Energy -!!$ do j=js,je -!!$ do i=is,ie -!!$ temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + & -!!$ vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) ) -!!$ enddo -!!$ enddo -!!$ tKE0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ tKE = tKE + tKE0 -!!$ -!!$! Conservation of Energy -!!$ do j=js,je -!!$ do i=is,ie -!!$ temp(i,j) = 0.5 * (delp(i,j,k)/Grav) * temp(i,j) ! Include Previously calcullated KE -!!$ temp(i,j) = temp(i,j) + & -!!$ Grav*((delp(i,j,k)/Grav + phis(i,j))*(delp(i,j,k)/Grav + phis(i,j))) - & -!!$ phis(i,j)*phis(i,j) -!!$ enddo -!!$ enddo -!!$ tener0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ tener = tener + tener0 -!!$ -!!$! Conservation of Potential Enstrophy -!!$ if (test_case>1) then -!!$ do j=js,je -!!$ do i=is,ie -!!$ temp(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - & -!!$ (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) ) -!!$ temp(i,j) = ( Grav*(temp(i,j)*temp(i,j))/delp(i,j,k) ) -!!$ enddo -!!$ enddo -!!$ tvort0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ tvort = tvort + tvort0 -!!$ else -!!$ tvort=1. -!!$ endif -!!$ enddo -!!$ -!!$ if (nt == 0) then -!!$ tmass_orig = tmass -!!$ tener_orig = tener -!!$ tvort_orig = tvort -!!$ endif -!!$ arr_r4(1) = (tmass-tmass_orig)/tmass_orig -!!$ arr_r4(2) = (tener-tener_orig)/tener_orig -!!$ arr_r4(3) = (tvort-tvort_orig)/tvort_orig -!!$ arr_r4(4) = tKE -!!$ if (test_case==12) arr_r4(4) = L2_norm -!!$#if defined(SW_DYNAMICS) -!!$ myRec = nt+1 -!!$#else -!!$ myRec = myDay*86400.0/dtout + 1 -!!$#endif -!!$ if (is_master()) write(consv_lun,rec=myRec) arr_r4(1:4) -!!$#if defined(SW_DYNAMICS) -!!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then -!!$#else -!!$ if ( (is_master()) ) then -!!$#endif -!!$ write(*,201) 'MASS TOTAL : ', tmass -!!$ write(*,201) 'NORMALIZED MASS : ', (tmass-tmass_orig)/tmass_orig -!!$ if (test_case >= 2) then -!!$ write(*,201) 'Kinetic Energy KE : ', tKE -!!$ write(*,201) 'ENERGY TOTAL : ', tener -!!$ write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig -!!$ write(*,201) 'ENSTR TOTAL : ', tvort -!!$ write(*,201) 'NORMALIZED ENSTR : ', (tvort-tvort_orig)/tvort_orig -!!$ endif -!!$ write(*,*) ' ' -!!$ endif -!!$ -!!$ nullify(grid) -!!$ nullify(agrid) -!!$ nullify(area) -!!$ nullify(f0) -!!$ nullify(dx) -!!$ nullify(dy) -!!$ -!!$ end subroutine get_stats - - subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3) ! get_pt_on_great_circle :: Get the mid-point on a great circle given: @@ -4998,1093 +4500,6 @@ end subroutine get_pt_on_great_circle ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! !------------------------------------------------------------------------------- -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! -!!$! get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined -!!$! in Williamson, 1994 (p.16) -!!$! for any var -!!$ -!!$ subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, & -!!$ vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) -!!$ type(fv_grid_bounds_type), intent(IN) :: bd -!!$ integer, intent(IN) :: npx, npy -!!$ integer, intent(IN) :: ndims -!!$ integer, intent(IN) :: nregions, tile -!!$ real , intent(IN) :: var(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real , intent(IN) :: varT(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real , intent(OUT) :: vmin -!!$ real , intent(OUT) :: vmax -!!$ real , intent(OUT) :: L1_norm -!!$ real , intent(OUT) :: L2_norm -!!$ real , intent(OUT) :: Linf_norm -!!$ -!!$ type(fv_grid_type), target :: gridstruct -!!$ -!!$ real :: vmean -!!$ real :: vvar -!!$ real :: vmin1 -!!$ real :: vmax1 -!!$ real :: pdiffmn -!!$ real :: pdiffmx -!!$ -!!$ real :: varSUM, varSUM2, varMAX -!!$ real :: gsum -!!$ real :: vminT, vmaxT, vmeanT, vvarT -!!$ integer :: i0, j0, n0 -!!$ -!!$ real, dimension(:,:,:), pointer :: grid, agrid -!!$ real, dimension(:,:), pointer :: area -!!$ -!!$ integer :: is, ie, js, je -!!$ integer :: isd, ied, jsd, jed, ng -!!$ -!!$ is = bd%is -!!$ ie = bd%ie -!!$ js = bd%js -!!$ je = bd%je -!!$ isd = bd%isd -!!$ ied = bd%ied -!!$ jsd = bd%jsd -!!$ jed = bd%jed -!!$ ng = bd%ng -!!$ -!!$ grid => gridstruct%grid -!!$ agrid=> gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ -!!$ varSUM = 0. -!!$ varSUM2 = 0. -!!$ varMAX = 0. -!!$ L1_norm = 0. -!!$ L2_norm = 0. -!!$ Linf_norm = 0. -!!$ vmean = 0. -!!$ vvar = 0. -!!$ vmax = 0. -!!$ vmin = 0. -!!$ pdiffmn= 0. -!!$ pdiffmx= 0. -!!$ vmeanT = 0. -!!$ vvarT = 0. -!!$ vmaxT = 0. -!!$ vminT = 0. -!!$ -!!$ vmean = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ vmeanT = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ vmean = vmean / (4.0*pi) -!!$ vmeanT = vmeanT / (4.0*pi) -!!$ -!!$ call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin , vmax , i0, j0, n0) -!!$ call pmxn(varT, npx, npy, nregions, tile, gridstruct, vminT, vmaxT, i0, j0, n0) -!!$ call pmxn(var-varT, npx, npy, nregions, tile, gridstruct, pdiffmn, pdiffmx, i0, j0, n0) -!!$ -!!$ vmax = (vmax - vmaxT) / (vmaxT-vminT) -!!$ vmin = (vmin - vminT) / (vmaxT-vminT) -!!$ -!!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ varSUM2 = globalsum(varT(is:ie,js:je)**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ L1_norm = globalsum(ABS(var(is:ie,js:je)-varT(is:ie,js:je)), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ L2_norm = globalsum((var(is:ie,js:je)-varT(is:ie,js:je))**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ L1_norm = L1_norm/varSUM -!!$ L2_norm = SQRT(L2_norm)/SQRT(varSUM2) -!!$ -!!$ call pmxn(ABS(varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) -!!$ varMAX = vmax -!!$ call pmxn(ABS(var-varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) -!!$ Linf_norm = vmax/varMAX -!!$ -!!$ end subroutine get_scalar_stats -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- -!!$ -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! -!!$! get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined -!!$! in Williamson, 1994 (p.16) -!!$! for any var -!!$ -!!$ subroutine get_vector_stats(varU, varUT, varV, varVT, & -!!$ npx, npy, ndims, nregions, & -!!$ vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd) -!!$ type(fv_grid_bounds_type), intent(IN) :: bd -!!$ integer, intent(IN) :: npx, npy -!!$ integer, intent(IN) :: ndims -!!$ integer, intent(IN) :: nregions, tile -!!$ real , intent(IN) :: varU(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real , intent(IN) :: varUT(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real , intent(IN) :: varV(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real , intent(IN) :: varVT(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real , intent(OUT) :: vmin -!!$ real , intent(OUT) :: vmax -!!$ real , intent(OUT) :: L1_norm -!!$ real , intent(OUT) :: L2_norm -!!$ real , intent(OUT) :: Linf_norm -!!$ -!!$ real :: var(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real :: varT(bd%isd:bd%ied,bd%jsd:bd%jed) -!!$ real :: vmean -!!$ real :: vvar -!!$ real :: vmin1 -!!$ real :: vmax1 -!!$ real :: pdiffmn -!!$ real :: pdiffmx -!!$ -!!$ real :: varSUM, varSUM2, varMAX -!!$ real :: gsum -!!$ real :: vminT, vmaxT, vmeanT, vvarT -!!$ integer :: i,j,n -!!$ integer :: i0, j0, n0 -!!$ -!!$ type(fv_grid_type), target :: gridstruct -!!$ -!!$ real, dimension(:,:,:), pointer :: grid, agrid -!!$ real, dimension(:,:), pointer :: area -!!$ -!!$ integer :: is, ie, js, je -!!$ integer :: isd, ied, jsd, jed, ng -!!$ -!!$ is = bd%is -!!$ ie = bd%ie -!!$ js = bd%js -!!$ je = bd%je -!!$ isd = bd%isd -!!$ ied = bd%ied -!!$ jsd = bd%jsd -!!$ jed = bd%jed -!!$ ng = bd%ng -!!$ -!!$ grid => gridstruct%grid -!!$ agrid=> gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ -!!$ varSUM = 0. -!!$ varSUM2 = 0. -!!$ varMAX = 0. -!!$ L1_norm = 0. -!!$ L2_norm = 0. -!!$ Linf_norm = 0. -!!$ vmean = 0. -!!$ vvar = 0. -!!$ vmax = 0. -!!$ vmin = 0. -!!$ pdiffmn= 0. -!!$ pdiffmx= 0. -!!$ vmeanT = 0. -!!$ vvarT = 0. -!!$ vmaxT = 0. -!!$ vminT = 0. -!!$ -!!$ do j=js,je -!!$ do i=is,ie -!!$ var(i,j) = SQRT( (varU(i,j)-varUT(i,j))**2. + & -!!$ (varV(i,j)-varVT(i,j))**2. ) -!!$ varT(i,j) = SQRT( varUT(i,j)*varUT(i,j) + & -!!$ varVT(i,j)*varVT(i,j) ) -!!$ enddo -!!$ enddo -!!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ L1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ L1_norm = L1_norm/varSUM -!!$ -!!$ call pmxn(varT, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) -!!$ varMAX = vmax -!!$ call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0) -!!$ Linf_norm = vmax/varMAX -!!$ -!!$ do j=js,je -!!$ do i=is,ie -!!$ var(i,j) = ( (varU(i,j)-varUT(i,j))**2. + & -!!$ (varV(i,j)-varVT(i,j))**2. ) -!!$ varT(i,j) = ( varUT(i,j)*varUT(i,j) + & -!!$ varVT(i,j)*varVT(i,j) ) -!!$ enddo -!!$ enddo -!!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ L2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile) -!!$ L2_norm = SQRT(L2_norm)/SQRT(varSUM) -!!$ -!!$ end subroutine get_vector_stats -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- - -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! -!!$! check_courant_numbers :: -!!$! -!!$ subroutine check_courant_numbers(uc,vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint) -!!$ -!!$ real, intent(IN) :: ndt -!!$ integer, intent(IN) :: n_split -!!$ integer, intent(IN) :: npx, npy, npz, tile -!!$ logical, OPTIONAL, intent(IN) :: noPrint -!!$ real , intent(IN) :: uc(isd:ied+1,jsd:jed ,npz) -!!$ real , intent(IN) :: vc(isd:ied ,jsd:jed+1,npz) -!!$ -!!$ real :: ideal_c=0.06 -!!$ real :: tolerance= 1.e-3 -!!$ real :: dt_inc, dt_orig -!!$ real :: meanCy, minCy, maxCy, meanCx, minCx, maxCx -!!$ -!!$ real :: counter -!!$ logical :: ideal -!!$ -!!$ integer :: i,j,k -!!$ real :: dt -!!$ -!!$ type(fv_grid_type), intent(IN), target :: gridstruct -!!$ real, dimension(:,:), pointer :: dxc, dyc -!!$ -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ dt = ndt/real(n_split) -!!$ -!!$ 300 format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14) -!!$ -!!$ dt_orig = dt -!!$ dt_inc = 1 -!!$ ideal = .false. -!!$ -!!$ do while(.not. ideal) -!!$ -!!$ counter = 0 -!!$ minCy = missing -!!$ maxCy = -1.*missing -!!$ minCx = missing -!!$ maxCx = -1.*missing -!!$ meanCx = 0 -!!$ meanCy = 0 -!!$ do k=1,npz -!!$ do j=js,je -!!$ do i=is,ie+1 -!!$ minCx = MIN(minCx, ABS( (dt/dxc(i,j))*uc(i,j,k) )) -!!$ maxCx = MAX(maxCx, ABS( (dt/dxc(i,j))*uc(i,j,k) )) -!!$ meanCx = meanCx + ABS( (dt/dxc(i,j))*uc(i,j,k) ) -!!$ -!!$ if (ABS( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then -!!$ counter = counter+1 -!!$ write(*,300) i,j,k,tile, ABS( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter -!!$ call exit(1) -!!$ endif -!!$ -!!$ enddo -!!$ enddo -!!$ do j=js,je+1 -!!$ do i=is,ie -!!$ minCy = MIN(minCy, ABS( (dt/dyc(i,j))*vc(i,j,k) )) -!!$ maxCy = MAX(maxCy, ABS( (dt/dyc(i,j))*vc(i,j,k) )) -!!$ meanCy = meanCy + ABS( (dt/dyc(i,j))*vc(i,j,k) ) -!!$ -!!$ if (ABS( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then -!!$ counter = counter+1 -!!$ write(*,300) i,j,k,tile, ABS( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter -!!$ call exit(1) -!!$ endif -!!$ -!!$ enddo -!!$ enddo -!!$ enddo -!!$ -!!$ call mp_reduce_max(maxCx) -!!$ call mp_reduce_max(maxCy) -!!$ minCx = -minCx -!!$ minCy = -minCy -!!$ call mp_reduce_max(minCx) -!!$ call mp_reduce_max(minCy) -!!$ minCx = -minCx -!!$ minCy = -minCy -!!$ call mp_reduce_sum(meanCx) -!!$ call mp_reduce_sum(meanCy) -!!$ meanCx = meanCx/(6.0*DBLE(npx)*DBLE(npy-1)) -!!$ meanCy = meanCy/(6.0*DBLE(npx-1)*DBLE(npy)) -!!$ -!!$ !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then -!!$ ideal = .true. -!!$ !elseif (maxCy-ideal_c > 0) then -!!$ ! dt = dt - dt_inc -!!$ !else -!!$ ! dt = dt + dt_inc -!!$ !endif -!!$ -!!$ enddo -!!$ -!!$ if ( (.not. present(noPrint)) .and. (is_master()) ) then -!!$ print*, '' -!!$ print*, '--------------------------------------------' -!!$ print*, 'Y-dir Courant number MIN : ', minCy -!!$ print*, 'Y-dir Courant number MAX : ', maxCy -!!$ print*, '' -!!$ print*, 'X-dir Courant number MIN : ', minCx -!!$ print*, 'X-dir Courant number MAX : ', maxCx -!!$ print*, '' -!!$ print*, 'X-dir Courant number MEAN : ', meanCx -!!$ print*, 'Y-dir Courant number MEAN : ', meanCy -!!$ print*, '' -!!$ print*, 'NDT: ', ndt -!!$ print*, 'n_split: ', n_split -!!$ print*, 'DT: ', dt -!!$ print*, '' -!!$ print*, '--------------------------------------------' -!!$ print*, '' -!!$ endif -!!$ -!!$ end subroutine check_courant_numbers -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- - -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! -!!$! pmxn :: find max and min of field p -!!$! -!!$ subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0) -!!$ integer, intent(IN) :: npx -!!$ integer, intent(IN) :: npy -!!$ integer, intent(IN) :: nregions, tile -!!$ real , intent(IN) :: p(isd:ied,jsd:jed) -!!$ type(fv_grid_type), intent(IN), target :: gridstruct -!!$ real , intent(OUT) :: pmin -!!$ real , intent(OUT) :: pmax -!!$ integer, intent(OUT) :: i0 -!!$ integer, intent(OUT) :: j0 -!!$ integer, intent(OUT) :: n0 -!!$ -!!$ real :: temp -!!$ integer :: i,j,n -!!$ -!!$ -!!$ real, pointer, dimension(:,:,:) :: agrid, grid -!!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0 -!!$ real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 -!!$ real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es -!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc -!!$ -!!$ logical, pointer :: cubed_sphere, latlon -!!$ -!!$ logical, pointer :: have_south_pole, have_north_pole -!!$ -!!$ integer, pointer :: ntiles_g -!!$ real, pointer :: acapN, acapS, globalarea -!!$ -!!$ grid => gridstruct%grid -!!$ agrid=> gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ rarea => gridstruct%rarea -!!$ -!!$ fC => gridstruct%fC -!!$ f0 => gridstruct%f0 -!!$ -!!$ ee1 => gridstruct%ee1 -!!$ ee2 => gridstruct%ee2 -!!$ ew => gridstruct%ew -!!$ es => gridstruct%es -!!$ en1 => gridstruct%en1 -!!$ en2 => gridstruct%en2 -!!$ -!!$ dx => gridstruct%dx -!!$ dy => gridstruct%dy -!!$ dxa => gridstruct%dxa -!!$ dya => gridstruct%dya -!!$ rdxa => gridstruct%rdxa -!!$ rdya => gridstruct%rdya -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ cubed_sphere => gridstruct%cubed_sphere -!!$ latlon => gridstruct%latlon -!!$ -!!$ have_south_pole => gridstruct%have_south_pole -!!$ have_north_pole => gridstruct%have_north_pole -!!$ -!!$ ntiles_g => gridstruct%ntiles_g -!!$ acapN => gridstruct%acapN -!!$ acapS => gridstruct%acapS -!!$ globalarea => gridstruct%globalarea -!!$ -!!$ pmax = -1.e25 -!!$ pmin = 1.e25 -!!$ i0 = -999 -!!$ j0 = -999 -!!$ n0 = tile -!!$ -!!$ do j=js,je -!!$ do i=is,ie -!!$ temp = p(i,j) -!!$ if (temp > pmax) then -!!$ pmax = temp -!!$ i0 = i -!!$ j0 = j -!!$ elseif (temp < pmin) then -!!$ pmin = temp -!!$ endif -!!$ enddo -!!$ enddo -!!$ -!!$ temp = pmax -!!$ call mp_reduce_max(temp) -!!$ if (temp /= pmax) then -!!$ i0 = -999 -!!$ j0 = -999 -!!$ n0 = -999 -!!$ endif -!!$ pmax = temp -!!$ call mp_reduce_max(i0) -!!$ call mp_reduce_max(j0) -!!$ call mp_reduce_max(n0) -!!$ -!!$ pmin = -pmin -!!$ call mp_reduce_max(pmin) -!!$ pmin = -pmin -!!$ -!!$ end subroutine pmxn -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- -!!$ -!!$!! These routines are no longer used -!!$#ifdef NCDF_OUTPUT -!!$ -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! -!!$! output_ncdf :: write out NETCDF fields -!!$! -!!$ subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, & -!!$ omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, & -!!$ npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, & -!!$ phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids, & -!!$ lats_id, lons_id, gridstruct, flagstruct) -!!$ real, intent(IN) :: dt -!!$ integer, intent(IN) :: nt, maxnt -!!$ integer, intent(INOUT) :: nout -!!$ -!!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) -!!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) -!!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) -!!$ -!!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) -!!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) -!!$ -!!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) -!!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) -!!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: omga(isd:ied ,jsd:jed ,npz) -!!$ -!!$ integer, intent(IN) :: npx, npy, npz -!!$ integer, intent(IN) :: ng, ncnst -!!$ integer, intent(IN) :: ndims -!!$ integer, intent(IN) :: nregions -!!$ integer, intent(IN) :: ncid -!!$ integer, intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id -!!$ integer, intent(IN) :: ntiles_id, nt_id -!!$ integer, intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id -!!$ integer, intent(IN) :: om_id ! omega (dp/dt) -!!$ integer, intent(IN) :: tracers_ids(ncnst-1) -!!$ integer, intent(IN) :: lats_id, lons_id -!!$ -!!$ type(fv_grid_type), target :: gridstruct -!!$ type(fv_flags_type), intent(IN) :: flagstruct -!!$ -!!$ real, allocatable :: tmp(:,:,:) -!!$ real, allocatable :: tmpA(:,:,:) -!!$#if defined(SW_DYNAMICS) -!!$ real, allocatable :: ut(:,:,:) -!!$ real, allocatable :: vt(:,:,:) -!!$#else -!!$ real, allocatable :: ut(:,:,:,:) -!!$ real, allocatable :: vt(:,:,:,:) -!!$ real, allocatable :: tmpA_3d(:,:,:,:) -!!$#endif -!!$ real, allocatable :: vort(:,:) -!!$ -!!$ real :: p1(2) ! Temporary Point -!!$ real :: p2(2) ! Temporary Point -!!$ real :: p3(2) ! Temporary Point -!!$ real :: p4(2) ! Temporary Point -!!$ real :: pa(2) ! Temporary Point -!!$ real :: utmp, vtmp, r, r0, dist, heading -!!$ integer :: i,j,k,n,iq,nreg -!!$ -!!$ real :: Vtx, p, w_p -!!$ real :: x1,y1,z1,x2,y2,z2,ang -!!$ -!!$ real, pointer, dimension(:,:,:) :: agrid, grid -!!$ real, pointer, dimension(:,:) :: area, rarea -!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc -!!$ -!!$ grid => gridstruct%grid -!!$ agrid => gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ rarea => gridstruct%rarea -!!$ -!!$ dx => gridstruct%dx -!!$ dy => gridstruct%dy -!!$ dxa => gridstruct%dxa -!!$ dya => gridstruct%dya -!!$ rdxa => gridstruct%rdxa -!!$ rdya => gridstruct%rdya -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ allocate( tmp(npx ,npy ,nregions) ) -!!$ allocate( tmpA(npx-1,npy-1,nregions) ) -!!$#if defined(SW_DYNAMICS) -!!$ allocate( ut(npx-1,npy-1,nregions) ) -!!$ allocate( vt(npx-1,npy-1,nregions) ) -!!$#else -!!$ allocate( ut(npx-1,npy-1,npz,nregions) ) -!!$ allocate( vt(npx-1,npy-1,npz,nregions) ) -!!$ allocate( tmpA_3d(npx-1,npy-1,npz,nregions) ) -!!$#endif -!!$ allocate( vort(isd:ied,jsd:jed) ) -!!$ -!!$ nout = nout + 1 -!!$ -!!$ if (nt==0) then -!!$ tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2) -!!$ call wrtvar_ncdf(ncid, lats_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3) -!!$ tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1) -!!$ call wrtvar_ncdf(ncid, lons_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3) -!!$ endif -!!$ -!!$#if defined(SW_DYNAMICS) -!!$ if (test_case > 1) then -!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav -!!$ -!!$ if ((nt==0) .and. (test_case==2)) then -!!$ Ubar = (2.0*pi*radius)/(12.0*86400.0) -!!$ gh0 = 2.94e4 -!!$ phis = 0.0 -!!$ do j=js,je+1 -!!$ do i=is,ie+1 -!!$ tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * & -!!$ ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + & -!!$ sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ else -!!$ -!!$ if (test_case==1) then -!!$! Get Current Height Field "Truth" -!!$ p1(1) = pi/2. + pi_shift -!!$ p1(2) = 0. -!!$ p2(1) = 3.*pi/2. + pi_shift -!!$ p2(2) = 0. -!!$ r0 = radius/3. !RADIUS /3. -!!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) -!!$ heading = 5.0*pi/2.0 - alpha -!!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3) -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ p2(1) = agrid(i,j,1) -!!$ p2(2) = agrid(i,j,2) -!!$ r = great_circle_dist( p3, p2, radius ) -!!$ if (r < r0) then -!!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) -!!$ else -!!$ phi0(i,j,1) = phis(i,j) -!!$ endif -!!$ enddo -!!$ enddo -!!$ elseif (test_case == 0) then -!!$ phi0 = 0.0 -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ x1 = agrid(i,j,1) -!!$ y1 = agrid(i,j,2) -!!$ z1 = radius -!!$ p = p0_c0 * cos(y1) -!!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) -!!$ w_p = 0.0 -!!$ if (p /= 0.0) w_p = Vtx/p -!!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1) -!!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) -!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1) -!!$ endif -!!$ call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) -!!$ -!!$ if (test_case == 9) then -!!$! Calc Vorticity -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - & -!!$ (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) ) -!!$ vort(i,j) = Grav*vort(i,j)/delp(i,j,1) -!!$ enddo -!!$ enddo -!!$ tmpA(is:ie,js:je,tile) = vort(is:ie,js:je) -!!$ call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) -!!$ endif -!!$ -!!$ call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, 1, 1, gridstruct%grid_type, gridstruct%bounded_domain, flagstruct%c2l_ord, bd) -!!$ do j=js,je -!!$ do i=is,ie -!!$ ut(i,j,tile) = ua(i,j,1) -!!$ vt(i,j,tile) = va(i,j,1) -!!$ enddo -!!$ enddo -!!$ -!!$ call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:nregions), 3) -!!$ call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:nregions), 3) -!!$ -!!$ if ((test_case >= 2) .and. (nt==0) ) then -!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav -!!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3) -!!$ endif -!!$#else -!!$ -!!$! Write Moisture Data -!!$ tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1) -!!$ call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) -!!$ -!!$! Write Tracer Data -!!$ do iq=2,ncnst -!!$ tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq) -!!$ call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) -!!$ enddo -!!$ -!!$! Write Surface height data -!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav -!!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3) -!!$ -!!$! Write Pressure Data -!!$ tmpA(is:ie,js:je,tile) = ps(is:ie,js:je) -!!$ call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3) -!!$ do k=1,npz -!!$ tmpA_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/Grav -!!$ enddo -!!$ call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) -!!$ -!!$! Write PT Data -!!$ do k=1,npz -!!$ tmpA_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k) -!!$ enddo -!!$ call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) -!!$ -!!$! Write U,V Data -!!$ call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, npz, gridstruct%grid_type, gridstruct%bounded_domain, flagstruct%c2l_ord) -!!$ do k=1,npz -!!$ do j=js,je -!!$ do i=is,ie -!!$ ut(i,j,k,tile) = ua(i,j,k) -!!$ vt(i,j,k,tile) = va(i,j,k) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:npz,1:nregions), 4) -!!$ call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:npz,1:nregions), 4) -!!$ -!!$ -!!$! Calc Vorticity -!!$ do k=1,npz -!!$ do j=js,je -!!$ do i=is,ie -!!$ tmpA_3d(i,j,k,tile) = rarea(i,j) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - & -!!$ (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) ) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) -!!$! -!!$! Output omega (dp/dt): -!!$ do k=1,npz -!!$ do j=js,je -!!$ do i=is,ie -!!$ tmpA_3d(i,j,k,tile) = omga(i,j,k) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4) -!!$ -!!$#endif -!!$ -!!$ deallocate( tmp ) -!!$ deallocate( tmpA ) -!!$#if defined(SW_DYNAMICS) -!!$ deallocate( ut ) -!!$ deallocate( vt ) -!!$#else -!!$ deallocate( ut ) -!!$ deallocate( vt ) -!!$ deallocate( tmpA_3d ) -!!$#endif -!!$ deallocate( vort ) -!!$ -!!$ nullify(grid) -!!$ nullify(agrid) -!!$ -!!$ nullify(area) -!!$ -!!$ nullify(dx) -!!$ nullify(dy) -!!$ nullify(dxa) -!!$ nullify(dya) -!!$ nullify(rdxa) -!!$ nullify(rdya) -!!$ nullify(dxc) -!!$ nullify(dyc) -!!$ -!!$ end subroutine output_ncdf -!!$ -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- -!!$ -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! -!!$! output :: write out fields -!!$! -!!$ subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, & -!!$ npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, & -!!$ pt_lun, pv_lun, uv_lun, gridstruct) -!!$ -!!$ real, intent(IN) :: dt -!!$ integer, intent(IN) :: nt, maxnt -!!$ integer, intent(INOUT) :: nout -!!$ -!!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) -!!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) -!!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) -!!$ -!!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) -!!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) -!!$ -!!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) -!!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) -!!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) -!!$ -!!$ integer, intent(IN) :: npx, npy, npz -!!$ integer, intent(IN) :: ng, ncnst -!!$ integer, intent(IN) :: ndims -!!$ integer, intent(IN) :: nregions -!!$ integer, intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun -!!$ -!!$ type(fv_grid_type), target :: gridstruct -!!$ -!!$ real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions) -!!$ real :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions) -!!$ real :: p1(2) ! Temporary Point -!!$ real :: p2(2) ! Temporary Point -!!$ real :: p3(2) ! Temporary Point -!!$ real :: p4(2) ! Temporary Point -!!$ real :: pa(2) ! Temporary Point -!!$ real :: ut(1:npx,1:npy,1:nregions) -!!$ real :: vt(1:npx,1:npy,1:nregions) -!!$ real :: utmp, vtmp, r, r0, dist, heading -!!$ integer :: i,j,k,n,nreg -!!$ real :: vort(isd:ied,jsd:jed) -!!$ -!!$ real :: Vtx, p, w_p -!!$ real :: x1,y1,z1,x2,y2,z2,ang -!!$ -!!$ real, pointer, dimension(:,:,:) :: agrid, grid -!!$ real, pointer, dimension(:,:) :: area, rarea -!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc -!!$ -!!$ grid => gridstruct%grid -!!$ agrid => gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ -!!$ dx => gridstruct%dx -!!$ dy => gridstruct%dy -!!$ dxa => gridstruct%dxa -!!$ dya => gridstruct%dya -!!$ rdxa => gridstruct%rdxa -!!$ rdya => gridstruct%rdya -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ cubed_sphere => gridstruct%cubed_sphere -!!$ -!!$ nout = nout + 1 -!!$ -!!$#if defined(SW_DYNAMICS) -!!$ if (test_case > 1) then -!!$ call atob_s(delp(:,:,1)/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) -!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav -!!$ -!!$ if ((nt==0) .and. (test_case==2)) then -!!$ Ubar = (2.0*pi*radius)/(12.0*86400.0) -!!$ gh0 = 2.94e4 -!!$ phis = 0.0 -!!$ do j=js,je+1 -!!$ do i=is,ie+1 -!!$ tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * & -!!$ ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + & -!!$ sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ else -!!$ -!!$ if (test_case==1) then -!!$! Get Current Height Field "Truth" -!!$ p1(1) = pi/2. + pi_shift -!!$ p1(2) = 0. -!!$ p2(1) = 3.*pi/2. + pi_shift -!!$ p2(2) = 0. -!!$ r0 = radius/3. !RADIUS /3. -!!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt))) -!!$ heading = 5.0*pi/2.0 - alpha -!!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3) -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ p2(1) = agrid(i,j,1) -!!$ p2(2) = agrid(i,j,2) -!!$ r = great_circle_dist( p3, p2, radius ) -!!$ if (r < r0) then -!!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0)) -!!$ else -!!$ phi0(i,j,1) = phis(i,j) -!!$ endif -!!$ enddo -!!$ enddo -!!$ elseif (test_case == 0) then -!!$ phi0 = 0.0 -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ x1 = agrid(i,j,1) -!!$ y1 = agrid(i,j,2) -!!$ z1 = radius -!!$ p = p0_c0 * cos(y1) -!!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p) -!!$ w_p = 0.0 -!!$ if (p /= 0.0) w_p = Vtx/p -!!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) ) -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) -!!$ tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1) -!!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) -!!$ call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) -!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1) -!!$ endif -!!$ ! call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) -!!$ call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) -!!$ -!!$ if (test_case == 9) then -!!$! Calc Vorticity -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - & -!!$ (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) ) -!!$ vort(i,j) = Grav*vort(i,j)/delp(i,j,1) -!!$ enddo -!!$ enddo -!!$ call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) -!!$ call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) -!!$ endif -!!$ -!!$ call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) -!!$! Rotate winds to standard Lat-Lon orientation -!!$ if (cubed_sphere) then -!!$ do j=js,je -!!$ do i=is,ie -!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1) -!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2) -!!$ call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3) -!!$ call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4) -!!$ utmp = ua(i,j,1) -!!$ vtmp = va(i,j,1) -!!$ if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2) -!!$ ut(i,j,tile) = utmp -!!$ vt(i,j,tile) = vtmp -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions)) -!!$ call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions)) -!!$ -!!$ if ((test_case >= 2) .and. (nt==0) ) then -!!$ call atob_s(phis/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1) -!!$ ! call wrt2d(phis_lun, nout , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions)) -!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav -!!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) -!!$ endif -!!$#else -!!$ -!!$! Write Surface height data -!!$ if (nt==0) then -!!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav -!!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) -!!$ endif -!!$ -!!$! Write Pressure Data -!!$ -!!$ !if (tile==2) then -!!$ ! do i=is,ie -!!$ ! print*, i, ps(i,35) -!!$ ! enddo -!!$ !endif -!!$ tmpA(is:ie,js:je,tile) = ps(is:ie,js:je) -!!$ call wrt2d(phi_lun, (nout-1)*(npz+1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) -!!$ do k=1,npz -!!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,k)/Grav -!!$ call wrt2d(phi_lun, (nout-1)*(npz+1) + 1 + k, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) -!!$ enddo -!!$ -!!$! Write PT Data -!!$ do k=1,npz -!!$ tmpA(is:ie,js:je,tile) = pt(is:ie,js:je,k) -!!$ call wrt2d(pt_lun, (nout-1)*npz + (k-1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions)) -!!$ enddo -!!$ -!!$! Write U,V Data -!!$ do k=1,npz -!!$ call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng) -!!$! Rotate winds to standard Lat-Lon orientation -!!$ if (cubed_sphere) then -!!$ do j=js,je -!!$ do i=is,ie -!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1) -!!$ call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2) -!!$ call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3) -!!$ call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4) -!!$ utmp = ua(i,j,k) -!!$ vtmp = va(i,j,k) -!!$ if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2) -!!$ ut(i,j,tile) = utmp -!!$ vt(i,j,tile) = vtmp -!!$ enddo -!!$ enddo -!!$ endif -!!$ call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions)) -!!$ call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions)) -!!$ enddo -!!$#endif -!!$ -!!$ nullify(grid) -!!$ nullify(agrid) -!!$ -!!$ nullify(area) -!!$ -!!$ nullify(dx) -!!$ nullify(dy) -!!$ nullify(dxa) -!!$ nullify(dya) -!!$ nullify(rdxa) -!!$ nullify(rdya) -!!$ nullify(dxc) -!!$ nullify(dyc) -!!$ -!!$ nullify(cubed_sphere) -!!$ -!!$ end subroutine output -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- -!!$ -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! wrt2d_ncdf :: write out a 2d field -!!$! -!!$ subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims) -!!$#include -!!$ integer, intent(IN) :: ncid, varid -!!$ integer, intent(IN) :: nrec -!!$ integer, intent(IN) :: i1,i2,j1,j2 -!!$ integer, intent(IN) :: npx -!!$ integer, intent(IN) :: npy -!!$ integer, intent(IN) :: npz -!!$ integer, intent(IN) :: ntiles -!!$ real , intent(IN) :: p(npx-1,npy-1,npz,ntiles) -!!$ integer, intent(IN) :: ndims -!!$ -!!$ integer :: error -!!$ real(kind=4), allocatable :: p_R4(:,:,:,:) -!!$ integer :: i,j,k,n -!!$ integer :: istart(ndims+1), icount(ndims+1) -!!$ -!!$ allocate( p_R4(npx-1,npy-1,npz,ntiles) ) -!!$ -!!$ p_R4(:,:,:,:) = missing -!!$ p_R4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile) -!!$ call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles) -!!$ -!!$ istart(:) = 1 -!!$ istart(ndims+1) = nrec -!!$ icount(1) = npx-1 -!!$ icount(2) = npy-1 -!!$ icount(3) = npz -!!$ if (ndims == 3) icount(3) = ntiles -!!$ if (ndims == 4) icount(4) = ntiles -!!$ icount(ndims+1) = 1 -!!$ -!!$ if (is_master()) then -!!$ error = NF_PUT_VARA_REAL(ncid, varid, istart, icount, p_R4) -!!$ endif ! masterproc -!!$ -!!$ deallocate( p_R4 ) -!!$ -!!$ end subroutine wrtvar_ncdf -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- -!!$ -!!$!------------------------------------------------------------------------------- -!!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! -!!$! wrt2d :: write out a 2d field -!!$! -!!$ subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p) -!!$ integer, intent(IN) :: iout -!!$ integer, intent(IN) :: nrec -!!$ integer, intent(IN) :: i1,i2,j1,j2 -!!$ integer, intent(IN) :: npx -!!$ integer, intent(IN) :: npy -!!$ integer, intent(IN) :: nregions -!!$ real , intent(IN) :: p(npx-1,npy-1,nregions) -!!$ -!!$ real(kind=4) :: p_R4(npx-1,npy-1,nregions) -!!$ integer :: i,j,n -!!$ -!!$ do n=tile,tile -!!$ do j=j1,j2 -!!$ do i=i1,i2 -!!$ p_R4(i,j,n) = p(i,j,n) -!!$ enddo -!!$ enddo -!!$ enddo -!!$ -!!$ call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, nregions) -!!$ -!!$ if (is_master()) then -!!$ write(iout,rec=nrec) p_R4(1:npx-1,1:npy-1,1:nregions) -!!$ endif ! masterproc -!!$ -!!$ end subroutine wrt2d -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- -!!$#endif !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! ! init_double_periodic @@ -7412,11 +5827,6 @@ subroutine DCMIP16_BC(delp,pt,u,v,q,w,delz,& piter = DCMIP16_BC_pressure(ziter,agrid(i,j,2)) titer = DCMIP16_BC_temperature(ziter,agrid(i,j,2)) z = ziter + (piter - p)*rdgrav*titer/piter -!!$ !!! DEBUG CODE -!!$ if (is_master() .and. i == is .and. j == js) then -!!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer -!!$ endif -!!$ !!! END DEBUG CODE if (abs(z - ziter) < zconv) exit enddo gz(i,j,k) = z @@ -7802,11 +6212,6 @@ subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,& piter = DCMIP16_TC_pressure(ziter,rc(i,j)) titer = DCMIP16_TC_temperature(ziter,rc(i,j)) z = ziter + (piter - p)*rdgrav*titer/piter -!!$ !!! DEBUG CODE -!!$ if (is_master() .and. i == is .and. j == js) then -!!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer -!!$ endif -!!$ !!! END DEBUG CODE if (abs(z - ziter) < zconv) exit enddo gz(i,j,k) = z @@ -8024,622 +6429,6 @@ end function DCMIP16_TC_sphum end subroutine DCMIP16_TC -!!$ subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, & -!!$ gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, & -!!$ mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in, bd) -!!$ -!!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) -!!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) -!!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst) -!!$ -!!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed ) -!!$ -!!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed ) -!!$ real , intent(INOUT) :: pe(is-1:ie+1,npz+1,js-1:je+1) -!!$ real , intent(INOUT) :: pk(is:ie ,js:je ,npz+1) -!!$ real , intent(INOUT) :: peln(is :ie ,npz+1 ,js:je) -!!$ real , intent(INOUT) :: pkz(is:ie ,js:je ,npz ) -!!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz) -!!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz) -!!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz) -!!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz) -!!$ real , intent(inout) :: delz(is:,js:,1:) -!!$ real , intent(inout) :: ze0(is:,js:,1:) -!!$ -!!$ real , intent(IN) :: ak(npz+1) -!!$ real , intent(IN) :: bk(npz+1) -!!$ -!!$ integer, intent(IN) :: npx, npy, npz -!!$ integer, intent(IN) :: ng, ncnst -!!$ integer, intent(IN) :: ndims -!!$ integer, intent(IN) :: nregions -!!$ integer,target,intent(IN):: tile_in -!!$ -!!$ real, intent(IN) :: dry_mass -!!$ logical, intent(IN) :: mountain -!!$ logical, intent(IN) :: moist_phys -!!$ logical, intent(IN) :: hybrid_z -!!$ -!!$ type(fv_grid_type), intent(IN), target :: gridstruct -!!$ type(domain2d), intent(IN), target :: domain_in -!!$ -!!$ real, pointer, dimension(:,:,:) :: agrid, grid -!!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0 -!!$ real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 -!!$ real, pointer, dimension(:,:,:,:) :: ew, es -!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc -!!$ -!!$ logical, pointer :: cubed_sphere, latlon -!!$ -!!$ type(domain2d), pointer :: domain -!!$ integer, pointer :: tile -!!$ -!!$ logical, pointer :: have_south_pole, have_north_pole -!!$ -!!$ integer, pointer :: ntiles_g -!!$ real, pointer :: acapN, acapS, globalarea -!!$ -!!$ real(kind=R_GRID) :: p1(2), p2(2) -!!$ real :: r, r0 -!!$ integer :: i,j -!!$ -!!$ agrid => gridstruct%agrid -!!$ grid => gridstruct%grid -!!$ -!!$ area => gridstruct%area -!!$ -!!$ dx => gridstruct%dx -!!$ dy => gridstruct%dy -!!$ dxa => gridstruct%dxa -!!$ dya => gridstruct%dya -!!$ rdxa => gridstruct%rdxa -!!$ rdya => gridstruct%rdya -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ fC => gridstruct%fC -!!$ f0 => gridstruct%f0 -!!$ -!!$ ntiles_g => gridstruct%ntiles_g -!!$ acapN => gridstruct%acapN -!!$ acapS => gridstruct%acapS -!!$ globalarea => gridstruct%globalarea -!!$ -!!$ domain => domain_in -!!$ tile => tile_in -!!$ -!!$ have_south_pole => gridstruct%have_south_pole -!!$ have_north_pole => gridstruct%have_north_pole -!!$ -!!$ do j=jsd,jed+1 -!!$ do i=isd,ied+1 -!!$ fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) & -!!$ +sin(grid(i,j,2))*cos(alpha) ) -!!$ enddo -!!$ enddo -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) & -!!$ +sin(agrid(i,j,2))*cos(alpha) ) -!!$ enddo -!!$ enddo -!!$ -!!$ select case (test_case) -!!$ case ( 1 ) -!!$ -!!$ Ubar = (2.0*pi*radius)/(12.0*86400.0) -!!$ phis = 0.0 -!!$ r0 = radius/3. !RADIUS radius/3. -!!$ p1(1) = 0. -!!$ p1(1) = pi/2. + pi_shift -!!$ p1(2) = 0. -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ p2(1) = agrid(i,j,1) -!!$ p2(2) = agrid(i,j,2) -!!$ r = great_circle_dist( p1, p2, radius ) -!!$ if (r < r0) then -!!$ delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(PI*r/r0)) -!!$ else -!!$ delp(i,j,1) = phis(i,j) -!!$ endif -!!$ enddo -!!$ enddo -!!$ call init_latlon_winds(UBar, u, v, ua, va, uc, vc, 1, gridstruct) -!!$ -!!$ -!!$ -!!$ end select -!!$ -!!$ nullify(grid) -!!$ nullify(agrid) -!!$ -!!$ nullify(area) -!!$ -!!$ nullify(fC) -!!$ nullify(f0) -!!$ -!!$ nullify(dx) -!!$ nullify(dy) -!!$ nullify(dxa) -!!$ nullify(dya) -!!$ nullify(rdxa) -!!$ nullify(rdya) -!!$ nullify(dxc) -!!$ nullify(dyc) -!!$ -!!$ nullify(domain) -!!$ nullify(tile) -!!$ -!!$ nullify(have_south_pole) -!!$ nullify(have_north_pole) -!!$ -!!$ nullify(ntiles_g) -!!$ nullify(acapN) -!!$ nullify(acapS) -!!$ nullify(globalarea) -!!$ -!!$ end subroutine init_latlon -!!$ -!!$ subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct) -!!$ -!!$ ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate -!!$ -!!$ real, intent(INOUT) :: UBar -!!$ real, intent(INOUT) :: u(isd:ied ,jsd:jed+1) -!!$ real, intent(INOUT) :: v(isd:ied+1,jsd:jed ) -!!$ real, intent(INOUT) :: uc(isd:ied+1,jsd:jed ) -!!$ real, intent(INOUT) :: vc(isd:ied ,jsd:jed+1) -!!$ real, intent(INOUT) :: ua(isd:ied ,jsd:jed ) -!!$ real, intent(INOUT) :: va(isd:ied ,jsd:jed ) -!!$ integer, intent(IN) :: defOnGrid -!!$ type(fv_grid_type), intent(IN), target :: gridstruct -!!$ -!!$ real :: p1(2),p2(2),p3(2),p4(2), pt(2) -!!$ real :: e1(3), e2(3), ex(3), ey(3) -!!$ -!!$ real :: dist, r, r0 -!!$ integer :: i,j,k,n -!!$ real :: utmp, vtmp -!!$ -!!$ real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2 -!!$ -!!$ real, dimension(:,:,:), pointer :: grid, agrid -!!$ real, dimension(:,:), pointer :: area, dx, dy, dxc, dyc -!!$ -!!$ grid => gridstruct%grid -!!$ agrid=> gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ dx => gridstruct%dx -!!$ dy => gridstruct%dy -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ psi(:,:) = 1.e25 -!!$ psi_b(:,:) = 1.e25 -!!$ do j=jsd,jed -!!$ do i=isd,ied -!!$ psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - & -!!$ cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) ) -!!$ enddo -!!$ enddo -!!$ do j=jsd,jed+1 -!!$ do i=isd,ied+1 -!!$ psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - & -!!$ cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) ) -!!$ enddo -!!$ enddo -!!$ -!!$ if ( defOnGrid == 1 ) then -!!$ do j=jsd,jed+1 -!!$ do i=isd,ied -!!$ dist = dx(i,j) -!!$ vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist -!!$ if (dist==0) vc(i,j) = 0. -!!$ enddo -!!$ enddo -!!$ do j=jsd,jed -!!$ do i=isd,ied+1 -!!$ dist = dy(i,j) -!!$ uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist -!!$ if (dist==0) uc(i,j) = 0. -!!$ enddo -!!$ enddo -!!$ -!!$ -!!$ do j=js,je -!!$ do i=is,ie+1 -!!$ dist = dxc(i,j) -!!$ v(i,j) = (psi(i,j)-psi(i-1,j))/dist -!!$ if (dist==0) v(i,j) = 0. -!!$ enddo -!!$ enddo -!!$ do j=js,je+1 -!!$ do i=is,ie -!!$ dist = dyc(i,j) -!!$ u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist -!!$ if (dist==0) u(i,j) = 0. -!!$ enddo -!!$ enddo -!!$ endif -!!$ -!!$ end subroutine init_latlon_winds - -!!$ subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, bounded_domain, & -!!$ u,v, ua,va, uc,vc, gridstruct, domain, bd) -!!$ -!!$! Input -!!$ integer, intent(IN) :: im,jm,km -!!$ integer, intent(IN) :: ifirst,ilast -!!$ integer, intent(IN) :: jfirst,jlast -!!$ integer, intent(IN) :: ng -!!$ logical, intent(IN) :: bounded_domain -!!$ type(fv_grid_type), intent(IN), target :: gridstruct -!!$ type(domain2d), intent(INOUT) :: domain -!!$ -!!$ !real , intent(in) :: sinlon(im,jm) -!!$ !real , intent(in) :: coslon(im,jm) -!!$ !real , intent(in) :: sinl5(im,jm) -!!$ !real , intent(in) :: cosl5(im,jm) -!!$ -!!$! Output -!!$ ! real , intent(inout) :: u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) -!!$ ! real , intent(inout) :: v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) -!!$ ! real , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) -!!$ ! real , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) -!!$ ! real , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) -!!$ ! real , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) -!!$ -!!$ real , intent(inout) :: u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) -!!$ real , intent(inout) :: v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) -!!$ real , intent(inout) :: ua(isd:ied,jsd:jed) !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) -!!$ real , intent(inout) :: va(isd:ied,jsd:jed) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng) -!!$ real , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng) -!!$ real , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng) -!!$ -!!$!-------------------------------------------------------------- -!!$! Local -!!$ -!!$ real :: sinlon(im,jm) -!!$ real :: coslon(im,jm) -!!$ real :: sinl5(im,jm) -!!$ real :: cosl5(im,jm) -!!$ -!!$ real :: tmp1(jsd:jed+1) -!!$ real :: tmp2(jsd:jed) -!!$ real :: tmp3(jsd:jed) -!!$ -!!$ real mag,mag1,mag2, ang,ang1,ang2 -!!$ real us, vs, un, vn -!!$ integer i, j, k, im2 -!!$ integer js1g1 -!!$ integer js2g1 -!!$ integer js2g2 -!!$ integer js2gc -!!$ integer js2gc1 -!!$ integer js2gcp1 -!!$ integer js2gd -!!$ integer jn2gc -!!$ integer jn1g1 -!!$ integer jn1g2 -!!$ integer jn2gd -!!$ integer jn2gsp1 -!!$ -!!$ real, pointer, dimension(:,:,:) :: agrid, grid -!!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0 -!!$ real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2 -!!$ real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es -!!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc -!!$ -!!$ logical, pointer :: cubed_sphere, latlon -!!$ -!!$ logical, pointer :: have_south_pole, have_north_pole -!!$ -!!$ integer, pointer :: ntiles_g -!!$ real, pointer :: acapN, acapS, globalarea -!!$ -!!$ grid => gridstruct%grid -!!$ agrid=> gridstruct%agrid -!!$ -!!$ area => gridstruct%area -!!$ rarea => gridstruct%rarea -!!$ -!!$ fC => gridstruct%fC -!!$ f0 => gridstruct%f0 -!!$ -!!$ ee1 => gridstruct%ee1 -!!$ ee2 => gridstruct%ee2 -!!$ ew => gridstruct%ew -!!$ es => gridstruct%es -!!$ en1 => gridstruct%en1 -!!$ en2 => gridstruct%en2 -!!$ -!!$ dx => gridstruct%dx -!!$ dy => gridstruct%dy -!!$ dxa => gridstruct%dxa -!!$ dya => gridstruct%dya -!!$ rdxa => gridstruct%rdxa -!!$ rdya => gridstruct%rdya -!!$ dxc => gridstruct%dxc -!!$ dyc => gridstruct%dyc -!!$ -!!$ cubed_sphere => gridstruct%cubed_sphere -!!$ latlon => gridstruct%latlon -!!$ -!!$ have_south_pole => gridstruct%have_south_pole -!!$ have_north_pole => gridstruct%have_north_pole -!!$ -!!$ ntiles_g => gridstruct%ntiles_g -!!$ acapN => gridstruct%acapN -!!$ acapS => gridstruct%acapS -!!$ globalarea => gridstruct%globalarea -!!$ -!!$ if (cubed_sphere) then -!!$ -!!$ call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,im,jm,ng) -!!$ if (.not. bounded_domain) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.) -!!$ call atoc(ua,va,uc,vc,dx,dy,dxa,dya,im,jm,ng, bounded_domain, domain, noComm=.true.) -!!$ if (.not. bounded_domain) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.) -!!$ -!!$ else ! Lat-Lon -!!$ -!!$ im2 = im/2 -!!$ -!!$! Set loop limits -!!$ -!!$ js1g1 = jfirst-1 -!!$ js2g1 = jfirst-1 -!!$ js2g2 = jfirst-2 -!!$ js2gc = jfirst-ng -!!$ js2gcp1 = jfirst-ng-1 -!!$ js2gd = jfirst-ng -!!$ jn1g1 = jlast+1 -!!$ jn1g2 = jlast+2 -!!$ jn2gc = jlast+ng -!!$ jn2gd = jlast+ng-1 -!!$ jn2gsp1 = jlast+ng-1 -!!$ -!!$ if (have_south_pole) then -!!$ js1g1 = 1 -!!$ js2g1 = 2 -!!$ js2g2 = 2 -!!$ js2gc = 2 -!!$ js2gcp1 = 2 ! NG-1 latitudes on S (starting at 2) -!!$ js2gd = 2 -!!$ endif -!!$ if (have_north_pole) then -!!$ jn1g1 = jm -!!$ jn1g2 = jm -!!$ jn2gc = jm-1 ! NG latitudes on N (ending at jm-1) -!!$ jn2gd = jm-1 -!!$ jn2gsp1 = jm-1 -!!$ endif -!!$! -!!$! Treat the special case of ng = 1 -!!$! -!!$ if ( ng == 1 .AND. ng > 1 ) THEN -!!$ js2gc1 = js2gc -!!$ else -!!$ js2gc1 = jfirst-ng+1 -!!$ if (have_south_pole) js2gc1 = 2 ! NG-1 latitudes on S (starting at 2) -!!$ endif -!!$ -!!$ do k=1,km -!!$ -!!$ if ((have_south_pole) .or. (have_north_pole)) then -!!$! Get D-grid V-wind at the poles. -!!$ call vpol5(u(1:im,:), v(1:im,:), im, jm, & -!!$ coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast ) -!!$ call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:)) -!!$ endif -!!$ -!!$ call dtoa(u, v, ua, va, dx,dy,dxa,dya,dxc,dyc,im, jm, ng) -!!$ if (.not. bounded_domain) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.) -!!$ -!!$ if ( have_south_pole ) then -!!$! Projection at SP -!!$ us = 0. -!!$ vs = 0. -!!$ do i=1,im2 -!!$ us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2) & -!!$ + (va(i,2)-va(i+im2,2))*coslon(i,2) -!!$ vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2) & -!!$ + (va(i+im2,2)-va(i,2))*sinlon(i,2) -!!$ enddo -!!$ us = us/im -!!$ vs = vs/im -!!$! SP -!!$ do i=1,im2 -!!$ ua(i,1) = -us*sinlon(i,1) - vs*coslon(i,1) -!!$ va(i,1) = us*coslon(i,1) - vs*sinlon(i,1) -!!$ ua(i+im2,1) = -ua(i,1) -!!$ va(i+im2,1) = -va(i,1) -!!$ enddo -!!$ ua(0 ,1) = ua(im,1) -!!$ ua(im+1,1) = ua(1 ,1) -!!$ va(im+1,1) = va(1 ,1) -!!$ endif -!!$ -!!$ if ( have_north_pole ) then -!!$! Projection at NP -!!$ un = 0. -!!$ vn = 0. -!!$ j = jm-1 -!!$ do i=1,im2 -!!$ un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j) & -!!$ + (va(i+im2,j)-va(i,j))*coslon(i,j) -!!$ vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j) & -!!$ + (va(i+im2,j)-va(i,j))*sinlon(i,j) -!!$ enddo -!!$ un = un/im -!!$ vn = vn/im -!!$! NP -!!$ do i=1,im2 -!!$ ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm) -!!$ va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm) -!!$ ua(i+im2,jm) = -ua(i,jm) -!!$ va(i+im2,jm) = -va(i,jm) -!!$ enddo -!!$ ua(0 ,jm) = ua(im,jm) -!!$ ua(im+1,jm) = ua(1 ,jm) -!!$ va(im+1,jm) = va(1 ,jm) -!!$ endif -!!$ -!!$ if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:)) -!!$ if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:)) -!!$ -!!$! A -> C -!!$ call atoc(ua, va, uc, vc, dx,dy,dxa,dya,im, jm, ng, bounded_domain, domain, noComm=.true.) -!!$ -!!$ enddo ! km loop -!!$ -!!$ if (.not. bounded_domain) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.) -!!$ endif -!!$ -!!$ -!!$ end subroutine d2a2c -!!$ - -!!$ subroutine atob_s(qin, qout, npx, npy, dxa, dya, bounded_domain, cubed_sphere, altInterp) -!!$ -!!$! atob_s :: interpolate scalar from the A-Grid to the B-grid -!!$! -!!$ integer, intent(IN) :: npx, npy -!!$ real , intent(IN) :: qin(isd:ied ,jsd:jed ) ! A-grid field -!!$ real , intent(OUT) :: qout(isd:ied+1,jsd:jed+1) ! Output B-grid field -!!$ integer, OPTIONAL, intent(IN) :: altInterp -!!$ logical, intent(IN) :: bounded_domain, cubed_sphere -!!$ real, intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya -!!$ -!!$ integer :: i,j,n -!!$ -!!$ real :: tmp1j(jsd:jed+1) -!!$ real :: tmp2j(jsd:jed+1) -!!$ real :: tmp3j(jsd:jed+1) -!!$ real :: tmp1i(isd:ied+1) -!!$ real :: tmp2i(isd:ied+1) -!!$ real :: tmp3i(isd:ied+1) -!!$ real :: tmpq(isd:ied ,jsd:jed ) -!!$ real :: tmpq1(isd:ied+1,jsd:jed+1) -!!$ real :: tmpq2(isd:ied+1,jsd:jed+1) -!!$ -!!$ if (present(altInterp)) then -!!$ -!!$ tmpq(:,:) = qin(:,:) -!!$ -!!$ if (.not. bounded_domain) call fill_corners(tmpq , npx, npy, FILL=XDir, AGRID=.true.) -!!$! ATOC -!!$ do j=jsd,jed -!!$ call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altInterp) -!!$ enddo -!!$ -!!$ if (.not. bounded_domain) call fill_corners(tmpq , npx, npy, FILL=YDir, AGRID=.true.) -!!$! ATOD -!!$ do i=isd,ied -!!$ tmp1j(jsd:jed) = 0.0 -!!$ tmp2j(jsd:jed) = tmpq(i,jsd:jed) -!!$ tmp3j(jsd:jed) = dya(i,jsd:jed) -!!$ call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altInterp) -!!$ tmpq2(i,jsd:jed) = tmp1j(jsd:jed) -!!$ enddo -!!$ -!!$! CTOB -!!$ do i=isd,ied -!!$ tmp1j(:) = tmpq1(i,:) -!!$ tmp2j(:) = tmpq1(i,:) -!!$ tmp3j(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce -!!$ call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altInterp) -!!$ tmpq1(i,:) = tmp1j(:) -!!$ enddo -!!$ -!!$! DTOB -!!$ do j=jsd,jed -!!$ tmp1i(:) = tmpq2(:,j) -!!$ tmp2i(:) = tmpq2(:,j) -!!$ tmp3i(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce -!!$ call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altInterp) -!!$ tmpq2(:,j) = tmp1i(:) -!!$ enddo -!!$ -!!$! Average -!!$ do j=jsd,jed+1 -!!$ do i=isd,ied+1 -!!$ qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j)) -!!$ enddo -!!$ enddo -!!$ -!!$! Fix Corners -!!$ if (cubed_sphere .and. .not. bounded_domain) then -!!$ i=1 -!!$ j=1 -!!$ if ( (is==i) .and. (js==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1)) -!!$ endif -!!$ -!!$ i=npx -!!$ j=1 -!!$ if ( (ie+1==i) .and. (js==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j)) -!!$ endif -!!$ -!!$ i=1 -!!$ j=npy -!!$ if ( (is==i) .and. (je+1==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j)) -!!$ endif -!!$ -!!$ i=npx -!!$ j=npy -!!$ if ( (ie+1==i) .and. (je+1==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j)) -!!$ endif -!!$ endif -!!$ -!!$ else ! altInterp -!!$ -!!$ do j=js,je+1 -!!$ do i=is,ie+1 -!!$ qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + & -!!$ qin(i ,j) + qin(i ,j-1)) -!!$ enddo -!!$ enddo -!!$ -!!$ if (.not. bounded_domain) then -!!$ i=1 -!!$ j=1 -!!$ if ( (is==i) .and. (js==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1)) -!!$ endif -!!$ -!!$ i=npx -!!$ j=1 -!!$ if ( (ie+1==i) .and. (js==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j)) -!!$ endif -!!$ -!!$ i=1 -!!$ j=npy -!!$ if ( (is==i) .and. (je+1==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j)) -!!$ endif -!!$ -!!$ i=npx -!!$ j=npy -!!$ if ( (ie+1==i) .and. (je+1==j) ) then -!!$ qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j)) -!!$ endif -!!$ endif !not bounded_domain -!!$ -!!$ endif ! altInterp -!!$ -!!$ end subroutine atob_s -!!$! -!!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! -!!$!------------------------------------------------------------------------------- - !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! ! @@ -8827,7 +6616,6 @@ subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, bounded_do call interp_left_edge_1d(uout(:,j), uin(:,j), dxa(:,j), isd, ied, interpOrder) enddo do i=isd,ied -!!$ tmp1j(:) = vout(i,:) tmp2j(:) = vin(i,:) tmp3j(:) = dya(i,:) call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder) @@ -8837,14 +6625,12 @@ subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, bounded_do #else do j=jsd,jed -!!$ tmp1i(:) = uout(:,j) tmp2i(:) = uin(:,j)*dya(:,j) tmp3i(:) = dxa(:,j) call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interpOrder) uout(:,j) = tmp1i(:)/dy(:,j) enddo do i=isd,ied -!!$ tmp1j(:) = vout(i,:) tmp2j(:) = vin(i,:)*dxa(i,:) tmp3j(:) = dya(i,:) call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder) @@ -9358,12 +7144,6 @@ subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order) ! if (tile==1) print*, 0.5*(qin(i-1)+qin(i)), qout(i) enddo -!!$ if (tile==1) print*,'x=fltarr(28)' -!!$ do i=ifirst,ilast -!!$ if (tile==1) print*, 'x(',i-ifirst,')=',qin(i) -!!$ enddo - - call mp_stop stop