!-------------------------------------- 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 initgdla(pgdvort,pgddiv,pgdpsi,pgdchi,cduvgrid,ldhelm, 9,10
& ldfilt)
!
IMPLICIT NONE
#if defined (DOC)
!
!s/r initgdla : Adjusts fields so as to be compatible with Limited-Area Boundary Conditions.
! This subroutine is used only in XD-Var grd_typ mode 'LU'.
! N.B.: On entry: ut1,v1 must contain wind-images on scalar grid.
! If cduvgrid = 'U' then
! on exit : ut1,v1 will contain wind-images on Staggered Arakawa-C wind grid.
! If cduvgrid = 'S' then
! on exit : ut1,v1 will preserve input wind-images on Scalar Arakawa-C grid.
! Only mach3.ftn is applied to ut1,vt1 to produce those fields in extension zone.
! If ldhelm = .false., PSI,CHI wont be computed here.
! This saves computational time if relevant.
!
! Author L. Fillion - ARMA/MSC - 14 Apr 2005.
!Revision:
! L. Fillion - ARMA/EC - 29 Apr 2008 - Make it general: GD1 is used as in/out adjusted fields.
! J-F Caron - ARMA/EC - 12 June 2008.
! V2 with wind interpolation toward Araka_c grid
! L. Fillion - ARMA/EC - 23 Jun 2008 - Consolidate initgdla.ftn and initgdla2.ftn (JF Caron's version).
! Introduce new argument ldwindint to interpolate winds to Arakawa-C grid if desired.
! - Document the use of cduvgrid and ldhelm above.
! L. Fillion - ARMA/EC - 2 Feb 2010 - Introduce interp_uv_la.ftn
! L. Fillion - ARMA/EC - 28 May 2010 - Introduce argument ldfilt.
! - Remove useless array pwrk3d.
!
#endif
!
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comgrd_param.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comcst.cdk"
#include "comgd1.cdk"
#include "comgdpar.cdk"
#include "namgdpar.cdk"
#include "compdg.cdk"
#include "comgem.cdk"
#include "comgrd.cdk"
#include "comcva.cdk"
!
character*1 cduvgrid
logical ldhelm
logical ldfilt
real*8 pgdvort(ni,nflev,nj)
real*8 pgddiv(ni,nflev,nj)
real*8 pgdpsi(ni,nflev,nj)
real*8 pgdchi(ni,nflev,nj)
!
character*1 clpart
logical llbiais,ldwindint
integer ji,jj,jlev,jvar,inij,inip1,injp1,iflag,ivrbl
integer idum1,idum2,idum3,idum4,itrunc,index
real*8 zmin,zmax
real*8 zfld(ni,nflev,nj)
real*8 zfldtt(ni,nflev,nj)
real*8 zfld2d(ni,nj)
real*8 zu1(ni,nflev,nj)
real*8 zv1(ni,nflev,nj)
!
real*8 zwrksp2d(nla,2)
real*8 zwrksp(nla,2,nflev)
!
write(nulout,*) 'Begin initgdla'
!
clpart = 'L' ! clpart = 2 will do L and H filtering
itrunc = 5
llbiais = .false.
inip1 = ni+1
injp1 = nj+1
if(ldhelm) then
write(nulout,*) 'initgdla: Prepare VORT, DIV, PSI and CHI'
else
write(nulout,*) 'initgdla: Discard PSI and CHI'
endif
!
!*1. Bi-periodicization
! ------------------
!
! 3D fields
!
do jvar=1,nfstvar
!
iflag = 0
ivrbl = 0
do jj=1,nj
do jlev=1,nflev
do ji=1,ni
if(jvar.eq.1) then
ivrbl = 1
zfld(ji,jlev,jj)=ut1(ji,jlev,jj)
if(zfld(ji,jlev,jj).ne.0.) iflag = 1
!
else if(jvar.eq.2) then
ivrbl = 1
zfld(ji,jlev,jj)=vt1(ji,jlev,jj)
if(zfld(ji,jlev,jj).ne.0.) iflag = 1
!
else if(cfstvar(jvar).eq.'TT') then
ivrbl = 1
zfld(ji,jlev,jj)=tt1(ji,jlev,jj)
zfldtt(ji,jlev,jj)=tt1(ji,jlev,jj)
if(zfld(ji,jlev,jj).ne.0.) iflag = 1
!
else if(cfstvar(jvar).eq.'HU'.or.cfstvar(jvar).eq.'LQ') then
ivrbl = 1
zfld(ji,jlev,jj)=q1(ji,jlev,jj)
if(zfld(ji,jlev,jj).ne.0.) iflag = 1
endif
enddo
enddo
enddo
!
if(iflag.eq.0.and.ivrbl.eq.1) then
write(nulout,*) 'initgdla: Variable ',cfstvar(jvar)
write(nulout,*) 'initgdla: Content of GD1 identically zero... check
$ probably...',cfstvar(jvar)
call abort3d(nulout,'initgdla: field identically zero')
endif
!
call mach3(zfld,ni,nj,nflev,inip1,injp1)
!
if(ldfilt.and.cfstvar(jvar).ne.'UU'.or.cfstvar(jvar).ne.'VV') then ! dont touch the winds for the moment....
call gdtruncr(zfld,zwrksp,'T',5,'L',.false.,nflev)
endif
!
do jlev=1,nflev
do ji=1,ni
do jj=1,nj
if(cfstvar(jvar).eq.'UU') then
ut1(ji,jlev,jj)=zfld(ji,jlev,jj)
zu1(ji,jlev,jj)=zfld(ji,jlev,jj)
!
else if(cfstvar(jvar).eq.'VV') then
vt1(ji,jlev,jj)=zfld(ji,jlev,jj)
zv1(ji,jlev,jj)=zfld(ji,jlev,jj)
!
else if(cfstvar(jvar).eq.'TT') then
tt1(ji,jlev,jj)=zfld(ji,jlev,jj)
else if(cfstvar(jvar).eq.'HU') then
q1(ji,jlev,jj)=zfld(ji,jlev,jj)
else if(cfstvar(jvar).eq.'LQ') then
q1(ji,jlev,jj)=zfld(ji,jlev,jj)
!
endif
enddo
enddo
enddo
enddo ! nfstvar
!
! 2D fields
!
do jvar=1,nfstvar2d
do ji=1,ni
do jj=1,nj
if(cfstvar2d(jvar).eq.'P0') then
zfld2d(ji,jj)=gps1(ji,1,jj)
else if(cfstvar2d(jvar).eq.'TG') then
zfld2d(ji,jj)=gtg1(ji,1,jj)
endif
enddo
enddo
!
call mach2(zfld2d,ni,nj,inip1,injp1)
!
if(ldfilt) then
call gdtruncr(zfld2d,zwrksp2d,'T',itrunc,clpart,.false.,1)
endif
!
do ji=1,ni
do jj=1,nj
if(cfstvar2d(jvar).eq.'P0') then
gps1(ji,1,jj)=zfld2d(ji,jj)
else if(cfstvar2d(jvar).eq.'TG') then
gtg1(ji,1,jj)=zfld2d(ji,jj)
endif
!
enddo
enddo
enddo
!
!*1b. Interpolate winds towards Arakawa-C grid for Helmholtz's functions
! ------------------------------------------------------------------
!
if(cduvgrid.eq.'U') then
call interp_uv_la
endif
!
!*2. Build (VORT, DIV)
! -----------------
!
if(cfstvar(1).ne.'QQ') then
call bld_zd(pgdvort,pgddiv,zu1,zv1)
endif
!
!*3. Build (PSI, CHI) & (ut1,vt1) derived from Helmhotlz's functions
! ---------------------------------------------------------------
!
if(ldhelm) then
call initpc(pgdpsi,pgdchi,pgdvort,pgddiv,cduvgrid)
if(ldfilt) then
call gdtruncr(pgdpsi,zwrksp2d,'T',5,'L',.false.,nflev)
call gdtruncr(pgdchi,zwrksp2d,'T',5,'L',.false.,nflev)
endif
endif
!
return
end