#include <misc.h>
module fv_prints 1,22
!-------------------------------------------------------------------------
!BOP
!
! !MODULE: fv_prints --- print maxima and minima of dycore varibles
!
! !PUBLIC MEMBER FUNCTIONS:
PUBLIC fv_out
!
! !DESCRIPTION:
!
! This module provides basic utilities to evaluate the dynamics state
!
! !REVISION HISTORY:
! 00.08.01 Lin Creation
! 01.01.05 Boville Modifications
! 01.03.26 Sawyer Added ProTex documentation
! 03.04.17 Sawyer Bug fix: pls=pls/2*plon instead of 2*plat (Boville)
!
!EOP
!-------------------------------------------------------------------------
CONTAINS
!-------------------------------------------------------------------------
!BOP
! !IROUTINE: fv_out --- Write out maxima and minima of dynamics state
!
! !INTERFACE:
subroutine fv_out( im, jm, km, jfirst, jlast, & 1
ng, kfirst,klast, pk, pt, &
ptop, ps, q3, nc, nq, &
delp, pe, surf_state, phys_state, ncdate, &
ncsec, full_phys )
! !USES:
use shr_kind_mod
, only: r8 => shr_kind_r8
use dynamics_vars
, only: cosp
use commap
, only: w
use ppgrid
, only: begchunk, endchunk, pcols, pver
use phys_grid
, only: gather_chunk_to_field, get_ncols_p
use physics_types
, only: physics_state
use comsrf
, only: surface_state
use pmgrid
, only: iam, plat, plon, strip3zaty, strip2d, &
myid_y, myid_z
#if defined( SPMD )
use spmd_dyn
, only: comm_y, comm_z
use parutilitiesmodule, only : pargatherreal
#endif
implicit none
! !INPUT PARAMETERS:
integer im ! Total longitudes
integer jm ! Total latitudes
integer km ! Total levels
integer jfirst ! First latitude on this PE
integer jlast ! Last latitude on this PE
integer ng ! Latitude ghost width (D-grid)
integer kfirst ! First level on this PE
integer klast ! Last level on this PE
integer nc, nq ! No. of non-advected and adv. tracers
integer ncdate ! Date
integer ncsec ! Time
real(r8) ptop ! Pressure at top
real(r8) ps(im,jfirst:jlast) ! Surface pressure
real(r8) pk(im,jfirst:jlast,kfirst:klast+1) ! Pe**kappa
real(r8) pt(im,jfirst-ng:jlast+ng,kfirst:klast) ! Potential temp.
real(r8) delp(im,jfirst:jlast,kfirst:klast) ! Layer thickness (pint(k+1) - pint(k))
real(r8) q3(im,jfirst-ng:jlast+ng,kfirst:klast,nc)! Tracers
real(r8) pe(im,kfirst:klast+1,jfirst:jlast) ! Edge pressure
type(surface_state), intent(in), dimension(begchunk:endchunk) :: surf_state
type(physics_state), intent(in), dimension(begchunk:endchunk) :: phys_state
logical full_phys ! Full physics on?
!
! !DESCRIPTION:
!
! Determine maxima and minima of dynamics state and write them out
!
! !REVISION HISTORY:
! 00.08.01 Lin Creation
! 01.01.05 Boville Modifications
! 01.03.26 Sawyer Added ProTex documentation
! 01.06.27 Mirin Converted to 2D yz decomposition
! 01.12.18 Mirin Calculate average height (htsum) metric
! 02.02.13 Eaton Pass precc and precl via surface_state type
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
integer i, j, k, ic, nj, lchnk, nck, ncol
real(r8), dimension(begchunk:endchunk) :: pmax, tmax, umax, vmax, wmax
real(r8), dimension(begchunk:endchunk) :: pmin, tmin, umin, vmin, wmin
real(r8), dimension(pcols,begchunk:endchunk) :: precc ! convective precip rate
real(r8), dimension(pcols,begchunk:endchunk) :: precl ! large-scale precip rate
real(r8), dimension(begchunk:endchunk) :: preccmax, preclmax
real(r8), dimension(begchunk:endchunk) :: preccmin, preclmin
real(r8), dimension(jfirst:jlast,nc) :: qmax
real(r8), dimension(jfirst:jlast,nc) :: qmin
real(r8) fac, precmax, precmin
real(r8) pcon, pls
real(r8) qtmp(im,kfirst:klast,jfirst:jlast)
real(r8) p1, p2,dtmp, apcon, htsum
real(r8), dimension(plon,plat) :: dfield
real(r8), allocatable :: htgeo(:,:,:),htgeoz(:,:,:)
real(r8), allocatable :: htg(:,:),htgy(:,:)
integer n, nhmsf
! statement function for hour minutes seconds of day
nhmsf(n) = n/3600*10000 + mod(n,3600 )/ 60*100 + mod(n, 60)
if (iam .eq. 0) then
write(6,*) ' '
write(6,*) nhmsf(ncsec), ncdate
endif
!
! Check total air and dry air mass.
call dryairm
( im, jm, km, jfirst, jlast, &
ng, kfirst,klast, &
.true., ptop, ps, q3, nc, &
nq, delp, pe, .true.)
!$omp parallel do private(lchnk, ncol)
do lchnk = begchunk, endchunk
ncol = get_ncols_p
(lchnk)
pmax(lchnk) = maxval(phys_state(lchnk)%ps(1:ncol))
pmin(lchnk) = minval(phys_state(lchnk)%ps(1:ncol))
tmax(lchnk) = maxval(phys_state(lchnk)%t(1:ncol,1:pver))
tmin(lchnk) = minval(phys_state(lchnk)%t(1:ncol,1:pver))
umax(lchnk) = maxval(phys_state(lchnk)%u(1:ncol,1:pver))
umin(lchnk) = minval(phys_state(lchnk)%u(1:ncol,1:pver))
vmax(lchnk) = maxval(phys_state(lchnk)%v(1:ncol,1:pver))
vmin(lchnk) = minval(phys_state(lchnk)%v(1:ncol,1:pver))
wmax(lchnk) = maxval(phys_state(lchnk)%omega(1:ncol,1:pver))
wmin(lchnk) = minval(phys_state(lchnk)%omega(1:ncol,1:pver))
end do
nck = endchunk - begchunk + 1
call pmaxmin2
('PS', pmin, pmax, nck, 0.01)
call pmaxmin2
('U ', umin, umax, nck, 1.)
call pmaxmin2
('V ', vmin, vmax, nck, 1.)
call pmaxmin2
('T ', tmin, tmax, nck, 1.)
call pmaxmin2
('W (mb/day)', wmin, wmax, nck, 864.)
nj = jlast - jfirst + 1
do ic=1,nc
!$omp parallel do private(i, j, k)
do j=jfirst,jlast
do k=kfirst,klast
do i=1,im
qtmp(i,k,j) = q3(i,j,k,ic)
enddo
enddo
enddo
call pmaxmin
('Q3', qtmp, p1, p2, im*(klast-kfirst+1), nj, 1.)
end do
allocate (htgeoz(im,jfirst:jlast,km))
allocate (htgeo(im,jfirst:jlast,kfirst:klast))
allocate (htgy(im,jm))
allocate (htg(im,jfirst:jlast))
apcon = 1./9.80616
!$omp parallel do private(i, j, k)
do k=kfirst,klast
do j=jfirst,jlast
do i=1,im
htgeo(i,j,k) = apcon * pt(i,j,k) * (pk(i,j,k+1)-pk(i,j,k))
enddo
enddo
enddo
#if defined( SPMD )
call pargatherreal(comm_z, 0, htgeo, strip3zaty, htgeoz)
#else
!$omp parallel do private(i, j, k)
do k=1,km
do j=jfirst,jlast
do i=1,im
htgeoz(i,j,k) = htgeo(i,j,k)
enddo
enddo
enddo
#endif
if (myid_z .eq. 0) then
!$omp parallel do private(i, j, k)
do j=jfirst,jlast
do i=1,im
htg(i,j) = 0.
enddo
do k=1,km
do i=1,im
htg(i,j) = htg(i,j) + htgeoz(i,j,k)
enddo
enddo
enddo
#if defined( SPMD )
call pargatherreal(comm_y, 0, htg, strip2d, htgy)
#else
do j=1,jm
do i=1,im
htgy(i,j) = htg(i,j)
enddo
enddo
#endif
if (myid_y .eq. 0) then
htsum = 0.
do j=1,jm
do i=1,im
htsum = htsum + htgy(i,j)*cosp(j)
enddo
enddo
htsum = htsum / (2.*im)
print *, 'Average Height (geopotential units) = ', htsum
endif
endif
deallocate (htgeoz)
deallocate (htgeo)
deallocate (htgy)
deallocate (htg)
if ( .not. full_phys ) return
! Global means:
fac = 86400000. ! convert to mm/day
!$omp parallel do private(lchnk, ncol)
do lchnk = begchunk, endchunk
ncol = get_ncols_p
(lchnk)
precc(:ncol,lchnk) = surf_state(lchnk)%precc(:ncol)
precl(:ncol,lchnk) = surf_state(lchnk)%precl(:ncol)
preccmax(lchnk) = maxval(precc(1:ncol,lchnk))
preccmin(lchnk) = minval(precc(1:ncol,lchnk))
preclmax(lchnk) = maxval(precl(1:ncol,lchnk))
preclmin(lchnk) = minval(precl(1:ncol,lchnk))
end do
nck = endchunk - begchunk + 1
call pmaxmin2
('PRECC', preccmin, preccmax, nck, fac)
call pmaxmin2
('PRECL', preclmin, preclmax, nck, fac)
call gather_chunk_to_field
(1,1,1,plon,precc,dfield)
if (iam .eq. 0) then
pcon = 0.0
do j=1,plat
dtmp = dfield(1,j)
do i=2,plon
dtmp = dtmp + dfield(i,j)
enddo
pcon = pcon + dtmp*w(j)
enddo
pcon = pcon / (2*plon)
endif
call gather_chunk_to_field
(1,1,1,plon,precl,dfield)
if (iam .eq. 0) then
pls = 0.0
do j=1,plat
dtmp = dfield(1,j)
do i=2,plon
dtmp = dtmp + dfield(i,j)
enddo
pls = pls + dtmp*w(j)
enddo
pls = pls / (2*plon)
endif
if (iam .eq. 0) then
pcon = pcon * fac
pls = pls * fac
write(6,*) 'Total precp=',pcon+pls,' CON=', pcon,' LS=',pls
write(6,*) ' '
endif
!EOC
end subroutine fv_out
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
! !IROUTINE: pmaxmin --- Find and print the maxima and minima of a field
!
! !INTERFACE:
subroutine pmaxmin( qname, a, pmin, pmax, im, jm, fac ) 1,1
! !USES:
use shr_kind_mod
, only: r8 => shr_kind_r8
#if defined( SPMD )
#define CPP_PRT_PREFIX if(gid.eq.0)
use parutilitiesmodule, only : commglobal,gid,maxop,parcollective
#else
#define CPP_PRT_PREFIX
#endif
implicit none
! !INPUT PARAMETERS:
character*(*) qname ! Name of field
integer im ! Total longitudes
integer jm ! Total latitudes
real(r8) a(im,jm) ! 2D field
real(r8) fac ! multiplication factor
! !OUTPUT PARAMETERS:
real(r8) pmax ! Field maximum
real(r8) pmin ! Field minimum
! !DESCRIPTION:
!
! Parallelized utility routine for computing/printing global
! max/min from input lists of max/min's (usually for each latitude).
!
! !REVISION HISTORY:
! 00.03.01 Lin Creation
! 00.05.01 Mirin Coalesce variables to minimize collective ops
! 01.08.05 Sawyer Modified to use parcollective
! 01.03.26 Sawyer Added ProTex documentation
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
integer i, j
real(r8) qmin(jm), qmax(jm)
real(r8) pm(2)
!$omp parallel do default(shared) private(i,j, pmax, pmin)
do j=1,jm
pmax = a(1,j)
pmin = a(1,j)
do i=2,im
pmax = max(pmax, a(i,j))
pmin = min(pmin, a(i,j))
enddo
qmax(j) = pmax
qmin(j) = pmin
enddo
!
! Now find max/min of qmax/qmin
!
pmax = qmax(1)
pmin = qmin(1)
do j=2,jm
pmax = max(pmax, qmax(j))
pmin = min(pmin, qmin(j))
enddo
#if defined( SPMD )
pm(1) = pmax
pm(2) = -pmin
call parcollective( commglobal, maxop, 2, pm )
pmax = pm(1)
pmin = -pm(2)
#endif
CPP_PRT_PREFIX write(*,*) qname, ' max = ', pmax*fac, ' min = ', pmin*fac
return
!EOC
end subroutine pmaxmin
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
! !IROUTINE: pmaxmin2 --- Find and print the maxima and minima of 1-D array
!
! !INTERFACE:
subroutine pmaxmin2( qname, qmin, qmax, nj, fac ) 7,1
! !USES:
use shr_kind_mod
, only: r8 => shr_kind_r8
#if defined( SPMD )
#define CPP_PRT_PREFIX if(gid.eq.0)
use parutilitiesmodule, only : commglobal,gid,maxop,parcollective
#else
#define CPP_PRT_PREFIX
#endif
implicit none
! !INPUT PARAMETERS:
character*(*) qname
integer nj
real(r8), intent(in), dimension(nj) :: qmax, qmin ! Fields
real(r8) fac ! multiplication factor
! !DESCRIPTION:
!
! Parallelized utility routine for computing/printing global max/min from
! input lists of max/min's (usually for each latitude). The primary purpose
! is to allow for the original array and the input max/min arrays to be
! distributed across nodes.
!
! !REVISION HISTORY:
! 00.10.01 Lin Creation from pmaxmin
! 01.03.26 Sawyer Added ProTex documentation
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
real(r8) pm(2)
real(r8) pmin, pmax
pmax = maxval(qmax)
pmin = minval(qmin)
#if defined( SPMD )
pm(1) = pmax
pm(2) = -pmin
call parcollective( commglobal, maxop, 2, pm )
pmax = pm(1)
pmin = -pm(2)
#endif
CPP_PRT_PREFIX write(*,*) qname, ' max = ', pmax*fac, ' min = ', pmin*fac
return
!EOC
end subroutine pmaxmin2
!-----------------------------------------------------------------------
end module fv_prints