!-------------------------------------- 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 --------------------------------------
!
SUBROUTINE enkf_pturb(kulout) 1,13
#if defined (DOC)
*
*** s/r enkf_pturb - Routine to prepare random perturbations for ENKF
*
* Author : C. Charette *ARMA/AES Mar , 2010
* Revision:
*
* Arguments
* -kulout- logical unit for printing
*
#endif
IMPLICIT NONE
integer kulout
* implicits
#include "comdim.cdk"
#include "pardim.cdk"
#include "comgem.cdk"
#include "comct0.cdk"
#include "comgd0.cdk"
#include "comcva.cdk"
#include "compost.cdk"
#include "comenkf.cdk"
integer fclos,fnom,fstouv,fstfrm,write_encode_hyb,newdate
integer ierr,iseed,istatus,kulfile,irandseed
integer ji,jj,jmem,jni,jnj,jnk,ip2,ip3,imode,ikind
integer idate,itime,ndate
real*8 gasdev,zdum
real zptop4,zpref4,zrcoef4
real*8,allocatable,dimension(:,:,:) :: gdmean
character*8 cletik
character*4 clprefix
character*10 cldate
character*3 clmember
character*25 clfiname
write(kulout,*)' ENKF_PTURB STARTS'
C
C* 1. Set default values for namelist NAMENKF parameters
C
NENKFMEM = 96
IRANDSEED = 1
NDATE_PTURB = 0101010101
CETIK_PTURB = 'ENFKPTRB'
C
C* 2. Read the parameters from NAMENKF
C
C
CALL READNML('NAMENKF',IERR)
C
allocate(gdmean(ni,nkgdim,nj),STAT=istatus)
if(istatus .ne. 0) then
CALL ABORT3D(KULOUT,'PROBLEM WITH ALLOCATE OF GDMEAN')
endif
write(kulout,*)' call supost'
call supost
c
c-----ATTN npak and nstamp belong to compost.cdk
c They are initialized in supost.ftn and used in postproc.ftn
c
npak = -16
ndate = NDATE_PTURB
write(cldate,'(I10)') ndate
c
c-----Decompose ndate(yyyymmddhh) into date(YYYYMMDD) time(HHMMSShh)
c calculate date-time stamp for postproc.ftn
c
idate = ndate/100
itime = (ndate-idate*100)*1000000
ierr = newdate(nstamp,idate,itime,3)
write(kulout,*)' idate= ',idate,' time= ',itime
write(kulout,*)' date= ',ndate,' stamp= ',nstamp
write(kulout,*)' call sucov'
call sucov(CCOV,kulout)
write(kulout,*) '******************'
write(kulout,*) 'COMPUTE the mean of the random perturbations'
& ,' of all the members'
irandseed = NRANDSEED
iseed = ABS(irandseed)
zdum = gasdev(-iseed)
gdmean(:,:,:) = 0.0
do jmem = 1,NENKFMEM
do jj = 1,nvadim
vazx(jj)=gasdev(1)
enddo
call oda_sqrtB(vazx,nvadim)
do jni = 1,ni
do jnj = 1,nj
do jnk = 1,nkgdim
gdmean(jni,jnk,jnj) = gdmean(jni,jnk,jnj)+gd(jni,jnk,jnj)
enddo
enddo
enddo
enddo
do jni = 1,ni
do jnj = 1,nj
do jnk = 1,nkgdim
gdmean(jni,jnk,jnj) = gdmean(jni,jnk,jnj)/real(NENKFMEM,8)
enddo
enddo
enddo
*
write(kulout,*) '******************'
write(kulout,*) 'REGENERATE the same random perturbations'
& ,' for each member and remove the mean'
zdum = gasdev(-iseed)
c
c-----Parameters for HY record in output file
c
ip2 = 0
ip3 = 0
zptop4 = rptopinc/100.0 ! Ptop MB
zrcoef4 = rcoefinc
zpref4 = rprefinc/100.0 ! Pref MB
cletik = CETIK_PTURB
clprefix= 'ptbm'
do jmem = 1,NENKFMEM
c-------Prepare output file name and open file
c
write(clmember,'(I3.3)') jmem
clfiname = clprefix(1:4) // cldate(1:10) // '_' // clmember(1:3)
write(6,*)'ENKF_PTURB: PROCESSING clfiname= ',clfiname
kulfile = 0
ierr = fnom(kulfile,trim(clfiname),'RND',0)
if(ierr.ge.0)then
write(kulout,*)' fstouv kulfile= ',kulfile
ierr = fstouv(kulfile,'RND')
else
write(kulout,*)'ENKF_PTURB:problem with file= ',clfiname
call abort3d(kulout,'ENKF_PTURB:problem with output file')
end if
c
c-------write HY in output file
c
ierr = write_encode_hyb(kulfile,'HY',ip2,ip3,cletik
& ,nstamp,zptop4,zpref4,zrcoef4)
do jj = 1,nvadim
vazx(jj)=gasdev(1)
enddo
call oda_sqrtB(vazx,nvadim)
do jni = 1,ni
do jnj = 1,nj
do jnk = 1,nkgdim
gd(jni,jnk,jnj) = gd(jni,jnk,jnj) - gdmean(jni,jnk,jnj)
enddo
enddo
enddo
c
c-------write perturbations in output file
c
write(kulout,*)' call postproc perturb= ',jmem
call postproc(kulfile,JMEM,'GRID',cletik)
ierr = fstfrm(kulfile)
ierr = fclos(kulfile)
enddo
deallocate(gdmean,STAT=istatus)
if(istatus .ne. 0) then
CALL ABORT3D(KULOUT,'PROBLEM WITH DEALLOCATE OF GDMEAN')
endif
write(kulout,*)' ENKF_PTURB ENDS'
return
end