*=*=*=*= advect.html =*=*=*=*
SUBROUTINE advect(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 Modif F.Forget 03/94 : on retire q de advect 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) c Local: c ------ REAL uav(ip1jmp1,llm),vav(ip1jm,llm) REAL wsur2(ip1jmp1), unsdsig2(llm), unspbx(ip1jm) REAL unspby(ip1jm), unsaire2(ip1jmp1), ge(ip1jmp1) REAL deuxjour,ww,gt INTEGER ij,l EXTERNAL SSUM REAL SSUM c----------------------------------------------------------------------- c 2. Calculs preliminaires: c ------------------------- IF (conser) THEN deuxjour = 2. * daysec DO 1 ij = 1, ip1jmp1 unsaire2(ij) = unsaire(ij) * unsaire(ij) 1 CONTINUE END IF DO 2 l = 1,llm unsdsig2( l ) = 0.5 * dsig1( l ) 2 CONTINUE 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------------------ -yy ---------------------------------------------- c 4. Calcul de u DO 400 l=1,llm DO 440 ij=iip2,ip1jmp1 uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) 440 CONTINUE DO 420 ij=iip2,ip1jm uav(ij,l)=uav(ij,l)+uav(ij+iip1,l) 420 CONTINUE DO 430 ij=1,iip1 uav(ij,l)=0. uav(ip1jm+ij,l)=0. 430 CONTINUE 400 CONTINUE c------------------ -xx ---------------------------------------------- c 5. Calcul de v DO 500 l=1,llm DO 540 ij=2,ip1jm vav(ij,l)=0.25*(vcov(ij,l)+vcov(ij-1,l)) 540 CONTINUE DO 560 ij=1,ip1jm,iip1 vav(ij,l)=vav(ij+iim,l) 560 CONTINUE DO 520 ij=1,ip1jm-1 vav(ij,l)=vav(ij,l)+vav(ij+1,l) 520 CONTINUE DO 530 ij=1,ip1jm,iip1 vav(ij+iim,l)=vav(ij,l) 530 CONTINUE 500 CONTINUE c----------------------------------------------------------------------- DO 20 l = 1,llmm1 c ...... calcul de - w/2. au niveau l+1 ....... DO 5 ij = 1,ip1jmp1 wsur2( ij ) = - 0.5 * w( ij,l+1 ) 5 CONTINUE c ..................... calcul pour du .................. DO 6 ij=iip2,ip1jm-1 ww=(wsur2(ij)+wsur2(ij+1))*unspbx(ij) du(ij,l)=du(ij,l)- $ ww*dsig1(l)*(0.5*(ucov(ij,l)+ucov(ij,l+1))-uav(ij,l)) du(ij,l+1)=du(ij,l+1)+ $ ww*dsig1(l+1)*(0.5*(ucov(ij,l)+ucov(ij,l+1))-uav(ij,l+1)) 6 CONTINUE c ..... correction pour du(iip1,j,l) ........ c ..... du(iip1,j,l)= du(1,j,l) ..... CDIR$ IVDEP DO 7 ij = iip1 +iip1, ip1jm, iip1 du( ij, l ) = du( ij -iim, l ) du( ij,l+1 ) = du( ij -iim,l+1 ) 7 CONTINUE c ................. calcul pour dv ..................... DO 8 ij=1,ip1jm ww=(wsur2(ij+iip1)+wsur2(ij))*unspby(ij) dv(ij,l)=dv(ij,l)- $ ww*dsig1(l)*(0.5*(vcov(ij,l)+vcov(ij,l+1))-vav(ij,l)) dv(ij,l+1)=dv(ij,l+1)+ $ ww*dsig1(l+1)*(0.5*(vcov(ij,l)+vcov(ij,l+1))-vav(ij,l+1)) 8 CONTINUE c c ............................................................ c ............... calcul pour dh ................... 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 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 20 CONTINUE RETURN END