copyright (C) 2001 MSC-RPN COMM %%%MC2%%% ***s/r euler -- Compute so-called Q terms *subroutine euler ( t1, dtm, dtp ) 1,1 implicit none * real t1(*) real*8 dtm,dtp * * #include "grd.cdk"
#include "yomdyn.cdk"
#include "yomdyn1.cdk"
#include "dynmem.cdk"
#include "wrnmem.cdk"
#include "nbcpu.cdk"
#include "partopo.cdk"
* ** integer i,j,k,n,id,jd,iff,jf,err real*8 dt real tra(minx:maxx,miny:maxy,gnk,max(1,ntr)) real pa,ua,va,wa,ba,hua pointer (papa , pa(minx:maxx,miny:maxy,0:gnk)), $ (paua , ua(minx:maxx,miny:maxy,*)), $ (pava , va(minx:maxx,miny:maxy,*)), $ (pawa , wa(minx:maxx,miny:maxy,*)), $ (paba , ba(minx:maxx,miny:maxy,*)), $ (pahua, hua(minx:maxx,miny:maxy,*)) *---------------------------------------------------------------------- papa = loc(t1( 1)) paua = loc(t1( dim3d+dim2d+1)) pava = loc(t1(2*dim3d+dim2d+1)) pawa = loc(t1(3*dim3d+dim2d+1)) paba = loc(t1(4*dim3d+dim2d+1)) pahua = loc(t1(5*dim3d+dim2d+1)) * call adveul
( ua, va, wa, ba, pa, hua, tra, $ minx,maxx,miny,maxy,gnk) * id =1 jd =1 iff=ldni-east jf =ldnj-north dt = dtm+dtp * do k=1,gnk if(k.ne.gnk) then do j=jd,jf do i=id+west,iff uup (i,j,k) = uup (i,j,k) + dt * (uur(i,j,k)+ua(i,j,k)) end do end do do j=jd+south,jf do i=id,iff vvp (i,j,k) = vvp (i,j,k) + dt * (vvr(i,j,k)+va(i,j,k)) end do end do endif do j=jd,jf do i=id,iff wwp(i,j,k) = wwp(i,j,k) + dt * (wwr(i,j,k) + wa(i,j,k)) bbp(i,j,k) = bbp(i,j,k) + dt * (bbr(i,j,k) + ba(i,j,k)) ppp(i,j,k) = ppp(i,j,k) + dt * (ppr(i,j,k) + pa(i,j,k)) hup(i,j,k) = hup(i,j,k) + dt * hua(i,j,k) end do end do do n=1,ntr do j=jd,jf do i=id,iff trp(i,j,k,n) = trp(i,j,k,n) + dt * tra(i,j,k,n) end do end do end do end do * *---------------------------------------------------------------------- return end