/[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 43 by guez, Fri Apr 8 12:43:31 2011 UTC trunk/dyn3d/vlspltqs.f revision 254 by guez, Mon Feb 5 10:39:38 2018 UTC
# Line 1  Line 1 
1  !  module vlspltqs_m
 ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/vlspltqs.F,v 1.2 2005/02/24 12:16:57 fairhead Exp $  
 !  
        SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt, &  
                                         p,pk,teta                 )  
 !  
 !     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron  
 !  
 !    ********************************************************************  
 !          Shema  d'advection " pseudo amont " .  
 !      + test sur humidite specifique: Q advecte< Qsat aval  
 !                   (F. Codron, 10/99)  
 !    ********************************************************************  
 !     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....  
 !  
 !     pente_max facteur de limitation des pentes: 2 en general  
 !                                                0 pour un schema amont  
 !     pbaru,pbarv,w flux de masse en u ,v ,w  
 !     pdt pas de temps  
 !  
 !     teta temperature potentielle, p pression aux interfaces,  
 !     pk exner au milieu des couches necessaire pour calculer Qsat  
 !   --------------------------------------------------------------------  
       use dimens_m  
       use paramet_m  
       use comconst  
       use comvert  
       use logic  
       IMPLICIT NONE  
 !  
   
 !  
 !   Arguments:  
 !   ----------  
       REAL masse(ip1jmp1,llm),pente_max  
       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 teta(ip1jmp1,llm),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  
2    
3        RETURN    IMPLICIT NONE
4        END  
5    contains
6    
7      SUBROUTINE vlspltqs(q, pente_max, masse, w, pbaru, pbarv, pdt, p, pk, teta)
8    
9        ! From LMDZ4/libf/dyn3d/vlspltqs.F, version 1.2 2005/02/24 12:16:57 fairhead
10    
11        ! Authors: P. Le Van, F. Hourdin, F. Forget, F. Codron
12    
13        ! Schéma d'advection "pseudo amont"
14        ! + test sur humidité spécifique : Q advecté < Qsat aval
15        ! (F. Codron, 10/99)
16    
17        ! q, pbaru, pbarv, w sont des arguments d'entree pour le sous-programme
18    
19        ! 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        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      END SUBROUTINE vlspltqs
137    
138    end module vlspltqs_m
Legend:
Removed from v.43  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.21