!--------------------------------------- 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 --------------------------------------
program diag_bmatrix,23
!
! program: diag_bmatrix - Program to compute diagnostics of the B matrix
!
! Author : M. Buehner March, 2013
!
use mpivar_mod
use MathPhysConstants_mod
use controlVector_mod
use gridStateVector_mod
use gaussGrid_mod
use bmatrix_mod
use verticalCoord_mod
IMPLICIT NONE
#include "comct0.cdk"
#include "comfilt.cdk"
type(struct_gsv) :: statevector
type(struct_vco), pointer :: vco_anl => null()
real*8, pointer :: field(:,:,:)
real*4, allocatable :: ensemble(:,:,:,:)
real*8, allocatable :: gdmean(:,:,:)
real*8, allocatable :: gdstddev(:,:,:)
real*8, allocatable :: zes(:,:,:)
real*8, allocatable :: ztv(:,:,:)
real*8, allocatable :: zgz(:,:,:)
real*8, allocatable :: zhu(:,:,:)
integer fclos,fnom,fstouv,fstfrm,fstopc,nulfile,newdate,nstamp
integer ierr,iseed
integer jmem,jj,jni,jnj,jnk,nkgdim
integer idate,itime,nulnam
real*8 gasdev,zdum,rwtinv
character*128 filename
character(len=10) :: datestr
character(len=4) :: varnames(10)
integer :: nlons,nlats,nlevs,ilon,ilat,ilev,iloc,nvarnames,ivar
integer :: numperturbations,nrandseed,diagdate
integer :: oneobs_levs(100),oneobs_lons(100),oneobs_lats(100)
namelist /namdiag/numperturbations,nrandseed,diagdate,oneobs_levs,oneobs_lons,oneobs_lats
write(*,*) " -------------------------------------------"
write(*,*) " --- START OF MAIN PROGRAM DIAG_BMATRIX: ---"
write(*,*) " --- Diagnositcs of the B matrix ---"
write(*,*) " --- Part of VARGLB Revision number ",crevision
write(*,*) " -------------------------------------------"
! MPI, tmg initialization
call mpi_init
call tmg_init(mpi_myid, 'TMG_DIAG-BMATRIX' )
ierr = fstopc('MSGLVL','ERRORS',0)
! Set some global variables
nstepobsinc=1
nstepobs=1
! Set default values for namelist NAMDIAG parameters
diagdate = 2011020100
numperturbations = -1
nrandseed = 1
oneobs_levs(:)=-1
oneobs_lons(:)=-1
oneobs_lats(:)=-1
! Read the parameters from NAMDIAG
nulnam=0
ierr=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
read(nulnam,nml=namdiag,iostat=ierr)
if(ierr.ne.0) call abort3d('diag_bmatrix: Error reading namelist')
write(*,nml=namdiag)
ierr=fclos(nulnam)
nlevs=0
do jj=1,size(oneobs_levs)
if(oneobs_levs(jj).ge.1) nlevs=nlevs+1
enddo
nlons=0
do jj=1,size(oneobs_lons)
if(oneobs_lons(jj).ge.1) nlons=nlons+1
enddo
nlats=0
do jj=1,size(oneobs_lats)
if(oneobs_lats(jj).ge.1) nlats=nlats+1
enddo
! Decompose diagdate(yyyymmddhh) into idate(YYYYMMDD) itime(HHMMSShh)
! and calculate date-time stamp
idate = diagdate/100
itime = (diagdate-idate*100)*1000000
ierr = newdate(nstamp,idate,itime,3)
write(datestr,'(i10.10)') diagdate
write(*,*)' idate= ',idate,' time= ',itime
write(*,*)' date= ',diagdate,' stamp= ',nstamp
! Initialize variables of the model states
call gsv_setup
! Initialize dimensions of the gaussian grid (analysis grid)
call gaus_setup
! Initialize the vertical coordinate from the statistics file
call vco_SetupFromFile(vco_anl,'./glbcov',.true.)
! Allocate the statevector
call gsv_setVco(statevector,vco_anl)
call gsv_allocate(statevector,gaus_ni,gaus_nj,1,dateStamp=nstamp,mpi_local=.true.)
nkgdim = statevector%nk
! Setup the B matrix
call bmat_setup(vco_anl,nstamp)
! Allocate auxillary variables
allocate(zes(gaus_ni,vco_anl%nlev_M,gaus_nj))
allocate(ztv(gaus_ni,vco_anl%nlev_M,gaus_nj))
allocate(zgz(gaus_ni,vco_anl%nlev_M,gaus_nj))
allocate(zhu(gaus_ni,vco_anl%nlev_M,gaus_nj))
zes(:,:,:)=0.0d0
ztv(:,:,:)=0.0d0
zgz(:,:,:)=0.0d0
zhu(:,:,:)=0.0d0
if(nlevs.ge.1.and.nlons.ge.1.and.nlats.ge.1) then
write(*,*) '********************************************'
write(*,*) 'Compute columns of B matrix'
write(*,*) '********************************************'
write(*,*) 'number of levels =',nlevs
write(*,*) 'number of longitudes =',nlons
write(*,*) 'number of latitudes =',nlats
nvarnames=4
varnames(1)='TT '
varnames(2)='HU '
varnames(3)='UU '
varnames(4)='VV '
do ivar=1,nvarnames
if(mpi_myid.eq.0) then
filename = 'columnB_' // trim(varnames(ivar)) // '_' // datestr // '.fst'
nulfile = 0
ierr = fnom(nulfile,trim(filename),'RND',0)
if(ierr.ge.0)then
write(*,*)' fstouv nulfile= ',nulfile
ierr = fstouv(nulfile,'RND')
else
call abort3d('diag_bmatrix: problem with file= ' // trim(filename))
endif
endif
iloc=0
do ilev=1,nlevs
do ilon=1,nlons
do ilat=1,nlats
iloc=iloc+1
call gsv_zero(statevector)
field => gsv_getField3d(statevector,varnames(ivar))
if(oneobs_lats(ilat).ge.statevector%myLatBeg.and.oneobs_lats(ilat).le.statevector%myLatEnd) then
field(oneobs_lons(ilon),oneobs_levs(ilev),oneobs_lats(ilat))=1.0d0
endif
cvm_vazx(:)=0.0d0
do jnj = statevector%myLatBeg,statevector%myLatEnd
rwtinv = real(statevector%ni,8)/gaus_rwt(jnj)
do jnk = 1,statevector%nlev_m
do jni = 1, statevector%ni
field(jni,jnk,jnj) = field(jni,jnk,jnj)*rwtinv
enddo
enddo
enddo
call bmat_sqrtBT(cvm_vazx,cvm_nvadim,statevector)
call bmat_sqrtB(cvm_vazx,cvm_nvadim,statevector)
write(*,*)'DIAG_BMATRIX: writing out the column of B, ilev,ilon,ilat=',ilev,ilon,ilat
call gsv_commMPIGlobal(statevector)
if(mpi_myid.eq.0) call varout(nulfile,statevector,zes,ztv,zgz,zhu,iloc)
call gsv_deallocate(statevector)
call gsv_allocate(statevector,gaus_ni,gaus_nj,1,dateStamp=nstamp,mpi_local=.true.)
enddo
enddo
enddo
if(mpi_myid.eq.0) then
ierr = fstfrm(nulfile)
ierr = fclos(nulfile)
endif
enddo
endif ! if oneobs_????(1).ge.1
if(numperturbations.gt.1) then
write(*,*) '********************************************'
write(*,*) 'Compute the stddev from random perturbations'
write(*,*) '********************************************'
! Allocate the ensemble, mean and stddev
allocate(ensemble(gaus_ni,statevector%nk,statevector%myLatBeg:statevector%myLatEnd,numperturbations))
allocate(gdmean(gaus_ni,nkgdim,statevector%myLatBeg:statevector%myLatEnd))
allocate(gdstddev(gaus_ni,nkgdim,statevector%myLatBeg:statevector%myLatEnd))
iseed = abs(nrandseed)
zdum = gasdev(-iseed)
gdmean(:,:,:) = 0.0d0
gdstddev(:,:,:) = 0.0d0
field => gsv_getField3d(statevector)
do jmem = 1,numperturbations
write(*,*) ' computing member number= ',jmem
do jj = 1,cvm_nvadim
cvm_vazx(jj)=gasdev(1)
enddo
call bmat_sqrtB(cvm_vazx,cvm_nvadim,statevector)
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = 1,gaus_ni
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
ensemble(jni,jnk,jnj,jmem)=field(jni,jnk,jnj)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
enddo
! Compute the ensemble mean
do jmem = 1,numperturbations
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = 1,gaus_ni
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
gdmean(jni,jnk,jnj) = gdmean(jni,jnk,jnj)+ensemble(jni,jnk,jnj,jmem)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
enddo
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = 1,gaus_ni
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
gdmean(jni,jnk,jnj) = gdmean(jni,jnk,jnj)/real(numperturbations,8)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! Remove the ensemble mean from the ensemble
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jmem,jnj,jnk)
do jni = 1,gaus_ni
do jmem = 1,numperturbations
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
ensemble(jni,jnk,jnj,jmem)=ensemble(jni,jnk,jnj,jmem)-gdmean(jni,jnk,jnj)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! Compute the ensemble stddev
do jmem = 1,numperturbations
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = 1,gaus_ni
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
gdstddev(jni,jnk,jnj) = gdstddev(jni,jnk,jnj)+(ensemble(jni,jnk,jnj,jmem)**2)/real(numperturbations,8)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
enddo
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = 1,gaus_ni
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
gdstddev(jni,jnk,jnj)=sqrt(gdstddev(jni,jnk,jnj))
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
if(mpi_myid.eq.0) then
filename = 'stddev_' // datestr // '.fst'
write(*,*)'DIAG_BMATRIX: writing out the stddev'
nulfile = 0
ierr = fnom(nulfile,trim(filename),'RND',0)
if(ierr.ge.0)then
write(*,*)' fstouv nulfile= ',nulfile
ierr = fstouv(nulfile,'RND')
else
call abort3d('diag_bmatrix: problem with file= ' // trim(filename))
endif
endif
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = 1,gaus_ni
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
field(jni,jnk,jnj) = gdstddev(jni,jnk,jnj)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call gsv_commMPIGlobal(statevector)
if(mpi_myid.eq.0) then
call varout(nulfile,statevector,zes,ztv,zgz,zhu,0)
ierr = fstfrm(nulfile)
ierr = fclos(nulfile)
endif
call gsv_deallocate(statevector)
call gsv_allocate(statevector,gaus_ni,gaus_nj,1,dateStamp=nstamp,mpi_local=.true.)
if(mpi_myid.eq.0) then
filename = 'stddev_zonavg_' // datestr // '.fst'
write(*,*)'DIAG_BMATRIX: writing out the stddev_zonavg'
nulfile = 0
ierr = fnom(nulfile,trim(filename),'RND',0)
if(ierr.ge.0)then
write(*,*)' fstouv nulfile= ',nulfile
ierr = fstouv(nulfile,'RND')
else
call abort3d('diag_bmatrix: problem with file= ' // trim(filename))
endif
endif
field => gsv_getField3d(statevector)
field(:,:,:) = 0.0d0
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jni = 1,gaus_ni
do jnk = 1,nkgdim
field(1,jnk,jnj) = field(1,jnk,jnj) + (gdstddev(jni,jnk,jnj)**2)/real(gaus_ni,8)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jnj = statevector%myLatBeg,statevector%myLatEnd
do jnk = 1,nkgdim
do jni = 2,gaus_ni
field(jni,jnk,jnj) = sqrt(field(1,jnk,jnj))
enddo
field(1,jnk,jnj) = sqrt(field(1,jnk,jnj))
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call gsv_commMPIGlobal(statevector)
if(mpi_myid.eq.0) then
call varout(nulfile,statevector,zes,ztv,zgz,zhu,0)
ierr = fstfrm(nulfile)
ierr = fclos(nulfile)
endif
call gsv_deallocate(statevector)
call gsv_allocate(statevector,gaus_ni,gaus_nj,1,dateStamp=nstamp,mpi_local=.true.)
deallocate(ensemble)
deallocate(gdmean)
deallocate(gdstddev)
endif ! if numperturbations.gt.1
! Deallocate arrays
call gsv_deallocate(statevector)
deallocate(zes)
deallocate(ztv)
deallocate(zgz)
deallocate(zhu)
! MPI, tmg finalize
call tmg_terminate(mpi_myid, 'TMG_DIAG-BMATRIX' )
CALL RPN_COMM_FINALIZE(ierr)
write(*,*) ' --------------------------------'
write(*,*) ' DIAG_BMATRIX ENDS'
write(*,*) ' --------------------------------'
end program diag_bmatrix