copyright (C) 2001 MSC-RPN COMM %%%MC2%%% ***s/r lhs3_qtsubroutine lhs3_qt 1 implicit none * *AUTHORs C. Girard & M. Desgagne * *OBJECT * #include "nbcpu.cdk"
#include "dynmem.cdk"
#include "consdyn_8.cdk"
#include "yomdyn.cdk"
#include "yomdyn1.cdk"
#include "dynpar.cdk"
#include "topo.cdk"
#include "dtmdtp.cdk"
#include "alfmem.cdk"
* integer i,j,k real*8 pt5, q3, wwp1, wwpgnk, nu0 parameter (pt5 = 0.5d0) * *--------------------------------------------------------------- * do k = 1, gnk * if (k.eq.1) then do j=1,ldnj-north do i=1,ldni-east ppp(i,j,k) = ppp(i,j,k) / c2r_star q3 = sbxy(i,j) * pt5 * $ (- gg1(i+1,j,k)*uup(i+1,j,k) - gg1(i,j,k)*uup(i,j,k) $ - gg2(i,j+1,k)*vvp(i,j+1,k) - gg2(i,j,k)*vvp(i,j,k) ) wwp(i,j,k) = dhdt(i,j,k) - q3 ppp(i,j,0) = ( - bbp(i,j,k) + $ (g0wr(i,j,k)-c05*n02g(i,j,k))*ppp(i,j,k) ) $ / (g0wr(i,j,k)+c05*n02g(i,j,k)) bbp(i,j,k) = bbp(i,j,k) $ + gama_star*pt5*(ppp(i,j,k)+ppp(i,j,k-1)) end do end do * else if ((k.eq.gnk).and.(.not.flextop)) then do j=1,ldnj-north do i=1,ldni-east wwp(i,j,k) = 0. ppp(i,j,k) = ( + bbp(i,j,k) + $ (g0wr(i,j,k)+c05*n02g(i,j,k))*ppp(i,j,k-1)) $ / (g0wr(i,j,k)-c05*n02g(i,j,k)) bbp(i,j,k) = bbp(i,j,k) $ + gama_star*pt5*(ppp(i,j,k)+ppp(i,j,k-1)) end do end do * else do j=1,ldnj-north do i=1,ldni-east ppp(i,j,k) = ppp(i,j,k) / c2r_star bbp(i,j,k) = bbp(i,j,k) $ + gama_star*pt5*(ppp(i,j,k)+ppp(i,j,k-1)) end do end do * endif * if(k.eq.gnk) then do j=1,ldnj do i=1,ldni uup(i,j,gnk)=uup(i,j,gnk-1) vvp(i,j,gnk)=vvp(i,j,gnk-1) end do end do endif * end do * *--------------------------------------------------------------- return end