!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r statfld - calcule la moyenne, la variance, le minimum et
* le maximum d un champs et imprime le resultat.
*
#include "model_macros_f.h"
subroutine statfld (F_field, F_nv_S, F_no, F_from_S, 7
$ minx,maxx,miny,maxy,lnk,
$ F_i0,F_j0,F_k0,F_in,F_jn,F_kn)
*
implicit none
*
character*(*) F_nv_S , F_from_S
integer minx,maxx,miny,maxy,lnk,
$ F_i0,F_j0,F_k0,F_in,F_jn,F_kn,F_no,unf
real F_field(minx:maxx,miny:maxy,lnk)
*
*author
* M. Desgagne
*
*revision
* v2_00 - Desgagne M. - initial MPI version (from MC2)
* v3_00 - Desgagne & Lee - Lam configuration
* v3_30 - Tanguay M. - Ask if Lun_out.gt.0
*
*object
* calcule et imprime: la moyenne (moy)
* la variance (var)
* le minimum et le maximum du champ f
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_field I Field to be operated on
* F_nv_S I User provided string to define F_field
* F_no I Usually the timestep #
* F_from_S I Usually the name of the calling subroutine
* F_i0,F_j0 I Global lower-left indexes of the sub-domain
* on which to perform statistics
* F_in,F_jn I Global upper-right indexes of the sub-domain
* on which to perform statistics
* F_k0,F_kn I Range of levels on which to perform statistics
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "lctl.cdk"
#
integer i,j,k,imin,jmin,kmin,imax,jmax,kmax
real*8 sum,sumd2,moy,var,mind,maxd,fijk,npt_8
*
*--------------------------------------------------------------------
*
npt_8 = 1.0d0*((F_in-F_i0+1)*(F_jn-F_j0+1)*(F_kn-F_k0+1))
*
sum = 0.0
sumd2 = 0.0
imin = F_i0
jmin = F_j0
kmin = F_k0
imax = F_in
jmax = F_jn
kmax = F_kn
maxd = F_field(F_in,F_jn,F_kn)
mind = F_field(F_i0,F_j0,F_k0)
*
do k=F_k0,F_kn
do j=F_j0,F_jn
do i=F_i0,F_in
fijk = F_field(i,j,k)
sum = sum + fijk
sumd2 = sumd2 + fijk*fijk
if (fijk .gt. maxd) then
maxd = fijk
imax = i
jmax = j
kmax = k
endif
if (fijk .lt. mind) then
mind = fijk
imin = i
jmin = j
kmin = k
endif
end do
end do
end do
*
moy = sum / npt_8
var = max(0.d0,1.0d0*(sumd2 + moy*moy*npt_8 - 2*moy*sum) / npt_8)
var = sqrt(var)
*
* ** On imprime
*
if (Lctl_r8stat_L) then
if (G_lam) then
if(Lun_out.gt.0) write(Lun_out,99) F_no,F_nv_S,moy,var,imin,jmin,kmin,mind,
$ imax,jmax,kmax,maxd,F_from_S
else
if(Lun_out.gt.0) write(Lun_out,99) F_no,F_nv_S,moy,var,imin,jmin,kmin,mind,
$ imax,jmax,kmax,maxd,F_from_S
endif
else
if (G_lam) then
if(Lun_out.gt.0) write(Lun_out,98) F_no,F_nv_S,moy,var,imin,jmin,kmin,mind,
$ imax,jmax,kmax,maxd,F_from_S
else
if(Lun_out.gt.0) write(Lun_out,98) F_no,F_nv_S,moy,var,imin,jmin,kmin,mind,
$ imax,jmax,kmax,maxd,F_from_S
endif
endif
*
98 format (i4,a4,' Mean:',e14.7,' Var:',e14.7,
$ ' Min:[(',i3,',',i3,',',i3,')',
$ e14.7,']',' Max:[(',i3,',',i3,',',i3,')',
$ e14.7,']',a6)
99 format (i4,a4,' Mean:',e22.14,' Var:',e22.14,/
$ ' Min:[(',i3,',',i3,',',i3,')',
$ e22.14,']',' Max:[(',i3,',',i3,',',i3,')',
$ e22.14,']',a6)
*
*----------------------------------------------------------------
*
return
end