/[lmdze]/trunk/dyn3d/vlspltqs.f
ViewVC logotype

Diff of /trunk/dyn3d/vlspltqs.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/dyn3d/vlspltqs.f90 revision 71 by guez, Mon Jul 8 18:12:18 2013 UTC trunk/dyn3d/vlspltqs.f revision 254 by guez, Mon Feb 5 10:39:38 2018 UTC
# Line 1  Line 1 
1  SUBROUTINE vlspltqs(q, pente_max, masse, w, pbaru, pbarv, pdt, p, pk, teta)  module vlspltqs_m
2    
3    ! From LMDZ4/libf/dyn3d/vlspltqs.F, version 1.2 2005/02/24 12:16:57 fairhead    IMPLICIT NONE
4    
5    ! Authors: P. Le Van, F. Hourdin, F. Forget, F. Codron  contains
6    
7    ! Schéma d'advection "pseudo amont"    SUBROUTINE vlspltqs(q, pente_max, masse, w, pbaru, pbarv, pdt, p, pk, teta)
   ! + test sur humidité spécifique : Q advecté < Qsat aval  
   ! (F. Codron, 10/99)  
8    
9    ! q, pbaru, pbarv, w sont des arguments d'entree pour le sous-programme      ! From LMDZ4/libf/dyn3d/vlspltqs.F, version 1.2 2005/02/24 12:16:57 fairhead
10    
11    ! pente_max facteur de limitation des pentes: 2 en général      ! Authors: P. Le Van, F. Hourdin, F. Forget, F. Codron
   ! 0 pour un schéma amont  
   ! pbaru, pbarv, w flux de masse en u , v , w  
   ! pdt pas de temps  
12    
13    ! teta température potentielle, p pression aux interfaces,      ! Schéma d'advection "pseudo amont"
14    ! pk exner au milieu des couches nécessaire pour calculer Qsat      ! + test sur humidité spécifique : Q advecté < Qsat aval
15        ! (F. Codron, 10/99)
16    
17    USE dimens_m, ONLY : iim, llm      ! q, pbaru, pbarv, w sont des arguments d'entree pour le sous-programme
   USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, llmp1  
   USE comconst, ONLY : cpp  
