Changeset 5791 for LMDZ6/branches/contrails/libf/phylmd/cv_routines.f90

Timestamp:

Jul 28, 2025, 7:23:15 PM (7 days ago)

Author:

aborella

Message:

Merge with trunk r5789

Location:

LMDZ6/branches/contrails

Files:

• . (modified) (1 prop)
• libf/phylmd/cv_routines.f90 (modified) (26 diffs)

LMDZ6/branches/contrails/libf/phylmd/cv_routines.f90

@@ -1 +1 @@
 
 ! $Id$
+MODULE cv_routines_mod
+PRIVATE
+
+PUBLIC cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, cv_undilute2, &
+       cv_closure, cv_mixing, cv_yield, cv_unsat, cv_uncompress
+
+CONTAINS
 
 SUBROUTINE cv_param(nd)
@@ -243 +250 @@
 
   ! Compute icbmax.
-
-  icbmax = 2
-  DO i = 1, len
-    icbmax = max(icbmax, icb(i))
-  END DO
+  !ym do not do that, independance between column
+  !ym icbmax = 2
+  !ym DO i = 1, len
+  !ym  icbmax = max(icbmax, icb(i))
+  !ym END DO
 
   RETURN
@@ -254 +261 @@
 SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, &
     clw)
-  USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,eps,epsi,lv0,minorig,rrv,t0
+  USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,eps,epsi,lv0,minorig,rrv,t0,nl
 
   IMPLICIT NONE
@@ -299 +306 @@
   ! ***   Calculate lifted parcel quantities below cloud base   ***
 
-  DO k = minorig, icbmax - 1
+  !ym bad dependance between column => icbmax computed in cv_feed
+!ym  DO k = minorig, icbmax - 1
+  DO k = minorig, nd
     DO i = 1, len
-      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
-      tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
+      IF (k <= MAX(2,icb(i))-1) THEN
+        tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
+        tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
+      ENDIF
     END DO
   END DO
@@ -352 +363 @@
     tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi)
   END DO
-
-  DO k = minorig, icbmax
+  
+  !ym bad dependance between column => ibmax computed in cv_feed
+!ym  DO k = minorig, icbmax
+  DO k = minorig, nd
     DO i = 1, len
-      tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
+      IF (k <= MAX(2,icb(i))) THEN
+        tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
+      ENDIF
     END DO
   END DO
@@ -392 +407 @@
 END SUBROUTINE cv_trigger
 
-SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
+SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, compress, nk1, icb1, cbmf1, plcl1, &
     tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, &
     tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, &
@@ -404 +419 @@
   INTEGER len, ncum, nd, nloc
   INTEGER iflag1(len), nk1(len), icb1(len)
+  LOGICAL compress
   REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len)
   REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
@@ -424 +440 @@
   CHARACTER (LEN=80) :: abort_message
 
-
-  DO k = 1, nl + 1
+  IF (compress) THEN 
+    DO k = 1, nl + 1
+      nn = 0
+      DO i = 1, len
+        IF (iflag1(i)==0) THEN
+          nn = nn + 1
+          t(nn, k) = t1(i, k)
+          q(nn, k) = q1(i, k)
+          qs(nn, k) = qs1(i, k)
+          u(nn, k) = u1(i, k)
+          v(nn, k) = v1(i, k)
+          gz(nn, k) = gz1(i, k)
+          h(nn, k) = h1(i, k)
+          lv(nn, k) = lv1(i, k)
+          cpn(nn, k) = cpn1(i, k)
+          p(nn, k) = p1(i, k)
+          ph(nn, k) = ph1(i, k)
+          tv(nn, k) = tv1(i, k)
+          tp(nn, k) = tp1(i, k)
+          tvp(nn, k) = tvp1(i, k)
+          clw(nn, k) = clw1(i, k)
+        END IF
+      END DO
+    END DO
+  
+    IF (nn/=ncum) THEN
+      WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
+      abort_message = ''
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+  
     nn = 0
     DO i = 1, len
       IF (iflag1(i)==0) THEN
         nn = nn + 1
