trunk/dyn3d/vlspltqs.f

!
! $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

      RETURN
      END
1	guez	3	!
2			! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/vlspltqs.F,v 1.2 2005/02/24 12:16:57 fairhead Exp $
3			!
4	guez	43	SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt, &
5			p,pk,teta )
6			!
7			! Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron
8			!
9			! ********************************************************************
10			! Shema d'advection " pseudo amont " .
11			! + test sur humidite specifique: Q advecte< Qsat aval
12			! (F. Codron, 10/99)
13			! ********************************************************************
14			! q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg ....
15			!
16			! pente_max facteur de limitation des pentes: 2 en general
17			! 0 pour un schema amont
18			! pbaru,pbarv,w flux de masse en u ,v ,w
19			! pdt pas de temps
20			!
21			! teta temperature potentielle, p pression aux interfaces,
22			! pk exner au milieu des couches necessaire pour calculer Qsat
23			! --------------------------------------------------------------------
24	guez	3	use dimens_m
25			use paramet_m
26			use comconst
27			use comvert
28			use logic
29			IMPLICIT NONE
30	guez	43	!
31	guez	3
32	guez	43	!
33			! Arguments:
34			! ----------
35	guez	3	REAL masse(ip1jmp1,llm),pente_max
36	guez	31	REAL, intent(in):: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
37	guez	3	REAL q(ip1jmp1,llm)
38	guez	28	REAL w(ip1jmp1,llm)
39			real, intent(in):: pdt
40	guez	10	REAL, intent(in):: p(ip1jmp1,llmp1)
41			real teta(ip1jmp1,llm),pk(ip1jmp1,llm)
42	guez	43	!
43			! Local
44			! ---------
45			!
46	guez	3	INTEGER i,ij,l,j,ii
47	guez	43	!
48	guez	3	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 temps1,temps2,temps3
55			REAL zzpbar, zzw
56			LOGICAL testcpu
57			SAVE testcpu
58			SAVE temps1,temps2,temps3
59
60			REAL qmin,qmax
61			DATA qmin,qmax/0.,1.e33/
62			DATA testcpu/.false./
63			DATA temps1,temps2,temps3/0.,0.,0./
64
65	guez	43	!--pour rapport de melange saturant--
66	guez	3
67			REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
68			REAL ptarg,pdelarg,foeew,zdelta
69			REAL tempe(ip1jmp1)
70
71	guez	43	! fonction psat(T)
72	guez	3
73	guez	43	FOEEW ( PTARG,PDELARG ) = EXP ( &
74			(R3LES(1.-PDELARG)+R3IESPDELARG) * (PTARG-RTT) &
75			/ (PTARG-(R4LES(1.-PDELARG)+R4IESPDELARG)) )
76	guez	3
77	guez	43	r2es = 380.11733
78	guez	3	r3les = 17.269
79			r3ies = 21.875
80			r4les = 35.86
81			r4ies = 7.66
82			retv = 0.6077667
83			rtt = 273.16
84
85	guez	43	!-- Calcul de Qsat en chaque point
86			!-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
87			! pour eviter une exponentielle.
88	guez	3	DO l = 1, llm
89			DO ij = 1, ip1jmp1
90			tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
91			ENDDO
92			DO ij = 1, ip1jmp1
93			zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
94			play = 0.5*(p(ij,l)+p(ij,l+1))
95			qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
96			qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
97			ENDDO
98			ENDDO
99
100			zzpbar = 0.5 * pdt
101			zzw = pdt
102			DO l=1,llm
103			DO ij = iip2,ip1jm
104			mu(ij,l)=pbaru(ij,l) * zzpbar
105			ENDDO
106			DO ij=1,ip1jm
107			mv(ij,l)=pbarv(ij,l) * zzpbar
108			ENDDO
109			DO ij=1,ip1jmp1
110			mw(ij,l)=w(ij,l) * zzw
111			ENDDO
112			ENDDO
113
114			DO ij=1,ip1jmp1
115			mw(ij,llm+1)=0.
116			ENDDO
117
118			CALL SCOPY(ijp1llm,q,1,zq,1)
119			CALL SCOPY(ijp1llm,masse,1,zm,1)
120
121	guez	43	! call minmaxq(zq,qmin,qmax,'avant vlxqs ')
122	guez	3	call vlxqs(zq,pente_max,zm,mu,qsat)
123
124
125	guez	43	! call minmaxq(zq,qmin,qmax,'avant vlyqs ')
126	guez	3
127			call vlyqs(zq,pente_max,zm,mv,qsat)
128
129
130	guez	43	! call minmaxq(zq,qmin,qmax,'avant vlz ')
131	guez	3
132			call vlz(zq,pente_max,zm,mw)
133
134
135	guez	43	! call minmaxq(zq,qmin,qmax,'avant vlyqs ')
136			! call minmaxq(zm,qmin,qmax,'M avant vlyqs ')
137	guez	3
138			call vlyqs(zq,pente_max,zm,mv,qsat)
139
140
141	guez	43	! call minmaxq(zq,qmin,qmax,'avant vlxqs ')
142			! call minmaxq(zm,qmin,qmax,'M avant vlxqs ')
143	guez	3
144			call vlxqs(zq,pente_max,zm,mu,qsat)
145
146	guez	43	! call minmaxq(zq,qmin,qmax,'apres vlxqs ')
147			! call minmaxq(zm,qmin,qmax,'M apres vlxqs ')
148	guez	3
149
150			DO l=1,llm
151			DO ij=1,ip1jmp1
152			q(ij,l)=zq(ij,l)
153			ENDDO
154			DO ij=1,ip1jm+1,iip1
155			q(ij+iim,l)=q(ij,l)
156			ENDDO
157			ENDDO
158
159			RETURN
160			END