trunk/dyn3d/vlspltqs.f

module vlspltqs_m

  IMPLICIT NONE

contains

  SUBROUTINE vlspltqs(q, pente_max, masse, w, pbaru, pbarv, pdt, p, pk, teta)

    ! From LMDZ4/libf/dyn3d/vlspltqs.F, version 1.2 2005/02/24 12:16:57 fairhead

    ! Authors: P. Le Van, F. Hourdin, F. Forget, F. Codron

    ! Schéma d'advection "pseudo amont"
    ! + test sur humidité spécifique : Q advecté < Qsat aval
    ! (F. Codron, 10/99)

    ! q, pbaru, pbarv, w sont des arguments d'entree pour le sous-programme

    ! pente_max facteur de limitation des pentes: 2 en général
    ! 0 pour un schéma amont
    ! pbaru, pbarv, w flux de masse en u , v , w
    ! pdt pas de temps

    ! teta température potentielle, p pression aux interfaces,
    ! pk exner au milieu des couches nécessaire pour calculer Qsat

    USE dimens_m, ONLY : iim, llm
    use FCTTRE, only: foeew
    USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, llmp1
    USE comconst, ONLY : cpp
    use SUPHEC_M, only: rtt

    ! 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, intent(in):: teta(ip1jmp1, llm)
    real, intent(in):: pk(ip1jmp1, llm)

    ! Local

    INTEGER ij, l

    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 zzpbar, zzw

    !--pour rapport de melange saturant--

    REAL retv, r2es, play
    logical zdelta
    REAL tempe(ip1jmp1)

    !------------------------------------------------------------------

    r2es = 380.11733
    retv = 0.6077667

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

  END SUBROUTINE vlspltqs

end module vlspltqs_m
1	guez	108	module vlspltqs_m
2	guez	3
3	guez	108	IMPLICIT NONE
4	guez	3
5	guez	108	contains
6	guez	3
7	guez	108	SUBROUTINE vlspltqs(q, pente_max, masse, w, pbaru, pbarv, pdt, p, pk, teta)
8	guez	3
9	guez	108	! From LMDZ4/libf/dyn3d/vlspltqs.F, version 1.2 2005/02/24 12:16:57 fairhead
10	guez	3
11	guez	108	! Authors: P. Le Van, F. Hourdin, F. Forget, F. Codron
12	guez	3
13	guez	108	! Schéma d'advection "pseudo amont"
14			! + test sur humidité spécifique : Q advecté < Qsat aval
15			! (F. Codron, 10/99)
16	guez	3
17	guez	108	! q, pbaru, pbarv, w sont des arguments d'entree pour le sous-programme
18	guez	3
19	guez	108	! 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	guez	3
24	guez	108	! teta température potentielle, p pression aux interfaces,
25			! pk exner au milieu des couches nécessaire pour calculer Qsat
26	guez	3
27	guez	108	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	guez	3
33	guez	108	! Arguments:
34	guez	3
35	guez	108	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	guez	3
44	guez	108	! Local
45	guez	3
46	guez	109	INTEGER ij, l
47	guez	3
48	guez	108	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	guez	3
56	guez	108	!--pour rapport de melange saturant--
57	guez	3
58	guez	108	REAL retv, r2es, play
59			logical zdelta
60			REAL tempe(ip1jmp1)
61	guez	3
62	guez	108	!------------------------------------------------------------------
63	guez	3
64	guez	108	r2es = 380.11733
65			retv = 0.6077667
66	guez	3
67	guez	108	!-- 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	guez	3
82	guez	108	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	guez	3
96	guez	108	DO ij=1, ip1jmp1
97			mw(ij, llm+1)=0.
98			ENDDO
99	guez	3
100	guez	108	CALL SCOPY(ijp1llm, q, 1, zq, 1)
101			CALL SCOPY(ijp1llm, masse, 1, zm, 1)
102	guez	3
103	guez	108	! call minmaxq(zq, qmin, qmax, 'avant vlxqs ')
104			call vlxqs(zq, pente_max, zm, mu, qsat)
105	guez	3
106	guez	108	! call minmaxq(zq, qmin, qmax, 'avant vlyqs ')
107	guez	3
108	guez	108	call vlyqs(zq, pente_max, zm, mv, qsat)
109	guez	3
110	guez	108	! call minmaxq(zq, qmin, qmax, 'avant vlz ')
111	guez	44
112	guez	108	call vlz(zq, pente_max, zm, mw)
113	guez	44
114	guez	108	! call minmaxq(zq, qmin, qmax, 'avant vlyqs ')
115			! call minmaxq(zm, qmin, qmax, 'M avant vlyqs ')
116	guez	44
117	guez	108	call vlyqs(zq, pente_max, zm, mv, qsat)
118	guez	44
119	guez	108	! call minmaxq(zq, qmin, qmax, 'avant vlxqs ')
120			! call minmaxq(zm, qmin, qmax, 'M avant vlxqs ')
121	guez	44
122	guez	108	call vlxqs(zq, pente_max, zm, mu, qsat)
123	guez	44
124	guez	108	! call minmaxq(zq, qmin, qmax, 'apres vlxqs ')
125			! call minmaxq(zm, qmin, qmax, 'M apres vlxqs ')
126	guez	44
127	guez	108	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