copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r casc_bcsh
*
subroutine casc_bcsh ( 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"
*
character*4 nomvar
character*8, dimension (:), allocatable :: trname_a
integer i,j,k,nka,ntra,n,err,ngas,ngaw,ofi,ofj,
$ nit,njt,d1,nis,njs,niw,njw,iscal(2),errcode
real htop
real*8, dimension (: ), allocatable :: xpsn,ypsn,xpwe,ypwe,
$ xpaqs,ypaqs,xpaus,ypavs,xpaqw,ypaqw,xpauw,ypavw
real , dimension (: ), allocatable :: zt1
real , dimension (:,:), allocatable :: mxns,uuns,vvns,wzns,buns,
$ prns,huns,clns,mxnw,uunw,vvnw,wznw,bunw,prnw,hunw,clnw
*-----------------------------------------------------------------------
*
errcode = 0
if (south_L.or.north_L.or.west_L.or.east_L) then
*
if (pazta.gt.0) call hpdeallc (pazta, err, 1)
pazta = 0
*
read (unf) nomvar,nis,njs,niw,njw,ntra
allocate (xpsn (nis),ypsn (njs*2),xpwe (niw*2),ypwe (njw))
nis = nis - 1
njs = njs - 1
niw = niw - 1
njw = njw - 1
allocate (xpaqs(nis),ypaqs(njs*2),xpaus(nis),ypavs(njs*2),
$ xpaqw(niw*2),ypaqw(njw),xpauw(niw*2),ypavw(njw))
read (unf) xpsn,ypsn,xpwe,ypwe
read (unf) nomvar,nka,iscal,htop
call hpalloc (pazta ,nka+3 , err,1)
allocate (zt1(nka))
read (unf) zt1
*
do k=1,nka
zta(k) = zt1(k)
end do
zta (nka+1) = htop
zta (nka+2) = iscal(1)
zta (nka+3) = iscal(2)
*
do i=1,nis
xpaqs(i) = xpsn(i+1)
xpaus(i) = 0.5 * (xpsn(i) + xpsn(i+1))
end do
do j=1,njs
ypaqs(j) = ypsn(j+1)
ypavs(j) = 0.5 * (ypsn(j) + ypsn(j+1))
end do
do j=njs+1,njs*2
ypaqs(j) = ypsn(j+2)
ypavs(j) = 0.5 * (ypsn(j+1) + ypsn(j+2))
end do
*
do i=1,niw
xpaqw(i) = xpwe(i+1)
xpauw(i) = 0.5 * (xpwe(i) + xpwe(i+1))
end do
do i=niw+1,niw*2
xpaqw(i) = xpwe(i+2)
xpauw(i) = 0.5 * (xpwe(i+1) + xpwe(i+2))
end do
do j=1,njw
ypaqw(j) = ypwe(j+1)
ypavw(j) = 0.5 * (ypwe(j) + ypwe(j+1))
end do
*
deallocate (xpsn,ypsn,xpwe,ypwe,zt1)
*
ngas = nis*njs*2
ngaw = niw*njw*2
allocate (mxns(ngas, 2),uuns(ngas,nka),vvns(ngas,nka ),
$ wzns(ngas,nka),buns(ngas,nka),prns(ngas,nka+1),
$ huns(ngas,nka),clns(ngas*nka,ntra), trname_a(ntra))
allocate (mxnw(ngaw, 2),uunw(ngaw,nka),vvnw(ngaw,nka ),
$ wznw(ngaw,nka),bunw(ngaw,nka),prnw(ngaw,nka+1),
$ hunw(ngaw,nka),clnw(ngaw*nka,ntra))
trname_a='!@@NOT@@'
*
read (unf)
call rdbcs ( mxns, mxnw, nis,njs,niw,njw, 2 , unf)
call rdbcs ( uuns, uunw, nis,njs,niw,njw,nka , unf)
call rdbcs ( vvns, vvnw, nis,njs,niw,njw,nka , unf)
call rdbcs ( wzns, wznw, nis,njs,niw,njw,nka , unf)
call rdbcs ( buns, bunw, nis,njs,niw,njw,nka , unf)
call rdbcs ( prns, prnw, nis,njs,niw,njw,nka+1, unf)
call rdbcs ( huns, hunw, nis,njs,niw,njw,nka , unf)
if (ntra.gt.0) then
call rdbcs_tr ( clns,clnw,nis,njs,niw,njw,nka,unf,
$ trname,ntr,trname_a,ntra )
endif
*
endif
*
ofi = ldni-hblen_x+2
ofj = ldnj-hblen_y+2
*
* Perform horizontal and vertical interpolations for S-N
* and W-E boundaries
*
errcode = -1
nit = max(dimxs,dimxn)
njt = 0
if (south_L) njt = njt + dimys
if (north_L) njt = njt + dimyn
d1 = dimys*north
*
if (nit*njt.gt.0) then
if ((south_L).and.(north_L)) then
if ((ypn(1).gt.ypaqs(2)).and.(ypn(njt/2).lt.ypaqs(njs-1)).and.
$ (ypn(njt/2+1).gt.ypaqs(njs+2)).and.
$ (ypn(njt).lt.ypaqs(2*njs-1))) errcode = 0
else if (south_L) then
if ((ypn(1).gt.ypaqs(2)).and.(ypn(njt).lt.ypaqs(njs-1))) errcode = 0
else if (north_L) then
if ((ypn(1).gt.ypaqs(njs+2)).and.(ypn(njt).lt.ypaqs(2*njs-1))) errcode = 0
endif
else
errcode = 0
endif
if (errcode.lt.0) print*, 'Insufficient input NS data in casc_bcsh - ABORT -',myproc
call mc2stop(errcode)
*
call casc_hvi (trname,trname_a,
$ xpn,ypn,xpun,ypvn,xpaqs,ypaqs,xpaus,ypavs,
$ 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),
$ mxns,uuns,vvns,wzns,buns,prns,huns,clns,
$ minxs,maxxs,minys,maxys,0,d1,0,ofj,gnk,nit,njt,
$ nis,njs*2,nka,ntra,south_L,north_L)
*
errcode = -1
nit = 0
njt = max(dimyw,dimye)
if (west_L) nit = nit + dimxw
if (east_L) nit = nit + dimxe
d1 = dimxw*east
*
if (nit*njt.gt.0) then
if ((west_L).and.(east_L)) then
if ((xpw(1).gt.xpaqw(2)).and.(xpw(nit/2).lt.xpaqw(niw-1)).and.
$ (xpw(nit/2+1).gt.xpaqw(niw+2)).and.
$ (xpw(nit).lt.xpaqw(2*niw-1))) errcode = 0
else if (west_L) then
if ((xpw(1).gt.xpaqw(2)).and.(xpw(nit).lt.xpaqw(niw-1))) errcode = 0
else if (east_L) then
if ((xpw(1).gt.xpaqw(niw+2)).and.(xpw(nit).lt.xpaqw(2*niw-1))) errcode = 0
endif
else
errcode = 0
endif
if (errcode.lt.0) print*, 'Insufficient input WE data in casc_bcsh - ABORT -',myproc
call mc2stop(errcode)
*
call casc_hvi (trname,trname_a,
$ xpw,ypw,xpuw,ypvw,xpaqw,ypaqw,xpauw,ypavw,
$ 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),
$ mxnw,uunw,vvnw,wznw,bunw,prnw,hunw,clnw,
$ minxw,maxxw,minyw,maxyw,d1,0,ofi,0,gnk,nit,njt,
$ niw*2,njw,nka,ntra,west_L,east_L)
*
if (south_L.or.north_L.or.west_L.or.east_L) then
deallocate (xpaqs,ypaqs,xpaus,ypavs,xpaqw,ypaqw,xpauw,ypavw,
$ mxns,uuns,vvns,wzns,buns,prns,huns,clns,
$ mxnw,uunw,vvnw,wznw,bunw,prnw,hunw,clnw,trname_a)
endif
*
if (myproc.eq.0) then
write(6,100)
write(6,101) datev
write(6,100)
endif
*
100 format (' ',65('*'))
101 format (' (CASC_BCSH) JUST READ INPUT DATA FOR DATE: ',a15)
*-----------------------------------------------------------------------
return
end
*
subroutine rdbcs ( fs, fw, nis, njs, niw, njw, nk, unf ) 7
implicit none
*
integer nis,njs,niw,njw,nk,unf
real fs (nis,njs*2,nk), fw (niw*2,njw,nk)
*
character*4 nomvar
integer k,ni1,nj1,ni2,nj2,nk1,nbits,nb,ns,nw
real, dimension (:), allocatable :: wkc,wkd
*
*-----------------------------------------------------------------------
*
nb = 0
read (unf) nomvar,ni1,nj1,ni2,nj2,nk1,nbits
if ((ni1.ne.nis).or.(nj1.ne.njs).or.
$ (ni2.ne.niw).or.(nj2.ne.njw).or.(nk1.ne.nk)) then
write (6,1001) ni1,nj1,ni2,nj2,nk1,nis,njs,niw,njw,nk
stop
endif
*
if (nbits.ge.32) then
read (unf) fs,fw
else
ns = (nis*njs*2*nbits+120+32-1)/32
allocate (wkc(ns))
nw = (niw*njw*2*nbits+120+32-1)/32
allocate (wkd(nw))
do k=1,nk
read (unf) wkc,wkd
call xxpak (fs(1,1,k), wkc, nis, njs*2, -nbits, nb, 2)
call xxpak (fw(1,1,k), wkd, niw*2, njw, -nbits, nb, 2)
end do
deallocate (wkc,wkd)
endif
*
*-----------------------------------------------------------------------
1001 format (/' PROBLEM WITH DIMENSIONS IN CASC_BCSH: ',10i6)
return
end
*
subroutine rdbcs_tr ( fs, fw, nis, njs, niw, njw, nk, unf, 1
$ trname,ntr,trname_a,ntra )
implicit none
*
integer nis,njs,niw,njw,nk,unf,ntr,ntra
character*8 trname(ntr),trname_a(ntra)
real fs (nis,njs*2,nk), fw (niw*2,njw,nk)
*
character*4 nomvar
integer k,n,m,ni1,nj1,ni2,nj2,nk1,takeit,nbits,nb,ns,nw
real, dimension (:), allocatable :: wkc,wkd
*
*-----------------------------------------------------------------------
*
nb = 0
do n=1,ntra
read (unf) nomvar,ni1,nj1,ni2,nj2,nk1,nbits
takeit=-1
do m=1,ntr
if (trname(m)(1:4).eq.nomvar) takeit=m
end do
if (takeit.gt.0) then
*
trname_a(n) = trname(takeit)
if ((ni1.ne.nis).or.(nj1.ne.njs).or.
$ (ni2.ne.niw).or.(nj2.ne.njw).or.(nk1.ne.nk)) then
write (6,1001) ni1,nj1,ni2,nj2,nk1,nis,njs,niw,njw,nk
stop
endif
*
if (nbits.ge.32) then
read (unf) fs,fw
else
ns = (nis*njs*2*nbits+120+32-1)/32
allocate (wkc(ns))
nw = (niw*njw*2*nbits+120+32-1)/32
allocate (wkd(nw))
do k=1,nk
read (unf) wkc,wkd
call xxpak (fs(1,1,k), wkc, nis, njs*2, -nbits, nb, 2)
call xxpak (fw(1,1,k), wkd, niw*2, njw, -nbits, nb, 2)
end do
deallocate (wkc,wkd)
endif
*
else
*
trname_a(n) = '!@@NOT@@'
read (unf)
*
endif
end do
*
*-----------------------------------------------------------------------
1001 format (/' PROBLEM WITH DIMENSIONS IN CASC_BCSH: ',10i6)
return
end