LCOV - code coverage report
Current view: | top level - physics/cam - physics_buffer.F90.in (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 326 | 608 | 53.6 %
Date: | 2025-01-13 21:54:50 |  | Functions: | 40 | 125 | 32.0 %

              Line data    Source code
           1             : !#define DEBUG 1
           2             : module physics_buffer
           3             :
           4             :   !-----------------------------------------------------------------------
           5             :   !
           6             :   ! Purpose:
           7             :   !    Buffer managment for persistant variables
           8             :   !
           9             :   ! Author: J. Edwards
          10             :   !
          11             :   ! This file is used with genf90.pl to generate buffer.F90
          12             :   !
          13             :   !-----------------------------------------------------------------------
          14             :
          15             :   use shr_kind_mod,   only: r8 => shr_kind_r8, r4=> shr_kind_r4, i4=> shr_kind_i4
          16             :   use ppgrid,         only: pcols, begchunk, endchunk, psubcols
          17             :   use cam_logfile,    only: iulog
          18             :   use pio,            only: var_desc_t
          19             :   use dyn_grid,       only: ptimelevels
          20             :   use cam_abortutils, only: endrun
          21             :   use buffer,         only: buffer_field_allocate, buffer_field_deallocate, buffer_get_field_ptr, buffer_set_field, &
          22             :                             dtype_i4, dtype_r4, dtype_r8, buffer_field_default_type, buffer_field_is_alloc
          23             :
          24             :   implicit none
          25             :   private
          26             :
          27             :   ! ngrid_types is a private parameter denoting how many types of a field
          28             :   ! (e.g., grid, subcol) a pbuf can hold
          29             :   integer, parameter :: ngrid_types = 2
          30             :
          31             :   ! --col_type parameters -- see pbuf_add_field and pbuf_get_field
          32             :   ! -- These indices should start at 1 and increment by 1 so that they
          33             :   ! -- may be used in a loop from 1 to ngrid_types
          34             :
          35             :   integer, parameter, public :: col_type_grid    = 1
          36             :   integer, parameter, public :: col_type_subcol  = 2
          37             :
          38             :   !
          39             :   ! PBUF field suffix strings for different grid types for restart files
          40             :   !      NB: There should be ngrid_types entries
          41             :   !
          42             :   character(len=5), parameter :: field_grid_suff(ngrid_types) = (/ "     ", "_SCOL" /)
          43             :
          44             :   integer :: old_time_idx = 1
          45             :
          46             :   ! The API has strings 'GLOBAL' and 'PHYSPKG' which correspond to these
          47             :   ! integer constants if global_allocate_all is false fields allocated with
          48             :   ! PHYSPKG persistence are deallocated at the end of each physics time step
          49             :   ! and reallocated at the beginning of the next.
          50             :   ! If global_allocate_all is true then all fields are allocated at model
          51             :   ! start and persist until model completion.
          52             :
          53             :   integer, parameter :: persistence_global  = 1
          54             :   integer, parameter :: persistence_physpkg = 2
          55             :   logical            :: global_allocate_all = .true.
          56             :
          57             :   !
          58             :   ! physics_buffer_hdr carries the description info for each buffer, only one header
          59             :   ! is allocated for each field and each chunk of the field points to it.
          60             :   ! It is carried as a linkedlist for initialization only.
          61             :   !
          62             :
          63             :   type physics_buffer_hdr
          64             :      character(len=16) :: name                    = ''
          65             :      integer           :: dtype                   = -1
          66             :      integer           :: persistence             = -1
          67             :      integer           :: dimsizes(6,ngrid_types) = 0
          68             :      type(var_desc_t)  :: vardesc(ngrid_types)  ! var id for restart files
          69             :      logical           :: is_copy(ngrid_types)    = .false.
          70             :      logical           :: added                   = .false.
          71             :      type(physics_buffer_hdr), pointer :: nexthdr => null()
          72             :
          73             :   end type physics_buffer_hdr
          74             :
          75             :   !
          76             :   ! The default type for a buffer field is buffer_field_double (r8) since that is the
          77             :   ! type most often used in the model.   The F90 transfer function is used to move
          78             :   ! data of other types into and out of the pbuf2d
          79             :   !
          80             :
          81             :   type physics_buffer_desc
          82             :      private
          83             :      integer                           :: lchnk
          84             :      type(physics_buffer_hdr), pointer :: hdr => null()
          85             :      type(buffer_field_default_type)   :: bfg(ngrid_types)
          86             :      logical                           :: used = .false.
          87             :   end type physics_buffer_desc
          88             :
          89             :   interface pbuf_get_field
          90             :      ! TYPE int,double,real
          91             :      ! DIMS 1,2,3,4,5
          92             :      module procedure get_pbuf1d_field_by_index_{DIMS}d_{TYPE}
          93             :      ! TYPE int,double,real
          94             :      ! DIMS 1,2,3,4,5
          95             :      module procedure get_pbuf2d_field_by_index_{DIMS}d_{TYPE}
          96             :   end interface
          97             :
          98             :   interface pbuf_get_field_restart
          99             :      ! TYPE int,double,real
         100             :      module procedure get_pbuf2d_field_restart_{TYPE}
         101             :   end interface
         102             :
         103             :   interface pbuf_set_field
         104             :      ! TYPE int,double,real
         105             :      ! DIMS 1,2,3,4,5
         106             :      module procedure  set_pbuf2d_field_by_index_{DIMS}d_{TYPE}
         107             :      ! TYPE int,double,real
         108             :      ! DIMS 1,2,3,4,5
         109             :      module procedure  set_pbuf1d_field_by_index_{DIMS}d_{TYPE}
         110             :      ! TYPE int,double,real
         111             :      module procedure  set_pbuf1d_field_const_by_index_{TYPE}
         112             :      ! TYPE int,double,real
         113             :      module procedure  set_pbuf2d_field_const_by_index_{TYPE}
         114             :   end interface
         115             :
         116             :   interface pbuf_add_field
         117             :      ! TYPE int,double,real
         118             :      module procedure pbuf_add_field_{TYPE}
         119             :   end interface
         120             :
         121             :   public :: pbuf_initialize,      &
         122             :             pbuf_readnl,          &! read namelist options
         123             :             pbuf_init_time,       &! Initialize dyn_time_lvls
         124             :             pbuf_old_tim_idx,     &! return the index for the oldest time
         125             :             pbuf_update_tim_idx,  &! update the index for the oldest time
         126             :             pbuf_col_type_index,  &
         127             :             pbuf_get_field_name,  &
         128             :             pbuf_get_field,       &
         129             :             pbuf_add_field,       &
         130             :             pbuf_register_subcol, &
         131             :             physics_buffer_desc,  &
         132             :             pbuf_get_index,       &
         133             :             pbuf_get_chunk,       &
         134             :             pbuf_allocate,        &
         135             :             pbuf_deallocate,      &
         136             :             pbuf_set_field,       &
         137             :             pbuf_init_restart,    &
         138             :             pbuf_write_restart,   &
         139             :             pbuf_read_restart,    &
         140             :             pbuf_is_used,         &
         141             :             dtype_r8, dtype_r4, dtype_i4
         142             :
         143             :   ! For help debugging code
         144             :   public :: pbuf_dump_pbuf
         145             :
         146             :   ! For snapshot use
         147             :   public :: pbuf_get_dim_strings
         148             :   public :: pbuf_cam_snapshot_register
         149             :
         150             :    integer, public :: dyn_time_lvls  ! number of time levels in physics buffer (dycore dependent)
         151             :
         152             :
         153             :   !
         154             :   !  Currentpbufflds is incremented in calls to pbuf_add_field and determines the size
         155             :   !  of the allocated pbuf2d
         156             :   !
         157             :
         158             :   integer :: currentpbufflds=0
         159             :   type(physics_buffer_hdr), pointer :: hdrbuffertop => null()
         160             :
         161             :   !
         162             :   ! Insures that we do not attempt to allocate physics_buffer more than once
         163             :   !
         164             :
         165             :   logical :: buffer_initialized =.false.
         166             :
         167             :   !
         168             :   ! private pio descriptor for time
         169             :   !
         170             :   type(var_desc_t) :: timeidx_desc
         171             :
         172             :   ! Set to .true. for more output
         173             :   logical :: debug = .false.
         174             :
         175             : !===============================================================================
         176             : CONTAINS
         177             : !===============================================================================
         178             :
         179           0 : subroutine pbuf_readnl(nlfile)
         180             :
         181             :    use namelist_utils,  only: find_group_name
         182             :    use units,           only: getunit, freeunit
         183             :    use spmd_utils,      only: masterproc, mpicom, mstrid=>masterprocid, mpi_logical
         184             :
         185             :    character(len=*), intent(in) :: nlfile  ! filepath for file containing namelist input
         186             :
         187             :    ! Local variables
         188             :    integer :: unitn, ierr
         189             :    character(len=*), parameter :: sub = 'pbuf_readnl'
         190             :
         191             :    logical :: pbuf_global_allocate
         192             :
         193             :    namelist /pbuf_nl/ pbuf_global_allocate
         194             :    !-----------------------------------------------------------------------------
         195             :
         196           0 :    pbuf_global_allocate = global_allocate_all
         197             :
         198             :    ! Read namelist
         199           0 :    if (masterproc) then
         200           0 :       unitn = getunit()
         201           0 :       open( unitn, file=trim(nlfile), status='old' )
         202           0 :       call find_group_name(unitn, 'pbuf_nl', status=ierr)
         203           0 :       if (ierr == 0) then
         204           0 :          read(unitn, pbuf_nl, iostat=ierr)
         205           0 :          if (ierr /= 0) then
         206           0 :             call endrun(sub//': FATAL: reading namelist')
         207             :          end if
         208             :       end if
         209           0 :       close(unitn)
         210           0 :       call freeunit(unitn)
         211             :    end if
         212             :
         213           0 :    call mpi_bcast(pbuf_global_allocate, 1, mpi_logical, mstrid, mpicom, ierr)
         214           0 :    if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: pbuf_global_allocate")
         215             :
         216           0 :    global_allocate_all = pbuf_global_allocate
         217             :
         218           0 :    if (masterproc) then
         219           0 :       write(iulog,*) 'physics buffer options:'
         220           0 :       write(iulog,*) '  pbuf_global_allocate =', global_allocate_all
         221             :    end if
         222             :
         223           0 : end subroutine pbuf_readnl
         224             :
         225             : !===============================================================================
         226             :
         227             :   !
         228             :   ! Initialize dyn_time_lvls
         229             :   !
         230        1536 :   subroutine pbuf_init_time()
         231        1536 :      dyn_time_lvls = ptimelevels - 1
         232        1536 :   end subroutine pbuf_init_time
         233             :
         234             :   !
         235             :   ! Return index of oldest time sample in the physics buffer.
         236             :   !
         237             :
         238    11204424 :   function pbuf_old_tim_idx()
         239             :      integer :: pbuf_old_tim_idx
         240    11204424 :      pbuf_old_tim_idx = old_time_idx
         241    11204424 :   end function pbuf_old_tim_idx
         242             :
         243             :   !
         244             :   ! Update index of old time sample in the physics buffer.
         245             :   !
         246             :
         247      369408 :   subroutine pbuf_update_tim_idx()
         248      369408 :      old_time_idx = mod(old_time_idx, dyn_time_lvls) + 1
         249      369408 :   end subroutine pbuf_update_tim_idx
         250             :
         251             :   !
         252             :   ! pbuf_col_type_index returns an index for use with pbuf calls
         253             :   !
         254             :   ! * col_type:         is set to col_type_grid (if use_subcol=.false.) or
         255             :   !                     col_type_subcol (if (use_subcol=.true.).
         256             :   !
         257             :
         258           0 :   subroutine pbuf_col_type_index(use_subcol, col_type)
         259             :
         260             :     logical,                  intent(in)  :: use_subcol
         261             :     integer,                  intent(out) :: col_type
         262             :
         263           0 :     if (use_subcol) then
         264           0 :       col_type = col_type_subcol
         265             :     else
         266           0 :       col_type = col_type_grid
         267             :     end if
         268             :
         269           0 :   end subroutine pbuf_col_type_index
         270             :
         271             :   !
         272             :   !  Return a pointer to the current chunks physics_buffer.
         273             :   !
         274             :
         275           0 :   function pbuf_get_field_name(index)
         276             :     integer, intent(in) :: index
         277             :     character(len=16) :: pbuf_get_field_name
         278             :     integer :: i
         279             :     type(physics_buffer_hdr), pointer :: hdrbuffer
         280             :
         281           0 :     hdrbuffer => hdrbuffertop
         282           0 :     do i=2,index
         283           0 :        hdrbuffer=>hdrbuffer%nexthdr
         284             :     end do
         285           0 :     pbuf_get_field_name = hdrbuffer%name
         286             :
         287           0 :   end function pbuf_get_field_name
         288             :
         289             :
         290    22716096 :   function pbuf_get_chunk(pbuf2d, lchnk)
         291             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
         292             :     integer, intent(in) :: lchnk
         293             :
         294             :     type(physics_buffer_desc), pointer :: pbuf_get_chunk(:)
         295             :
         296    22716096 :     pbuf_get_chunk => pbuf2d(:,lchnk)
         297             :
         298             :
         299             :   end function pbuf_get_chunk
         300             :
         301             :   !
         302             :   !  Return .true. iff pbuf has an allocated grid field
         303             :   !
         304             :
         305             :   logical function pbuf_field_has_gridcols(pbuf, index) result(rval)
         306             :
         307             :     type(physics_buffer_desc), pointer                :: pbuf(:)
         308             :     integer,                            intent(in)    :: index
         309             :
         310             :     ! If the field is a copy, return .false. even if it is allocated
         311             :     if (pbuf(index)%hdr%is_copy(col_type_grid)) then
         312             :       rval = .false.
         313             :     else
         314             :       rval = buffer_field_is_alloc(pbuf(index)%bfg(col_type_grid))
         315             :     end if
         316             :
         317             :   end function pbuf_field_has_gridcols
         318             :
         319             :   !
         320             :   !  Return .true. iff pbuf has an allocated subcolumn field
         321             :   !
         322             :
         323             :   logical function pbuf_field_has_subcols(pbuf, index) result(rval)
         324             :
         325             :     type(physics_buffer_desc), pointer                :: pbuf(:)
         326             :     integer,                            intent(in)    :: index
         327             :
         328             :     ! If the field is a copy, return .false. even if it is allocated
         329             :     if (pbuf(index)%hdr%is_copy(col_type_subcol)) then
         330             :       rval = .false.
         331             :     else
         332             :       rval = buffer_field_is_alloc(pbuf(index)%bfg(col_type_subcol))
         333             :     end if
         334             :
         335             :   end function pbuf_field_has_subcols
         336             :
         337             :   !
         338             :   !  Return .true. iff pbuf has an allocated col_type column field
         339             :   !
         340             :
         341             :   logical function pbuf_field_has_col_type(pbuf, index, col_type) result(rval)
         342             :
         343             :     type(physics_buffer_desc), pointer                :: pbuf(:)
         344             :     integer,                            intent(in)    :: index
         345             :     integer,                            intent(in)    :: col_type
         346             :
         347             :     if (col_type == col_type_grid) then
         348             :       rval = pbuf_field_has_gridcols(pbuf, index)
         349             :     else if(col_type == col_type_subcol) then
         350             :       rval = pbuf_field_has_subcols(pbuf, index)
         351             :     else
         352             :       call endrun('pbuf_field_has_col_type: Invalid col_type')
         353             :     end if
         354             :
         355             :   end function pbuf_field_has_col_type
         356             :
         357             :   !
         358             :   !  Initialize the buffer, should be called after all pbuf_add_field calls
         359             :   !  have been completed and should only be called once in a run
         360             :   !
         361        2304 :   subroutine pbuf_initialize(pbuf2d)
         362             :     use phys_grid, only: phys_grid_initialized
         363             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
         364             :
         365             :     integer :: i, c
         366             :     type(physics_buffer_hdr), pointer :: hdrbuffer
         367             :
         368             :     !
         369             :     ! Allocate memory
         370             :     !
         371        2304 :     if (buffer_initialized) return
         372        1536 :     if (.not. phys_grid_initialized()) then
         373           0 :        call endrun('pbuf_initialize: Physics decomposition not initialized')
         374             :     end if
         375             :     ! Allocate at least 1 to avoid unallocated error in ideal physics
         376      739872 :     allocate(pbuf2d(max(1,currentpbufflds),begchunk:endchunk))
         377        1536 :     if(currentpbufflds<1) return
         378             :
         379        7728 :     do c = begchunk, endchunk
         380        6192 :       hdrbuffer => hdrbuffertop
         381      732192 :       do i = 1, currentpbufflds
         382      724464 :         if(.not. hdrbuffer%added) then
         383           0 :           call endrun('pbuf_initialize: pbuf, '//trim(hdrbuffer%name)//', not added')
         384             :         end if
         385      724464 :         pbuf2d(i,c)%lchnk = c
         386      724464 :         pbuf2d(i,c)%hdr => hdrbuffer
         387      730656 :         hdrbuffer => hdrbuffer%nexthdr
         388             :       end do
         389             :     end do
         390             :
         391        1536 :     buffer_initialized=.true.
         392        1536 :     call pbuf_allocate(pbuf2d, 'global')
         393             : #ifdef DEBUG
         394        1536 :     call pbuf2d_print(pbuf2d)
         395             : #endif
         396        1536 :     return
         397        2304 :   end subroutine pbuf_initialize
         398             :
         399             :
         400      372480 :   subroutine pbuf_allocate(pbuf2d, persistence)
         401             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
         402             :     character(len=*), intent(in) :: persistence
         403             :     integer :: i
         404             :     logical :: allocate_all
         405             :
         406             :     ! allocate_all is used to force allocation of all fields at same time as allocation
         407             :     ! for global scope.
         408      372480 :     allocate_all = .false.
         409      372480 :     if ( global_allocate_all ) then
         410      372480 :        if ( persistence == 'global' ) then
         411             :           allocate_all = .true.
         412             :        else
         413      370944 :           return
         414             :        end if
         415             :     end if
         416             :
         417             :     if(allocate_all) then
         418      181248 :        do i=1,currentpbufflds
         419      181248 :           select case(pbuf2d(i,begchunk)%hdr%dtype)
         420             :           case(TYPEDOUBLE)
         421      173568 :              call pbuf_allocate_field_double(pbuf2d, i, dtype_r8)
         422             :           case(TYPEREAL)
         423           0 :              call pbuf_allocate_field_real(pbuf2d, i, dtype_r4)
         424             : !          case(i8)
         425             : !             call pbuf_allocate_field_long(pbuf2d, i)
         426             :           case(TYPEINT)
         427      179712 :              call pbuf_allocate_field_int(pbuf2d, i, dtype_i4)
         428             :           end select
         429             :        end do
         430           0 :     else if(persistence .eq. 'physpkg') then
         431           0 :        do i=1,currentpbufflds
         432           0 :           if(pbuf2d(i,begchunk)%hdr%persistence==persistence_physpkg) then
         433           0 :              select case(pbuf2d(i,begchunk)%hdr%dtype)
         434             :              case(TYPEDOUBLE)
         435           0 :                 call pbuf_allocate_field_double(pbuf2d, i, dtype_r8)
         436             :              case(TYPEREAL)
         437           0 :                 call pbuf_allocate_field_real(pbuf2d, i, dtype_r4)
         438             : !             case(i8)
         439             : !                call pbuf_allocate_field_long(pbuf2d, i)
         440             :              case(TYPEINT)
         441           0 :                 call pbuf_allocate_field_int(pbuf2d, i, dtype_i4)
         442             :              end select
         443             :           end if
         444             :        end do
         445           0 :     else if(persistence .eq. 'global') then
         446           0 :        do i=1,currentpbufflds
         447           0 :           if(pbuf2d(i,begchunk)%hdr%persistence==persistence_global) then
         448             :
         449           0 :              select case(pbuf2d(i,begchunk)%hdr%dtype)
         450             :              case(TYPEDOUBLE)
         451           0 :                 call pbuf_allocate_field_double(pbuf2d, i, dtype_r8)
         452             :              case(TYPEREAL)
         453           0 :                 call pbuf_allocate_field_real(pbuf2d, i, dtype_r4)
         454             : !             case(i8)
         455             : !                call pbuf_allocate_field_long(pbuf2d, i)
         456             :              case(TYPEINT)
         457           0 :                 call pbuf_allocate_field_int(pbuf2d, i, dtype_i4)
         458             :              end select
         459             :           end if
         460             :        end do
         461             :     end if
         462        2304 :   end subroutine pbuf_allocate
         463             :
         464             :   ! TYPE int,double,real
         465      179712 :   subroutine pbuf_allocate_field_{TYPE}(pbuf2d, index, dtype)
         466             :     {VTYPE},                            intent(in)    :: dtype
         467             :     type(physics_buffer_desc), pointer                :: pbuf2d(:,:)
         468             :     integer,                            intent(in)    :: index
         469             :
         470      179712 :     integer,                   pointer                :: dimsizes(:)
         471             :     integer                                           :: c, i
         472             :     logical                                           :: is_copy
         473             :
         474      539136 :     do i = 1, ngrid_types
         475             :        ! Note - dimsizes(:)=0 is special case to indicate "do not allocate" and is not fatal
         476             :        ! Since this is called by a single thread, setting the dimsizes pointer to first chunk is okay
         477      359424 :        dimsizes => pbuf2d(index,begchunk)%hdr%dimsizes(:,i)
         478             :        ! Note - We may have dimsizes /= 0 but still don't allocate if copy
         479      359424 :        is_copy = pbuf2d(index,begchunk)%hdr%is_copy(i)
         480             :
         481     2515968 :        if (any(dimsizes(:) < 0)) &
         482             :           call endrun('pbuf_allocate_field: dimsizes must be greater than 0 for pbuf field '&
         483           0 :                        //trim(pbuf2d(index,begchunk)%hdr%name))
         484             :
         485     1617408 :        if (all(dimsizes(:) /= 0) .and. (.not. is_copy)) then
         486      904176 :           do c = begchunk, endchunk
         487      904176 :              call buffer_field_allocate(pbuf2d(index,c)%bfg(i), dimsizes, dtype)
         488             :           end do
         489             :        end if
         490             :     end do
         491             :
         492      179712 :   end subroutine pbuf_allocate_field_{TYPE}
         493             :
         494    86800896 :   pure logical function pbuf_do_deallocate(hdr, persistence, col_type) result(rval)
         495             :     type(physics_buffer_hdr), pointer            :: hdr
         496             :     character(len=*),                 intent(in) :: persistence
         497             :     integer,                          intent(in) :: col_type
         498             :
         499    86800896 :     if (persistence .eq. 'physpkg') then
         500    86441472 :       if (hdr%is_copy(col_type)) then
         501             :         ! If this is a copied field, it is always deallocated
         502             :         rval = .true.
         503    86441472 :       else if (global_allocate_all) then
         504             :         ! This is an all-global run so no deallocation
         505             :         rval = .false.
         506           0 :       else if(hdr%persistence == persistence_physpkg) then
         507             :         ! This pbuf is a physpkg type, deallocate
         508             :         rval = .true.
         509             :       else
         510             :         ! This pbuf is global, do not deallocate
         511           0 :         rval = .false.
         512             :       end if
         513             :     else
         514             :       ! We are doing a global deallocate, everything must go!
         515             :       rval = .true.
         516             :     end if
         517    86800896 :   end function pbuf_do_deallocate
         518             :
         519      370944 :   subroutine pbuf_deallocate(pbuf2d, persistence)
         520             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
         521             :     character(len=*) :: persistence
         522             :
         523             :     integer :: i, j, c
         524             :
         525    43771392 :     do i = 1, currentpbufflds
         526   130572288 :       do j = 1, ngrid_types
         527   130201344 :         if (pbuf_do_deallocate(pbuf2d(i,begchunk)%hdr, persistence, j)) then
         528      359424 :           if (buffer_field_is_alloc(pbuf2d(i,begchunk)%bfg(j))) then
         529      353280 :              select case(pbuf2d(i,begchunk)%hdr%dtype)
         530             :              case(TYPEDOUBLE)
         531      873264 :                 do c = begchunk,endchunk
         532      873264 :                   call buffer_field_deallocate(pbuf2d(i,c)%bfg(j), dtype_r8)
         533             :                 end do
         534             :              case(TYPEREAL)
         535           0 :                 do c = begchunk,endchunk
         536           0 :                   call buffer_field_deallocate(pbuf2d(i,c)%bfg(j), dtype_r4)
         537             :                 end do
         538             :              case(TYPEINT)
         539      204480 :                 do c = begchunk,endchunk
         540       30912 :                   call buffer_field_deallocate(pbuf2d(i,c)%bfg(j), dtype_i4)
         541             :                 end do
         542             :              end select
         543             :            end if
         544             :         end if
         545             :       end do    ! ngrid_types
         546             :     end do      ! currentpbufflds
         547      370944 :   end subroutine pbuf_deallocate
         548             :
         549             :   ! Find a pbuf header pointer based on the name input
         550             :   ! Automatically tacks on an extra header if <name> is not found.
         551      179712 :   subroutine find_pbuf_header(name, index, bufptr)
         552             :     character(len=*),                 intent(in)  :: name
         553             :     type(physics_buffer_hdr), pointer             :: bufptr
         554             :     integer,                          intent(out) :: index
         555             :
         556             :     ! Local Variables
         557             :     logical                                       :: buf_found
         558             :
         559      179712 :     if(.not. associated(hdrbuffertop)) then
         560             :       ! This is the very first pbuf, allocate and set
         561       26112 :       allocate(hdrbuffertop)
         562        1536 :       currentpbufflds = 1
         563        1536 :       hdrbuffertop%name = name
         564             :     end if
         565             :
         566      179712 :     bufptr=>hdrbuffertop
         567      179712 :     buf_found = .false.
         568      179712 :     index = 1
         569    10604544 :     do while(.not. buf_found)
         570    10604544 :       if(trim(bufptr%name) == trim(name)) then
         571             :         buf_found = .true.
         572             :       else
         573    10423296 :         if (associated(bufptr%nexthdr)) then
         574    10245120 :           bufptr=>bufptr%nexthdr
         575    10245120 :           index = index + 1
         576             :         else
         577             :           ! We ran off the end of the buffers, make a new one for <name>
         578             :           ! Sanity check, we should have checked exactly currentpbufflds
         579      178176 :           if (index /= currentpbufflds) then
         580           0 :             call endrun("find_pbuf_header: currentpbufflds indexing off")
         581             :           end if
         582      178176 :           currentpbufflds = currentpbufflds + 1
         583      178176 :           index = currentpbufflds
         584     3028992 :           allocate(bufptr%nexthdr)
         585      178176 :           bufptr=>bufptr%nexthdr
         586      178176 :           bufptr%name = trim(name)
         587      178176 :           buf_found = .true.
         588             :         end if
         589             :       end if
         590             :     end do
         591      179712 :   end subroutine find_pbuf_header
         592             :   !
         593             :   !  Register a field in the pbuf
         594             :   !  This should be called from physics register routines.
         595             :   !  persistence must be 'global' or 'physpkg'
         596             :   !  dtype can be any of r8, r4, i4 as defined in shr_kinds_mod.F90
         597             :   !  col_type is either col_type_grid or col_type_subcol.
         598             :   !  If no col_type, then grid field is defined (i.e., dimsizes set)
         599             :
         600      179712 :   subroutine pbuf_register_field_int(name, pname, index, persistence,         &
         601      179712 :        dtype, dimsizes, col_type, pbuf_add)
         602             :
         603             :     ! Dummy Arguments
         604             :     character(len=*),           intent(in)  :: name
         605             :     character(len=*),           intent(in)  :: pname ! name of calling parameterization
         606             :     integer,                    intent(out) :: index
         607             :     character(len=*), optional, intent(in)  :: persistence
         608             :     integer,          optional, intent(in)  :: dtype ! used to differentiate specific calls
         609             :     integer,          optional, intent(in)  :: dimsizes(:) ! dimension sizes of grid field
         610             :     integer,          optional, intent(in)  :: col_type
         611             :     logical,          optional, intent(in)  :: pbuf_add
         612             :
         613             :
         614             :     ! Local Variables
         615             :     type(physics_buffer_hdr), pointer :: bufptr
         616             :     integer                           :: dimcnt, col_type_use
         617             :     character(len=128)                :: errmsg
         618             :
         619      179712 :     if(buffer_initialized) then
         620           0 :       call endrun('Attempt to register pbuf field after buffer initialized')
         621             :     end if
         622             :
         623      179712 :     call find_pbuf_header(name, index, bufptr)
         624             :
         625      179712 :     if (present(persistence)) then
         626      179712 :       if(persistence .eq. "global") then
         627       58368 :         bufptr%persistence = persistence_global
         628             :       else
         629      121344 :         bufptr%persistence = persistence_physpkg
         630             :       end if
         631             :     end if
         632             :
         633      179712 :     if (present(dtype)) then
         634      179712 :       bufptr%dtype = dtype
         635             :     end if
         636             :
         637      179712 :     if (present(dimsizes)) then
         638             :       ! Normally, we only set buffer dimsizes if dimsizes is passed
         639      179712 :       dimcnt = size(dimsizes)
         640             :
         641      179712 :       if (present(col_type)) then
         642      179712 :         col_type_use = col_type
         643             :       else
         644             :         col_type_use = col_type_grid
         645             :       end if
         646             :
         647             :       ! Only allow up to 5 dimensions. #6 is reserved for subcolumn umpacking
         648             :       ! and #7 is for the physics chunk index.
         649      179712 :       if (dimcnt > 5) then
         650           0 :         call endrun('pbuf_register_field: Attempt to exceed maximum of 5 dimensions for '//trim(name))
         651             :       end if
         652             :
         653             :       ! Assign dimensions dependent on col_types input
         654             :       ! Note that dimensions are initialized to zero and set if being used
         655      179712 :       if (col_type_use == col_type_grid) then
         656             :         ! grid is requested
         657     1257984 :         bufptr%dimsizes(:,col_type_grid) = 1
         658      505344 :         bufptr%dimsizes(1:dimcnt,col_type_grid) = dimsizes
         659             :         ! If someone previously registered the subcol, reset those dims
         660      179712 :         if (bufptr%dimsizes(1,col_type_subcol) == pcols*psubcols) then
         661           0 :           bufptr%dimsizes(2:dimcnt,col_type_subcol) = dimsizes(2:dimcnt)
         662             :         end if
         663           0 :       else if (col_type_use == col_type_subcol) then
         664           0 :         bufptr%dimsizes(:,col_type_subcol) = 1
         665           0 :         bufptr%dimsizes(1,col_type_subcol) = pcols*psubcols
         666             :         ! This case should only be used for a pbuf_add_field call adding a subcolumn-only field
         667           0 :         if (dimcnt > 1) then
         668           0 :           bufptr%dimsizes(2:dimcnt,col_type_subcol) = dimsizes(2:dimcnt)
         669           0 :         else if (bufptr%dimsizes(1,col_type_grid) > 0) then
         670             :           ! If grid field previously registered or added, update dims
         671           0 :           bufptr%dimsizes(2:,col_type_subcol) = bufptr%dimsizes(2:,col_type_grid)
         672             :         end if
         673             :       end if
         674             :     end if
         675             :
         676      179712 :     if (present(pbuf_add)) then
         677      179712 :       if (pbuf_add) then
         678             :         ! An add request has been made but we have to make sure we have all info
         679      179712 :         if (all(bufptr%dimsizes(:,:) == 0)) then
         680           0 :           write(errmsg, *) 'pbuf_add_field: trying to add field with no dimensions'
         681           0 :           call endrun(errmsg)
         682             :         end if
         683      179712 :         if (bufptr%dtype < 0) then
         684           0 :           write(errmsg, *) 'pbuf_add_field: trying to add field with no type'
         685           0 :           call endrun(errmsg)
         686             :         end if
         687      179712 :         if (bufptr%persistence < 0) then
         688           0 :           write(errmsg, *) 'pbuf_add_field: trying to add field with bad persistence'
         689           0 :           call endrun(errmsg)
         690             :         end if
         691      179712 :         bufptr%added = .true.
         692             :       end if
         693             :     end if
         694             :
         695      179712 :   end subroutine pbuf_register_field_int
         696             :
         697             :   !
         698             :   !  Add a field to the pbuf, this should be called from physics register routines
         699             :   !  name is required to be unique,
         700             :   !  persistence must be 'global' or 'physpkg'
         701             :   !  dtype can be any of r8, r4, i4 as defined in shr_kinds_mod.F90
         702             :   !  If present, col_type must be either col_type_grid or col_type_subcol
         703             :
         704             :   ! TYPE int,double,real
         705      179712 :   subroutine pbuf_add_field_{TYPE}(name, persistence, dtype, dimsizes, index, col_type)
         706             :
         707             :     character(len=*), intent(in)  :: name, persistence
         708             :     {VTYPE}, intent(in)           :: dtype ! used only to differentiate specific calls
         709             :     integer, intent(in)           :: dimsizes(:) ! dimension sizes of grid field
         710             :     integer, intent(in), optional :: col_type
         711             :     integer, intent(out)          :: index
         712             :
         713             :     ! Local Variables
         714             :     integer                           :: col_type_use
         715             :
         716      179712 :     if(buffer_initialized) then
         717           0 :       call endrun('Attempt to add pbuf field after buffer initialized')
         718             :     end if
         719             :
         720      179712 :     if (present(col_type)) then
         721           0 :       col_type_use = col_type
         722             :     else
         723      179712 :       col_type_use = col_type_grid
         724             :     end if
         725             :
         726             :     call pbuf_register_field_int(trim(name), '', index,                       &
         727             :          persistence=persistence, dtype={ITYPE},                              &
         728      179712 :          dimsizes=dimsizes, col_type=col_type_use, pbuf_add=.true.)
         729             :
         730      179712 :   end subroutine pbuf_add_field_{TYPE}
         731             :
         732           0 :   subroutine pbuf_register_subcol(name, pname, index)
         733             :     use subcol_utils, only: is_subcol_on
         734             :
         735             :     ! Dummy Arguments
         736             :     character(len=*),           intent(in)  :: name
         737             :     character(len=*),           intent(in)  :: pname ! name of calling parameterization
         738             :     integer,                    intent(out) :: index
         739             :
         740             :     ! Local variables
         741             :     integer                                 :: dimsizes(1)
         742             :
         743             :     ! You really should not call this routine if subcolumns are not on
         744           0 :     if (.not. is_subcol_on()) then
         745           0 :       call endrun('pbuf_register_subcol: subcolumns are not active')
         746             :     end if
         747             :     ! Create and pass dimsizes so that subcolums are registered
         748           0 :     dimsizes(1) = pcols * psubcols
         749             :     call pbuf_register_field_int(trim(name), trim(pname), index,              &
         750           0 :          dimsizes=dimsizes, col_type=col_type_subcol)
         751             :
         752           0 :   end subroutine pbuf_register_subcol
         753             :
         754        1536 :   subroutine pbuf2d_print(pbuf2d)
         755             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
         756             :
         757        1536 :     call pbuf1d_print(pbuf_get_chunk(pbuf2d,begchunk))
         758             :
         759             :
         760           0 :   end subroutine pbuf2d_print
         761             :
         762        1536 :   subroutine pbuf1d_print(pbuf)
         763             :     use spmd_utils, only: masterproc
         764             :
         765             :     type(physics_buffer_desc), pointer :: pbuf(:)
         766             :
         767             :     integer                            :: ind
         768             :     type(physics_buffer_desc), pointer :: pbufPtr
         769             :
         770        1536 :     if (masterproc .and. debug) then
         771           0 :        write(iulog, *) __FILE__, __LINE__, currentpbufflds, size(pbuf)
         772           0 :        do ind = 1, currentpbufflds
         773           0 :           pbufPtr => pbuf(ind)
         774           0 :           write(iulog, *) __FILE__, __LINE__, ind, trim(pbufPtr%hdr%name),    &
         775           0 :                pbufPtr%hdr%dtype, pbufPtr%hdr%persistence, pbufPtr%hdr%dimsizes
         776             :        end do
         777             :     end if
         778             :
         779        1536 :   end subroutine pbuf1d_print
         780             :   !
         781             :   ! Given a pbuf field name return an integer index to the field.
         782             :   ! This index can be used to retrieve the field and is much faster
         783             :   ! than using the name in most cases
         784             :   !
         785             :
         786    22590936 :   function pbuf_get_index(name, errcode) result(index)
         787             :     character(len=*), intent(in)     :: name
         788             :     integer, intent(inout), optional :: errcode
         789             :     integer :: index
         790             :     integer :: i
         791             :     type(physics_buffer_hdr), pointer :: bufptr
         792             :
         793             :
         794    22590936 :     bufptr=>hdrbuffertop
         795    22590936 :     index = -1
         796  1189803672 :     do i=1,currentpbufflds
         797  1188298320 :        if(bufptr%name .eq. name) then
         798             :           index=i
         799             :           exit
         800             :        end if
         801  1168718088 :        bufptr=>bufptr%nexthdr
         802             :     end do
         803             :
         804    22590936 :     if (present(errcode)) then
         805    15015888 :         errcode = index
         806     7575048 :     else if(index<0) then
         807           0 :        call endrun('Attempt to find undefined name in pbuf '//trim(name))
         808             :     end if
         809             :
         810             :
         811    22590936 :   end function pbuf_get_index
         812             :
         813             :   !=========================================================================================
         814             :
         815             :   !
         816             :   ! Given a pbuf2d chunk and an index return a pointer to a field chunk
         817             :   !
         818             :   !
         819             :
         820             :
         821             :   ! TYPE int,double,real
         822             :   ! DIMS 1,2,3,4,5
         823   302850720 :   subroutine get_pbuf1d_field_by_index_{DIMS}d_{TYPE}(pbuf, index, field, start,kount, col_type, copy_if_needed, errcode)
         824             :
         825             :     ! Get the data based on the col_type which is specified.  If no col_type, then grid field is returned
         826   302850720 :     use subcol_utils,    only: subcol_field_copy
         827             :
         828             :     type(physics_buffer_desc), pointer:: pbuf(:)
         829             :     integer,             intent(in)               :: index
         830             :     {VTYPE},    pointer                           :: field{DIMSTR}
         831             :     integer,             intent(in),  optional    :: start(:),kount(:)
         832             :     integer,             intent(in),  optional    :: col_type
         833             :     logical,             intent(in),  optional    :: copy_if_needed
         834             :     integer,             intent(out), optional    :: errcode
         835             :
         836   302850720 :     integer,    pointer               :: dimsizes(:)
         837   302850720 :     {VTYPE},    pointer               :: gfield{DIMSTR}
         838   302850720 :     {VTYPE},    pointer               :: sfield{DIMSTR}
         839             :     integer                           :: col_type_use
         840   302850720 :     integer, allocatable              :: kount_grid(:) ! For use in copy_if_needed
         841             :     logical                           :: subset
         842             :     character(len=*), parameter       :: subname='GET_PBUF1D_FIELD_BY_INDEX'
         843             :     character(len=128)                :: errmsg
         844             :
         845             :     ! Copy the generic type to one compatable with the request
         846   302850720 :     if((index < 1) .or. (index > size(pbuf))) then
         847           0 :       write(errmsg, '(2a,i0,a)') subname,': index (',index,') out of range'
         848           0 :       call endrun(errmsg)
         849             :     end if
         850             :
         851             :     ! Default col_type is grid columns
         852   302850720 :     if (present(col_type)) then
         853      235296 :       col_type_use = col_type
         854             :     else
         855             :       col_type_use = col_type_grid
         856             :     end if
         857             :
         858             :     ! If there is an errcode, start with an OK status (zero)
         859   302850720 :     if (present(errcode)) then
         860           0 :       errcode = 0
         861             :     end if
         862             :
         863             :     ! Check whether subset of data requested (default is false)
         864   302850720 :     subset = .false.
         865   302850720 :     if (present(start) .and. present(kount)) subset = .true.
         866             :
         867             :     ! Check for ill-formed request
         868   302850720 :     if ( (present(start) .and. .not. present(kount)) .or.        &
         869             :          (.not. present(start) .and. present(kount)) ) then
         870           0 :       call endrun('pbuf_get_field: Both start and kount must be present for '//trim(pbuf(index)%hdr%name))
         871             :     end if
         872             :
         873             :     ! See if we need to copy the grid field to subcolumns
         874   302850720 :     if (present(copy_if_needed)) then
         875           0 :       if (copy_if_needed) then
         876           0 :         if (col_type_use == col_type_subcol) then
         877             :           ! If a subcolumn field buffer does not exist, allocate one.
         878             :           ! Even if start and kount are being passed, allocate and copy the
         879             :           ! full grid field buffer so that a future access will succeed.
         880           0 :           if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_use))) then
         881           0 :             dimsizes => pbuf(index)%hdr%dimsizes(:,col_type_use)
         882           0 :             dimsizes(2:) = pbuf(index)%hdr%dimsizes(2:,col_type_grid)
         883           0 :             dimsizes(1) = pcols * psubcols
         884           0 :             select case(pbuf(index)%hdr%dtype)
         885             :             case(TYPEDOUBLE)
         886             :               call buffer_field_allocate(pbuf(index)%bfg(col_type_subcol),       &
         887           0 :                    dimsizes, dtype_r8)
         888             :             case(TYPEREAL)
         889             :               call buffer_field_allocate(pbuf(index)%bfg(col_type_subcol),       &
         890           0 :                    dimsizes, dtype_r4)
         891             :             case(TYPEINT)
         892             :               call buffer_field_allocate(pbuf(index)%bfg(col_type_subcol),       &
         893           0 :                    dimsizes, dtype_i4)
         894             :             end select
         895             :             ! Set copy only if we did the allocation after init time
         896           0 :             pbuf(index)%hdr%is_copy(col_type_subcol) = .true.
         897             :           end if
         898             :         else
         899           0 :           call endrun('pbuf_get_field: copy_if_needed only supported for subcolumns')
         900             :         end if
         901           0 :         if (pbuf(index)%hdr%is_copy(col_type_subcol)) then
         902             :           ! Only do the copy if we did the alloc (i.e., set the is_copy flag)
         903             :           ! Only copy the portion we are going to hand back (i.e., start, kount)
         904             :           ! Chances are that kount(1) = pcols*psubcols because we are looking
         905             :           ! for a subcolumn field (or we wouldn't be here). Now,
         906             :           ! subcol_field_copy requires kount(1) = pcols for the input and
         907             :           ! therefore, kount(1) = pcols*psubcols for the output. Check and
         908             :           ! make it work
         909             :
         910           0 :           if (subset) then
         911             :
         912             :             ! Create kount array for grid field
         913             :             ! Use input subcol kount array, replacing the first dimension with pcols
         914           0 :             if (size(kount) > size(pbuf(index)%hdr%dimsizes(:,col_type_subcol))) then
         915           0 :               call endrun('pbuf_get_field: kount input has too many dimensions')
         916             :             end if
         917           0 :             if (kount(1) /= pcols * psubcols) then
         918           0 :               call endrun('pbuf_get_field: kount(1) must be pcols*psubcols when using copy_if_needed=.true.')
         919             :             endif
         920             :
         921           0 :             allocate(kount_grid(size(kount)))
         922           0 :             kount_grid(2:) = kount(2:)
         923           0 :             kount_grid(1) = pcols
         924             :
         925             :             ! Don't need to create start array for grid field as start array for subcolumn field is identical
         926           0 :             if (size(start) > size(pbuf(index)%hdr%dimsizes(:,col_type_subcol))) then
         927           0 :               call endrun('pbuf_get_field: start input has too many dimensions')
         928             :             end if
         929           0 :             if (start(1) /= 1) then
         930           0 :               call endrun('pbuf_get_field: start(1) must be 1 when using copy_if_needed=.true.')
         931             :             end if
         932             :
         933             :             ! Get the grid field
         934           0 :             pbuf(index)%used = .true.
         935           0 :             call buffer_get_field_ptr(pbuf(index)%bfg(col_type_grid),           &
         936           0 :                  gfield, start, kount_grid)
         937             :
         938           0 :             deallocate(kount_grid)
         939             :
         940             :           else
         941             :             ! Get the grid field
         942           0 :             pbuf(index)%used = .true.
         943           0 :             call buffer_get_field_ptr(pbuf(index)%bfg(col_type_grid),           &
         944           0 :                  gfield)
         945             :           end if
         946             :
         947             :           ! Get the subcol field pointer (note optional start/kount retain their status in this call)
         948           0 :           pbuf(index)%used = .true.
         949           0 :           call buffer_get_field_ptr(pbuf(index)%bfg(col_type_subcol),            &
         950           0 :                sfield, start, kount)
         951             :
         952           0 :           call subcol_field_copy(gfield, pbuf(index)%lchnk, sfield)
         953             :
         954             :         end if
         955             :       end if
         956             :     end if
         957             :
         958             :     ! Copy or not, retrieve the requested field pointer
         959   302850720 :     if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_use))) then
         960           0 :        if (present(errcode)) then
         961           0 :          errcode = -1
         962             :        else
         963           0 :          if (col_type_use == col_type_grid) then
         964             :            call endrun('pbuf_get_field: probably missing a pbuf_add_field call.  field not allocated for '&
         965           0 :                         //trim(pbuf(index)%hdr%name))
         966           0 :          else if (col_type_use == col_type_subcol) then
         967             :            call endrun('pbuf_get_field: probably missing a pbuf_register_subcol.  field not allocated for '&
         968           0 :                         //trim(pbuf(index)%hdr%name))
         969             :          else
         970           0 :            call endrun('pbuf_get_field:  field not allocated for '//trim(pbuf(index)%hdr%name))
         971             :          end if
         972             :        end if
         973             :     else
         974             :         ! Get the field pointer (note optional start/kount retain their status in this call)
         975   302850720 :        pbuf(index)%used = .true.
         976   826396704 :        call buffer_get_field_ptr(pbuf(index)%bfg(col_type_use),field,start,kount )
         977             :     end if
         978             :
         979   605701440 :   end subroutine get_pbuf1d_field_by_index_{DIMS}d_{TYPE}
         980             :
         981             :   ! TYPE int,double,real
         982             :   ! DIMS 1,2,3,4,5
         983     1730664 :   subroutine get_pbuf2d_field_by_index_{DIMS}d_{TYPE}(pbuf2d, lchnk, index, field, start, kount, col_type, errcode)
         984             :
         985             :     ! Get the data based on the col_type which is specified.  If no col_type, then grid field is returned
         986             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
         987             :     integer, intent(in) :: lchnk
         988             :     integer, intent(in) :: index
         989             :     integer, intent(in),  optional :: start(:),kount(:)
         990             :     integer, intent(in),  optional :: col_type
         991             :     integer, intent(out), optional :: errcode
         992             :
         993             :     {VTYPE}, pointer :: field{DIMSTR}
         994             :
         995             :     ! Check for ill-formed request
         996     1730664 :     if ( (present(start) .and. .not. present(kount)) .or.&
         997             :          (.not. present(start) .and. present(kount)) ) then
         998           0 :       call endrun('pbuf_get_field: Both start and kount must be present for '//trim(pbuf2d(index,begchunk)%hdr%name))
         999             :     end if
        1000             :
        1001             :     call pbuf_get_field(pbuf_get_chunk(pbuf2d,lchnk), index, field,           &
        1002     5191992 :          start=start, kount=kount, col_type=col_type, errcode=errcode)
        1003     1730664 :   end subroutine get_pbuf2d_field_by_index_{DIMS}d_{TYPE}
        1004             :
        1005             :   ! TYPE int,double,real
        1006      235296 :   subroutine get_pbuf2d_field_restart_{TYPE}(pbuf2d, lchnk, index, field, mdimsize, col_type)
        1007             :     use subcol_pack_mod, only: subcol_unpack
        1008             :
        1009             :     ! NB: This routine is really only useful for write_restart_field
        1010             :     ! Get the data based on the col_type which is specified.
        1011             :     ! If no col_type, then grid field is assumed
        1012             :     ! For grid field, reference buffer and copy into chunk (field)
        1013             :     ! If col_type is a subcol, unpack subcolumn data
        1014             :     ! Field is then reshaped into (/pcols, psubcols*mdims/).
        1015             :
        1016             :     ! Dummy variables
        1017             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
        1018             :     integer, intent(in)                :: lchnk
        1019             :     integer, intent(in)                :: index
        1020             :     integer, intent(in)                :: mdimsize
        1021             :     integer, intent(in)                :: col_type
        1022             :     {VTYPE}, intent(inout)             :: field(:,:)
        1023             :
        1024             :     ! Local variables
        1025      235296 :     {VTYPE},      allocatable          :: exp_fld(:,:,:,:,:,:)
        1026      235296 :     {VTYPE},                   pointer :: buf(:,:,:,:,:)
        1027             :     {VTYPE}                            :: fillvalue
        1028             :     character(len=128)                 :: errmsg
        1029      235296 :     integer,                   pointer :: dimsizes(:)
        1030             :
        1031             : #if ({ITYPE}==TYPEREAL)
        1032           0 :     fillvalue = 0._r4
        1033             : #elif ({ITYPE}==TYPEDOUBLE)
        1034      235296 :     fillvalue = 0._r8
        1035             : #else
        1036           0 :     fillvalue = 0
        1037             : #endif
        1038             :
        1039      235296 :     if (col_type == col_type_grid) then
        1040      235296 :       call pbuf_get_field(pbuf2d, lchnk, index, buf, col_type=col_type)
        1041      705888 :       field(:,:) = reshape(buf, (/pcols, mdimsize/))
        1042           0 :     else if (col_type == col_type_subcol) then
        1043             :       ! Don't initialize field, unpack will fill in unused slots
        1044           0 :       call pbuf_get_field(pbuf2d, lchnk, index, buf, col_type=col_type)
        1045           0 :       dimsizes => pbuf2d(index, lchnk)%hdr%dimsizes(:,col_type_subcol)
        1046           0 :       allocate(exp_fld(pcols, psubcols, dimsizes(2), dimsizes(3), dimsizes(4), dimsizes(5)))
        1047             :       ! unpack the subcolumns into their own dimension
        1048           0 :       call subcol_unpack(lchnk, buf, exp_fld, fillvalue)
        1049             :       ! Reshape back to pcols for outputting
        1050           0 :       field(:,:) = reshape(exp_fld, (/pcols, mdimsize/))
        1051           0 :       deallocate(exp_fld)
        1052             :     else
        1053           0 :       write(errmsg, *) "get_pbuf2d_field_restart_{TYPE}: Bad col_type:",col_type
        1054           0 :       call endrun(errmsg)
        1055             :     end if
        1056      470592 :   end subroutine get_pbuf2d_field_restart_{TYPE}
        1057             :
        1058             :   ! TYPE int,double,real
        1059             :   ! DIMS 1,2,3,4,5
        1060       13056 :   subroutine set_pbuf2d_field_const_by_index_{TYPE}(pbuf2d,index,const, col_type)
        1061             :
        1062             :     ! Set the field specified by the col_type
        1063             :
        1064             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
        1065             :     integer, intent(in)                :: index
        1066             :     {VTYPE},intent(in)                 :: const
        1067             :     integer,intent(in)  ,optional      :: col_type
        1068             :
        1069             :     integer :: c
        1070             :
        1071       65688 :     do c=begchunk,endchunk
        1072       65688 :        if(present(col_type)) then
        1073           0 :           call set_pbuf1d_field_const_by_index_{TYPE}(pbuf_get_chunk(pbuf2d,c),index,const, col_type=col_type)
        1074             :        else
        1075       52632 :           call set_pbuf1d_field_const_by_index_{TYPE}(pbuf_get_chunk(pbuf2d,c),index,const)
        1076             :        end if
        1077             :     end do
        1078             :
        1079       13056 :   end subroutine set_pbuf2d_field_const_by_index_{TYPE}
        1080             :
        1081             :   ! TYPE int,double,real
        1082             :   ! DIMS 1,2,3,4,5
        1083       52632 :   subroutine set_pbuf1d_field_const_by_index_{TYPE}(pbuf,index,const,start,kount, col_type)
        1084             :
        1085             :     ! Set the field(s) specified by the col_type
        1086             :     type(physics_buffer_desc), pointer :: pbuf(:)
        1087             :     integer, intent(in) :: index
        1088             :     {VTYPE},intent(in) :: const
        1089             :     integer, intent(in), optional :: start(:),kount(:)
        1090             :     integer, intent(in), optional :: col_type
        1091             :
        1092             :     integer :: col_type_use
        1093             :     logical :: subset
        1094             :
        1095             :     ! Default col_type is grid
        1096       52632 :     if (present(col_type)) then
        1097           0 :       col_type_use = col_type
        1098             :     else
        1099             :       col_type_use = col_type_grid
        1100             :     end if
        1101             :
        1102             :     ! Check whether subset of data requested (default is false)
        1103       52632 :     subset = .false.
        1104       52632 :     if (present(start) .and. present(kount)) subset = .true.
        1105             :
        1106             :     ! Check for ill-formed request
        1107       52632 :     if ( (present(start) .and. .not. present(kount)) .or.&
        1108             :          (.not. present(start) .and. present(kount)) ) then
        1109           0 :        call endrun('pbuf_set_field: Both start and kount must be present for '//trim(pbuf(index)%hdr%name))
        1110             :     end if
        1111             :
        1112             :     ! Set the appropriate grid or sub-column field.  Check that the fields have been allocated.
        1113       52632 :     if(subset) then
        1114             :
        1115           0 :        if (col_type_use == col_type_subcol) then
        1116             :          ! Set sub-column field
        1117           0 :          if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_subcol))) &
        1118           0 :               call endrun('pbuf_set_field: sub-column field not allocated for '//trim(pbuf(index)%hdr%name))
        1119           0 :          pbuf(index)%used = .true.
        1120           0 :          call buffer_set_field(pbuf(index)%bfg(col_type_subcol),const,start,kount)
        1121             :
        1122           0 :        else if (col_type_use == col_type_grid) then
        1123             :          ! Set grid field
        1124           0 :          if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_grid))) &
        1125           0 :               call endrun('pbuf_set_field: grid field not allocated for '//trim(pbuf(index)%hdr%name))
        1126           0 :          pbuf(index)%used = .true.
        1127           0 :          call buffer_set_field(pbuf(index)%bfg(col_type_grid),const,start,kount)
        1128             :        else
        1129           0 :          call endrun('pbuf_set_field: Trying to set '//trim(pbuf(index)%hdr%name)//&
        1130           0 :               ' but col_type is neither col_type_grid nor col_type_subcol')
        1131             :        end if
        1132             :
        1133             :      else
        1134             :
        1135       52632 :        if (col_type_use == col_type_subcol) then
        1136             :          ! Set sub-column field
        1137           0 :          if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_subcol))) &
        1138           0 :               call endrun('pbuf_set_field: sub-column field not allocated for '//trim(pbuf(index)%hdr%name))
        1139           0 :          pbuf(index)%used = .true.
        1140           0 :          call buffer_set_field(pbuf(index)%bfg(col_type_subcol),const)
        1141             :
        1142       52632 :        else if (col_type_use == col_type_grid) then
        1143             :          ! Set grid field
        1144       52632 :          if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_grid))) &
        1145           0 :               call endrun('pbuf_set_field: grid field not allocated for '//trim(pbuf(index)%hdr%name))
        1146       52632 :          pbuf(index)%used = .true.
        1147       52632 :          call buffer_set_field(pbuf(index)%bfg(col_type_grid),const)
        1148             :        else
        1149           0 :          call endrun('pbuf_set_field: Trying to set '//trim(pbuf(index)%hdr%name)//&
        1150           0 :               ' but col_type is neither col_type_grid nor col_type_subcol')
        1151             :        end if
        1152             :
        1153             :      end if
        1154             :
        1155       52632 :    end subroutine set_pbuf1d_field_const_by_index_{TYPE}
        1156             :
        1157             :   ! TYPE int,double,real
        1158             :   ! DIMS 1,2,3,4,5
        1159        4608 :   subroutine set_pbuf2d_field_by_index_{DIMS}d_{TYPE}(pbuf2d,index,field, start, kount, col_type)
        1160             :
        1161             :     ! Set the field(s) specified by the col_type
        1162             :     type(physics_buffer_desc), pointer :: pbuf2d(:,:)
        1163             :     integer, intent(in) :: index
        1164             :     integer,intent(in),optional :: start(:), kount(:)
        1165             :     integer,intent(in),optional :: col_type
        1166             :
        1167             :     logical :: subset
        1168             :
        1169             :     integer :: c
        1170        4608 :     {VTYPE}, pointer :: fld{DIMSTR}
        1171             :
        1172             :
        1173             : #if ({DIMS}==1)
        1174             :     {VTYPE},pointer :: field(:,:)
        1175             : #elif ({DIMS}==2)
        1176             :     {VTYPE},pointer :: field(:,:,:)
        1177             : #elif ({DIMS}==3)
        1178             :     {VTYPE},pointer :: field(:,:,:,:)
        1179             : #elif ({DIMS}==4)
        1180             :     {VTYPE},pointer :: field(:,:,:,:,:)
        1181             : #elif ({DIMS}==5)
        1182             :     {VTYPE},pointer :: field(:,:,:,:,:,:)
        1183             : #endif
        1184             :
        1185             :     ! Check whether subset of data requested (default is false)
        1186        4608 :     subset = .false.
        1187        2304 :     if (present(start) .and. present(kount)) subset = .true.
        1188             :
        1189             :     ! Check for ill-formed request
        1190        4608 :     if ( (present(start) .and. .not. present(kount)) .or.&
        1191             :          (.not. present(start) .and. present(kount)) ) then
        1192           0 :       call endrun('pbuf_set_field: Both start and kount must be present for '//trim(pbuf2d(index,begchunk)%hdr%name))
        1193             :     end if
        1194             :
        1195       23184 :     do c=begchunk,endchunk
        1196       18576 :       fld => get_field_chunk_{DIMS}d_{TYPE}(field,c)
        1197       23184 :       if(subset .and. present(col_type)) then
        1198           0 :         call pbuf_set_field(pbuf_get_chunk(pbuf2d,c),index,fld,start,kount, col_type)
        1199       18576 :       else if(subset) then
        1200        9288 :         call pbuf_set_field(pbuf_get_chunk(pbuf2d,c),index,fld,start,kount)
        1201        9288 :       else if(present(col_type)) then
        1202           0 :         call pbuf_set_field(pbuf_get_chunk(pbuf2d,c),index,fld,col_type=col_type)
        1203             :       else
        1204        9288 :         call pbuf_set_field(pbuf_get_chunk(pbuf2d,c),index,fld)
        1205             :       end if
        1206             :     end do
        1207        4608 :   end subroutine set_pbuf2d_field_by_index_{DIMS}d_{TYPE}
        1208             :
        1209             :   ! TYPE int,double,real
        1210             :   ! DIMS 1,2,3,4,5
        1211       18576 :   function get_field_chunk_{DIMS}d_{TYPE}(field, c) result(fld)
        1212             :     ! module private helper function
        1213             :     {VTYPE}, pointer :: fld{DIMSTR}
        1214             :     integer, intent(in) :: c
        1215             :
        1216             : #if ({DIMS}==1)
        1217             :     {VTYPE},pointer :: field(:,:)
        1218        9288 :     fld => field(:,c)
        1219             : #elif ({DIMS}==2)
        1220             :     {VTYPE},pointer :: field(:,:,:)
        1221        9288 :     fld => field(:,:,c)
        1222             : #elif ({DIMS}==3)
        1223             :     {VTYPE},pointer :: field(:,:,:,:)
        1224           0 :     fld => field(:,:,:,c)
        1225             : #elif ({DIMS}==4)
        1226             :     {VTYPE},pointer :: field(:,:,:,:,:)
        1227           0 :     fld => field(:,:,:,:,c)
        1228             : #elif ({DIMS}==5)
        1229             :     {VTYPE},pointer :: field(:,:,:,:,:,:)
        1230           0 :     fld => field(:,:,:,:,:,c)
        1231             : #endif
        1232             :
        1233       18576 :   end function get_field_chunk_{DIMS}d_{TYPE}
        1234             :
        1235             :
        1236             :
        1237             :   ! TYPE int,double,real
        1238             :   ! DIMS 1,2,3,4,5
        1239     5984568 :   subroutine set_pbuf1d_field_by_index_{DIMS}d_{TYPE}(pbuf,index,field, start, kount, col_type)
        1240             :
        1241             :     type(physics_buffer_desc), pointer :: pbuf(:)
        1242             :     integer, intent(in) :: index
        1243             :     {VTYPE}, intent(in) :: field{DIMSTR}
        1244             :     integer,intent(in),optional :: start(:), kount(:)
        1245             :     integer,intent(in),optional :: col_type
        1246             :
        1247             :     integer :: col_type_use
        1248             :     logical :: subset
        1249             :
        1250             :     ! Default col_type is grid only
        1251     5984568 :     if (present(col_type)) then
        1252           0 :       col_type_use = col_type
        1253             :     else
        1254             :       col_type_use = col_type_grid
        1255             :     end if
        1256             :
        1257             :     ! Check whether subset of data requested (default is false)
        1258     5984568 :     subset = .false.
        1259     5984568 :     if (present(start) .and. present(kount)) subset = .true.
        1260             :
        1261             :     ! Check for ill-formed request
        1262     5984568 :     if ( (present(start) .and. .not. present(kount)) .or.&
        1263             :          (.not. present(start) .and. present(kount)) ) then
        1264           0 :        call endrun('pbuf_set_field: Both start and kount must be present for '//trim(pbuf(index)%hdr%name))
        1265             :     end if
        1266             :
        1267     5984568 :     if(subset) then
        1268             :
        1269             :        ! Set sub-column field
        1270     2993832 :        if (col_type_use == col_type_subcol) then
        1271           0 :           if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_subcol))) &
        1272           0 :               call endrun('pbuf_set_field: sub-column field not allocated for '//trim(pbuf(index)%hdr%name))
        1273           0 :           pbuf(index)%used = .true.
        1274           0 :           call buffer_set_field(pbuf(index)%bfg(col_type_subcol),field,start,kount)
        1275             :
        1276             :        ! Set grid field
        1277     2993832 :        else if (col_type_use == col_type_grid) then
        1278     2993832 :           if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_grid))) &
        1279           0 :                  call endrun('pbuf_set_field: grid field not allocated for '//trim(pbuf(index)%hdr%name))
        1280     2993832 :           pbuf(index)%used = .true.
        1281     2993832 :           call buffer_set_field(pbuf(index)%bfg(col_type_grid),field,start,kount)
        1282             :        else
        1283           0 :          call endrun('pbuf_set_field: Trying to set '//trim(pbuf(index)%hdr%name)//&
        1284           0 :                     ' but col_type is neigher col_type_grid nor col_type_subcol ')
        1285             :        end if
        1286             :     else
        1287             :
        1288             :        ! Set sub-column field
        1289     2990736 :        if (col_type_use == col_type_subcol) then
        1290           0 :           if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_subcol))) &
        1291           0 :               call endrun('pbuf_set_field: sub-column field not allocated for '//trim(pbuf(index)%hdr%name))
        1292           0 :           pbuf(index)%used = .true.
        1293           0 :           call buffer_set_field(pbuf(index)%bfg(col_type_subcol),field)
        1294             :
        1295             :        ! Set grid field
        1296     2990736 :        else if (col_type_use == col_type_grid) then
        1297     2990736 :           if (.not. buffer_field_is_alloc(pbuf(index)%bfg(col_type_grid))) &
        1298           0 :                  call endrun('pbuf_set_field: grid field not allocated for '//trim(pbuf(index)%hdr%name))
        1299     2990736 :           pbuf(index)%used = .true.
        1300     2990736 :           call buffer_set_field(pbuf(index)%bfg(col_type_grid),field)
        1301             :        else
        1302           0 :          call endrun('pbuf_set_field: Trying to set '//trim(pbuf(index)%hdr%name)//&
        1303           0 :                     ' but col_type is neither col_type_grid nor col_type_subcol ')
        1304             :        end if
        1305             :     endif
        1306             :
        1307     5984568 :   end subroutine set_pbuf1d_field_by_index_{DIMS}d_{TYPE}
        1308             :
        1309             :
        1310       58368 :   function pbuftype2piotype(pbuftype) result(piotype)
        1311             :     use pio, only : pio_double, pio_int, pio_real
        1312             :
        1313             :     integer, intent(in) :: pbuftype
        1314             :     integer :: piotype
        1315             :
        1316       58368 :     select case(pbuftype)
        1317             :     case (TYPEDOUBLE)
        1318           0 :        piotype = pio_double
        1319             :     case(TYPEINT)
        1320           0 :        piotype = pio_int
        1321             :     case(TYPEREAL)
        1322           0 :        piotype = pio_real
        1323             : !    case(TYPELONG)
        1324             : !       piotype = pio_int
        1325             :     case default
        1326           0 :        write(iulog, *) 'Dtype = ', pbuftype
        1327       58368 :        call endrun('No restart support for dtype')
        1328             :     end select
        1329       58368 :   end function pbuftype2piotype
        1330             :
        1331             :
        1332             : !
        1333             : ! Initialize a restart file to write - all additional dims in a field are
        1334             : ! bundled into a single dimension for output and a dim pbuf_xxxxx is declared
        1335             : ! in the file if it does not already exist.
        1336             : !
        1337        1536 :   subroutine pbuf_init_restart(File, pbuf2d)
        1338             :     use pio,              only: file_desc_t, pio_int
        1339             :     use cam_pio_utils,    only: cam_pio_def_dim, cam_pio_def_var
        1340             :     use phys_grid,        only: phys_decomp
        1341             :     use cam_grid_support, only: cam_grid_get_file_dimids, cam_grid_dimensions
        1342             :
        1343             :
        1344             :     ! Dummy Variables
        1345             :     type(file_desc_t),                 intent(inout) :: file
        1346             :     type(physics_buffer_desc), pointer               :: pbuf2d(:,:)
        1347             :
        1348             :     ! Local Variables
        1349             :     type(physics_buffer_desc), pointer               :: pbuf
        1350             :     integer                                          :: i, grid_select
        1351             :     integer                                          :: adimid(3) ! PIO IDs
        1352             :     integer                                          :: hdimcnt ! # grid dims
        1353             :     integer                                          :: dimcnt  ! # array dims
        1354             :     integer                                          :: mdimsize, piodtype
        1355             :
        1356             :     character(len=10)                                :: dimname
        1357             :     character(len=24)                                :: varname
        1358             :
        1359             :     ! Use adimid as a temp to find number of horizontal dims
        1360        1536 :     call cam_grid_dimensions(phys_decomp, adimid(1:2), hdimcnt)
        1361        1536 :     call cam_grid_get_file_dimids(phys_decomp, File, adimid)
        1362             :
        1363      181248 :     do i = 1, currentpbufflds
        1364      179712 :       pbuf => pbuf2d(i,begchunk)
        1365             :
        1366             :       ! Only save global pbufs for restart
        1367      179712 :       if(pbuf%hdr%persistence /= persistence_global) cycle
        1368             :
        1369       58368 :       piodtype = pbuftype2piotype(pbuf%hdr%dtype)
        1370             :
        1371      176640 :       do grid_select = 1, ngrid_types
        1372             :         ! For subcol fields, mdimsize includes psubcols in size
        1373      817152 :         mdimsize  = product(pbuf%hdr%dimsizes(:,grid_select))/pcols
        1374      116736 :         if(mdimsize > 1) then
        1375       32256 :           write(dimname,'(a,i5.5)') 'pbuf_',mdimsize
        1376       32256 :           call cam_pio_def_dim(File, dimname, mdimsize, adimid(hdimcnt+1),    &
        1377       64512 :                existOK=.true.)
        1378       32256 :           dimcnt = hdimcnt + 1
        1379             :         else
        1380       84480 :           dimcnt = hdimcnt
        1381             :         end if
        1382      296448 :         if (mdimsize > 0) then
        1383       58368 :           varname = trim(pbuf%hdr%name)//trim(field_grid_suff(grid_select))
        1384           0 :           call cam_pio_def_var(File, varname, piodtype, adimid(1:dimcnt),     &
        1385       58368 :                pbuf%hdr%vardesc(grid_select), existOK=.false.)
        1386             :         end if
        1387             :       end do
        1388             :
        1389             :     end do
        1390             :
        1391             :     call cam_pio_def_var(File, 'pbuf_time_idx', pio_int, timeidx_desc,        &
        1392        1536 :          existOK=.false.)
        1393             :
        1394        1536 :   end subroutine pbuf_init_restart
        1395             :
        1396             :
        1397        1536 :   subroutine pbuf_write_restart(File, pbuf2d)
        1398        1536 :     use pio,              only: file_desc_t, pio_put_var
        1399             :     use cam_grid_support, only: cam_grid_dimensions
        1400             :     use phys_grid,        only: phys_decomp
        1401             :
        1402             :     ! Dummy Variables
        1403             :     type(file_desc_t),                 intent(inout) :: file
        1404             :     type(physics_buffer_desc), pointer               :: pbuf2d(:,:)
        1405             :
        1406             :     ! Local Variables
        1407        1536 :     type(physics_buffer_desc), pointer                :: pbufhdr(:)
        1408             :
        1409             :     integer                                           :: index, dtype, ierr
        1410             :     integer                                           :: gdimlens(2)
        1411             :     integer                                           :: grank
        1412             :
        1413        1536 :     pbufhdr => pbuf_get_chunk(pbuf2d, begchunk)
        1414        4608 :     gdimlens = 1
        1415        1536 :     call cam_grid_dimensions(phys_decomp, gdimlens(1:2), grank)
        1416             :
        1417      181248 :     do index = 1, currentpbufflds
        1418      181248 :       if(pbufhdr(index)%hdr%persistence == persistence_global) then
        1419       58368 :         dtype = pbufhdr(index)%hdr%dtype
        1420       58368 :         select case(dtype)
        1421             :         case (TYPEDOUBLE)
        1422       58368 :           call write_restart_field_double(File, pbuf2d, index, gdimlens, grank)
        1423             :         case (TYPEREAL)
        1424           0 :           call write_restart_field_real(File, pbuf2d, index, gdimlens, grank)
        1425             :         case (TYPEINT)
        1426       58368 :           call write_restart_field_int(File, pbuf2d, index, gdimlens, grank)
        1427             :         end select
        1428             :       end if
        1429             :     end do
        1430        3072 :     ierr = pio_put_var(File, timeidx_desc, (/old_time_idx/))
        1431             :
        1432        3072 :   end subroutine pbuf_write_restart
        1433             :
        1434      145920 :   subroutine pbuf_restart_dimsizes(pbuf, gdimlens, grank, gridnum, adimlens,  &
        1435             :        fdimlens, frank)
        1436             :
        1437             :     ! Dummy arguments
        1438             :     type(physics_buffer_desc), pointer    :: pbuf
        1439             :     integer,                intent(in)    :: gdimlens(2) ! Grid horiz. dim sizes
        1440             :     integer,                intent(in)    :: grank       ! Array rank on file
        1441             :     integer,                intent(in)    :: gridnum     ! pbuf grid selector
        1442             :     integer,                intent(out)   :: adimlens(3) ! Array dims
        1443             :     integer,                intent(out)   :: fdimlens(3) ! Array dims on file
        1444             :     integer,                intent(out)   :: frank       ! array rank on file
        1445             :
        1446             :     ! Local variable
        1447             :     integer                             :: mdimsize
        1448             :
        1449     1021440 :     mdimsize = PRODUCT(pbuf%hdr%dimsizes(:,gridnum)) / pcols
        1450      437760 :     fdimlens(1:2) = gdimlens
        1451      145920 :     if (grank == 1) then
        1452             :       ! Unstructured grid
        1453      145920 :       fdimlens(2) = mdimsize
        1454      145920 :       fdimlens(3) = 1
        1455      145920 :       frank       = 2
        1456             :     else
        1457           0 :       fdimlens(3) = mdimsize
        1458           0 :       frank       = 3
        1459             :     end if
        1460             :     ! Restart does not write a dimension if mdimsize == 1
        1461      145920 :     if (mdimsize == 1) then
        1462       39168 :       frank = frank - 1
        1463             :     end if
        1464             :
        1465      145920 :     adimlens(1) = pcols
        1466      145920 :     adimlens(2) = mdimsize
        1467      145920 :     adimlens(3) = endchunk - begchunk + 1
        1468             :
        1469        1536 :   end subroutine pbuf_restart_dimsizes
        1470             :
        1471             :   ! TYPE int,double,real
        1472       58368 :   subroutine write_restart_field_{TYPE}(File, pbuf2d, index, gdimlens, grank)
        1473       58368 :     use cam_grid_support, only: cam_grid_write_dist_array
        1474             :     use phys_grid,        only: phys_decomp
        1475             :     use pio,              only: file_desc_t
        1476             :
        1477             :     ! Dummy Variables
        1478             :     type(file_desc_t),                 intent(inout) :: File
        1479             :     type(physics_buffer_desc), pointer               :: pbuf2d(:,:)
        1480             :     integer,                           intent(in)    :: index
        1481             :     integer,                           intent(in)    :: gdimlens(2)
        1482             :     integer,                           intent(in)    :: grank
        1483             :
        1484             :     ! Local Variables
        1485             :     type(physics_buffer_desc), pointer               :: pbuf
        1486       58368 :     {VTYPE},       allocatable                       :: field(:,:,:)
        1487             :
        1488             :     integer                                          :: grid_select ! 1=grid, 2=subcol
        1489             :     integer                                          :: c           ! Chunk index
        1490             :     integer                                          :: fdimlens(3) ! Array dimensions on NetCDF file
        1491             :     integer                                          :: adimlens(3) ! Array dimensions
        1492             :     integer                                          :: frank
        1493             :
        1494       58368 :     pbuf => pbuf2d(index, begchunk)
        1495             :
        1496      175104 :     do grid_select = 1, ngrid_types
        1497             :       call pbuf_restart_dimsizes(pbuf, gdimlens, grank, grid_select,          &
        1498      116736 :            adimlens, fdimlens, frank)
        1499      525312 :       if ((PRODUCT(adimlens) > 0) .and. (.not. pbuf%hdr%is_copy(grid_select))) then
        1500      291840 :         allocate(field(adimlens(1), adimlens(2), begchunk:endchunk))
        1501      293664 :         do c = begchunk, endchunk
        1502             :           call pbuf_get_field_restart(pbuf2d, c, index, field(:,:,c),         &
        1503      293664 :                adimlens(2), grid_select)
        1504             :         end do
        1505       58368 :         if (size(field,2) == 1) then
        1506             :           ! Special case for 2-D pbuf fields
        1507       26112 :           adimlens(2) = adimlens(3)
        1508             :           call cam_grid_write_dist_array(File, phys_decomp, adimlens(1:2),    &
        1509       26112 :                fdimlens(1:frank), field(:,1,:), pbuf%hdr%vardesc(grid_select))
        1510             :         else
        1511             :           call cam_grid_write_dist_array(File, phys_decomp, adimlens,         &
        1512       32256 :                fdimlens(1:frank), field, pbuf%hdr%vardesc(grid_select))
        1513             :         end if
        1514       58368 :         deallocate(field)
        1515             :       end if
        1516             :     end do
        1517             :
        1518       58368 :   end subroutine write_restart_field_{TYPE}
        1519             :
        1520             :
        1521         768 :   subroutine pbuf_read_restart(File, pbuf2d)
        1522           0 :     use cam_grid_support, only: cam_grid_dimensions
        1523             :     use phys_grid,        only: phys_decomp
        1524             :     use pio,              only: file_desc_t, pio_inq_varid, pio_get_var
        1525             :
        1526             :     ! Dummy Variables
        1527             :     type(File_desc_t),                 intent(inout) :: File
        1528             :     type(physics_buffer_desc), pointer               :: pbuf2d(:,:)
        1529             :
        1530             :     ! Local Variables
        1531         768 :     type(physics_buffer_desc), pointer               :: pbufhdr(:)
        1532             :
        1533             :     integer                                          :: index, dtype, ierr
        1534             :     integer                                          :: gdimlens(2) ! Horizontal grid dimensions
        1535             :     integer                                          :: grank
        1536             :
        1537         768 :     call pbuf_initialize(pbuf2d)
        1538             :
        1539         768 :     pbufhdr => pbuf_get_chunk(pbuf2d, begchunk)
        1540             :
        1541        2304 :     gdimlens = 1
        1542         768 :     call cam_grid_dimensions(phys_decomp, gdimlens(1:2), grank)
        1543         768 :     ierr = pio_inq_varid(File, 'pbuf_time_idx', timeidx_desc)
        1544         768 :     ierr = pio_get_var(File, timeidx_desc, old_time_idx)
        1545             :
        1546       90624 :     do index = 1, currentpbufflds
        1547       90624 :       if(pbufhdr(index)%hdr%persistence == persistence_global) then
        1548       29184 :         dtype = pbufhdr(index)%hdr%dtype
        1549       29184 :         select case(dtype)
        1550             :         case (TYPEDOUBLE)
        1551       29184 :           call read_restart_field_double(File, pbuf2d, index, gdimlens, grank)
        1552             :         case (TYPEREAL)
        1553           0 :           call read_restart_field_real(File, pbuf2d, index, gdimlens, grank)
        1554             :         case (TYPEINT)
        1555       29184 :           call read_restart_field_int(File, pbuf2d, index, gdimlens, grank)
        1556             :         end select
        1557             :       end if
        1558             :     end do
        1559             :
        1560        1536 :   end subroutine pbuf_read_restart
        1561             :
        1562             :   ! TYPE int,double,real
        1563       29184 :   subroutine read_restart_field_{TYPE} (File, pbuf2d, index, gdimlens, grank)
        1564       29952 :     use pio,              only: file_desc_t
        1565             :     use pio,              only: pio_inq_varid
        1566             :     use cam_pio_utils,    only: cam_pio_handle_error
        1567             :     use cam_grid_support, only: cam_grid_read_dist_array
        1568             :     use subcol_pack_mod,  only: subcol_pack
        1569             :     use phys_grid,        only: phys_decomp
        1570             :
        1571             :     ! Dummy Variables
        1572             :     type(file_desc_t),                 intent(inout) :: File
        1573             :     type(physics_buffer_desc), pointer               :: pbuf2d(:,:)
        1574             :     integer,                           intent(in)    :: index
        1575             :     integer,                           intent(in)    :: gdimlens(2)
        1576             :     integer,                           intent(in)    :: grank
        1577             :
        1578             :     ! Local Variables
        1579             :     type(physics_buffer_desc), pointer :: pbuf
        1580       29184 :     {VTYPE},                   pointer :: fld6(:,:,:,:,:,:)
        1581       29184 :     {VTYPE},       allocatable         :: fld5_pack(:,:,:,:,:)
        1582       29184 :     {VTYPE},       allocatable         :: field(:,:,:)
        1583             :
        1584             :     integer                            :: grid_select ! (1=grid, 2=subcol)
        1585             :     integer                            :: ierr, c
        1586             :     integer                            :: start(6)
        1587             :     integer                            :: dimsizes(6)
        1588             :     integer                            :: fdimlens(3) ! Array dimensions on NetCDF file
        1589             :     integer                            :: frank       ! Array rank on file
        1590             :     integer                            :: adimlens(3) ! Array dimensions
        1591             :
        1592             :     character(len=24)                  :: varname
        1593             :     character(len=*), parameter        :: subname = 'read_restart_field_{TYPE}'
        1594             :
        1595       29184 :     pbuf => pbuf2d(index, begchunk)
        1596      204288 :     start = 1
        1597             :
        1598       87552 :     do grid_select = 1, ngrid_types
        1599             :
        1600      408576 :       dimsizes(:) = pbuf%hdr%dimsizes(:, grid_select)
        1601      233472 :       if(all(dimsizes(:) == 0)) then
        1602             :         ! None of this grid type for this variable
        1603             :         cycle
        1604             :       end if
        1605             :
        1606             :       call pbuf_restart_dimsizes(pbuf, gdimlens, grank, grid_select,          &
        1607       29184 :            adimlens, fdimlens, frank)
        1608             :       ! Fix up dimensions for subcolumn field
        1609       29184 :       if (grid_select == col_type_subcol) then
        1610             :         ! Field stored as  (pcols, psubcols*restDims, chunks)
        1611             :         ! Read then pack to (pcols*psubcols,restDims, chunks)
        1612           0 :         allocate(fld5_pack(dimsizes(1),dimsizes(2),dimsizes(3),dimsizes(4),dimsizes(5)))
        1613           0 :         do c = 5, 2, -1
        1614           0 :           dimsizes(c + 1) = dimsizes(c)
        1615             :         end do
        1616           0 :         dimsizes(1) = pcols
        1617           0 :         dimsizes(2) = psubcols
        1618             :       end if
        1619             :
        1620       29184 :       varname = trim(pbuf%hdr%name)//trim(field_grid_suff(grid_select))
        1621       29184 :       ierr = pio_inq_varid(File, varname, pbuf%hdr%vardesc(grid_select))
        1622       29184 :       call cam_pio_handle_error(ierr, trim(subname)//': '//trim(varname)//' not found')
        1623             :
        1624      145920 :       allocate(field(adimlens(1), adimlens(2), begchunk:endchunk))
        1625       29184 :       if (size(field,2) == 1) then
        1626             :         ! Special case for 2-D pbuf fields
        1627       13056 :         adimlens(2) = adimlens(3)
        1628             :         call cam_grid_read_dist_array(File, phys_decomp, adimlens(1:2),       &
        1629       13056 :              fdimlens(1:frank), field(:,1,:), pbuf%hdr%vardesc(grid_select))
        1630             :       else
        1631             :         call cam_grid_read_dist_array(File, phys_decomp, adimlens,            &
        1632       16128 :              fdimlens(1:frank), field, pbuf%hdr%vardesc(grid_select))
        1633             :       end if
        1634             :
        1635      146832 :       do c = begchunk, endchunk
        1636      146832 :         if (grid_select == col_type_grid) then
        1637      117648 :            pbuf%used = .true.
        1638      117648 :            call buffer_get_field_ptr(pbuf2d(index,c)%bfg(grid_select), fld6,  &
        1639      235296 :                 start, dimsizes)
        1640      823536 :           fld6 = reshape(field(:,:,c), dimsizes)
        1641           0 :         else if (grid_select == col_type_subcol) then
        1642           0 :           call subcol_pack(c, reshape(field(:,:,c), dimsizes), fld5_pack)
        1643           0 :           pbuf%used = .true.
        1644           0 :           call buffer_set_field(pbuf2d(index,c)%bfg(grid_select), fld5_pack)
        1645             :         else
        1646           0 :           call endrun('read_restart_field_{TYPE}: invalid grid selector - must be either 1 or 2')
        1647             :         end if
        1648             :       end do
        1649       29184 :       nullify(fld6)
        1650       29184 :       deallocate(field)
        1651       87552 :       if (allocated(fld5_pack)) then
        1652           0 :         deallocate(fld5_pack)
        1653             :       end if
        1654             :     end do
        1655             :
        1656       58368 :   end subroutine read_restart_field_{TYPE}
        1657             :
        1658           0 :   logical function pbuf_is_used(pbuf)
        1659             :      type(physics_buffer_desc), intent(in) :: pbuf
        1660             :
        1661           0 :      pbuf_is_used = pbuf%used
        1662           0 :   end function pbuf_is_used
        1663             :
        1664           0 :   subroutine pbuf_dump_pbuf(pbuf2d, name, num)
        1665             :     use cam_pio_utils,    only: cam_pio_dump_field
        1666             :     use spmd_utils,       only: masterproc
        1667             :
        1668             :     ! Dummy arguments
        1669             :     type(physics_buffer_desc), pointer     :: pbuf2d(:,:)
        1670             :     character(len=*), optional, intent(in) :: name
        1671             :     integer,          optional, intent(in) :: num
        1672             :
        1673             :     ! Local variables
        1674             :     integer, parameter                     :: max_name = 64
        1675             :     character(len=max_name)                :: field_name
        1676             :     integer                                :: index, grid_select, c
        1677             :     integer                                :: namelen
        1678             :     integer                                :: dimstart(6), dimend(6)
        1679             :     integer                                :: ierr
        1680             :     integer                                :: dtype
        1681           0 :     type(physics_buffer_desc), pointer     :: pbufhdr(:)
        1682           0 :     real(r8), allocatable                  :: field(:,:,:,:,:,:)
        1683           0 :     real(r8), pointer                      :: fld5(:,:,:,:,:)
        1684             :
        1685           0 :     pbufhdr => pbuf_get_chunk(pbuf2d, begchunk)
        1686           0 :     dimstart = 1
        1687             :
        1688           0 :     do index = 1, currentpbufflds
        1689           0 :       dtype = pbufhdr(index)%hdr%dtype
        1690           0 :       do grid_select = 1, ngrid_types
        1691           0 :         namelen = len_trim(pbufhdr(index)%hdr%name)
        1692           0 :         namelen = namelen + len_trim(field_grid_suff(grid_select))
        1693           0 :         if (present(name)) then
        1694           0 :           namelen = namelen + len_trim(name)
        1695             :         end if
        1696           0 :         if (present(num)) then
        1697           0 :           namelen = namelen + int(log10(real(num))) + 2
        1698             :         end if
        1699           0 :         if (namelen > 64) then
        1700           0 :           call endrun("PBUF_DUMP_PBUF: Name string too long")
        1701             :         end if
        1702           0 :         if (present(name)) then
        1703           0 :           if (present(num)) then
        1704           0 :             write(field_name, '(4a,i0)') trim(pbufhdr(index)%hdr%name),       &
        1705           0 :                  trim(field_grid_suff(grid_select)), trim(name), '_', num
        1706             :           else
        1707           0 :             write(field_name, '(3a)') trim(pbufhdr(index)%hdr%name),          &
        1708           0 :                  trim(field_grid_suff(grid_select)), trim(name)
        1709             :           end if
        1710           0 :         else if (present(num)) then
        1711           0 :           write(field_name, '(3a,i0)') trim(pbufhdr(index)%hdr%name),         &
        1712           0 :                trim(field_grid_suff(grid_select)), '_', num
        1713             :         else
        1714           0 :           write(field_name, '(2a)') trim(pbufhdr(index)%hdr%name),            &
        1715           0 :                trim(field_grid_suff(grid_select))
        1716             :         end if
        1717           0 :         dimend = pbufhdr(index)%hdr%dimsizes(:, grid_select)
        1718           0 :         if (PRODUCT(dimend) > 0) then
        1719           0 :           if (dimend(6) /= 1) then
        1720           0 :             if (masterproc) then
        1721           0 :               write(iulog, *) 'PBUF_DUMP_PBUF: ', trim(field_name), dimend
        1722             :             end if
        1723           0 :             call endrun("PBUF_DUMP_PBUF: No support for 6D pbuf field")
        1724             :           end if
        1725           0 :           dimend(6) = endchunk - begchunk + 1
        1726           0 :           select case(dtype)
        1727             :           case (TYPEDOUBLE)
        1728           0 :             allocate(field(dimend(1), dimend(2), dimend(3), dimend(4),        &
        1729           0 :                  dimend(5), dimend(6)))
        1730           0 :             do c = begchunk, endchunk
        1731             :               call pbuf_get_field(pbuf2d, c, index, fld5,                     &
        1732           0 :                    col_type=grid_select, errcode=ierr)
        1733           0 :               field(:,:,:,:,:,c-begchunk+1) = fld5(:,:,:,:,:)
        1734             :             end do
        1735             :             call cam_pio_dump_field(field_name, dimstart, dimend,             &
        1736           0 :                  field, compute_maxdim_in=.false.)
        1737           0 :             deallocate(field)
        1738             :           case (TYPEREAL)
        1739           0 :             if (masterproc) then
        1740           0 :               write(iulog, *) 'PBUF_DUMP_PBUF: No support for real fields'
        1741             :             end if
        1742             :           case (TYPEINT)
        1743           0 :             if (masterproc) then
        1744           0 :               write(iulog, *) 'PBUF_DUMP_PBUF: No support for integer fields'
        1745             :             end if
        1746             :           end select
        1747             :         end if
        1748             :       end do
        1749             :     end do
        1750           0 :   end subroutine pbuf_dump_pbuf
        1751             :
        1752           0 : subroutine pbuf_cam_snapshot_register()
        1753             : !--------------------------------------------------------
        1754             : ! This subroutine checks that all of the dimensions in pbuf fields have been registered
        1755             : ! If they have not, then a new dimension is added with the "pbuf_" prepending the actual size
        1756             : !--------------------------------------------------------
        1757             :
        1758           0 :    use cam_grid_support,    only: max_hcoordname_len
        1759             :    use cam_history_support, only: hist_dimension_name, add_hist_coord
        1760             :
        1761             :    type(physics_buffer_hdr), pointer  :: hdrbuffer
        1762             :    integer                            :: i, j
        1763             :    integer                            :: dim_size
        1764             :    character(len=max_hcoordname_len)  :: dim_name
        1765             :    character(len=max_hcoordname_len)  :: dim_string
        1766             :
        1767           0 :    hdrbuffer => hdrbuffertop
        1768           0 :    do i=1, currentpbufflds
        1769           0 :       do j =1, 6    ! The max number of pbuf dimensions
        1770           0 :          dim_size=hdrbuffer%dimsizes(j,1)
        1771           0 :          if (dim_size /= 1) then         ! Don't check subcolumn dimensions
        1772           0 :              dim_name = hist_dimension_name(dim_size)
        1773           0 :              if (dim_name == '') then                   ! found a dimension which needs a name
        1774           0 :                 write(dim_string,'(a,i0)') 'pbuf_',dim_size
        1775           0 :                 call add_hist_coord(dim_string, dim_size, dim_string)
        1776             :              end if
        1777             :          end if
        1778             :       end do
        1779           0 :       hdrbuffer => hdrbuffer%nexthdr
        1780             :    end do
        1781             :
        1782           0 : end subroutine pbuf_cam_snapshot_register
        1783             :
        1784           0 : subroutine pbuf_get_dim_strings(pbuf, string)
        1785             :
        1786             : !--------------------------------------------------------
        1787             : ! This subroutine retrieves the pbuf dimension strings
        1788             : !--------------------------------------------------------
        1789             :
        1790           0 :   use cam_history_support, only: hist_dimension_name
        1791             :   use cam_grid_support,    only: max_hcoordname_len
        1792             :
        1793             :   type(physics_buffer_desc), intent(in) :: pbuf(:)
        1794             :   character(len=*),       intent(inout) :: string(:,:)
        1795             :
        1796             :   character(len=max_hcoordname_len) :: dim_name
        1797             :   integer :: i, j
        1798             :
        1799           0 :   do i = 1, size(pbuf(:))
        1800           0 :      string(i,:)=''
        1801           0 :      do j = 1, 6  ! Hardwired number of pbuf dimensions
        1802           0 :         dim_name = hist_dimension_name(pbuf(i)%hdr%dimsizes(j,1))
        1803           0 :         if (dim_name /= '') then
        1804           0 :            string(i,j)=trim(dim_name)
        1805             :         end if
        1806             :      end do
        1807             :   end do
        1808             :
        1809           0 : end subroutine pbuf_get_dim_strings
        1810             :
        1811             :
        1812             :
        1813           0 : end module physics_buffer

Generated by: LCOV version 1.14