/[lmdze]/trunk/libf/dyn3d/dissip.f90

Diff of /trunk/libf/dyn3d/dissip.f90

Parent Directory | Revision Log | View Patch Patch

-revision 26 by guez,
Tue Mar  9 15:27:15 2010 UTC
+revision 47 by guez,
Fri Jul  1 15:00:48 2011 UTC
 Line 1
- SUBROUTINE dissip(vcov,ucov,teta,p,dv,du,dh)
+ module dissip_m
-   ! From dyn3d/dissip.F,v 1.1.1.1 2004/05/19 12:53:05
-   ! Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
-   ! Auteur:  P. Le Van
-   ! Objet: dissipation horizontale
-   USE dimens_m, ONLY : llm
-   USE paramet_m, ONLY : iip1, iip2, ip1jm, ip1jmp1, llmp1
-   USE comdissnew, ONLY : lstardis, nitergdiv, nitergrot, niterh
-   USE inidissip_m, ONLY : dtdiss, tetah, tetaudiv, tetaurot
    IMPLICIT NONE
-   !   Arguments:
+ contains
-   REAL :: vcov(ip1jm,llm), ucov(ip1jmp1,llm), teta(ip1jmp1,llm)
-   REAL, INTENT (IN) :: p(ip1jmp1,llmp1)
+   SUBROUTINE dissip(vcov, ucov, teta, p, dv, du, dh)
-   REAL :: dv(ip1jm,llm), du(ip1jmp1,llm), dh(ip1jmp1,llm)
+     ! From dyn3d/dissip.F, version 1.1.1.1 2004/05/19 12:53:05
-   !   Local:
+     ! Avec nouveaux opérateurs star : gradiv2, divgrad2, nxgraro2
-   REAL :: gdx(ip1jmp1,llm), gdy(ip1jm,llm)
+     ! Author: P. Le Van
-   REAL :: grx(ip1jmp1,llm), gry(ip1jm,llm)
+     ! Objet : dissipation horizontale
-   REAL :: te1dt(llm), te2dt(llm), te3dt(llm)
-   REAL :: deltapres(ip1jmp1,llm)
+     USE dimens_m, ONLY : iim, jjm, llm
+     USE paramet_m, ONLY : iip1, iip2, ip1jmp1, llmp1
-   INTEGER :: l, ij
+     USE comdissnew, ONLY : lstardis, nitergdiv, nitergrot, niterh
+     USE inidissip_m, ONLY : dtdiss, tetah, tetaudiv, tetaurot
-   !-----------------------------------------------------------------------
+     ! Arguments:
-   !   initialisations:
+     REAL vcov((iim + 1) * jjm, llm), ucov(ip1jmp1, llm), teta(ip1jmp1, llm)
+     REAL, INTENT (IN) :: p(ip1jmp1, llmp1)
-   DO l = 1, llm
+     REAL dv((iim + 1) * jjm, llm), du(ip1jmp1, llm), dh(ip1jmp1, llm)
-      te1dt(l) = tetaudiv(l)*dtdiss
-      te2dt(l) = tetaurot(l)*dtdiss
+     ! Local:
-      te3dt(l) = tetah(l)*dtdiss
+     REAL gdx(ip1jmp1, llm), gdy((iim + 1) * jjm, llm)
-   END DO
+     REAL grx(ip1jmp1, llm), gry((iim + 1) * jjm, llm)
-   du = 0.
+     REAL te1dt(llm), te2dt(llm), te3dt(llm)
-   dv = 0.
+     REAL deltapres(ip1jmp1, llm)
-   dh = 0.
+     INTEGER l, ij
-   !   Calcul de la dissipation:
+     !-----------------------------------------------------------------------
-   !   Calcul de la partie   grad  ( div ) :
+     ! Initializations:
-   IF (lstardis) THEN
+     te1dt = tetaudiv * dtdiss
-      CALL gradiv2(llm,ucov,vcov,nitergdiv,gdx,gdy)
+     te2dt = tetaurot * dtdiss
-   ELSE
+     te3dt = tetah * dtdiss
-      CALL gradiv(llm,ucov,vcov,nitergdiv,gdx,gdy)
+     du = 0.
-   END IF
+     dv = 0.
+     dh = 0.
-   DO l = 1, llm
+     ! Calcul de la dissipation:
-      DO ij = 1, iip1
-         gdx(ij,l) = 0.
+     ! Calcul de la partie grad (div) :
-         gdx(ij+ip1jm,l) = 0.
-      END DO
+     IF (lstardis) THEN
+        CALL gradiv2(llm, ucov, vcov, nitergdiv, gdx, gdy)
-      DO ij = iip2, ip1jm
+     ELSE
-         du(ij,l) = du(ij,l) - te1dt(l)*gdx(ij,l)
+        CALL gradiv(llm, ucov, vcov, nitergdiv, gdx, gdy)
-      END DO
+     END IF
-      DO ij = 1, ip1jm
-         dv(ij,l) = dv(ij,l) - te1dt(l)*gdy(ij,l)
+     DO l = 1, llm
-      END DO
+        DO ij = 1, iip1
-   END DO
+           gdx(ij, l) = 0.
+           gdx(ij+(iim + 1) * jjm, l) = 0.
-   !   calcul de la partie   n X grad ( rot ):
+        END DO
-   IF (lstardis) THEN
+        DO ij = iip2, (iim + 1) * jjm
-      CALL nxgraro2(llm,ucov,vcov,nitergrot,grx,gry)
+           du(ij, l) = du(ij, l) - te1dt(l) * gdx(ij, l)
-   ELSE
+        END DO
-      CALL nxgrarot(llm,ucov,vcov,nitergrot,grx,gry)
+        DO ij = 1, (iim + 1) * jjm
-   END IF
+           dv(ij, l) = dv(ij, l) - te1dt(l) * gdy(ij, l)
+        END DO
+     END DO
-   DO l = 1, llm
-      DO ij = 1, iip1
+     ! calcul de la partie n X grad (rot) :
-         grx(ij,l) = 0.
-      END DO
+     IF (lstardis) THEN
+        CALL nxgraro2(llm, ucov, vcov, nitergrot, grx, gry)
-      DO ij = iip2, ip1jm
+     ELSE
-         du(ij,l) = du(ij,l) - te2dt(l)*grx(ij,l)
+        CALL nxgrarot(llm, ucov, vcov, nitergrot, grx, gry)
-      END DO
+     END IF
-      DO ij = 1, ip1jm
-         dv(ij,l) = dv(ij,l) - te2dt(l)*gry(ij,l)
-      END DO
+     DO l = 1, llm
-   END DO
+        DO ij = 1, iip1
+           grx(ij, l) = 0.
-   !   calcul de la partie   div ( grad ):
+        END DO
-   IF (lstardis) THEN
+        DO ij = iip2, (iim + 1) * jjm
+           du(ij, l) = du(ij, l) - te2dt(l) * grx(ij, l)
-      DO l = 1, llm
+        END DO
-         DO ij = 1, ip1jmp1
+        DO ij = 1, (iim + 1) * jjm
-            deltapres(ij,l) = amax1(0.,p(ij,l)-p(ij,l+1))
+           dv(ij, l) = dv(ij, l) - te2dt(l) * gry(ij, l)
-         END DO
+        END DO
-      END DO
+     END DO
-      CALL divgrad2(llm,teta,deltapres,niterh,gdx)
+     ! calcul de la partie div (grad) :
-   ELSE
-      CALL divgrad(llm,teta,niterh,gdx)
+     IF (lstardis) THEN
-   END IF
+        DO l = 1, llm
+           DO ij = 1, ip1jmp1
-   DO l = 1, llm
+              deltapres(ij, l) = max(0., p(ij, l) - p(ij, l + 1))
-      DO ij = 1, ip1jmp1
+           END DO
-         dh(ij,l) = dh(ij,l) - te3dt(l)*gdx(ij,l)
+        END DO
-      END DO
-   END DO
+        CALL divgrad2(llm, teta, deltapres, niterh, gdx)
+     ELSE
+        CALL divgrad(llm, teta, niterh, gdx)
+     END IF
+     forall (l = 1: llm) dh(:, l) = dh(:, l) - te3dt(l) * gdx(:, l)
+   END SUBROUTINE dissip
- END SUBROUTINE dissip
+ end module dissip_m

 Legend:



Removed from v.26
 


changed lines


 
Added in v.47
 Legend:



Removed from v.26
 


changed lines


 
Added in v.47
-Removed from v.26
+Added in v.47

	ViewVC Help
Powered by ViewVC 1.1.21