18    
19    IMPLICIT NONE      ! pente_max facteur de limitation des pentes: 2 en général
20        ! 0 pour un schéma amont
21        ! pbaru, pbarv, w flux de masse en u , v , w
22        ! pdt pas de temps
23    
24        ! teta température potentielle, p pression aux interfaces,
25        ! pk exner au milieu des couches nécessaire pour calculer Qsat
26    
27        USE dimens_m, ONLY : iim, llm
28        use FCTTRE, only: foeew
29        USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, llmp1
30        USE comconst, ONLY : cpp
31        use SUPHEC_M, only: rtt
32    
33        ! Arguments:
34    
35        REAL masse(ip1jmp1, llm), pente_max
36        REAL, intent(in):: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
37        REAL q(ip1jmp1, llm)
38        REAL w(ip1jmp1, llm)
39        real, intent(in):: pdt
40        REAL, intent(in):: p(ip1jmp1, llmp1)
41        real, intent(in):: teta(ip1jmp1, llm)
42        real, intent(in):: pk(ip1jmp1, llm)
43    
44        ! Local
45    
46        INTEGER ij, l
47    
48        REAL qsat(ip1jmp1, llm)
49        REAL zm(ip1jmp1, llm)
50        REAL mu(ip1jmp1, llm)
51        REAL mv(ip1jm, llm)
52        REAL mw(ip1jmp1, llm+1)
53        REAL zq(ip1jmp1, llm)
54        REAL zzpbar, zzw
55    
56        !--pour rapport de melange saturant--
57    
58        REAL retv, r2es, play
59        logical zdelta
60        REAL tempe(ip1jmp1)
61    
62        !------------------------------------------------------------------
63    
64        r2es = 380.11733
65        retv = 0.6077667
66    
67        !-- Calcul de Qsat en chaque point
68        !-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
69        ! pour eviter une exponentielle.
70        DO l = 1, llm
71           DO ij = 1, ip1jmp1
72              tempe(ij) = teta(ij, l) * pk(ij, l) /cpp
73           ENDDO
74           DO ij = 1, ip1jmp1
75              zdelta = rtt > tempe(ij)
76              play = 0.5*(p(ij, l)+p(ij, l+1))
77              qsat(ij, l) = MIN(0.5, r2es* FOEEW(tempe(ij), zdelta) / play)
78              qsat(ij, l) = qsat(ij, l) / (1. - retv * qsat(ij, l))
79           ENDDO
80        ENDDO
81    
82        zzpbar = 0.5 * pdt
83        zzw = pdt
84        DO l=1, llm
85           DO ij = iip2, ip1jm
86              mu(ij, l)=pbaru(ij, l) * zzpbar
87           ENDDO
88           DO ij=1, ip1jm
89              mv(ij, l)=pbarv(ij, l) * zzpbar
90           ENDDO
91           DO ij=1, ip1jmp1
92              mw(ij, l)=w(ij, l) * zzw
93           ENDDO
94        ENDDO
95    
96        DO ij=1, ip1jmp1
97           mw(ij, llm+1)=0.
98        ENDDO
99    
100        CALL SCOPY(ijp1llm, q, 1, zq, 1)
101        CALL SCOPY(ijp1llm, masse, 1, zm, 1)
102    
103        ! call minmaxq(zq, qmin, qmax, 'avant vlxqs ')
104        call vlxqs(zq, pente_max, zm, mu, qsat)
105    
106        ! call minmaxq(zq, qmin, qmax, 'avant vlyqs ')
107    
108        call vlyqs(zq, pente_max, zm, mv, qsat)
109    
110        ! call minmaxq(zq, qmin, qmax, 'avant vlz ')
111    
112        call vlz(zq, pente_max, zm, mw)
113    
114        ! call minmaxq(zq, qmin, qmax, 'avant vlyqs ')
115        ! call minmaxq(zm, qmin, qmax, 'M avant vlyqs ')
116    
117        call vlyqs(zq, pente_max, zm, mv, qsat)
118    
119        ! call minmaxq(zq, qmin, qmax, 'avant vlxqs ')
120        ! call minmaxq(zm, qmin, qmax, 'M avant vlxqs ')
121    
122        call vlxqs(zq, pente_max, zm, mu, qsat)
123    
124        ! call minmaxq(zq, qmin, qmax, 'apres vlxqs ')
125        ! call minmaxq(zm, qmin, qmax, 'M apres vlxqs ')
126    
127    ! Arguments:      DO l=1, llm
128           DO ij=1, ip1jmp1
129              q(ij, l)=zq(ij, l)
130           ENDDO
131           DO ij=1, ip1jm+1, iip1
132              q(ij+iim, l)=q(ij, l)
133           ENDDO
134        ENDDO
135    
136    REAL masse(ip1jmp1, llm), pente_max    END SUBROUTINE vlspltqs
   REAL, intent(in):: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)  
   REAL q(ip1jmp1, llm)  
   REAL w(ip1jmp1, llm)  
   real, intent(in):: pdt  
   REAL, intent(in):: p(ip1jmp1, llmp1)  
   real, intent(in):: teta(ip1jmp1, llm)  
   real, intent(in):: pk(ip1jmp1, llm)  
   
   ! Local  
   
   INTEGER i, ij, l, j, ii  
   
   REAL qsat(ip1jmp1, llm)  
   REAL zm(ip1jmp1, llm)  
   REAL mu(ip1jmp1, llm)  
   REAL mv(ip1jm, llm)  
   REAL mw(ip1jmp1, llm+1)  
   REAL zq(ip1jmp1, llm)  
   REAL temps1, temps2, temps3  
   REAL zzpbar, zzw  
   LOGICAL testcpu  
   SAVE testcpu  
   SAVE temps1, temps2, temps3  
   
   REAL qmin, qmax  
   DATA qmin, qmax/0., 1.e33/  
   DATA testcpu/.false./  
   DATA temps1, temps2, temps3/0., 0., 0./  
   
   !--pour rapport de melange saturant--  
   
   REAL rtt, retv, r2es, r3les, r3ies, r4les, r4ies, play  
   REAL ptarg, pdelarg, foeew, zdelta  
   REAL tempe(ip1jmp1)  
   
   ! fonction psat(T)  
   FOEEW(PTARG, PDELARG) = EXP ((R3LES*(1.-PDELARG)+R3IES*PDELARG) &  
        * (PTARG-RTT) / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)))  
   
   !------------------------------------------------------------------  
   
   r2es = 380.11733  
   r3les = 17.269  
   r3ies = 21.875  
   r4les = 35.86  
   r4ies = 7.66  
   retv = 0.6077667  
   rtt = 273.16  
   
   !-- Calcul de Qsat en chaque point  
   !-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2  
   ! pour eviter une exponentielle.  
   DO l = 1, llm  
      DO ij = 1, ip1jmp1  
         tempe(ij) = teta(ij, l) * pk(ij, l) /cpp  
      ENDDO  
      DO ij = 1, ip1jmp1  
         zdelta = MAX(0., SIGN(1., rtt - tempe(ij)))  
         play = 0.5*(p(ij, l)+p(ij, l+1))  
         qsat(ij, l) = MIN(0.5, r2es* FOEEW(tempe(ij), zdelta) / play)  
         qsat(ij, l) = qsat(ij, l) / (1. - retv * qsat(ij, l))  
      ENDDO  
   ENDDO  
   
   zzpbar = 0.5 * pdt  
   zzw = pdt  
   DO l=1, llm  
      DO ij = iip2, ip1jm  
         mu(ij, l)=pbaru(ij, l) * zzpbar  
      ENDDO  
      DO ij=1, ip1jm  
         mv(ij, l)=pbarv(ij, l) * zzpbar  
      ENDDO  
      DO ij=1, ip1jmp1  
         mw(ij, l)=w(ij, l) * zzw  
      ENDDO  
   ENDDO  
   
   DO ij=1, ip1jmp1  
      mw(ij, llm+1)=0.  
   ENDDO  
   
   CALL SCOPY(ijp1llm, q, 1, zq, 1)  
   CALL SCOPY(ijp1llm, masse, 1, zm, 1)  
   
   ! call minmaxq(zq, qmin, qmax, 'avant vlxqs ')  
   call vlxqs(zq, pente_max, zm, mu, qsat)  
   
   ! call minmaxq(zq, qmin, qmax, 'avant vlyqs ')  
   
   call vlyqs(zq, pente_max, zm, mv, qsat)  
   
   ! call minmaxq(zq, qmin, qmax, 'avant vlz ')  
   
   call vlz(zq, pente_max, zm, mw)  
   
   ! call minmaxq(zq, qmin, qmax, 'avant vlyqs ')  
   ! call minmaxq(zm, qmin, qmax, 'M avant vlyqs ')  
   
   call vlyqs(zq, pente_max, zm, mv, qsat)  
   
   ! call minmaxq(zq, qmin, qmax, 'avant vlxqs ')  
   ! call minmaxq(zm, qmin, qmax, 'M avant vlxqs ')  
   
   call vlxqs(zq, pente_max, zm, mu, qsat)  
   
   ! call minmaxq(zq, qmin, qmax, 'apres vlxqs ')  
   ! call minmaxq(zm, qmin, qmax, 'M apres vlxqs ')  
   
   DO l=1, llm  
      DO ij=1, ip1jmp1  
         q(ij, l)=zq(ij, l)  
      ENDDO  
      DO ij=1, ip1jm+1, iip1  
         q(ij+iim, l)=q(ij, l)  
      ENDDO  
   ENDDO  
137    
138  END SUBROUTINE vlspltqs  end module vlspltqs_m
Legend:
Removed from v.71  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.21