*=*=*=*= advectnew.html =*=*=*=*
SUBROUTINE advectnew(ucov,vcov,h,w,pbarx,pbary,du,dv,dh) IMPLICIT NONE c======================================================================= c c Auteur: P. Le Van c ------- c c Objet: c ------ c c *********************************************************** c .... calcul des termes d'advection vertic.pour u,v,h,q .... c *********************************************************** c ces termes sont ajoutes a du,dv,dh et dq . c c======================================================================= c----------------------------------------------------------------------- c Declarations: c ------------- #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comvert.h" #include "comgeom.h" #include "logic.h" #include "ener.h" c Arguments: c ---------- REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),h(ip1jmp1,llm) REAL pbarx(ip1jmp1),pbary(ip1jm),w(ip1jmp1,llm) REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm) REAL wav(ip1jm,llm) c Local: c ------ REAL wsur2(ip1jm), unsdsig2(llm), unspbx(ip1jm) REAL unspby(ip1jm), unsaire2(ip1jmp1), ge(ip1jmp1) REAL deuxjour,ww,gt INTEGER ij,l EXTERNAL SSUM,SCOPY REAL SSUM c----------------------------------------------------------------------- deuxjour = 2.* daysec c c moyenene de w en x et en y: c --------------------------- DO l=1,llm DO ij=1,ip1jm-1 wav(ij,l)=.25*(w(ij,l)+w(ij+1,l)+w(ij+iip1,l)+w(ij+iip2,l)) ENDDO ENDDO CALL SCOPY(jjm*llm,w,iip1,w(iip1,1),iip1) c----------------------------------------------------------------------- c DO 2 l = 1,llm unsdsig2( l ) = 0.5 * dsig1( l ) 2 CONTINUE c DO 3 ij = iip2, ip1jm unspbx( ij ) = 1./ pbarx( ij ) 3 CONTINUE DO 4 ij = 1 , ip1jm unspby( ij ) = 1./ pbary( ij ) 4 CONTINUE c c DO 20 l = 1,llmm1 c c ...... calcul de - w/2. au niveau l+1 ....... c ...................................................... c DO 5 ij = 1,ip1jm wsur2( ij ) = - 0.5 * wav( ij,l+1 ) 5 CONTINUE c c c ................................................................ c ..................... calcul pour du .................. c ................................................................ c c c c ---------------z c ---yyx ----x c calcul de - w * d(ucov)/ (pext * d(sigma) ) qu'on ajoute a du c c c -----x,z = moyennes en x,z c c DO ij=iip2,ip1jm ww=(wsur2(ij)+wsur2(ij-iip1))* s (ucov(ij,l)-ucov(ij,l+1))*unspbx(ij) du(ij,l)= du(ij,l)+ unsdsig2(l)* ww du(ij,l+1)=du(ij,l+1)+unsdsig2(l+1)*ww ENDDO c c c ................................................................ c ................. calcul pour dv ..................... c ................................................................ c c c ---------------z c ---xxy ----y c calcul de - w * d(vcov)/ (pext * d(sigma) ) qu'on ajoute a dv c c DO ij = 2,ip1jm ww=(wsur2(ij)+wsur2(ij-1))*(vcov(ij,l)-vcov(ij,l+1))* * unspby(ij) dv(ij,l) = dv(ij,l) + unsdsig2(l) * ww dv(ij,l+1)= dv(ij,l+1) + unsdsig2(l+1) * ww ENDDO c c c c c ............................................................ c ............... calcul pour dh ................... c ............................................................ c c c ---z c calcul de - d( h * w )/ d(sigma) qu'on ajoute a dh c ......... DO 15 ij = 1,ip1jmp1 ww = wsur2(ij) * ( h(ij,l) + h(ij,l+1) ) dh(ij,l) = dh(ij,l) - dsig1(l) * ww dh(ij,l+1)= dh(ij,l+1) + dsig1(l+1) * ww 15 CONTINUE c IF( conser) THEN DO 17 ij = 1,ip1jmp1 ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) 17 CONTINUE gt = SSUM( ip1jmp1,ge,1 ) gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) END IF c 20 CONTINUE c correction pour dv: c ------------------- CALL SCOPY(jjm*llm,dv(iip1,1),iip1,dv,iip1) RETURN END