copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r brook_3d
*
subroutine brook_3d 1,8
implicit none
*
**
#include "nesting.cdk"
#include "dynmem.cdk"
#include "tracers.cdk"
#include "nestpnt.cdk"
#include "yomdyn.cdk"
#include "yomdyn1.cdk"
#include "consdyn_8.cdk"
#include "levels.cdk"
#include "partopo.cdk"
#include "brook.cdk"
#include "bcsdim.cdk"
#include "bcsmem.cdk"
*
integer i,j,k,n,gnix,gnjy,dim,kc,
$ id,indn,indw,inde,ofn,ofw,ofe
real up1(gni+2*hx,gnj+2*hy,gnk),s,d
pointer (pas1 ,s(*)), (pad1 ,d(*))
*
*---------------------------------------------------------------------
*
gnix = gni+2*hx
gnjy = gnj+2*hy
*
if (myproc.eq.0) then
*
print*, 'EXTERNAL FROUDE NUMBER = U0/sqrt(G*D0) = ',
$ brook_flo/sqrt(grav_8*htop)
*
endif
*
* Initialize all fields to zero except wind along X-axis
*
do k=1,gnk
if(k.eq.1) then
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
ppp(i,j,0) = 0.
end do
end do
endif
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
uup(i,j,k) = brook_flo
vvp(i,j,k) = 0.
hup(i,j,k) = 0.
wwp(i,j,k) = 0.
bbp(i,j,k) = 0.
ppp(i,j,k) = 0.
end do
end do
end do
*
c---- A Buble is introduced as a tracer
if (myproc.eq.0) then
kc=0
do k=1,gnk-1
if (zm(k).lt.blb_zp) kc=k
enddo
print *,"kc=",kc," : ",zm(kc)
do k=1,gnk
do j=1,gnjy
do i=1,gnix
c up1(i,j,k)=100./(1.+
c $ (real(k-kc)/real(blb_zs))**4.+
c $ (real(i-gnix/4)/real(blb_xs))**4.)
c up1(i,j,k)= min(5,max(5-abs(i-gnix/4),0))
up1(i,j,k)= 1.
end do
end do
end do
endif
call glbdist2 (up1,trp ,minx,maxx,miny,maxy,gni+hx,gnj+hy,gnk)
c----
*
dim = ndynvar*dim3d+dim2d
pas1 = pappp
pad1 = papp0
do i=1,dim
d(i) = s(i)
end do
*
ofn = (bcs_in-bcs_is)/gnk
ofw = (bcs_iw-bcs_in)/gnk
ofe = (bcs_ie-bcs_iw)/gnk
indn = bcs_in + ofn
indw = bcs_iw + ofn + ofw
inde = bcs_ie + ofn + ofw + ofe
call trnes (uup,bcs_uu(bcs_is),bcs_uu(bcs_in),bcs_uu(bcs_iw),
$ bcs_uu(bcs_ie),minx,maxx,miny,maxy,
$ minxs,maxxs,minys,maxys,minxw,maxxw,minyw,maxyw,gnk)
call trnes (vvp,bcs_vv(bcs_is),bcs_vv(bcs_in),bcs_vv(bcs_iw),
$ bcs_vv(bcs_ie),minx,maxx,miny,maxy,
$ minxs,maxxs,minys,maxys,minxw,maxxw,minyw,maxyw,gnk)
call trnes (wwp,bcs_ww(bcs_is),bcs_ww(bcs_in),bcs_ww(bcs_iw),
$ bcs_ww(bcs_ie),minx,maxx,miny,maxy,
$ minxs,maxxs,minys,maxys,minxw,maxxw,minyw,maxyw,gnk)
call trnes (bbp,bcs_bb(bcs_is),bcs_bb(bcs_in),bcs_bb(bcs_iw),
$ bcs_bb(bcs_ie),minx,maxx,miny,maxy,
$ minxs,maxxs,minys,maxys,minxw,maxxw,minyw,maxyw,gnk)
call trnes (ppp,bcs_pp(bcs_is),bcs_pp(indn) ,bcs_pp(indw) ,
$ bcs_pp(inde) ,minx,maxx,miny,maxy,
$ minxs,maxxs,minys,maxys,minxw,maxxw,minyw,maxyw,gnk+1)
call trnes (hup,bcs_hu(bcs_is),bcs_hu(bcs_in),bcs_hu(bcs_iw),
$ bcs_hu(bcs_ie),minx,maxx,miny,maxy,
$ minxs,maxxs,minys,maxys,minxw,maxxw,minyw,maxyw,gnk)
do n = 1, ntr
id = (n-1)*bcs_sz+1
call trnes (trp(1-hx,1-hy,1,n),bcs_tr(id),bcs_tr(id+bcs_in-1),
$ bcs_tr(id+bcs_iw-1),bcs_tr(id+bcs_ie-1),minx,maxx,miny,maxy,
$ minxs,maxxs,minys,maxys,minxw,maxxw,minyw,maxyw,gnk)
end do
if (ctebcs) then
do i=1,(ntr+6)*bcs_sz+bcs_sz/gnk
bcs_ppa(i) = bcs_pp(i)
end do
endif
*
if (gnpilver.gt.0) then
do k=1,gnk
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
ppntt(i,j,k) = ppp(i,j,k)
uuntt(i,j,k) = uup(i,j,k)
vvntt(i,j,k) = vvp(i,j,k)
wwntt(i,j,k) = wwp(i,j,k)
bbntt(i,j,k) = bbp(i,j,k)
huntt(i,j,k) = hup(i,j,k)
end do
end do
end do
do n = 1, ntr
do k=1,gnk
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
trntt(i,j,k,n) = trp(i,j,k,n)
end do
end do
end do
end do
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
ppntt(i,j,0) = ppp(i,j,0)
end do
end do
*
if (ctebcs) then
do k=1,gnk
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
ppnta(i,j,k) = ppp(i,j,k)
uunta(i,j,k) = uup(i,j,k)
vvnta(i,j,k) = vvp(i,j,k)
wwnta(i,j,k) = wwp(i,j,k)
bbnta(i,j,k) = bbp(i,j,k)
hunta(i,j,k) = hup(i,j,k)
end do
end do
do n=1,ntr
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
trnta(i,j,k,n) = trp(i,j,k,n)
end do
end do
end do
end do
do j=1-hy,ldnj+hy
do i=1-hx,ldni+hx
ppnta(i,j,0) = ppp(i,j,0)
end do
end do
endif
endif
c print*, 'gnpilver: ',gnpilver
c call mc2stop(-1)
*
if (myproc.eq.0) then
write (6,602)
endif
*
602 format (/'INITIALIZATION OF BROOK PROBLEM COMPLETED')
*---------------------------------------------------------------------
return
end