#include <misc.h>
#include <params.h>
module phys_buffer 17,8
!-----------------------------------------------------------------------
!
! Purpose:
! Implement a physics buffer to hold arrays that must persist
! across timesteps or between calls to different physics packages.
!
! Current implementation only supports one buffer.
!
! Author: B. Eaton
!
!-----------------------------------------------------------------------
use shr_kind_mod, only: r8 => shr_kind_r8
use infnan, only: nan
use pmgrid, only: masterproc
use ppgrid, only: pcols, begchunk, endchunk
use phys_grid, only: physgrid_set, write_field_from_chunk, read_chunk_from_field
use prognostics, only: ptimelevels
use string_utils, only: to_upper
use abortutils, only: endrun
#ifdef SPMD
use mpishorthand, only: mpicom, mpiint
#endif
implicit none
private
save
! Public methods
public ::&
pbuf_init, &! initialize physics buffer
pbuf_add, &! add field to physics buffer
pbuf_get_fld_idx, &! get index of specified field in the physics buffer
pbuf_old_tim_idx, &! return the index for the oldest time
pbuf_next_tim_idx, &! return the index for the next time
pbuf_update_tim_idx,&! update the index for the oldest time
pbuf_allocate, &! allocate memory for physics buffer fields
pbuf_deallocate, &! deallocate memory for physics buffer fields
pbuf_write_restart, &! write physics buffer to restart file
pbuf_read_restart ! read physics buffer from restart file
! Public types and data
type, public :: pbuf_fld
character(len=16) :: name
character(len=16) :: scope
integer :: fdim, mdim, ldim
real(r8), pointer, dimension(:,:,:,:,:) :: fld_ptr
end type pbuf_fld
integer, public, parameter :: pbuf_size_max=100
type(pbuf_fld), public, dimension(pbuf_size_max) :: pbuf
integer, public :: pbuf_times ! number of time levels in physics buffer (dycore dependent)
! Private module data
integer :: pbuf_size = 0
integer :: old_time_idx = 1
!=========================================================================================
contains
!=========================================================================================
subroutine pbuf_init() 1
! Initialize physics buffer.
implicit none
!-----------------------------------------------------------------------------------------
pbuf_times = ptimelevels - 1
end subroutine pbuf_init
!=========================================================================================
subroutine pbuf_add(name, scope, fdim, mdim, ldim, index) 7,2
! Add a field to the physics buffer
implicit none
character(len=*), intent(in) :: name ! field name
character(len=*), intent(in) :: scope ! field scope, either 'global' or 'physpkg'
integer, intent(in) :: fdim ! first generic field dimension
integer, intent(in) :: mdim ! middle generic field dimension
integer, intent(in) :: ldim ! last generic field dimension
integer, intent(out) :: index ! index in the physics buffer
! Local variables
character(len=*), parameter :: sub = 'pbuf_add'
integer :: i
!-----------------------------------------------------------------------------------------
if ( pbuf_size >= pbuf_size_max ) then
call endrun (sub//': max number physics buffer fields exceeded. Increase pbuf_size_max in phys_buffer.F90')
end if
do i = 1, pbuf_size
if ( pbuf(i)%name == name ) then
call endrun (sub//': ERROR: field name '//name//' is already in use.')
end if
end do
pbuf_size = pbuf_size + 1
index = pbuf_size
pbuf(index)%name = name
pbuf(index)%scope = scope
pbuf(index)%fdim = fdim
pbuf(index)%mdim = mdim
pbuf(index)%ldim = ldim
end subroutine pbuf_add
!=========================================================================================
function pbuf_get_fld_idx(name) 22,2
! Get index of specified field in the physics buffer. String matching is case insensitive.
! Call endrun if name not found
implicit none
character(len=*), intent(in) :: name ! field name
! Return value
integer :: pbuf_get_fld_idx
! Local variables
integer :: i
character(len=len(name)) :: Uname ! =to_upper(name)
!-----------------------------------------------------------------------------------------
!
! Search for specified field in physics buffer, assuming that case of
! argument "name" matches definition in pbuf structure.
!
do i = 1, pbuf_size
if ( pbuf(i)%name == name ) then
pbuf_get_fld_idx = i
return
end if
end do
!
! Search for specified field in physics buffer, assuming that case of
! argument "name" does not matches definition in pbuf structure. In this
! instance, convert all names to upper case.
!
Uname = to_upper(name)
do i = 1, pbuf_size
if ( to_upper(pbuf(i)%name) == Uname ) then
pbuf_get_fld_idx = i
return
end if
end do
call endrun ('PBUF_GET_FLD_IDX: index not found for '//name)
end function pbuf_get_fld_idx
!=========================================================================================
function pbuf_old_tim_idx() 4
! Return index of oldest time sample in the physics buffer.
implicit none
! Return value
integer :: pbuf_old_tim_idx
!-----------------------------------------------------------------------------------------
pbuf_old_tim_idx = old_time_idx
end function pbuf_old_tim_idx
!=========================================================================================
function pbuf_next_tim_idx(idx) 1
! Return index of next time sample in the physics buffer.
implicit none
integer, intent(in) :: idx
! Return value
integer :: pbuf_next_tim_idx
!-----------------------------------------------------------------------------------------
pbuf_next_tim_idx = mod(idx, pbuf_times) + 1
end function pbuf_next_tim_idx
!=========================================================================================
subroutine pbuf_update_tim_idx() 1
! Update index of old time sample in the physics buffer.
implicit none
!-----------------------------------------------------------------------------------------
old_time_idx = mod(old_time_idx, pbuf_times) + 1
end subroutine pbuf_update_tim_idx
!=========================================================================================
subroutine pbuf_allocate(scope) 3,1
! Allocate storage for fields in the physics buffer with the specified scope.
!
! N.B. This routine must be called after phys_grid_init because that's
! where begchunk and endchunk are set
implicit none
character(len=*), intent(in) :: scope
! Local variables
character(len=*), parameter :: sub = 'pbuf_allocate'
integer :: i, fdim, mdim, ldim, istat
!-----------------------------------------------------------------------------------------
if ( .not. physgrid_set ) then
call endrun (sub//': ERROR: called before physics grid initialized.')
end if
do i = 1, pbuf_size
if ( pbuf(i)%scope == scope ) then
fdim = pbuf(i)%fdim
mdim = pbuf(i)%mdim
ldim = pbuf(i)%ldim
allocate(pbuf(i)%fld_ptr(fdim,pcols,mdim,begchunk:endchunk,ldim), stat=istat)
if ( istat /= 0 ) then
call endrun (sub//': ERROR: allocate failed for '//pbuf(i)%name)
end if
pbuf(i)%fld_ptr = nan
end if
end do
end subroutine pbuf_allocate
!=========================================================================================
subroutine pbuf_deallocate(scope) 1,1
! Deallocate storage for fields in the physics buffer with the specified scope.
implicit none
character(len=*), intent(in) :: scope
! Local variables
character(len=*), parameter :: sub = 'pbuf_deallocate'
integer :: i, fdim, mdim, ldim
!-----------------------------------------------------------------------------------------
do i = 1, pbuf_size
if ( pbuf(i)%scope == scope ) then
if (associated(pbuf(i)%fld_ptr)) then
deallocate(pbuf(i)%fld_ptr)
else
call endrun (sub//': ERROR: '//pbuf(i)%name//' is not allocated')
end if
end if
end do
end subroutine pbuf_deallocate
!=========================================================================================
subroutine pbuf_write_restart(iu) 1,2
! write physics buffer to restart file
implicit none
integer, intent(in) :: iu ! Fortran unit number
! Local variables
character(len=*), parameter :: sub = 'pbuf_write_restart'
integer :: i, ioerr
!-----------------------------------------------------------------------------------------
if (masterproc) then
write (iu,iostat=ioerr) old_time_idx
if (ioerr /= 0 ) then
write (6,*) sub,' ioerror ', ioerr,' on i/o unit = ',iu
call endrun
end if
endif
do i = 1, pbuf_size
if ( pbuf(i)%scope == 'global' ) then
call write_field_from_chunk(iu, pbuf(i)%fdim, pbuf(i)%mdim, pbuf(i)%ldim, pbuf(i)%fld_ptr)
end if
end do
end subroutine pbuf_write_restart
!=========================================================================================
subroutine pbuf_read_restart(iu) 1,3
! write physics buffer to restart file
implicit none
integer, intent(in) :: iu ! Fortran unit number
! Local variables
character(len=*), parameter :: sub = 'pbuf_read_restart'
integer :: i, ioerr
!-----------------------------------------------------------------------------------------
if (masterproc) then
read (iu,iostat=ioerr) old_time_idx
if (ioerr /= 0 ) then
write (6,*) sub,' ioerror ', ioerr,' on i/o unit = ',iu
call endrun
end if
endif
#if ( defined SPMD )
call mpibcast(old_time_idx, 1, mpiint, 0, mpicom)
#endif
do i = 1, pbuf_size
if ( pbuf(i)%scope == 'global' ) then
call read_chunk_from_field(iu, pbuf(i)%fdim, pbuf(i)%mdim, pbuf(i)%ldim, pbuf(i)%fld_ptr)
end if
end do
end subroutine pbuf_read_restart
!=========================================================================================
end module phys_buffer