!-------------------------------------- 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 acid_3df_dynp - read 3df files for acid test
*
#include "model_macros_f.h"
*
subroutine acid_3df_dynp (dimgx,dimgy,unf) 1,56
implicit none
*
integer dimgx,dimgy,unf
*
*author
* Vivian Lee - Dec 2006 (from casc_3df_dynp)
*revision
* v3_30 - Lee V. - initial version for GEMDM
*
*
#include "glb_ld.cdk"
#include "bcsdim.cdk"
#include "bcsgrds.cdk"
#include "bcsmem.cdk"
#include "dcst.cdk"
#include "cstv.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 "vth.cdk"
#include "vtx.cdk"
#include "lun.cdk"
#include "p_geof.cdk"
#include "filename.cdk"
#include "lctl.cdk"
#include "hblen.cdk"
#include "itf_phy_buses.cdk"
#include "itf_phy_busind.cdk"
#include "acid.cdk"
*
integer vmmlod,vmmget,vmmuld,longueur,sid3df
external vmmlod,vmmget,vmmuld,longueur,sid3df
*
character*2 md
character*4 nomvar
character*8 dynophy
character*8, dimension (:), pointer :: trname_a
character*4, dimension (:), pointer :: phynm
character*15 datev
character*256 fn
logical done,dyn_done,phy_done,same_topo_L,vertint_L
logical dyn_init,geo_init,busper_init,phy_init
integer*8 pnt_trp(Tr3d_ntr)
integer i,j,k,jj,jjj,kk,nia,nja,nk0,nka,ntra,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,key1(24),nij,ijk
integer i0,in,j0,jn,keyp_,keyp(Tr3d_ntr),ni2,nj2
integer idd,jdo,mult,shp,bigk,offbb,offbo,offg,ng
integer difftopo,tdifftopo
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)
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
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,psdn,ttn,tpn,tdn,fin,qqn,fipn,pipn,wwn,mun,
$ tpln,ssr,ssn,
$ xxn,yyn,zzn,xxcn,yycn,zzcn,
$ phybn,ps,psu,psv
real, dimension (:,:,:), pointer ::
$ gz_temp,tt_temp,
$ uur,vvr,psdr,ttr,tpr,tdr,fir,qqr,fipr,pipr,wwr,mur,
$ tplr,w1,w2,
$ xxr,yyr,zzr,xxcr,yycr,zzcr,
$ trn,trr
real trp
pointer (patrp, trp(LDIST_SHAPE,*))
real*8 xpxext(0:dimgx+1), ypxext(0:dimgy+1)
data nfphy,nkphy /0,0/
*-----------------------------------------------------------------------
*
if (Lun_debug_L) write (Lun_out,1000)
key1( 1) = VMM_KEY( xth)
key1( 2) = VMM_KEY( yth)
key1( 3) = VMM_KEY( zth)
key1( 4) = VMM_KEY( xcth)
key1( 5) = VMM_KEY( ycth)
key1( 6) = VMM_KEY( zcth)
vmmnvar = 6
*
err = vmmlod(key1,vmmnvar)
*
err = VMM_GET_VAR( xth)
err = VMM_GET_VAR( yth)
err = VMM_GET_VAR( zth)
err = VMM_GET_VAR( xcth)
err = VMM_GET_VAR( ycth)
err = VMM_GET_VAR( zcth)
*
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)
nullify(
$ uun,vvn,psdn,ttn,tpn,tdn,fin,qqn,fipn,pipn,wwn,mun,
$ tpln,ssr,ssn,
$ xxn,yyn,zzn,xxcn,yycn,zzcn,
$ phybn,ps,psu,psv)
nullify(
$ gz_temp,tt_temp,
$ uur,vvr,psdr,ttr,tpr,tdr,fir,qqr,fipr,pipr,wwr,mur,
$ tplr,w1,w2,
$ xxr,yyr,zzr,xxcr,yycr,zzcr,
$ trn,trr)
*
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.
busper_init = .false.
geo_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 ='../casc/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,ntra)
if (err.lt.0.and.dyn_done) then
* This means that no physics data are available. Must read in geophy file.
err = 0
phy_done = .true.
errphy = 0
goto 33
endif
read (unf,end=33) 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=33)(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.busper_init) 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=33)(phynm(i),nks(i),i=1,P_bper_top)
nkphy=0
do i=1,p_bper_top
nkphy=nkphy+nks(i)
enddo
if (.not.Lam_busper_init_L) allocate(phybn(nia*nja,nkphy))
Lam_busper_init_L= .true.
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
elseif (dynophy.eq.'GEOPHYSS') then
if (Lun_debug_L) write (Lun_out,1002)
p_bgeo_top= cnt
if (.not.geo_init) then
if (associated(phybn)) deallocate(phybn)
endif
read (unf,end=33) (geonm(i,1),geonm(i,5),
$ geopar(i,1),geopar(i,2),
$ geopar(i,3),i=1,P_bgeo_top)
* redefine Geobus structure in terms of local dimensions
nkphy=geopar(1,3)
geopar(1,1) = 1
geopar(1,2) = l_ni*l_nj*geopar(1,3)
do i=2,p_bgeo_top
geopar(i,1) = geopar(i-1,1)+l_ni*l_nj*geopar(i-1,3)
geopar(i,2) = l_ni*l_nj*geopar(i,3)
nkphy = nkphy+geopar(i,3)
enddo
p_bgeo_siz=geopar(p_bgeo_top,1)+l_ni*l_nj*geopar(p_bgeo_top,3)
if (.not.geo_init) then
allocate(phybn(nia*nja,nkphy))
endif
geo_init = .true.
cumerr = 0
nkphy = 1
do i=1,P_bgeo_top
k = geopar(i,3)
call filmup (phybn(1,nkphy),ifd_niad,ifd_niaf,ifd_njad,
$ ifd_njaf,k,unf,ofi,ofj,cumerr)
nkphy = nkphy + k
end do
nkphy = nkphy - 1
errphy = cumerr
phy_done = .true.
if (.not. dyn_done) goto 55
endif
*
if (dynophy.eq.'DYNAMICS') then
*
if (.not.dyn_init) then
if (associated(uun)) deallocate(uun)
if (associated(vvn)) deallocate(vvn)
if (associated(psdn)) deallocate(psdn)
if (associated(ttn)) deallocate(ttn)
if (associated(tpn)) deallocate(tpn)
if (associated(tdn)) deallocate(tdn)
if (associated(fin)) deallocate(fin)
if (associated(qqn)) deallocate(qqn)
if (associated(ssn)) deallocate(ssn)
if (associated(fipn)) deallocate(fipn)
if (associated(pipn)) deallocate(pipn)
if (associated(tpln)) deallocate(tpln)
if (associated(xxn)) deallocate(xxn)
if (associated(yyn)) deallocate(yyn)
if (associated(zzn)) deallocate(zzn)
if (associated(xxcn)) deallocate(xxcn)
if (associated(yycn)) deallocate(yycn)
if (associated(zzcn)) deallocate(zzcn)
if (associated(wwn)) deallocate(wwn)
if (associated(mun)) deallocate(mun)
if (associated(trn)) deallocate(trn)
if (associated(trname_a)) deallocate(trname_a)
allocate ( uun(nia*nja,nka ),
$ vvn(nia*nja,nka), psdn(nia*nja,nka),
$ ttn(nia*nja,nka), tpn(nia*nja,nka),
$ tdn(nia*nja,nka), fin(nia*nja,nka),
$ qqn(nia*nja,nka), ssn(nia,nja),
$ fipn(nia*nja,nka), pipn(nia*nja,nka),
$ tpln(nia*nja,nka), wlnph(nia*nja),
$ xxn(nia*nja,nka), xxcn(nia*nja,nka),
$ yyn(nia*nja,nka), yycn(nia*nja,nka),
$ zzn(nia*nja,nka), zzcn(nia*nja,nka),
$ wwn(nia*nja,nka), mun(nia*nja,nka),
$ trn(nia*nja,nka,ntra), trname_a(ntra) )
dyn_init = .true.
endif
*
cumerr=0
if (nvar.eq.5) then
if (Lun_out.gt.0) write (Lun_out,1010)
goto 999
endif
call filmup ( ttn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( fin,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( qqn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup (pipn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( tpn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( ssn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ 1 ,unf,ofi,ofj,cumerr )
call filmup (fipn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( psdn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( tdn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
if (nvar.eq.13.or.nvar.eq.20) then
call filmup ( wwn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( mun,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
endif
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 )
if (nvar.eq.18 .or. nvar.eq.20) then
call filmup (tpln,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( xxn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( yyn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( zzn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( xxcn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( yycn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
call filmup ( zzcn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ nka,unf,ofi,ofj,cumerr )
Acid_skippospers_L = .true.
endif
errdyn = cumerr
dyn_done = .true.
if ((.not.phy_done).and.(Schm_phyms_L)) goto 55
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('acid_3df_dynp',err)
*
* Obtain topography field from geodata
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
endif
enddo
*
* 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(psdr)) deallocate(psdr)
if (associated(ttr)) deallocate(ttr)
if (associated(tpr)) deallocate(tpr)
if (associated(tdr)) deallocate(tdr)
if (associated(fir)) deallocate(fir)
if (associated(qqr)) deallocate(qqr)
if (associated(ssr)) deallocate(ssr)
if (associated(fipr)) deallocate(fipr)
if (associated(pipr)) deallocate(pipr)
if (associated(tplr)) deallocate(tplr)
if (associated(xxr)) deallocate(xxr)
if (associated(yyr)) deallocate(yyr)
if (associated(zzr)) deallocate(zzr)
if (associated(xxcr)) deallocate(xxcr)
if (associated(yycr)) deallocate(yycr)
if (associated(zzcr)) deallocate(zzcr)
if (associated(wwr)) deallocate(wwr)
if (associated(mur)) deallocate(mur)
if (associated(trr)) deallocate(trr)
if (associated(ana_p0)) deallocate(ana_p0)
allocate ( uur(ni1,nj1,nka ),
$ vvr(ni1,nj1,nka), psdr(ni1,nj1,nka ),
$ ttr(ni1,nj1,nka), tpr(ni1,nj1,nka),
$ tdr(ni1,nj1,nka), fir(ni1,nj1,nka),
$ qqr(ni1,nj1,nka), ssr(ni1,nj1),
$ fipr(ni1,nj1,nka), pipr(ni1,nj1,nka),
$ tplr(ni1,nj1,nka),ana_p0(ni1*nj1),
$ xxr(ni1,nj1,nka), xxcr(ni1,nj1,nka),
$ yyr(ni1,nj1,nka), yycr(ni1,nj1,nka),
$ zzr(ni1,nj1,nka), zzcr(ni1,nj1,nka),
$ wwr(ni1,nj1,nka), mur(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)
*
* Topography is stored in geofld and may be overwriten if
* available in fields from GEOPHYSS or PHYSICSS
*
* Fill geophysical bus partially ===> (xp1,yp1) (geophysics grid)
if (nkphy.gt.0 .and. phy_init) 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)
if (phynm(pid).eq.nomvar) then
if (Lun_debug_L) write(Lun_out,*)'REFilling',nomvar
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
endif
enddo
ofj=ofj+nks(pid)*ni1*nj1
enddo
if (Lctl_debug_L) then
do gid=1,p_bgeo_top
call glbstat1(geofld(geopar(gid,1)),geonm(gid,1)(1:8),"geop",
$ 1,l_ni,1,l_nj,geopar(gid,3), 1,G_ni,1,G_nj,1,geopar(gid,3))
enddo
endif
endif
* Fill geophysical bus completely ===> (xp1,yp1) (geophysics grid)
if (nkphy.gt.0 .and. geo_init) then
call hinterpo (geofld,ni1,nj1,phybn,nia,nja,nkphy,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
do gid=1,p_bgeo_top
call glbstat1(geofld(geopar(gid,1)),geonm(gid,1)(1:8),"geop",
$ 1,l_ni,1,l_nj,geopar(gid,3), 1,G_ni,1,G_nj,1,geopar(gid,3))
enddo
endif
* Obtain topography from analysis GZ
call hinterpo ( fir(1,1,nka),ni1,nj1, fin(1,nka),nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
* Check topography from geofld to the one in the analysis
same_topo_L=.true.
difftopo=0
do j=1,l_nj
do i=1,l_ni
if (topo_temp(i,j).ne.fir(i,j,nka)) difftopo=1
enddo
enddo
call rpn_comm_ALLREDUCE ( difftopo, tdifftopo, 1,
$ "MPI_INTEGER","MPI_SUM","grid",err )
if (tdifftopo.gt.0) same_topo_L=.false.
if (Lun_debug_L) write(Lun_out,*)'same_topo_L=',same_topo_L
if (.not.same_topo_L)then
if (Lun_out.gt.0) write (Lun_out,1011)
goto 999
endif
* Check vertical coordinate for model vs analysis
vertint_L=.false.
If (same_topo_L.and.G_nk.eq.nka) then
do k=1,G_nk
if (Geomg_pia(k).ne.ana_pia(k)) vertint_L=.true.
if (Geomg_pibb(k).ne.ana_pibb(k)) vertint_L=.true.
enddo
else
vertint_L=.true.
endif
If (Lun_debug_L) write(Lun_out,*) 'vertint=',vertint_L
if (vertint_L)then
if (Lun_out.gt.0) write (Lun_out,1012)
goto 999
endif
call hinterpo ( ttr,ni1,nj1, ttn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo ( fir,ni1,nj1, fin,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo ( qqr,ni1,nj1, qqn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (pipr,ni1,nj1,pipn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo ( tpr,ni1,nj1, tpn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo ( ssr,ni1,nj1, ssn,nia,nja, 1,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (fipr,ni1,nj1,fipn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (psdr,ni1,nj1,psdn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo ( tdr,ni1,nj1, tdn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
* 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)
if (nvar.eq.18 .or. nvar.eq.20) then
call hinterpo (tplr,ni1,nj1,tpln,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (xxr,ni1,nj1,xxn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (yyr,ni1,nj1,yyn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (zzr,ni1,nj1,zzn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (xxcr,ni1,nj1,xxcn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (yycr,ni1,nj1,yycn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo (zzcr,ni1,nj1,zzcn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
endif
if ( nvar.eq.20 .and. .not. Schm_hydro_L) then
call hinterpo ( wwr,ni1,nj1, wwn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
call hinterpo ( mur,ni1,nj1, mun,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
endif
*
* 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) 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)
*
* 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)
*
*
* Put the lo-res topography back in the piloting region
*
do j=1,pil_s
do i=1,l_ni
topo_temp(i,j) = fir(i,j,nka)
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)
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)
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)
end do
end do
call nesajr (topo_temp, fir(1,1,nka), 1,l_ni,1,l_nj,
$ 1,0,0,Hblen_x,Hblen_y)
*
* 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))
* -----------------------------------------------------------
*
* NO VERTICAL INTERPOLATION
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
Ind_fi(i,j,k) = fir(i,j,k)
Ind_t(i,j,k) = ttr(i,j,k)
Ind_u(i,j,k) = uur(i,j,k)
Ind_v(i,j,k) = vvr(i,j,k)
Ind_psd(i,j,k)=psdr(i,j,k)
Ind_tp(i,j,k)=tpr(i,j,k)
Ind_q(i,j,k)=qqr(i,j,k)
Ind_td(i,j,k)=tdr(i,j,k)
Ind_fip(i,j,k)=fipr(i,j,k)
Ind_pip(i,j,k)=pipr(i,j,k)
end do
end do
end do
do j=1,l_nj
do i=1,l_ni
Ind_s(i,j) = ssr(i,j)
end do
end do
if (nvar.eq.18.or.nvar.eq.20) then
nij = l_ni*l_nj
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
ijk=(k-1)*nij+(j-1)*l_ni+i
Ind_tpl(i,j,k) = tplr(i,j,k)
xth(ijk) = xxr(i,j,k)
xcth(ijk) = xxcr(i,j,k)
yth(ijk) = yyr(i,j,k)
ycth(ijk) = yycr(i,j,k)
zth(ijk) = zzr(i,j,k)
zcth(ijk) = zzcr(i,j,k)
end do
end do
end do
endif
if (.not.Schm_hydro_L) then
if (nvar.eq.13 .or. nvar.eq.20) then
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
Ind_w(i,j,k) = wwr(i,j,k)
Ind_mu(i,j,k) = mur(i,j,k)
end do
end do
end do
else
Ind_w = 0.
Ind_mu = 0.
endif
endif
do j=1,l_nj
do i=1,l_ni
ps(i,j)=ana_p0((j-1)*l_ni+i)
enddo
enddo
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) )
enddo
enddo
* TRACERS
do 200 n=1,Tr3d_ntr
patrp = pnt_trp(n)
jj=-1
do k=1,ntra
if (Tr3d_name_S(n).eq.trname_a(k)(1:4)) jj=k
end do
if ( jj.gt.0 ) then
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
trp(i,j,k) = trr((j-1)*l_ni+i,k,jj)
end do
end do
end do
if (.not.Schm_moist_L) then
jjj=-1
do kk = 1,h2o_ntr
if (trname_a(jj)(1:2).eq.h2o_name_S(kk)(1:2)) 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.
end do
end do
end do
endif
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)
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 set_dync
*
if (Acid_skippospers_L) then
do k= 1, G_nk
pr1 = Dcst_rgasd_8 * Cstv_tstr_8 * geomg_pib(k) / geomg_z_8(k)
pr2 = Cstv_tstr_8*(geomg_pib(k)/geomg_z_8(k) - geomg_dpib(k))
do j= 1, l_nj
do i= 1, l_ni
Ind_gp(i,j,k) = Ind_fip(i,j,k) + pr1 * Ind_s(i,j)
end do
end do
end do
else
do k= 1, G_nk
pr1 = Dcst_rgasd_8 * Cstv_tstr_8 * geomg_pib(k) / geomg_z_8(k)
pr2 = Cstv_tstr_8*(geomg_pib(k)/geomg_z_8(k) - geomg_dpib(k))
do j= 1, l_nj
do i= 1, l_ni
Ind_gp(i,j,k) = Ind_fip(i,j,k) + pr1 * Ind_s(i,j)
Ind_tpl(i,j,k) = (Cstv_tstr_8+Ind_tp(i,j,k))*
$ (1.0+geomg_dpib(k)*(exp(Ind_s(i,j))-1.))*
$ geomg_z_8(k)/(geomg_z_8(k)+Ind_pip(i,j,k))-Cstv_tstr_8
Ind_tpl(i,j,k) = Ind_tpl(i,j,k) + pr2 * Ind_s(i,j)
end do
end do
end do
endif
if ( .not. Schm_hydro_L ) then
Ind_mul = 0.
Ind_qp = 0.
endif
err = vmmuld(keyp,Tr3d_ntr)
err = vmmuld(key1,vmmnvar)
*
100 format (' ',65('*'))
101 format (' (acid_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 acid_3df_dynp --ABORT--'/)
1000 format(
+3X,'READING DATA IN (S/R acid_3df_dynp)')
1001 format(
+3X,'READING PHYSICSS DATA IN (S/R acid_3df_dynp)')
1002 format(
+3X,'READING GEOPHYSS DATA IN (S/R acid_3df_dynp)')
1003 format(
+3X,'READING BUSPER DATA IN (S/R acid_3df_dynp)')
1004 format(
+3X,'UPDATING GEOPHY DATA IN (S/R acid_3df_dynp)')
1010 format(
+3X,'NVAR=5, PILOTING DATA INSUFFICIENT FOR ACID TEST (S/R acid_3df_dynp)')
1011 format(
+3X,'TOPOGRAPHY DIFFERENT IN CASCADE AND PILOT (S/R acid_3df_dynp)')
1012 format(
+3X,'VERT LEVELS DIFFERENT BTWN CASCADE AND PILOT (S/R acid_3df_dynp)')
*
*-----------------------------------------------------------------------
return
end
*