! $Id: tpcore_geos5_window_mod.f90,v 1.1 2011/02/23 00:08:48 daven Exp $ module TPCORE_GEOS5_WINDOW_MOD ! !****************************************************************************** ! Module TPCORE_GES5_WINDOW_MOD contains routines for the GEOS-4/fvDAS ! transport scheme. Original code from S-J Lin and Kevin Yeh. ! (bdf, bmy, 5/7/03, 10/29/04) ! ! The Harvard Atmospheric Chemistry Modeling Group has modified the original ! code in order to implement the Philip-Cameron Smith pressure fixer for mass ! conservation, and also to save out mass fluxes. These changes are denoted ! in the code by comment tag lines !%%%%%%%. Also, all modifications to the ! original code are written in ALL CAPITALS. ! ! Module Routines: ! ============================================================================ ! (1 ) INIT_TPCORE : Initialization routine for TPCORE ! (2 ) EXIT_TPCORE : Cleanup and exit routine for TPCORE ! (3 ) TPCORE_FVDAS : Driver routine for GEOS-4/TPCORE transport scheme ! (4 ) AIR_MASS_FLUX : TPCORE internal routine ! (5 ) TP2G : TPCORE internal routine ! (6 ) TP2D : TPCORE internal routine ! (7 ) XTP : TPCORE internal routine ! (8 ) XMIST : TPCORE internal routine ! (9 ) FXPPM : TPCORE internal routine ! (10) LMPPM : TPCORE internal routine ! (11) HUYNH : TPCORE internal routine ! (12) YTP : TPCORE internal routine ! (13) YMIST : TPCORE internal routine ! (14) FYPPM : TPCORE internal routine ! (15) XPAVG : TPCORE internal routine ! (16) QMAP : TPCORE internal routine ! (17) MAP1_PPM : TPCORE internal routine ! (18) PPM2M : TPCORE internal routine ! (19) STEEPZ : TPCORE internal routine ! (20) KMPPM : TPCORE internal routine ! (21) FCT_X : TPCORE internal routine ! (22) FILLZ : TPCORE internal routine ! (23) PFIX : TPCORE internal routine ! (24) GMEAN : TPCORE internal routine ! (25) ADJ_FX : TPCORE internal routine ! ! GEOS-CHEM modules referenced by "tpcore_fvdas_mod.f90" ! ============================================================================ ! none ! ! NOTES: ! (1 ) Renamed this module from "transport_fv.F90" to "tpcore_fvdas_mod.f90" ! to be more consistent with GEOS-CHEM naming convention. ! (2 ) Renamed routine TPCORE to TPCORE_FVDAS to avoid conflict with ! existing routine TPCORE from S-J Lin's version 7.1.m. ! (3 ) Added code for PJC pressure fixer. Also now declare everything ! PRIVATE except for INIT_TPCORE, TPCORE_FVDAS, and EXIT_TPCORE. ! (bdf, bmy, 5/7/03) ! (4 ) Added modifications to save mass fluxes in ND24, ND25, ND26 ! diagnostics. Also now make places in the code which have been ! modified by Harvard more clear to discern. (bdf, bmy, 9/28/04) ! (5 ) Bug fix: Need to multiply ND25 N/S transport fluxes by the array ! RGW_25 which accounts for the latitude factor (bdf, bmy, 10/29/04) ! (6 ) Bug fix: In INIT_GEOS5_WINDOW, need to dimension COSE with JM+1 ! instead of JM. (Xiaoguang Gu, bmy, 1/20/09) !****************************************************************************** ! ! The original module documentation header is listed here: ! ! TransPort module for NASA Goddard Chemistry Transport Model ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Last modified: February 27, 2002 ! ! Purpose: perform the transport of 3-D mixing ratio fields using ! externally specified winds and surface pressure on the ! hybrid Eta-coordinate. ! One call to tpcore updates the 3-D mixing ratio ! fields for one time step (DT). ! ! Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) schemes ! (Lin and Rood 1996, MWR) with many unpublished modifications ! ! Messaging passing library based on "Pilgrim" developed by W. Sawyer ! ! Suggested compiler options: ! SGI Origin: f90 -c -r8 -64 -O3 -mips4 -mp ! loader: f90 -64 -mp ! Linux Lahey/Fujitsu lf95 -c -CcdRR8 --tpp ! ! Send comments/suggestions to the algorithm developers: ! ! S.-J. Lin ! Code 910.3, NASA/GSFC, Greenbelt, MD 20771 ! E-mail: slin@dao.gsfc.nasa.gov ! ! Kevin Yeh ! Code 910.3, NASA/GSFC, Greenbelt, MD 20771 ! E-mail: kyeh@dao.gsfc.nasa.gov ! ! The algorithm is primarily based on the following papers: ! ! 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- ! Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. ! ! 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of ! the van Leer-type transport schemes and its applications to the moist- ! ure transport in a General Circulation Model. Mon. Wea. Rev., 122, ! 1575-1593. !****************************************************************************** ! !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Add MODULE PRIVATE declarations. For safety's sake, declare all !%%% routines and variables PRIVATE except for INIT_TPCORE and !%%% TPCORE_FVDAS, which need to be seen outside. (bdf, bmy, 5/7/03) !%%% PRIVATE PUBLIC :: TPCORE_GEOS5_WINDOW PUBLIC :: INIT_GEOS5_WINDOW PUBLIC :: EXIT_GEOS5_TPCORE_WINDOW !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #if defined(SPMD) #define PRT_PREFIX if(gid.eq.0) #if defined(PILGRIM) use decompmodule, only: decomptype use ghostmodule, only: ghosttype use parutilitiesmodule, only: gid, parpatterntype, & parbegintransfer, parendtransfer type(parpatterntype) :: pattern2dmg, pattern2dng type(decomptype) :: decomp2d type(ghosttype) :: ghost2dmg, ghost2dng #else use mod_comm, only: gid, mp_barrier, mp_send3d_ns, & mp_recv3d_ns, mp_allgather1d #endif #else #define PRT_PREFIX #endif real ,ALLOCATABLE, save :: dtdx5(:) real ,ALLOCATABLE, save :: dtdy5(:) real ,ALLOCATABLE, save :: cosp(:) real ,ALLOCATABLE, save :: cose(:) real ,ALLOCATABLE, save :: gw(:) real ,ALLOCATABLE, save :: rgw(:) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added DLAT as allocatable array for PJC pressure fixer !%%% (bdf, bmy, 5/7/03) !%%% REAL, ALLOCATABLE, SAVE :: DLAT(:) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added RGW_25 as allocatable array for ND25 N/S mass flux diagnostic. !%%% This accounts for the latitude factor. (bdf, bmy, 10/29/04) !%%% REAL, ALLOCATABLE, SAVE :: RGW_25(:) REAL, ALLOCATABLE, SAVE :: SINE_25(:) !(dan 0803) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% CONTAINS !------------------------------------------------------------------------- subroutine init_GEOS5_WINDOW(im,jm,km,jfirst,jlast,ng, mg, dt, ae, clat) !------------------------------------------------------------------------- #if defined(SPMD) #if defined(PILGRIM) use decompmodule, only : decompcreate use ghostmodule, only : ghostcreate use parutilitiesmodule, only : gid, gsize, commglobal, parpatterncreate #else use mod_comm, only : gid, y_decomp #endif #endif implicit none !------- ! Input !------- integer, intent(in):: im ! Global E-W dimension integer, intent(in):: jm ! Global N-S dimension integer, intent(in):: km ! Vertical dimension integer, intent(out):: jfirst ! Local first index for N-S integer, intent(out):: jlast ! Local last index for N-S integer, intent(in):: ng ! large ghost width integer, intent(in):: mg ! small ghost width real, intent(in):: dt ! Time step in seconds real, intent(in):: ae ! Earth's radius (m) real, intent(in):: clat(0:jm+1) ! latitude in radian (dan) !----- ! Local !----- real elat(jm+1) ! cell edge latitude in radian real sine(jm+1) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Comment out this declaration of DLAT. DLAT has now been declared !%%% as ALLOCATABLE for use in TPCORE_FVDAS. (bdf, bmy, 5/7/03) !%%% !%%%real dlat(jm) ! delta-latitude in radian !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Add SINE_25 array as a local variable. This is used to initialize !%%% the RGW_25 array, which is necessary for the ND25 diagnostic. !%%% (bdf, bmy, 10/29/04) !%%% ! REAL SINE_25(JM+1) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% real dlon real pi integer i, j #if defined(SPMD) #if defined(PILGRIM) integer, allocatable :: xdist(:), ydist(:) allocate(xdist(1)) allocate(ydist(gsize)) ! ! Decomposition ! xdist(1) = im call newdecomp(jm,gsize,ydist) jfirst = 1 do i=1,gid jfirst = jfirst + ydist(i) enddo jlast = jfirst + ydist(gid+1) - 1 call decompcreate(1, gsize, xdist, ydist, decomp2d ) ! 2D region with 1D lat decomposition call ghostcreate(decomp2d, gid, im, 1, im, .false., & jm, jfirst-mg, jlast+mg, .false., ghost2dmg ) call ghostcreate(decomp2d, gid, im, 1, im, .false., & jm, jfirst-ng, jlast+ng, .false., ghost2dng ) call parpatterncreate(commglobal, ghost2dmg, pattern2dmg) call parpatterncreate(commglobal, ghost2dng, pattern2dng) #else ! ! Default decomposition ! call y_decomp(jm, km, jfirst, jlast, 1, km, gid) #endif #else jfirst = 1 jlast = jm #endif if ( jlast - jfirst < 2 ) then write(*,*) 'Minimum size of subdomain is 3' endif !---------------- ! Allocate arrays !---------------- allocate ( cosp(jm) ) !------------------------------------------------------------------------ ! Prior to 1/20/09: ! Bug fix: should be dimensioned with JM+1 (Xiaoguang Gu, bmy, 1/20/09) !allocate ( cose(jm) ) !------------------------------------------------------------------------ allocate ( cose(jm+1) ) allocate ( gw(jm) ) allocate ( rgw(jm) ) allocate ( dtdx5(jm) ) allocate ( dtdy5(jm) ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% We must allocate DLAT here for PJC pressure fixer (bdf, bmy, 5/7/03) !%%% ALLOCATE ( DLAT(JM) ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% We must allocate RGW_25 here for ND25 N/S transport fluxes diagnostic. !%%% This accounts for the latitude factor. (bdf, bmy, 10/29/04) !%%% ALLOCATE ( RGW_25(JM) ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ALLOCATE ( SINE_25(JM+1) ) !(dan 0803) pi = 4. * atan(1.) dlon = 2.*pi / float(540) !(dan) ! dan for window !elat(1) = -0.5*pi ! S. Pole !sine(1) = -1. !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Initialize SINE_25 array (bmy, bdf, 10/29/04) !%%% !SINE_25(1) = -1.0 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !cose(1) = 0. do j=1,jm+1 !(dan) elat(j) = 0.5*(clat(j-1) + clat(j)) sine(j) = sin(elat(j)) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Initialize SINE_25 array (bmy, bdf, 10/29/04) !%%% SINE_25(J) = SIN( CLAT(J) ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cose(j) = cos(elat(j)) enddo !dan for window !elat(jm+1) = 0.5*pi ! N. Pole !sine(jm+1) = 1. !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Initialize SINE_25 array (bmy, bdf, 10/29/04) !%%% !SINE_25(JM+1) = 1.0 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !dlat(1) = 2.*(elat(2) - elat(1)) ! Polar cap (dan) do j=1,jm dlat(j) = elat(j+1) - elat(j) enddo !dlat(jm) = 2.*(elat(jm+1) - elat(jm)) ! Polar cap (dan) do j=1,jm gw(j) = sine(j+1) - sine(j) cosp(j) = gw(j) / dlat(j) rgw(j) = 1. / gw(j) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Initialize RGW_25 for the ND25 N/S transport fluxes diagnostic. !%%% RGW_25 takes into account the latitude factor. (bdf, bmy, 10/29/04) !%%% RGW_25(J) = 1. / ( SINE_25(J+1) - SINE_25(J) ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% dtdx5(j) = 0.5 * dt / (dlon*ae*cosp(j)) dtdy5(j) = 0.5 * dt / (ae*dlat(j)) enddo !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% Comment out the === lines (bmy, 7/20/04) !%%%! Now use REPEAT cmd (bmy, 4/29/03) !%%%PRT_PREFIX write( 6, '(a)' ) REPEAT( '=', 79 ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% PRT_PREFIX write( 6, '(a)' ) 'NASA-GSFC Tracer Transport Module successfully initialized' !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% Comment out the === lines (bmy, 7/20/04) !%%%PRT_PREFIX write( 6, '(a)' ) REPEAT( '=', 79 ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end subroutine init_GEOS5_WINDOW !------------------------------------------------------------------------- subroutine EXIT_GEOS5_TPCORE_WINDOW !------------------------------------------------------------------------- #if defined(SPMD) && defined(PILGRIM) use decompmodule, only : decompfree use ghostmodule, only : ghostfree use parutilitiesmodule, only : commglobal, parpatternfree call parpatternfree(commglobal, pattern2dmg) call parpatternfree(commglobal, pattern2dng) call ghostfree(ghost2dmg) call ghostfree(ghost2dng) call decompfree(decomp2d) #endif !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Comment out original code below (bdf, bmy, 5/9/03) !%%% !%%%deallocate ( cosp ) !%%%deallocate ( cose ) !%%%deallocate ( gw ) !%%%deallocate ( rgw ) !%%%deallocate ( dtdx5 ) !%%%deallocate ( dtdy5 ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Now deallocate arrays only if they have been allocated (bmy, 5/9/03) !%%% Also deallocate RGW_25 array (bdf, bmy, 10/29/04) !%%% IF ( ALLOCATED( COSP ) ) DEALLOCATE( COSP ) IF ( ALLOCATED( COSE ) ) DEALLOCATE( COSE ) IF ( ALLOCATED( GW ) ) DEALLOCATE( GW ) IF ( ALLOCATED( RGW ) ) DEALLOCATE( RGW ) IF ( ALLOCATED( RGW_25 ) ) DEALLOCATE( RGW_25 ) ! (bdf, bmy, 10/29/04) IF ( ALLOCATED( DTDX5 ) ) DEALLOCATE( DTDX5 ) IF ( ALLOCATED( DTDY5 ) ) DEALLOCATE( DTDY5 ) IF ( ALLOCATED( DLAT ) ) DEALLOCATE( DLAT ) IF ( ALLOCATED( SINE_25) ) DEALLOCATE( SINE_25) !(dan 0803) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end subroutine EXIT_GEOS5_TPCORE_WINDOW !---------------------------------------------------------------------------- subroutine TPCORE_GEOS5_WINDOW( dt, ae, im, jm, km, jfirst, & jlast, ng, mg, & nq, ak, bk, u, v, ps1, ps2, ps, q, & iord, jord, kord, n_adj, & !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added XMASS, YMASS arguments to arg list of TPCORE_FVDAS for PJC/LLNL !%%% pressure fixer (bdf, bmy, 5/7/03) !%%% XMASS, YMASS, & !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added MASSFLEW, MASSFLNS, MASSFLUP, AREA_M2, TCVV, ND24, ND25, and !%%% ND26 to arg list of TPCORE_FVDAS for GEOS-CHEM mass-flux diagnostics !%%% (bdf, bmy, 9/28/04) !%%% MASSFLEW, MASSFLNS, MASSFLUP, AREA_M2, & TCVV, ND24, ND25, ND26, iv ) !(zhe 11/28/10) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !---------------------------------------------------------------------------- implicit none ! Input: integer, intent(in):: im ! Global E-W dimension integer, intent(in):: jm ! Global N-S dimension integer, intent(in):: km ! Vertical dimension integer, intent(in):: jfirst ! Local first index for N-S integer, intent(in):: jlast ! Local last index for N-S integer, intent(in):: ng ! Primary ghost region integer, intent(in):: mg ! Secondary ghost region integer, intent(in):: nq ! Ghosted latitudes (3 required by PPM) integer, intent(in):: iord ! E-W transport scheme integer, intent(in):: jord ! N-S transport scheme integer, intent(in):: kord ! Vertical mapping scheme integer, intent(in):: n_adj ! Number of adjustemnt to air_mass_flux ! 0 --> no adjustment ! Recommended values : iord=jord=4, kord=7 ! _ord: !--------------------------------------------------------------------------- ! 1: 1st order upstream scheme ! 2: 2nd order van Leer (full monotonicity constraint; ! see Lin et al 1994, MWR) ! 3: Standard monotonic PPM* (Collela & Woodward 1984) ! 4: New & Improved monotonic PPM ! 5: positive-definite PPM (constraint on the subgrid distribution is ! only strong enough to prevent generation of negative values; ! both overshoots & undershootes are possible). ! 6: un-constrained PPM (nearly diffusion free; faster but ! positivity of the subgrid distribution is not quaranteed. ! 7: Huynh/Van Leer/Lin full monotonicity constraint !--------------------------------------------------------------------------- ! Only kord can be set to 7 to enable the use of Huynh's 2nd monotonicity ! constraint for piece-wise parabolic distribution. ! *PPM: Piece-wise Parabolic Method real, intent(in):: ak(km+1) ! See below real, intent(in):: bk(km+1) ! See below real, intent(in):: u(:,:,:) ! u-wind (m/s) at mid-time-level (t=t+dt/2) real, intent(inout):: v(:,:,:) ! v-wind (m/s) at mid-time-level (t=t+dt/2) !------------------------------------------------------ ! The hybrid ETA-coordinate: ! pressure at layer edges are defined as follows: ! ! p(i,j,k) = ak(k) + bk(k)*ps(i,j) !------------------------------------------------------ ! ak and bk are defined at layer edges. ! ///////////////////////////////// ! / \ ------ Model top P=ak(1) --------- ak(1), bk(1) ! | ! delp(1) | ........... q(i,j,1) ............ ! | ! \ / --------------------------------- ak(2), bk(2) ! ! ! ! / \ --------------------------------- ak(k), bk(k) ! | ! delp(k) | ........... q(i,j,k) ............ ! | ! \ / --------------------------------- ak(k+1), bk(k+1) ! ! ! ! / \ --------------------------------- ak(km), bk(km) ! | ! delp(km) | ........... q(i,j,km) ......... ! | ! \ / -----Earth's surface P=Psfc ------ ak(km+1), bk(km+1) ! ////////////////////////////////// ! Note: surface pressure can be of any unit (e.g., pascal or mb) as long as it is ! consistent with the definition of (ak, bk) defined above ! Winds (u,v), ps, and q are assumed to be defined at the same points. ! The latitudes are given by clat, input to the initialization routine: init_tpcore. real, intent(in):: ps1(im,jfirst:jlast) ! surface pressure at current time real, intent(in):: ps2(im,jfirst:jlast) ! surface pressure at future time=t+dt real, intent(in):: dt ! Transport time step in seconds real, intent(in):: ae ! Earth's radius (m) real, intent(inout):: q(:,:,:,:) ! Tracer "mixing ratios" ! q could easily be re-dimensioned real, intent(out):: ps(im,jfirst:jlast) ! "predicted" surface pressure real delp(im,jfirst:jlast,km) ! Predicted thickness at future time (t=t+dt) real pe(im,km+1,jfirst:jlast) ! Pressure at layer edges (predicted) real fx(im,jfirst:jlast,km) ! E-W air mass flux real va(im,jfirst:jlast,km) ! N-S CFL at cell center (scalar points) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added XMASS, YMASS for the PJC pressure-fixer (bdf, bmy, 5/7/03) !%%% REAL, INTENT(IN) :: XMASS(:,:,:), YMASS(:,:,:) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added MASSFLEW, MASSFLNS, MASSFLUP, AREA_M2, TCVV, ND24, ND25, ND26 !%%% for mass-flux diagnostics (bdf, bmy, 9/28/04) !%%% REAL, INTENT(INOUT) :: MASSFLEW(IM,JM,KM,NQ) ! east/west mass flux REAL, INTENT(INOUT) :: MASSFLNS(IM,JM,KM,NQ) ! north/south mass flux REAL, INTENT(INOUT) :: MASSFLUP(IM,JM,KM,NQ) ! up/down vertical mass flux REAL, INTENT(IN) :: AREA_M2(JM) ! box area for mass flux diag REAL, INTENT(IN) :: TCVV(NQ) ! tracer masses for flux diag INTEGER, INTENT(IN) :: ND24 ! E/W flux diag switch INTEGER, INTENT(IN) :: ND25 ! N/S flux diag switch INTEGER, INTENT(IN) :: ND26 ! up/down flux diag switch !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !----------------------- ! Ghosted local arrays: !----------------------- real cx(im,jfirst-ng:jlast+ng,km) ! E-W CFL number on C-grid real delp1(im,jfirst-mg:jlast+mg,km) ! Pressure thickness at current time (t) real fy(im,jfirst:jlast+mg,km) ! N-S air mass flux real cy(im,jfirst:jlast+mg,km) ! N-S CFL number on C-grid real psg(im,jfirst-mg:jlast+mg,2) ! Was psm and psn real q2(im,jfirst-ng:jlast+ng) ! local 2D q array logical ffsl(jfirst-ng:jlast+ng,km) ! Flag to compute Integer fluxes ! Local variables: integer i,j,k,iq integer iord_bg ! E-W scheme for background mass flux integer jord_bg ! N-S scheme for background mass flux integer js1gd ! Southern latitude border (1 on SP PE) integer jn1gd ! Northern latitude border (JM on NP PE) integer nx ! Internal E-W OpenMP decomposition integer iv ! Monotonicity constraints for top and bottom !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Define DTC, QTEMP, TRACE_DIFF for ND26 diagnostic (bdf, bmy, 9/28/04) !%%% REAL DTC(IM,JM,KM,NQ) ! up/down flux temp array REAL QTEMP(IM,JM,KM,NQ) ! up/down flux array REAL TRACE_DIFF ! up/down flux variable !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% parameter (nx = 1) ! Try 2 or 4 if large number of OMP threads ! is to be used js1gd = max(1, jfirst-ng) ! NG latitudes on S (starting at 1) jn1gd = min(jm,jlast+ng) ! NG latitudes on N (ending at jm) iord_bg = 1 jord_bg = 1 ! Now pass iv as an argument (zj, dkh, 02/04/11) ! iv = 1 ! Enforce strong constraint at top & bottom ! ! May want to change to iv=0 if diffusion is a problem ! ! ! iv =0 !(dan.iv 0803) ! ! iv=-1 !(dan 0803) ! Ensure inputs are single-valued at poles: do j=jfirst,jlast do i=1,im psg(i,j,1) = ps1(i,j) psg(i,j,2) = ps2(i,j) enddo enddo if ( jfirst == 1 ) then call xpavg(psg(:,1,1), im) call xpavg(psg(:,1,2), im) endif if ( jlast == jm ) then call xpavg(psg(:,jm,1), im) call xpavg(psg(:,jm,2), im) endif #if defined(SPMD) ! Ghost v, psm and psn north/south --> now in one array psg #if defined(PILGRIM) call parbegintransfer(pattern2dmg, km, v, v) call parbegintransfer(pattern2dmg, 2, psg, psg) #else call mp_send3d_ns(im, jm, jfirst, jlast, 1, km, mg, mg, v, 1) call mp_send3d_ns(im, jm, jfirst, jlast, 1, 2, mg, mg, psg, 2) #endif #endif ! Average q at both poles do iq=1,nq !$omp parallel do & !$omp shared(im) & !$omp private(k) do k=1,km if ( jfirst == 1 ) then call xpavg(q(:,1,k,iq), im) endif if ( jlast == jm ) then call xpavg(q(:,jm,k,iq), im) endif enddo enddo #if defined(SPMD) #if defined(PILGRIM) call parendtransfer(pattern2dmg, km, v, v) call parendtransfer(pattern2dmg, 2, psg, psg) #else call mp_barrier() call mp_recv3d_ns(im, jm, jfirst, jlast, 1, km, mg, mg, v, 1) call mp_recv3d_ns(im, jm, jfirst, jlast, 1, 2, mg, mg, psg, 2) call mp_barrier() #endif #endif !---------------------------------------------- ! Compute background air mass fluxes !---------------------------------------------- call air_mass_flux(im, jm, km, jfirst, jlast, & iord_bg, jord_bg, ak, bk, & psg, ps, u, v, & cx, cy, va, fx, fy, ng, mg, & ffsl, delp1, delp, pe, dt, & ae, n_adj, & !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added XMASS, YMASS to the arg list of AIR_MASS_FLUX !%%% for the PJC/LLNL pressure-fixer (bdf, bmy, 5/7/03) !%%% XMASS, YMASS ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !--------------------------------------------------- ! Do tracer transport !--------------------------------------------------- #if defined(SPMD) ! non-blocking-send for tracer #1 #if defined(PILGRIM) call parbegintransfer(pattern2dng,km,q(:,:,:,1),q(:,:,:,1)) #else call mp_send3d_ns(im, jm, jfirst, jlast, 1, km, ng, ng, & q(1,jfirst-ng,1,1), 1) #endif #endif ! Multi_Tracer: do iq=1,nq #if defined(SPMD) ! Receive current tracer #if defined(PILGRIM) call parendtransfer(pattern2dng,km,q(:,:,:,iq),q(:,:,:,iq)) if (iq < nq) then call parbegintransfer(pattern2dng,km,q(:,:,:,iq+1),q(:,:,:,iq+1)) endif #else call mp_barrier() call mp_recv3d_ns(im, jm, jfirst, jlast, 1, km, ng, ng, & q(1,jfirst-ng,1,iq),iq) call mp_barrier() if ( iq < nq ) then ! non-blocking send for next tracer call mp_send3d_ns(im, jm, jfirst, jlast, 1, km, ng, ng, & q(1,jfirst-ng,1,iq+1),iq+1) endif #endif #endif !$omp parallel do & !$omp shared(im,jm,iv,iord,jord,ng,mg,jfirst,jlast) & !$omp private(i, j, k, q2) ! Vertical_OMP: do k=1,km ! Copying q to 2d work array for transport. This allows q to be dimensioned ! differently from the calling routine. do j=js1gd,jn1gd do i=1,im q2(i,j) = q(i,j,k,iq) enddo enddo call tp2g( q2(1,jfirst-ng), va(1,jfirst,k), & cx(1,jfirst-ng,k), cy(1,jfirst,k), & im, jm, iv, iord, jord, & ng, mg, fx(1,jfirst,k), fy(1,jfirst,k), & ffsl(jfirst-ng,k), jfirst, jlast, & delp1(1,jfirst-mg,k), delp(1,jfirst,k), & !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Now pass MASSFLEW, MASSFLNS, AREA_M2, TCVV, ND24, ND25, DT as !%%% arguments to routine TP2G for GEOS-CHEM mass flux diagnostics !%%% (bdf, bmy, 9/28/04) !%%% MASSFLEW(1,1,K,IQ), MASSFLNS(1,1,K,IQ), & AREA_M2, TCVV(IQ), ND24, ND25, DT ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% do j=jfirst,jlast do i=1,im q(i,j,k,iq) = q2(i,j) enddo enddo ! enddo Vertical_OMP ! enddo Multi_Tracer enddo enddo !--------------------------------------------------------------- ! Perform Remapping back to the hybrid sigma-pressure coordinate ! Mass will be conserved if predicted ps2 == psn (data/model) !--------------------------------------------------------------- !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Save tracer values before vertical transport (bdf, bmy, 9/28/04) !%%% QTEMP = Q !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% call qmap(pe, q, im, jm, km, nx, jfirst, jlast, ng, nq, & ps, ak, bk, kord, iv) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Implement ND26 diag: Up/down flux of tracer [kg/s] (bmy, bdf, 9/28/04) !%%% !%%% The vertical transport done in qmap. We need to find the difference !%%% in order to to interpret transport. !%%% !%%% Break up diagnostic into up & down fluxes using the surface boundary !%%% conditions. Start from top down (really surface up for flipped TPCORE) !%%% IF ( ND26 > 0 ) THEN !----------------- ! start with top !----------------- K = 1 !$OMP PARALLEL DO & !$OMP DEFAULT( SHARED ) & !$OMP PRIVATE( I, J, IQ ) DO IQ = 1, NQ DO I = 1, IM DO J = 1, JM DTC(I,J,K,IQ) = ( Q(I,J,K,IQ) * DELP1(I,J,K) - & QTEMP(I,J,K,IQ) * DELP(I,J,K) ) * & (100d0) * AREA_M2(J) / ( 9.8d0 * TCVV(IQ) ) ! top layer should have no residual. the small residual is from ! a non-pressure fixed flux diag. The z direction may be off by ! a few percent. !MASSFLUP(I,J,K,IQ) = MASSFLUP(I,J,K,IQ) + DTC(I,J,K,IQ)/dt ENDDO ENDDO ENDDO !$OMP END PARALLEL DO !---------------------------------------------------- ! get the other fluxes using a mass balance equation !---------------------------------------------------- DO K = 2, KM !$OMP PARALLEL DO & !$OMP DEFAULT( SHARED ) & !$OMP PRIVATE( I, J, IQ, TRACE_DIFF ) DO IQ = 1, NQ DO I = 1, IM DO J = 1, JM TRACE_DIFF = ( Q(I,J,K,IQ) * DELP1(I,J,K) - & QTEMP(I,J,K,IQ) * DELP(I,J,K) ) * & (100D0) * AREA_M2(J) / ( 9.8D0* TCVV(IQ) ) DTC(I,J,K,IQ) = DTC(I,J,K-1,IQ) + TRACE_DIFF MASSFLUP(I,J,K,IQ) = MASSFLUP(I,J,K,IQ) + DTC(I,J,K,IQ) / DT ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDDO !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ENDIF END subroutine TPCORE_GEOS5_WINDOW subroutine air_mass_flux(im, jm, km, jfirst, jlast, iord, jord, & ak, bk, psg, ps, u, v, cx, cy, va, & fx, fy, ng, mg, ffsl, delp1, delp, & pe, dt, ae, n_adj, & !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added XMASS, YMASS to the arg list of AIR_MASS_FLUX !%%% for the PJC/LLNL pressure-fixer (bdf, bmy, 5/7/03) !%%% XMASS, YMASS ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !------------------------------------------------------ ! The hybrid ETA-coordinate: ! pressure at layer edges are defined as follows: ! ! p(i,j,k) = ak(k) + bk(k)*ps(i,j) (1) !------------------------------------------------------ ! Input from Data/Model: ! (u,v) is the time mean wind at Time=t+dt/2 ! delp1 is the layer thickness at Time=t ! Output: ! delp is the predicted thickness at Time=t+dt ! (fx,fy): background air mass flxues ! (cx,cy): CFL number implicit none integer, intent(in):: im integer, intent(in):: jm integer, intent(in):: km integer, intent(in):: jfirst integer, intent(in):: jlast integer, intent(in):: iord integer, intent(in):: jord integer, intent(in):: ng integer, intent(in):: mg integer, intent(in):: n_adj real, intent(in):: dt real, intent(in):: ae real, intent(in):: ak(km+1) real, intent(in):: bk(km+1) real, intent(in):: psg(im,jfirst-mg:jlast+mg,2) ! Was ps1 and ps2 real, intent(in):: u(im,jfirst:jlast,km) real, intent(in):: v(im,jfirst-mg:jlast+mg,km) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added XMASS, YMASS for PJC/LLNL pressure fixer (bdf, bmy, 5/7/03) !%%% REAL, INTENT(IN) :: XMASS(IM,JM,KM), YMASS(IM,JM,KM) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! Output: logical,intent(out):: ffsl(jfirst-ng:jlast+ng,km) real, intent(out):: cx(im,jfirst-ng:jlast+ng,km) real, intent(out):: delp (im,jfirst:jlast,km) real, intent(out):: ps(im,jfirst:jlast) real, intent(out):: fx(im,jfirst:jlast,km) real, intent(out):: cy(im,jfirst:jlast+mg,km) real, intent(out):: fy(im,jfirst:jlast+mg,km) real, intent(out):: va(im,jfirst:jlast,km) real, intent(out):: delp1(im,jfirst-mg:jlast+mg,km) real, intent(out):: pe(im,km+1,jfirst:jlast) ! Local: real yms(im,jfirst:jlast+mg,km) real tiny parameter (tiny = 1.e-10) real dak, dbk real dtoa, vt integer i,j,k integer js2g0 integer jn2g0 integer jn1g1 integer js2gd, jn2gd !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Declare extra variables PJC/LLNL pressure fixer (bdf, bmy, 5/7/03) !%%% REAL :: DELPM(IM,JM,KM), FACTY, UT !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% js2g0 = max(2,jfirst) ! No ghosting jn2g0 = min(jm-1,jlast) ! No ghosting jn1g1 = min(jm,jlast+1) ! Ghost 1 on N js2gd = max(2, jfirst-ng) ! NG latitudes on S (starting at 1) jn2gd = min(jm-1,jlast+ng) ! NG latitudes on N (ending at jm-1) dtoa = .5*dt/ae cx(:,:,:)=0D0 cy(:,:,:)=0D0 fx(:,:,:)=0D0 fy(:,:,:)=0D0 delp(:,:,:)=0D0 ps(:,:)=0D0 va(:,:,:)=0D0 delp1(:,:,:)=0D0 pe(:,:,:)=0D0 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Define DELPM for PJC pressure fixer (bdf, bmy, 5/7/03) !%%% DO K = 1, KM DO J = 1, JM DO I = 1, IM DELPM(I,J,K) = ( AK(K+1) - AK(K) ) + & ( BK(K+1) - BK(K) ) * & ( 0.5d0 * ( PSG(I,J,1) + PSG(I,J,2 ) + 2d0 * AK(1) ) ) ENDDO ENDDO ENDDO !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added for PJC/LLNL pressure-fixer (bdf, bmy, 5/7/03) !%%% Note that DTDY5 is the same everywhere except at the poles, so !%%% we can just pick a value roughly close to the equator !%%% FACTY = DTDY5(JM/2) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !$omp parallel do private(i, j, k, vt, UT ) do k=1,km do j=js2g0, jn1g1 do i=1,im !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Change calculation of VT for PJC pressure fixer (bdf, bmy, 5/7/03) !%%% VT = YMASS(I,J,K) / FACTY / COSE(J) / DELPM(I,J,K) + & V(I,J-1,K) * ( 1d0 - DELPM(I,J-1,K) / DELPM(I,J,K) ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% if ( vt > 0. ) then cy(i,j,k) = dtdy5(j-1)*vt else cy(i,j,k) = dtdy5(j)*vt endif yms(i,j,k) = dtoa*vt*cose(j) enddo enddo do j=js2g0,jn2g0 do i=1,im if( cy(i,j,k)*cy(i,j+1,k) > 0. ) then if( cy(i,j,k) > 0. ) then va(i,j,k) = cy(i,j,k) else va(i,j,k) = cy(i,j+1,k) endif else va(i,j,k) = 0. endif enddo enddo !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Removed this section for PJC pressure fixer (bdf, bmy, 5/7/03) !%%% do j=js2g0,jn2g0 !%%% cx(1,j,k) = dtdx5(j)*(u(1,j,k)+u(im,j,k)) !%%% do i=2,im !%%% cx(i,j,k) = dtdx5(j)*(u(i,j,k)+u(i-1,j,k)) !%%% enddo !%%% enddo !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Added this section for PJC pressure fixer (bdf, bmy, 5/7/03) !%%% DO J = JS2G0, JN2G0 UT = XMASS(1,J,K) / DTDX5(J) / DELPM(1,J,K) + & U(IM,J,K) * ( 1d0 - DELPM(IM,J,K) / DELPM(1,J,K) ) CX(1,J,K) = DTDX5(J) * UT DO I = 2, IM UT = XMASS(I,J,K) / DTDX5(J) / DELPM(I,J,K) + & U(I-1,J,K) * ( 1d0 - DELPM(I-1,J,K) / DELPM(I,J,K) ) CX(I,J,K) = DTDX5(J) * UT ENDDO ENDDO !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% enddo #if defined(SPMD) ! No buffer version (km calls to mpi_sendrecv) #if defined(PILGRIM) call parbegintransfer(pattern2dng, km, cx, cx) call parendtransfer(pattern2dng, km, cx, cx) #else call mp_send3d_ns(im, jm, jfirst, jlast, 1, km, ng, ng, cx, 3) call mp_barrier() call mp_recv3d_ns(im, jm, jfirst, jlast, 1, km, ng, ng, cx, 3) call mp_barrier() #endif #endif !--------------------------------------------------- ! Compute background mass-flux (fx, fy) and (cx, cy) !--------------------------------------------------- !$omp parallel do & !$omp shared(im,jm,iord,jord,mg,jfirst,jlast) & !$omp private(i, j, k, dak, dbk) do k=1,km do j=js2gd,jn2gd ! ffsl needed on N*ng S*ng ffsl(j,k) = .false. do i=1,im if( abs(cx(i,j,k)) > 1. ) then ffsl(j,k) = .true. go to 2222 endif enddo 2222 continue enddo dak = ak(k+1) - ak(k) dbk = bk(k+1) - bk(k) do j=max(1,jfirst-mg),min(jm,jlast+mg) do i=1,im delp1(i,j,k) = dak + dbk*psg(i,j,1) enddo enddo call tp2d(va(1,jfirst,k), delp1(1,jfirst-mg,k), cx(1,jfirst-mg,k), & cy(1,jfirst,k), im, jm, iord, jord, mg, mg, & fx(1,jfirst,k), fy(1,jfirst,k), ffsl(jfirst-mg,k), & cx(1,jfirst,k), yms(1,jfirst,k), 0, jfirst, jlast) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Fix mass fluxes in regions not over the courant limit (bdf, bmy, 5/7/03) !%%% DO J = 4, JM-4 FX(:,J,K) = XMASS(:,J,K) FY(:,J,K) = YMASS(:,J,K) * DLAT(J) ENDDO !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% do j=js2g0,jn2g0 do i=1,im-1 delp(i,j,k) = delp1(i,j,k) + fx(i,j,k) - fx(i+1,j,k) + & (fy(i,j,k)-fy(i,j+1,k))*rgw(j) enddo delp(im,j,k) = delp1(im,j,k) + fx(im,j,k) - fx(1,j,k) + & (fy(im,j,k)-fy(im,j+1,k))*rgw(j) enddo if ( jfirst == 1 ) then do i=1,im delp(i,1,k) = delp1(i,1,k) - fy(i,2,k)*rgw(1) enddo call xpavg(delp(1,1,k), im) endif if ( jlast == jm ) then do i=1,im delp(i,jm,k) = delp1(i,jm,k) + fy(i,jm,k)*rgw(jm) enddo call xpavg(delp(1,jm,k), im) endif if ( n_adj == 0 ) then do j=js2g0,jn2g0 if( ffsl(j,k) ) then do i=1,im fx(i,j,k) = fx(i,j,k)/sign(max(abs(cx(i,j,k)),tiny),cx(i,j,k)) enddo endif enddo endif enddo !-------------- ! Compute ps: !-------------- !$omp parallel do private(i, j, k) do j=jfirst,jlast do i=1,im pe(i,1,j) = ak(1) enddo do k=1,km do i=1,im pe(i,k+1,j) = pe(i,k,j) + delp(i,j,k) enddo enddo do i=1,im ps(i,j) = pe(i,km+1,j) enddo enddo !-------------------------------------------------------------- ! Apply mass_flux adjuster to nudge predicted ps towards "data" !-------------------------------------------------------------- if ( n_adj > 0 ) then call adj_fx(im, jm, km, jfirst, jlast, ak, bk, ffsl, & ps, psg(:,:,2), pe, delp, fx, cx, fy, ng, mg, & tiny, n_adj) endif end subroutine air_mass_flux subroutine tp2g(h, va, crx, cry, im, jm, iv, & iord, jord, ng, mg, xfx, yfx, ffsl, & jfirst, jlast, dp, dpp, & !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Add MFLEW, MFLNS, AREA_M2, TCV, ND24, ND25, DT as arguments !%%% to subroutine TP2G for mass-flux diagnostics (bmy, 9/28/04) !%%% MFLEW, MFLNS, AREA_M2, & TCV, ND24, ND25, DT ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% implicit none ! !INPUT PARAMETERS: integer, intent(in):: im, jm ! Dimensions integer, intent(in):: jfirst, jlast ! Latitude strip integer, intent(in):: iv ! iv=-1 --> vector integer, intent(in):: iord, jord ! Interpolation order in x,y integer, intent(in):: ng ! Max. NS dependencies integer, intent(in):: mg ! Secondary ghosting zones logical, intent(in):: ffsl(jfirst-ng:jlast+ng) ! Use flux-form semi-Lagrangian trans.? real, intent(in):: va(im,jfirst:jlast) ! CFL in y at cell center real, intent(in):: dp(im,jfirst-mg:jlast+mg) real, intent(in):: dpp(im,jfirst:jlast) real, intent(in):: crx(im,jfirst-ng:jlast+ng) ! ( N*NG S*NG ) real, intent(in):: cry(im,jfirst:jlast+mg) ! ( N like FY ) real, intent(in):: xfx(im,jfirst:jlast) ! x-mass flux real, intent(in):: yfx(im,jfirst:jlast+mg) ! y-mass flux real, intent(inout) :: h(im,jfirst-ng:jlast+ng) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Declare MFLEW, MFLNS, AREA_M2, TCV, ND24, ND25, DT for the !%%% GEOS-CHEM mass-flux diagnostics (bdf, bmy, 9/28/04) !%%% REAL, INTENT(INOUT) :: MFLEW(IM,JM) ! E/W mass flux array REAL, INTENT(INOUT) :: MFLNS(IM,JM) ! N/S mass flux array REAL, INTENT(IN) :: AREA_M2(JM) ! Grid bos surface area [m2] REAL, INTENT(IN) :: TCV ! Mass ratio INTEGER, INTENT(IN) :: ND24 ! flux diag INTEGER, INTENT(IN) :: ND25 ! flux diag REAL, INTENT(IN) :: DT ! time step for flux diagnostic !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! Local real fx(im,jfirst:jlast) ! tracer flux in x ( unghosted ) real fy(im,jfirst:jlast+mg) ! tracer flux in y ( N, see tp2c ) integer i, j, js2g0, jn2g0 real sum1, DTC js2g0 = max(2,jfirst) ! No ghosting jn2g0 = min(jm-1,jlast) ! No ghosting call tp2d(va, h(1,jfirst-ng), crx(1,jfirst-ng), cry, im, jm, & iord, jord, ng, mg, fx, fy, ffsl(jfirst-ng), & xfx, yfx, 1, jfirst, jlast) do j=js2g0,jn2g0 do i=1,im-1 h(i,j) = h(i,j)*dp(i,j) + fx(i,j)-fx(i+1,j)+(fy(i,j)-fy(i,j+1))*rgw(j) enddo enddo do j=js2g0,jn2g0 h(im,j) = h(im,j)*dp(im,j) + fx(im,j)-fx(1,j)+(fy(im,j)-fy(im,j+1))*rgw(j) enddo ! Poles if ( jfirst == 1 ) then do i=1,im h(i,1) = h(i,1)*dp(i,1) - fy(i,2)*rgw(1) enddo call xpavg(h(1, 1), im) endif if ( jlast == jm ) then do i=1,im h(i,jm) = h(i,jm)*dp(i,jm) + fy(i,jm)*rgw(jm) enddo call xpavg(h(1,jm), im) endif !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Implement ND24 diag: E/W flux of tracer [kg/s] (bmy, bdf, 9/28/04) !%%% !%%% (1) H is in units of mixing ratio (input as Q) !%%% (2) Unit conversion needs multiply from mixing !%%% (airmass/tracer mass)/timestep to get into kg/s !%%% (3) DP is current pressure thickness !%%% IF ( ND24 > 0 ) THEN DO J = JS2G0, JN2G0 DO I = 1, IM-1 DTC = FX(I,J)*AREA_M2(J)*100.d0 / (TCV*DT*9.8d0) MFLEW(I,J) = MFLEW(I,J) + DTC ENDDO DTC = FX(IM,J)*AREA_M2(J)*100.d0 / (TCV*DT*9.8d0) MFLEW(IM,J) = MFLEW(I,J) + DTC ENDDO ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% MODIFICATION by Harvard Atmospheric Chemistry Modeling Group !%%% !%%% Implement ND25 diag: N/S flux of tracer [kg/s] (bdf, bmy, 9/28/04) !%%% Now multiply fluxes by latitude factor RGW_25 (bdf, bmy, 10/29/04) !%%% IF ( ND25 > 0 ) THEN DO J = JS2G0, JN2G0 DO I = 1, IM DTC = FY(I,J)*RGW_25(J)*AREA_M2(J)*100./ (TCV*DT*9.8) MFLNS(I,J) = MFLNS(I,J) + DTC ENDDO ENDDO ! South Pole IF ( JFIRST == 1 ) THEN DO I = 1, IM DTC = -FY(I,2)*RGW_25(1)*AREA_M2(1)*100./(TCV*DT*9.8) MFLNS(I,1) = MFLNS(I,1) + DTC ENDDO ENDIF ! North Pole IF ( JLAST == JM ) THEN DO I = 1, IM DTC = FY(I,JM)*RGW_25(JM)*AREA_M2(JM)*100./(TCV*DT*9.8) MFLNS(I,JM) = MFLNS(I,JM) + DTC ENDDO ENDIF ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !------------------------------------------------------------------- ! Apply a simple nearest neighbor flux correction to reduce negatives !------------------------------------------------------------------- if ( iv /= -1 ) then call fct_x(h, im, jm, jfirst, jlast, ng, i) endif do j=jfirst,jlast do i=1,im h(i,j) = h(i,j) / dpp(i,j) enddo enddo end subroutine tp2g subroutine tp2d(va, q, crx, cry, im, jm, iord, jord, ng, mg, fx, fy, & ffsl, xfx, yfx, id, jfirst, jlast) implicit none # include "define.h" ! !INPUT PARAMETERS: integer, intent(in):: im, jm ! Dimensions integer, intent(in):: jfirst, jlast ! Latitude strip integer iord, jord ! Interpolation order in x,y integer ng ! Max. NS dependencies integer mg ! integer id ! density (0) (mfx = C) ! mixing ratio (1) (mfx = mass flux) logical ffsl(jfirst-ng:jlast+ng) ! Use flux-form semi-Lagrangian trans.? ! ghosted N*ng S*ng real va(im,jfirst:jlast) ! Courant (unghosted) real q(im,jfirst-ng:jlast+ng) ! transported scalar ( N*NG S*NG ) real crx(im,jfirst-ng:jlast+ng) ! Ask S.-J. ( N*NG S*NG ) real cry(im,jfirst:jlast+mg) ! Ask S.-J. ( N like FY ) real xfx(im,jfirst:jlast) ! Ask S.-J. ( unghosted like FX ) real yfx(im,jfirst:jlast+mg) ! Ask S.-J. ( N like FY ) ! !OUTPUT PARAMETERS: real fx(im,jfirst:jlast) ! Flux in x ( unghosted ) real fy(im,jfirst:jlast+mg) ! Flux in y ( N, see tp2c ) ! Local: integer i, j, iad, jp, js2g0, js2gng, jn2g0, jn2gng real adx(im,jfirst-ng:jlast+ng) real wk1(im) real dm(-im/3:im+im/3) real qtmp(-im/3:im+im/3) real al(-im/3:im+im/3) real ar(-im/3:im+im/3) real a6(-im/3:im+im/3) ! Number of ghost latitudes js2g0 = max(2,jfirst) ! No ghosting jn2g0 = min(jm-1,jlast) ! No ghosting js2gng = max(2,jfirst-ng) ! Number needed on S jn2gng = min(jm-1,jlast+ng) ! Number needed on N iad = 1 do j=js2gng,jn2gng ! adx needed on N*ng S*ng call xtp(im, ffsl(j), wk1, q(1,j), & crx(1,j), iad, crx(1,j), cosp(j), 0, & dm, qtmp, al, ar, a6) do i=1,im-1 adx(i,j) = q(i,j) + 0.5 * & (wk1(i)-wk1(i+1) + q(i,j)*(crx(i+1,j)-crx(i,j))) enddo adx(im,j) = q(im,j) + 0.5 * & (wk1(im)-wk1(1) + q(im,j)*(crx(1,j)-crx(im,j))) enddo if ( jfirst == 1 ) then do i=1,im adx(i, 1) = q(i,1) enddo endif if ( jlast == jm ) then do i=1,im adx(i,jm) = q(i,jm) enddo endif call ytp(im,jm,fy, adx,cry,yfx,ng,mg,jord,0,jfirst,jlast) do j=js2g0,jn2g0 do i=1,im jp = j-va(i,j) #if defined( NESTED_NA ) !-------------------------------------------------------------------------- ! Error KLUDGE: the ghost regime can get screwed up in the buffer zone. ! Not sure why, but not a bid deal to skip as these get overwritten by BCs. ! (dkh, 01/15/13) IF ( jp+1 > 121 ) then print*, ' tpcore warning jp = ', jp print*, ' i = ', i, j print*, 'js2g0,jn2g0 = ', js2g0, jn2g0 jp = 120 ENDIF !-------------------------------------------------------------------------- #endif wk1(i) = q(i,j) +0.5*va(i,j)*(q(i,jp)-q(i,jp+1)) enddo call xtp(im, ffsl(j), fx(1,j), wk1, & crx(1,j), iord, xfx(1,j), cosp(j), id, & dm, qtmp, al, ar, a6) enddo end subroutine tp2d subroutine xtp(im, ffsl, fx, q, c, iord, mfx, & cosa, id, dm, qtmp, al, ar, a6) implicit none ! !INPUT PARAMETERS: integer id ! ID = 0: density (mfx = C) ! ID = 1: mixing ratio (mfx is mass flux) integer im ! Total longitudes real c(im) ! Courant numbers real q(im) real mfx(im) logical ffsl integer iord real cosa ! !INPUT/OUTPUT PARAMETERS: real qtmp(-im/3:im+im/3) ! Input work arrays: real dm(-im/3:im+im/3) real al(-im/3:im+im/3) real ar(-im/3:im+im/3) real a6(-im/3:im+im/3) ! !OUTPUT PARAMETERS: real fx(im) ! Local: real cos_upw !critical cosine for upwind real cos_van !critical cosine for van Leer real cos_ppm !critical cosine for ppm parameter (cos_upw = 0.05) !roughly at 87 deg. parameter (cos_van = 0.25) !roughly at 75 deg. parameter (cos_ppm = 0.25) integer i, imp real qmax, qmin real rut, tmp integer iu, itmp, ist integer isave(im) integer iuw, iue imp = im + 1 do i=1,im qtmp(i) = q(i) enddo if( ffsl ) then ! Figure out ghost zone for the western edge: iuw = -c(1) iuw = min(0, iuw) do i=iuw, 0 qtmp(i) = q(im+i) enddo ! Figure out ghost zone for the eastern edge: iue = im - c(im) iue = max(imp, iue) do i=imp, iue qtmp(i) = q(i-im) enddo if( iord == 1 .or. cosa < cos_upw) then do i=1,im iu = c(i) if(c(i) <= 0.) then itmp = i - iu isave(i) = itmp - 1 else itmp = i - iu - 1 isave(i) = itmp + 1 endif fx(i) = (c(i)-iu) * qtmp(itmp) enddo else do i=1,im ! 2nd order slope tmp = 0.25*(qtmp(i+1) - qtmp(i-1)) qmax = max(qtmp(i-1), qtmp(i), qtmp(i+1)) - qtmp(i) qmin = qtmp(i) - min(qtmp(i-1), qtmp(i), qtmp(i+1)) dm(i) = sign(min(abs(tmp),qmax,qmin), tmp) enddo do i=iuw, 0 dm(i) = dm(im+i) enddo do i=imp, iue dm(i) = dm(i-im) enddo if(iord >= 3 .and. cosa > cos_ppm) then call fxppm(im, c, mfx, qtmp, dm, fx, iord, al, ar, a6, & iuw, iue, ffsl, isave) else do i=1,im iu = c(i) rut = c(i) - iu if(c(i) .le. 0.) then itmp = i - iu isave(i) = itmp - 1 fx(i) = rut*(qtmp(itmp)-dm(itmp)*(1.+rut)) else itmp = i - iu - 1 isave(i) = itmp + 1 fx(i) = rut*(qtmp(itmp)+dm(itmp)*(1.-rut)) endif enddo endif endif do i=1,im if(c(i) >= 1.) then do ist = isave(i),i-1 fx(i) = fx(i) + qtmp(ist) enddo elseif(c(i) <= -1.) then do ist = i,isave(i) fx(i) = fx(i) - qtmp(ist) enddo endif enddo if(id .ne. 0) then do i=1,im fx(i) = fx(i)*mfx(i) enddo endif else ! Regular PPM (Eulerian without FFSL extension) qtmp(imp) = q(1) qtmp( 0) = q(im) if(iord == 1 .or. cosa < cos_upw) then do i=1,im iu = float(i) - c(i) fx(i) = mfx(i)*qtmp(iu) enddo else qtmp(-1) = q(im-1) qtmp(imp+1) = q(2) if(iord > 0 .or. cosa < cos_van) then call xmist(im, qtmp, dm, 2) else call xmist(im, qtmp, dm, iord) endif dm(0) = dm(im) if( abs(iord) ==2 .or. cosa < cos_van ) then do i=1,im iu = float(i) - c(i) fx(i) = mfx(i)*(qtmp(iu)+dm(iu)*(sign(1.,c(i))-c(i))) enddo else call fxppm(im, c, mfx, qtmp, dm, fx, iord, al, ar, a6, & iuw, iue, ffsl, isave) endif endif endif end subroutine xtp subroutine xmist(im, q, dm, id) implicit none ! !INPUT PARAMETERS: integer, intent(in):: im ! Total number of longitudes integer, intent(in):: id ! ID = 0: density (mfx = C) ! ID = 1: mixing ratio (mfx is mass flux) real, intent(in):: q(-im/3:im+im/3) ! scalar field ! !OUTPUT PARAMETERS: real, intent(out):: dm(-im/3:im+im/3) ! ! Local real r24 parameter( r24 = 1./24.) integer i real qmin, qmax if(id <= 2) then do i=1,im dm(i) = r24*(8.*(q(i+1) - q(i-1)) + q(i-2) - q(i+2)) enddo else do i=1,im dm(i) = 0.25*(q(i+1) - q(i-1)) enddo endif if( id < 0 ) return ! Apply monotonicity constraint (Lin et al. 1994, MWR) do i=1,im qmax = max( q(i-1), q(i), q(i+1) ) - q(i) qmin = q(i) - min( q(i-1), q(i), q(i+1) ) dm(i) = sign( min(abs(dm(i)), qmax, qmin), dm(i) ) enddo end subroutine xmist subroutine fxppm(im, c, mfx, p, dm, fx, iord, al, ar, a6, & iuw, iue, ffsl, isave) implicit none ! !INPUT PARAMETERS: integer, intent(in):: im, iord integer, intent(in):: iuw, iue logical, intent(in):: ffsl real, intent(in):: c(im) real, intent(in):: p(-im/3:im+im/3) real, intent(in):: dm(-im/3:im+im/3) real, intent(in):: mfx(im) ! !INPUT/OUTPUT PARAMETERS: integer, intent(inout):: isave(im) real, intent(out):: fx(im) real, intent(out):: al(-im/3:im+im/3) real, intent(out):: ar(-im/3:im+im/3) real, intent(out):: a6(-im/3:im+im/3) ! LOCAL VARIABLES: real r3, r23 parameter ( r3 = 1./3., r23 = 2./3. ) integer i, lmt integer iu, itmp real ru do i=1,im al(i) = 0.5*(p(i-1)+p(i)) + (dm(i-1) - dm(i))*r3 enddo do i=1,im-1 ar(i) = al(i+1) enddo ar(im) = al(1) if(iord == 7) then call huynh(im, ar(1), al(1), p(1), a6(1), dm(1)) else if(iord == 3 .or. iord == 5) then do i=1,im a6(i) = 3.*(p(i)+p(i) - (al(i)+ar(i))) enddo endif lmt = iord - 3 call lmppm( dm(1), a6(1), ar(1), al(1), p(1), im, lmt ) endif if( ffsl ) then do i=iuw, 0 al(i) = al(im+i) ar(i) = ar(im+i) a6(i) = a6(im+i) enddo do i=im+1, iue al(i) = al(i-im) ar(i) = ar(i-im) a6(i) = a6(i-im) enddo do i=1,im iu = c(i) ru = c(i) - iu if(c(i) > 0.) then itmp = i - iu - 1 isave(i) = itmp + 1 fx(i) = ru*(ar(itmp)+0.5*ru*(al(itmp)-ar(itmp) + & a6(itmp)*(1.-r23*ru)) ) else itmp = i - iu isave(i) = itmp - 1 fx(i) = ru*(al(itmp)-0.5*ru*(ar(itmp)-al(itmp) + & a6(itmp)*(1.+r23*ru)) ) endif enddo else al(0) = al(im) ar(0) = ar(im) a6(0) = a6(im) do i=1,im if(c(i) > 0.) then fx(i) = ar(i-1) + 0.5*c(i)*(al(i-1) - ar(i-1) + & a6(i-1)*(1.-r23*c(i)) ) else fx(i) = al(i) - 0.5*c(i)*(ar(i) - al(i) + & a6(i)*(1.+r23*c(i))) endif fx(i) = mfx(i) * fx(i) enddo endif end subroutine fxppm subroutine lmppm(dm, a6, ar, al, p, im, lmt) implicit none ! !INPUT PARAMETERS: integer, intent(in):: im ! Total longitudes integer, intent(in):: lmt ! LMT = 0: full monotonicity ! LMT = 1: Improved and simplified full monotonic constraint ! LMT = 2: positive-definite constraint ! LMT = 3: Quasi-monotone constraint real, intent(in):: p(im) real, intent(in):: dm(im) real, intent(inout):: a6(im) real, intent(inout):: ar(im) real, intent(inout):: al(im) ! !LOCAL VARIABLES: real r12 parameter ( r12 = 1./12. ) real da1, da2, fmin, a6da real dr, dl integer i ! LMT = 0: full monotonicity ! LMT = 1: Improved and simplified full monotonic constraint ! LMT = 2: positive-definite constraint ! LMT = 3: Quasi-monotone constraint if( lmt == 0 ) then ! Full constraint do i=1,im if(dm(i) == 0.) then ar(i) = p(i) al(i) = p(i) a6(i) = 0. else da1 = ar(i) - al(i) da2 = da1**2 a6da = a6(i)*da1 if(a6da < -da2) then a6(i) = 3.*(al(i)-p(i)) ar(i) = al(i) - a6(i) elseif(a6da > da2) then a6(i) = 3.*(ar(i)-p(i)) al(i) = ar(i) - a6(i) endif endif enddo elseif( lmt == 1 ) then ! Improved (Lin 200?) full constraint do i=1,im da1 = dm(i) + dm(i) dl = sign(min(abs(da1),abs(al(i)-p(i))), da1) dr = sign(min(abs(da1),abs(ar(i)-p(i))), da1) ar(i) = p(i) + dr al(i) = p(i) - dl a6(i) = 3.*(dl-dr) enddo elseif( lmt == 2 ) then ! Positive definite only constraint do 250 i=1,im if(abs(ar(i)-al(i)) .ge. -a6(i)) go to 250 fmin = p(i) + 0.25*(ar(i)-al(i))**2/a6(i) + a6(i)*r12 if(fmin.ge.0.) go to 250 if(p(i) < ar(i) .and. p(i) < al(i)) then ar(i) = p(i) al(i) = p(i) a6(i) = 0. elseif(ar(i) > al(i)) then a6(i) = 3.*(al(i)-p(i)) ar(i) = al(i) - a6(i) else a6(i) = 3.*(ar(i)-p(i)) al(i) = ar(i) - a6(i) endif 250 continue elseif(lmt == 3) then ! Quasi-monotone constraint do i=1,im da1 = 4.*dm(i) dl = sign(min(abs(da1),abs(al(i)-p(i))), da1) dr = sign(min(abs(da1),abs(ar(i)-p(i))), da1) ar(i) = p(i) + dr al(i) = p(i) - dl a6(i) = 3.*(dl-dr) enddo endif end subroutine lmppm subroutine huynh(im, ar, al, p, d2, d1) implicit none ! !INPUT PARAMETERS: integer im real p(im) ! !OUTPUT PARAMETERS: real ar(im) real al(im) real d2(im) real d1(im) ! !LOCAL VARIABLES: integer i real pmp real lac real pmin real pmax ! Compute d1 and d2 d1(1) = p(1) - p(im) do i=2,im d1(i) = p(i) - p(i-1) enddo do i=1,im-1 d2(i) = d1(i+1) - d1(i) enddo d2(im) = d1(1) - d1(im) ! Constraint for AR ! i = 1 pmp = p(1) + 2.0 * d1(1) lac = p(1) + 0.5 * (d1(1)+d2(im)) + d2(im) pmin = min(p(1), pmp, lac) pmax = max(p(1), pmp, lac) ar(1) = min(pmax, max(ar(1), pmin)) do i=2, im pmp = p(i) + 2.0*d1(i) lac = p(i) + 0.5*(d1(i)+d2(i-1)) + d2(i-1) pmin = min(p(i), pmp, lac) pmax = max(p(i), pmp, lac) ar(i) = min(pmax, max(ar(i), pmin)) enddo ! Constraint for AL do i=1, im-1 pmp = p(i) - 2.0*d1(i+1) lac = p(i) + 0.5*(d2(i+1)-d1(i+1)) + d2(i+1) pmin = min(p(i), pmp, lac) pmax = max(p(i), pmp, lac) al(i) = min(pmax, max(al(i), pmin)) enddo ! i=im i = im pmp = p(im) - 2.0*d1(1) lac = p(im) + 0.5*(d2(1)-d1(1)) + d2(1) pmin = min(p(im), pmp, lac) pmax = max(p(im), pmp, lac) al(im) = min(pmax, max(al(im), pmin)) ! compute A6 (d2) do i=1, im d2(i) = 3.*(p(i)+p(i) - (al(i)+ar(i))) enddo end subroutine huynh subroutine ytp(im, jm, fy, q, c, yfx, ng, mg, jord, iv, jfirst, jlast) implicit none # include "define.h" ! !INPUT PARAMETERS: integer im, jm ! Dimensions integer jfirst, jlast ! Latitude strip integer ng ! Max. NS dependencies integer mg ! integer jord ! order of subgrid dist integer iv ! Scalar=0, Vector=1 real q(im,jfirst-ng:jlast+ng) ! advected scalar N*jord S*jord real c(im,jfirst:jlast+mg) ! Courant N (like FY) real yfx(im,jfirst:jlast+mg) ! Backgrond mass flux ! !OUTPUT PARAMETERS: real fy(im,jfirst:jlast+mg) ! Flux N (see tp2c) ! !LOCAL VARIABLES: integer i, j, jt integer js2g0, jn1g1 ! work arrays (should pass in eventually for performance enhancement): real dm(im,jfirst-ng:jlast+ng) ! real ar(im,jfirst-1:jlast+1) ! AR needs to be ghosted on NS ! real al(im,jfirst-1:jlast+2) ! AL needs to be ghosted on N2S ! real a6(im,jfirst-1:jlast+1) ! A6 needs to be ghosted on NS js2g0 = max(2,jfirst) ! No ghosting jn1g1 = min(jm,jlast+1) ! Ghost N*1 if(jord == 1) then do j=js2g0,jn1g1 do i=1,im jt = float(j) - c(i,j) #if defined( NESTED_NA ) !-------------------------------------------------------------------------- ! Error KLUDGE: the ghost regime can get screwed up in the buffer zone. ! Not sure why, but not a bid deal to skip as these get overwritten by BCs. ! (dkh, 01/15/13) IF ( jt > 121 ) then print*, ' error: jt = ', jt print*, ' i = ', i, j print*, ' c = ', c(i,j) print*, 'js2g0,jn1g1 = ', js2g0,jn1g1 jt = 121 ENDIF !-------------------------------------------------------------------------- #endif fy(i,j) = q(i,jt) enddo enddo else ! ! YMIST requires q on NS; Only call to YMIST here ! call ymist(im, jm, q, dm, ng, jord, iv, jfirst, jlast) if( abs(jord) .ge. 3 ) then call fyppm(c,q,dm,fy,im,jm,ng,mg,jord,iv,jfirst,jlast) else ! ! JORD can either have the value 2 or -2 at this point ! do j=js2g0,jn1g1 do i=1,im jt = float(j) - c(i,j) fy(i,j) = q(i,jt) + (sign(1.,c(i,j))-c(i,j))*dm(i,jt) enddo enddo endif endif do j=js2g0,jn1g1 do i=1,im fy(i,j) = fy(i,j)*yfx(i,j) enddo enddo end subroutine ytp subroutine ymist(im, jm, q, dm, ng, jord, iv, jfirst, jlast) implicit none ! !INPUT PARAMETERS: integer im, jm ! Dimensions integer jfirst, jlast ! Latitude strip integer ng ! NS dependencies integer jord ! order of subgrid distribution integer iv ! Scalar (==0) Vector (==1) real q(im,jfirst-ng:jlast+ng) ! transported scalar N*ng S*ng ! !OUTPUT PARAMETERS: real dm(im,jfirst-ng:jlast+ng) ! Slope only N*(ng-1) S*(ng-1) used ! Local variables integer i, j, jm1, im2, js2gng1, jn2gng1 real qmax, qmin, tmp js2gng1 = max(2, jfirst-ng+1) ! Number needed on S jn2gng1 = min(jm-1,jlast+ng-1) ! Number needed on N jm1 = jm - 1 im2 = im / 2 do j=js2gng1,jn2gng1 do i=1,im dm(i,j) = 0.25*(q(i,j+1) - q(i,j-1)) enddo enddo if( iv == 0 ) then if ( jfirst == 1 ) then ! S pole do i=1,im2 tmp = 0.25*(q(i,2)-q(i+im2,2)) qmax = max(q(i,2),q(i,1), q(i+im2,2)) - q(i,1) qmin = q(i,1) - min(q(i,2),q(i,1), q(i+im2,2)) dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp) enddo do i=im2+1,im dm(i, 1) = - dm(i-im2, 1) enddo endif if ( jlast == jm ) then ! N pole do i=1,im2 tmp = 0.25*(q(i+im2,jm1)-q(i,jm1)) qmax = max(q(i+im2,jm1),q(i,jm), q(i,jm1)) - q(i,jm) qmin = q(i,jm) - min(q(i+im2,jm1),q(i,jm), q(i,jm1)) dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp) enddo do i=im2+1,im dm(i,jm) = - dm(i-im2,jm) enddo endif else if ( jfirst == 1 ) then ! South do i=1,im2 tmp = 0.25*(q(i,2)+q(i+im2,2)) qmax = max(q(i,2),q(i,1), -q(i+im2,2)) - q(i,1) qmin = q(i,1) - min(q(i,2),q(i,1),-q(i+im2,2)) dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp) enddo do i=im2+1,im dm(i, 1) = dm(i-im2, 1) enddo endif if ( jlast == jm ) then ! North do i=1,im2 tmp = -0.25*(q(i+im2,jm1)+q(i,jm1)) qmax = max(-q(i+im2,jm1),q(i,jm), q(i,jm1)) - q(i,jm) qmin = q(i,jm) - min(-q(i+im2,jm1),q(i,jm), q(i,jm1)) dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp) enddo do i=im2+1,im dm(i,jm) = dm(i-im2,jm) enddo endif endif if( jord > 0 ) then ! ! Applies monotonic slope constraint (off if jord less than zero) ! do j=js2gng1,jn2gng1 do i=1,im qmax = max(q(i,j-1),q(i,j),q(i,j+1)) - q(i,j) qmin = q(i,j) - min(q(i,j-1),q(i,j),q(i,j+1)) dm(i,j) = sign(min(abs(dm(i,j)),qmin,qmax),dm(i,j)) enddo enddo endif end subroutine ymist subroutine fyppm(c, q, dm, flux, im, jm, ng,mg, jord, iv, jfirst, jlast) implicit none ! !INPUT PARAMETERS: integer im, jm ! Dimensions integer jfirst, jlast ! Latitude strip integer ng ! Max. NS dependencies integer mg ! integer jord ! Approximation order integer iv ! Scalar=0, Vector=1 real q(im,jfirst-ng:jlast+ng) ! mean value needed only N*2 S*2 real dm(im,jfirst-ng:jlast+ng) ! Slope needed only N*2 S*2 real c(im,jfirst:jlast+mg) ! Courant N (like FLUX) ! !INPUT/OUTPUT PARAMETERS: real ar(im,jfirst-1:jlast+1) ! AR needs to be ghosted on NS real al(im,jfirst-1:jlast+2) ! AL needs to be ghosted on N2S real a6(im,jfirst-1:jlast+1) ! A6 needs to be ghosted on NS ! !OUTPUT PARAMETERS: real flux(im,jfirst:jlast+mg) ! Flux N (see tp2c) ! Local real r3, r23 parameter ( r3 = 1./3., r23 = 2./3. ) integer i, j, imh, jm1, lmt integer js1g1, js2g0, js2g1, jn1g2, jn1g1, jn2g1 imh = im / 2 jm1 = jm - 1 js1g1 = max(1,jfirst-1) ! Ghost S*1 js2g0 = max(2,jfirst) ! No ghosting js2g1 = max(2,jfirst-1) ! Ghost S*1 jn1g1 = min(jm,jlast+1) ! Ghost N*1 jn1g2 = min(jm,jlast+2) ! Ghost N*2 jn2g1 = min(jm-1,jlast+1) ! Ghost N*1 do j=js2g1,jn1g2 ! AL needed N2S do i=1,im ! P, dm ghosted N2S2 (at least) al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j)) enddo enddo do j=js1g1,jn2g1 ! AR needed NS do i=1,im ar(i,j) = al(i,j+1) ! AL ghosted N2S enddo enddo ! Poles: if( iv == 0 ) then if ( jfirst .eq. 1 ) then do i=1,imh al(i, 1) = al(i+imh,2) al(i+imh,1) = al(i, 2) enddo endif if ( jlast .eq. jm ) then do i=1,imh ar(i, jm) = ar(i+imh,jm1) ar(i+imh,jm) = ar(i, jm1) enddo endif else if ( jfirst .eq. 1 ) then do i=1,imh al(i, 1) = -al(i+imh,2) al(i+imh,1) = -al(i, 2) enddo endif if ( jlast .eq. jm ) then do i=1,imh ar(i, jm) = -ar(i+imh,jm1) ar(i+imh,jm) = -ar(i, jm1) enddo endif endif if( jord == 3 .or. jord == 5 ) then do j=js1g1,jn1g1 ! A6 needed NS do i=1,im a6(i,j) = 3.*(q(i,j)+q(i,j) - (al(i,j)+ar(i,j))) enddo enddo endif lmt = jord - 3 call lmppm(dm(1,js1g1), a6(1,js1g1), ar(1,js1g1), & al(1,js1g1), q(1,js1g1), im*(jn1g1-js1g1+1), lmt) do j=js2g0,jn1g1 ! flux needed N do i=1,im if(c(i,j) > 0.) then flux(i,j) = ar(i,j-1) + 0.5*c(i,j)*(al(i,j-1) - ar(i,j-1) + & a6(i,j-1)*(1.-r23*c(i,j)) ) else flux(i,j) = al(i,j) - 0.5*c(i,j)*(ar(i,j) - al(i,j) + & a6(i,j)*(1.+r23*c(i,j))) endif enddo enddo end subroutine fyppm subroutine xpavg(p, im) implicit none ! !INPUT PARAMETERS: integer im ! !INPUT/OUTPUT PARAMETERS: real p(im) integer i real sum1 sum1 = 0. do i=1,im sum1 = sum1 + p(i) enddo sum1 = sum1 / im do i=1,im p(i) = sum1 enddo end subroutine xpavg subroutine qmap(pe, q, im, jm, km, nx, jfirst, jlast, ng, nq, & ps, ak, bk, kord, iv) implicit none !INPUT integer im, jm, km ! x, y, z dimensions integer nq ! number of tracers integer nx ! number of SMP "decomposition" in x integer iv ! monotonicity at top and bottom ! iv=0 : weak constraint ! iv=1 : strong constraint ! iv=-1: for vector integer jfirst, jlast ! starting & ending latitude index integer ng ! width of ghost regions real, intent(in):: ak(km+1) real, intent(in):: bk(km+1) real, intent(in):: pe(im,km+1,jfirst:jlast) ! INPUT/OUTPUT real q(im,jfirst-ng:jlast+ng,km,nq) ! tracers including specific humidity real ps(im,jfirst:jlast) ! surface pressure ! Local arrays: real pe2(im,km+1) real temp integer i, j, k, iq integer ixj, jp, it, i1, i2 integer kord it = im / nx jp = nx * ( jlast - jfirst + 1 ) !$omp parallel do & !$omp shared(im,km,jfirst,jlast,ng,iv,kord) & !$omp private(i, j, k, iq, i1, i2, ixj, pe2) ! do 2000 j=jfirst,jlast do 2000 ixj=1,jp j = jfirst + (ixj-1) / nx i1 = 1 + it * mod(ixj-1, nx) i2 = i1 + it - 1 ! k=1 do i=i1,i2 pe2(i,1) = ak(1) enddo do k=2,km do i=i1,i2 pe2(i,k) = ak(k) + bk(k)*ps(i,j) enddo enddo ! k=km+1 do i=i1,i2 pe2(i,km+1) = ps(i,j) enddo temp = sum(q) do iq=1,nq call map1_ppm ( km, pe(1,1,j), q(1,jfirst-ng,1,iq), & km, pe2, q(1,jfirst-ng,1,iq), & im, i1, i2, j, jfirst, jlast, ng, iv, kord) enddo 2000 continue end subroutine qmap subroutine map1_ppm( km, pe1, q1, & kn, pe2, q2, & im, i1, i2, j, jfirst, jlast, ng, iv, kord) implicit none !INPUT PARAMETERS: integer i1 ! Starting longitude integer i2 ! Finishing longitude integer im ! E-W dimension integer iv ! Mode: 0 == constituents 1 == ??? integer kord ! Method order integer j ! Current latitude integer jfirst ! Starting latitude integer jlast ! Finishing latitude integer ng ! Width of ghost regions integer km ! Original vertical dimension integer kn ! Target vertical dimension real pe1(im,km+1) ! pressure at layer edges ! (from model top to bottom surface) ! in the original vertical coordinate real pe2(im,kn+1) ! pressure at layer edges ! (from model top to bottom surface) ! in the new vertical coordinate real q1(im,jfirst-ng:jlast+ng,km) ! Field input !OUTPUT PARAMETERS: real q2(im,jfirst-ng:jlast+ng,kn) ! Field output ! LOCAL VARIABLES: real dp1(i1:i2,km) real q4(4,i1:i2,km) integer i, k, l, ll, k0 real pl, pr, qsum, delp, esl real r3, r23 real temp parameter (r3 = 1./3., r23 = 2./3.) do k=1,km do i=i1,i2 dp1(i,k) = pe1(i,k+1) - pe1(i,k) q4(1,i,k) = q1(i,j,k) enddo enddo temp = sum(q4) ! Compute vertical subgrid distribution call ppm2m( q4, dp1, km, i1, i2, iv, kord ) temp = sum(q2) ! Mapping do 1000 i=i1,i2 k0 = 1 do 555 k=1,kn do 100 l=k0,km ! locate the top edge: pe2(i,k) if(pe2(i,k) .ge. pe1(i,l) .and. pe2(i,k) .le. pe1(i,l+1)) then pl = (pe2(i,k)-pe1(i,l)) / dp1(i,l) if(pe2(i,k+1) .le. pe1(i,l+1)) then ! entire new grid is within the original grid pr = (pe2(i,k+1)-pe1(i,l)) / dp1(i,l) q2(i,j,k) = q4(2,i,l) + 0.5*(q4(4,i,l)+q4(3,i,l)-q4(2,i,l)) & *(pr+pl)-q4(4,i,l)*r3*(pr*(pr+pl)+pl**2) k0 = l goto 555 else ! Fractional area... qsum = (pe1(i,l+1)-pe2(i,k))*(q4(2,i,l)+0.5*(q4(4,i,l)+ & q4(3,i,l)-q4(2,i,l))*(1.+pl)-q4(4,i,l)* & (r3*(1.+pl*(1.+pl)))) do ll=l+1,km ! locate the bottom edge: pe2(i,k+1) if(pe2(i,k+1) > pe1(i,ll+1) ) then ! Whole layer.. qsum = qsum + dp1(i,ll)*q4(1,i,ll) else delp = pe2(i,k+1)-pe1(i,ll) esl = delp / dp1(i,ll) qsum = qsum + delp*(q4(2,i,ll)+0.5*esl* & (q4(3,i,ll)-q4(2,i,ll)+q4(4,i,ll)*(1.-r23*esl))) k0 = ll goto 123 endif enddo goto 123 endif endif 100 continue 123 q2(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) 555 continue 1000 continue end subroutine map1_ppm subroutine ppm2m(a4, delp, km, i1, i2, iv, kord) implicit none ! INPUT PARAMETERS: integer, intent(in):: iv ! iv =-1: winds ! iv = 0: positive definite scalars ! iv = 1: others integer, intent(in):: i1 ! Starting longitude integer, intent(in):: i2 ! Finishing longitude integer, intent(in):: km ! vertical dimension integer, intent(in):: kord ! Order (or more accurately method no.): ! real, intent(in):: delp(i1:i2,km) ! layer pressure thickness real, intent(inout):: a4(4,i1:i2,km) ! Interpolated values ! local arrays. real dc(i1:i2,km) real h2(i1:i2,km) real delq(i1:i2,km) real df2(i1:i2,km) real d4(i1:i2,km) real fac real a1, a2, c1, c2, c3, d1, d2 real qmax, qmin, cmax, cmin real qm, dq, tmp real qmp, pmp real lac integer lmt integer i, k, km1 integer it km1 = km - 1 it = i2 - i1 + 1 do k=2,km do i=i1,i2 delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) d4(i,k ) = delp(i,k-1) + delp(i,k) enddo enddo do k=2,km1 do i=i1,i2 c1 = (delp(i,k-1)+0.5*delp(i,k))/d4(i,k+1) c2 = (delp(i,k+1)+0.5*delp(i,k))/d4(i,k) tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & (d4(i,k)+delp(i,k+1)) qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) df2(i,k) = tmp enddo enddo !------------------------------------------------------------ ! 4th order interpolation of the provisional cell edge value !------------------------------------------------------------ do k=3,km1 do i=i1,i2 c1 = delq(i,k-1)*delp(i,k-1) / d4(i,k) a1 = d4(i,k-1) / (d4(i,k) + delp(i,k-1)) a2 = d4(i,k+1) / (d4(i,k) + delp(i,k)) a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(d4(i,k-1)+d4(i,k+1)) * & ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & delp(i,k-1)*a1*dc(i,k ) ) enddo enddo if(kord>3) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4) ! Area preserving cubic with 2nd deriv. = 0 at the boundaries ! Top do i=i1,i2 d1 = delp(i,1) d2 = delp(i,2) qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) c1 = (a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) a4(2,i,2) = qm - c1*d1*d2*(d2+3.*d1) a4(2,i,1) = d1*(8.*c1*d1**2-c3) + a4(2,i,2) dc(i,1) = a4(1,i,1) - a4(2,i,1) ! No over- and undershoot condition cmax = max(a4(1,i,1), a4(1,i,2)) cmin = min(a4(1,i,1), a4(1,i,2)) a4(2,i,2) = max(cmin,a4(2,i,2)) a4(2,i,2) = min(cmax,a4(2,i,2)) enddo if( iv == 0 ) then do i=i1,i2 a4(2,i,1) = max(0.,a4(2,i,1)) enddo elseif ( iv == 1 ) then ! Monotone tracers: do i=i1,i2 dc(i,1) = 0. a4(2,i,1) = a4(1,i,1) a4(2,i,2) = a4(1,i,1) enddo elseif ( iv == -1 ) then ! Winds: do i=i1,i2 if( a4(1,i,1)*a4(2,i,1) <= 0. ) then a4(2,i,1) = 0. else a4(2,i,1) = sign(min(abs(a4(1,i,1)), & abs(a4(2,i,1))), & a4(1,i,1) ) endif enddo endif ! Bottom ! Area preserving cubic with 2nd deriv. = 0 at the surface do i=i1,i2 d1 = delp(i,km) d2 = delp(i,km1) qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) dc(i,km) = a4(3,i,km) - a4(1,i,km) ! No over- and under-shoot condition cmax = max(a4(1,i,km), a4(1,i,km1)) cmin = min(a4(1,i,km), a4(1,i,km1)) a4(2,i,km) = max(cmin,a4(2,i,km)) a4(2,i,km) = min(cmax,a4(2,i,km)) enddo ! Enforce constraint at the surface if ( iv == 0 ) then ! Positive definite scalars: do i=i1,i2 a4(3,i,km) = max(0., a4(3,i,km)) enddo elseif ( iv == 1 ) then ! Monotone tracers: do i=i1,i2 dc(i,km) = 0. a4(2,i,km) = a4(1,i,km) a4(3,i,km) = a4(1,i,km) enddo elseif ( iv == -1 ) then ! Winds: do i=i1,i2 if( a4(1,i,km)*a4(3,i,km) <= 0. ) then a4(3,i,km) = 0. else a4(3,i,km) = sign( min(abs(a4(1,i,km)), & abs(a4(3,i,km))), & a4(1,i,km) ) endif enddo endif do k=1,km1 do i=i1,i2 a4(3,i,k) = a4(2,i,k+1) enddo enddo ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) ! Top 2 and bottom 2 layers always use monotonic mapping do k=1,2 do i=i1,i2 a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) enddo call kmppm(dc(i1,k), a4(1,i1,k), it, 0) enddo if(kord .ge. 7) then !---------------------------------------- ! Huynh's 2nd constraint !---------------------------------------- do k=2, km1 do i=i1,i2 ! Method#1 ! h2(i,k) = delq(i,k) - delq(i,k-1) ! Method#2 ! h2(i,k) = 2.*(dc(i,k+1)/delp(i,k+1) - dc(i,k-1)/delp(i,k-1)) ! & / ( delp(i,k)+0.5*(delp(i,k-1)+delp(i,k+1)) ) ! & * delp(i,k)**2 ! Method#3 h2(i,k) = dc(i,k+1) - dc(i,k-1) enddo enddo if( kord == 7 ) then fac = 1.5 ! original quasi-monotone else fac = 0.125 ! full monotone endif do k=3, km-2 do i=i1,i2 ! Right edges ! qmp = a4(1,i,k) + 2.0*delq(i,k-1) ! lac = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1) ! pmp = 2.*dc(i,k) qmp = a4(1,i,k) + pmp lac = a4(1,i,k) + fac*h2(i,k-1) + dc(i,k) qmin = min(a4(1,i,k), qmp, lac) qmax = max(a4(1,i,k), qmp, lac) a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) ! Left edges ! qmp = a4(1,i,k) - 2.0*delq(i,k) ! lac = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k) ! qmp = a4(1,i,k) - pmp lac = a4(1,i,k) + fac*h2(i,k+1) - dc(i,k) qmin = min(a4(1,i,k), qmp, lac) qmax = max(a4(1,i,k), qmp, lac) a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) ! Recompute A6 a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) enddo ! Additional constraint to prevent negatives when kord=7 if (iv /= -1 .and. kord == 7) then call kmppm(dc(i1,k), a4(1,i1,k), it, 2) endif enddo else lmt = kord - 3 lmt = max(0, lmt) if (iv == 0) lmt = min(2, lmt) do k=3, km-2 if( kord .ne. 4) then do i=i1,i2 a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) enddo endif call kmppm(dc(i1,k), a4(1,i1,k), it, lmt) enddo endif do k=km1,km do i=i1,i2 a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) enddo call kmppm(dc(i1,k), a4(1,i1,k), it, 0) enddo end subroutine ppm2m subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4) implicit none !INPUT PARAMETERS: integer km ! Total levels integer i1 ! Starting longitude integer i2 ! Finishing longitude real dp(i1:i2,km) ! grid size real dq(i1:i2,km) ! backward diff of q real d4(i1:i2,km) ! backward sum: dp(k)+ dp(k-1) real df2(i1:i2,km) ! first guess mismatch real dm(i1:i2,km) ! monotonic mismatch ! !INPUT/OUTPUT PARAMETERS: real a4(4,i1:i2,km) ! first guess/steepened ! !LOCAL VARIABLES: integer i, k real alfa(i1:i2,km) real f(i1:i2,km) real rat(i1:i2,km) real dg2 ! Compute ratio of dq/dp do k=2,km do i=i1,i2 rat(i,k) = dq(i,k-1) / d4(i,k) enddo enddo ! Compute F do k=2,km-1 do i=i1,i2 f(i,k) = (rat(i,k+1) - rat(i,k)) & / ( dp(i,k-1)+dp(i,k)+dp(i,k+1) ) enddo enddo do k=3,km-2 do i=i1,i2 if(f(i,k+1)*f(i,k-1) < 0. .and. df2(i,k).ne.0.) then dg2 = (f(i,k+1)-f(i,k-1))*((dp(i,k+1)-dp(i,k-1))**2 & + d4(i,k)*d4(i,k+1) ) alfa(i,k) = max(0., min(0.5, -0.1875*dg2/df2(i,k))) else alfa(i,k) = 0. endif enddo enddo do k=4,km-2 do i=i1,i2 a4(2,i,k) = (1.-alfa(i,k-1)-alfa(i,k)) * a4(2,i,k) + & alfa(i,k-1)*(a4(1,i,k)-dm(i,k)) + & alfa(i,k)*(a4(1,i,k-1)+dm(i,k-1)) enddo enddo end subroutine steepz subroutine kmppm(dm, a4, itot, lmt) implicit none ! !INPUT PARAMETERS: real dm(*) ! ?????? integer itot ! Total Longitudes integer lmt ! 0: Standard PPM constraint ! 1: Improved full monotonicity constraint (Lin) ! 2: Positive definite constraint ! 3: do nothing (return immediately) ! !INPUT/OUTPUT PARAMETERS: real a4(4,*) ! AA <-- a4(1,i) ! AL <-- a4(2,i) ! AR <-- a4(3,i) ! A6 <-- a4(4,i) ! !LOCAL VARIABLES: real r12 parameter (r12 = 1./12.) real qmp integer i real da1, da2, a6da real fmin if ( lmt == 3 ) return if(lmt == 0) then ! Standard PPM constraint do i=1,itot if(dm(i) .eq. 0.) then a4(2,i) = a4(1,i) a4(3,i) = a4(1,i) a4(4,i) = 0. else da1 = a4(3,i) - a4(2,i) da2 = da1**2 a6da = a4(4,i)*da1 if(a6da < -da2) then a4(4,i) = 3.*(a4(2,i)-a4(1,i)) a4(3,i) = a4(2,i) - a4(4,i) elseif(a6da > da2) then a4(4,i) = 3.*(a4(3,i)-a4(1,i)) a4(2,i) = a4(3,i) - a4(4,i) endif endif enddo elseif (lmt == 1) then ! Improved full monotonicity constraint (Lin) ! Note: no need to provide first guess of A6 <-- a4(4,i) do i=1, itot qmp = 2.*dm(i) a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) enddo elseif (lmt == 2) then ! Positive definite constraint do i=1,itot if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 if( fmin < 0. ) then if(a4(1,i) < a4(3,i) .and. a4(1,i) < a4(2,i)) then a4(3,i) = a4(1,i) a4(2,i) = a4(1,i) a4(4,i) = 0. elseif(a4(3,i) > a4(2,i)) then a4(4,i) = 3.*(a4(2,i)-a4(1,i)) a4(3,i) = a4(2,i) - a4(4,i) else a4(4,i) = 3.*(a4(3,i)-a4(1,i)) a4(2,i) = a4(3,i) - a4(4,i) endif endif endif enddo endif end subroutine kmppm subroutine fct_x(q, im, jm, jfirst, jlast, ng, ipx) implicit none ! !INPUT PARAMETERS: integer im ! Longitudes integer jm ! Total latitudes integer jfirst ! Starting latitude integer jlast ! Finishing latitude integer ng real tiny ! A small number to pump up value parameter (tiny = 1.e-40) ! !INPUT/OUTPUT PARAMETERS: real q(im,jfirst-ng:jlast+ng) ! Field to adjust ! !OUTPUT PARAMETERS: integer ipx ! Flag: 0 if Q not change, 1 if changed ! !LOCAL VARIABLES: real d0, d1, d2 real qtmp(jfirst:jlast,im) integer i, j, jm1, ip2 integer j1, j2 j1 = max( jfirst, 2 ) j2 = min( jlast, jm-1 ) jm1 = jm-1 ipx = 0 ! Copy & swap direction for vectorization. do i=1,im do j=j1,j2 qtmp(j,i) = q(i,j) enddo enddo do i=2,im-1 do j=j1,j2 if(qtmp(j,i) < 0.) then ipx = 1 ! west d0 = max(0.,qtmp(j,i-1)) d1 = min(-qtmp(j,i),d0) qtmp(j,i-1) = qtmp(j,i-1) - d1 qtmp(j,i) = qtmp(j,i) + d1 ! east d0 = max(0.,qtmp(j,i+1)) d2 = min(-qtmp(j,i),d0) qtmp(j,i+1) = qtmp(j,i+1) - d2 qtmp(j,i) = qtmp(j,i) + d2 + tiny endif enddo enddo i=1 do j=j1,j2 if(qtmp(j,i) < 0.) then ipx = 1 ! west d0 = max(0.,qtmp(j,im)) d1 = min(-qtmp(j,i),d0) qtmp(j,im) = qtmp(j,im) - d1 qtmp(j,i) = qtmp(j,i) + d1 ! east d0 = max(0.,qtmp(j,i+1)) d2 = min(-qtmp(j,i),d0) qtmp(j,i+1) = qtmp(j,i+1) - d2 qtmp(j,i) = qtmp(j,i) + d2 + tiny endif enddo i=im do j=j1,j2 if(qtmp(j,i) < 0.) then ipx = 1 ! west d0 = max(0.,qtmp(j,i-1)) d1 = min(-qtmp(j,i),d0) qtmp(j,i-1) = qtmp(j,i-1) - d1 qtmp(j,i) = qtmp(j,i) + d1 ! east d0 = max(0.,qtmp(j,1)) d2 = min(-qtmp(j,i),d0) qtmp(j,1) = qtmp(j,1) - d2 qtmp(j,i) = qtmp(j,i) + d2 + tiny endif enddo if(ipx .ne. 0) then !----------- ! Final pass !----------- do i=1,im-1 do j=j1,j2 if (qtmp(j,i) < 0. ) then ! Take mass from east (essentially adjusting fx(i+1,j)) qtmp(j,i+1) = qtmp(j,i+1) + qtmp(j,i) qtmp(j,i) = 0. endif enddo enddo ! Final sweep do i=im,2,-1 do j=j1,j2 if (qtmp(j,i) < 0. ) then ! Take mass from west (essentially adjusting fx(i,j)) qtmp(j,i-1) = qtmp(j,i-1) + qtmp(j,i) qtmp(j,i) = 0. endif enddo ! Note: qtmp(j,1) could still be negative enddo do j=j1,j2 do i=1,im q(i,j) = qtmp(j,i) q(i,j) = max(0., qtmp(j,i)) !(dan 0803) enddo enddo endif ! Check Poles. if ( jfirst == 1 ) then ip2 = 0 ! SP if(q(1,1) < 0.) then call pfix(q(1,2),q(1,1),im,ipx) else ! Check j=2 do i=1,im if(q(i,2) < 0.) then ip2 = 1 go to 322 endif enddo 322 continue if(ip2.ne.0) call pfix(q(1,2),q(1,1),im,ipx) endif endif if ( jlast == jm ) then ip2 = 0 ! NP if(q(1,jm) < 0.) then call pfix(q(1,jm1),q(1,jm),im,ipx) else ! Check j=jm1 do i=1,im if(q(i,jm1) < 0.) then ip2 = 1 go to 323 endif enddo 323 continue if(ip2.ne.0) call pfix(q(1,jm1),q(1,jm),im,ipx) endif endif end subroutine fct_x subroutine fillz(im, i1, i2, km, nq, q, dp) implicit none ! !INPUT PARAMETERS: integer, intent(in) :: im ! No. of longitudes integer, intent(in) :: km ! No. of levels integer, intent(in) :: i1 ! Starting longitude integer, intent(in) :: i2 ! Finishing longitude integer, intent(in) :: nq ! Total number of tracers real, intent(in) :: dp(im,km) ! pressure thickness ! !INPUT/OUTPUT PARAMETERS: real, intent(inout) :: q(im,km,nq) ! tracer mixing ratio ! !LOCAL VARIABLES: integer i, k, ic real qup, qly, dup do ic=1,nq ! Top layer do i=i1,i2 if( q(i,1,ic) < 0.) then q(i,2,ic) = q(i,2,ic) + q(i,1,ic)*dp(i,1)/dp(i,2) q(i,1,ic) = 0. endif enddo ! Interior do k=2,km-1 do i=i1,i2 if( q(i,k,ic) < 0. ) then ! Borrow from above qup = q(i,k-1,ic)*dp(i,k-1) qly = -q(i,k ,ic)*dp(i,k ) dup = min( 0.5*qly, qup ) !borrow no more than 50% q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1) ! Borrow from below: q(i,k,ic) is still negative at this stage q(i,k+1,ic) = q(i,k+1,ic) + (dup-qly)/dp(i,k+1) q(i,k ,ic) = 0. endif enddo enddo ! Bottom layer k = km do i=i1,i2 if( q(i,k,ic) < 0.) then ! Borrow from above qup = q(i,k-1,ic)*dp(i,k-1) qly = -q(i,k ,ic)*dp(i,k ) dup = min( qly, qup ) q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1) q(i,k,ic) = 0. endif enddo enddo end subroutine fillz subroutine pfix(q, qp, im, ipx) implicit none ! !INPUT PARAMETERS: integer im ! Longitudes ! !INPUT/OUTPUT PARAMETERS: real q(im) ! Latitude-level field to adjust real qp(im) ! Second latitude-level field to adjust (usually pole) ! !OUTPUT PARAMETERS: integer ipx ! Flag: 0 if Q not change, 1 if changed ! !LOCAL VARIABLES: integer i real summ, sump, pmean summ = 0. sump = 0. do i=1,im summ = summ + q(i) sump = sump + qp(i) enddo pmean = (sump*gw(1) + summ*gw(2)) / (im*(gw(1)+gw(2))) do i=1,im q(i) = pmean qp(i) = pmean enddo if( qp(1) < 0. ) ipx = 1 end subroutine pfix subroutine gmean(im, jm, jfirst, jlast, q, qmean) #if defined(SPMD) #if defined(PILGRIM) use parutilitiesmodule, only : parcollective, commglobal, sumop #else use mod_comm, only: mp_allgather1d, gid #endif #endif implicit none #if defined(SPMD) real gsum(jm) #endif integer im, jm ! Horizontal dimensions integer jfirst, jlast ! Latitude strip real, intent(in):: q(im,jfirst:jlast) ! 2D field real qmean real xsum(jfirst:jlast) integer i, j integer ierror do j=jfirst,jlast xsum(j) = 0. do i=1,im xsum(j) = xsum(j) + q(i,j) enddo xsum(j) = xsum(j)*gw(j) enddo #if defined(SPMD) gsum = 0. #if defined(PILGRIM) do j=jfirst,jlast gsum(j) = xsum(j) enddo call parcollective(commglobal, sumop, jm, gsum) #else call mp_allgather1d(jm, jfirst, jlast, xsum(jfirst), gsum) #endif if (gid == 0 ) then qmean = 0.0 do j=1,jm qmean = qmean + gsum(j) enddo qmean = qmean / (2*im) endif #else qmean = 0.0 do j=1,jm qmean = qmean + xsum(j) enddo qmean = qmean / (2*im) #endif end subroutine gmean subroutine adj_fx(im, jm, km, jfirst, jlast, ak, bk, ffsl, & ps0, ps2, pe, delp, fx3, cx, fy3, ng, & mg, tiny, n_adj) implicit none integer, intent(in):: im integer, intent(in):: jm integer, intent(in):: km integer, intent(in):: ng, mg integer, intent(in):: jfirst, jlast integer, intent(in):: n_adj real, intent(in):: tiny real, intent(in):: ak(km+1) real, intent(in):: bk(km+1) real, intent(in):: ps2(im,jfirst-mg:jlast+mg) real, intent(in):: cx(im,jfirst-ng:jlast+ng,km) real, intent(inout):: pe(im,km+1,jfirst:jlast) logical, intent(in):: ffsl(jfirst-ng:jlast+ng,km) real, intent(inout):: ps0(im,jfirst:jlast) real, intent(inout):: fx3(im,jfirst:jlast,km) real, intent(inout):: fy3(im,jfirst:jlast+mg,km) real, intent(inout):: delp(im,jfirst:jlast,km) ! Local real ps(im,jfirst-mg:jlast+mg) real fy(im,jfirst:jlast+mg) real fx(im+1) real dps(0:im) real dpy(im,jfirst-mg:jlast+mg) real er0, er1 integer i,j,k, it real tmpf, dh real dbk integer js2g0, jn2g0 real fac parameter ( fac = 0.25 ) js2g0 = max(2,jfirst) ! No ghosting jn2g0 = min(jm-1,jlast) ! No ghosting do j=jfirst,jlast do i=1,im ps(i,j) = ps0(i,j) enddo enddo fx_iteration: do it=1,n_adj #if defined(SPMD) #if defined(PILGRIM) call parbegintransfer(pattern2dmg, ps, ps) call parendtransfer(pattern2dmg, ps, ps) #else call mp_send3d_ns(im, jm, jfirst, jlast, 1, 1, mg, mg, ps, 2) call mp_barrier() call mp_recv3d_ns(im, jm, jfirst, jlast, 1, 1, mg, mg, ps, 2) call mp_barrier() #endif #endif !$omp parallel do & !$omp shared(im) & !$omp private(i, j, k, dbk, dps, dpy, tmpf, fx, fy) !--- adjust fx ---- do k=3,km dbk = bk(k+1) - bk(k) if( dbk > 0.001 ) then do j=js2g0,jn2g0 do i=1,im dps(i) = (ps(i,j) - ps2(i,j))*dbk enddo dps(0) = dps(im) do i=1,im fx(i) = fac*(dps(i-1)-dps(i)) tmpf = fx3(i,j,k) + fx(i) if ( tmpf*fx3(i,j,k) > 0. ) then fx3(i,j,k) = tmpf else fx(i) = fx3(i,j,k) fx3(i,j,k) = sign(min(abs(tmpf), abs(fx3(i,j,k))), fx3(i,j,k)) fx(i) = fx3(i,j,k) - fx(i) endif enddo fx(im+1) = fx(1) ! update delp do i=1,im delp(i,j,k) = delp(i,j,k) + fx(i) - fx(i+1) enddo enddo ! j-loop !--- adjust fy ---- do j=max(jfirst-1,1) ,min(jm,jlast+1) ! Need ps at jlast+1 do i=1,im dpy(i,j) = (ps(i,j) - ps2(i,j))*dbk*gw(j) enddo enddo do j=js2g0,min(jm,jlast+1) do i=1,im fy(i,j) = fac*(dpy(i,j-1)-dpy(i,j)) tmpf = fy3(i,j,k) + fy(i,j) if ( tmpf*fy3(i,j,k) > 0. ) then fy3(i,j,k) = tmpf else fy(i,j) = fy3(i,j,k) fy3(i,j,k) = sign(min(abs(tmpf), abs(fy3(i,j,k))), fy3(i,j,k)) fy(i,j) = fy3(i,j,k) - fy(i,j) endif enddo enddo ! update delp do j=js2g0,jn2g0 do i=1,im delp(i,j,k) = delp(i,j,k) + (fy(i,j) - fy(i,j+1)) * rgw(j) enddo enddo ! Poles: if ( jfirst == 1 ) then do i=1,im delp(i,1,k) = delp(i,1,k) - fy(i,2)*rgw(1) enddo call xpavg(delp(1,1,k), im) endif if ( jlast == jm ) then do i=1,im delp(i,jm,k) = delp(i,jm,k) + fy(i,jm)*rgw(jm) enddo call xpavg(delp(1,jm,k), im) endif endif enddo ! k-loop ! Update pe and ps !$omp parallel do private(i, j, k) do j=jfirst,jlast do i=1,im pe(i,1,j) = ak(1) enddo do k=1,km do i=1,im pe(i,k+1,j) = pe(i,k,j) + delp(i,j,k) enddo enddo do i=1,im ps(i,j) = pe(i,km+1,j) enddo enddo enddo fx_iteration !$omp parallel do private(i, j, k, dbk, dps, tmpf, fx, er0, er1, dh) do 2000 j=js2g0,jn2g0 do k=km,3,-1 dbk = bk(k+1) - bk(k) if( dbk > 0.001 ) then do i=1,im dps(i) = (ps(i,j) - ps2(i,j))*dbk enddo dps(0) = dps(im) ! i=1 er0 = dps(i-1) er1 = dps(i) if( er0*er1 < 0. ) then if( er1 > 0. ) then dh = min(-er0, er1) fx3(i,j,k) = fx3(i,j,k) - dh delp(im,j,k) = delp(im,j,k) + dh delp(i,j,k) = delp(i,j,k) - dh else dh = min(er0, -er1) fx3(i,j,k) = fx3(i,j,k) + dh delp(im,j,k) = delp(im,j,k) - dh delp(i,j,k) = delp(i,j,k) + dh endif endif do i=2,im er0 = dps(i-1) er1 = dps(i) if( er0*er1 < 0. ) then if( er1 > 0. ) then dh = min(-er0, er1) fx3(i,j,k) = fx3(i,j,k) - dh delp(i-1,j,k) = delp(i-1,j,k) + dh delp(i,j,k) = delp(i,j,k) - dh else dh = min(er0, -er1) fx3(i,j,k) = fx3(i,j,k) + dh delp(i-1,j,k) = delp(i-1,j,k) - dh delp(i,j,k) = delp(i,j,k) + dh endif endif enddo endif enddo ! k-loop do i=1,im pe(i,1,j) = ak(1) enddo do k=1,km do i=1,im pe(i,k+1,j) = pe(i,k,j) + delp(i,j,k) enddo enddo do i=1,im ps(i,j) = pe(i,km+1,j) enddo do k=1,km if( ffsl(j,k) ) then do i=1,im fx3(i,j,k) = fx3(i,j,k)/sign(max(abs(cx(i,j,k)),tiny),cx(i,j,k)) enddo endif enddo 2000 continue !* Copy adjusted surface pressure !* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ do j = jfirst, jlast do i = 1, im ps0(i,j) = ps(i,j) enddo enddo end subroutine adj_fx end module TPCORE_GEOS5_WINDOW_MOD