!-------------------------------------- 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 --------------------------------------
***s/r casc_3df_dynp - For reading cascade 3DF pilot files where
* 3DF01 files were written after advection,
* 3DF02 files were written after Physics
* For initialization of the model run
*
#include "model_macros_f.h"
*
subroutine casc_3df_dynp (dimgx,dimgy,unf,listgeonm) 1,44
implicit none
*
character* (*) listgeonm(2,*)
integer dimgx,dimgy,unf
*
*author
* M. Desgagne April 2006 (MC2 casc_3df_dynp)
*
*revision
* v3_30 - Lee V. - initial version for GEMDM
* v3_30 - McTaggart-Cowan R. - implement variable orography
* v3_31 - Lee V. - add for Schm_offline_L
* v3_31 - Tanguay M. - Mix PILOT and ANAL mountains when BCS/3DF
*
#include "glb_ld.cdk"
#include "bcsdim.cdk"
#include "bcsgrds.cdk"
#include "bcsmem.cdk"
#include "dcst.cdk"
#include "geomg.cdk"
#include "ifd.cdk"
#include "ind.cdk"
#include "pres.cdk"
#include "lam.cdk"
#include "ptopo.cdk"
#include "schm.cdk"
#include "tr3d.cdk"
#include "vt1.cdk"
#include "lun.cdk"
#include "itf_phy_buses.cdk"
#include "lctl.cdk"
#include "hblen.cdk"
#include "itf_phy_busind.cdk"
#include "itf_phy_config.cdk"
#include "vtopo.cdk"
#include "path.cdk"
*
integer vmmlod,vmmget,vmmuld,longueur,sid3df
external vmmlod,vmmget,vmmuld,longueur,sid3df
*
character*2 md
character*4 nomvar
character*8 dynophy,vn
character*8, dimension (:), pointer :: trname_a, geop_name
character*4, dimension (:), pointer :: phynm
character*15 datev
character*256 fn
logical done,dyn_done,phy_done,same_topo_L,temp_same_L,flag
logical dyn_init,phy_init
integer*8 pnt_trp(Tr3d_ntr)
integer i,j,k,jj,jjj,kk,nia,nja,nk0,nka,ntra,ntra1,ni1,nj1,nk1,n,err,
$ errop,ofi,ofj,l_in,l_jn,mode,nvar, vmmnvar,ungeo,
$ cnt,nkphy,errdyn,errphy,cumerr,pid,gid,nfphy,
$ wowp,nij,ijk
integer i0,in,j0,jn,keyp_,keyp(Tr3d_ntr),ni2,nj2,nvargeo
integer idd,jdo,mult,shp,bigk,offbb,offbo,offg,ng
real busper, busper2(max(1,p_bper_siz))
real topo_temp(l_ni,l_nj),topu_temp(l_ni,l_nj),topv_temp(l_ni,l_nj),
$ zero(l_ni,l_nj),dtopo_temp(l_ni,l_nj)
real topox_temp(LDIST_SHAPE)
pointer (pabusper,busper(*))
integer, dimension (: ), pointer :: idx,idu,idy,nks
real xi,xf,yi,yf,htopa,maxtopo(2),maxtopo_g(2),
$ psmin, psmax, psmin_glob, psmax_glob, pr1,pr2
real , dimension (: ), pointer :: phybr
real , dimension (: ), pointer :: wlnph,ana_p0,ana_p0u,ana_p0v
real*8, dimension (: ), pointer ::
$ xpaq,ypaq,xpau,ypav,xpuu,ypvv,
$ cxa,cxb,cxc,cxd,cua,cub,cuc,cud,cya,cyb,cyc,cyd
real, dimension (:,:), pointer ::
$ uun,vvn,ttn,fin,pipn,
$ phybn,ps,psu,psv
real, dimension (:,:,:), pointer ::
$ gz_temp,tt_temp,
$ uur,vvr,ttr,fir,w1,w2,
$ trn,trr,ttru,ttrv,firu,firv
real trp
pointer (patrp, trp(LDIST_SHAPE,*))
real*8 xpxext(0:dimgx+1), ypxext(0:dimgy+1)
data nfphy,nkphy /0,0/
*-----------------------------------------------------------------------
*
if (Schm_offline_L) then
call casc_3df_dynp_offline(dimgx,dimgy,unf)
return
endif
nvargeo = 9
if (P_pbl_schsl_S.eq.'ISBA') nvargeo = nvargeo + 5
if (P_pbl_icelac_L) nvargeo = nvargeo + 1
allocate (geop_name(nvargeo))
*
geop_name (1) = 'TWATEREN'
geop_name (2) = 'ICEDPEN'
geop_name (3) = 'TGLACEN'
geop_name (4) = 'TMICEN'
geop_name (5) = 'SNODPEN'
geop_name (6) = 'TSOILEN'
geop_name (7) = 'GLSEAEN'
geop_name (8) = 'HS'
geop_name (9) = 'ALEN'
if (P_pbl_schsl_S.eq.'ISBA') then
geop_name (8) = 'WSOILEN'
geop_name (10) = 'ISOILEN'
geop_name (11) = 'WVEGEN'
geop_name (12) = 'WSNOWEN'
if (P_pbl_snoalb_L) then
geop_name (13) = 'SNOALEN'
else
geop_name (13) = 'SNOAGEN'
endif
geop_name (14) = 'SNOROEN'
endif
if (P_pbl_icelac_L) geop_name(nvargeo) = 'ICELINEN'
*
if (Lun_debug_L) write (Lun_out,1000)
*
keyp_ = VMM_KEY (trt1)
do k=1,Tr3d_ntr
keyp(k) = keyp_ + k
end do
err = vmmlod(keyp,Tr3d_ntr)
do k=1,Tr3d_ntr
err = vmmget(keyp(k),patrp,trp)
pnt_trp(k) = patrp
end do
*
* Positional parameters on extended global grid
*
do i=1,dimgx
xpxext(i) = G_xg_8(i)
end do
xpxext(0) = xpxext(1) - (xpxext(2)-xpxext(1))
xpxext(dimgx+1) = xpxext(dimgx) + (xpxext(dimgx)-xpxext(dimgx-1))
*
do i=1,dimgy
ypxext(i) = G_yg_8(i)
end do
ypxext(0) = ypxext(1) - (ypxext(2)-ypxext(1))
ypxext(dimgy+1) = ypxext(dimgy) + (ypxext(dimgy)-ypxext(dimgy-1))
*
* Read all needed files and construct the source domain for
* the horozontal interpolation
*
bcs_nia = ifd_niaf - ifd_niad + 1
bcs_nja = ifd_njaf - ifd_njad + 1
nia = bcs_nia
nja = bcs_nja
nullify(xpaq,xpau,ypaq,ypav,trname_a,phynm,
$ phybr,wlnph,ana_p0,ana_p0u,ana_p0v)
nullify(
$ uun,vvn,ttn,fin,pipn,
$ phybn,ps,psu,psv)
nullify(
$ gz_temp,tt_temp,
$ uur,vvr,ttr,fir,w1,w2,
$ trn,trr,ttru,ttrv,firu,firv)
*
if (associated(xpaq)) deallocate(xpaq)
if (associated(ypaq)) deallocate(ypaq)
if (associated(xpau)) deallocate(xpau)
if (associated(ypav)) deallocate(ypav)
allocate (xpaq(nia), ypaq(nja), xpau(nia), ypav(nja))
*
datev= Lam_runstrt_S
*
ntra = 0
err = 0
*
* wowp = 2 ===> input data has seen the physics
* wowp = 1 ===> input data just after dynamics (no physics)
* We prefer to initialize uup, vvp etc... with wowp=2 status.
*
wowp = 3
48 wowp = wowp - 1
if (wowp.lt.1) then
write (6,204)
err = -1
goto 999
endif
*
write (md,'(i2.2)') wowp
done = .false.
dyn_init = .false.
phy_init = .false.
Lam_busper_init_L=.false.
*
do n=1,ifd_nf
*
ofi = ifd_minx(n)-1
ofj = ifd_miny(n)-1
if (ifd_needit(n)) then
*
errdyn = -1
errphy = -1
dyn_done = .false.
phy_done = .false.
*
fn = trim(Path_ind_S)//'/3df'//md//
$ '_'//datev//'_'//ifd_fnext(n)
open (unf,file=fn(1:longueur(fn)),access='SEQUENTIAL',
$ form='UNFORMATTED',status='OLD',iostat=errop)
if (Lun_debug_L)
$ write(Lun_out,*) 'Opening',fn(1:longueur(fn)),'err=',errop
if (errop.ne.0) goto 33
*
* Use first file to establish 3D grid dimensions and geo-references
* of all input staggered grids (xpaq, ypaq, xpau and ypva).
*
55 if (dyn_done.and.phy_done) goto 33
err = sid3df (xpaq,ypaq,xpau,ypav,unf,done,nia,nja,
$ nka,nvar,ntra1)
if (err.lt.0) then
if (dyn_done) then
* Assumes no physics data are available
err=0
phy_done = .true.
errphy = 0
endif
* Continue to next file
goto 33
endif
*
read (unf,end=1010,err=1010) dynophy,cnt,mode
*
if (dynophy.eq.'PHYSICSS') then
if (Lun_debug_L) write (Lun_out,1001)
nfphy=cnt
if (.not.phy_init) then
if (associated(phybn)) deallocate(phybn)
if (associated(phynm)) deallocate(phynm)
if (associated(nks)) deallocate(nks)
allocate (phynm(nfphy),nks(nfphy))
endif
read(unf,end=1010,err=1010)(phynm(i),nks(i),i=1,nfphy)
if (Lun_debug_L) then
write(Lun_out,*) (phynm(i),nks(i),i=1,nfphy)
endif
nkphy=0
do i=1,nfphy
nkphy=nkphy+nks(i)
enddo
if (.not.phy_init) allocate(phybn(nia*nja,nkphy))
phy_init = .true.
cumerr = 0
nkphy=1
do i=1,nfphy
k = nks(i)
call filmup (phybn(1,nkphy),ifd_niad,ifd_niaf,ifd_njad,
$ ifd_njaf,k,unf,ofi,ofj,cumerr)
nkphy = nkphy + k
enddo
errphy=cumerr
phy_done = .true.
nkphy = nkphy - 1
if (.not. dyn_done) goto 55
elseif (dynophy.eq.'PERBUSSS') then
if (Lun_debug_L) write (Lun_out,1003)
if (.not.Lam_busper_init_L) then
if (associated(phybn)) deallocate(phybn)
if (associated(phynm)) deallocate(phynm)
if (associated(nks)) deallocate(nks)
allocate (phynm(p_bper_top),nks(p_bper_top))
endif
read(unf,end=1010,err=1010)(phynm(i),nks(i),i=1,P_bper_top)
nkphy=0
do i=1,p_bper_top
nkphy=nkphy+nks(i)
enddo
Lam_busper_init_L= .true.
allocate(phybn(nia*nja,nkphy))
cumerr = 0
nkphy=1
do i=1,p_bper_top
k = nks(i)
call filmup (phybn(1,nkphy),ifd_niad,ifd_niaf,ifd_njad,
$ ifd_njaf,k,unf,ofi,ofj,cumerr)
nkphy = nkphy + k
enddo
errphy=cumerr
phy_done = .true.
nkphy = nkphy - 1
if (.not. dyn_done) goto 55
else if (dynophy.eq.'DYNAMICS') then
*
ntra=ntra1
if (.not.dyn_init) then
if (associated(uun)) deallocate(uun)
if (associated(vvn)) deallocate(vvn)
if (associated(ttn)) deallocate(ttn)
if (associated(fin)) deallocate(fin)
if (associated(pipn)) deallocate(pipn)
if (associated(wlnph)) deallocate(wlnph)
if (associated(trn)) deallocate(trn)
if (associated(trname_a)) deallocate(trname_a)
allocate (
$ uun(nia*nja,nka), vvn(nia*nja,nka),
$ ttn(nia*nja,nka), fin(nia*nja,nka),
$ pipn(nia*nja,nka), wlnph(nia*nja),
$ trn(nia*nja,nka,ntra), trname_a(ntra) )
dyn_init = .true.
endif
*
cumerr=0
call filmup ( ttn,ifd_niad,ifd_niaf,ifd_njad,
$ ifd_njaf, nka,unf,ofi,ofj,cumerr )
call filmup ( fin(1,nka),ifd_niad,ifd_niaf,ifd_njad,
$ ifd_njaf, 1,unf,ofi,ofj,cumerr )
call filmup (pipn(1,nka),ifd_niad,ifd_niaf,ifd_njad,
$ ifd_njaf, 1,unf,ofi,ofj,cumerr )
if (ntra.gt.0) then
call filuptr ( trn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,Tr3d_name_S,Tr3d_ntr,
$ trname_a,ntra,cumerr )
endif
call filmup ( uun,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( vvn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
errdyn = cumerr
dyn_done = .true.
if ((.not.phy_done).and.(Schm_phyms_L)) goto 55
*
else
* Unrecognizable marker
write (6,205) dynophy
goto 1010
endif
*
33 close (unf)
*
if ((errdyn.lt.0).and.(wowp.gt.1)) goto 48
*
if (.not.Schm_phyms_L) errphy = 0
err = err + errdyn + errphy
done = .true.
if (err.lt.0) then
write (6,203) fn(1:longueur(fn)),Ptopo_myproc
goto 999
endif
endif
end do
*
999 call gem_stop('casc_3df_dynp',err)
*
* Copy target topography field from geofld (see geodata.ftn) unless
* "growing" topography is used, in which case the current model
* topography is retained.
*
if (Vtopo_L .and. Lctl_step > Vtopo_start) then
topo_temp = Ind_topo(1:l_ni,1:l_nj)
else
do gid=1,P_bgeo_top
if (geonm(gid,1).eq.'MF') then
offg = geopar(gid,1)
cnt = 0
do j=1,l_nj
do i=1,l_ni
cnt=cnt+1
topo_temp(i,j)=dble(geofld(offg +cnt-1))*Dcst_grav_8
enddo
enddo
*
* Store ANAL mountains P grid BEFORE blending
* -------------------------------------------
if (Lun_debug_L)
% write (Lun_out,*)'Store ANAL mountains BEFORE blending'
*
do j=1,l_nj
do i=1,l_ni
Ind_topa(i,j) = topo_temp(i,j)
enddo
enddo
*
endif
enddo
endif
*
* Establish geo-references of model target horizontal grids
* (xp1, yp1, xpuu and ypvv).
i0 = 1
j0 = 1
in = l_ni
jn = l_nj
ni1 = in - i0 + 1
nj1 = jn - j0 + 1
*
if (associated(uur)) deallocate(uur)
if (associated(vvr)) deallocate(vvr)
if (associated(ttr)) deallocate(ttr)
if (associated(fir)) deallocate(fir)
if (associated(trr)) deallocate(trr)
if (associated(ana_p0)) deallocate(ana_p0)
if (associated(ana_p0u)) deallocate(ana_p0u)
if (associated(ana_p0v)) deallocate(ana_p0v)
allocate ( uur(ni1,nj1,nka), vvr(ni1,nj1,nka),
$ ttr(ni1,nj1,nka), fir(ni1,nj1,nka),
$ ana_p0(ni1*nj1),
$ ana_p0u(ni1*nj1),ana_p0v(ni1*nj1),
$ firu(ni1,nj1,nka), firv(ni1,nj1,nka),
$ ttru(ni1,nj1,nka), ttrv(ni1,nj1,nka),
$ trr(ni1*nj1,nka,ntra))
if (associated(xpuu)) deallocate(xpuu)
if (associated(ypvv)) deallocate(ypvv)
if (associated(gz_temp)) deallocate(gz_temp)
if (associated(tt_temp)) deallocate(tt_temp)
allocate (xpuu(l_ni),ypvv(l_nj))
allocate (tt_temp(ni1,nj1,max(g_nk,nka)),
$ gz_temp(ni1,nj1,max(g_nk,nka)))
*
ofi = l_i0 - 1
ofj = l_j0 - 1
*
do i=i0,in
xpuu(i) = 0.5d0 * (xpxext(ofi+i+1)+xpxext(ofi+i))
end do
do j=j0,jn
ypvv(j) = 0.5d0 * (ypxext(ofj+j+1)+ypxext(ofj+j))
end do
*
* Horizontal interpolation (xpaq,ypaq) ===> (xp1,yp1) PHI GRID
*
if (associated(idx)) deallocate(idx)
if (associated(idu)) deallocate(idu)
if (associated(idy)) deallocate(idy)
if (associated(cxa)) deallocate(cxa)
if (associated(cxb)) deallocate(cxb)
if (associated(cxc)) deallocate(cxc)
if (associated(cxd)) deallocate(cxd)
if (associated(cya)) deallocate(cya)
if (associated(cyb)) deallocate(cyb)
if (associated(cyc)) deallocate(cyc)
if (associated(cyd)) deallocate(cyd)
if (associated(cua)) deallocate(cua)
if (associated(cub)) deallocate(cub)
if (associated(cuc)) deallocate(cuc)
if (associated(cud)) deallocate(cud)
allocate (idx(l_ni), idu(max(l_ni,l_nj)),idy(l_nj))
allocate (cxa(l_ni),cxb(l_ni),cxc(l_ni),cxd(l_ni),
$ cua(max(l_ni,l_nj)),cub(max(l_ni,l_nj)),
$ cuc(max(l_ni,l_nj)),cud(max(l_ni,l_nj)),
$ cya(l_nj),cyb(l_nj),cyc(l_nj),cyd(l_nj))
*
call grid_to_grid_coef (xpxext(l_i0),ni1,
$ xpaq,nia,idx,cxa,cxb,cxc,cxd,Lam_hint_S)
call grid_to_grid_coef (ypxext(l_j0),nj1,
$ ypaq,nja,idy,cya,cyb,cyc,cyd,Lam_hint_S)
*
* Refill geofld bus with subset from PHYSICSS=> (xp1,yp1) (geophy grid)
* For exact fields, refer to out_phy_3df
*
if (Lam_cascsfc_L) then
if (nkphy.gt.0 .and. phy_init .and. Schm_phyms_L) then
if (Lun_debug_L) write (Lun_out,1004)
if (associated(phybr)) deallocate (phybr)
allocate(phybr(ni1*nj1*nkphy))
call hinterpo (phybr,ni1,nj1,phybn,nia,nja,nkphy,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
ofj=0
do pid=1,nfphy
do gid=1,p_bgeo_top
nomvar = geonm(gid,2)
vn = geonm(gid,1)
flag = .false.
do k=1,nvargeo
if (vn.eq.geop_name(k)) flag=.true.
end do
if ((phynm(pid).eq.nomvar).and.flag) then
ofi = geopar(gid,1) -1
if ((nomvar.eq.'LG').or.(nomvar.eq.'AL')
$ .or.(nomvar.eq.'HS')) then
do i=1,ni1*nj1*geopar(gid,3)
geofld(ofi+i) = min(max(0.,phybr(ofj+i)),1.)
end do
else
do i=1,ni1*nj1*geopar(gid,3)
geofld(ofi+i) = phybr(ofj+i)
end do
endif
listgeonm(2,gid) = 'OK'
endif
enddo
ofj=ofj+nks(pid)*ni1*nj1
enddo
endif
endif
*
* Interpolate topography from input GZ
* Assume topography is not the same as analysis, always interpolate
*
call hinterpo ( fir(1,1,nka),ni1,nj1, fin(1,nka),nia,nja,1,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
*
call hinterpo ( ttr,ni1,nj1, ttn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
*
* For "growing" topography, the full grid over the pre-spinup period
* should be replaced by the analysis topography
*
if (Vtopo_L .and. Lctl_step <= Vtopo_start) then
dtopo_temp = topo_temp - fir(1:l_ni,1:l_nj,nka)
topo_temp = fir(1:l_ni,1:l_nj,nka)
endif
*
* Compute p0, surface pressure from analysis
*
do i=1,nia*nja
wlnph(i) = ana_z(nka)+pipn(i,nka)
enddo
call hinterpo (ana_p0,ni1,nj1,wlnph,nia,nja,1,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
*
* Humidity is in first cube of trr(1,1,1)
*
do kk=1,ntra
if (trname_a(kk).ne.'!@@NOT@@') then
call hinterpo (trr(1,1,kk),ni1,nj1,trn(1,1,kk),nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
endif
end do
*
* Fill permanent bus in Physic ===> (xp1,yp1) (physics grid)
*
if (nkphy.gt.0 .and. Lam_busper_init_L .and. Schm_phyms_L) then
if (associated(phybr)) deallocate (phybr)
allocate(phybr(ni1*nj1*nkphy))
call hinterpo (phybr,ni1,nj1,phybn,nia,nja,nkphy,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
do jdo=1,p_nj
pabusper=loc(Phy_busper3D((jdo-1)*p_bper_siz+1))
bigk=1
do idd=1,p_bper_top
offbo=(bigk-1)*l_ni*l_nj
offbb=perpar(idd,1)
j = jdo + p_offj
if (perpar(idd,5).gt.p_ni) then
shp=l_nk
else
shp=1
endif
do mult=1,perpar(idd,6)
do k=1,shp
do i=1,p_ni
busper(offbb+(k*mult-1)*p_ni + i - 1)=
$ phybr(offbo+(k*mult-1)*l_ni*l_nj +
$ (j-1)*l_ni + i+ p_offi)
enddo
enddo
enddo
bigk = bigk + shp*perpar(idd,6)
enddo
enddo
endif
*
* Horizontal interpolation (xpau,ypaq) ===> (xpuu,yp1) U GRID
*
call grid_to_grid_coef (xpuu,ni1,xpau,nia,idu,cua,cub,cuc,cud,
$ Lam_hint_S)
call hinterpo (uur,ni1,nj1,uun,nia,nja,nka,
$ idu,idy,cua,cub,cuc,cud,cya,cyb,cyc,cyd,Lam_hint_S)
*
* Compute p0,tt,gz on U grid from analysis
*
call grid_to_grid_coef (xpuu,ni1,xpaq,nia,idu,cua,cub,cuc,cud,
$ Lam_hint_S)
call hinterpo (ana_p0u,ni1,nj1,wlnph,nia,nja,1,
$ idu,idy,cua,cub,cuc,cud,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (ttru,ni1,nj1,ttn,nia,nja,nka,
$ idu,idy,cua,cub,cuc,cud,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (firu(1,1,nka),ni1,nj1,fin(1,nka),nia,nja,1,
$ idu,idy,cua,cub,cuc,cud,cya,cyb,cyc,cyd,Lam_hint_S)
do j=1,l_nj
do i=1,l_ni
topox_temp(i,j)=topo_temp(i,j)
enddo
enddo
call rpn_comm_xch_halo (topox_temp, LDIST_DIM, l_ni,l_nj,
$ 1,G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
* Horizontal interpolation topo(xp1,yp1) ===> (xpuu,yp1)
* Put the current topography in topu_temp by areal averaging
*
do j=1,l_nj
do i=1,l_niu
topu_temp(i,j)= (topox_temp(i,j)+topox_temp(i+1,j))*.5
enddo
enddo
if (l_east) then
do j=1,l_nj
topu_temp(l_ni,j)= topu_temp(l_niu,j)
enddo
endif
*
* Store ANAL mountains U grid BEFORE blending
* -------------------------------------------
do j=1,l_nj
do i=1,l_ni
Ind_toua(i,j) = topu_temp(i,j)
enddo
enddo
*
* Horizontal interpolation (xpaq,ypav) ===> (xp1,ypvv) V GRID
*
call grid_to_grid_coef (ypvv,nj1,ypav,nja,idu,cua,cub,cuc,cud,
$ Lam_hint_S)
call hinterpo (vvr,ni1,nj1,vvn,nia,nja,nka,
$ idx,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,Lam_hint_S)
call grid_to_grid_coef (ypvv,nj1,ypaq,nja,idu,cua,cub,cuc,cud,
$ Lam_hint_S)
*
* Compute p0,tt,gz on V grid from analysis
*
call hinterpo (ana_p0v,ni1,nj1,wlnph,nia,nja,1,
$ idx,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,Lam_hint_S)
call hinterpo (ttrv,ni1,nj1,ttn,nia,nja,nka,
$ idx,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,Lam_hint_S)
call hinterpo (firv(1,1,nka),ni1,nj1,fin(1,nka),nia,nja,1,
$ idx,idu,cxa,cxb,cxc,cxd,cua,cub,cuc,cud,Lam_hint_S)
*
* Horizontal interpolation topo(xp1,yp1) ===> (xp1,ypvv)
call rpn_comm_xch_halo (topox_temp, LDIST_DIM, l_ni,l_nj, 1,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
* Put the hi-res topography in topv_temp by areal averaging
do j=1,l_njv
do i=1,l_ni
topv_temp(i,j)= (topox_temp(i,j)+topox_temp(i,j+1))*.5
enddo
enddo
if (l_north) then
do i=1,l_ni
topv_temp(i,l_nj)= topv_temp(i,l_njv)
enddo
endif
*
* Store ANAL mountains V grid BEFORE blending
* -------------------------------------------
do j=1,l_nj
do i=1,l_ni
Ind_tova(i,j) = topv_temp(i,j)
enddo
enddo
*
* Put the lo-res topography back in the piloting region
* and prevent mountain "growth" in that area. Then compute values
* for topography and growth rate in the blending zone.
*
if (Lam_blendoro_L) then
do j=1,pil_s
do i=1,l_ni
topo_temp(i,j) = fir(i,j,nka)
dtopo_temp(i,j) = 0.
end do
end do
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
topo_temp(i,j) = fir(i,j,nka)
dtopo_temp(i,j) = 0.
end do
end do
do i=1,pil_w
do j=pil_s+1,l_nj-pil_n
topo_temp(i,j) = fir(i,j,nka)
dtopo_temp(i,j) = 0.
end do
end do
do i=l_ni-pil_e+1,l_ni
do j=pil_s+1,l_nj-pil_n
topo_temp(i,j) = fir(i,j,nka)
dtopo_temp(i,j) = 0.
end do
end do
zero = 0.
call nesajr (topo_temp, fir(1,1,nka), 1,l_ni,1,l_nj,
$ 1,0,0,Hblen_x,Hblen_y)
if (Vtopo_L .and. Lctl_step <= Vtopo_start) then
call nesajr (dtopo_temp, zero(1,1), 1,l_ni,1,l_nj,
$ 1,0,0,Hblen_x,Hblen_y)
Ind_dtopo(1:l_ni,1:l_nj) = dtopo_temp
endif
*
do j=1,pil_s
do i=1,l_ni
topu_temp(i,j) = firu(i,j,nka)
end do
end do
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
topu_temp(i,j) = firu(i,j,nka)
end do
end do
do i=1,pil_w
do j=pil_s+1,l_nj-pil_n
topu_temp(i,j) = firu(i,j,nka)
end do
end do
do i=l_niu-pil_e+1,l_ni
do j=pil_s+1,l_nj-pil_n
topu_temp(i,j) = firu(i,j,nka)
end do
end do
call nesajr (topu_temp, firu(1,1,nka), 1,l_ni,1,l_nj,
$ 1,1,0,Hblen_x,Hblen_y)
do j=1,pil_s
do i=1,l_ni
topv_temp(i,j) = firv(i,j,nka)
end do
end do
do j=l_njv-pil_n+1,l_nj
do i=1,l_ni
topv_temp(i,j) = firv(i,j,nka)
end do
end do
do i=1,pil_w
do j=pil_s+1,l_njv-pil_n
topv_temp(i,j) = firv(i,j,nka)
end do
end do
do i=l_ni-pil_e+1,l_ni
do j=pil_s+1,l_njv-pil_n
topv_temp(i,j) = firv(i,j,nka)
end do
end do
call nesajr (topv_temp, firv(1,1,nka), 1,l_ni,1,l_nj,
$ 1,0,1,Hblen_x,Hblen_y)
endif
*
* Allocate surface pressures for scalar,U,V grid
*
ng = ni1*nj1
if (associated(ps)) deallocate (ps)
if (associated(psu)) deallocate (psu)
if (associated(psv)) deallocate (psv)
if (associated(w1)) deallocate (w1)
if (associated(w2)) deallocate (w2)
allocate (ps(ni1,nj1),psu(ni1,nj1),psv(ni1,nj1),
$ w1(l_ni,l_nj,G_nk),w2(l_ni,l_nj,G_nk))
*
* -----------------------------------------------------------
* Setup for Vertical interpolation for scalar grid fields
*
do j=1,l_nj
do i=1,l_ni
gz_temp(i,j,nka) = fir(i,j,nka)
enddo
enddo
call p0vt2gz_hyb ( gz_temp, ana_pia, ana_pibb, ana_p0,
$ ttr,ng, nka,.false.,.false.)
call getp0 ( ps, topo_temp,ana_pia,ana_pibb, ana_p0, gz_temp, ttr,
$ ng, nka,.false.)
*
* Setup for Vertical interpolation for winds
*
do j=1,l_nj
do i=1,l_ni
gz_temp(i,j,nka) = firu(i,j,nka)
enddo
enddo
call p0vt2gz_hyb ( gz_temp, ana_pia, ana_pibb, ana_p0u,
$ ttru,ng, nka,.false.,.false.)
call getp0 ( psu, topu_temp,ana_pia,ana_pibb,ana_p0u,gz_temp,ttru,
$ ng, nka,.false.)
*
do j=1,l_nj
do i=1,l_ni
gz_temp(i,j,nka) = firv(i,j,nka)
enddo
enddo
call p0vt2gz_hyb ( gz_temp, ana_pia, ana_pibb, ana_p0v,
$ ttrv,ng, nka,.false.,.false.)
call getp0 ( psv, topv_temp,ana_pia,ana_pibb,ana_p0v,gz_temp,ttrv,
$ ng, nka,.false.)
*
* Interpolate VT
*
call vte_hyb2hyb (tt_temp, Geomg_pia, Geomg_pibb,ps,G_nk, ttr,
$ ana_pia,ana_pibb, ana_p0, nka, ng, 'VT',.false.)
*
* Compute hydrostatic GZ on model's levels
*
do j=1,l_nj
do i=1,l_ni
gz_temp(i,j,g_nk)=topo_temp(i,j)
enddo
enddo
call p0vt2gz_hyb ( gz_temp, Geomg_pia, Geomg_pibb, ps,
$ tt_temp, ng, G_nk,.false.,.false. )
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
Ind_fi(i,j,k) = gz_temp(i,j,k)
Ind_t (i,j,k) = tt_temp(i,j,k)
end do
end do
end do
*
* Interpolate UT1 and VT1
*
call vte_hyb2hyb (w1, Geomg_pia, Geomg_pibb,psu,G_nk, uur,
$ ana_pia,ana_pibb, ana_p0u, nka, ng, 'UU',.false.)
call vte_hyb2hyb (w2, Geomg_pia, Geomg_pibb,psv,G_nk, vvr,
$ ana_pia,ana_pibb, ana_p0v, nka, ng, 'VV',.false.)
*
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
Ind_u(i,j,k) = w1(i,j,k)
Ind_v(i,j,k) = w2(i,j,k)
end do
end do
end do
*
psmin = ps(1,1)
psmax = ps(1,1)
do j=1,l_nj
do i=1,l_ni
psmin = min( psmin, ps(i,j) )
psmax = max( psmax, ps(i,j) )
Ind_q(i,j,g_nk) = alog(ps(i,j))
Ind_q(i,j,1 ) = alog(Pres_ptop*100.)
enddo
enddo
*
* TRACERS
*
do 200 n=1,Tr3d_ntr
patrp = pnt_trp(n)
jj=-1
* If data found for this tracer
do k=1,ntra
if (Tr3d_name_S(n).eq.trname_a(k)(1:4)) jj=k
end do
if ( jj.gt.0 ) then
call vte_hyb2hyb (w1, Geomg_pia, Geomg_pibb,ps,G_nk,
$ trr(1,1,jj),ana_pia,ana_pibb, ana_p0,
$ nka,ng,trname_a(jj)(1:2),.false.)
* ALWAYS clip tracers to zero after vertical interpolation (Desgagne)
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
trp(i,j,k) = max(w1(i,j,k),0.0)
end do
end do
end do
else
* No data found for this tracer, set to user-defined value.
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
trp(i,j,k) = Tr3d_sval(n)
end do
end do
end do
endif
* If no moist scheme, put humid tracers to zero
if (.not.Schm_moist_L) then
jjj=-1
* See if it is a humid tracer
do kk = 1,h2o_ntr
if (Tr3d_name_S(n).eq.h2o_name_S(kk)) jjj=kk
enddo
if (jjj.gt.0) then
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
trp(i,j,k) = 0.0
enddo
enddo
enddo
endif
endif
200 continue
*
* Copy topography into vmm field
*
do j=1,l_nj
do i=1,l_ni
Ind_topo(i,j) = topo_temp(i,j)
Ind_topu(i,j) = topu_temp(i,j)
Ind_topv(i,j) = topv_temp(i,j)
enddo
enddo
*
if (Lun_debug_L) then
write(Lun_out,100)
write(Lun_out,101) datev,wowp
write(Lun_out,100)
endif
*
call rpn_comm_allreduce(psmin,psmin_glob,1,"MPI_REAL","MPI_MIN",
$ "grid",err)
call rpn_comm_allreduce(psmax,psmax_glob,1,"MPI_REAL","MPI_MAX",
$ "grid",err)
psmin=psmin_glob
psmax=psmax_glob
*
if ( Ptopo_myproc.eq.0 ) then
write(6,*)'PSMIN = ',PSMIN,' PSMAX = ',PSMAX,
$ ' PSMINMAX = ',0.5*(PSMIN+PSMAX),' (PASCAL)'
endif
*
Pres_surf = dble(0.5*(psmin+psmax))
Pres_top = dble(Pres_ptop*100.)
*
call v4d_indata3 ()
call set_dync
*
call predat()
if ( .not. Schm_hydro_L ) then
Ind_mul = 0.
Ind_qp = 0.
endif
*
deallocate (geop_name)
*
100 format (' ',65('*'))
101 format (' (CASC_3DF_DYNP) JUST READ INIT DATA FOR DATE: ',a15,1x,i3)
203 format (/' PROBLEM WITH FILE: ',a,', PROC#:',i4,' --ABORT--'/)
204 format (/' NO DATA IN CASC_3DF_DYNP --ABORT--'/)
205 format (/' Unrecognizable tag found: ',a,'?'/)
1000 format(
+3X,'READING DATA IN (S/R CASC_3DF_DYNP)')
1001 format(
+3X,'READING PHYSICSS DATA IN (S/R CASC_3DF_DYNP)')
1002 format(
+3X,'READING GEOPHYSS DATA IN (S/R CASC_3DF_DYNP)')
1003 format(
+3X,'READING BUSPER DATA IN (S/R CASC_3DF_DYNP)')
1004 format(
+3X,'UPDATING GEOPHY DATA IN (S/R CASC_3DF_DYNP)')
*
*-----------------------------------------------------------------------
return
1010 write (6,203) fn(1:longueur(fn)),Ptopo_myproc
call gem_stop('casc_3df_dynp',-1)
return
end
*