LCOV - code coverage report
Current view: | top level - physics/cam - physics_types.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 665 | 872 | 76.3 %
Date: | 2025-01-13 21:54:50 |  | Functions: | 17 | 31 | 54.8 %

              Line data    Source code
           1             : !-------------------------------------------------------------------------------
           2             : !physics data types module
           3             : !-------------------------------------------------------------------------------
           4             : module physics_types
           5             :
           6             :   use shr_kind_mod,     only: r8 => shr_kind_r8
           7             :   use ppgrid,           only: pcols, pver
           8             :   use constituents,     only: pcnst, qmin, cnst_name, cnst_get_ind
           9             :   use geopotential,     only: geopotential_t
          10             :   use physconst,        only: zvir, gravit, cpair, rair
          11             :   use air_composition,  only: cpairv, rairv
          12             :   use phys_grid,        only: get_ncols_p, get_rlon_all_p, get_rlat_all_p, get_gcol_all_p
          13             :   use cam_logfile,      only: iulog
          14             :   use cam_abortutils,   only: endrun
          15             :   use phys_control,     only: waccmx_is
          16             :   use shr_const_mod,    only: shr_const_rwv
          17             :
          18             :   implicit none
          19             :   private          ! Make default type private to the module
          20             :
          21             : ! Public types:
          22             :
          23             :   public physics_state
          24             :   public physics_tend
          25             :   public physics_ptend
          26             :
          27             : ! Public interfaces
          28             :
          29             :   public physics_update
          30             :   public physics_state_check ! Check state object for invalid data.
          31             :   public physics_ptend_reset
          32             :   public physics_ptend_init
          33             :   public physics_state_set_grid
          34             :   public physics_dme_adjust  ! adjust dry mass and energy for change in water
          35             :                              ! cannot be applied to eul or sld dycores
          36             :   public physics_state_copy  ! copy a physics_state object
          37             :   public physics_ptend_copy  ! copy a physics_ptend object
          38             :   public physics_ptend_sum   ! accumulate physics_ptend objects
          39             :   public physics_ptend_scale ! Multiply physics_ptend objects by a constant factor.
          40             :   public physics_tend_init   ! initialize a physics_tend object
          41             :
          42             :   public set_state_pdry      ! calculate dry air masses in state variable
          43             :   public set_wet_to_dry
          44             :   public set_dry_to_wet
          45             :   public physics_type_alloc
          46             :
          47             :   public physics_state_alloc   ! allocate individual components within state
          48             :   public physics_state_dealloc ! deallocate individual components within state
          49             :   public physics_tend_alloc    ! allocate individual components within tend
          50             :   public physics_tend_dealloc  ! deallocate individual components within tend
          51             :   public physics_ptend_alloc   ! allocate individual components within tend
          52             :   public physics_ptend_dealloc ! deallocate individual components within tend
          53             :
          54             :   public physics_cnst_limit ! apply limiters to constituents (waccmx)
          55             : !-------------------------------------------------------------------------------
          56             :   integer, parameter, public :: phys_te_idx = 1
          57             :   integer ,parameter, public :: dyn_te_idx = 2
          58             :
          59             :   type physics_state
          60             :      integer                                     :: &
          61             :           lchnk,                &! chunk index
          62             :           ngrdcol,              &! -- Grid        -- number of active columns (on the grid)
          63             :           psetcols=0,           &! --             -- max number of columns set - if subcols = pcols*psubcols, else = pcols
          64             :           ncol=0                 ! --             -- sum of nsubcol for all ngrdcols - number of active columns
          65             :      real(r8), dimension(:), allocatable         :: &
          66             :           lat,     &! latitude (radians)
          67             :           lon,     &! longitude (radians)
          68             :           ps,      &! surface pressure
          69             :           psdry,   &! dry surface pressure
          70             :           phis,    &! surface geopotential
          71             :           ulat,    &! unique latitudes  (radians)
          72             :           ulon      ! unique longitudes (radians)
          73             :      real(r8), dimension(:,:),allocatable        :: &
          74             :           t,       &! temperature (K)
          75             :           u,       &! zonal wind (m/s)
          76             :           v,       &! meridional wind (m/s)
          77             :           s,       &! dry static energy
          78             :           omega,   &! vertical pressure velocity (Pa/s)
          79             :           pmid,    &! midpoint pressure (Pa)
          80             :           pmiddry, &! midpoint pressure dry (Pa)
          81             :           pdel,    &! layer thickness (Pa)
          82             :           pdeldry, &! layer thickness dry (Pa)
          83             :           rpdel,   &! reciprocal of layer thickness (Pa)
          84             :           rpdeldry,&! recipricol layer thickness dry (Pa)
          85             :           lnpmid,  &! ln(pmid)
          86             :           lnpmiddry,&! log midpoint pressure dry (Pa)
          87             :           exner,   &! inverse exner function w.r.t. surface pressure (ps/p)^(R/cp)
          88             :           zm        ! geopotential height above surface at midpoints (m)
          89             :
          90             :      real(r8), dimension(:,:,:),allocatable      :: &
          91             :           q         ! constituent mixing ratio (kg/kg moist or dry air depending on type)
          92             :
          93             :      real(r8), dimension(:,:),allocatable        :: &
          94             :           pint,     &! interface pressure (Pa)
          95             :           pintdry,  &! interface pressure dry (Pa)
          96             :           lnpint,   &! ln(pint)
          97             :           lnpintdry,&! log interface pressure dry (Pa)
          98             :           zi         ! geopotential height above surface at interfaces (m)
          99             :
         100             :      real(r8), dimension(:,:),allocatable          :: &
         101             :                            ! Second dimension is (phys_te_idx) CAM physics total energy and
         102             :                            ! (dyn_te_idx) dycore total energy computed in physics
         103             :           te_ini,         &! vertically integrated total (kinetic + static) energy of initial state
         104             :           te_cur           ! vertically integrated total (kinetic + static) energy of current state
         105             :      real(r8), dimension(:), allocatable           :: &
         106             :           tw_ini,         &! vertically integrated total water of initial state
         107             :           tw_cur           ! vertically integrated total water of new state
         108             :      real(r8), dimension(:,:),allocatable          :: &
         109             :           temp_ini,       &! Temperature of initial state (used for energy computations)
         110             :           z_ini            ! Height of initial state (used for energy computations)
         111             :      integer :: count ! count of values with significant energy or water imbalances
         112             :      integer, dimension(:),allocatable           :: &
         113             :           latmapback, &! map from column to unique lat for that column
         114             :           lonmapback, &! map from column to unique lon for that column
         115             :           cid        ! unique column id
         116             :      integer :: ulatcnt, &! number of unique lats in chunk
         117             :                 uloncnt   ! number of unique lons in chunk
         118             :
         119             :   end type physics_state
         120             :
         121             : !-------------------------------------------------------------------------------
         122             :   type physics_tend
         123             :
         124             :      integer   ::   psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols
         125             :
         126             :      real(r8), dimension(:,:),allocatable        :: dtdt, dudt, dvdt
         127             :      real(r8), dimension(:),  allocatable        :: flx_net
         128             :      real(r8), dimension(:),  allocatable        :: &
         129             :           te_tnd,  &! cumulative boundary flux of total energy
         130             :           tw_tnd    ! cumulative boundary flux of total water
         131             :   end type physics_tend
         132             :
         133             : !-------------------------------------------------------------------------------
         134             : ! This is for tendencies returned from individual parameterizations
         135             :   type physics_ptend
         136             :
         137             :      integer   ::   psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols
         138             :
         139             :      character*24 :: name    ! name of parameterization which produced tendencies.
         140             :
         141             :      logical ::             &
         142             :           ls = .false.,               &! true if dsdt is returned
         143             :           lu = .false.,               &! true if dudt is returned
         144             :           lv = .false.                 ! true if dvdt is returned
         145             :
         146             :      logical,dimension(pcnst) ::  lq = .false.  ! true if dqdt() is returned
         147             :
         148             :      integer ::             &
         149             :           top_level,        &! top level index for which nonzero tendencies have been set
         150             :           bot_level          ! bottom level index for which nonzero tendencies have been set
         151             :
         152             :      real(r8), dimension(:,:),allocatable   :: &
         153             :           s,                &! heating rate (J/kg/s)
         154             :           u,                &! u momentum tendency (m/s/s)
         155             :           v                  ! v momentum tendency (m/s/s)
         156             :      real(r8), dimension(:,:,:),allocatable :: &
         157             :           q                  ! consituent tendencies (kg/kg/s)
         158             :
         159             : ! boundary fluxes
         160             :      real(r8), dimension(:),allocatable     ::&
         161             :           hflux_srf,     &! net heat flux at surface (W/m2)
         162             :           hflux_top,     &! net heat flux at top of model (W/m2)
         163             :           taux_srf,      &! net zonal stress at surface (Pa)
         164             :           taux_top,      &! net zonal stress at top of model (Pa)
         165             :           tauy_srf,      &! net meridional stress at surface (Pa)
         166             :           tauy_top        ! net meridional stress at top of model (Pa)
         167             :      real(r8), dimension(:,:),allocatable   ::&
         168             :           cflx_srf,      &! constituent flux at surface (kg/m2/s)
         169             :           cflx_top        ! constituent flux top of model (kg/m2/s)
         170             :
         171             :   end type physics_ptend
         172             :
         173             :
         174             : !===============================================================================
         175             : contains
         176             : !===============================================================================
         177        1536 :   subroutine physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, psetcols)
         178             :     implicit none
         179             :     type(physics_state), pointer :: phys_state(:)
         180             :     type(physics_tend), pointer :: phys_tend(:)
         181             :     integer, intent(in) :: begchunk, endchunk
         182             :     integer, intent(in) :: psetcols
         183             :
         184             :     integer :: ierr=0, lchnk
         185             :
         186       10800 :     allocate(phys_state(begchunk:endchunk), stat=ierr)
         187        1536 :     if( ierr /= 0 ) then
         188           0 :        write(iulog,*) 'physics_types: phys_state allocation error = ',ierr
         189           0 :        call endrun('physics_types: failed to allocate physics_state array')
         190             :     end if
         191             :
         192        7728 :     do lchnk=begchunk,endchunk
         193        7728 :        call physics_state_alloc(phys_state(lchnk),lchnk,pcols)
         194             :     end do
         195             :
         196       10800 :     allocate(phys_tend(begchunk:endchunk), stat=ierr)
         197        1536 :     if( ierr /= 0 ) then
         198           0 :        write(iulog,*) 'physics_types: phys_tend allocation error = ',ierr
         199           0 :        call endrun('physics_types: failed to allocate physics_tend array')
         200             :     end if
         201             :
         202        7728 :     do lchnk=begchunk,endchunk
         203        7728 :        call physics_tend_alloc(phys_tend(lchnk),phys_state(lchnk)%psetcols)
         204             :     end do
         205             :
         206        1536 :   end subroutine physics_type_alloc
         207             : !===============================================================================
         208    38817648 :   subroutine physics_update(state, ptend, dt, tend)
         209             : !-----------------------------------------------------------------------
         210             : ! Update the state and or tendency structure with the parameterization tendencies
         211             : !-----------------------------------------------------------------------
         212             :     use scamMod,         only: scm_crm_mode, single_column
         213             :     use phys_control,    only: phys_getopts
         214             :     use cam_thermo,      only: cam_thermo_dry_air_update ! Routine which updates physconst variables (WACCM-X)
         215             :     use air_composition, only: dry_air_species_num
         216             :     use qneg_module   ,  only: qneg3
         217             :
         218             : !------------------------------Arguments--------------------------------
         219             :     type(physics_ptend), intent(inout)  :: ptend   ! Parameterization tendencies
         220             :
         221             :     type(physics_state), intent(inout)  :: state   ! Physics state variables
         222             :
         223             :     real(r8), intent(in) :: dt                     ! time step
         224             :
         225             :     type(physics_tend ), intent(inout), optional  :: tend  ! Physics tendencies over timestep
         226             :     ! tend is usually only needed by calls from physpkg.
         227             : !
         228             : !---------------------------Local storage-------------------------------
         229             :     integer :: k,m                                 ! column,level,constituent indices
         230             :     integer :: ixcldice, ixcldliq                  ! indices for CLDICE and CLDLIQ
         231             :     integer :: ixnumice, ixnumliq
         232             :     integer :: ixnumsnow, ixnumrain
         233             :     integer :: ncol                                ! number of columns
         234             :     integer :: ixh, ixh2    ! constituent indices for H, H2
         235             :
         236    77635296 :     real(r8) :: zvirv(state%psetcols,pver)  ! Local zvir array pointer
         237             :
         238    38817648 :     real(r8),allocatable :: cpairv_loc(:,:)
         239    38817648 :     real(r8),allocatable :: rairv_loc(:,:)
         240             :
         241             :     ! PERGRO limits cldliq/ice for macro/microphysics:
         242             :     character(len=24), parameter :: pergro_cldlim_names(4) = &
         243             :          (/ "stratiform", "cldwat    ", "micro_mg  ", "macro_park" /)
         244             :
         245             :     ! cldliq/ice limits that are always on.
         246             :     character(len=24), parameter :: cldlim_names(2) = &
         247             :          (/ "convect_deep", "zm_conv_tend" /)
         248             :
         249             :     ! Whether to do validation of state on each call.
         250             :     logical :: state_debug_checks
         251             :
         252             :     !-----------------------------------------------------------------------
         253             :
         254             :     ! The column radiation model does not update the state
         255    38817648 :     if(single_column.and.scm_crm_mode) return
         256             :
         257             :
         258             :     !-----------------------------------------------------------------------
         259             :     ! If no fields are set, then return
         260    99979128 :     if (.not. (any(ptend%lq(:)) .or. ptend%ls .or. ptend%lu .or. ptend%lv)) then
         261    13414968 :        ptend%name  = "none"
         262    13414968 :        ptend%psetcols = 0
         263    13414968 :        return
         264             :     end if
         265             :
         266             :     !-----------------------------------------------------------------------
         267             :     ! Check that the state/tend/ptend are all dimensioned with the same number of columns
         268    25402680 :     if (state%psetcols /= ptend%psetcols) then
         269             :        call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) &
         270           0 :             //': state and ptend must have the same number of psetcols.')
         271             :     end if
         272             :
         273    25402680 :     if (present(tend)) then
         274    13439736 :        if (state%psetcols /= tend%psetcols) then
         275             :           call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) &
         276           0 :                //': state and tend must have the same number of psetcols.')
         277             :        end if
         278             :     end if
         279             :
         280             :
         281             :     !-----------------------------------------------------------------------
         282    25402680 :     call phys_getopts(state_debug_checks_out=state_debug_checks)
         283             :
         284    25402680 :     ncol = state%ncol
         285             :
         286             :     ! Update u,v fields
         287    25402680 :     if(ptend%lu) then
         288   201373128 :        do k = ptend%top_level, ptend%bot_level
         289  3237927264 :           state%u  (:ncol,k) = state%u  (:ncol,k) + ptend%u(:ncol,k) * dt
         290   193914864 :           if (present(tend)) &
         291  2596187160 :                tend%dudt(:ncol,k) = tend%dudt(:ncol,k) + ptend%u(:ncol,k)
         292             :        end do
         293             :     end if
         294             :
         295    25402680 :     if(ptend%lv) then
         296   201373128 :        do k = ptend%top_level, ptend%bot_level
         297  3237927264 :           state%v  (:ncol,k) = state%v  (:ncol,k) + ptend%v(:ncol,k) * dt
         298   193914864 :           if (present(tend)) &
         299  2596187160 :                tend%dvdt(:ncol,k) = tend%dvdt(:ncol,k) + ptend%v(:ncol,k)
         300             :        end do
         301             :     end if
         302             :
         303             :    ! Update constituents, all schemes use time split q: no tendency kept
         304    25402680 :     call cnst_get_ind('CLDICE', ixcldice, abort=.false.)
         305    25402680 :     call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.)
         306             :     ! Check for number concentration of cloud liquid and cloud ice (if not present
         307             :     ! the indices will be set to -1)
         308    25402680 :     call cnst_get_ind('NUMICE', ixnumice, abort=.false.)
         309    25402680 :     call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.)
         310    25402680 :     call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.)
         311    25402680 :     call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.)
         312             :
         313   101610720 :     do m = 1, pcnst
         314   101610720 :        if(ptend%lq(m)) then
         315  1210244976 :           do k = ptend%top_level, ptend%bot_level
         316 19504645776 :              state%q(:ncol,k,m) = state%q(:ncol,k,m) + ptend%q(:ncol,k,m) * dt
         317             :           end do
         318             :
         319             :           ! now test for mixing ratios which are too small
         320             :           ! don't call qneg3 for number concentration variables
         321             :           if (m /= ixnumice  .and.  m /= ixnumliq .and. &
         322    44823888 :               m /= ixnumrain .and.  m /= ixnumsnow ) then
         323    44823888 :              call qneg3(trim(ptend%name), state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m))
         324             :           else
         325           0 :              do k = ptend%top_level, ptend%bot_level
         326             :                 ! checks for number concentration
         327           0 :                 state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m))
         328           0 :                 state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m))
         329             :              end do
         330             :           end if
         331             :
         332             :        end if
         333             :
         334             :     end do
         335             :
         336             :     !------------------------------------------------------------------------
         337             :     ! This is a temporary fix for the large H, H2 in WACCM-X
         338             :     ! Well, it was supposed to be temporary, but it has been here
         339             :     ! for a while now.
         340             :     !------------------------------------------------------------------------
         341    25402680 :     if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
         342           0 :        call cnst_get_ind('H', ixh)
         343           0 :        do k = ptend%top_level, ptend%bot_level
         344           0 :           state%q(:ncol,k,ixh) = min(state%q(:ncol,k,ixh), 0.01_r8)
         345             :        end do
         346             :
         347           0 :        call cnst_get_ind('H2', ixh2)
         348           0 :        do k = ptend%top_level, ptend%bot_level
         349           0 :           state%q(:ncol,k,ixh2) = min(state%q(:ncol,k,ixh2), 6.e-5_r8)
         350             :        end do
         351             :     endif
         352             :
         353             :     ! Special tests for cloud liquid and ice:
         354             :     ! Enforce a minimum non-zero value.
         355    25402680 :     if (ixcldliq > 1) then
         356    25402680 :        if(ptend%lq(ixcldliq)) then
         357             : #ifdef PERGRO
         358             :           if ( any(ptend%name == pergro_cldlim_names) ) &
         359             :                call state_cnst_min_nz(1.e-12_r8, ixcldliq, ixnumliq)
         360             : #endif
         361    43328520 :           if ( any(ptend%name == cldlim_names) ) &
         362     1495368 :                call state_cnst_min_nz(1.e-36_r8, ixcldliq, ixnumliq)
         363             :        end if
         364             :     end if
         365             :
         366    25402680 :     if (ixcldice > 1) then
         367    25402680 :        if(ptend%lq(ixcldice)) then
         368             : #ifdef PERGRO
         369             :           if ( any(ptend%name == pergro_cldlim_names) ) &
         370             :                call state_cnst_min_nz(1.e-12_r8, ixcldice, ixnumice)
         371             : #endif
         372    38842416 :           if ( any(ptend%name == cldlim_names) ) &
         373     1495368 :                call state_cnst_min_nz(1.e-36_r8, ixcldice, ixnumice)
         374             :        end if
         375             :     end if
         376             :
         377             :     !------------------------------------------------------------------------
         378             :     ! Get indices for molecular weights and call WACCM-X cam_thermo_update
         379             :     !------------------------------------------------------------------------
         380    25402680 :     if (dry_air_species_num>0) then
         381           0 :       call cam_thermo_dry_air_update(state%q, state%t, state%lchnk, state%ncol)
         382             :     endif
         383             :
         384             :     !-----------------------------------------------------------------------
         385             :     ! cpairv_loc and rairv_loc need to be allocated to a size which matches state and ptend
         386             :     ! If psetcols == pcols, the cpairv is the correct size and just copy
         387             :     ! If psetcols > pcols and all cpairv match cpair, then assign the constant cpair
         388    76208040 :     allocate(cpairv_loc(state%psetcols,pver))
         389    25402680 :     if (state%psetcols == pcols) then
         390 11253387240 :        cpairv_loc(:,:) = cpairv(:,:,state%lchnk)
         391           0 :     else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then
         392           0 :        cpairv_loc(:,:) = cpair
         393             :     else
         394           0 :        call endrun('physics_update: cpairv is not allowed to vary when subcolumns are turned on')
         395             :     end if
         396    76208040 :     allocate(rairv_loc(state%psetcols,pver))
         397    25402680 :     if (state%psetcols == pcols) then
         398 11253387240 :        rairv_loc(:,:) = rairv(:,:,state%lchnk)
         399           0 :     else if (state%psetcols > pcols .and. all(rairv(:,:,:) == rair)) then
         400           0 :        rairv_loc(:,:) = rair
         401             :     else
         402           0 :        call endrun('physics_update: rairv_loc is not allowed to vary when subcolumns are turned on')
         403             :     end if
         404             :
         405    25402680 :     if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
         406           0 :       zvirv(:,:) = shr_const_rwv / rairv_loc(:,:) - 1._r8
         407             :     else
         408 11253387240 :       zvirv(:,:) = zvir
         409             :     endif
         410             :
         411             :     !-------------------------------------------------------------------------------------------------------------
         412             :     ! Update temperature from dry static energy (moved from above for WACCM-X so updating after cpairv_loc update)
         413             :     !-------------------------------------------------------------------------------------------------------------
         414             :
         415    25402680 :     if(ptend%ls) then
         416   605122488 :        do k = ptend%top_level, ptend%bot_level
         417  9729910944 :           state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k)
         418   582710544 :           if (present(tend)) &
         419  5857132680 :                tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k)
         420             :        end do
         421             :     end if
         422             :
         423             :     ! Derive new geopotential fields if heating or water tendency not 0.
         424             :
         425    25402680 :     if (ptend%ls .or. ptend%lq(1)) then
         426             :        call geopotential_t  (                                                                    &
         427             :             state%lnpint, state%lnpmid, state%pint  , state%pmid  , state%pdel  , state%rpdel  , &
         428             :             state%t     , state%q(:,:,:), rairv_loc(:,:), gravit  , zvirv              , &
         429    22411944 :             state%zi    , state%zm      , ncol         )
         430             :        ! update dry static energy for use in next process
         431   605122488 :        do k = ptend%top_level, ptend%bot_level
         432   582710544 :           state%s(:ncol,k) = state%t(:ncol,k)*cpairv_loc(:ncol,k) &
         433 10335033432 :                            + gravit*state%zm(:ncol,k) + state%phis(:ncol)
         434             :        end do
         435             :     end if
         436             :
         437    25402680 :     if (state_debug_checks) call physics_state_check(state, ptend%name)
         438             :
         439    25402680 :     deallocate(cpairv_loc, rairv_loc)
         440             :
         441             :     ! Deallocate ptend
         442    25402680 :     call physics_ptend_dealloc(ptend)
         443             :
         444    25402680 :     ptend%name  = "none"
         445   101610720 :     ptend%lq(:) = .false.
         446    25402680 :     ptend%ls    = .false.
         447    25402680 :     ptend%lu    = .false.
         448    25402680 :     ptend%lv    = .false.
         449    64220328 :     ptend%psetcols = 0
         450             :
         451             :   contains
         452             :
         453     2990736 :     subroutine state_cnst_min_nz(lim, qix, numix)
         454             :       ! Small utility function for setting minimum nonzero
         455             :       ! constituent concentrations.
         456             :
         457             :       ! Lower limit and constituent index
         458             :       real(r8), intent(in) :: lim
         459             :       integer,  intent(in) :: qix
         460             :       ! Number concentration that goes with qix.
         461             :       ! Ignored if <= 0 (and therefore constituent is not present).
         462             :       integer,  intent(in) :: numix
         463             :
         464     2990736 :       if (numix > 0) then
         465             :          ! Where q is too small, zero mass and number
         466             :          ! concentration.
         467           0 :          where (state%q(:ncol,:,qix) < lim)
         468           0 :             state%q(:ncol,:,qix) = 0._r8
         469           0 :             state%q(:ncol,:,numix) = 0._r8
         470             :          end where
         471             :       else
         472             :          ! If no number index, just do mass.
         473  1301387472 :           where (state%q(:ncol,:,qix) < lim)
         474     2990736 :              state%q(:ncol,:,qix) = 0._r8
         475             :           end where
         476             :       end if
         477             :
         478    38817648 :     end subroutine state_cnst_min_nz
         479             :
         480             :
         481             :   end subroutine physics_update
         482             :
         483             : !===============================================================================
         484             :
         485    29882592 :   subroutine physics_state_check(state, name)
         486             : !-----------------------------------------------------------------------
         487             : ! Check a physics_state object for invalid data (e.g NaNs, negative
         488             : ! temperatures).
         489             : !-----------------------------------------------------------------------
         490             :     use shr_infnan_mod, only: assignment(=), &
         491             :                               shr_infnan_posinf, shr_infnan_neginf
         492             :     use shr_assert_mod, only: shr_assert_in_domain
         493             :     use constituents,   only: pcnst
         494             :
         495             : !------------------------------Arguments--------------------------------
         496             :     ! State to check.
         497             :     type(physics_state), intent(in)           :: state
         498             :     ! Name of the package responsible for this state.
         499             :     character(len=*),    intent(in), optional :: name
         500             :
         501             : !---------------------------Local storage-------------------------------
         502             :     ! Shortened name for ncol.
         503             :     integer :: ncol
         504             :     ! Double precision positive/negative infinity.
         505             :     real(r8) :: posinf_r8, neginf_r8
         506             :     ! Canned message.
         507             :     character(len=64) :: msg
         508             :     ! Constituent index
         509             :     integer :: m
         510             :
         511             : !-----------------------------------------------------------------------
         512             :
         513    29882592 :     ncol = state%ncol
         514             :
         515    29882592 :     posinf_r8 = shr_infnan_posinf
         516    29882592 :     neginf_r8 = shr_infnan_neginf
         517             :
         518             :     ! It may be reasonable to check some of the integer components of the
         519             :     ! state as well, but this is not yet implemented.
         520             :
         521             :     ! Check for NaN first to avoid any IEEE exceptions.
         522             :
         523    29882592 :     if (present(name)) then
         524             :        msg = "NaN produced in physics_state by package "// &
         525    29882592 :             trim(name)//"."
         526             :     else
         527           0 :        msg = "NaN found in physics_state."
         528             :     end if
         529             :
         530             :     ! 1-D variables
         531           0 :     call shr_assert_in_domain(state%ps(:ncol),          is_nan=.false., &
         532    29882592 :          varname="state%ps",        msg=msg)
         533           0 :     call shr_assert_in_domain(state%psdry(:ncol),       is_nan=.false., &
         534    29882592 :          varname="state%psdry",     msg=msg)
         535           0 :     call shr_assert_in_domain(state%phis(:ncol),        is_nan=.false., &
         536    29882592 :          varname="state%phis",      msg=msg)
         537           0 :     call shr_assert_in_domain(state%te_ini(:ncol,:),    is_nan=.false., &
         538    29882592 :          varname="state%te_ini",    msg=msg)
         539           0 :     call shr_assert_in_domain(state%te_cur(:ncol,:),    is_nan=.false., &
         540    29882592 :          varname="state%te_cur",    msg=msg)
         541           0 :     call shr_assert_in_domain(state%tw_ini(:ncol),      is_nan=.false., &
         542    29882592 :          varname="state%tw_ini",    msg=msg)
         543           0 :     call shr_assert_in_domain(state%tw_cur(:ncol),      is_nan=.false., &
         544    29882592 :          varname="state%tw_cur",    msg=msg)
         545           0 :     call shr_assert_in_domain(state%temp_ini(:ncol,:),  is_nan=.false., &
         546    29882592 :          varname="state%temp_ini",  msg=msg)
         547           0 :     call shr_assert_in_domain(state%z_ini(:ncol,:),  is_nan=.false., &
         548    29882592 :          varname="state%z_ini",  msg=msg)
         549             :
         550             :     ! 2-D variables (at midpoints)
         551           0 :     call shr_assert_in_domain(state%t(:ncol,:),         is_nan=.false., &
         552    29882592 :          varname="state%t",         msg=msg)
         553           0 :     call shr_assert_in_domain(state%u(:ncol,:),         is_nan=.false., &
         554    29882592 :          varname="state%u",         msg=msg)
         555           0 :     call shr_assert_in_domain(state%v(:ncol,:),         is_nan=.false., &
         556    29882592 :          varname="state%v",         msg=msg)
         557           0 :     call shr_assert_in_domain(state%s(:ncol,:),         is_nan=.false., &
         558    29882592 :          varname="state%s",         msg=msg)
         559           0 :     call shr_assert_in_domain(state%omega(:ncol,:),     is_nan=.false., &
         560    29882592 :          varname="state%omega",     msg=msg)
         561           0 :     call shr_assert_in_domain(state%pmid(:ncol,:),      is_nan=.false., &
         562    29882592 :          varname="state%pmid",      msg=msg)
         563           0 :     call shr_assert_in_domain(state%pmiddry(:ncol,:),   is_nan=.false., &
         564    29882592 :          varname="state%pmiddry",   msg=msg)
         565           0 :     call shr_assert_in_domain(state%pdel(:ncol,:),      is_nan=.false., &
         566    29882592 :          varname="state%pdel",      msg=msg)
         567           0 :     call shr_assert_in_domain(state%pdeldry(:ncol,:),   is_nan=.false., &
         568    29882592 :          varname="state%pdeldry",   msg=msg)
         569           0 :     call shr_assert_in_domain(state%rpdel(:ncol,:),     is_nan=.false., &
         570    29882592 :          varname="state%rpdel",     msg=msg)
         571           0 :     call shr_assert_in_domain(state%rpdeldry(:ncol,:),  is_nan=.false., &
         572    29882592 :          varname="state%rpdeldry",  msg=msg)
         573           0 :     call shr_assert_in_domain(state%lnpmid(:ncol,:),    is_nan=.false., &
         574    29882592 :          varname="state%lnpmid",    msg=msg)
         575           0 :     call shr_assert_in_domain(state%lnpmiddry(:ncol,:), is_nan=.false., &
         576    29882592 :          varname="state%lnpmiddry", msg=msg)
         577           0 :     call shr_assert_in_domain(state%exner(:ncol,:),     is_nan=.false., &
         578    29882592 :          varname="state%exner",     msg=msg)
         579           0 :     call shr_assert_in_domain(state%zm(:ncol,:),        is_nan=.false., &
         580    29882592 :          varname="state%zm",        msg=msg)
         581             :
         582             :     ! 2-D variables (at interfaces)
         583           0 :     call shr_assert_in_domain(state%pint(:ncol,:),      is_nan=.false., &
         584    29882592 :          varname="state%pint",      msg=msg)
         585           0 :     call shr_assert_in_domain(state%pintdry(:ncol,:),   is_nan=.false., &
         586    29882592 :          varname="state%pintdry",   msg=msg)
         587           0 :     call shr_assert_in_domain(state%lnpint(:ncol,:),    is_nan=.false., &
         588    29882592 :          varname="state%lnpint",    msg=msg)
         589           0 :     call shr_assert_in_domain(state%lnpintdry(:ncol,:), is_nan=.false., &
         590    29882592 :          varname="state%lnpintdry", msg=msg)
         591           0 :     call shr_assert_in_domain(state%zi(:ncol,:),        is_nan=.false., &
         592    29882592 :          varname="state%zi",        msg=msg)
         593             :
         594             :     ! 3-D variables
         595           0 :     call shr_assert_in_domain(state%q(:ncol,:,:),       is_nan=.false., &
         596    29882592 :          varname="state%q",         msg=msg)
         597             :
         598             :     ! Now run other checks (i.e. values are finite and within a range that
         599             :     ! is physically meaningful).
         600             :
         601    29882592 :     if (present(name)) then
         602             :        msg = "Invalid value produced in physics_state by package "// &
         603    29882592 :             trim(name)//"."
         604             :     else
         605           0 :        msg = "Invalid value found in physics_state."
         606             :     end if
         607             :
         608             :     ! 1-D variables
         609             :     call shr_assert_in_domain(state%ps(:ncol),          lt=posinf_r8, gt=0._r8, &
         610    29882592 :          varname="state%ps",        msg=msg)
         611             :     call shr_assert_in_domain(state%psdry(:ncol),       lt=posinf_r8, gt=0._r8, &
         612    29882592 :          varname="state%psdry",     msg=msg)
         613             :     call shr_assert_in_domain(state%phis(:ncol),        lt=posinf_r8, gt=neginf_r8, &
         614    29882592 :          varname="state%phis",      msg=msg)
         615             :     call shr_assert_in_domain(state%te_ini(:ncol,:),    lt=posinf_r8, gt=neginf_r8, &
         616    29882592 :          varname="state%te_ini",    msg=msg)
         617             :     call shr_assert_in_domain(state%te_cur(:ncol,:),    lt=posinf_r8, gt=neginf_r8, &
         618    29882592 :          varname="state%te_cur",    msg=msg)
         619             :     call shr_assert_in_domain(state%tw_ini(:ncol),      lt=posinf_r8, gt=neginf_r8, &
         620    29882592 :          varname="state%tw_ini",    msg=msg)
         621             :     call shr_assert_in_domain(state%tw_cur(:ncol),      lt=posinf_r8, gt=neginf_r8, &
         622    29882592 :          varname="state%tw_cur",    msg=msg)
         623             :     call shr_assert_in_domain(state%temp_ini(:ncol,:),  lt=posinf_r8, gt=neginf_r8, &
         624    29882592 :          varname="state%temp_ini",  msg=msg)
         625             :     call shr_assert_in_domain(state%z_ini(:ncol,:),  lt=posinf_r8, gt=neginf_r8, &
         626    29882592 :          varname="state%z_ini",  msg=msg)
         627             :
         628             :     ! 2-D variables (at midpoints)
         629             :     call shr_assert_in_domain(state%t(:ncol,:),         lt=posinf_r8, gt=0._r8, &
         630    29882592 :          varname="state%t",         msg=msg)
         631             :     call shr_assert_in_domain(state%u(:ncol,:),         lt=posinf_r8, gt=neginf_r8, &
         632    29882592 :          varname="state%u",         msg=msg)
         633             :     call shr_assert_in_domain(state%v(:ncol,:),         lt=posinf_r8, gt=neginf_r8, &
         634    29882592 :          varname="state%v",         msg=msg)
         635             :     call shr_assert_in_domain(state%s(:ncol,:),         lt=posinf_r8, gt=neginf_r8, &
         636    29882592 :          varname="state%s",         msg=msg)
         637             :     call shr_assert_in_domain(state%omega(:ncol,:),     lt=posinf_r8, gt=neginf_r8, &
         638    29882592 :          varname="state%omega",     msg=msg)
         639             :     call shr_assert_in_domain(state%pmid(:ncol,:),      lt=posinf_r8, gt=0._r8, &
         640    29882592 :          varname="state%pmid",      msg=msg)
         641             :     call shr_assert_in_domain(state%pmiddry(:ncol,:),   lt=posinf_r8, gt=0._r8, &
         642    29882592 :          varname="state%pmiddry",   msg=msg)
         643             :     call shr_assert_in_domain(state%pdel(:ncol,:),      lt=posinf_r8, gt=neginf_r8, &
         644    29882592 :          varname="state%pdel",      msg=msg)
         645             :     call shr_assert_in_domain(state%pdeldry(:ncol,:),   lt=posinf_r8, gt=neginf_r8, &
         646    29882592 :          varname="state%pdeldry",   msg=msg)
         647             :     call shr_assert_in_domain(state%rpdel(:ncol,:),     lt=posinf_r8, gt=neginf_r8, &
         648    29882592 :          varname="state%rpdel",     msg=msg)
         649             :     call shr_assert_in_domain(state%rpdeldry(:ncol,:),  lt=posinf_r8, gt=neginf_r8, &
         650    29882592 :          varname="state%rpdeldry",  msg=msg)
         651             :     call shr_assert_in_domain(state%lnpmid(:ncol,:),    lt=posinf_r8, gt=neginf_r8, &
         652    29882592 :          varname="state%lnpmid",    msg=msg)
         653             :     call shr_assert_in_domain(state%lnpmiddry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
         654    29882592 :          varname="state%lnpmiddry", msg=msg)
         655             :     call shr_assert_in_domain(state%exner(:ncol,:),     lt=posinf_r8, gt=0._r8, &
         656    29882592 :          varname="state%exner",     msg=msg)
         657             :     call shr_assert_in_domain(state%zm(:ncol,:),        lt=posinf_r8, gt=neginf_r8, &
         658    29882592 :          varname="state%zm",        msg=msg)
         659             :
         660             :     ! 2-D variables (at interfaces)
         661             :     call shr_assert_in_domain(state%pint(:ncol,:),      lt=posinf_r8, gt=0._r8, &
         662    29882592 :          varname="state%pint",      msg=msg)
         663             :     call shr_assert_in_domain(state%pintdry(:ncol,:),   lt=posinf_r8, gt=0._r8, &
         664    29882592 :          varname="state%pintdry",   msg=msg)
         665             :     call shr_assert_in_domain(state%lnpint(:ncol,:),    lt=posinf_r8, gt=neginf_r8, &
         666    29882592 :          varname="state%lnpint",    msg=msg)
         667             :     call shr_assert_in_domain(state%lnpintdry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
         668    29882592 :          varname="state%lnpintdry", msg=msg)
         669             :     call shr_assert_in_domain(state%zi(:ncol,:),        lt=posinf_r8, gt=neginf_r8, &
         670    29882592 :          varname="state%zi",        msg=msg)
         671             :
         672             :     ! 3-D variables
         673   119530368 :     do m = 1,pcnst
         674             :        call shr_assert_in_domain(state%q(:ncol,:,m),    lt=posinf_r8, gt=neginf_r8, &
         675   119530368 :             varname="state%q ("//trim(cnst_name(m))//")", msg=msg)
         676             :     end do
         677             :
         678    29882592 :   end subroutine physics_state_check
         679             :
         680             : !===============================================================================
         681             :
         682    14953680 :   subroutine physics_ptend_sum(ptend, ptend_sum, ncol)
         683             : !-----------------------------------------------------------------------
         684             : ! Add ptend fields to ptend_sum for ptend logical flags = .true.
         685             : ! Where ptend logical flags = .false, don't change ptend_sum
         686             : !-----------------------------------------------------------------------
         687             :
         688             : !------------------------------Arguments--------------------------------
         689             :     type(physics_ptend), intent(in)     :: ptend   ! New parameterization tendencies
         690             :     type(physics_ptend), intent(inout)  :: ptend_sum   ! Sum of incoming ptend_sum and ptend
         691             :     integer, intent(in)                 :: ncol    ! number of columns
         692             :
         693             : !---------------------------Local storage-------------------------------
         694             :     integer :: i,k,m                               ! column,level,constituent indices
         695             :     integer :: psetcols                            ! maximum number of columns
         696             :     integer :: ierr = 0
         697             :
         698             : !-----------------------------------------------------------------------
         699    14953680 :     if (ptend%psetcols /= ptend_sum%psetcols) then
         700           0 :        call endrun('physics_ptend_sum error: ptend and ptend_sum must have the same value for psetcols')
         701             :     end if
         702             :
         703    14953680 :     if (ncol > ptend_sum%psetcols) then
         704           0 :        call endrun('physics_ptend_sum error: ncol must be less than or equal to psetcols')
         705             :     end if
         706             :
         707    14953680 :     psetcols = ptend_sum%psetcols
         708             :
         709    14953680 :     ptend_sum%top_level = ptend%top_level
         710    14953680 :     ptend_sum%bot_level = ptend%bot_level
         711             :
         712             : ! Update u,v fields
         713    14953680 :     if(ptend%lu) then
         714     1495368 :        if (.not. allocated(ptend_sum%u)) then
         715     4486104 :           allocate(ptend_sum%u(psetcols,pver), stat=ierr)
         716     1495368 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%u')
         717   662448024 :           ptend_sum%u=0.0_r8
         718             :
         719     4486104 :           allocate(ptend_sum%taux_srf(psetcols), stat=ierr)
         720     1495368 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_srf')
         721    25421256 :           ptend_sum%taux_srf=0.0_r8
         722             :
         723     2990736 :           allocate(ptend_sum%taux_top(psetcols), stat=ierr)
         724     1495368 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_top')
         725    25421256 :           ptend_sum%taux_top=0.0_r8
         726             :        end if
         727     1495368 :        ptend_sum%lu = .true.
         728             :
         729    40374936 :        do k = ptend%top_level, ptend%bot_level
         730   650693736 :           do i = 1, ncol
         731   649198368 :              ptend_sum%u(i,k) = ptend_sum%u(i,k) + ptend%u(i,k)
         732             :           end do
         733             :        end do
         734    24969168 :        do i = 1, ncol
         735    23473800 :           ptend_sum%taux_srf(i) = ptend_sum%taux_srf(i) + ptend%taux_srf(i)
         736    24969168 :           ptend_sum%taux_top(i) = ptend_sum%taux_top(i) + ptend%taux_top(i)
         737             :        end do
         738             :     end if
         739             :
         740    14953680 :     if(ptend%lv) then
         741     1495368 :        if (.not. allocated(ptend_sum%v)) then
         742     4486104 :           allocate(ptend_sum%v(psetcols,pver), stat=ierr)
         743     1495368 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%v')
         744   662448024 :           ptend_sum%v=0.0_r8
         745             :
         746     4486104 :           allocate(ptend_sum%tauy_srf(psetcols), stat=ierr)
         747     1495368 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_srf')
         748    25421256 :           ptend_sum%tauy_srf=0.0_r8
         749             :
         750     2990736 :           allocate(ptend_sum%tauy_top(psetcols), stat=ierr)
         751     1495368 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_top')
         752    25421256 :           ptend_sum%tauy_top=0.0_r8
         753             :        end if
         754     1495368 :        ptend_sum%lv = .true.
         755             :
         756    40374936 :        do k = ptend%top_level, ptend%bot_level
         757   650693736 :           do i = 1, ncol
         758   649198368 :              ptend_sum%v(i,k) = ptend_sum%v(i,k) + ptend%v(i,k)
         759             :           end do
         760             :        end do
         761    24969168 :        do i = 1, ncol
         762    23473800 :           ptend_sum%tauy_srf(i) = ptend_sum%tauy_srf(i) + ptend%tauy_srf(i)
         763    24969168 :           ptend_sum%tauy_top(i) = ptend_sum%tauy_top(i) + ptend%tauy_top(i)
         764             :        end do
         765             :     end if
         766             :
         767             :
         768    14953680 :     if(ptend%ls) then
         769    10467576 :        if (.not. allocated(ptend_sum%s)) then
         770    13458312 :           allocate(ptend_sum%s(psetcols,pver), stat=ierr)
         771     4486104 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%s')
         772  1987344072 :           ptend_sum%s=0.0_r8
         773             :
         774    13458312 :           allocate(ptend_sum%hflux_srf(psetcols), stat=ierr)
         775     4486104 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_srf')
         776    76263768 :           ptend_sum%hflux_srf=0.0_r8
         777             :
         778     8972208 :           allocate(ptend_sum%hflux_top(psetcols), stat=ierr)
         779     4486104 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_top')
         780    76263768 :           ptend_sum%hflux_top=0.0_r8
         781             :        end if
         782    10467576 :        ptend_sum%ls = .true.
         783             :
         784   282624552 :        do k = ptend%top_level, ptend%bot_level
         785  4554856152 :           do i = 1, ncol
         786  4544388576 :              ptend_sum%s(i,k) = ptend_sum%s(i,k) + ptend%s(i,k)
         787             :           end do
         788             :        end do
         789   174784176 :        do i = 1, ncol
         790   164316600 :           ptend_sum%hflux_srf(i) = ptend_sum%hflux_srf(i) + ptend%hflux_srf(i)
         791   174784176 :           ptend_sum%hflux_top(i) = ptend_sum%hflux_top(i) + ptend%hflux_top(i)
         792             :        end do
         793             :     end if
         794             :
         795    23925888 :     if (any(ptend%lq(:))) then
         796             :
         797    13458312 :        if (.not. allocated(ptend_sum%q)) then
         798    17944416 :           allocate(ptend_sum%q(psetcols,pver,pcnst), stat=ierr)
         799     4486104 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%q')
         800  5966518320 :           ptend_sum%q=0.0_r8
         801             :
         802    13458312 :           allocate(ptend_sum%cflx_srf(psetcols,pcnst), stat=ierr)
         803     4486104 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_srf')
         804   233277408 :           ptend_sum%cflx_srf=0.0_r8
         805             :
         806     8972208 :           allocate(ptend_sum%cflx_top(psetcols,pcnst), stat=ierr)
         807     4486104 :           if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_top')
         808   233277408 :           ptend_sum%cflx_top=0.0_r8
         809             :        end if
         810             :
         811    53833248 :        do m = 1, pcnst
         812    53833248 :           if(ptend%lq(m)) then
         813    25421256 :              ptend_sum%lq(m) = .true.
         814   686373912 :              do k = ptend%top_level, ptend%bot_level
         815 11061793512 :                 do i = 1,ncol
         816 11036372256 :                    ptend_sum%q(i,k,m) = ptend_sum%q(i,k,m) + ptend%q(i,k,m)
         817             :                 end do
         818             :              end do
         819   424475856 :              do i = 1,ncol
         820   399054600 :                 ptend_sum%cflx_srf(i,m) = ptend_sum%cflx_srf(i,m) + ptend%cflx_srf(i,m)
         821   424475856 :                 ptend_sum%cflx_top(i,m) = ptend_sum%cflx_top(i,m) + ptend%cflx_top(i,m)
         822             :              end do
         823             :           end if
         824             :        end do
         825             :
         826             :     end if
         827             :
         828    14953680 :   end subroutine physics_ptend_sum
         829             :
         830             : !===============================================================================
         831             :
         832           0 :   subroutine physics_ptend_scale(ptend, fac, ncol)
         833             : !-----------------------------------------------------------------------
         834             : ! Scale ptend fields for ptend logical flags = .true.
         835             : ! Where ptend logical flags = .false, don't change ptend.
         836             : !
         837             : ! Assumes that input ptend is valid (e.g. that
         838             : ! ptend%lu .eqv. allocated(ptend%u)), and therefore
         839             : ! does not check allocation status of individual arrays.
         840             : !-----------------------------------------------------------------------
         841             :
         842             : !------------------------------Arguments--------------------------------
         843             :     type(physics_ptend), intent(inout)  :: ptend   ! Incoming ptend
         844             :     real(r8), intent(in) :: fac                    ! Factor to multiply ptend by.
         845             :     integer, intent(in)                 :: ncol    ! number of columns
         846             :
         847             : !---------------------------Local storage-------------------------------
         848             :     integer :: m                                   ! constituent index
         849             :
         850             : !-----------------------------------------------------------------------
         851             :
         852             : ! Update u,v fields
         853           0 :     if (ptend%lu) &
         854             :          call multiply_tendency(ptend%u, &
         855           0 :          ptend%taux_srf, ptend%taux_top)
         856             :
         857           0 :     if (ptend%lv) &
         858             :          call multiply_tendency(ptend%v, &
         859           0 :          ptend%tauy_srf, ptend%tauy_top)
         860             :
         861             : ! Heat
         862           0 :     if (ptend%ls) &
         863             :          call multiply_tendency(ptend%s, &
         864           0 :          ptend%hflux_srf, ptend%hflux_top)
         865             :
         866             : ! Update constituents
         867           0 :     do m = 1, pcnst
         868           0 :        if (ptend%lq(m)) &
         869             :             call multiply_tendency(ptend%q(:,:,m), &
         870           0 :             ptend%cflx_srf(:,m), ptend%cflx_top(:,m))
         871             :     end do
         872             :
         873             :
         874             :   contains
         875             :
         876           0 :     subroutine multiply_tendency(tend_arr, flx_srf, flx_top)
         877             :       real(r8), intent(inout) :: tend_arr(:,:) ! Tendency array (pcols, plev)
         878             :       real(r8), intent(inout) :: flx_srf(:)    ! Surface flux (or stress)
         879             :       real(r8), intent(inout) :: flx_top(:)    ! Top-of-model flux (or stress)
         880             :
         881             :       integer :: k
         882             :
         883           0 :       do k = ptend%top_level, ptend%bot_level
         884           0 :          tend_arr(:ncol,k) = tend_arr(:ncol,k) * fac
         885             :       end do
         886           0 :       flx_srf(:ncol) = flx_srf(:ncol) * fac
         887           0 :       flx_top(:ncol) = flx_top(:ncol) * fac
         888             :
         889           0 :     end subroutine multiply_tendency
         890             :
         891             :   end subroutine physics_ptend_scale
         892             :
         893             : !===============================================================================
         894             :
         895           0 : subroutine physics_ptend_copy(ptend, ptend_cp)
         896             :
         897             :    !-----------------------------------------------------------------------
         898             :    ! Copy a physics_ptend object.  Allocate ptend_cp internally before copy.
         899             :    !-----------------------------------------------------------------------
         900             :
         901             :    type(physics_ptend), intent(in)    :: ptend    ! ptend source
         902             :    type(physics_ptend), intent(out)   :: ptend_cp ! copy of ptend
         903             :
         904             :    !-----------------------------------------------------------------------
         905             :
         906           0 :    ptend_cp%name      = ptend%name
         907             :
         908           0 :    ptend_cp%ls = ptend%ls
         909           0 :    ptend_cp%lu = ptend%lu
         910           0 :    ptend_cp%lv = ptend%lv
         911           0 :    ptend_cp%lq = ptend%lq
         912             :
         913           0 :    call physics_ptend_alloc(ptend_cp, ptend%psetcols)
         914             :
         915           0 :    ptend_cp%top_level = ptend%top_level
         916           0 :    ptend_cp%bot_level = ptend%bot_level
         917             :
         918           0 :    if (ptend_cp%ls) then
         919           0 :       ptend_cp%s = ptend%s
         920           0 :       ptend_cp%hflux_srf = ptend%hflux_srf
         921           0 :       ptend_cp%hflux_top = ptend%hflux_top
         922             :    end if
         923             :
         924           0 :    if (ptend_cp%lu) then
         925           0 :       ptend_cp%u = ptend%u
         926           0 :       ptend_cp%taux_srf  = ptend%taux_srf
         927           0 :       ptend_cp%taux_top  = ptend%taux_top
         928             :    end if
         929             :
         930           0 :    if (ptend_cp%lv) then
         931           0 :       ptend_cp%v = ptend%v
         932           0 :       ptend_cp%tauy_srf  = ptend%tauy_srf
         933           0 :       ptend_cp%tauy_top  = ptend%tauy_top
         934             :    end if
         935             :
         936           0 :    if (any(ptend_cp%lq(:))) then
         937           0 :       ptend_cp%q = ptend%q
         938           0 :       ptend_cp%cflx_srf  = ptend%cflx_srf
         939           0 :       ptend_cp%cflx_top  = ptend%cflx_top
         940             :    end if
         941             :
         942           0 : end subroutine physics_ptend_copy
         943             :
         944             : !===============================================================================
         945             :
         946    25402680 :   subroutine physics_ptend_reset(ptend)
         947             : !-----------------------------------------------------------------------
         948             : ! Reset the parameterization tendency structure to "empty"
         949             : !-----------------------------------------------------------------------
         950             :
         951             : !------------------------------Arguments--------------------------------
         952             :     type(physics_ptend), intent(inout)  :: ptend   ! Parameterization tendencies
         953             : !-----------------------------------------------------------------------
         954             :
         955    25402680 :     if(ptend%ls) then
         956  8603595144 :        ptend%s = 0._r8
         957   330160536 :        ptend%hflux_srf = 0._r8
         958   330160536 :        ptend%hflux_top = 0._r8
         959             :     endif
         960    25402680 :     if(ptend%lu) then
         961  2641562928 :        ptend%u = 0._r8
         962   101369232 :        ptend%taux_srf = 0._r8
         963   101369232 :        ptend%taux_top = 0._r8
         964             :     endif
         965    25402680 :     if(ptend%lv) then
         966  2641562928 :        ptend%v = 0._r8
         967   101369232 :        ptend%tauy_srf = 0._r8
         968   101369232 :        ptend%tauy_top = 0._r8
         969             :     endif
         970    52300728 :     if(any (ptend%lq(:))) then
         971 23849602560 :        ptend%q = 0._r8
         972   932465664 :        ptend%cflx_srf = 0._r8
         973   932465664 :        ptend%cflx_top = 0._r8
         974             :     end if
         975             :
         976    25402680 :     ptend%top_level = 1
         977    25402680 :     ptend%bot_level = pver
         978             :
         979    25402680 :     return
         980             :   end subroutine physics_ptend_reset
         981             :
         982             : !===============================================================================
         983   143381952 :   subroutine physics_ptend_init(ptend, psetcols, name, ls, lu, lv, lq)
         984             : !-----------------------------------------------------------------------
         985             : ! Allocate the fields in the structure which are specified.
         986             : ! Initialize the parameterization tendency structure to "empty"
         987             : !-----------------------------------------------------------------------
         988             :
         989             : !------------------------------Arguments--------------------------------
         990             :     type(physics_ptend), intent(out)    :: ptend    ! Parameterization tendencies
         991             :     integer, intent(in)                 :: psetcols ! maximum number of columns
         992             :     character(len=*)                    :: name     ! optional name of parameterization which produced tendencies.
         993             :     logical, optional                   :: ls       ! if true, then fields to support dsdt are allocated
         994             :     logical, optional                   :: lu       ! if true, then fields to support dudt are allocated
         995             :     logical, optional                   :: lv       ! if true, then fields to support dvdt are allocated
         996             :     logical, dimension(pcnst),optional  :: lq       ! if true, then fields to support dqdt are allocated
         997             :
         998             : !-----------------------------------------------------------------------
         999             :
        1000    35845488 :     if (allocated(ptend%s)) then
        1001           0 :        call endrun(' physics_ptend_init: ptend should not be allocated before calling this routine')
        1002             :     end if
        1003             :
        1004    35845488 :     ptend%name     = name
        1005    35845488 :     ptend%psetcols =  psetcols
        1006             :
        1007             :     ! If no fields being stored, initialize all values to appropriate nulls and return
        1008    35845488 :     if (.not. present(ls) .and. .not. present(lu) .and. .not. present(lv) .and. .not. present(lq) ) then
        1009    10442808 :        ptend%ls       = .false.
        1010    10442808 :        ptend%lu       = .false.
        1011    10442808 :        ptend%lv       = .false.
        1012    41771232 :        ptend%lq(:)    = .false.
        1013    10442808 :        ptend%top_level = 1
        1014    10442808 :        ptend%bot_level = pver
        1015    10442808 :        return
        1016             :     end if
        1017             :
        1018    25402680 :     if (present(ls)) then
        1019    19421208 :        ptend%ls = ls
        1020             :     else
        1021     5981472 :        ptend%ls = .false.
        1022             :     end if
        1023             :
        1024    25402680 :     if (present(lu)) then
        1025     5962896 :        ptend%lu = lu
        1026             :     else
        1027    19439784 :        ptend%lu = .false.
        1028             :     end if
        1029             :
        1030    25402680 :     if (present(lv)) then
        1031     5962896 :        ptend%lv = lv
        1032             :     else
        1033    19439784 :        ptend%lv = .false.
        1034             :     end if
        1035             :
        1036    25402680 :     if (present(lq)) then
        1037    77709600 :        ptend%lq(:) = lq(:)
        1038             :     else
        1039    23901120 :        ptend%lq(:) = .false.
        1040             :     end if
        1041             :
        1042    25402680 :     call physics_ptend_alloc(ptend, psetcols)
        1043             :
        1044    25402680 :     call physics_ptend_reset(ptend)
        1045             :
        1046    25402680 :     return
        1047    35845488 :   end subroutine physics_ptend_init
        1048             :
        1049             : !===============================================================================
        1050             :
        1051        6192 :   subroutine physics_state_set_grid(lchnk, phys_state)
        1052             : !-----------------------------------------------------------------------
        1053             : ! Set the grid components of the physics_state object
        1054             : !-----------------------------------------------------------------------
        1055             :
        1056             :     integer,             intent(in)    :: lchnk
        1057             :     type(physics_state), intent(inout) :: phys_state
        1058             :
        1059             :     ! local variables
        1060             :     integer  :: i, ncol
        1061             :     real(r8) :: rlon(pcols)
        1062             :     real(r8) :: rlat(pcols)
        1063             :
        1064             :     !-----------------------------------------------------------------------
        1065             :     ! get_ncols_p requires a state which does not have sub-columns
        1066        6192 :     if (phys_state%psetcols .ne. pcols) then
        1067           0 :        call endrun('physics_state_set_grid: cannot pass in a state which has sub-columns')
        1068             :     end if
        1069             :
        1070        6192 :     ncol = get_ncols_p(lchnk)
        1071             :
        1072        6192 :     if(ncol<=0) then
        1073           0 :        write(iulog,*) lchnk, ncol
        1074           0 :        call endrun('physics_state_set_grid')
        1075             :     end if
        1076             :
        1077        6192 :     call get_rlon_all_p(lchnk, ncol, rlon)
        1078        6192 :     call get_rlat_all_p(lchnk, ncol, rlat)
        1079        6192 :     phys_state%ncol  = ncol
        1080        6192 :     phys_state%lchnk = lchnk
        1081      103392 :     do i=1,ncol
        1082       97200 :        phys_state%lat(i) = rlat(i)
        1083      103392 :        phys_state%lon(i) = rlon(i)
        1084             :     end do
        1085        6192 :     call init_geo_unique(phys_state,ncol)
        1086             :
        1087        6192 :   end subroutine physics_state_set_grid
        1088             :
        1089             :
        1090        6192 :   subroutine init_geo_unique(phys_state,ncol)
        1091             :     integer,             intent(in)    :: ncol
        1092             :     type(physics_state), intent(inout) :: phys_state
        1093             :     logical :: match
        1094             :     integer :: i, j, ulatcnt, uloncnt
        1095             :
        1096      105264 :     phys_state%ulat=-999._r8
        1097      105264 :     phys_state%ulon=-999._r8
        1098      105264 :     phys_state%latmapback=0
        1099      105264 :     phys_state%lonmapback=0
        1100             :     match=.false.
        1101        6192 :     ulatcnt=0
        1102        6192 :     uloncnt=0
        1103        6192 :     match=.false.
        1104      103392 :     do i=1,ncol
        1105      807210 :        do j=1,ulatcnt
        1106      807210 :           if(phys_state%lat(i) .eq. phys_state%ulat(j)) then
        1107        1858 :              match=.true.
        1108        1858 :              phys_state%latmapback(i)=j
        1109             :           end if
        1110             :        end do
        1111       97200 :        if(.not. match) then
        1112       95342 :           ulatcnt=ulatcnt+1
        1113       95342 :           phys_state%ulat(ulatcnt)=phys_state%lat(i)
        1114       95342 :           phys_state%latmapback(i)=ulatcnt
        1115             :        end if
        1116             :
        1117       97200 :        match=.false.
        1118      597614 :        do j=1,uloncnt
        1119      597614 :           if(phys_state%lon(i) .eq. phys_state%ulon(j)) then
        1120       38438 :              match=.true.
        1121       38438 :              phys_state%lonmapback(i)=j
        1122             :           end if
        1123             :        end do
        1124       97200 :        if(.not. match) then
        1125       58762 :           uloncnt=uloncnt+1
        1126       58762 :           phys_state%ulon(uloncnt)=phys_state%lon(i)
        1127       58762 :           phys_state%lonmapback(i)=uloncnt
        1128             :        end if
        1129      103392 :        match=.false.
        1130             :
        1131             :     end do
        1132        6192 :     phys_state%uloncnt=uloncnt
        1133        6192 :     phys_state%ulatcnt=ulatcnt
        1134             :
        1135        6192 :     call get_gcol_all_p(phys_state%lchnk,pcols,phys_state%cid)
        1136             :
        1137             :
        1138        6192 :   end subroutine init_geo_unique
        1139             :
        1140             : !===============================================================================
        1141           0 :   subroutine physics_cnst_limit(state)
        1142             :     type(physics_state), intent(inout) :: state
        1143             :
        1144             :     integer :: i,k, ncol
        1145             :
        1146             :     real(r8) :: mmrSum_O_O2_H                ! Sum of mass mixing ratios for O, O2, and H
        1147             :     real(r8), parameter :: mmrMin=1.e-20_r8  ! lower limit of o2, o, and h mixing ratios
        1148             :     real(r8), parameter :: N2mmrMin=1.e-6_r8 ! lower limit of N2 mass mixing ratio
        1149             :     real(r8), parameter :: H2lim=6.e-5_r8    ! H2 limiter: 10x global H2 MMR (Roble, 1995)
        1150             :     integer :: ixo, ixo2, ixh, ixh2
        1151             :
        1152           0 :     if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
        1153           0 :        call cnst_get_ind('O', ixo)
        1154           0 :        call cnst_get_ind('O2', ixo2)
        1155           0 :        call cnst_get_ind('H', ixh)
        1156           0 :        call cnst_get_ind('H2', ixh2)
        1157             :
        1158           0 :        ncol = state%ncol
        1159             :
        1160             :        !------------------------------------------------------------
        1161             :        ! Ensure N2 = 1-(O2 + O + H) mmr is greater than 0
        1162             :        ! Check for unusually large H2 values and set to lower value.
        1163             :        !------------------------------------------------------------
        1164             :
        1165           0 :        do k=1,pver
        1166           0 :           do i=1,ncol
        1167             :
        1168           0 :              if (state%q(i,k,ixo) < mmrMin) state%q(i,k,ixo) = mmrMin
        1169           0 :              if (state%q(i,k,ixo2) < mmrMin) state%q(i,k,ixo2) = mmrMin
        1170             :
        1171           0 :              mmrSum_O_O2_H = state%q(i,k,ixo)+state%q(i,k,ixo2)+state%q(i,k,ixh)
        1172             :
        1173           0 :              if ((1._r8-mmrMin-mmrSum_O_O2_H) < 0._r8) then
        1174             :
        1175           0 :                 state%q(i,k,ixo) = state%q(i,k,ixo) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
        1176             :
        1177           0 :                 state%q(i,k,ixo2) = state%q(i,k,ixo2) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
        1178             :
        1179           0 :                 state%q(i,k,ixh) = state%q(i,k,ixh) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
        1180             :
        1181             :              endif
        1182             :
        1183           0 :              if(state%q(i,k,ixh2) > H2lim) then
        1184           0 :                 state%q(i,k,ixh2) = H2lim
        1185             :              endif
        1186             :
        1187             :           end do
        1188             :        end do
        1189             :
        1190             :     end if
        1191           0 :   end subroutine physics_cnst_limit
        1192             :
        1193             : !===============================================================================
        1194           0 :   subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt)
        1195             :     use air_composition, only: dry_air_species_num,thermodynamic_active_species_num
        1196             :     use air_composition, only: thermodynamic_active_species_idx
        1197             :     use dycore,          only: dycore_is
        1198             :     !-----------------------------------------------------------------------
        1199             :     !
        1200             :     ! Purpose: Adjust the dry mass in each layer back to the value of physics input state
        1201             :     !
        1202             :     ! Method: Conserve the integrated mass, momentum and total energy in each layer
        1203             :     !         by scaling the specific mass of consituents, specific momentum (velocity)
        1204             :     !         and specific total energy by the relative change in layer mass. Solve for
        1205             :     !         the new temperature by subtracting the new kinetic energy from total energy
        1206             :     !         and inverting the hydrostatic equation
        1207             :     !
        1208             :     !         The mass in each layer is modified, changing the relationship of the layer
        1209             :     !         interfaces and midpoints to the surface pressure. The result is no longer in
        1210             :     !         the original hybrid coordinate.
        1211             :     !
        1212             :     !         This procedure cannot be applied to the "eul" or "sld" dycores because they
        1213             :     !         require the hybrid coordinate.
        1214             :     !
        1215             :     ! Author: Byron Boville
        1216             :
        1217             :     ! !REVISION HISTORY:
        1218             :     !   03.03.28  Boville    Created, partly from code by Lin in p_d_adjust
        1219             :     !
        1220             :     !-----------------------------------------------------------------------
        1221             :
        1222             :     implicit none
        1223             :     !
        1224             :     ! Arguments
        1225             :     !
        1226             :     type(physics_state), intent(inout) :: state
        1227             :     type(physics_tend ), intent(inout) :: tend
        1228             :     real(r8),            intent(in   ) :: qini(pcols,pver)    ! initial specific humidity
        1229             :     real(r8),            intent(in   ) :: liqini(pcols,pver)  ! initial total liquid
        1230             :     real(r8),            intent(in   ) :: iceini(pcols,pver)  ! initial total ice
        1231             :     real(r8),            intent(in   ) :: dt                  ! model physics timestep
        1232             :     !
        1233             :     !---------------------------Local workspace-----------------------------
        1234             :     !
        1235             :     integer  :: lchnk         ! chunk identifier
        1236             :     integer  :: ncol          ! number of atmospheric columns
        1237             :     integer  :: k,m           ! Longitude, level indices
        1238             :     real(r8) :: fdq(pcols)    ! mass adjustment factor
        1239             :     real(r8) :: te(pcols)     ! total energy in a layer
        1240             :     real(r8) :: utmp(pcols)   ! temp variable for recalculating the initial u values
        1241             :     real(r8) :: vtmp(pcols)   ! temp variable for recalculating the initial v values
        1242             :
        1243             :     real(r8) :: zvirv(pcols,pver)    ! Local zvir array pointer
        1244             :
        1245             :     real(r8) :: tot_water (pcols,2)  ! total water (initial, present)
        1246             :     real(r8) :: tot_water_chg(pcols) ! total water change
        1247             :
        1248             :
        1249             :     real(r8),allocatable :: cpairv_loc(:,:)
        1250             :     integer :: m_cnst
        1251             :     !
        1252             :     !-----------------------------------------------------------------------
        1253             :
        1254           0 :     if (state%psetcols .ne. pcols) then
        1255           0 :        call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns')
        1256             :     end if
        1257             :
        1258           0 :     lchnk = state%lchnk
        1259           0 :     ncol  = state%ncol
        1260             :
        1261             :     ! adjust dry mass in each layer back to input value, while conserving
        1262             :     ! constituents, momentum, and total energy
        1263           0 :     state%ps(:ncol) = state%pint(:ncol,1)
        1264             :
        1265             :     !
        1266             :     ! original code for backwards compatability with FV and EUL
        1267             :     !
        1268           0 :     if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then
        1269           0 :       do k = 1, pver
        1270             :
        1271             :         ! adjusment factor is just change in water vapor
        1272           0 :         fdq(:ncol) = 1._r8 + state%q(:ncol,k,1) - qini(:ncol,k)
        1273             :
        1274             :         ! adjust constituents to conserve mass in each layer
        1275           0 :         do m = 1, pcnst
        1276           0 :           state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol)
        1277             :         end do
        1278             :         ! compute new total pressure variables
        1279           0 :         state%pdel  (:ncol,k  ) = state%pdel(:ncol,k  ) * fdq(:ncol)
        1280           0 :         state%ps(:ncol)         = state%ps(:ncol)       + state%pdel(:ncol,k)
        1281           0 :         state%pint  (:ncol,k+1) = state%pint(:ncol,k  ) + state%pdel(:ncol,k)
        1282           0 :         state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1))
        1283           0 :         state%rpdel (:ncol,k  ) = 1._r8/ state%pdel(:ncol,k  )
        1284             :       end do
        1285             :     else
        1286           0 :       do k = 1, pver
        1287           0 :         tot_water(:ncol,1) = qini(:ncol,k) +liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O
        1288           0 :         tot_water(:ncol,2) = 0.0_r8
        1289           0 :         do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num
        1290           0 :           m = thermodynamic_active_species_idx(m_cnst)
        1291           0 :           tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m)
        1292             :         end do
        1293           0 :         fdq(:ncol) = 1._r8 + tot_water(:ncol,2) - tot_water(:ncol,1)
        1294             :         ! adjust constituents to conserve mass in each layer
        1295           0 :         do m = 1, pcnst
        1296           0 :           state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol)
        1297             :         end do
        1298             :         ! compute new total pressure variables
        1299           0 :         state%pdel  (:ncol,k  ) = state%pdel(:ncol,k  ) * fdq(:ncol)
        1300           0 :         state%ps(:ncol)         = state%ps(:ncol)       + state%pdel(:ncol,k)
        1301           0 :         state%pint  (:ncol,k+1) = state%pint(:ncol,k  ) + state%pdel(:ncol,k)
        1302           0 :         state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1))
        1303           0 :         state%rpdel (:ncol,k  ) = 1._r8/ state%pdel(:ncol,k  )
        1304             :         !note that mid-level variables (e.g. pmid) are not recomputed
        1305             :       end do
        1306             :     endif
        1307           0 :     if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
        1308           0 :       zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8
        1309             :     else
        1310           0 :       zvirv(:,:) = zvir
        1311             :     endif
        1312             :
        1313           0 :   end subroutine physics_dme_adjust
        1314             :
        1315             : !-----------------------------------------------------------------------
        1316             :
        1317             : !===============================================================================
        1318     5975280 :   subroutine physics_state_copy(state_in, state_out)
        1319             :
        1320             :     use ppgrid,       only: pver, pverp
        1321             :     use constituents, only: pcnst
        1322             :
        1323             :     implicit none
        1324             :
        1325             :     !
        1326             :     ! Arguments
        1327             :     !
        1328             :     type(physics_state), intent(in)    :: state_in
        1329             :     type(physics_state), intent(out)   :: state_out
        1330             :
        1331             :     !
        1332             :     ! Local variables
        1333             :     !
        1334             :     integer i, k, m, ncol
        1335             :
        1336             :     ! Allocate state_out with same subcol dimension as state_in
        1337     5975280 :     call physics_state_alloc ( state_out, state_in%lchnk, state_in%psetcols)
        1338             :
        1339     5975280 :     ncol = state_in%ncol
        1340             :
        1341     5975280 :     state_out%psetcols = state_in%psetcols
        1342     5975280 :     state_out%ngrdcol  = state_in%ngrdcol
        1343     5975280 :     state_out%lchnk    = state_in%lchnk
        1344     5975280 :     state_out%ncol     = state_in%ncol
        1345     5975280 :     state_out%count    = state_in%count
        1346             :
        1347    99773280 :     do i = 1, ncol
        1348    93798000 :        state_out%lat(i)      = state_in%lat(i)
        1349    93798000 :        state_out%lon(i)      = state_in%lon(i)
        1350    93798000 :        state_out%ps(i)       = state_in%ps(i)
        1351    99773280 :        state_out%phis(i)     = state_in%phis(i)
        1352             :      end do
        1353   205521840 :      state_out%te_ini(:ncol,:) = state_in%te_ini(:ncol,:)
        1354   205521840 :      state_out%te_cur(:ncol,:) = state_in%te_cur(:ncol,:)
        1355    99773280 :      state_out%tw_ini(:ncol)   = state_in%tw_ini(:ncol)
        1356    99773280 :      state_out%tw_cur(:ncol)   = state_in%tw_cur(:ncol)
        1357             :
        1358   161332560 :     do k = 1, pver
        1359  2600080560 :        do i = 1, ncol
        1360  2438748000 :           state_out%temp_ini(i,k)  = state_in%temp_ini(i,k)
        1361  2438748000 :           state_out%z_ini(i,k)     = state_in%z_ini(i,k)
        1362  2438748000 :           state_out%t(i,k)         = state_in%t(i,k)
        1363  2438748000 :           state_out%u(i,k)         = state_in%u(i,k)
        1364  2438748000 :           state_out%v(i,k)         = state_in%v(i,k)
        1365  2438748000 :           state_out%s(i,k)         = state_in%s(i,k)
        1366  2438748000 :           state_out%omega(i,k)     = state_in%omega(i,k)
        1367  2438748000 :           state_out%pmid(i,k)      = state_in%pmid(i,k)
        1368  2438748000 :           state_out%pdel(i,k)      = state_in%pdel(i,k)
        1369  2438748000 :           state_out%rpdel(i,k)     = state_in%rpdel(i,k)
        1370  2438748000 :           state_out%lnpmid(i,k)    = state_in%lnpmid(i,k)
        1371  2438748000 :           state_out%exner(i,k)     = state_in%exner(i,k)
        1372  2594105280 :           state_out%zm(i,k)        = state_in%zm(i,k)
        1373             :        end do
        1374             :     end do
        1375             :
        1376   167307840 :     do k = 1, pverp
        1377  2699853840 :        do i = 1, ncol
        1378  2532546000 :           state_out%pint(i,k)      = state_in%pint(i,k)
        1379  2532546000 :           state_out%lnpint(i,k)    = state_in%lnpint(i,k)
        1380  2693878560 :           state_out%zi(i,k)        = state_in% zi(i,k)
        1381             :        end do
        1382             :     end do
        1383             :
        1384             :
        1385    99773280 :        do i = 1, ncol
        1386    99773280 :           state_out%psdry(i)  = state_in%psdry(i)
        1387             :        end do
        1388   161332560 :        do k = 1, pver
        1389  2600080560 :           do i = 1, ncol
        1390  2438748000 :              state_out%lnpmiddry(i,k) = state_in%lnpmiddry(i,k)
        1391  2438748000 :              state_out%pmiddry(i,k)   = state_in%pmiddry(i,k)
        1392  2438748000 :              state_out%pdeldry(i,k)   = state_in%pdeldry(i,k)
        1393  2594105280 :              state_out%rpdeldry(i,k)  = state_in%rpdeldry(i,k)
        1394             :           end do
        1395             :        end do
        1396   167307840 :        do k = 1, pverp
        1397  2699853840 :           do i = 1, ncol
        1398  2532546000 :              state_out%pintdry(i,k)   = state_in%pintdry(i,k)
        1399  2693878560 :              state_out%lnpintdry(i,k) = state_in%lnpintdry(i,k)
        1400             :           end do
        1401             :        end do
        1402             :
        1403    23901120 :     do m = 1, pcnst
        1404   489972960 :        do k = 1, pver
        1405  7800241680 :           do i = 1, ncol
        1406  7782315840 :              state_out%q(i,k,m) = state_in%q(i,k,m)
        1407             :           end do
        1408             :        end do
        1409             :     end do
        1410             :
        1411     5975280 :   end subroutine physics_state_copy
        1412             : !===============================================================================
        1413             :
        1414           0 :   subroutine physics_tend_init(tend)
        1415             :
        1416             :     implicit none
        1417             :
        1418             :     !
        1419             :     ! Arguments
        1420             :     !
        1421             :     type(physics_tend), intent(inout) :: tend
        1422             :
        1423             :     !
        1424             :     ! Local variables
        1425             :     !
        1426             :
        1427           0 :     if (.not. allocated(tend%dtdt)) then
        1428           0 :        call endrun('physics_tend_init: tend must be allocated before it can be initialized')
        1429             :     end if
        1430             :
        1431           0 :     tend%dtdt    = 0._r8
        1432           0 :     tend%dudt    = 0._r8
        1433           0 :     tend%dvdt    = 0._r8
        1434           0 :     tend%flx_net = 0._r8
        1435           0 :     tend%te_tnd  = 0._r8
        1436           0 :     tend%tw_tnd  = 0._r8
        1437             :
        1438           0 : end subroutine physics_tend_init
        1439             :
        1440             : !===============================================================================
        1441             :
        1442           0 : subroutine set_state_pdry (state,pdeld_calc)
        1443             :
        1444             :   use ppgrid,  only: pver
        1445             :   implicit none
        1446             :
        1447             :   type(physics_state), intent(inout) :: state
        1448             :   logical, optional, intent(in) :: pdeld_calc    !  .true. do calculate pdeld [default]
        1449             :                                                  !  .false. don't calculate pdeld
        1450             :   integer ncol
        1451             :   integer k
        1452             :   logical do_pdeld_calc
        1453             :
        1454           0 :   if ( present(pdeld_calc) ) then
        1455           0 :      do_pdeld_calc = pdeld_calc
        1456             :   else
        1457             :      do_pdeld_calc = .true.
        1458             :   endif
        1459             :
        1460           0 :   ncol = state%ncol
        1461             :
        1462             :
        1463           0 :   state%psdry(:ncol) = state%pint(:ncol,1)
        1464           0 :   state%pintdry(:ncol,1) = state%pint(:ncol,1)
        1465             :
        1466           0 :   if (do_pdeld_calc)  then
        1467           0 :      do k = 1, pver
        1468           0 :         state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-state%q(:ncol,k,1))
        1469             :      end do
        1470             :   endif
        1471           0 :   do k = 1, pver
        1472           0 :      state%pintdry(:ncol,k+1) = state%pintdry(:ncol,k)+state%pdeldry(:ncol,k)
        1473           0 :      state%pmiddry(:ncol,k) = (state%pintdry(:ncol,k+1)+state%pintdry(:ncol,k))/2._r8
        1474           0 :      state%psdry(:ncol) = state%psdry(:ncol) + state%pdeldry(:ncol,k)
        1475             :   end do
        1476             :
        1477           0 :   state%rpdeldry(:ncol,:) = 1._r8/state%pdeldry(:ncol,:)
        1478           0 :   state%lnpmiddry(:ncol,:) = log(state%pmiddry(:ncol,:))
        1479           0 :   state%lnpintdry(:ncol,:) = log(state%pintdry(:ncol,:))
        1480             :
        1481           0 : end subroutine set_state_pdry
        1482             :
        1483             : !===============================================================================
        1484             :
        1485     1489176 : subroutine set_wet_to_dry(state, convert_cnst_type)
        1486             :
        1487             :   ! Convert mixing ratios from a wet to dry basis for constituents of type
        1488             :   ! convert_cnst_type.  Constituents are given a type when they are added
        1489             :   ! to the constituent array by a call to cnst_add during the register
        1490             :   ! phase of initialization.  There are two constituent types: 'wet' for
        1491             :   ! water species and 'dry' for non-water species.
        1492             :
        1493             :   use constituents,  only: pcnst, cnst_type
        1494             :
        1495             :   type(physics_state), intent(inout) :: state
        1496             :   character(len=3),    intent(in)    :: convert_cnst_type
        1497             :
        1498             :   ! local variables
        1499             :   integer m, ncol
        1500             :   character(len=*), parameter :: sub = 'set_wet_to_dry'
        1501             :   !-----------------------------------------------------------------------------
        1502             :
        1503             :   ! check input
        1504     1489176 :   if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then
        1505           0 :     write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type
        1506           0 :     call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type)
        1507             :   end if
        1508             :
        1509     1489176 :   ncol = state%ncol
        1510             :
        1511     5956704 :   do m = 1, pcnst
        1512     5956704 :      if (cnst_type(m) == convert_cnst_type) then
        1513           0 :         state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:)
        1514             :      end if
        1515             :   end do
        1516             :
        1517     1489176 : end subroutine set_wet_to_dry
        1518             :
        1519             : !===============================================================================
        1520             :
        1521     2978352 : subroutine set_dry_to_wet(state, convert_cnst_type)
        1522             :
        1523             :   ! Convert mixing ratios from a dry to wet basis for constituents of type
        1524             :   ! convert_cnst_type.  Constituents are given a type when they are added
        1525             :   ! to the constituent array by a call to cnst_add during the register
        1526             :   ! phase of initialization.  There are two constituent types: 'wet' for
        1527             :   ! water species and 'dry' for non-water species.
        1528             :
        1529             :   use constituents,  only: pcnst, cnst_type
        1530             :
        1531             :   type(physics_state), intent(inout) :: state
        1532             :   character(len=3),    intent(in)    :: convert_cnst_type
        1533             :
        1534             :   ! local variables
        1535             :   integer m, ncol
        1536             :   character(len=*), parameter :: sub = 'set_dry_to_wet'
        1537             :   !-----------------------------------------------------------------------------
        1538             :
        1539             :   ! check input
        1540     2978352 :   if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then
        1541           0 :     write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type
        1542           0 :     call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type)
        1543             :   end if
        1544             :
        1545     2978352 :   ncol = state%ncol
        1546             :
        1547    11913408 :   do m = 1, pcnst
        1548    11913408 :      if (cnst_type(m) == convert_cnst_type) then
        1549           0 :         state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:)
        1550             :      end if
        1551             :   end do
        1552             :
        1553     2978352 : end subroutine set_dry_to_wet
        1554             :
        1555             : !===============================================================================
        1556             :
        1557     5981472 : subroutine physics_state_alloc(state,lchnk,psetcols)
        1558             :
        1559             :   use infnan,     only: inf, assignment(=)
        1560             :
        1561             : ! allocate the individual state components
        1562             :
        1563             :   type(physics_state), intent(inout) :: state
        1564             :   integer,intent(in)                 :: lchnk
        1565             :
        1566             :   integer, intent(in)                :: psetcols
        1567             :
        1568             :   integer :: ierr=0
        1569             :
        1570     5981472 :   state%lchnk    = lchnk
        1571     5981472 :   state%psetcols = psetcols
        1572     5981472 :   state%ngrdcol  = get_ncols_p(lchnk)  ! Number of grid columns
        1573             :
        1574             :   !----------------------------------
        1575             :   ! Following variables will be overwritten by sub-column generator, if sub-columns are being used
        1576             :
        1577             :   !  state%ncol - is initialized in physics_state_set_grid,  if not using sub-columns
        1578             :
        1579             :   !----------------------------------
        1580             :
        1581    17944416 :   allocate(state%lat(psetcols), stat=ierr)
        1582     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lat')
        1583             :
        1584    11962944 :   allocate(state%lon(psetcols), stat=ierr)
        1585     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lon')
        1586             :
        1587    11962944 :   allocate(state%ps(psetcols), stat=ierr)
        1588     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ps')
        1589             :
        1590    11962944 :   allocate(state%psdry(psetcols), stat=ierr)
        1591     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%psdry')
        1592             :
        1593    11962944 :   allocate(state%phis(psetcols), stat=ierr)
        1594     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%phis')
        1595             :
        1596    11962944 :   allocate(state%ulat(psetcols), stat=ierr)
        1597     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulat')
        1598             :
        1599    11962944 :   allocate(state%ulon(psetcols), stat=ierr)
        1600     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulon')
        1601             :
        1602    17944416 :   allocate(state%t(psetcols,pver), stat=ierr)
        1603     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%t')
        1604             :
        1605    11962944 :   allocate(state%u(psetcols,pver), stat=ierr)
        1606     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%u')
        1607             :
        1608    11962944 :   allocate(state%v(psetcols,pver), stat=ierr)
        1609     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%v')
        1610             :
        1611    11962944 :   allocate(state%s(psetcols,pver), stat=ierr)
        1612     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%s')
        1613             :
        1614    11962944 :   allocate(state%omega(psetcols,pver), stat=ierr)
        1615     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%omega')
        1616             :
        1617    11962944 :   allocate(state%pmid(psetcols,pver), stat=ierr)
        1618     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmid')
        1619             :
        1620    11962944 :   allocate(state%pmiddry(psetcols,pver), stat=ierr)
        1621     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmiddry')
        1622             :
        1623    11962944 :   allocate(state%pdel(psetcols,pver), stat=ierr)
        1624     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdel')
        1625             :
        1626    11962944 :   allocate(state%pdeldry(psetcols,pver), stat=ierr)
        1627     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdeldry')
        1628             :
        1629    11962944 :   allocate(state%rpdel(psetcols,pver), stat=ierr)
        1630     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdel')
        1631             :
        1632    11962944 :   allocate(state%rpdeldry(psetcols,pver), stat=ierr)
        1633     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdeldry')
        1634             :
        1635    11962944 :   allocate(state%lnpmid(psetcols,pver), stat=ierr)
        1636     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmid')
        1637             :
        1638    11962944 :   allocate(state%lnpmiddry(psetcols,pver), stat=ierr)
        1639     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmiddry')
        1640             :
        1641    11962944 :   allocate(state%exner(psetcols,pver), stat=ierr)
        1642     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%exner')
        1643             :
        1644    11962944 :   allocate(state%zm(psetcols,pver), stat=ierr)
        1645     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zm')
        1646             :
        1647    23925888 :   allocate(state%q(psetcols,pver,pcnst), stat=ierr)
        1648     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%q')
        1649             :
        1650    17944416 :   allocate(state%pint(psetcols,pver+1), stat=ierr)
        1651     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pint')
        1652             :
        1653    11962944 :   allocate(state%pintdry(psetcols,pver+1), stat=ierr)
        1654     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pintdry')
        1655             :
        1656    11962944 :   allocate(state%lnpint(psetcols,pver+1), stat=ierr)
        1657     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpint')
        1658             :
        1659    11962944 :   allocate(state%lnpintdry(psetcols,pver+1), stat=ierr)
        1660     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpintdry')
        1661             :
        1662    11962944 :   allocate(state%zi(psetcols,pver+1), stat=ierr)
        1663     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zi')
        1664             :
        1665    17944416 :   allocate(state%te_ini(psetcols,2), stat=ierr)
        1666     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_ini')
        1667             :
        1668    11962944 :   allocate(state%te_cur(psetcols,2), stat=ierr)
        1669     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur')
        1670             :
        1671    11962944 :   allocate(state%tw_ini(psetcols), stat=ierr)
        1672     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini')
        1673             :
        1674    11962944 :   allocate(state%tw_cur(psetcols), stat=ierr)
        1675     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_cur')
        1676             :
        1677    11962944 :   allocate(state%temp_ini(psetcols,pver), stat=ierr)
        1678     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%temp_ini')
        1679             :
        1680    11962944 :   allocate(state%z_ini(psetcols,pver), stat=ierr)
        1681     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%z_ini')
        1682             :
        1683    17944416 :   allocate(state%latmapback(psetcols), stat=ierr)
        1684     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%latmapback')
        1685             :
        1686    11962944 :   allocate(state%lonmapback(psetcols), stat=ierr)
        1687     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lonmapback')
        1688             :
        1689    11962944 :   allocate(state%cid(psetcols), stat=ierr)
        1690     5981472 :   if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid')
        1691             :
        1692     5981472 :   state%lat(:) = inf
        1693     5981472 :   state%lon(:) = inf
        1694     5981472 :   state%ulat(:) = inf
        1695     5981472 :   state%ulon(:) = inf
        1696     5981472 :   state%ps(:) = inf
        1697     5981472 :   state%psdry(:) = inf
        1698     5981472 :   state%phis(:) = inf
        1699     5981472 :   state%t(:,:) = inf
        1700     5981472 :   state%u(:,:) = inf
        1701     5981472 :   state%v(:,:) = inf
        1702     5981472 :   state%s(:,:) = inf
        1703     5981472 :   state%omega(:,:) = inf
        1704     5981472 :   state%pmid(:,:) = inf
        1705     5981472 :   state%pmiddry(:,:) = inf
        1706     5981472 :   state%pdel(:,:) = inf
        1707     5981472 :   state%pdeldry(:,:) = inf
        1708     5981472 :   state%rpdel(:,:) = inf
        1709     5981472 :   state%rpdeldry(:,:) = inf
        1710     5981472 :   state%lnpmid(:,:) = inf
        1711     5981472 :   state%lnpmiddry(:,:) = inf
        1712     5981472 :   state%exner(:,:) = inf
        1713     5981472 :   state%zm(:,:) = inf
        1714     5981472 :   state%q(:,:,:) = inf
        1715             :
        1716     5981472 :   state%pint(:,:) = inf
        1717     5981472 :   state%pintdry(:,:) = inf
        1718     5981472 :   state%lnpint(:,:) = inf
        1719     5981472 :   state%lnpintdry(:,:) = inf
        1720     5981472 :   state%zi(:,:) = inf
        1721             :
        1722     5981472 :   state%te_ini(:,:) = inf
        1723     5981472 :   state%te_cur(:,:) = inf
        1724     5981472 :   state%tw_ini(:) = inf
        1725     5981472 :   state%tw_cur(:) = inf
        1726     5981472 :   state%temp_ini(:,:) = inf
        1727     5981472 :   state%z_ini(:,:)  = inf
        1728             :
        1729     5981472 : end subroutine physics_state_alloc
        1730             :
        1731             : !===============================================================================
        1732             :
        1733     4486104 : subroutine physics_state_dealloc(state)
        1734             :
        1735             : ! deallocate the individual state components
        1736             :
        1737             :   type(physics_state), intent(inout) :: state
        1738             :   integer                            :: ierr = 0
        1739             :
        1740     4486104 :   deallocate(state%lat, stat=ierr)
        1741     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lat')
        1742             :
        1743     4486104 :   deallocate(state%lon, stat=ierr)
        1744     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lon')
        1745             :
        1746     4486104 :   deallocate(state%ps, stat=ierr)
        1747     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ps')
        1748             :
        1749     4486104 :   deallocate(state%psdry, stat=ierr)
        1750     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%psdry')
        1751             :
        1752     4486104 :   deallocate(state%phis, stat=ierr)
        1753     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%phis')
        1754             :
        1755     4486104 :   deallocate(state%ulat, stat=ierr)
        1756     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulat')
        1757             :
        1758     4486104 :   deallocate(state%ulon, stat=ierr)
        1759     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulon')
        1760             :
        1761     4486104 :   deallocate(state%t, stat=ierr)
        1762     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%t')
        1763             :
        1764     4486104 :   deallocate(state%u, stat=ierr)
        1765     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%u')
        1766             :
        1767     4486104 :   deallocate(state%v, stat=ierr)
        1768     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%v')
        1769             :
        1770     4486104 :   deallocate(state%s, stat=ierr)
        1771     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%s')
        1772             :
        1773     4486104 :   deallocate(state%omega, stat=ierr)
        1774     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%omega')
        1775             :
        1776     4486104 :   deallocate(state%pmid, stat=ierr)
        1777     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmid')
        1778             :
        1779     4486104 :   deallocate(state%pmiddry, stat=ierr)
        1780     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmiddry')
        1781             :
        1782     4486104 :   deallocate(state%pdel, stat=ierr)
        1783     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdel')
        1784             :
        1785     4486104 :   deallocate(state%pdeldry, stat=ierr)
        1786     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdeldry')
        1787             :
        1788     4486104 :   deallocate(state%rpdel, stat=ierr)
        1789     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdel')
        1790             :
        1791     4486104 :   deallocate(state%rpdeldry, stat=ierr)
        1792     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdeldry')
        1793             :
        1794     4486104 :   deallocate(state%lnpmid, stat=ierr)
        1795     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmid')
        1796             :
        1797     4486104 :   deallocate(state%lnpmiddry, stat=ierr)
        1798     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmiddry')
        1799             :
        1800     4486104 :   deallocate(state%exner, stat=ierr)
        1801     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%exner')
        1802             :
        1803     4486104 :   deallocate(state%zm, stat=ierr)
        1804     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zm')
        1805             :
        1806     4486104 :   deallocate(state%q, stat=ierr)
        1807     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%q')
        1808             :
        1809     4486104 :   deallocate(state%pint, stat=ierr)
        1810     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pint')
        1811             :
        1812     4486104 :   deallocate(state%pintdry, stat=ierr)
        1813     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pintdry')
        1814             :
        1815     4486104 :   deallocate(state%lnpint, stat=ierr)
        1816     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpint')
        1817             :
        1818     4486104 :   deallocate(state%lnpintdry, stat=ierr)
        1819     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpintdry')
        1820             :
        1821     4486104 :   deallocate(state%zi, stat=ierr)
        1822     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zi')
        1823             :
        1824     4486104 :   deallocate(state%te_ini, stat=ierr)
        1825     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_ini')
        1826             :
        1827     4486104 :   deallocate(state%te_cur, stat=ierr)
        1828     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur')
        1829             :
        1830     4486104 :   deallocate(state%tw_ini, stat=ierr)
        1831     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini')
        1832             :
        1833     4486104 :   deallocate(state%tw_cur, stat=ierr)
        1834     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_cur')
        1835             :
        1836     4486104 :   deallocate(state%temp_ini, stat=ierr)
        1837     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%temp_ini')
        1838             :
        1839     4486104 :   deallocate(state%z_ini, stat=ierr)
        1840     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%z_ini')
        1841             :
        1842     4486104 :   deallocate(state%latmapback, stat=ierr)
        1843     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%latmapback')
        1844             :
        1845     4486104 :   deallocate(state%lonmapback, stat=ierr)
        1846     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lonmapback')
        1847             :
        1848     4486104 :   deallocate(state%cid, stat=ierr)
        1849     4486104 :   if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%cid')
        1850             :
        1851     4486104 : end subroutine physics_state_dealloc
        1852             :
        1853             : !===============================================================================
        1854             :
        1855        6192 : subroutine physics_tend_alloc(tend,psetcols)
        1856             :
        1857             :   use infnan, only : inf, assignment(=)
        1858             : ! allocate the individual tend components
        1859             :
        1860             :   type(physics_tend), intent(inout)  :: tend
        1861             :
        1862             :   integer, intent(in)                :: psetcols
        1863             :
        1864             :   integer :: ierr = 0
        1865             :
        1866        6192 :   tend%psetcols = psetcols
        1867             :
        1868       18576 :   allocate(tend%dtdt(psetcols,pver), stat=ierr)
        1869        6192 :   if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dtdt')
        1870             :
        1871       12384 :   allocate(tend%dudt(psetcols,pver), stat=ierr)
        1872        6192 :   if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dudt')
        1873             :
        1874       12384 :   allocate(tend%dvdt(psetcols,pver), stat=ierr)
        1875        6192 :   if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dvdt')
        1876             :
        1877       18576 :   allocate(tend%flx_net(psetcols), stat=ierr)
        1878        6192 :   if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%flx_net')
        1879             :
        1880       12384 :   allocate(tend%te_tnd(psetcols), stat=ierr)
        1881        6192 :   if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_tnd')
        1882             :
        1883       12384 :   allocate(tend%tw_tnd(psetcols), stat=ierr)
        1884        6192 :   if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%tw_tnd')
        1885             :
        1886        6192 :   tend%dtdt(:,:) = inf
        1887        6192 :   tend%dudt(:,:) = inf
        1888        6192 :   tend%dvdt(:,:) = inf
        1889        6192 :   tend%flx_net(:) = inf
        1890        6192 :   tend%te_tnd(:) = inf
        1891        6192 :   tend%tw_tnd(:) = inf
        1892             :
        1893        6192 : end subroutine physics_tend_alloc
        1894             :
        1895             : !===============================================================================
        1896             :
        1897           0 : subroutine physics_tend_dealloc(tend)
        1898             :
        1899             : ! deallocate the individual tend components
        1900             :
        1901             :   type(physics_tend), intent(inout)  :: tend
        1902             :   integer :: ierr = 0
        1903             :
        1904           0 :   deallocate(tend%dtdt, stat=ierr)
        1905           0 :   if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dtdt')
        1906             :
        1907           0 :   deallocate(tend%dudt, stat=ierr)
        1908           0 :   if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dudt')
        1909             :
        1910           0 :   deallocate(tend%dvdt, stat=ierr)
        1911           0 :   if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dvdt')
        1912             :
        1913           0 :   deallocate(tend%flx_net, stat=ierr)
        1914           0 :   if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%flx_net')
        1915             :
        1916           0 :   deallocate(tend%te_tnd, stat=ierr)
        1917           0 :   if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_tnd')
        1918             :
        1919           0 :   deallocate(tend%tw_tnd, stat=ierr)
        1920           0 :   if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%tw_tnd')
        1921           0 : end subroutine physics_tend_dealloc
        1922             :
        1923             : !===============================================================================
        1924             :
        1925    25402680 : subroutine physics_ptend_alloc(ptend,psetcols)
        1926             :
        1927             : ! allocate the individual ptend components
        1928             :
        1929             :   type(physics_ptend), intent(inout) :: ptend
        1930             :
        1931             :   integer, intent(in)                :: psetcols
        1932             :
        1933             :   integer :: ierr = 0
        1934             :
        1935    25402680 :   ptend%psetcols = psetcols
        1936             :
        1937    25402680 :   if (ptend%ls) then
        1938    58263624 :      allocate(ptend%s(psetcols,pver), stat=ierr)
        1939    19421208 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%s')
        1940             :
        1941    58263624 :      allocate(ptend%hflux_srf(psetcols), stat=ierr)
        1942    19421208 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_srf')
        1943             :
        1944    38842416 :      allocate(ptend%hflux_top(psetcols), stat=ierr)
        1945    19421208 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_top')
        1946             :   end if
        1947             :
        1948    25402680 :   if (ptend%lu) then
        1949    17888688 :      allocate(ptend%u(psetcols,pver), stat=ierr)
        1950     5962896 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%u')
        1951             :
        1952    17888688 :      allocate(ptend%taux_srf(psetcols), stat=ierr)
        1953     5962896 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_srf')
        1954             :
        1955    11925792 :      allocate(ptend%taux_top(psetcols), stat=ierr)
        1956     5962896 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_top')
        1957             :   end if
        1958             :
        1959    25402680 :   if (ptend%lv) then
        1960    17888688 :      allocate(ptend%v(psetcols,pver), stat=ierr)
        1961     5962896 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%v')
        1962             :
        1963    17888688 :      allocate(ptend%tauy_srf(psetcols), stat=ierr)
        1964     5962896 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_srf')
        1965             :
        1966    11925792 :      allocate(ptend%tauy_top(psetcols), stat=ierr)
        1967     5962896 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_top')
        1968             :   end if
        1969             :
        1970    52300728 :   if (any(ptend%lq)) then
        1971    71728128 :      allocate(ptend%q(psetcols,pver,pcnst), stat=ierr)
        1972    17932032 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%q')
        1973             :
        1974    53796096 :      allocate(ptend%cflx_srf(psetcols,pcnst), stat=ierr)
        1975    17932032 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_srf')
        1976             :
        1977    35864064 :      allocate(ptend%cflx_top(psetcols,pcnst), stat=ierr)
        1978    17932032 :      if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_top')
        1979             :   end if
        1980             :
        1981    25402680 : end subroutine physics_ptend_alloc
        1982             :
        1983             : !===============================================================================
        1984             :
        1985    28393416 : subroutine physics_ptend_dealloc(ptend)
        1986             :
        1987             : ! deallocate the individual ptend components
        1988             :
        1989             :   type(physics_ptend), intent(inout) :: ptend
        1990             :   integer :: ierr = 0
        1991             :
        1992    28393416 :   ptend%psetcols = 0
        1993             :
        1994    28393416 :   if (allocated(ptend%s)) deallocate(ptend%s, stat=ierr)
        1995    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%s')
        1996             :
        1997    28393416 :   if (allocated(ptend%hflux_srf))   deallocate(ptend%hflux_srf, stat=ierr)
        1998    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_srf')
        1999             :
        2000    28393416 :   if (allocated(ptend%hflux_top))  deallocate(ptend%hflux_top, stat=ierr)
        2001    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_top')
        2002             :
        2003    28393416 :   if (allocated(ptend%u))   deallocate(ptend%u, stat=ierr)
        2004    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%u')
        2005             :
        2006    28393416 :   if (allocated(ptend%taux_srf)) deallocate(ptend%taux_srf, stat=ierr)
        2007    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_srf')
        2008             :
        2009    28393416 :   if (allocated(ptend%taux_top))   deallocate(ptend%taux_top, stat=ierr)
        2010    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_top')
        2011             :
        2012    28393416 :   if (allocated(ptend%v)) deallocate(ptend%v, stat=ierr)
        2013    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%v')
        2014             :
        2015    28393416 :   if (allocated(ptend%tauy_srf))   deallocate(ptend%tauy_srf, stat=ierr)
        2016    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_srf')
        2017             :
        2018    28393416 :   if (allocated(ptend%tauy_top))   deallocate(ptend%tauy_top, stat=ierr)
        2019    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_top')
        2020             :
        2021    28393416 :   if (allocated(ptend%q))  deallocate(ptend%q, stat=ierr)
        2022    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%q')
        2023             :
        2024    28393416 :   if (allocated(ptend%cflx_srf))   deallocate(ptend%cflx_srf, stat=ierr)
        2025    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_srf')
        2026             :
        2027    28393416 :   if(allocated(ptend%cflx_top))   deallocate(ptend%cflx_top, stat=ierr)
        2028    28393416 :   if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_top')
        2029             :
        2030    28393416 : end subroutine physics_ptend_dealloc
        2031             :
        2032           0 : end module physics_types

Generated by: LCOV version 1.14