!-------------------------------------- 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 --------------------------------------
copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r casc_bcs_offline - For reading cascade 3DF pilot files where
* 3DF01 files were written after advection,
* 3DF02 files were written after Physics
* This one is used for after the initialization of LAM
* See casc_3df_dynp.ftn.
*
#include "model_macros_f.h"
*
integer function casc_bcs_offline ( datev, dimgx,dimgy,unf, wowp, errp ) 1,10
implicit none
*
character*15 datev
integer dimgx,dimgy,unf,wowp,errp
*
*author
* V. Lee Sept 2008 (GEM casc_bcs_offline)
*
*revision
* v3_31 - Lee V. - initial version for GEMDM
*
*
#include "glb_ld.cdk"
#include "ptopo.cdk"
#include "ifd.cdk"
#include "pres.cdk"
#include "lam.cdk"
#include "schm.cdk"
#include "tr3d.cdk"
#include "lun.cdk"
#include "itf_phy_busind.cdk"
#include "lctl.cdk"
#include "ind.cdk"
#include "nest.cdk"
#include "path.cdk"
*
integer vmmlod,vmmget,vmmuld,longueur,sid3df
external vmmlod,vmmget,vmmuld,longueur,sid3df
character*2 md
character*8 dynophy
character*8, dimension (:), pointer :: trname_a
character*256 fn
logical done
integer*8 pnt_trp(Tr3d_ntr)
real trp
pointer (patrp, trp(LDIST_SHAPE,*))
real*8 xpxext(0:dimgx+1), ypxext(0:dimgy+1)
integer i0,j0,in,jn
integer i,j,k,jj,jjj,kk,nka,ntra,n,err,nga,errop,ofi,ofj,mode,
$ errdyn,cumerr,cnt,nia,nja,d1,ni1,nj1,nvar
integer key1(17),keyp_,keyp(Tr3d_ntr)
integer, dimension (: ), pointer :: idx,idy
real*8, dimension (: ), pointer ::
$ xpaq,ypaq,xpau,ypav,
$ cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd
real, dimension (:,:), pointer ::
$ uun,vvn,ps,ttn
real, dimension (:,:,:), pointer ::
$ uur,vvr,ttr,trn,trr
*-----------------------------------------------------------------------
*
if (Lun_debug_L) write (Lun_out,1000) Lctl_step,wowp
*
casc_bcs_offline = -1
nullify(xpaq,ypaq,xpau,ypav,
$ uun,vvn,ps,ttn,
$ trn,trname_a)
*
* OFFLINE data2treat = TRUE always
*
nia = ifd_niaf - ifd_niad + 1
nja = ifd_njaf - ifd_njad + 1
nga = nia * nja
nka = 0
ntra = 0
err = 0
done = .false.
write (md,'(i2.2)') wowp
*
* Read all needed files and construct the source domain for
* the horozontal interpolation
*
do 50 n=1,ifd_nf
ofi = ifd_minx(n)-1
ofj = ifd_miny(n)-1
if (ifd_needit(n)) then
errdyn = -1
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)),'errop=',errop
if (errop.ne.0) goto 33
*
* Use first file to establish 3D grid dimensions and geo-references
* of all input stagerred grids (xpaq, ypaq, xpau and ypva).
*
if (.not.done) allocate (xpaq(nia), ypaq(nja),
$ xpau(nia), ypav(nja))
err = sid3df (xpaq,ypaq,xpau,ypav,unf,done,
$ nia,nja,nka,nvar,ntra)
read (unf,end=33) dynophy,cnt,mode
*
if (.not.done) then
allocate (uun(nga,nka),vvn(nga,nka),
$ ttn(nga,nka), trn(nga,nka,ntra), trname_a(ntra) )
uun=0.; vvn=0.; ttn=0.; trn=0.
endif
cumerr=0
* filling uun buffer by reading from unit unf
call filmup ( ttn,ifd_niad,ifd_niaf,ifd_njad,
$ ifd_njaf, nka,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
33 continue
*
* finish filmup for dynamic variables
err = err + errdyn
if (err.lt.0) then
if (Ptopo_myproc.eq.0) write (6,203) fn(1:longueur(fn))
goto 999
endif
34 continue
err = err + errdyn
if (err.lt.0) then
if (Ptopo_myproc.eq.0) write (6,204) fn(1:longueur(fn))
goto 999
endif
done = .true.
close (unf)
endif
50 continue
casc_bcs_offline = 0
999 continue
*
*
if (casc_bcs_offline.lt.0) then
if (done) then
if (associated(uun)) deallocate (uun)
if (associated(vvn)) deallocate (vvn)
if (associated(ttn)) deallocate (ttn)
if (associated(trn)) deallocate (trn)
if (associated(trname_a)) deallocate (trname_a)
if (associated(xpaq)) deallocate (xpaq)
if (associated(xpau)) deallocate (xpau)
if (associated(ypaq)) deallocate (ypaq)
if (associated(ypav)) deallocate (ypav)
endif
return
endif
*
* Data is read, now do horizontal and vertical interpolations
*
* Obtain VMM tracers in Nest
keyp_ = VMM_KEY (nest_trf)
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
*
* Establish geo-references of model target horizontal grids
* (xpxext, ypxext ).
*
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))
*
i0 = 1
j0 = 1
in = l_ni
jn = l_nj
ni1 = in - i0 + 1
nj1 = jn - j0 + 1
*
allocate ( uur(ni1,nj1,nka), vvr(ni1,nj1,nka),
$ ttr(ni1,nj1,nka),
$ trr(ni1*nj1,nka,ntra))
*
ofi = l_i0 - 1
ofj = l_j0 - 1
*
* Horizontal interpolation (xpaq,ypaq) ===> (xpxext,ypxext) PHI GRID
*
allocate (idx(l_ni), idy(l_nj))
allocate (cxa(l_ni),cxb(l_ni),cxc(l_ni),cxd(l_ni),
$ 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)
call hinterpo ( ttr,ni1,nj1, ttn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
*
* Compute p0, surface pressure from analysis
*
allocate (ps(ni1,nj1))
*
* 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)
if (trname_a(kk).eq.'P0') then
do j=1,nj1
do i=1,ni1
ps(i,j) = trr(i+(j-1)*ni1,1,kk)
enddo
enddo
endif
endif
end do
*
* Horizontal interpolation (xpaq,ypaq) ===> (xpxext,ypxext) PHI GRID
*
call hinterpo (uur,ni1,nj1,uun,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
*
* Horizontal interpolation (xpaq,ypaq) ===> (xpxext,ypxext) PHI GRID
*
call hinterpo (vvr,ni1,nj1,vvn,nia,nja,nka,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,Lam_hint_S)
*
* Fill IND variables with newly interpolated data
*
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
Ind_fi(i,j,k) = 0.0
Ind_t (i,j,k) = ttr(i,j,1)
end do
end do
end do
*
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
Ind_u(i,j,k) = uur(i,j,1)
Ind_v(i,j,k) = vvr(i,j,1)
end do
end do
end do
*
do j=1,l_nj
do i=1,l_ni
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
* 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(trr(i+(j-1)*l_ni,1,jj),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
if (Lun_debug_L) then
write(Lun_out,100)
write(Lun_out,101) datev,wowp
write(Lun_out,100)
endif
*
call predat()
if ( .not. Schm_hydro_L ) then
Ind_mul = 0.
Ind_qp = 0.
endif
* Deallocate all variables
if (associated(uun)) deallocate (uun)
if (associated(vvn)) deallocate (vvn)
if (associated(ttn)) deallocate (ttn)
if (associated(trn)) deallocate (trn)
if (associated(trname_a)) deallocate (trname_a)
if (associated(xpaq)) deallocate (xpaq)
if (associated(xpau)) deallocate (xpau)
if (associated(ypaq)) deallocate (ypaq)
if (associated(ypav)) deallocate (ypav)
if (associated(ps)) deallocate (ps)
if (associated(uur)) deallocate(uur)
if (associated(vvr)) deallocate(vvr)
if (associated(ttr)) deallocate(ttr)
if (associated(trr)) deallocate(trr)
if (associated(idx)) deallocate(idx)
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)
*
*
100 format (' ',60('*'))
101 format (' (CASC_BCS_OFFLINE) JUST READ LBCS DATA FOR DATE: ',a15,x,i3)
203 format (' FILE: ',a,' NOT AVAILABLE')
204 format (' FILE: ',a,' IS AVAILABLE BUT NOT CORRECT')
1000 format (/' CASC_BCS_OFFLINE AT TIMESTEP', I8,' WOWP=',I3)
*-----------------------------------------------------------------------
return
end
*