-        t(nn, k) = t1(i, k)
-        q(nn, k) = q1(i, k)
-        qs(nn, k) = qs1(i, k)
-        u(nn, k) = u1(i, k)
-        v(nn, k) = v1(i, k)
-        gz(nn, k) = gz1(i, k)
-        h(nn, k) = h1(i, k)
-        lv(nn, k) = lv1(i, k)
-        cpn(nn, k) = cpn1(i, k)
-        p(nn, k) = p1(i, k)
-        ph(nn, k) = ph1(i, k)
-        tv(nn, k) = tv1(i, k)
-        tp(nn, k) = tp1(i, k)
-        tvp(nn, k) = tvp1(i, k)
-        clw(nn, k) = clw1(i, k)
-      END IF
-    END DO
-  END DO
-
-  IF (nn/=ncum) THEN
-    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  nn = 0
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      nn = nn + 1
-      cbmf(nn) = cbmf1(i)
-      plcl(nn) = plcl1(i)
-      tnk(nn) = tnk1(i)
-      qnk(nn) = qnk1(i)
-      gznk(nn) = gznk1(i)
-      nk(nn) = nk1(i)
-      icb(nn) = icb1(i)
-      iflag(nn) = iflag1(i)
-    END IF
-  END DO
+        cbmf(nn) = cbmf1(i)
+        plcl(nn) = plcl1(i)
+        tnk(nn) = tnk1(i)
+        qnk(nn) = qnk1(i)
+        gznk(nn) = gznk1(i)
+        nk(nn) = nk1(i)
+        icb(nn) = icb1(i)
+        iflag(nn) = iflag1(i)
+      END IF
+    END DO
+  
+  ELSE  !compress
+    t(:, 1:nl+1) = t1(:, 1:nl+1)
+    q(:, 1:nl+1) = q1(:, 1:nl+1)
+    qs(:, 1:nl+1) = qs1(:, 1:nl+1)
+    u(:, 1:nl+1) = u1(:, 1:nl+1)
+    v(:, 1:nl+1) = v1(:, 1:nl+1)
+    gz(:, 1:nl+1) = gz1(:, 1:nl+1)
+    h(:, 1:nl+1) = h1(:, 1:nl+1)
+    lv(:, 1:nl+1) = lv1(:, 1:nl+1)
+    cpn(:, 1:nl+1) = cpn1(:, 1:nl+1)
+    p(:, 1:nl+1) = p1(:, 1:nl+1)
+    ph(:, 1:nl+1) = ph1(:, 1:nl+1)
+    tv(:, 1:nl+1) = tv1(:, 1:nl+1)
+    tp(:, 1:nl+1) = tp1(:, 1:nl+1)
+    tvp(:, 1:nl+1) = tvp1(:, 1:nl+1)
+    clw(:, 1:nl+1) = clw1(:, 1:nl+1)
+
+    cbmf(:) = cbmf1(:)
+    plcl(:) = plcl1(:)
+    tnk(:) = tnk1(:)
+    qnk(:) = qnk1(:)
+    gznk(:) = gznk1(:)
+    nk(:) = nk1(:)
+    icb(:) = icb1(:)
+    iflag(:) = iflag1(:)
+  ENDIF
 
   DO k = 1, nl
@@ -712 +755 @@
   ! J Teixeira fix
 
-  CALL zilch(byp, ncum)
+  byp(1:ncum) = 0
+
   DO i = 1, ncum
     lcape(i) = .TRUE.
@@ -745 +789 @@
 
   ! initialization:
-  DO i = 1, ncum*nlp
-    hp(i, 1) = h(i, 1)
-  END DO
+!ym very bad  
+!ym  DO i = 1, ncum*nlp
+!ym    hp(i, 1) = h(i, 1)
+!ym  END DO
+  DO k=1,nlp
+    DO i=1,ncum
+      hp(i, k) = h(i, k)
+    ENDDO
+  ENDDO
 
   DO k = minorig + 1, nl
@@ -786 +836 @@
   ! Compute icbmax.
   ! -------------------------------------------------------------------
-
-  icbmax = 2
-  DO i = 1, ncum
-    icbmax = max(icbmax, icb(i))
-  END DO
+  
+!ym independance betwwen column
+!ym  icbmax = 2
+!ym  DO i = 1, ncum
+!ym    icbmax = max(icbmax, icb(i))
+!ym  END DO
 
   ! =====================================================================
@@ -814 +865 @@
 
   ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
-
-  DO k = minorig, icbmax
+!ym independance betwwen column
+!ym  DO k = minorig, icbmax
+  DO k = minorig, nd
     DO i = 1, ncum
-      IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
-        dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
-      END IF
+      IF (k<=MAX(2,icb(i))) THEN
+        IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
+          dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
+        END IF
+      ENDIF
     END DO
   END DO
@@ -878 +932 @@
   ! =====================================================================
 
-  DO i = 1, ncum*nlp
-    nent(i, 1) = 0
-    m(i, 1) = 0.0
-  END DO
+!ym very bad
+!ym  DO i = 1, ncum*nlp
+!ym    nent(i, 1) = 0
+!ym    m(i, 1) = 0.0
+!ym  END DO
+  DO k = 1, nlp
+    DO i = 1, ncum 
+      nent(i, k) = 0
+      m(i, k) = 0.0
+    ENDDO
+  ENDDO
 
   DO k = 1, nlp
@@ -900 +961 @@
   ! -------------------------------------------------------------------
 
-  CALL zilch(work, ncum)
-
+  work(1:ncum) = 0.
+ 
   DO j = minorig + 1, nl
     DO i = 1, ncum
