!-------------------------------------- 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 enkf_pturb,41
!
!** s/r enkf_pturb - Routine to prepare random perturbations for ENKF
!
use topLevelControl_mod
use mpi_mod
use mpivar_mod
use MathPhysConstants_mod
use controlVector_mod
use gridStateVector_mod
use gaussGrid_mod
use bmatrix_mod
use verticalCoord_mod
use horizontalCoord_mod
use LamAnalysisGrid_mod
use writeIncrement_mod
IMPLICIT NONE
type(struct_gsv) :: statevector
type(struct_vco), pointer :: vco_anl => null()
type(struct_hco), pointer :: hco_anl => null()
real(8), pointer :: field(:,:,:)
integer :: fclos,fnom,newdate,nstamp
integer :: ierr,iseed,status
integer :: ji,jj,jmem,jni,jnj,jnk,nkgdim,nlev_T
integer :: idate,itime,ndate,nulnam,cvDim_local
integer :: get_max_rss
integer :: LatPerPE, myLatBeg, myLatEnd
integer :: LonPerPE, myLonBeg, myLonEnd
real(8) :: gasdev,zdum
real(8), allocatable :: cvm_vazx_global(:)
real(8), allocatable :: gdmean(:,:,:)
real(8), allocatable :: zes_global(:,:,:)
real(8), allocatable :: ztv_global(:,:,:)
real(8), allocatable :: zgz_global(:,:,:)
real(8), allocatable :: zhu_global(:,:,:)
real(4), allocatable :: ensemble_r4(:,:,:,:)
character(len=10) :: cldate
character(len=3) :: clmember
character(len=25) :: clfiname
LOGICAL :: LREMOVE_MEAN
INTEGER :: NENKFMEM,NRANDSEED,NDATE_PTURB
NAMELIST /NAMENKF/NENKFMEM,NRANDSEED,NDATE_PTURB,LREMOVE_MEAN
write(*,'(/,' // &
'3(" *****************"),/,' // &
'14x,"-- START OF MAIN ENKF_PTURB --",/,' // &
'14x,"-- Generation of the isotropic perturbations --",/, ' // &
'14x,"-- VARGLB Revision number ",a," --",/,' // &
'3(" *****************"))') top_crevision
!
!- 0. MPI, tmg initialization
!
call mpi_initialize
call tmg_init(mpi_myid, 'TMG_ENKF-PTURB' )
!
!- 1. Set/Read values for the namelist NAMENKF
!
!- 1.1 Setting default values
NENKFMEM = 10
NRANDSEED = 1
NDATE_PTURB = 1900120100
LREMOVE_MEAN = .true.
!- 1.2 Read the namelist
nulnam=0
ierr=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
read(nulnam,nml=namenkf,iostat=ierr)
if(ierr.ne.0) call abort3d('enkf_pturb: Error reading namelist')
write(*,nml=namenkf)
ierr=fclos(nulnam)
ndate = NDATE_PTURB
write(cldate,'(I10)') ndate
!
!- 2. Initialization
!
!- 2.1 Decompose ndate(yyyymmddhh) into date(YYYYMMDD) time(HHMMSShh)
! calculate date-time stamp for postproc.ftn
idate = ndate/100
itime = (ndate-idate*100)*1000000
ierr = newdate(nstamp,idate,itime,3)
write(*,*)' idate= ',idate,' time= ',itime
write(*,*)' date= ',ndate,' stamp= ',nstamp
!- 2.2 Initialize variables of the model states
call gsv_setup
!- 2.3 Initialize the Analysis grid
if (mpi_myid == 0) write(*,*)''
if (mpi_myid == 0) write(*,*)' preproc: Set hco parameters for analysis grid'
call hco_SetupFromFile( './analysisgrid', 'ANALYSIS', 'Analysis' ) ! IN
hco_anl => hco_Get('Analysis')
if ( hco_anl % global ) then
!- Setup the global analysis grid metrics
call gaus_SetupFromHCO(hco_anl) ! IN
else
!- Iniatilized the core (Non-Exteded) analysis grid
call hco_SetupFromFile( './analysisgrid', 'COREGRID', 'AnalysisNonExt' ) ! IN
!- Setup the LAM analysis grid metrics
call lag_SetupFromHCO( 'Analysis', 'AnalysisNonExt' ) ! IN
end if
call mpivar_setup_latbands(hco_anl % nj, & ! IN
latPerPE, myLatBeg, myLatEnd ) ! OUT
call mpivar_setup_lonbands(hco_anl % ni, & ! IN
lonPerPE, myLonBeg, myLonEnd ) ! OUT
!- 2.4 Initialize the vertical coordinate from the statistics file
call vco_SetupFromFile( vco_anl,'./bgcov',.true.)
!- 2.5 Initialize the B_hi matrix
call bmat_setup(hco_anl,vco_anl)
!
!- 3. Memory allocations
!
!- 3.1 Allocate the statevector
call gsv_setHco(statevector,hco_anl)
call gsv_setVco(statevector,vco_anl)
call gsv_allocate(statevector,1,dateStamp=nstamp,mpi_local=.true.)
nkgdim = statevector%nk
allocate(ensemble_r4(myLonBeg:myLonEnd,statevector%nk,myLatBeg:myLatEnd,nenkfmem))
!- 3.2 Allocate auxillary variables
nlev_T = vco_getNumLev(vco_anl,'TH')
allocate(zes_global(hco_anl%ni,nlev_T,hco_anl % nj))
allocate(ztv_global(hco_anl % ni,nlev_T,hco_anl % nj))
allocate(zgz_global(hco_anl % ni,nlev_T,hco_anl % nj))
allocate(zhu_global(hco_anl % ni,nlev_T,hco_anl % nj))
zes_global(:,:,:)=0.0d0
ztv_global(:,:,:)=0.0d0
zgz_global(:,:,:)=0.0d0
zhu_global(:,:,:)=0.0d0
allocate(gdmean(myLonBeg:myLonEnd,nkgdim,myLatBeg:myLatEnd),STAT=status)
if ( status /= 0 ) then
call abort3d('enkf_pturb: PROBLEM WITH ALLOCATING OF GDMEAN')
endif
allocate(cvm_vazx_global(cvm_nvadim_mpiglobal))
!
!- 4. Compute an ensemble of random perturbations
!
write(*,*) '******************'
write(*,*) 'COMPUTE the mean of the random perturbations' &
,' of all the members'
iseed = ABS(nrandseed)
zdum = gasdev(-iseed)
gdmean(:,:,:) = 0.0D0
field => gsv_getField3d(statevector)
!- 4.1 Generate a (potentially) biased ensemble
do jmem = 1,NENKFMEM
write(*,*) ' computing member number= ',jmem
!- 4.1.1 Create a random control vector in spectral space
!- Global vector (same for each processors)
do jj = 1, cvm_nvadim_mpiglobal
cvm_vazx_global(jj) = gasdev(1)
enddo
!- Extract only the subvector for this processor
call bmat_reduceToMPILocal(cvm_vazx, & ! OUT
cvm_vazx_global, & ! IN
cvDim_local ) ! OUT
!- 4.1.2 Transform to control variables in physical space
call bmat_sqrtB(cvm_vazx, cvm_nvadim, & ! IN
statevector ) ! OUT
!- 4.1.3 Running ensemble sum
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = myLonBeg, myLonEnd
do jnj = myLatBeg, myLatEnd
do jnk = 1, nkgdim
ensemble_r4(jni,jnk,jnj,jmem) = real(field(jni,jnk,jnj),4)
gdmean(jni,jnk,jnj) = gdmean(jni,jnk,jnj) + field(jni,jnk,jnj)
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end do
call gsv_deallocate(statevector)
!- 4.2 Remove the ensemble mean
if ( LREMOVE_MEAN ) then
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = myLonBeg, myLonEnd
do jnj = myLatBeg, myLatEnd
do jnk = 1, nkgdim
gdmean(jni,jnk,jnj) = gdmean(jni,jnk,jnj) / real(NENKFMEM,8)
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jmem,jnj,jnk)
do jni = myLonBeg, myLonEnd
do jmem = 1, NENKFMEM
do jnj = myLatBeg, myLatEnd
do jnk = 1, nkgdim
ensemble_r4(jni,jnk,jnj,jmem) = ensemble_r4(jni,jnk,jnj,jmem) - &
real(gdmean(jni,jnk,jnj),4)
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if
!- 4.3 Write the perturbations
do jmem = 1,NENKFMEM
write(*,*)
write(*,*) ' pre-processing for writing member number= ',jmem
call gsv_allocate(statevector,1,dateStamp=nstamp,mpi_local=.true.)
field => gsv_getField3d(statevector)
!$OMP PARALLEL
!$OMP DO PRIVATE (jni,jnj,jnk)
do jni = myLonBeg, myLonEnd
do jnj = myLatBeg, myLatEnd
do jnk = 1, nkgdim
field(jni,jnk,jnj) = ensemble_r4(jni,jnk,jnj,jmem)
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
! mpiglobal result for 3D increment only on myid=0
call gsv_commMPIGlobal3D(statevector)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
if (mpi_myid == 0) then
write(clmember,'(I3.3)') jmem
clfiname = './ptbm_'//trim(cldate)//'_'//trim(clmember)
write(*,*)'ENKF_PTURB: PROCESSING clfiname= ',clfiname
call writeIncrement(clfiname,statevector,zes_global,ztv_global, & ! IN
zgz_global,zhu_global,nstamp) ! IN
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
end if
call gsv_deallocate(statevector)
end do
!
!- 5. Memory deallocations
!
deallocate(gdmean,STAT=status)
if ( status /= 0 ) then
call abort3d('enkf_pturb: PROBLEM WITH DEALLOCATE OF GDMEAN')
endif
deallocate(zes_global)
deallocate(ztv_global)
deallocate(zgz_global)
deallocate(zhu_global)
deallocate(ensemble_r4)
deallocate(cvm_vazx_global)
!
!- 6. MPI, tmg finalize
!
call tmg_terminate(mpi_myid, 'TMG_ENKF-PTURB' )
CALL RPN_COMM_FINALIZE(ierr)
!
!- 7. Ending
!
write(*,*) ' --------------------------------'
write(*,*) ' ENKF_PTURB ENDS'
write(*,*) ' --------------------------------'
end program enkf_pturb