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

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

Parent Directory | Revision Log | View Patch Patch

-revision 46 by guez,
Wed Apr 13 12:29:18 2011 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, version 1.1.1.1 2004/05/19 12:53:05
-   ! Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2
-   ! Author: 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
-      DO ij = 1, iip1
+     ! Calcul de la dissipation:
-         gdx(ij, l) = 0.
-         gdx(ij+ip1jm, l) = 0.
+     ! Calcul de la partie grad (div) :
-      END DO
+     IF (lstardis) THEN
-      DO ij = iip2, ip1jm
+        CALL gradiv2(llm, ucov, vcov, nitergdiv, gdx, gdy)
-         du(ij, l) = du(ij, l) - te1dt(l)*gdx(ij, l)
+     ELSE
-      END DO
+        CALL gradiv(llm, ucov, vcov, nitergdiv, gdx, gdy)
-      DO ij = 1, ip1jm
+     END IF
-         dv(ij, l) = dv(ij, l) - te1dt(l)*gdy(ij, l)
-      END DO
+     DO l = 1, llm
-   END DO
+        DO ij = 1, iip1
+           gdx(ij, l) = 0.
-   ! calcul de la partie n X grad (rot) :
+           gdx(ij+(iim + 1) * jjm, l) = 0.
+        END DO
-   IF (lstardis) THEN
-      CALL nxgraro2(llm, ucov, vcov, nitergrot, grx, gry)
+        DO ij = iip2, (iim + 1) * jjm
-   ELSE
+           du(ij, l) = du(ij, l) - te1dt(l) * gdx(ij, l)
-      CALL nxgrarot(llm, ucov, vcov, nitergrot, grx, gry)
+        END DO
-   END IF
+        DO ij = 1, (iim + 1) * jjm
+           dv(ij, l) = dv(ij, l) - te1dt(l) * gdy(ij, l)
+        END DO
-   DO l = 1, llm
+     END DO
-      DO ij = 1, iip1
-         grx(ij, l) = 0.
+     ! calcul de la partie n X grad (rot) :
-      END DO
+     IF (lstardis) THEN
-      DO ij = iip2, ip1jm
+        CALL nxgraro2(llm, ucov, vcov, nitergrot, grx, gry)
-         du(ij, l) = du(ij, l) - te2dt(l)*grx(ij, l)
+     ELSE
-      END DO
+        CALL nxgrarot(llm, ucov, vcov, nitergrot, grx, gry)
-      DO ij = 1, ip1jm
+     END IF
-         dv(ij, l) = dv(ij, l) - te2dt(l)*gry(ij, l)
-      END DO
-   END DO
+     DO l = 1, llm
+        DO ij = 1, iip1
-   ! calcul de la partie div (grad) :
+           grx(ij, l) = 0.
+        END DO
-   IF (lstardis) THEN
-      DO l = 1, llm
+        DO ij = iip2, (iim + 1) * jjm
-         DO ij = 1, ip1jmp1
+           du(ij, l) = du(ij, l) - te2dt(l) * grx(ij, l)
-            deltapres(ij, l) = amax1(0., p(ij, l)-p(ij, l+1))
+        END DO
-         END DO
+        DO ij = 1, (iim + 1) * jjm
-      END DO
+           dv(ij, l) = dv(ij, l) - te2dt(l) * gry(ij, l)
+        END DO
-      CALL divgrad2(llm, teta, deltapres, niterh, gdx)
+     END DO
-   ELSE
-      CALL divgrad(llm, teta, niterh, gdx)
+     ! calcul de la partie div (grad) :
-   END IF
+     IF (lstardis) THEN
-   DO l = 1, llm
+        DO l = 1, llm
-      DO ij = 1, ip1jmp1
+           DO ij = 1, ip1jmp1
-         dh(ij, l) = dh(ij, l) - te3dt(l)*gdx(ij, l)
+              deltapres(ij, l) = max(0., p(ij, l) - p(ij, l + 1))
-      END DO
+           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.46
 


changed lines


 
Added in v.47
 Legend:



Removed from v.46
 


changed lines


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

	ViewVC Help
Powered by ViewVC 1.1.21