copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r casc_bcs
*
subroutine casc_bcs ( trname, datev, unf ) 1,12
implicit none
*
character*8 trname(*)
character*15 datev
integer unf
*
#include "lcldim.cdk"
#include "bcsdim.cdk"
#include "bcsmem.cdk"
#include "bcsgrds.cdk"
#include "nestpnt.cdk"
#include "partopo.cdk"
#include "ifd.cdk"
*
integer longueur,sid3df
external longueur,sid3df
character*4 nomvar
character*8 dynophy
character*8, dimension (:), allocatable :: trname_a
character*256 fn
logical done
integer i,j,nka,ntra,n,err,ngd,nga,errop,ofi,ofj,
$ errdyn,cumerr,cnt,nit,njt,d1,ni1,nj1,nk1,nbits
real*8 , dimension (: ), allocatable :: xpaq,ypaq,xpau,ypav
real, dimension (:,:), allocatable :: mxn,uun,vvn,wzn,
$ bun,prn,hun,cln
*-----------------------------------------------------------------------
*
* Read all needed files and construct the source domain for
* the horozontal interpolation
*
if (south_L.or.north_L.or.west_L.or.east_L) then
*
nga = bcs_nia * bcs_nja
nka = 0
ntra = 0
err = 0
done = .false.
*
do n=1,ifd_nf
if (ifd_needit(n)) then
errdyn = -1
fn ='../casc/3df_'//datev//'_'//ifd_fnext(n)
open (unf,file=fn(1:longueur(fn)),access='SEQUENTIAL',
$ form='UNFORMATTED',status='OLD',iostat=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(bcs_nia), ypaq(bcs_nja),
$ xpau(bcs_nia), ypav(bcs_nja))
err = sid3df (xpaq,ypaq,xpau,ypav,unf,done,
$ bcs_nia,bcs_nja,bcs_nka,bcs_ntra)
nka = bcs_nka
ntra= bcs_ntra
if (.not.done) then
allocate (mxn(nga,2),uun(nga,nka),vvn(nga,nka),wzn(nga,nka),
$ bun(nga,nka),prn(nga,nka+1),hun(nga,nka),
$ cln(nga*nka,ntra), trname_a(ntra))
trname_a='!@@NOT@@'
endif
*
ofi = ifd_minx(n)-1
ofj = ifd_miny(n)-1
read (unf,end=33) dynophy,cnt
*
23 if (dynophy.eq.'PHYSICSS') then
read (unf)
do i=1,cnt
read (unf)
read (unf)
end do
read (unf,end=33) dynophy,cnt
endif
*
cumerr=0
call filmup ( mxn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf, 2,
$ unf,ofi,ofj,cumerr )
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 )
call filmup ( wzn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,nka,
$ unf,ofi,ofj,cumerr )
call filmup ( bun,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,nka,
$ unf,ofi,ofj,cumerr )
call filmup ( prn,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,nka+1,
$ unf,ofi,ofj,cumerr )
call filmup ( hun,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,nka,
$ unf,ofi,ofj,cumerr )
if (ntra.gt.0) then
call filuptr ( cln,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,nka,
$ unf,ofi,ofj,trname,ntr,trname_a,ntra,cumerr )
endif
errdyn = cumerr
33 continue
*
err = err + errdyn
if (err.lt.0) then
write (6,203) fn(1:longueur(fn)),myproc
goto 999
endif
done = .true.
close (unf)
endif
end do
999 continue
*
else
err = 0
endif
*
call mc2stop(err)
*
ofi = ldni-hblen_x+2
ofj = ldnj-hblen_y+2
*
* Perform horizontal and vertical interpolations for S-N
* and W-E boundaries
*
nit = max(dimxs,dimxn)
njt = 0
if (south_L) njt = njt + dimys
if (north_L) njt = njt + dimyn
d1 = dimys*north
ngd = nit * njt
*
call casc_hvi (trname,trname_a,
$ xpn,ypn,xpun,ypvn,xpaq,ypaq,xpau,ypav,
$ bcs_ppa,bcs_ppa(bcs_inq),
$ bcs_uua,bcs_uua(bcs_in),bcs_vva,bcs_vva(bcs_in),
$ bcs_wwa,bcs_wwa(bcs_in),bcs_bba,bcs_bba(bcs_in),
$ bcs_hua,bcs_hua(bcs_in),bcs_tra,bcs_tra(bcs_in),
$ mxn,uun,vvn,wzn,bun,prn,hun,cln,
$ minxs,maxxs,minys,maxys,0,d1,0,ofj,gnk,nit,njt,
$ bcs_nia,bcs_nja,nka,ntra,south_L,north_L)
*
nit = 0
njt = max(dimyw,dimye)
if (west_L) nit = nit + dimxw
if (east_L) nit = nit + dimxe
d1 = dimxw*east
ngd = nit * njt
*
call casc_hvi (trname,trname_a,
$ xpw,ypw,xpuw,ypvw,xpaq,ypaq,xpau,ypav,
$ bcs_ppa(bcs_iwq),bcs_ppa(bcs_ieq),
$ bcs_uua(bcs_iw),bcs_uua(bcs_ie),bcs_vva(bcs_iw),bcs_vva(bcs_ie),
$ bcs_wwa(bcs_iw),bcs_wwa(bcs_ie),bcs_bba(bcs_iw),bcs_bba(bcs_ie),
$ bcs_hua(bcs_iw),bcs_hua(bcs_ie),bcs_tra(bcs_iw),bcs_tra(bcs_ie),
$ mxn,uun,vvn,wzn,bun,prn,hun,cln,
$ minxw,maxxw,minyw,maxyw,d1,0,ofi,0,gnk,nit,njt,
$ bcs_nia,bcs_nja,nka,ntra,west_L,east_L)
*
if (myproc.eq.0) then
write(6,100)
write(6,101) datev
write(6,100)
endif
*
100 format (' ',65('*'))
101 format (' (CASC_BCS) JUST READ INPUT DATA FOR DATE: ',a15)
203 format (/' PROBLEM WITH FILE: ',a,', PROC#:',i4,' --ABORT--'/)
*-----------------------------------------------------------------------
return
end
*