!--------------------------------------- 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 --------------------------------------
module writeIncrement_mod 2,11
use MathPhysConstants_mod
use EarthConstants_mod
use varNameList_mod
use controlVector_mod
use bmatrix_mod
use mpivar_mod
use gridStateVector_mod
use verticalCoord_mod
use HorizontalCoord_mod
use timeCoord_mod
use physicsFunctions_mod
implicit none
save
private
public :: calcWriteIncrement,writeIncrement
! this is set to true when supost runs
logical :: initialized = .false.
character(len=12) :: cetikinc_orig
logical :: basic_tt = .false.
logical :: basic_hu = .false.
! namelist variables
character(len=4) :: cppcvar(20)
character(len=12) :: cetikinc
integer :: nppcvar, randSeed
logical :: write4dInc, useTL_LQtoHU, removeMean, pertBhiOnly
real(8) :: e1_scaleFactor, e2_scaleFactor
contains
SUBROUTINE SUPOST 2,1
!
!**s/r SUPOST - initialize the post-processing of the model state
!
implicit none
integer :: ierr, jvar, ihu, itt, ivt, imin, igz, ip0, ilq
integer :: nulnam, fnom, fclos
logical :: lvtout, lgzout
namelist /nampost/nppcvar, cppcvar, cetikinc, write4dInc, useTL_LQtoHU, &
e1_scaleFactor,e2_scaleFactor, randSeed, removeMean, pertBhiOnly
write(*,*) '========================================='
write(*,*) 'supost: initialization of postprocessing'
write(*,*) '========================================='
initialized=.true.
!
! 1. Set default values
!
cetikinc = 'UNDEFINED***'
nppcvar=6
cppcvar(:) = ' '
cppcvar(1) = 'UU'
cppcvar(2) = 'VV'
cppcvar(3) = 'TT'
cppcvar(4) = 'LQ'
cppcvar(5) = 'P0'
cppcvar(6) = 'TG'
write4dInc = .false.
useTL_LQtoHU = .false.
e1_scaleFactor = 0.66d0
e2_scaleFactor = 0.33d0
randSeed = 1
removeMean = .true.
pertBhiOnly = .true.
!
! 2. Read the parameters from NAMPOST
!
nulnam=0
ierr=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
read(nulnam,nml=nampost,iostat=ierr)
if(ierr.ne.0) call abort3d('supost: Error reading namelist')
if(mpi_myid.eq.0) write(*,nml=nampost)
ierr=fclos(nulnam)
cetikinc_orig = cetikinc
!
! reordering cppcvar for dependent variables in writeIncrement
!
ip0 = 0
ihu = 0
itt = 0
ivt = 0
lgzout = .false.
lvtout = .false.
do jvar = 1,nppcvar
if(cppcvar(jvar).eq.'P0') then
ip0 = jvar
endif
if(cppcvar(jvar).eq.'TT') then
itt = jvar
endif
if(cppcvar(jvar).eq.'GZ') then
igz = jvar
lgzout = .true.
basic_tt = .true.
basic_hu = .true.
endif
if(cppcvar(jvar).eq.'HU') then
ihu = jvar
basic_hu = .true.
endif
if(cppcvar(jvar).eq.'VT') then
ivt = jvar
lvtout = .true.
basic_hu = .true.
endif
if(cppcvar(jvar).eq.'LQ') then
ilq = jvar
endif
if(cppcvar(jvar).eq.'ES') then
basic_hu = .true.
endif
enddo
if(basic_tt.and.mpi_myid.eq.0) write(*,*) 'SUPOST: TT trial field will be read'
if(basic_hu.and.mpi_myid.eq.0) write(*,*) 'SUPOST: HU trial field will be read'
if((lgzout.or.lvtout).and.ihu.eq.0) then
! Make sure that HU is part of the list
ihu = nppcvar+1
cppcvar(ihu) = 'HU'
nppcvar = ihu
endif
if(ihu.ne.0) then
! Make sure that TT is part of the list
imin = min(itt,ihu)
if (imin.eq.0) then
! TT is not requested: put it in the list before HU
cppcvar(ihu) = 'TT'
cppcvar(nppcvar+1) = 'HU'
nppcvar = nppcvar + 1
else
! TT is requested: make sure that TT is before HU in the list
cppcvar(max(itt,ihu)) = 'HU'
cppcvar(imin) = 'TT'
endif
endif
if(ip0 .gt. 1) then
do jvar = ip0, 2,-1
cppcvar(jvar) = cppcvar(jvar -1)
enddo
cppcvar(1) = 'P0'
endif
!
! 4. Print the values
!
DO jvar = 1, NPPCVAR
if(mpi_myid.eq.0) WRITE(*,FMT='(4X,"VAR NO.",I3,":",2X,"CPPCVAR= ",A5)') jvar,CPPCVAR(jvar)
ENDDO
END SUBROUTINE SUPOST
subroutine calcWriteIncrement(vco_anl,vco_trl,indexAnalysis) 1,51
!
! s/r calcWriteIncrement - calculate and write analysis increment after minimization
!
implicit none
type(struct_vco), pointer :: vco_anl, vco_trl
integer :: indexAnalysis
type(struct_hco), pointer :: hco_anl
type(struct_gsv) :: statevector,statevectorg,statevectorp
integer :: jlev, jj, ji, jstep, jvar, perturbLoop, numPerturbLoop, nlev_T, nlev_M, iseed
integer :: ierr, fnom, fstouv, fstfrm, fclos
integer :: Vcode_anl,status
integer :: datestamplist(tim_nstepobsinc)
real(8) :: hu_anl,deltaHours, gasdev, zdum, scaleFactor
real(8), allocatable :: zes(:,:,:)
real(8), allocatable :: ztv(:,:,:)
real(8), allocatable :: zgz_M(:,:,:),zgz_T(:,:,:)
real(8), allocatable :: zhu(:,:,:)
real(8), allocatable :: cv_pert_mpilocal(:), cv_pert_mpiglobal(:)
real(8), allocatable :: scaleFactorBhi(:)
real(8), pointer :: cv_pert_bens_mpilocal(:), field(:,:,:,:)
real(8), pointer :: lq_inc_ptr(:,:,:,:), hu_trl_ptr(:,:,:,:)
character(len=4) :: flnum, flnum2
character(len=1) :: flnum3
character(len=128) :: incFileName
integer :: get_max_rss
logical :: globalGSVpresent
write(*,*) '-------------------------------'
write(*,*) '--Starting subroutine calcWriteIncrement--'
write(*,*) '-------------------------------'
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
call rpn_comm_barrier("GRID",ierr)
call tmg_start(3,'WRITEINCR')
!
! Read namelist and do some setup
!
if(.not.initialized) call supost
!
! Check that we have at least as many processors as increment timesteps
!
if(mpi_nprocs .lt. tim_nstepobsinc) then
write(*,*) 'mpi_nprocs=',mpi_nprocs,', nstepobsinc=',tim_nstepobsinc
call abort3d('calcWriteIncrement: number of cpus < number of increment timesteps, aborting!')
endif
!
! Determine which MPI tasks will have mpiglobal statevectors (increment, background, perturbation)
! if 3D increment: background fields only on myid=0, so only do calculations for myid=0
! if 4D increment: background fields for jstep on myid=jstep-1, do calculations for first numstep procs
!
if( (write4dInc .and. mpi_myid .lt. tim_nstepobsinc) .or. &
(.not.write4dInc .and. mpi_myid .eq. 0 ) ) then
globalGSVpresent = .true.
else
globalGSVpresent = .false.
endif
!
! Setup statevector for storing the analysis increment
!
hco_anl => hco_Get('Analysis')
call gsv_setVco(statevector,vco_anl)
call gsv_setHco(statevector,hco_anl)
nlev_T = vco_getNumLev(vco_anl,'TH')
nlev_M = vco_getNumLev(vco_anl,'MM')
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
call gsv_allocate(statevector,tim_nstepobsinc, &
datestamp=tim_getDatestamp(),mpi_local=.true.)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
!
! Prepare background fields (only P0, TT, HU) at each analysis time needed for computing
! diagnostic fields and make mpiglobal (result only on myid=increment_time_step-1)
!
call rpn_comm_barrier("GRID",ierr)
call tmg_start(95,'POST_SUBASIC')
write(*,*)' calcWriteIncrement: Read in background variables to enable calculation of diagnostic variables'
call gsv_setVco(statevectorg,vco_anl)
call gsv_setHco(statevectorg,hco_anl )
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
call gsv_allocate(statevectorg,1,datestamp=tim_getDatestamp(),mpi_local=.false.)
do jstep=1,tim_nstepobsinc
datestamplist(jstep)=gsv_getDateStamp(statevector,jstep)
enddo
if(write4dInc) then
! read in the background fields at all increment timesteps
call subasic_gd(statevectorg,vco_trl,tim_nstepobsinc,datestamplist,indexAnalysis)
else
! only read in the background fields at the "analysis" timestep (usually the middle)
call subasic_gd(statevectorg,vco_trl,1,datestamplist(statevector%anltime),indexAnalysis)
endif
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
call tmg_stop(95)
!
! Compute the analysis increment and make mpiglobal (result only on myid=increment_time_step-1)
!
call tmg_start(91,'POST_COMPUTEDX')
call bmat_sqrtB(cvm_vazx,cvm_nvadim,statevector)
if(write4dInc) then
! mpiglobal result for 4D increment only on myid=(increment_time_step -1)
call gsv_commMPIGlobal(statevector)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
else
! mpiglobal result for 3D increment only on myid=0
call gsv_commMPIGlobal3D(statevector)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
endif
call tmg_stop(91)
!
! Allocate fields to hold diagnostic fields
!
if(globalGSVpresent) then
if(write4dInc) then
jstep=mpi_myid+1
else
jstep=statevector%anltime
endif
write(*,*) 'calcWriteIncrement: computing the diag variables for timestep:',jstep
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
allocate( zes(hco_anl%ni, nlev_T, hco_anl%nj) )
allocate( ztv(hco_anl%ni, nlev_T, hco_anl%nj) )
allocate( zgz_M(hco_anl%ni, nlev_M, hco_anl%nj) )
allocate( zgz_T(hco_anl%ni, nlev_T, hco_anl%nj) )
allocate( zhu(hco_anl%ni, nlev_T, hco_anl%nj) )
endif
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
!
! If ens-EnVar, loop over additional types of perturbations to analysis increment
!
if(indexAnalysis.gt.0) then
numPerturbLoop = 2
else
numPerturbLoop = 0
endif
do perturbLoop = 0, numPerturbLoop
if(indexAnalysis.gt.1 .and. perturbLoop.eq.1) then ! THIS IS FOR E1 INCREMENTS
! setup statevectorp for storing the perturbation
call gsv_setVco(statevectorp,vco_anl)
call gsv_setHco(statevectorp,hco_anl)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
call gsv_allocate(statevectorp,tim_nstepobsinc, &
datestamp=tim_getDatestamp(),mpi_local=.true.)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
! compute the (unscaled) perturbation and make it mpiglobal
call tmg_start(91,'POST_COMPUTEDX')
iseed = abs(randSeed) + indexAnalysis
zdum = gasdev(-iseed)
allocate(cv_pert_mpiglobal(cvm_nvadim_mpiglobal))
do jj = 1, cvm_nvadim_mpiglobal
cv_pert_mpiglobal(jj) = gasdev(1)
enddo
allocate(cv_pert_mpilocal(cvm_nvadim))
call bmat_reduceToMPILocal(cv_pert_mpilocal, & ! OUT
cv_pert_mpiglobal, & ! IN
jj ) ! OUT
deallocate(cv_pert_mpiglobal)
if(pertBhiOnly) then
! set Bensemble component of control vector to zero
cv_pert_bens_mpilocal => cvm_getSubVector(cv_pert_mpilocal,2)
cv_pert_bens_mpilocal(:) = 0.0d0
endif
call bmat_sqrtB(cv_pert_mpilocal,cvm_nvadim,statevectorp)
deallocate(cv_pert_mpilocal)
if(pertBhiOnly) then
! undo the Bhi scaleFactor
allocate(scaleFactorBhi(max(nLev_M,nLev_T)))
call bhi_getScaleFactor(scaleFactorBhi)
! for 3D variables
do jvar=1,vnl_numvarmax3D
if(gsv_varExist(vnl_varNameList3D(jvar))) then
field => gsv_getField(statevectorp,vnl_varNameList3D(jvar))
do jlev = 1, gsv_getNumLev(statevectorp,vnl_vartypeFromVarname(vnl_varNameList3D(jvar)))
if(scaleFactorBhi(jlev).gt.0.0d0) then
field(:,jlev,:,:)=field(:,jlev,:,:)/scaleFactorBhi(jlev)
endif
enddo
endif
enddo
! for 2D variables
do jvar=1,vnl_numvarmax2D
if(gsv_varExist(vnl_varNameList2D(jvar))) then
field => gsv_getField(statevectorp,vnl_varNameList2D(jvar))
jlev = max(nLev_M,nLev_T)
if(scaleFactorBhi(jlev).gt.0.0d0) then
field(:,1,:,:)=field(:,1,:,:)/scaleFactorBhi(jlev)
endif
endif
enddo
deallocate(scaleFactorBhi)
endif
if(write4dInc) then
! mpiglobal result for 4D increment only on myid=(increment_time_step -1)
call gsv_commMPIGlobal(statevectorp)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
else
! mpiglobal result for 3D increment only on myid=0
call gsv_commMPIGlobal3D(statevectorp)
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
endif
call tmg_stop(91)
if(globalGSVpresent) then
! add the perturbation times e1_scaleFactor
write(*,*) 'calcWriteIncrement: adding E1 perturbation, scaleFactor=',e1_scaleFactor
call gsv_add(statevectorp,statevector,e1_scaleFactor)
endif
elseif(indexAnalysis.gt.1 .and. perturbLoop.eq.2) then ! THIS IS FOR E2 INCREMENTS
if(globalGSVpresent) then
! add the perturbation again (accumulatively) with modified scaleFactor
write(*,*) 'calcWriteIncrement: adding E2 perturbation, scaleFactor=',e2_scaleFactor
scaleFactor = e2_scaleFactor - e1_scaleFactor
call gsv_add(statevectorp,statevector,scaleFactor)
endif
endif
if(perturbLoop.eq.0) then ! THIS IS FOR UNPERTURBED INCREMENTS
cetikinc = cetikinc_orig
elseif(perturbLoop.eq.1) then ! THIS IS FOR E1 INCREMENTS
if(len_trim(cetikinc_orig).le.9) then
cetikinc = trim(cetikinc_orig) // '_E1'
else
cetikinc = cetikinc_orig
endif
elseif(perturbLoop.eq.2) then ! THIS IS FOR E2 INCREMENTS
if(len_trim(cetikinc_orig).le.9) then
cetikinc = trim(cetikinc_orig) // '_E2'
else
cetikinc = cetikinc_orig
endif
endif
!
! Compute diagnostic variables and write entire increment to file
!
call tmg_start(92,'POST_DIAG')
if(globalGSVpresent) then
!
! Compute HU increment from LQ increment (always)
!
hu_trl_ptr => gsv_getField(statevectorg,'HU') ! this is HU_b
lq_inc_ptr => gsv_getField(statevector ,'HU') ! this is delta LQ
!$OMP PARALLEL DO PRIVATE(jj,jlev,ji,hu_anl)
do jj = 1,statevectorg%nj
do jlev = 1,nlev_T
do ji = 1,statevectorg%ni
! choose either tangent linear or nonlinear operator for LQ to HU
if(useTL_LQtoHU) then
zhu(ji,jlev,jj) = lq_inc_ptr(ji,jlev,jj,1)*hu_trl_ptr(ji,jlev,jj,1)
else
hu_anl = log(hu_trl_ptr(ji,jlev,jj,1)) + lq_inc_ptr(ji,jlev,jj,1)
zhu(ji,jlev,jj) = EXP(hu_anl) - hu_trl_ptr(ji,jlev,jj,1)
endif
enddo
enddo
enddo
!$OMP END PARALLEL DO
!
! Compute ES increment (if requested)
!
do jvar = 1,nppcvar
if(cppcvar(jvar).eq.'ES') call lq2esgd(zes,statevector,statevectorg)
enddo
!
! Compute VT increment (if VT or GZ requested)
!
VARLOOP: do jvar = 1,nppcvar
if(cppcvar(jvar).eq.'VT'.or.cppcvar(jvar).eq.'GZ') then
call lt2tvgd(ztv,statevector,statevectorg)
exit VARLOOP
endif
enddo VARLOOP
!
! Compute GZ increment (if requested)
!
do jvar = 1,nppcvar
if(cppcvar(jvar).eq.'GZ') then
status = vgd_get(statevectorg%vco%vgrid,key='ig_1 - vertical coord code',value=Vcode_anl)
if(Vcode_anl.eq.5001) then
call ltt2phigd(zgz_T,ztv,statevectorg)
else
call ltt2phigd_gem4(zgz_M,zgz_T,ztv,statevector,statevectorg)
endif
endif
enddo
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
endif
call tmg_stop(92)
if(globalGSVpresent) then
!
! Now, write out the increment, including diagostic variables
!
incFileName = './rebm'
if(indexAnalysis.gt.0) then
write(flnum3,'(I1.1)') perturbLoop
incFileName = trim(incFileName) // trim(flnum3)
endif
if(write4dInc) then
call difdatr(datestamplist(jstep),tim_getDatestamp(),deltaHours)
if(nint(deltaHours*60.0d0).lt.0) then
write(flnum,'(I4.3)') nint(deltaHours*60.0d0)
else
write(flnum,'(I3.3)') nint(deltaHours*60.0d0)
endif
write(*,*) 'calcWriteIncrement: dates=',dateStampList(jstep),tim_getDatestamp(),deltaHours,nint(deltaHours*60.0d0)
write(*,*) 'calcWriteIncrement: flnum=###',trim(flnum),'###'
incFileName = trim(incFileName) // '_' // trim(flnum) // 'm'
endif
if(indexAnalysis.gt.0) then
write(flnum2,'(I4.4)') (indexAnalysis-1)
incFileName = trim(incFileName) // '_' // trim(flnum2)
endif
call writeIncrement(incFileName,statevector,zes,ztv,zgz_T,zhu,dateStampList(jstep))
write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
endif ! globalGSVpresent
enddo ! perturbLoop
if(globalGSVpresent) then
deallocate(zes)
deallocate(ztv)
deallocate(zgz_M)
deallocate(zgz_T)
deallocate(zhu)
endif
! free up some memory related to increment
if(indexAnalysis.gt.1) call gsv_deallocate(statevectorp)
call gsv_deallocate(statevectorg)
call gsv_deallocate(statevector)
call tmg_stop (3)
write(*,*) 'LEAVING calcWriteIncrement'
END SUBROUTINE calcWriteIncrement
SUBROUTINE writeIncrement(incFileName,statevector,zes,ztv,zgz_T,zhu,datestamp,val_ip3) 2,9
!
!**s/r writeIncrement - Transfer of the contents of statevector into an RPN
! standard file
!
implicit none
character(len=*) :: incFileName
type(struct_gsv) :: statevector
real(8) :: zes(:,:,:),ztv(:,:,:),zgz_T(:,:,:),zhu(:,:,:)
integer :: datestamp
integer, optional :: val_ip3
integer write_encode_hyb,fnom,fstouv,fstfrm,fclos,vfstecr
integer jvar,jlev,ierr,numlev,nulfile
integer inpak_inc,status,Vcode_anl
real(8) zwork
real(8), allocatable :: zbuffer(:)
real zptop_r4, zpref_r4,zrcoef_r4
integer nip1,nip2,nip3,ndeet,npas,nidatyp,nig1,nig2,nig3,nig4
character(len=1) :: cgrtyp
character(len=2) :: cltypinc
character(len=12) :: cletiket
real(8) :: zlowvar(statevector%ni,statevector%nj)
logical llimplemented,FlipLatitude
WRITE(*,FMT='(/,4X,"Starting writeIncrement",//)')
!
! Read namelist and do some setup
!
if(.not.initialized) call supost
nulfile = 0
write(*,*)'writeIncrement: increment file name = ',trim(incFileName)
ierr = fnom(nulfile,trim(incFileName),'RND',0)
if(ierr.ge.0)then
write(*,*)'writeIncrement: increment file opened with unit number ',nulfile
ierr = fstouv(nulfile,'RND')
else
call abort3d('writeIncrement: problem opening increment file, aborting!')
end if
if(nulfile.eq.0) then
write(*,*) 'writeIncrement: unit number for increment file not valid!'
return
endif
if(present(val_ip3)) then
WRITE(*,FMT='(/,4X,''Transfer of the gridpoint model state on file at iteration No.'',I3)') val_ip3
endif
!
! Setup packing for each variable
!
inpak_inc = -32 ! 32 bits are needed by AAI
write(*,*)'************************************** '
write(*,*) 'PACKING for increments is ',inpak_inc
write(*,*)'************************************** '
!
! Write TIC-TAC if needed
!
if ( statevector % hco % grtyp == 'Z' ) then
ndeet = 0
NIP1 = statevector % hco % ig1
NIP2 = statevector % hco % ig2
NIP3 = 0
NPAS = 0
NIDATYP = 1
CGRTYP = 'E'
CLTYPINC = 'X'
cletiket = cetikinc
call cxgaig ( CGRTYP, & ! IN
NIG1, NIG2, NIG3, NIG4, & ! OUT
real(statevector % hco % xlat1), real(statevector % hco % xlon1), & ! IN
real(statevector % hco % xlat2), real(statevector % hco % xlon2) ) ! IN
allocate(zbuffer(statevector % hco % ni))
zbuffer(:)= statevector % hco % lon(:) * MPC_DEGREES_PER_RADIAN_R8
IERR = VFSTECR(zbuffer,zwork,inpak_inc, &
nulfile,datestamp,ndeet,npas,statevector%ni,1,1,nip1, &
nip2,nip3,cltypinc,'>>',cletiket,cgrtyp,nig1, &
nig2,nig3,nig4,nidatyp,.true.)
deallocate(zbuffer)
allocate(zbuffer(statevector % hco % nj))
zbuffer(:)= statevector % hco % lat(:) * MPC_DEGREES_PER_RADIAN_R8
IERR = VFSTECR(zbuffer,zwork,inpak_inc, &
nulfile,datestamp,ndeet,npas,1,statevector%nj,1,nip1, &
nip2,nip3,cltypinc,'^^',cletiket,cgrtyp,nig1, &
nig2,nig3,nig4,nidatyp,.true.)
deallocate(zbuffer)
end if
!
! Write analysis increments
!
ndeet=0
NIP2 = 0
if(present(val_ip3)) then
NIP3 = val_ip3
else
NIP3 = 0
endif
NPAS = 0
NIDATYP = 1
CGRTYP = statevector % hco % grtyp
CLTYPINC = 'R'
NIG1 = statevector % hco % ig1
if ( statevector % hco % grtyp == 'G' .and. &
statevector % hco % ig2 == 1 ) then
FlipLatitude = .true.
NIG2 = 0
else
FlipLatitude = .false.
NIG2 = statevector % hco % ig2
end if
NIG3 = statevector % hco % ig3
NIG4 = statevector % hco % ig4
cletiket=cetikinc
write(*,*) 'Writing fields for datestamp= ',datestamp
status = vgd_get(statevector%vco%vgrid,key='ig_1 - vertical coord code',value=Vcode_anl)
if(Vcode_anl.eq.5001) then
write(*,*) 'Writing variable HY in analysis-increment file'
zptop_r4 = statevector%vco%dpt_M*MPC_MBAR_PER_PA_R8
zpref_r4 = statevector%vco%dprf_M*MPC_MBAR_PER_PA_R8
zrcoef_r4 = statevector%vco%drcf1
ierr = write_encode_hyb(nulfile,'HY',nip2,nip3,cletiket, &
datestamp,zptop_r4,zpref_r4,zrcoef_r4)
elseif(Vcode_anl.eq.5002) then
write(*,*) 'Writing Vgrid descriptor record in analysis-increment file'
status = vgd_write(statevector%vco%vgrid,nulfile,'fst')
else
write(*,*) 'Vcode_anl=',Vcode_anl
call abort3d('writeIncrement: unknown value of Vcode!')
endif
!
! Analysis grid hybrid vertical coordinate parameters
!
write(*,*)' '
write(*,*)'************************************** '
write(*,*) ' The hybride coordinate parameters from increment', &
' analysis grid are:'
write(*,*) ' PTOP = ',statevector%vco%dpt_M*MPC_MBAR_PER_PA_R8,' MB'
write(*,*) ' PREF = ',statevector%vco%dprf_M*MPC_MBAR_PER_PA_R8,' MB'
write(*,*) ' RCOEF= ',statevector%vco%drcf1
write(*,*)'************************************** '
write(*,*)' '
do jvar = 1, nppcvar
!
! Some variable may be request for other to be computed but not
! necessaraly wanted as output..
!
llimplemented = .true.
write(*,*) 'Writing variable ',cppcvar(jvar)
numlev = gsv_getNumLev(statevector,vnl_vartypeFromVarname(cppcvar(jvar)))
write(*,*) 'numlev=',numlev
do jlev=1,numlev
call gdout2(cppcvar(jvar),ZLOWVAR,jlev, &
llimplemented,nip1,FlipLatitude,statevector,zes,ztv,zgz_T,zhu)
if(.not.llimplemented) exit
IERR = VFSTECR(ZLOWVAR,zwork,inpak_inc &
,nulfile,datestamp,ndeet,npas,statevector%ni,statevector%nj,1,nip1 &
,nip2,nip3,cltypinc,cppcvar(jvar),cletiket,cgrtyp,nig1 &
,nig2,nig3,nig4,nidatyp,.true.)
if(nip1.eq.0) exit
enddo
enddo
ierr = fstfrm(nulfile)
ierr = fclos(nulfile)
write(*,*) 'END of writeIncrement'
END SUBROUTINE writeIncrement
subroutine lq2esgd(pesinc,statevector,statevectorg) 1,10
!
!**S/R lq2esgd - Computes increments of ES=T-TD FROM T AND lnq
! increments in Grid-Point Space.
!
!Arguments:
!
! Out:
! pesinc : Dew-point depression increment on the analysis grid
! IN:
! statevector : increment
! statevectorg : Background state on analysis grid
!
!Object: For Postprocessing analysis increment (called by DIAG3DVAR):
! calculate the TLM OF dew point depression from TLM specific
! humidity, temperature and pressure. No ice phase is
! CONSIDERED.
!
IMPLICIT NONE
type(struct_gsv) :: statevector,statevectorg
real(8) pesinc(:,:,:)
integer ji,jj,jlev,nlev_T,status
REAL(8) ZE, ZEL, ZTD, ZTDL, ZGAMMA
real(8), pointer :: ps_trl_ptr(:,:,:,:),ps_inc_ptr(:,:,:,:),hu_trl_ptr(:,:,:,:),hu_inc_ptr(:,:,:,:),tt_inc_ptr(:,:,:,:)
real(8), pointer :: zpres(:,:,:) => null()
real(8), pointer :: dPdPsfc(:,:,:) => null()
real(8), allocatable :: ps_trl(:,:)
write(*,FMT='(/,4X,"Starting LQ2ESGD",//)')
ps_trl_ptr => gsv_getField(statevectorg,'P0')
ps_inc_ptr => gsv_getField(statevector ,'P0')
hu_trl_ptr => gsv_getField(statevectorg,'HU')
hu_inc_ptr => gsv_getField(statevector ,'HU')
tt_inc_ptr => gsv_getField(statevector ,'TT')
nlev_T = gsv_getNumLev(statevectorg,'TH')
allocate(ps_trl(statevectorg%ni,statevectorg%nj))
ps_trl(:,:) = ps_trl_ptr(:,1,:,1)
status=vgd_levels(statevectorg%vco%vgrid,ip1_list=statevectorg%vco%ip1_T, &
levels=zpres,sfc_field=ps_trl,in_log=.false.)
status = vgd_dpidpis(statevectorg%vco%vgrid,statevectorg%vco%ip1_T,dPdPsfc,ps_trl)
!$OMP PARALLEL DO PRIVATE(jlev,jj,ji,ze,zel,ztd,zgamma,ztdl)
do jj=1,statevectorg%nj
do ji=1,statevectorg%ni
do jlev=1,nlev_T
!
! First do the forward branch to get vapour pressure from q
!
ZE = FOEFQ8(max(hu_trl_ptr(ji,jlev,jj,1),1.d-12), zpres(ji,jj,jlev) )
!
! TLM of the vapor pressure from q (specific humidity)
!
ZEL = FOEFQL(hu_inc_ptr(ji,jlev,jj,1),ps_inc_ptr(ji,1,jj,1), &
hu_trl_ptr(ji,jlev,jj,1),zpres(ji,jj,jlev),dPdPsfc(ji,jj,jlev))
!
! TLM of the dewpoint temperature calculation from Teten's relation
!
ZTD=FOTW8(ZE)
ZGAMMA=FODTW8(ZTD,ZE)
ZTDL = ZGAMMA*ZEL
pesinc(ji,jlev,jj) = tt_inc_ptr(ji,jlev,jj,1) - ZTDL
enddo
enddo
enddo
!$OMP END PARALLEL DO
! array allocated by vgrid
deallocate(zpres,dPdPsfc)
END subroutine lq2esgd
subroutine lt2tvgd(ptv,statevector,statevectorg) 1,4
!
! s/r lt2tvgd: TL transform from delT to delTv
!
IMPLICIT NONE
type(struct_gsv) :: statevector,statevectorg
real(8) :: ptv(:,:,:)
real(8), pointer :: hu_trl_ptr(:,:,:,:),tt_inc_ptr(:,:,:,:),hu_inc_ptr(:,:,:,:)
integer :: ji,jj,jlev,nlev_T
WRITE(*,FMT='(/,4X,"Starting LT2TVGD",//)')
hu_trl_ptr => gsv_getField(statevectorg,'HU')
tt_inc_ptr => gsv_getField(statevector ,'TT')
hu_inc_ptr => gsv_getField(statevector ,'HU')
nlev_T = gsv_getNumLev(statevector,'TH')
!$OMP PARALLEL DO PRIVATE(jj,jlev,ji)
do jj = 1, statevector%nj
do jlev = 1, nlev_T
do ji = 1, statevector%ni
ptv(ji,jlev,jj)=(1.D0+MPC_DELTA_R8*hu_trl_ptr(ji,jlev,jj,1))*tt_inc_ptr(ji,jlev,jj,1) + &
MPC_DELTA_R8*hu_trl_ptr(ji,jlev,jj,1)*tt_inc_ptr(ji,jlev,jj,1)*hu_inc_ptr(ji,jlev,jj,1)
enddo
enddo
enddo
!$OMP END PARALLEL DO
END subroutine lt2tvgd
SUBROUTINE ltt2phigd_gem4(delGz_M,delGz_T,delTv,statevector,statevectorg) 1,8
!
!**s/r ltt2phigd_gem4 - Temperature to geopotential transformation on GEM4 staggered levels
! NOTE: we assume
! 1) nlev_T = nlev_M+1
! 2) GZ_T(nlev_T) = GZ_M(nlev_M), both at the surface
! 3) a thermo level exists at the top, higher than the highest momentum level
! 4) the placement of the thermo levels means that GZ_T is the average of 2 nearest GZ_M
! (according to Ron and Claude)
!
!Author : M. Buehner, February 2014
!
implicit none
real(8) :: delGZ_M(:,:,:),delGZ_T(:,:,:)
real(8) :: delTv(:,:,:)
type(struct_gsv) :: statevector,statevectorg
integer :: jlat,jlon,lev_M,lev_T,nlev_M,nlev_T
integer :: status
real(8) :: hu,tt,ratioP1
real(8), allocatable :: tv(:),ratioP(:)
real(8), allocatable :: delLnP_M(:),delLnP_T(:)
real(8), pointer :: Psfc(:,:),ps_ptr(:,:,:,:),zpres3d_ptr(:,:,:)
real(8), pointer :: dP_dPsfc_M(:,:,:),dP_dPsfc_T(:,:,:)
real(8), pointer :: Pres_M(:,:,:),Pres_T(:,:,:)
real(8), pointer :: hu_ptr(:,:,:,:),tt_ptr(:,:,:,:),delPsfc(:,:,:,:)
write(*,FMT='(/,4X,"Starting LTT2PHIGD_GEM4",//)')
nlev_T = gsv_getNumLev(statevectorg,'TH')
nlev_M = gsv_getNumLev(statevectorg,'MM')
if(nlev_T .ne. nlev_M+1) call abort3d('ltt2phi_gem4: nlev_T is not equal to nlev_M+1!')
delPsfc => gsv_getField(statevector ,'P0')
! compute pressure on all levels
ps_ptr => gsv_getField(statevectorg,'P0')
Psfc => ps_ptr(:,1,:,1)
status=vgd_levels(statevectorg%vco%vgrid,ip1_list=statevectorg%vco%ip1_M, &
levels=Pres_M,sfc_field=Psfc,in_log=.false.)
status=vgd_levels(statevectorg%vco%vgrid,ip1_list=statevectorg%vco%ip1_T, &
levels=Pres_T,sfc_field=Psfc,in_log=.false.)
! compute dP_dPsfc on all levels
status = vgd_dpidpis(statevectorg%vco%vgrid,statevectorg%vco%ip1_M,dP_dPsfc_M,Psfc)
status = vgd_dpidpis(statevectorg%vco%vgrid,statevectorg%vco%ip1_T,dP_dPsfc_T,Psfc)
allocate(tv(nlev_T))
allocate(ratioP(nlev_T))
allocate(delLnP_M(nlev_M))
allocate(delLnP_T(nlev_T))
hu_ptr => gsv_getField(statevectorg,'HU')
tt_ptr => gsv_getField(statevectorg,'TT')
! loop over all horizontal gridpoints
do jlat = 1, statevectorg%nj
do jlon = 1, statevectorg%ni
! initialize GZ increment to zero
delGz_M(jlon,:,jlat) = 0.0d0
delGz_T(jlon,:,jlat) = 0.0d0
! compute lnP increment on momentum and thermo levels
do lev_M = 1, nlev_M
delLnP_M(lev_M) = dP_dPsfc_M(jlon,jlat,lev_M)*delPsfc(jlon,1,jlat,1)/ &
Pres_M(jlon,jlat,lev_M)
enddo
do lev_T = 1, nlev_T
delLnP_T(lev_T) = dP_dPsfc_T(jlon,jlat,lev_T)*delPsfc(jlon,1,jlat,1)/ &
Pres_T(jlon,jlat,lev_T)
enddo
! compute background virtual temperature
do lev_T = 1, nlev_T
hu = hu_ptr(jlon,lev_T,jlat,1)
tt = tt_ptr(jlon,lev_T,jlat,1)
tv(lev_T) = fotvt8(tt,hu)
enddo
! compute natural log of momenutum level pressure ratios for each layer
do lev_M = 1,(nlev_M-1)
lev_T = lev_M+1 ! thermo level just below momentum level
ratioP(lev_T) = log( Pres_M(jlon,jlat,lev_M+1) / &
Pres_M(jlon,jlat,lev_M ) )
enddo
! compute GZ increment on momentum levels
do lev_M = (nlev_M-1), 1, -1
lev_T = lev_M+1 ! thermo level just below momentum level being computed
delGz_M(jlon,lev_M,jlat) = delGz_M(jlon,lev_M+1,jlat) + &
MPC_RGAS_DRY_AIR_R8*( ratioP(lev_T)*delTv(jlon,lev_T,jlat) + &
tv(lev_T)*(delLnP_M(lev_M+1) - &
delLnP_M(lev_M)) )
enddo
! compute GZ increment for top thermo level (from top momentum level)
ratioP1 = log( Pres_M(jlon,jlat,1) / &
Pres_T(jlon,jlat,1) )
delGz_T(jlon,1,jlat) = delGz_M(jlon,1,jlat) + &
MPC_RGAS_DRY_AIR_R8*( ratioP1*delTv(jlon,1,jlat) + &
tv(1)*(delLnP_M(1) - delLnP_T(1)) )
! compute GZ increment on remaining thermo levels by simple averaging
do lev_T = 2, (nlev_T-1)
lev_M = lev_T ! momentum level just below thermo level being computed
delGz_T(jlon,lev_T,jlat) = 0.5d0*( delGz_M(jlon,lev_M-1,jlat) + &
delGz_M(jlon,lev_M,jlat) )
enddo
enddo
enddo
deallocate(tv)
deallocate(ratioP)
deallocate(delLnP_M)
deallocate(delLnP_T)
! arrays allocated by vgrid
deallocate(Pres_M,Pres_T)
deallocate(dP_dPsfc_M,dP_dPsfc_T)
end subroutine ltt2phigd_gem4
SUBROUTINE ltt2phigd(pgz,ptt,statevectorg) 1,5
!
!**s/r ltt2phigd - Grid-point version of ltt2phi.ftn
!
!Arguments
! in-
! ptt : 4D Temperature Incr. appearing on r.h.s. of TL-eq.
! out-
! pgz : 4D GZ fields computed from TL-Hydrostatic equation
IMPLICIT NONE
type(struct_gsv) :: statevectorg
real(8) pgz(:,:,:)
real(8) ptt(:,:,:)
real(8), allocatable :: vma(:),vmb(:),vmc(:),vmd(:),vme(:),vmf(:)
INTEGER JLEV, JLAT, JLON, NLEV_T
real(8) zalpha
real(8), allocatable :: zprof(:)
real(8), pointer :: ps_ptr(:,:,:,:), zpres3d_ptr(:,:,:)
real(8), pointer :: zps2d(:,:)
integer status
write(*,FMT='(/,4X,"Starting LTT2PHIGD",//)')
nlev_T = gsv_getNumLev(statevectorg,'TH')
zalpha=-1.0D0
allocate(vma(nlev_T))
allocate(vmb(nlev_T))
allocate(vmc(nlev_T))
allocate(vmd(nlev_T))
allocate(vme(nlev_T))
allocate(vmf(nlev_T))
allocate(zprof(nlev_T))
!
! Prepare r.h.s. for TL-Hydrostatic equation
!
ps_ptr => gsv_getField(statevectorg,'P0')
zps2d => ps_ptr(:,1,:,1)
status=vgd_levels(statevectorg%vco%vgrid, &
ip1_list=statevectorg%vco%ip1_T, &
levels=zpres3d_ptr,sfc_field=zps2d,in_log=.false.)
if(status.ne.VGD_OK)then
call abort3d('ERROR with vgd_levels for desired levels ')
endif
do jlat = 1, statevectorg%nj
do jlon = 1, statevectorg%ni
do jlev = 1,nlev_T
zprof(jlev) = zpres3d_ptr(jlon,jlat,jlev)
enddo
call matapat(zprof,zalpha,nlev_T,vma,vmb,vmc,vmd,vme,vmf)
call lvtapgd(pgz,ptt,jlon,jlat)
enddo
enddo
deallocate(vma)
deallocate(vmb)
deallocate(vmc)
deallocate(vmd)
deallocate(vme)
deallocate(vmf)
deallocate(zprof)
! array allocated by vgrid
deallocate(zpres3d_ptr)
RETURN
CONTAINS
subroutine lvtapgd(pgz,ptt,ki,kj) 1
!S/P LVTAPGD:
!
! CALCULE Y A PARTIR DE R PAR SOLUTION DE L'EQUATION R*CON=S**E*D(Y)
! AVEC UN SCHEME DU 4EME ORDRE DU A J. COTE.
! NOTE: CET ALGORITHME EST EXACTEMENT REVERSIBLE (VOIR VPAT).
!
! ON DOIT FOURNIR LA COND
! A LA LIMITE INF. Y(N). LA MATRICE MATAP A ETE CALCULEE DANS LA
! SUBR. MATAPAT.
!
IMPLICIT NONE
integer ki,kj
INTEGER IKLEVM2, JLEV, IK
REAL(8) ZAK, ZBK, ZCK, ZCON
real(8) pgz(:,:,:)
real(8) ptt(:,:,:)
!
! ptt : working vector of virtual temperatures.
!
ZCON = -MPC_RGAS_DRY_AIR_R8
ZAK = -2.0D0*ZCON*VMA(nlev_T)
ZBK = -2.0D0*ZCON*VMB(nlev_T)
ZCK = -2.0D0*ZCON*VMC(nlev_T)
pgz(ki,nlev_T,kj) = 0.0D0
pgz(ki,nlev_T-1,kj)=ZAK*ptt(ki,nlev_T-1,kj)+ &
ZBK*ptt(ki,nlev_T,kj)+ &
ZCK*ptt(ki,nlev_T-2,kj)+ &
pgz(ki,nlev_T,kj)
IKLEVM2 = nlev_T-2
do JLEV = 1, IKLEVM2
IK = nlev_T-1-JLEV
ZAK = -2.0D0*ZCON*VMA(IK+1)
ZBK = -2.0D0*ZCON*VMB(IK+1)
ZCK = -2.0D0*ZCON*VMC(IK+1)
pgz(ki,ik,kj)= ZAK*ptt(ki,IK,kj)+ &
ZBK*ptt(ki,IK+1,kj)+ &
ZCK*ptt(ki,IK+2,kj)+ &
pgz(ki,IK+2,kj)
enddo
END SUBROUTINE lvtapgd
END subroutine ltt2phigd
SUBROUTINE GDOUT2(varName,pptrans,KLEV,lplok,kip1,FlipLatitude,statevector,zes,ztv,zgz_T,zhu) 1,7
!
!**s/r GDOUT2 - Transfer of the content of COMGD0 on a RPN
! . standard file.
!
!Arguments
! i varName : variable name
! i KLEV : index of the level to be transferred
! OUTPUT
! o pptrans : vector containing the variable
! o lplok : logical indicating if the variable has been
! implemented
! o kip1 : ip1 of the corresponding level
IMPLICIT NONE
INTEGER klev,kip1
type(struct_gsv) :: statevector
real(8), pointer :: field_ptr(:,:,:,:)
real(8) :: pptrans(:,:)
real(8) :: zes(:,:,:)
real(8) :: ztv(:,:,:)
real(8) :: zgz_T(:,:,:)
real(8) :: zhu(:,:,:)
character(len=*) :: varName
logical lplok, FlipLatitude
INTEGER JLON, JGL
REAL(8) ZTEMP, ZGEOP, ZDAM, ZCON
!
lplok = .true.
!
IF(trim(varName).EQ.'VT') THEN
!
! Virtual temperature field
!
kIP1 = statevector%vco%ip1_T(klev)
DO JLON = 1, statevector%ni
DO JGL = 1, statevector%nj
PPTRANS(JLON,JGL) = ZTV(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(trim(varName).EQ.'GZ') THEN
!
! Geopotential field
!
kIP1 = statevector%vco%ip1_T(klev)
ZGEOP = 10.0d0 * RG
ZDAM = 1.0d0/ZGEOP
DO JLON = 1, statevector%ni
DO JGL = 1, statevector%nj
PPTRANS(JLON,JGL) = ZDAM * zgz_T(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(trim(varName).EQ.'UU'.or.trim(varName).EQ.'VV') THEN
!
! Wind component (in Knots)
!
kIP1 = statevector%vco%ip1_M(klev)
field_ptr => gsv_getField(statevector,varName)
DO JGL = 1, statevector%nj
DO JLON = 1, statevector%ni
PPTRANS(JLON,JGL) = field_ptr(JLON,KLEV,JGL,1)*MPC_KNOTS_PER_M_PER_S_R8
END DO
END DO
ELSE IF(trim(varName).EQ.'ES') THEN
!
! Humidity field T - Td
!
kIP1 = statevector%vco%ip1_T(klev)
DO JLON = 1, statevector%ni
DO JGL = 1, statevector%nj
PPTRANS(JLON,JGL) = zes(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(trim(varName).EQ.'LQ') THEN
!
! Humidity field ln(HU)
!
kIP1 = statevector%vco%ip1_T(klev)
field_ptr => gsv_getField(statevector,'HU')
DO JLON = 1, statevector%ni
DO JGL = 1, statevector%nj
PPTRANS(JLON,JGL) = field_ptr(JLON,KLEV,JGL,1)
END DO
END DO
ELSE IF(trim(varName).EQ.'HU') THEN
!
! Humidity field HU
!
kIP1 = statevector%vco%ip1_T(klev)
DO JLON = 1, statevector%ni
DO JGL = 1, statevector%nj
PPTRANS(JLON,JGL) = zhu(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(trim(varName).EQ.'P0') THEN
!
! Surface Pressure from units of Pascal to millibar
!
kip1=0
field_ptr => gsv_getField(statevector,varName)
DO JLON = 1, statevector%ni
DO JGL = 1, statevector%nj
PPTRANS(JLON,JGL) = field_ptr(JLON,1,JGL,1)*MPC_MBAR_PER_PA_R8
END DO
END DO
else
!
! All remaining 2D and 3D variables that do not require unit conversions
!
if(gsv_varExist(varName)) then
field_ptr => gsv_getField(statevector,varName)
if(vnl_vartypeFromVarname(varName).eq.'SF') then
kip1=0
do jlon = 1, statevector%ni
do jgl = 1, statevector%nj
pptrans(jlon,jgl) = field_ptr(jlon,1,jgl,1)
enddo
enddo
else
if(vnl_vartypeFromVarname(varName).eq.'MM') then
kIP1 = statevector%vco%ip1_M(klev)
else
kIP1 = statevector%vco%ip1_T(klev)
endif
do jlon = 1, statevector%ni
do jgl = 1, statevector%nj
pptrans(jlon,jgl) = field_ptr(jlon,klev,jgl,1)
enddo
enddo
endif
else
LPLOK = .FALSE.
WRITE(*,*)' ****************************************'
WRITE(*,'(" GDOUT2: THE FOLLOWING FIELD IS NOT SUPPORTED varName= ",A2)')varName
WRITE(*,*)' ****************************************'
endif
ENDIF
IF (lplok .and. FlipLatitude) THEN
DO JLON = 1, statevector%ni
DO JGL = 1, statevector%nj/2
ZTEMP = pptrans(JLON,JGL)
pptrans(JLON,JGL) = pptrans(JLON,statevector%nj-JGL+1)
pptrans(JLON,statevector%nj-JGL+1)= ZTEMP
end do
end do
END IF
END subroutine gdout2
subroutine subasic_gd(statevectorg,vco_trl,numStep,datestamplist,indexAnalysis) 2,14
!
!**s/r subasic_gd - Get some background fields on analysis grid.
! These fields are needed for:
! Postprocessing diagnostic analysis increments on the analysis grid
! using TL observation operators.
! IMPORTANT: when numStep>1, each 3D background state is
! stored in statevectorg only when myid = timestep-1, i.e.
! one 3D state per processor
!
IMPLICIT NONE
INTEGER INI,INJ,INK,IG1,IG2,IG3,IG4,IERR,numStep
integer :: indexAnalysis
INTEGER :: datestamplist(numStep)
CHARACTER(len=2) :: CLTYPVAR
CHARACTER(len=1) :: CLGRTYP
CHARACTER(len=4) :: CLNOMVAR
CHARACTER(len=12) :: CLETIKET
INTEGER FNOM,FSTFRM,FCLOS,FSTOUV,FSTINF
type(struct_gsv) :: statevectorg
type(struct_vco), pointer :: vco_trl
type(struct_vco), pointer :: vco_anl
type(struct_hco), pointer :: hco_anl
logical ltrial
integer datestamp,jfile,jstep
integer anl_gid,ezqkdef
REAL*8, allocatable :: zttg(:,:,:), zqqg(:,:,:), zpsg(:,:)
real*8, pointer :: ps_ptr(:,:,:,:),tt_ptr(:,:,:,:),hu_ptr(:,:,:,:)
integer ntrials, nlev_T
integer :: nultrl(tim_nstepobs)
CHARACTER(len=2) :: flnum
CHARACTER(len=4) :: flnum2
CHARACTER(len=128) :: trialfile
WRITE(*,FMT='(/,4X,"Starting SUBASIC_GD",//)')
vco_anl => gsv_getVco(statevectorg)
nlev_T = gsv_getNumLev(statevectorg,'TH')
allocate(zpsg(statevectorg%ni,statevectorg%nj))
allocate(zttg(statevectorg%ni,statevectorg%nj,nlev_T))
allocate(zqqg(statevectorg%ni,statevectorg%nj,nlev_T))
!
! Open all of the Trial fields
!
call tmg_start(96,'POST_READBASIC')
nultrl(:)=0
ntrials=0
do
write(flnum,'(I2.2)') ntrials+1
trialfile='./trlm_' // trim(flnum)
if(indexAnalysis.gt.0) then
write(flnum2,'(I4.4)') (indexAnalysis-1)
trialfile = trim(trialfile) // '_' // trim(flnum2)
endif
inquire(file=trim(trialfile),exist=ltrial)
if(ltrial) then
ntrials=ntrials+1
ierr=fnom(nultrl(ntrials),trim(trialfile),'RND+OLD+R/O',0)
write(*,*) 'ITRIAL - File :', trim(trialfile)
write(*,*) ' opened as unit file ',nultrl(ntrials)
ierr = fstouv(nultrl(ntrials),'RND+OLD')
else if ( (.not. ltrial) .and. ntrials >0 ) then
exit
else if ( (.not. ltrial) .and. ntrials == 0 ) then
CALL ABORT3D('SUBASIC_GD:NO TRIAL FILE')
endif
enddo
if(ntrials.ne.tim_nstepobs) then
write(*,*) 'ntrials, tim_nstepobs = ',ntrials, tim_nstepobs
call abort3d('subasic_gd: ntrials <> tim_nstepobs')
endif
call tmg_stop(96)
!
! Define horizontal analysis grid
!
hco_anl => hco_Get('Analysis')
anl_gid = hco_anl % EZscintID
!
! Read trial fields and interpolate them (horizontal & vertical) to analysis grid
!
CLETIKET = ' '
CLTYPVAR = 'P'
do jstep=1,numStep
datestamp=datestamplist(jstep)
!
! Surface-pressure
!
write(*,*)'subasic_gd: reading P0'
CLNOMVAR = 'P0'
write(*,*) 'subasic_gd: datestamp = ',datestamp
! read the background P0, interpolate to analysis grid and put result on proc jstep-1
! NOTE: all processors participate in reading the file
call vhfstfld(zpsg,statevectorg%ni,statevectorg%nj,anl_gid, &
1,clnomvar,datestamp,nultrl,ntrials,jstep,vco_anl,vco_trl)
! copy interpolated P0 to statevectorg
call tmg_start(96,'POST_READBASIC')
if(mpi_myid.eq.(jstep-1)) then
ps_ptr => gsv_getField(statevectorg,'P0')
CALL INITGDG2(ps_ptr(:,:,:,1),zpsg,statevectorg%ni,statevectorg%nj,1,CLNOMVAR)
endif
call tmg_stop(96)
if(basic_tt) then
!
! Temperature
!
write(*,*)'subasic_gd: reading TT'
CLNOMVAR = 'TT'
! read the background TT, interpolate to analysis grid and put result on proc jstep-1
! NOTE: all processors participate in reading the file
call vhfstfld(zttg,statevectorg%ni,statevectorg%nj,anl_gid, &
nlev_T,clnomvar,datestamp,nultrl,ntrials,jstep,vco_anl,vco_trl)
! copy interpolated TT to statevectorg
call tmg_start(96,'POST_READBASIC')
if(mpi_myid.eq.(jstep-1)) then
tt_ptr => gsv_getField(statevectorg,'TT')
CALL INITGDG2(tt_ptr(:,:,:,1),zttg,statevectorg%ni,statevectorg%nj,nlev_T,CLNOMVAR)
endif
call tmg_stop(96)
endif
if(basic_hu) then
!
! Specific-Humidity
!
write(*,*)'subasic_gd: reading HU'
CLNOMVAR = 'HU'
! read the background HU, interpolate to analysis grid and put result on proc jstep-1
! NOTE: all processors participate in reading the file
call vhfstfld(zqqg,statevectorg%ni,statevectorg%nj,anl_gid, &
nlev_T,clnomvar,datestamp,nultrl,ntrials,jstep,vco_anl,vco_trl)
! copy interpolated HU to statevectorg
call tmg_start(96,'POST_READBASIC')
if(mpi_myid.eq.(jstep-1)) then
hu_ptr => gsv_getField(statevectorg,'HU')
CALL INITGDG2(hu_ptr(:,:,:,1),zqqg,statevectorg%ni,statevectorg%nj,nlev_T,CLNOMVAR)
endif
call tmg_stop(96)
endif
enddo ! jstep
!
! Close the Trials files
!
call tmg_start(96,'POST_READBASIC')
do jfile=1,ntrials
ierr=fstfrm(nultrl(jfile))
ierr=fclos(nultrl(jfile))
enddo
write(*,*) 'Trial files have been closed'
call tmg_stop(96)
deallocate(zpsg)
deallocate(zttg)
deallocate(zqqg)
end subroutine subasic_gd
subroutine vhfstfld(pvar,ini_anl,inj_anl,ktrggid,knk,varName,kstampv,kulfst,ktrials,kstep,vco_anl,vco_trl) 3,18
!
!**s/r vhfstfld - Interpolate background fields on analysis grid.
! These fields are need for posprocessing diagnostic
! analysis increments on the analysis grid using
! TL observation operators.
!
!Author : S. Pellerin *ARMA/SMC May 2000
!
!Arguments
! Output:
! pvar(ini_anl,inj_anl,knk) : Interpolated Output variable
! Input:
! ini_anl,inj_anl: dimensions of horizontal analysis grid
! ktrggid : grid id of output variable
! knk : Number of level of targetted variable
! varName : Variable nomvar
! kstampv : Valid CMC date-time stamp values for reserch in
! fst source file
! kulfst : Unit of pre-opened standard file containing src fields
! ktrials : number of trial files.
IMPLICIT NONE
type(struct_vco), pointer :: vco_anl, vco_trl
integer :: ktrials,kstep
integer :: kulfst(ktrials)
integer :: INI_ANL,INJ_ANL,KNK,ktrggid,kstampv
integer :: INI,INJ,INK,IG1,IG2,IG3,IG4,fstinf
integer :: inlev
real*8 :: pvar(ini_anl,inj_anl,knk)
character(len=*) :: varName
integer, parameter :: kmaxlev=200
integer :: jlev,jlat,jlon
integer :: iip1s(kmaxlev),iip1,iip2,iip3,itrlnlev,itrlgid
integer :: ikey,ezgprm,vfstluk,fstluk,ezsetopt,ezsint
integer :: ezdefset,iset
integer :: ikind,imode,ip1style,ip1kind
integer :: koutmpg
real*8 :: zeta(kmaxlev)
real*8, allocatable :: zhighvar(:,:)
real*8, allocatable :: zlowvar(:,:,:)
real*8, allocatable :: zpstrl(:,:),zps(:,:)
real*8, pointer :: zprestrl(:,:,:),zpresanl(:,:,:)
character(len=1) :: clstring
integer :: status,tag,pe_send,pe_recv,nsize,ierr
character(len=2) :: CLTYPVAR
character(len=1) :: CLGRTYP
character(len=12) :: CLETIKET
integer :: nsizes(0:(mpi_nprocs-1)), displs(0:(mpi_nprocs-1))
WRITE(*,FMT='(/,4X,"Starting VHFSTFLD",//)')
ierr = ezsetopt('INTERP_DEGREE','LINEAR')
!
! get field parameters from trial field
!
! Special case for GZ which is present at both thermo and momentum
! levels trial field file.
! We will process GZ on momentum levels only.
! We will therefore get the parameters for UU which is present
! on momentum levels.
if (varName .eq. 'GZ') then
call abort3d('vhfstfld (subasic_gd): use of GZ background state not supported!')
else
call getfldprm2(IIP1S,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR &
,ITRLGID,varName,kstampv,kmaxlev,kulfst &
,ip1style,ip1kind,ktrials,koutmpg)
endif
! Convert ip1 to real value P
imode = -1
ikind = ip1kind
do jlev = 1,itrlnlev
call VCONVIP( iip1s(jlev), zeta(jlev), ikind, imode, clstring, .false. )
enddo
call vsort(zeta,itrlnlev)
! Convert real value P to IP
imode = ip1style
ikind = ip1kind
do jlev = 1,itrlnlev
call VCONVIP(iip1s(jlev),zeta(jlev),ikind,imode,clstring, .false.)
enddo
iset = ezdefset(ktrggid,itrlgid)
ierr = ezgprm(itrlgid,clgrtyp,ini,inj,ig1,ig2,ig3,ig4)
allocate(zhighvar(ini,inj))
allocate(zlowvar(ini_anl,inj_anl,itrlnlev))
write(*,*)'vhfstfld: reading ',varName
call rpn_comm_barrier("GRID",ierr)
call tmg_start(96,'POST_READBASIC')
do JLEV = (1+mpi_myid),itrlnlev,mpi_nprocs
! Read the high-res trial field
ikey = fstinf(koutmpg, INI, INJ, INK, kstampv, cletiket, iip1s(jlev), iip2, iip3,cltypvar,varName)
if (ikey.lt.0) then
write(*,*) 'Problems finding variable ',varName,' at level ',iip1s(jlev),' in trial file'
call abort3d('VHFSTFLD')
endif
ikey = vfstluk(zhighvar,ikey,INI,INJ,INK)
!
! Do horizontal interpolation
!
if(trim(varName).ne.'UV') then
call vezsint(zlowvar(:,:,jlev),zhighvar,ini_anl,inj_anl,1,ini,inj,1)
else
call abort3d('vhfstfld: vector interpolation no longer supported')
endif
enddo !jlev
call tmg_stop(96)
!
! Send all vertical levels to myid = kstep-1
!
call rpn_comm_barrier("GRID",ierr)
call tmg_start(94,'POST_COMM1')
do jlev = 1,itrlnlev
pe_send = mod(jlev-1,mpi_nprocs)
pe_recv = kstep-1
tag = pe_send+1
nsize=ini_anl*inj_anl
if(pe_send.ne.pe_recv) then
if(mpi_myid.eq.pe_send) then
call rpn_comm_send(zlowvar(:,:,jlev),nsize,"mpi_double_precision",pe_recv,tag,"GRID",ierr)
elseif(mpi_myid.eq.pe_recv) then
call rpn_comm_recv(zlowvar(:,:,jlev),nsize,"mpi_double_precision",pe_send,tag,"GRID",status,ierr)
endif
endif !pe_send <> pe_recv (i.e. kstep-1)
enddo !jlev
call tmg_stop(94)
deallocate(zhighvar)
call tmg_start(97,'POST_VINTERP')
! From now on, only the processor with the data does work
if(mpi_myid.eq.kstep-1) then
!
! Do vertical interpolation:
!
if (itrlnlev.gt.1) then
write(*,*) 'vhfstfld: Reading P0 trial field for vertical interpolation'
call getfldprm(IIP1,IIP2,IIP3,INLEV,CLETIKET,CLTYPVAR, &
ITRLGID,'P0',kstampv,kmaxlev,koutmpg, &
ip1style,ip1kind)
ikey = FSTINF(koutmpg, INI, INJ, INK, kstampv, cletiket, &
iip1, iip2, iip3,cltypvar,'P0')
if(ikey.lt.0) then
write(*,*) ' ******* ERROR ******* '
write(*,*) 'No P0 found in ',koutmpg
call abort3d('VHFSTFLD')
endif
allocate(zpstrl(ini,inj))
ikey = VFSTLUK(zpstrl, ikey, INI, INJ, INK)
zpstrl(:,:)=zpstrl(:,:)*MPC_PA_PER_MBAR_R8
allocate(zps(ini_anl,inj_anl))
!
! Interpolation of high res. P0 to low res. variable grid
!
call vezsint(zps,zpstrl,ini_anl,inj_anl,1,ini,inj,1)
status=vgd_levels(vco_anl%vgrid,ip1_list=vco_anl%ip1_T, &
levels=zpresanl,sfc_field=zps,in_log=.false.)
if(status.ne.VGD_OK)then
call abort3d('ERROR with vgd_levels for anl levels')
endif
if (trim(varName) .eq. 'GZ') then
call abort3d('vhfstfld (subasic_gd): use of GZ background state not supported!')
else
status=vgd_levels(vco_trl%vgrid,ip1_list=vco_trl%ip1_T, &
levels=zprestrl,sfc_field=zps,in_log=.false.)
endif
if(status.ne.VGD_OK)then
call abort3d('ERROR with vgd_levels for trl levels')
endif
call vintgd(pvar,zpresanl,knk,zlowvar,zprestrl,itrlnlev,ini_anl,inj_anl)
deallocate(zpresanl)
deallocate(zps)
deallocate(zprestrl)
else
if (knk.ne.itrlnlev) then
write(*,*) ' *********** ERROR ***********'
write(*,*) 'Number of level inconsistancies'
write(*,*) knk,' levels asked on output and '
write(*,*) itrlnlev,' levels found in standard file'
write(*,*) ' *********** ERROR ***********'
call abort3d('VHFSTFLD')
else
jlev=1
do jlat = 1, inj_anl
do jlon = 1, ini_anl
pvar(jlon,jlat,jlev) = zlowvar(jlon,jlat,jlev)
enddo
enddo
endif
endif
!
! End of vertical interpolation
!
endif
call tmg_stop(97)
deallocate(zlowvar)
write(*,*) 'END of VHFSTFLD'
end subroutine VHFSTFLD
end module writeIncrement_mod