@@ -997 +1058 @@
   ! =====================================================================
 
-  CALL zilch(bsum, ncum*nlp)
+  bsum(1:ncum,1:nlp) = 0.
   DO ij = 1, ncum
     lwork(ij) = .FALSE.
@@ -1007 +1068 @@
       IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1
     END DO
-    IF (num1<=0) GO TO 789
+!ym    IF (num1<=0) GO TO 789
+    IF (num1<=0) CYCLE
 
     DO ij = 1, ncum
@@ -1030 +1092 @@
           ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
       END DO
-      IF (num2<=0) GO TO 783
+!ym      IF (num2<=0) GO TO 783
+      IF (num2<=0) CYCLE
 
       DO ij = 1, ncum
@@ -1173 +1236 @@
 
 
-  CALL zilch(wdtrain, ncum)
+  wdtrain(1:ncum) = 0.
   DO i = nl + 1, 1, -1
 
@@ -1180 +1243 @@
       IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
     END DO
-    IF (num1<=0) GO TO 899
+!ym    IF (num1<=0) GO TO 899
+    IF (num1<=0) CYCLE
 
 
@@ -1431 +1495 @@
       IF (i<=inb(ij)) num1 = num1 + 1
     END DO
-    IF (num1<=0) GO TO 1500
-
-    CALL zilch(amp1, ncum)
-    CALL zilch(ad, ncum)
+!ym    IF (num1<=0) GO TO 1500
+    IF (num1<=0) CYCLE
+
+    amp1(1:ncum)=0.
+    ad(1:ncum)=0.
 
     DO k = i + 1, nl + 1
@@ -1486 +1551 @@
       DO ij = 1, ncum
         IF (i<=inb(ij)) THEN
+          dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
           awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i)
           awat = max(awat, 0.0)
@@ -1503 +1569 @@
       DO ij = 1, ncum
         IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
+          dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
           fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i &
             ))
@@ -1514 +1581 @@
     DO ij = 1, ncum
       IF (i<=inb(ij)) THEN
+        dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
         fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, &
           i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
@@ -1662 +1730 @@
 END SUBROUTINE cv_yield
 
-SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
+SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, iflag, precip, cbmf, ft, &
     fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, &
     qcondc1)
@@ -1672 +1740 @@
   INTEGER len, ncum, nd, nloc
   INTEGER idcum(nloc)
+  LOGICAL is_convect(nloc)
+  LOGICAL compress
   INTEGER iflag(nloc)
   REAL precip(nloc), cbmf(nloc)
@@ -1687 +1757 @@
   ! local variables:
   INTEGER i, k
-
-  DO i = 1, ncum
-    precip1(idcum(i)) = precip(i)
-    cbmf1(idcum(i)) = cbmf(i)
-    iflag1(idcum(i)) = iflag(i)
-  END DO
-
-  DO k = 1, nl
+  
+  IF (compress) THEN
     DO i = 1, ncum
-      ft1(idcum(i), k) = ft(i, k)
-      fq1(idcum(i), k) = fq(i, k)
-      fu1(idcum(i), k) = fu(i, k)
-      fv1(idcum(i), k) = fv(i, k)
-      ma1(idcum(i), k) = ma(i, k)
-      qcondc1(idcum(i), k) = qcondc(i, k)
-    END DO
-  END DO
-
+      precip1(idcum(i)) = precip(i)
+      cbmf1(idcum(i)) = cbmf(i)
+      iflag1(idcum(i)) = iflag(i)
+    END DO
+  
+    DO k = 1, nl
+      DO i = 1, ncum
+        ft1(idcum(i), k) = ft(i, k)
+        fq1(idcum(i), k) = fq(i, k)
+        fu1(idcum(i), k) = fu(i, k)
+        fv1(idcum(i), k) = fv(i, k)
+        ma1(idcum(i), k) = ma(i, k)
+        qcondc1(idcum(i), k) = qcondc(i, k)
+      END DO
+    END DO
+  ELSE
+    DO i = 1, len
+      IF (is_convect(i)) THEN
+        precip1(i) = precip(i)
+        cbmf1(i) = cbmf(i)
+        iflag1(i) = iflag(i)
+      ENDIF
+    END DO
+  
+    DO k = 1, nl
+      DO i = 1, ncum
+        IF (is_convect(i)) THEN
+          ft1(i, k) = ft(i, k)
+          fq1(i, k) = fq(i, k)
+          fu1(i, k) = fu(i, k)
+          fv1(i, k) = fv(i, k)
+          ma1(i, k) = ma(i, k)
+          qcondc1(i, k) = qcondc(i, k)
+        ENDIF
+      END DO
+    END DO    
+  ENDIF
   RETURN
 END SUBROUTINE cv_uncompress
 
+END MODULE cv_routines_mod