LCOV - code coverage report
Current view: | top level - physics/cam - subcol_utils.F90.in (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 36 | 459 | 7.8 %
Date: | 2025-01-13 21:54:50 |  | Functions: | 5 | 58 | 8.6 %

              Line data    Source code
           1             :  module subcol_utils
           2             :    !---------------------------------------------------------------------------
           3             :    ! Purpose:
           4             :    !
           5             :    ! Provides utilities to support subcolumns
           6             :    !
           7             :    !---------------------------------------------------------------------------
           8             :
           9             :    use shr_kind_mod,    only: r8=>shr_kind_r8, r4=>shr_kind_r4, i4=>shr_kind_i4
          10             :    use infnan,          only: nan, assignment(=)
          11             :    use physics_types,   only: physics_state, physics_ptend, physics_tend, physics_tend_alloc, physics_state_alloc
          12             :    use ppgrid,          only: pcols, psubcols, pver
          13             :    use constituents,    only: pcnst
          14             :    use cam_abortutils,  only: endrun
          15             :    use pio,             only: var_desc_t
          16             :    use subcol_pack_mod, only: subcol_get_nsubcol, subcol_set_nsubcol, subcol_get_indcol
          17             :
          18             :    implicit none
          19             :
          20             :    private
          21             :    save
          22             :
          23             :    integer, target, allocatable :: filter2d(:,:)
          24             :    real(r8),target, allocatable :: weight2d(:,:)
          25             :    logical :: weight_set, filter_set
          26             :
          27             :    !! The active subcolumn scheme
          28             :    character(len=16) :: subcol_scheme = 'off'
          29             :
          30             :    !! Public interface functions which do not depend on the subcolumn scheme
          31             :
          32             :    public :: subcol_utils_init       ! Initialize module data (e.g., nsubcol2d)
          33             :    public :: subcol_get_filter       ! return the filter values
          34             :    public :: subcol_set_filter       ! set the filter values
          35             :    public :: subcol_get_weight       ! return the weight values
          36             :    public :: subcol_set_weight       ! set the weight values
          37             :
          38             :    public :: subcol_field_copy       ! copy a physics buffer field into one with subcolumn dimensions
          39             :    public :: subcol_ptend_copy       ! copy a physics_ptend object into one with subcolumn dimensions
          40             :    public :: subcol_set_subcols      ! set nsubcols and copy state & tend objects into one with subcolumn dimensions
          41             :
          42             :    public :: subcol_field_avg_shr    ! Average subcol fields back into GBA fields
          43             :    public :: subcol_ptend_avg_shr    ! average subcolumn ptend to grid ptend
          44             :
          45             :    public :: subcol_field_get_firstsubcol  ! Retrieve the first subcolumn and assign to grid
          46             :    public :: subcol_ptend_get_firstsubcol  ! retrieve the first subcolumn from the ptend fields and assign to grid ptend
          47             :
          48             :    public :: subcol_utils_init_restart     ! Initialize restart with subcolumn specific fields
          49             :    public :: subcol_utils_read_restart     ! Read subcolumn specific fields from restart
          50             :    public :: subcol_utils_write_restart    ! Write subcolumn specific fields for restart
          51             :    public :: is_filter_set           ! True if filters for averaging have been set
          52             :    public :: is_weight_set           ! True if weights for averaging have been set
          53             :    public :: is_subcol_on            ! true is any subcol_scheme other than "off" is set
          54             :    public :: subcol_get_scheme       ! Return the active subcolumn scheme name
          55             :    public :: subcol_utils_readnl     ! Set the active scheme based on namelist
          56             :
          57             :    interface subcol_field_avg_shr
          58             :       ! TYPE int,double,real
          59             :       ! DIMS 1,2
          60             :       module procedure subcol_field_avg_shr_{DIMS}d{TYPE}
          61             :    end interface
          62             :
          63             :    interface subcol_avg_inter
          64             :       ! TYPE int,double,real
          65             :       module procedure subcol_avg_inter_{TYPE}
          66             :    end interface
          67             :
          68             :    interface subcol_avg
          69             :       ! TYPE int,double,real
          70             :       module procedure subcol_avg_{TYPE}
          71             :    end interface
          72             :
          73             :    interface subcol_field_get_firstsubcol
          74             :       ! TYPE int,double,real
          75             :       ! DIMS 1,2
          76             :       module procedure subcol_field_get_firstsubcol_{DIMS}d{TYPE}
          77             :    end interface
          78             :
          79             :    interface subcol_state_field_copy
          80             :       ! TYPE double
          81             :       ! DIMS 1,2,3
          82             :       module procedure subcol_state_field_copy_{DIMS}d{TYPE}
          83             :    end interface
          84             :
          85             :    interface subcol_field_copy
          86             :       ! TYPE int,double,real
          87             :       ! DIMS 1,2,3,4,5
          88             :       module procedure subcol_field_copy_{DIMS}d{TYPE}
          89             :    end interface
          90             :
          91             :    type(var_desc_t) :: weight2d_desc, filter2d_desc
          92             :    integer          :: subcol_dimid = -1 ! subcol dimension for restart
          93             :
          94             :    integer :: ret_nan_int
          95             :    real(r8):: ret_nan_double
          96             :    real(r4):: ret_nan_real
          97             :
          98             :    integer :: fillval_int
          99             :    real(r8):: fillval_double
         100             :    real(r4):: fillval_real
         101             :
         102             : contains
         103             :
         104         768 :    subroutine subcol_allocate_internal()
         105             :       use ppgrid,          only: begchunk, endchunk
         106             :       use subcol_pack_mod, only: subcol_pack_allocate
         107             :
         108         768 :       call subcol_pack_allocate()
         109             :
         110         768 :       if (allocated(filter2d)) then
         111           0 :          deallocate(filter2d)
         112             :       end if
         113        2304 :       allocate(filter2d(pcols*psubcols, begchunk:endchunk))
         114       53400 :       filter2d = 0
         115             :
         116         768 :       if (allocated(weight2d)) then
         117           0 :          deallocate(weight2d)
         118             :       end if
         119        2304 :       allocate(weight2d(pcols*psubcols, begchunk:endchunk))
         120       53400 :       weight2d = 0._r8
         121             :
         122         768 :     end subroutine subcol_allocate_internal
         123             :
         124         768 :    subroutine subcol_utils_init(subcol_scheme_init)
         125             :
         126             :       character(len=*), optional, intent(in) :: subcol_scheme_init ! Name of subcolumn generator
         127             :
         128         768 :       call subcol_allocate_internal()
         129             :
         130         768 :       ret_nan_int    = 0
         131         768 :       ret_nan_double = nan
         132         768 :       ret_nan_real   = nan
         133             :
         134         768 :       fillval_int    = 0
         135         768 :       fillval_double = 0._r8
         136         768 :       fillval_real   = 0._r4
         137             :
         138         768 :       weight_set = .false.
         139         768 :       filter_set = .false.
         140             :
         141         768 :    end subroutine subcol_utils_init
         142             :
         143           0 :    subroutine subcol_get_filter(lchnk, filter)
         144             :    !-----------------------------------------------------------------------
         145             :    ! Retrieve the filter module variable
         146             :    !-----------------------------------------------------------------------
         147             :
         148             :      integer,    intent(in)    :: lchnk
         149             :      integer,    intent(out)   :: filter(:)
         150             :
         151           0 :      filter(:) = filter2d(:,lchnk)
         152           0 :    end subroutine subcol_get_filter
         153             :
         154           0 :    subroutine subcol_get_weight(lchnk, weight)
         155             :    !-----------------------------------------------------------------------
         156             :    ! Retrieve the weight module variable
         157             :    !-----------------------------------------------------------------------
         158             :
         159             :      integer,    intent(in)    :: lchnk
         160             :      real(r8),   intent(out)   :: weight(:)
         161             :
         162           0 :      weight(:) = weight2d(:,lchnk)
         163           0 :    end subroutine subcol_get_weight
         164             :
         165           0 :    integer function subcol_get_ncol(lchnk) result(ncol)
         166             :    !-----------------------------------------------------------------------
         167             :    ! Compute the number of (sub)columns for a chunk
         168             :    ! NB: This is considered an internal function so it can use nsubcol2d
         169             :    !-----------------------------------------------------------------------
         170             :      integer,    intent(in)    :: lchnk
         171             :
         172             :      integer :: nsubcol(pcols)
         173             :
         174           0 :      call subcol_get_nsubcol(lchnk, nsubcol)
         175           0 :      ncol = SUM(nsubcol)
         176             :
         177           0 :    end function subcol_get_ncol
         178             :
         179           0 :    subroutine subcol_set_filter(lchnk, filter)
         180             :    !-----------------------------------------------------------------------
         181             :    ! Set the filter module variable
         182             :    !-----------------------------------------------------------------------
         183             :
         184             :      integer,    intent(in)    :: lchnk
         185             :      integer,    intent(in)    :: filter(:)
         186             :
         187           0 :      filter2d(:,lchnk) = filter(:)
         188           0 :      filter_set        = .true.
         189           0 :    end subroutine subcol_set_filter
         190             :
         191           0 :    subroutine subcol_set_weight(lchnk, weight)
         192             :    !-----------------------------------------------------------------------
         193             :    ! Set the weight module variable
         194             :    !-----------------------------------------------------------------------
         195             :
         196             :      integer,    intent(in)    :: lchnk
         197             :      real(r8),   intent(in)    :: weight(:)
         198             :
         199           0 :      weight2d(:,lchnk) = weight(:)
         200           0 :      weight_set        = .true.
         201           0 :    end subroutine subcol_set_weight
         202             :
         203           0 :    logical function is_weight_set()
         204           0 :       is_weight_set=weight_set
         205           0 :    end function is_weight_set
         206             :
         207           0 :    logical function is_filter_set()
         208           0 :       is_filter_set=filter_set
         209           0 :    end function is_filter_set
         210             :
         211        6912 :    logical function is_subcol_on()
         212        6912 :       is_subcol_on = (trim(subcol_scheme) /= 'off')
         213        6912 :    end function is_subcol_on
         214             :
         215        6144 :    character(len=16) function subcol_get_scheme()
         216        6144 :       subcol_get_scheme = trim(subcol_scheme)
         217        6144 :    end function subcol_get_scheme
         218             :
         219        1536 :    subroutine subcol_utils_readnl(nlfile)
         220             :       use namelist_utils,  only: find_group_name
         221             :       use units,           only: getunit, freeunit
         222             :       use spmd_utils,      only: masterproc, mpi_character, masterprocid, mpicom
         223             :
         224             :       character(len=*), intent(in) :: nlfile  ! filepath for file containing namelist input
         225             :
         226             :       ! Local variables
         227             :       integer :: unitn, ierr
         228             :
         229             :       namelist /subcol_nl/ subcol_scheme
         230             :
         231        1536 :       if (masterproc) then
         232           2 :          unitn = getunit()
         233           2 :          open( unitn, file=trim(nlfile), status='old' )
         234           2 :          call find_group_name(unitn, 'subcol_nl', status=ierr)
         235           2 :          if (ierr == 0) then
         236           0 :             read(unitn, subcol_nl, iostat=ierr)
         237           0 :             if (ierr /= 0) then
         238           0 :                call endrun('subcol_readnl: ERROR reading namelist')
         239             :             end if
         240             :          end if
         241           2 :          close(unitn)
         242           2 :          call freeunit(unitn)
         243             :       end if
         244             :
         245             : #ifdef SPMD
         246             :       ! Broadcast namelist variables
         247        1536 :       call mpi_bcast(subcol_scheme, len(subcol_scheme), mpi_character, masterprocid, mpicom, ierr)
         248             : #endif
         249             :
         250        1536 :    end subroutine subcol_utils_readnl
         251             :
         252             :    ! TYPE int,double,real
         253             :    ! DIMS 1,2,3,4,5
         254           0 :    subroutine subcol_field_copy_{DIMS}d{TYPE} (field, lchnk, field_sc)
         255             :    !-----------------------------------------------------------------------
         256             :    ! Copy a pbuf field dimensioned pcols to one with pcols*psubcols and fill appropriately
         257             :    !-----------------------------------------------------------------------
         258             :
         259             :       {VTYPE},          intent(in)      :: field{DIMSTR}
         260             :       integer,          intent(in)      :: lchnk
         261             :       {VTYPE},          intent(out)     :: field_sc{DIMSTR}   ! intent out
         262             :
         263             :       ! Local Variables
         264             :       integer                           :: ncol
         265             :       integer                           :: indcol(pcols*psubcols)
         266             :
         267           0 :       if (size(field,dim=1) .ne. pcols) then
         268           0 :          call endrun('subcol_field_copy error: only fields with first dimension pcols may use this routine')
         269             :       end if
         270             :
         271           0 :       field_sc = fillval_{TYPE}
         272           0 :       ncol = subcol_get_ncol(lchnk)
         273           0 :       call subcol_get_indcol(lchnk, indcol)
         274             :
         275             : #if ({DIMS} == 1)
         276           0 :       field_sc(:ncol) = field(indcol(:ncol))
         277             : #endif
         278             :
         279             : #if ({DIMS} == 2)
         280           0 :       field_sc(:ncol,:) = field(indcol(:ncol),:)
         281             : #endif
         282             :
         283             : #if ({DIMS} == 3)
         284           0 :       field_sc(:ncol,:,:) = field(indcol(:ncol),:,:)
         285             : #endif
         286             :
         287             : #if ({DIMS} == 4)
         288           0 :       field_sc(:ncol,:,:,:) = field(indcol(:ncol),:,:,:)
         289             : #endif
         290             :
         291             : #if ({DIMS} == 5)
         292           0 :       field_sc(:ncol,:,:,:,:) = field(indcol(:ncol),:,:,:,:)
         293             : #endif
         294             :
         295           0 :    end subroutine subcol_field_copy_{DIMS}d{TYPE}
         296             :
         297             :    ! TYPE double
         298             :    ! DIMS 1,2,3
         299           0 :    subroutine subcol_state_field_copy_{DIMS}d{TYPE} (field, state, field_sc)
         300             :    !-----------------------------------------------------------------------
         301             :    ! Copy a state field dimensioned with pcols to one with pcols*psubcols and fill appropriately
         302             :    !-----------------------------------------------------------------------
         303             :
         304             :       {VTYPE}, intent(in)                     :: field{DIMSTR}
         305             :       type(physics_state), intent(in)         :: state
         306             :       {VTYPE},          allocatable           :: field_sc{DIMSTR}   ! intent out
         307             :
         308             :       integer :: dim2, dim3
         309             :       integer :: indcol(pcols*psubcols)
         310             :
         311           0 :       if (size(field,dim=1) .ne. pcols) then
         312           0 :          call endrun('subcol_state_field_copy error: only fields with first dimension pcols may use this routine')
         313             :       end if
         314             :
         315           0 :       call subcol_get_indcol(state%lchnk, indcol)
         316             :
         317             : #if ({DIMS} == 1)
         318           0 :       if (.not. allocated(field_sc)) then
         319           0 :          allocate(field_sc(pcols*psubcols))
         320             :       end if
         321             :
         322           0 :       field_sc = 0._r8
         323           0 :       field_sc(:state%ncol) = field(indcol(:state%ncol))
         324             : #endif
         325             :
         326             : #if ({DIMS} == 2)
         327           0 :       if (.not. allocated(field_sc)) then
         328           0 :          dim2 = size(field,dim=2)
         329           0 :          allocate(field_sc(pcols*psubcols,dim2))
         330             :       end if
         331             :
         332           0 :       field_sc = 0._r8
         333           0 :       field_sc(:state%ncol,:) = field(indcol(:state%ncol),:)
         334             : #endif
         335             :
         336             : #if ({DIMS} == 3)
         337           0 :       if (.not. allocated(field_sc)) then
         338           0 :          dim2 = size(field,dim=2)
         339           0 :          dim3 = size(field,dim=3)
         340           0 :          allocate(field_sc(pcols*psubcols,dim2,dim3))
         341             :       end if
         342             :
         343           0 :       field_sc = 0._r8
         344           0 :       field_sc(:state%ncol,:,:) = field(indcol(:state%ncol),:,:)
         345             : #endif
         346             :
         347           0 :    end subroutine subcol_state_field_copy_{DIMS}d{TYPE}
         348             :
         349           0 :    subroutine subcol_tend_copy(tend, state_sc, tend_sc)
         350             :    !-----------------------------------------------------------------------
         351             :    ! Copy all of tend to subcolumns in tend_sc, allocating tend_sc if necessary
         352             :    !-----------------------------------------------------------------------
         353             :       type(physics_tend),  intent(inout) :: tend
         354             :       type(physics_state), intent(in)    :: state_sc        ! subcolumn state
         355             :       type(physics_tend),  intent(inout) :: tend_sc         ! subcolumn tend
         356             :
         357             :
         358           0 :       if (.not. allocated(tend%dtdt)) then
         359           0 :          call physics_tend_alloc(tend_sc, state_sc%psetcols)
         360             :       end if
         361             :
         362           0 :       tend_sc%psetcols   = pcols*psubcols
         363           0 :       call subcol_state_field_copy(tend%dtdt,       state_sc, tend_sc%dtdt)
         364           0 :       call subcol_state_field_copy(tend%dudt,       state_sc, tend_sc%dudt)
         365           0 :       call subcol_state_field_copy(tend%dvdt,       state_sc, tend_sc%dvdt)
         366           0 :       call subcol_state_field_copy(tend%flx_net,    state_sc, tend_sc%flx_net)
         367           0 :       call subcol_state_field_copy(tend%te_tnd,     state_sc, tend_sc%te_tnd)
         368           0 :       call subcol_state_field_copy(tend%tw_tnd,     state_sc, tend_sc%tw_tnd)
         369             :
         370           0 :    end subroutine subcol_tend_copy
         371             :
         372           0 :    subroutine subcol_state_copy(state, state_sc)
         373             :    !-----------------------------------------------------------------------
         374             :    ! Copy all of state to subcolumns in state_sc, allocating state_sc if necessary
         375             :    !-----------------------------------------------------------------------
         376             :       type(physics_state), intent(in)    :: state
         377             :       type(physics_state), intent(inout) :: state_sc        ! subcolumn state
         378             :
         379             :       !
         380             :       ! Local variables
         381             :       !
         382             :       integer :: ngrdcol
         383             :
         384           0 :       if (.not. allocated(state_sc%lat)) then
         385           0 :          call endrun('subcol_state_copy: user must allocate state_sc prior to calling this routine')
         386             :       end if
         387             :
         388           0 :       ngrdcol       = state%ngrdcol
         389             :
         390           0 :       call subcol_state_hdrinit(state, state_sc)
         391             :
         392           0 :       call subcol_state_field_copy(state%lat,       state_sc, state_sc%lat)
         393           0 :       call subcol_state_field_copy(state%lon,       state_sc, state_sc%lon)
         394           0 :       call subcol_state_field_copy(state%ps,        state_sc, state_sc%ps)
         395           0 :       call subcol_state_field_copy(state%psdry,     state_sc, state_sc%psdry)
         396           0 :       call subcol_state_field_copy(state%phis,      state_sc, state_sc%phis)
         397           0 :       call subcol_state_field_copy(state%te_ini,    state_sc, state_sc%te_ini)
         398           0 :       call subcol_state_field_copy(state%te_cur,    state_sc, state_sc%te_cur)
         399           0 :       call subcol_state_field_copy(state%tw_ini,    state_sc, state_sc%tw_ini)
         400           0 :       call subcol_state_field_copy(state%tw_cur,    state_sc, state_sc%tw_cur)
         401           0 :       call subcol_state_field_copy(state%t,         state_sc, state_sc%t)
         402           0 :       call subcol_state_field_copy(state%u,         state_sc, state_sc%u)
         403           0 :       call subcol_state_field_copy(state%v,         state_sc, state_sc%v)
         404           0 :       call subcol_state_field_copy(state%s,         state_sc, state_sc%s)
         405           0 :       call subcol_state_field_copy(state%omega,     state_sc, state_sc%omega)
         406           0 :       call subcol_state_field_copy(state%pmid,      state_sc, state_sc%pmid)
         407           0 :       call subcol_state_field_copy(state%pdel,      state_sc, state_sc%pdel)
         408           0 :       call subcol_state_field_copy(state%rpdel,     state_sc, state_sc%rpdel)
         409           0 :       call subcol_state_field_copy(state%lnpmid,    state_sc, state_sc%lnpmid)
         410           0 :       call subcol_state_field_copy(state%exner,     state_sc, state_sc%exner)
         411           0 :       call subcol_state_field_copy(state%zm,        state_sc, state_sc%zm)
         412           0 :       call subcol_state_field_copy(state%pint,      state_sc, state_sc%pint)
         413           0 :       call subcol_state_field_copy(state%lnpint,    state_sc, state_sc%lnpint)
         414           0 :       call subcol_state_field_copy(state%zi,        state_sc, state_sc%zi)
         415           0 :       call subcol_state_field_copy(state%lnpmiddry, state_sc, state_sc%lnpmiddry)
         416           0 :       call subcol_state_field_copy(state%pmiddry,   state_sc, state_sc%pmiddry)
         417           0 :       call subcol_state_field_copy(state%pdeldry,   state_sc, state_sc%pdeldry)
         418           0 :       call subcol_state_field_copy(state%rpdeldry,  state_sc, state_sc%rpdeldry)
         419           0 :       call subcol_state_field_copy(state%pintdry,   state_sc, state_sc%pintdry)
         420           0 :       call subcol_state_field_copy(state%lnpintdry, state_sc, state_sc%lnpintdry)
         421           0 :       call subcol_state_field_copy(state%q,         state_sc, state_sc%q)
         422             :
         423           0 :    end subroutine subcol_state_copy
         424             :
         425           0 :    subroutine subcol_set_subcols(state, tend, nsubcol, state_sc, tend_sc)
         426             :    !-----------------------------------------------------------------------
         427             :    ! Propogate nsubcol information to common areas such as state, tend,
         428             :    ! nsubcol2d, and indcol2d
         429             :    !-----------------------------------------------------------------------
         430             :       type(physics_state), intent(in)    :: state
         431             :       type(physics_tend),  intent(inout) :: tend
         432             :       integer,             intent(in)    :: nsubcol(pcols)
         433             :       type(physics_state), intent(inout) :: state_sc        ! subcolumn state
         434             :       type(physics_tend),  intent(inout) :: tend_sc         ! subcolumn tend
         435             :
         436           0 :       call subcol_set_nsubcol(state%lchnk, state%ngrdcol, nsubcol)
         437           0 :       call subcol_state_copy(state, state_sc)
         438           0 :       call subcol_tend_copy(tend, state_sc, tend_sc)
         439           0 :    end subroutine subcol_set_subcols
         440             :
         441             :
         442           0 :    subroutine subcol_ptend_copy(ptend, state, ptend_cp)
         443             :    !-----------------------------------------------------------------------
         444             :    ! Copy a physics_ptend object into one which has subcolumns
         445             :    !-----------------------------------------------------------------------
         446             :       use physics_types, only: physics_ptend_init
         447             :
         448             :       type(physics_ptend), intent(in)    :: ptend    ! ptend source, dimensioned with grid columns
         449             :       type(physics_state), intent(in)    :: state    ! state with subcolumns
         450             :       type(physics_ptend), intent(out)   :: ptend_cp ! copy of ptend, dimensioned with subcolumns
         451             :
         452             :       ! Local Variables
         453             :       integer                            :: ncol
         454             :       integer                            :: indcol(pcols*psubcols)
         455             :
         456             :       !-----------------------------------------------------------------------
         457             :
         458           0 :       if (ptend%psetcols .ne. pcols) then
         459           0 :          call endrun('subcol_ptend_copy: ptend must be dimensioned pcols to use this routine')
         460             :       end if
         461             :
         462             :       call physics_ptend_init(ptend_cp,state%psetcols, ptend%name, ls=ptend%ls, lu=ptend%lu,  &
         463           0 :            lv=ptend%lv, lq=ptend%lq)
         464             :
         465           0 :       ptend_cp%top_level = ptend%top_level
         466           0 :       ptend_cp%bot_level = ptend%bot_level
         467             :
         468           0 :       ncol = subcol_get_ncol(state%lchnk)
         469           0 :       call subcol_get_indcol(state%lchnk, indcol)
         470             :
         471             :       ! Copy the grid column data into each of the subcolumns - indcol contains the grid index for each subcolumn
         472           0 :       if (ptend_cp%ls) then
         473           0 :          ptend_cp%s(:ncol,:) = ptend%s(indcol(:ncol),:)
         474           0 :          ptend_cp%hflux_srf(:ncol) = ptend%hflux_srf(indcol(:ncol))
         475           0 :          ptend_cp%hflux_top(:ncol) = ptend%hflux_top(indcol(:ncol))
         476             :       end if
         477             :
         478           0 :       if (ptend_cp%lu) then
         479           0 :          ptend_cp%u(:ncol,:) = ptend%u(indcol(:ncol),:)
         480           0 :          ptend_cp%taux_srf(:ncol)  = ptend%taux_srf(indcol(:ncol))
         481           0 :          ptend_cp%taux_top(:ncol)  = ptend%taux_top(indcol(:ncol))
         482             :       end if
         483             :
         484           0 :       if (ptend_cp%lv) then
         485           0 :          ptend_cp%v(:ncol,:) = ptend%v(indcol(:ncol),:)
         486           0 :          ptend_cp%tauy_srf(:ncol)  = ptend%tauy_srf(indcol(:ncol))
         487           0 :          ptend_cp%tauy_top(:ncol)  = ptend%tauy_top(indcol(:ncol))
         488             :       end if
         489             :
         490           0 :       if (any(ptend_cp%lq(:))) then
         491           0 :          ptend_cp%q(:ncol,:,:) = ptend%q(indcol(:ncol),:,:)
         492           0 :          ptend_cp%cflx_srf(:ncol,:)  = ptend%cflx_srf(indcol(:ncol),:)
         493           0 :          ptend_cp%cflx_top(:ncol,:)  = ptend%cflx_top(indcol(:ncol),:)
         494             :       end if
         495             :
         496           0 :    end subroutine subcol_ptend_copy
         497             :
         498           0 :    subroutine subcol_state_hdrinit(state, state_sc)
         499             :    !-----------------------------------------------------------------------
         500             :    ! Initialize the subcolumn state header variables
         501             :    !----------------------------------------------------------------------
         502             :       type(physics_state), intent(in)    :: state
         503             :       type(physics_state), intent(inout) :: state_sc        ! subcolumn state
         504             :
         505             :       integer :: isize
         506             :       integer :: nsubcol(pcols)
         507             :
         508           0 :       call subcol_get_nsubcol(state%lchnk, nsubcol)
         509           0 :       isize = state%ngrdcol
         510           0 :       if (size(nsubcol) < isize) then
         511           0 :          call endrun('subcol_state_hdrinit error: input nsubcol array must be dimensioned at least as large as state%ngrdcol')
         512             :       end if
         513             :
         514           0 :       state_sc%ngrdcol    = state%ngrdcol
         515           0 :       state_sc%lchnk      = state%lchnk
         516             :
         517           0 :       state_sc%psetcols   = pcols*psubcols
         518             :       ! Set count to a too-large value. It should be correctly initialized in check_energy_timestep_init
         519           0 :       state_sc%count      = pcols*psubcols*2
         520             :
         521             :       ! Set the number of set subcolumns to the total count
         522           0 :       state_sc%ncol       = subcol_get_ncol(state%lchnk)
         523             :
         524           0 :    end subroutine subcol_state_hdrinit
         525             :
         526             :    ! TYPE int,double,real
         527             :    ! DIMS 1,2
         528           0 :    subroutine subcol_field_avg_shr_{DIMS}d{TYPE}(field_sc, ngrdcol, lchnk, field,  usefilter, useweight)
         529             :    !-----------------------------------------------------------------------
         530             :    ! This is the high level subcol field averaging routine which
         531             :    ! averages a field dimensioned pcols*psubcols to a grid one dimensioned pcols
         532             :    !
         533             :    ! Its purpose is to check filter and weight settings and to subset the
         534             :    ! appropriate subsection of the field array to pass on the averaging routine
         535             :    !-----------------------------------------------------------------------
         536             :
         537             :       {VTYPE},intent(in)                      :: field_sc{DIMSTR} ! intent in
         538             :       integer, intent(in)                     :: ngrdcol          ! # grid cols
         539             :       integer, intent(in)                     :: lchnk            ! chunk index
         540             :       {VTYPE}, intent(out)                    :: field{DIMSTR}
         541             :       logical, intent(in)                     :: usefilter
         542             :       logical, intent(in)                     :: useweight
         543             :
         544             :       !
         545             :       ! Local variables
         546             :       !
         547             :       integer           :: indx, nsubcol, i, j
         548             :       integer           :: nsubcols(pcols)
         549             :
         550           0 :       field = ret_nan_{TYPE}
         551             :
         552           0 :       if (usefilter .and. .not. filter_set) then
         553           0 :         call endrun('subcol_field_avg_shr error: Cannot specify using filters when none set')
         554             :       end if
         555             :
         556           0 :       if (useweight .and. .not. weight_set) then
         557           0 :         call endrun('subcol_field_avg_shr error: Cannot specify using weights when none set')
         558             :       end if
         559             :
         560           0 :       call subcol_get_nsubcol(lchnk, nsubcols)
         561           0 :       indx = 1
         562           0 :       do i = 1, ngrdcol
         563           0 :          if (nsubcols(i) .gt. 0) then
         564           0 :            nsubcol = nsubcols(i)
         565             : #if ({DIMS} >=2)
         566           0 :            do j=1,size(field_sc,dim=2)
         567             : #endif
         568             : #if ({DIMS} == 1)
         569           0 :              field(i)=subcol_avg_inter(field_sc(indx:indx+nsubcol-1), lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         570             : #endif
         571             : #if ({DIMS} == 2)
         572           0 :              field(i,j)=subcol_avg_inter(field_sc(indx:indx+nsubcol-1,j), lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         573             : #endif
         574             : #if ({DIMS} >=2)
         575             :            end do
         576             : #endif
         577           0 :            indx = indx + nsubcol
         578             :          end if
         579             :       end do
         580           0 :    end subroutine subcol_field_avg_shr_{DIMS}d{TYPE}
         581             :
         582             :
         583             :    ! TYPE int,double,real
         584             :    ! DIMS 1,2
         585           0 :    subroutine subcol_field_get_firstsubcol_{DIMS}d{TYPE}(field_sc, docheck, ngrdcol, lchnk, field)
         586             :    !-----------------------------------------------------------------------
         587             :    ! Retrieve the first subcolumn from a field dimensioned pcols*psubcols
         588             :    ! and assign to one with pcols, performing optional checking that all other subcolumns are identical
         589             :    !-----------------------------------------------------------------------
         590             :
         591             :       {VTYPE}, intent(in)                     :: field_sc{DIMSTR} ! intent in
         592             :       logical, intent(in)                     :: docheck          ! true=check, false=no check
         593             :       integer, intent(in)                     :: ngrdcol          ! # grid cols
         594             :       integer, intent(in)                     :: lchnk            ! chunk index
         595             :       {VTYPE}, intent(out)                    :: field{DIMSTR}
         596             :
         597             :       !
         598             :       ! Local variables
         599             :       !
         600             :       integer           :: indx, nsubcol, i, j, l
         601             :       integer           :: nsubcols(pcols)
         602             :
         603           0 :       call subcol_get_nsubcol(lchnk, nsubcols)
         604           0 :       field = 0
         605           0 :       indx = 1
         606           0 :       do i = 1, ngrdcol
         607           0 :          if (nsubcols(i) .gt. 0) then
         608           0 :             nsubcol = nsubcols(i)
         609             : #if ({DIMS}>=2)
         610           0 :             do j=1,size(field_sc,dim=2)
         611             : #endif
         612             :
         613             : #if ({DIMS} == 1)
         614           0 :                field(i) = field_sc(indx)
         615             : #elif ({DIMS} == 2)
         616           0 :                field(i,j) = field_sc(indx,j)
         617             : #endif
         618           0 :                if (docheck) then
         619           0 :                   do l=1,nsubcol-1
         620             : #if ({DIMS} == 1)
         621           0 :                     if (field_sc(indx) /= field_sc(indx+l)) then
         622             : #elif ({DIMS} == 2)
         623           0 :                     if (field_sc(indx,j) /= field_sc(indx+l,j)) then
         624             : #endif
         625           0 :                       call endrun('subcol_field_get_firstsubcol error: Not all subcolumn fields are identical')
         626             :                     end if
         627             :                   end do
         628             :                end if
         629             : #if ({DIMS}>=2)
         630             :             end do
         631             : #endif
         632           0 :             indx = indx + nsubcol
         633             :          end if
         634             :       end do
         635           0 :    end subroutine subcol_field_get_firstsubcol_{DIMS}d{TYPE}
         636             :
         637           0 :    subroutine subcol_ptend_avg_shr(ptend_sc, ngrdcol, lchnk, ptend, usefilter, useweight)
         638             :    !-----------------------------------------------------------------------
         639             :    ! Average a subcolumn ptend to a grid ptend
         640             :    !-----------------------------------------------------------------------
         641             :
         642             :       type(physics_ptend),  intent(in)    :: ptend_sc      ! subcolumn ptend
         643             :       integer,              intent(in)    :: ngrdcol       ! # grid cols
         644             :       integer,              intent(in)    :: lchnk         ! chunk index
         645             :       type(physics_ptend),  intent(inout) :: ptend         ! grid ptend
         646             :       logical,              intent(in)    :: usefilter
         647             :       logical,              intent(in)    :: useweight
         648             :
         649             :       !
         650             :       ! Local variables
         651             :       !
         652             :       integer           :: indx, i, j, k, nsubcol
         653             :       integer           :: nsubcols(pcols)
         654             :
         655           0 :       if (usefilter .and. .not. filter_set) then
         656           0 :          call endrun('subcol_ptend_avg_shr error: Cannot specify using filters when none set')
         657             :       end if
         658             :
         659           0 :       if (useweight .and. .not. weight_set) then
         660           0 :          call endrun('subcol_ptend_avg_shr error: Cannot specify using weights when none set')
         661             :       end if
         662             :
         663           0 :       call subcol_get_nsubcol(lchnk, nsubcols)
         664             :       ! physics_ptend_init has already been called by the master interface
         665           0 :       if (ptend%ls) then
         666           0 :          ptend%s(:,:)        = 0._r8
         667           0 :          ptend%hflux_srf(:)  = 0._r8
         668           0 :          ptend%hflux_top(:)  = 0._r8
         669           0 :          indx = 1
         670           0 :          do i = 1, ngrdcol
         671           0 :             if (nsubcols(i) > 0) then
         672             :                nsubcol = nsubcols(i)
         673           0 :                do j=1,pver
         674           0 :                   ptend%s(i,j)=subcol_avg_inter(ptend_sc%s(indx:indx+nsubcol-1,j), &
         675           0 :                        lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         676             :                end do
         677           0 :                ptend%hflux_srf(i) = subcol_avg_inter(ptend_sc%hflux_srf(indx:indx+nsubcol-1), &
         678           0 :                     lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         679           0 :                ptend%hflux_top(i) = subcol_avg_inter(ptend_sc%hflux_top(indx:indx+nsubcol-1), &
         680           0 :                     lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         681           0 :                indx = indx + nsubcol
         682             :             end if
         683             :          end do
         684             :       end if
         685           0 :       if (ptend%lu) then
         686           0 :          ptend%u(:,:)       = 0._r8
         687           0 :          ptend%taux_srf(:)  = 0._r8
         688           0 :          ptend%taux_top(:)  = 0._r8
         689           0 :          indx = 1
         690           0 :          do i = 1, ngrdcol
         691           0 :             if (nsubcols(i) > 0) then
         692             :                nsubcol = nsubcols(i)
         693           0 :                do j=1,pver
         694           0 :                   ptend%u(i,j)=subcol_avg_inter(ptend_sc%u(indx:indx+nsubcol-1,j), &
         695           0 :                        lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         696             :                end do
         697           0 :                ptend%taux_srf(i) = subcol_avg_inter(ptend_sc%taux_srf(indx:indx+nsubcol-1), &
         698           0 :                     lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         699           0 :                ptend%taux_top(i) = subcol_avg_inter(ptend_sc%taux_top(indx:indx+nsubcol-1), &
         700           0 :                     lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         701           0 :                indx = indx + nsubcol
         702             :             end if
         703             :          end do
         704             :       end if
         705           0 :       if (ptend%lv) then
         706           0 :          ptend%v(:,:)       = 0._r8
         707           0 :          ptend%tauy_srf(:)  = 0._r8
         708           0 :          ptend%tauy_top(:)  = 0._r8
         709           0 :          indx = 1
         710           0 :          do i = 1, ngrdcol
         711           0 :             if (nsubcols(i) > 0) then
         712             :                nsubcol = nsubcols(i)
         713           0 :                do j=1,pver
         714           0 :                   ptend%v(i,j)=subcol_avg_inter(ptend_sc%v(indx:indx+nsubcol-1,j), &
         715           0 :                        lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         716             :                end do
         717           0 :                ptend%tauy_srf(i) = subcol_avg_inter(ptend_sc%tauy_srf(indx:indx+nsubcol-1), &
         718           0 :                     lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         719           0 :                ptend%tauy_top(i) = subcol_avg_inter(ptend_sc%tauy_top(indx:indx+nsubcol-1), &
         720           0 :                     lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         721           0 :                indx = indx + nsubcol
         722             :             end if
         723             :          end do
         724             :       end if
         725           0 :       if (any(ptend%lq(:))) then
         726           0 :          ptend%q(:,:,:)       = 0._r8
         727           0 :          ptend%cflx_srf(:,:)  = 0._r8
         728           0 :          ptend%cflx_top(:,:)  = 0._r8
         729           0 :          indx = 1
         730           0 :          do i = 1, ngrdcol
         731           0 :             if (nsubcols(i) > 0) then
         732             :                nsubcol = nsubcols(i)
         733           0 :                do j=1,pver
         734           0 :                   do k=1, pcnst
         735           0 :                      ptend%q(i,j,k)=subcol_avg_inter(ptend_sc%q(indx:indx+nsubcol-1,j,k), &
         736           0 :                           lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         737             :                   end do
         738             :                end do
         739           0 :                do k=1,pcnst
         740           0 :                   ptend%cflx_srf(i,k) = subcol_avg_inter(ptend_sc%cflx_srf(indx:indx+nsubcol-1,k), &
         741           0 :                        lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         742           0 :                   ptend%cflx_top(i,k) = subcol_avg_inter(ptend_sc%cflx_top(indx:indx+nsubcol-1,k), &
         743           0 :                        lchnk, i, indx, indx+nsubcol-1, usefilter, useweight)
         744             :                end do
         745           0 :                indx = indx + nsubcol
         746             :             end if
         747             :          end do
         748             :       end if
         749             :
         750           0 :    end subroutine subcol_ptend_avg_shr
         751             :
         752           0 :    subroutine subcol_ptend_get_firstsubcol(ptend_sc, docheck, ngrdcol, lchnk, ptend)
         753             :    !-----------------------------------------------------------------------
         754             :    ! Retrieve the first subcolumn from a ptend field dimensioned pcols*psubcols
         755             :    ! and assign to one with pcols, performing optional check that all other subcolumns are identical
         756             :    !-----------------------------------------------------------------------
         757             :
         758             :       type(physics_ptend),  intent(in)    :: ptend_sc      ! subcolumn ptend
         759             :       logical,              intent(in)    :: docheck       ! perform check that all subcolumns match
         760             :       integer,              intent(in)    :: ngrdcol       ! # grid cols
         761             :       integer,              intent(in)    :: lchnk         ! chunk index
         762             :       type(physics_ptend),  intent(inout) :: ptend         ! grid ptend
         763             :
         764             :       !
         765             :       ! Local variables
         766             :       !
         767             :       integer           :: indx, i, j, l
         768             :       integer           :: nsubcols(pcols)
         769             :
         770           0 :       call subcol_get_nsubcol(lchnk, nsubcols)
         771             :       ! physics_ptend_init has already been called by the master interface
         772           0 :       if (ptend%ls) then
         773           0 :          ptend%s(:,:)       = 0._r8
         774           0 :          ptend%hflux_srf(:) = 0._r8
         775           0 :          ptend%hflux_top(:) = 0._r8
         776           0 :          indx = 1
         777           0 :          do i = 1, ngrdcol
         778           0 :             if (docheck) then
         779           0 :                do l=1,nsubcols(i)-1
         780           0 :                  if (any(ptend_sc%s(indx,:) /= ptend_sc%s(indx+l,:))) &
         781           0 :                     call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%s')
         782           0 :                  if (ptend_sc%hflux_srf(indx) /= ptend_sc%hflux_srf(indx+l)) &
         783           0 :                     call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%hflux_srf')
         784           0 :                  if (ptend_sc%hflux_top(indx) /= ptend_sc%hflux_top(indx+l)) &
         785           0 :                     call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%hflux_top')
         786             :                end do
         787             :             end if
         788           0 :             ptend%s(i,:)          = ptend_sc%s(indx,:)
         789           0 :             ptend%hflux_srf(i)    = ptend_sc%hflux_srf(indx)
         790           0 :             ptend%hflux_top(i)    = ptend_sc%hflux_top(indx)
         791           0 :             indx = indx + nsubcols(i)
         792             :          end do
         793             :       end if
         794           0 :       if (ptend%lu) then
         795           0 :          ptend%u(:,:)       = 0._r8
         796           0 :          ptend%taux_srf(:)  = 0._r8
         797           0 :          ptend%taux_top(:)  = 0._r8
         798           0 :          indx = 1
         799           0 :          do i = 1, ngrdcol
         800           0 :             do l=1,nsubcols(i)-1
         801           0 :               if (any(ptend_sc%u(indx,:) /= ptend_sc%u(indx+l,:))) &
         802           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%u')
         803           0 :               if (ptend_sc%taux_srf(indx) /= ptend_sc%taux_srf(indx+l)) &
         804           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%taux_srf')
         805           0 :               if (ptend_sc%taux_top(indx) /= ptend_sc%taux_top(indx+l)) &
         806           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%taux_top')
         807             :             end do
         808           0 :             ptend%u(i,:)      = ptend_sc%u(indx,:)
         809           0 :             ptend%taux_srf(i) = ptend_sc%taux_srf(indx)
         810           0 :             ptend%taux_top(i) = ptend_sc%taux_top(indx)
         811           0 :             indx = indx + nsubcols(i)
         812             :          end do
         813             :       end if
         814           0 :       if (ptend%lv) then
         815           0 :          ptend%v(:,:)       = 0._r8
         816           0 :          ptend%tauy_srf(:)  = 0._r8
         817           0 :          ptend%tauy_top(:)  = 0._r8
         818           0 :          indx = 1
         819           0 :          do i = 1, ngrdcol
         820           0 :             do l=1,nsubcols(i)-1
         821           0 :               if (any(ptend_sc%v(indx,:) /= ptend_sc%v(indx+l,:))) &
         822           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%v')
         823           0 :               if (ptend_sc%tauy_srf(indx) /= ptend_sc%tauy_srf(indx+l)) &
         824           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%tauy_srf')
         825           0 :               if (ptend_sc%tauy_top(indx) /= ptend_sc%tauy_top(indx+l)) &
         826           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%tauy_top')
         827             :             end do
         828           0 :             ptend%v(i,:)         = ptend_sc%v(indx,:)
         829           0 :             ptend%tauy_srf(i)    = ptend_sc%tauy_srf(indx)
         830           0 :             ptend%tauy_top(i)    = ptend_sc%tauy_top(indx)
         831           0 :             indx = indx + nsubcols(i)
         832             :          end do
         833             :       end if
         834           0 :       if (any(ptend%lq(:))) then
         835           0 :          ptend%q(:,:,:)       = 0._r8
         836           0 :          ptend%cflx_srf(:,:)  = 0._r8
         837           0 :          ptend%cflx_top(:,:)  = 0._r8
         838           0 :          indx = 1
         839           0 :          do i = 1, ngrdcol
         840           0 :             do l=1,nsubcols(i)-1
         841           0 :               if (any(ptend_sc%q(indx,:,:) /= ptend_sc%q(indx+l,:,:))) &
         842           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%q')
         843           0 :               if (any(ptend_sc%cflx_srf(indx,:) /= ptend_sc%cflx_srf(indx+l,:))) &
         844           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%cflx_srf')
         845           0 :               if (any(ptend_sc%cflx_top(indx,:) /= ptend_sc%cflx_top(indx+l,:))) &
         846           0 :                    call endrun('subcol_ptend_get_firstsubcol error: Not all subcolumn fields are identical for ptend%cflx_top')
         847             :             end do
         848           0 :             ptend%q(i,:,:)         = ptend_sc%q(indx,:,:)
         849           0 :             ptend%cflx_srf(i,:)    = ptend_sc%cflx_srf(indx,:)
         850           0 :             ptend%cflx_top(i,:)    = ptend_sc%cflx_top(indx,:)
         851           0 :             indx = indx + nsubcols(i)
         852             :          end do
         853             :       end if
         854             :
         855           0 :    end subroutine subcol_ptend_get_firstsubcol
         856             :
         857             :    ! TYPE int,double,real
         858           0 :    {VTYPE} function subcol_avg_inter_{TYPE}(vals, lchnk, icol, indx1, indx2, usefilter, useweight) result(avgs)
         859             :    !------------------------------------------------------------------
         860             :    ! This function handles the transformation of the usefilter and useweight logicals to passing the
         861             :    ! actual fields which subcol_avg requires based on the values of the logicals
         862             :    !------------------------------------------------------------------
         863             :
         864             :       {VTYPE},intent(in)  :: vals(:)
         865             :       integer, intent(in) :: lchnk
         866             :       integer, intent(in) :: icol
         867             :       integer, intent(in) :: indx1
         868             :       integer, intent(in) :: indx2
         869             :       logical, intent(in) :: usefilter
         870             :       logical, intent(in) :: useweight
         871             :
         872             :       integer :: nsubcol(pcols)
         873             :
         874           0 :       call subcol_get_nsubcol(lchnk, nsubcol)
         875           0 :       if (usefilter .and. useweight) then
         876           0 :          avgs = subcol_avg(vals,nsubcol(icol),filter=filter2d(indx1:indx2,lchnk),weight=weight2d(indx1:indx2,lchnk))
         877           0 :       else if (useweight) then
         878           0 :          avgs = subcol_avg(vals,nsubcol(icol),weight=weight2d(indx1:indx2,lchnk))
         879           0 :       else if (usefilter) then
         880           0 :          avgs = subcol_avg(vals, nsubcol(icol),filter=filter2d(indx1:indx2,lchnk))
         881             :       else
         882           0 :          avgs = subcol_avg(vals,nsubcol(icol))
         883             :       end if
         884             :
         885           0 :    end function subcol_avg_inter_{TYPE}
         886             :
         887             :    ! TYPE int,double,real
         888           0 :    {VTYPE} function subcol_avg_{TYPE}(vals, nsubcol, filter, weight) result(avgs)
         889             :    !------------------------------------------------------------------
         890             :    ! This function performs the averaging of subcolumn fields, using the optional &
         891             :    ! filters and weights appropriately
         892             :    !------------------------------------------------------------------
         893             :
         894             :      {VTYPE},  intent(in)           :: vals(:)
         895             :      integer,  intent(in)           :: nsubcol
         896             :      integer,  intent(in), optional :: filter(:)
         897             :      real(r8), intent(in), optional :: weight(:)
         898             :
         899             :      integer :: icnt
         900             :      {VTYPE} :: fillval
         901             :
         902           0 :      fillval = fillval_{TYPE}
         903             :
         904           0 :      if (present(filter) .and. present(weight)) then
         905           0 :         if (any(filter==1).and. sum(weight,mask=(filter==1)) /=0 ) then
         906           0 :            avgs = sum(vals*weight, mask=(filter==1)) /  sum(weight, mask=(filter==1))
         907             :         else
         908             :            avgs = fillval
         909             :         end if
         910           0 :      else if (present(weight)) then
         911           0 :         if (sum(weight) /=0 ) then
         912           0 :            avgs = sum(vals*weight) / sum(weight)
         913             :         else
         914             :            avgs = fillval
         915             :         end if
         916           0 :      else if (present(filter)) then
         917           0 :         if (any(filter==1)) then
         918           0 :            icnt = count(filter==1)
         919           0 :            avgs = sum(vals, mask=(filter==1)) / icnt
         920             :         else
         921             :            avgs = fillval
         922             :         end if
         923           0 :      else if (nsubcol /= 0) then
         924           0 :         avgs = sum(vals) / nsubcol
         925             :      else
         926             :         avgs = fillval
         927             :      end if
         928             :
         929           0 :    end function subcol_avg_{TYPE}
         930             :
         931           0 :    subroutine subcol_utils_init_restart(File, hdimids)
         932             :
         933             :      use pio,             only: file_desc_t, pio_int, pio_double
         934             :      use cam_pio_utils,   only: cam_pio_def_dim, cam_pio_def_var
         935             :      use subcol_pack_mod, only: subcol_pack_init_restart
         936             :
         937             :      ! Dummy arguments
         938             :      type(file_desc_t), intent(inout) :: File
         939             :      integer,           intent(in)    :: hdimids(:)
         940             :
         941             :      ! Local variable
         942           0 :      integer, allocatable          :: adimids(:)
         943             :
         944           0 :      call subcol_pack_init_restart(File, hdimids)
         945             :
         946             :      ! Storing filter and weight data even if not being filled by the current
         947             :      !     subcolumn generator. While these are 2-D arrays, they don't match
         948             :      !     the grid so we will have to recast them as 3-D
         949             :
         950             :      ! We will need a dimid for the subcol dimension
         951             :      call cam_pio_def_dim(File, 'psubcols', psubcols, subcol_dimid,           &
         952           0 :           existOK=.true.)
         953           0 :      allocate(adimids(size(hdimids,1) + 1))
         954           0 :      adimids(1:size(hdimids)) = hdimids(:)
         955           0 :      adimids(size(hdimids) + 1) = subcol_dimid
         956             :
         957           0 :      call cam_pio_def_var(File, 'FILTER2D', pio_int,    adimids, filter2d_desc)
         958           0 :      call cam_pio_def_var(File, 'WEIGHT2D', pio_double, adimids, weight2d_desc)
         959             :
         960           0 :    end subroutine subcol_utils_init_restart
         961             :
         962           0 :    subroutine subcol_utils_write_restart(File)
         963             :      use cam_grid_support, only: cam_grid_write_dist_array
         964           0 :      use cam_grid_support, only: cam_grid_id, cam_grid_dimensions
         965             :      use ppgrid,           only: begchunk, endchunk
         966             :      use subcol_pack_mod,  only: subcol_unpack
         967             :      use subcol_pack_mod,  only: subcol_pack_write_restart
         968             :      use pio,              only: file_desc_t
         969             :
         970             :      ! Dummy argument
         971             :      type(file_desc_t), intent(inout) :: File
         972             :
         973             :      ! Local variables
         974             :      integer                          :: c
         975             :      integer                          :: adimlens(3)
         976             :      integer                          :: fdimlens(3)
         977             :      integer                          :: frank
         978             :      integer                          :: grid_id
         979           0 :      integer,  allocatable            :: unpacked_i(:,:,:)
         980           0 :      real(r8), allocatable            :: unpacked_r(:,:,:)
         981             :      character(len=*), parameter      :: subname = 'SUBCOL_UTILS_WRITE_RESTART'
         982             :
         983             :      ! File dimensions
         984           0 :      grid_id = cam_grid_id('physgrid')
         985           0 :      call cam_grid_dimensions(grid_id, fdimlens(1:2), frank)
         986             :
         987             :      ! Write nsubcol2d
         988           0 :      call subcol_pack_write_restart(File, grid_id, fdimlens(1:frank))
         989             :
         990             :      ! filter2d and weight2d are 3-D variables
         991           0 :      fdimlens(frank + 1) = psubcols
         992           0 :      frank = frank + 1
         993             :
         994             :      ! Write filter2d
         995           0 :      adimlens(1) = pcols
         996           0 :      adimlens(2) = psubcols
         997           0 :      adimlens(3) = endchunk - begchunk + 1
         998           0 :      if ((pcols * psubcols) /= size(filter2d, 1)) then
         999           0 :        call endrun(trim(subname)//": Unsupported size for FILTER2D")
        1000             :      end if
        1001             :      ! Unpack filter2d for proper output
        1002           0 :      allocate(unpacked_i(pcols, psubcols, begchunk:endchunk))
        1003           0 :      do c = begchunk, endchunk
        1004           0 :        call subcol_unpack(c, filter2d(:,c), unpacked_i(:,:,c), 0)
        1005             :      end do
        1006             :      call cam_grid_write_dist_array(File, grid_id, adimlens,                  &
        1007           0 :              fdimlens(1:frank), unpacked_i, filter2d_desc)
        1008           0 :      deallocate(unpacked_i)
        1009             :
        1010             :      ! Write weight2d
        1011           0 :      adimlens(1) = pcols
        1012           0 :      adimlens(2) = psubcols
        1013           0 :      adimlens(3) = endchunk - begchunk + 1
        1014           0 :      if ((pcols * psubcols) /= size(weight2d, 1)) then
        1015           0 :        call endrun(trim(subname)//": Unsupported size for WEIGHT2D")
        1016             :      end if
        1017             :      ! Unpack weight2d for proper output
        1018           0 :      allocate(unpacked_r(pcols, psubcols, begchunk:endchunk))
        1019           0 :      do c = begchunk, endchunk
        1020           0 :        call subcol_unpack(c, weight2d(:,c), unpacked_r(:,:,c), 0.0_r8)
        1021             :      end do
        1022             :      call cam_grid_write_dist_array(File, grid_id, adimlens,                  &
        1023           0 :              fdimlens(1:frank), unpacked_r, weight2d_desc)
        1024           0 :      deallocate(unpacked_r)
        1025             :
        1026           0 :    end subroutine subcol_utils_write_restart
        1027             :
        1028           0 :    subroutine subcol_utils_read_restart(File)
        1029           0 :      use pio,              only: file_desc_t, pio_inq_varid
        1030             :      use cam_pio_utils,    only: cam_pio_handle_error
        1031             :      use cam_grid_support, only: cam_grid_id, cam_grid_read_dist_array
        1032             :      use cam_grid_support, only: cam_grid_dimensions
        1033             :      use ppgrid,           only: begchunk, endchunk
        1034             :      use subcol_pack_mod,  only: subcol_pack
        1035             :      use subcol_pack_mod,  only: subcol_pack_read_restart
        1036             :
        1037             :      ! Dummy argument
        1038             :      type(file_desc_t), intent(inout) :: File
        1039             :
        1040             :      integer                          :: ierr, c
        1041             :      integer                          :: adimlens(3)
        1042             :      integer                          :: fdimlens(3)
        1043             :      integer                          :: grid_id
        1044             :      integer                          :: frank
        1045           0 :      integer,  allocatable            :: unpacked_i(:,:,:)
        1046           0 :      real(r8), allocatable            :: unpacked_r(:,:,:)
        1047             :      character(len=*), parameter      :: subname = 'SUBCOL_UTILS_READ_RESTART'
        1048             :      integer,  allocatable            :: nsubcol2d(:,:)
        1049             :
        1050           0 :      call subcol_allocate_internal()
        1051             :
        1052             :      ! File dimensions
        1053           0 :      grid_id = cam_grid_id('physgrid')
        1054           0 :      call cam_grid_dimensions(grid_id, fdimlens(1:2), frank)
        1055           0 :      call subcol_pack_read_restart(File, grid_id, fdimlens(1:frank))
        1056             :
        1057           0 :      ierr = pio_inq_varid(File, 'FILTER2D', filter2d_desc)
        1058           0 :      call cam_pio_handle_error(ierr, trim(subname)//': FILTER2D not found')
        1059             :      ! Array dimensions
        1060           0 :      adimlens(1) = pcols
        1061           0 :      adimlens(2) = psubcols
        1062           0 :      adimlens(3) = endchunk - begchunk + 1
        1063           0 :      if ((pcols * psubcols) /= size(filter2d, 1)) then
        1064           0 :        call endrun(trim(subname)//": Unsupported size for FILTER2D")
        1065             :      end if
        1066           0 :      allocate(unpacked_i(pcols, psubcols, begchunk:endchunk))
        1067             :      ! File dimensions (good for both filter2d and weight2d)
        1068           0 :      frank = frank + 1
        1069           0 :      fdimlens(frank) = psubcols
        1070             :      call cam_grid_read_dist_array(File, grid_id, adimlens,                   &
        1071           0 :           fdimlens(1:frank), unpacked_i, filter2d_desc)
        1072             :      ! Pack filter2d for proper output
        1073           0 :      do c = begchunk, endchunk
        1074           0 :        call subcol_pack(c, unpacked_i(:,:,c), filter2d(:,c))
        1075             :      end do
        1076           0 :      deallocate(unpacked_i)
        1077             :
        1078           0 :      ierr = pio_inq_varid(File, 'WEIGHT2D', weight2d_desc)
        1079           0 :      adimlens(1) = pcols
        1080           0 :      adimlens(2) = psubcols
        1081           0 :      adimlens(3) = endchunk - begchunk + 1
        1082           0 :      if ((pcols * psubcols) /= size(weight2d, 1)) then
        1083           0 :        call endrun(trim(subname)//": Unsupported size for WEIGHT2D")
        1084             :      end if
        1085           0 :      allocate(unpacked_r(pcols, psubcols, begchunk:endchunk))
        1086           0 :      call cam_pio_handle_error(ierr, trim(subname)//': WEIGHT2D not found')
        1087             :      call cam_grid_read_dist_array(File, grid_id, adimlens,                   &
        1088           0 :           fdimlens(1:frank), unpacked_r, weight2d_desc)
        1089             :      ! Pack weight2d for proper output
        1090           0 :      do c = begchunk, endchunk
        1091           0 :        call subcol_pack(c, unpacked_r(:,:,c), weight2d(:,c))
        1092             :      end do
        1093           0 :      deallocate(unpacked_r)
        1094             :
        1095           0 :    end subroutine subcol_utils_read_restart
        1096             :
        1097             : end module subcol_utils

Generated by: LCOV version 1.14