LCOV - code coverage report
Current view: top level - physics/cam - physics_types.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 660 906 72.8 %
Date: 2025-04-28 18:59:15 Functions: 15 31 48.4 %

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

Generated by: LCOV version 1.14