Sources/phylmd/phystokenc.f

module phystokenc_m

  IMPLICIT NONE

contains

  SUBROUTINE phystokenc(pdtphys, pt, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
       pfm_therm, pentr_therm, pcoefh, yu1, yv1, ftsol, pctsrf, frac_impa, &
       frac_nucl, pphis, paire, dtime, itap)

    ! From phylmd/phystokenc.F, version 1.2 2004/06/22 11:45:35
    ! Author: Fr\'ed\'eric Hourdin
    ! Objet : \'ecriture des variables pour transport offline

    use gr_phy_write_m, only: gr_phy_write
    USE histwrite_m, ONLY: histwrite
    USE histsync_m, ONLY: histsync
    USE dimens_m, ONLY: iim, jjm
    USE indicesol, ONLY: nbsrf
    use initphysto_m, only: initphysto
    USE dimphy, ONLY: klev, klon
    USE tracstoke, ONLY: istphy

    REAL, INTENT (IN):: pdtphys ! pas d'integration pour la physique (seconde)
    REAL, intent(in):: pt(klon, klev)

    ! convection: 

    REAL, INTENT (IN):: pmfu(klon, klev) ! flux de masse dans le panache montant

    REAL, intent(in):: pmfd(klon, klev)
    ! flux de masse dans le panache descendant

    REAL, intent(in):: pen_u(klon, klev) ! flux entraine dans le panache montant
    REAL, intent(in):: pde_u(klon, klev) ! flux detraine dans le panache montant

    REAL, intent(in):: pen_d(klon, klev) 
    ! flux entraine dans le panache descendant

    REAL, intent(in):: pde_d(klon, klev) 
    ! flux detraine dans le panache descendant

    ! Les Thermiques
    REAL pfm_therm(klon, klev+1)
    REAL pentr_therm(klon, klev)

    ! Couche limite: 

    REAL pcoefh(klon, klev) ! coeff melange Couche limite
    REAL yu1(klon)
    REAL yv1(klon)

    ! Arguments necessaires pour les sources et puits de traceur 

    REAL ftsol(klon, nbsrf) ! Temperature du sol (surf)(Kelvin)
    REAL pctsrf(klon, nbsrf) ! Pourcentage de sol f(nature du sol)

    ! Lessivage: 

    REAL frac_impa(klon, klev)
    REAL frac_nucl(klon, klev)

    REAL, INTENT(IN):: pphis(klon)
    real paire(klon)
    REAL, INTENT (IN):: dtime
    INTEGER, INTENT (IN):: itap

    ! Variables local to the procedure:

    real t(klon, klev)
    INTEGER, SAVE:: physid

    ! Les Thermiques

    REAL fm_therm1(klon, klev)
    REAL entr_therm(klon, klev)
    REAL fm_therm(klon, klev)

    INTEGER i, k

    REAL, save:: mfu(klon, klev) ! flux de masse dans le panache montant
    REAL mfd(klon, klev) ! flux de masse dans le panache descendant
    REAL en_u(klon, klev) ! flux entraine dans le panache montant
    REAL de_u(klon, klev) ! flux detraine dans le panache montant
    REAL en_d(klon, klev) ! flux entraine dans le panache descendant
    REAL de_d(klon, klev) ! flux detraine dans le panache descendant
    REAL coefh(klon, klev) ! flux detraine dans le panache descendant

    REAL pyu1(klon), pyv1(klon)
    REAL pftsol(klon, nbsrf), ppsrf(klon, nbsrf)
    REAL pftsol1(klon), pftsol2(klon), pftsol3(klon), pftsol4(klon)
    REAL ppsrf1(klon), ppsrf2(klon), ppsrf3(klon), ppsrf4(klon)

    REAL dtcum

    INTEGER:: iadvtr = 0, irec = 1
    REAL zmin, zmax
    LOGICAL ok_sync

    SAVE t, mfd, en_u, de_u, en_d, de_d, coefh, dtcum
    SAVE fm_therm, entr_therm
    SAVE pyu1, pyv1, pftsol, ppsrf

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

    ! Couche limite: 

    ok_sync = .TRUE.

    IF (iadvtr==0) CALL initphysto('phystoke', dtime, dtime*istphy, dtime*istphy, physid)

    i = itap
    CALL histwrite(physid, 'phis', i, gr_phy_write(pphis))
    i = itap
    CALL histwrite(physid, 'aire', i, gr_phy_write(paire))
    iadvtr = iadvtr + 1

    IF (mod(iadvtr, istphy) == 1 .OR. istphy == 1) THEN
       PRINT *, 'reinitialisation des champs cumules a iadvtr =', iadvtr
       DO k = 1, klev
          DO i = 1, klon
             mfu(i, k) = 0.
             mfd(i, k) = 0.
             en_u(i, k) = 0.
             de_u(i, k) = 0.
             en_d(i, k) = 0.
             de_d(i, k) = 0.
             coefh(i, k) = 0.
             t(i, k) = 0.
             fm_therm(i, k) = 0.
             entr_therm(i, k) = 0.
          END DO
       END DO
       DO i = 1, klon
          pyv1(i) = 0.
          pyu1(i) = 0.
       END DO
       DO k = 1, nbsrf
          DO i = 1, klon
             pftsol(i, k) = 0.
             ppsrf(i, k) = 0.
          END DO
       END DO

       dtcum = 0.
    END IF

    DO k = 1, klev
       DO i = 1, klon
          mfu(i, k) = mfu(i, k) + pmfu(i, k)*pdtphys
          mfd(i, k) = mfd(i, k) + pmfd(i, k)*pdtphys
          en_u(i, k) = en_u(i, k) + pen_u(i, k)*pdtphys
          de_u(i, k) = de_u(i, k) + pde_u(i, k)*pdtphys
          en_d(i, k) = en_d(i, k) + pen_d(i, k)*pdtphys
          de_d(i, k) = de_d(i, k) + pde_d(i, k)*pdtphys
          coefh(i, k) = coefh(i, k) + pcoefh(i, k)*pdtphys
          t(i, k) = t(i, k) + pt(i, k)*pdtphys
          fm_therm(i, k) = fm_therm(i, k) + pfm_therm(i, k)*pdtphys
          entr_therm(i, k) = entr_therm(i, k) + pentr_therm(i, k)*pdtphys
       END DO
    END DO
    DO i = 1, klon
       pyv1(i) = pyv1(i) + yv1(i)*pdtphys
       pyu1(i) = pyu1(i) + yu1(i)*pdtphys
    END DO
    DO k = 1, nbsrf
       DO i = 1, klon
          pftsol(i, k) = pftsol(i, k) + ftsol(i, k)*pdtphys
          ppsrf(i, k) = ppsrf(i, k) + pctsrf(i, k)*pdtphys
       END DO
    END DO

    dtcum = dtcum + pdtphys

    IF (mod(iadvtr, istphy) == 0) THEN
       ! normalisation par le temps cumule 
       DO k = 1, klev
          DO i = 1, klon
             mfu(i, k) = mfu(i, k)/dtcum
             mfd(i, k) = mfd(i, k)/dtcum
             en_u(i, k) = en_u(i, k)/dtcum
             de_u(i, k) = de_u(i, k)/dtcum
             en_d(i, k) = en_d(i, k)/dtcum
             de_d(i, k) = de_d(i, k)/dtcum
             coefh(i, k) = coefh(i, k)/dtcum
             ! Unitel a enlever
             t(i, k) = t(i, k)/dtcum
             fm_therm(i, k) = fm_therm(i, k)/dtcum
             entr_therm(i, k) = entr_therm(i, k)/dtcum
          END DO
       END DO
       DO i = 1, klon
          pyv1(i) = pyv1(i)/dtcum
          pyu1(i) = pyu1(i)/dtcum
       END DO
       DO k = 1, nbsrf
          DO i = 1, klon
             pftsol(i, k) = pftsol(i, k)/dtcum
             pftsol1(i) = pftsol(i, 1)
             pftsol2(i) = pftsol(i, 2)
             pftsol3(i) = pftsol(i, 3)
             pftsol4(i) = pftsol(i, 4)

             ppsrf(i, k) = ppsrf(i, k)/dtcum
             ppsrf1(i) = ppsrf(i, 1)
             ppsrf2(i) = ppsrf(i, 2)
             ppsrf3(i) = ppsrf(i, 3)
             ppsrf4(i) = ppsrf(i, 4)
          END DO
       END DO

       ! ecriture des champs 

       irec = irec + 1

       CALL histwrite(physid, 't', itap, gr_phy_write(t))
       CALL histwrite(physid, 'mfu', itap, gr_phy_write(mfu))
       CALL histwrite(physid, 'mfd', itap, gr_phy_write(mfd))
       CALL histwrite(physid, 'en_u', itap, gr_phy_write(en_u))
       CALL histwrite(physid, 'de_u', itap, gr_phy_write(de_u))
       CALL histwrite(physid, 'en_d', itap, gr_phy_write(en_d))
       CALL histwrite(physid, 'de_d', itap, gr_phy_write(de_d))
       CALL histwrite(physid, 'coefh', itap, gr_phy_write(coefh))
       DO k = 1, klev
          DO i = 1, klon
             fm_therm1(i, k) = fm_therm(i, k)
          END DO
       END DO

       CALL histwrite(physid, 'fm_th', itap, gr_phy_write(fm_therm1))
       CALL histwrite(physid, 'en_th', itap, gr_phy_write(entr_therm))
       !ccc 
       CALL histwrite(physid, 'frac_impa', itap, gr_phy_write(frac_impa))
       CALL histwrite(physid, 'frac_nucl', itap, gr_phy_write(frac_nucl))
       CALL histwrite(physid, 'pyu1', itap, gr_phy_write(pyu1))
       CALL histwrite(physid, 'pyv1', itap, gr_phy_write(pyv1))
       CALL histwrite(physid, 'ftsol1', itap, gr_phy_write(pftsol1))
       CALL histwrite(physid, 'ftsol2', itap, gr_phy_write(pftsol2))
       CALL histwrite(physid, 'ftsol3', itap, gr_phy_write(pftsol3))
       CALL histwrite(physid, 'ftsol4', itap, gr_phy_write(pftsol4))
       CALL histwrite(physid, 'psrf1', itap, gr_phy_write(ppsrf1))
       CALL histwrite(physid, 'psrf2', itap, gr_phy_write(ppsrf2))
       CALL histwrite(physid, 'psrf3', itap, gr_phy_write(ppsrf3))
       CALL histwrite(physid, 'psrf4', itap, gr_phy_write(ppsrf4))
       IF (ok_sync) CALL histsync(physid)

       ! Test sur la valeur des coefficients de lessivage 

       zmin = 1E33
       zmax = -1E33
       DO k = 1, klev
          DO i = 1, klon
             zmax = max(zmax, frac_nucl(i, k))
             zmin = min(zmin, frac_nucl(i, k))
          END DO
       END DO
       PRINT *, 'coefs de lessivage (min et max)'
       PRINT *, 'facteur de nucleation ', zmin, zmax
       zmin = 1E33
       zmax = -1E33
       DO k = 1, klev
          DO i = 1, klon
             zmax = max(zmax, frac_impa(i, k))
             zmin = min(zmin, frac_impa(i, k))
          END DO
       END DO
       PRINT *, 'facteur d impaction ', zmin, zmax
    END IF

  END SUBROUTINE phystokenc

end module phystokenc_m
1	guez	32	module phystokenc_m
2	guez	3
3	guez	32	IMPLICIT NONE
4	guez	3
5	guez	32	contains
6	guez	3
7	guez	190	SUBROUTINE phystokenc(pdtphys, pt, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
8			pfm_therm, pentr_therm, pcoefh, yu1, yv1, ftsol, pctsrf, frac_impa, &
9			frac_nucl, pphis, paire, dtime, itap)
10	guez	3
11	guez	32	! From phylmd/phystokenc.F, version 1.2 2004/06/22 11:45:35
12	guez	155	! Author: Fr\'ed\'eric Hourdin
13			! Objet : \'ecriture des variables pour transport offline
14	guez	3
15	guez	189	use gr_phy_write_m, only: gr_phy_write
16	guez	78	USE histwrite_m, ONLY: histwrite
17			USE histsync_m, ONLY: histsync
18	guez	178	USE dimens_m, ONLY: iim, jjm
19	guez	78	USE indicesol, ONLY: nbsrf
20	guez	155	use initphysto_m, only: initphysto
21	guez	78	USE dimphy, ONLY: klev, klon
22			USE tracstoke, ONLY: istphy
23	guez	3
24	guez	62	REAL, INTENT (IN):: pdtphys ! pas d'integration pour la physique (seconde)
25	guez	78	REAL, intent(in):: pt(klon, klev)
26	guez	3
27	guez	78	! convection:
28	guez	3
29	guez	62	REAL, INTENT (IN):: pmfu(klon, klev) ! flux de masse dans le panache montant
30	guez	72
31			REAL, intent(in):: pmfd(klon, klev)
32			! flux de masse dans le panache descendant
33
34	guez	78	REAL, intent(in):: pen_u(klon, klev) ! flux entraine dans le panache montant
35			REAL, intent(in):: pde_u(klon, klev) ! flux detraine dans le panache montant
36	guez	3
37	guez	78	REAL, intent(in):: pen_d(klon, klev)
38			! flux entraine dans le panache descendant
39	guez	3
40	guez	78	REAL, intent(in):: pde_d(klon, klev)
41			! flux detraine dans le panache descendant
42
43			! Les Thermiques
44	guez	32	REAL pfm_therm(klon, klev+1)
45			REAL pentr_therm(klon, klev)
46	guez	3
47	guez	78	! Couche limite:
48	guez	3
49	guez	78	REAL pcoefh(klon, klev) ! coeff melange Couche limite
50			REAL yu1(klon)
51	guez	32	REAL yv1(klon)
52	guez	3
53	guez	78	! Arguments necessaires pour les sources et puits de traceur
54	guez	3
55	guez	32	REAL ftsol(klon, nbsrf) ! Temperature du sol (surf)(Kelvin)
56			REAL pctsrf(klon, nbsrf) ! Pourcentage de sol f(nature du sol)
57	guez	3
58	guez	78	! Lessivage:
59	guez	3
60	guez	32	REAL frac_impa(klon, klev)
61			REAL frac_nucl(klon, klev)
62	guez	3
63	guez	78	REAL, INTENT(IN):: pphis(klon)
64			real paire(klon)
65			REAL, INTENT (IN):: dtime
66			INTEGER, INTENT (IN):: itap
67
68	guez	32	! Variables local to the procedure:
69	guez	3
70	guez	32	real t(klon, klev)
71			INTEGER, SAVE:: physid
72	guez	3
73	guez	78	! Les Thermiques
74	guez	3
75	guez	32	REAL fm_therm1(klon, klev)
76			REAL entr_therm(klon, klev)
77			REAL fm_therm(klon, klev)
78	guez	3
79	guez	32	INTEGER i, k
80	guez	3
81	guez	62	REAL, save:: mfu(klon, klev) ! flux de masse dans le panache montant
82	guez	32	REAL mfd(klon, klev) ! flux de masse dans le panache descendant
83			REAL en_u(klon, klev) ! flux entraine dans le panache montant
84			REAL de_u(klon, klev) ! flux detraine dans le panache montant
85			REAL en_d(klon, klev) ! flux entraine dans le panache descendant
86			REAL de_d(klon, klev) ! flux detraine dans le panache descendant
87			REAL coefh(klon, klev) ! flux detraine dans le panache descendant
88	guez	3
89	guez	32	REAL pyu1(klon), pyv1(klon)
90			REAL pftsol(klon, nbsrf), ppsrf(klon, nbsrf)
91			REAL pftsol1(klon), pftsol2(klon), pftsol3(klon), pftsol4(klon)
92			REAL ppsrf1(klon), ppsrf2(klon), ppsrf3(klon), ppsrf4(klon)
93	guez	3
94	guez	32	REAL dtcum
95	guez	3
96	guez	62	INTEGER:: iadvtr = 0, irec = 1
97	guez	32	REAL zmin, zmax
98			LOGICAL ok_sync
99	guez	3
100	guez	62	SAVE t, mfd, en_u, de_u, en_d, de_d, coefh, dtcum
101	guez	32	SAVE fm_therm, entr_therm
102			SAVE pyu1, pyv1, pftsol, ppsrf
103	guez	3
104	guez	32	!------------------------------------------------------
105	guez	3
106	guez	78	! Couche limite:
107	guez	32
108			ok_sync = .TRUE.
109
110	guez	190	IF (iadvtr==0) CALL initphysto('phystoke', dtime, dtimeistphy, dtimeistphy, physid)
111	guez	32
112			i = itap
113	guez	190	CALL histwrite(physid, 'phis', i, gr_phy_write(pphis))
114	guez	32	i = itap
115	guez	190	CALL histwrite(physid, 'aire', i, gr_phy_write(paire))
116	guez	32	iadvtr = iadvtr + 1
117
118	guez	62	IF (mod(iadvtr, istphy) == 1 .OR. istphy == 1) THEN
119			PRINT *, 'reinitialisation des champs cumules a iadvtr =', iadvtr
120	guez	32	DO k = 1, klev
121			DO i = 1, klon
122			mfu(i, k) = 0.
123			mfd(i, k) = 0.
124			en_u(i, k) = 0.
125			de_u(i, k) = 0.
126			en_d(i, k) = 0.
127			de_d(i, k) = 0.
128			coefh(i, k) = 0.
129			t(i, k) = 0.
130			fm_therm(i, k) = 0.
131			entr_therm(i, k) = 0.
132			END DO
133			END DO
134			DO i = 1, klon
135			pyv1(i) = 0.
136			pyu1(i) = 0.
137			END DO
138			DO k = 1, nbsrf
139			DO i = 1, klon
140			pftsol(i, k) = 0.
141			ppsrf(i, k) = 0.
142			END DO
143			END DO
144
145			dtcum = 0.
146			END IF
147
148			DO k = 1, klev
149			DO i = 1, klon
150			mfu(i, k) = mfu(i, k) + pmfu(i, k)*pdtphys
151			mfd(i, k) = mfd(i, k) + pmfd(i, k)*pdtphys
152			en_u(i, k) = en_u(i, k) + pen_u(i, k)*pdtphys
153			de_u(i, k) = de_u(i, k) + pde_u(i, k)*pdtphys
154			en_d(i, k) = en_d(i, k) + pen_d(i, k)*pdtphys
155			de_d(i, k) = de_d(i, k) + pde_d(i, k)*pdtphys
156			coefh(i, k) = coefh(i, k) + pcoefh(i, k)*pdtphys
157			t(i, k) = t(i, k) + pt(i, k)*pdtphys
158			fm_therm(i, k) = fm_therm(i, k) + pfm_therm(i, k)*pdtphys
159			entr_therm(i, k) = entr_therm(i, k) + pentr_therm(i, k)*pdtphys
160			END DO
161			END DO
162			DO i = 1, klon
163			pyv1(i) = pyv1(i) + yv1(i)*pdtphys
164			pyu1(i) = pyu1(i) + yu1(i)*pdtphys
165			END DO
166			DO k = 1, nbsrf
167			DO i = 1, klon
168			pftsol(i, k) = pftsol(i, k) + ftsol(i, k)*pdtphys
169			ppsrf(i, k) = ppsrf(i, k) + pctsrf(i, k)*pdtphys
170			END DO
171			END DO
172
173			dtcum = dtcum + pdtphys
174
175	guez	78	IF (mod(iadvtr, istphy) == 0) THEN
176			! normalisation par le temps cumule
177	guez	32	DO k = 1, klev
178			DO i = 1, klon
179			mfu(i, k) = mfu(i, k)/dtcum
180			mfd(i, k) = mfd(i, k)/dtcum
181			en_u(i, k) = en_u(i, k)/dtcum
182			de_u(i, k) = de_u(i, k)/dtcum
183			en_d(i, k) = en_d(i, k)/dtcum
184			de_d(i, k) = de_d(i, k)/dtcum
185			coefh(i, k) = coefh(i, k)/dtcum
186			! Unitel a enlever
187			t(i, k) = t(i, k)/dtcum
188			fm_therm(i, k) = fm_therm(i, k)/dtcum
189			entr_therm(i, k) = entr_therm(i, k)/dtcum
190			END DO
191			END DO
192			DO i = 1, klon
193			pyv1(i) = pyv1(i)/dtcum
194			pyu1(i) = pyu1(i)/dtcum
195			END DO
196			DO k = 1, nbsrf
197			DO i = 1, klon
198			pftsol(i, k) = pftsol(i, k)/dtcum
199			pftsol1(i) = pftsol(i, 1)
200			pftsol2(i) = pftsol(i, 2)
201			pftsol3(i) = pftsol(i, 3)
202			pftsol4(i) = pftsol(i, 4)
203
204			ppsrf(i, k) = ppsrf(i, k)/dtcum
205			ppsrf1(i) = ppsrf(i, 1)
206			ppsrf2(i) = ppsrf(i, 2)
207			ppsrf3(i) = ppsrf(i, 3)
208			ppsrf4(i) = ppsrf(i, 4)
209			END DO
210			END DO
211
212	guez	78	! ecriture des champs
213	guez	32
214			irec = irec + 1
215
216	guez	190	CALL histwrite(physid, 't', itap, gr_phy_write(t))
217			CALL histwrite(physid, 'mfu', itap, gr_phy_write(mfu))
218			CALL histwrite(physid, 'mfd', itap, gr_phy_write(mfd))
219			CALL histwrite(physid, 'en_u', itap, gr_phy_write(en_u))
220			CALL histwrite(physid, 'de_u', itap, gr_phy_write(de_u))
221			CALL histwrite(physid, 'en_d', itap, gr_phy_write(en_d))
222			CALL histwrite(physid, 'de_d', itap, gr_phy_write(de_d))
223			CALL histwrite(physid, 'coefh', itap, gr_phy_write(coefh))
224	guez	32	DO k = 1, klev
225			DO i = 1, klon
226			fm_therm1(i, k) = fm_therm(i, k)
227			END DO
228			END DO
229
230	guez	190	CALL histwrite(physid, 'fm_th', itap, gr_phy_write(fm_therm1))
231			CALL histwrite(physid, 'en_th', itap, gr_phy_write(entr_therm))
232	guez	78	!ccc
233	guez	190	CALL histwrite(physid, 'frac_impa', itap, gr_phy_write(frac_impa))
234			CALL histwrite(physid, 'frac_nucl', itap, gr_phy_write(frac_nucl))
235			CALL histwrite(physid, 'pyu1', itap, gr_phy_write(pyu1))
236			CALL histwrite(physid, 'pyv1', itap, gr_phy_write(pyv1))
237			CALL histwrite(physid, 'ftsol1', itap, gr_phy_write(pftsol1))
238			CALL histwrite(physid, 'ftsol2', itap, gr_phy_write(pftsol2))
239			CALL histwrite(physid, 'ftsol3', itap, gr_phy_write(pftsol3))
240			CALL histwrite(physid, 'ftsol4', itap, gr_phy_write(pftsol4))
241			CALL histwrite(physid, 'psrf1', itap, gr_phy_write(ppsrf1))
242			CALL histwrite(physid, 'psrf2', itap, gr_phy_write(ppsrf2))
243			CALL histwrite(physid, 'psrf3', itap, gr_phy_write(ppsrf3))
244			CALL histwrite(physid, 'psrf4', itap, gr_phy_write(ppsrf4))
245	guez	32	IF (ok_sync) CALL histsync(physid)
246
247	guez	78	! Test sur la valeur des coefficients de lessivage
248	guez	32
249			zmin = 1E33
250			zmax = -1E33
251			DO k = 1, klev
252			DO i = 1, klon
253			zmax = max(zmax, frac_nucl(i, k))
254			zmin = min(zmin, frac_nucl(i, k))
255			END DO
256			END DO
257	guez	62	PRINT *, 'coefs de lessivage (min et max)'
258	guez	32	PRINT *, 'facteur de nucleation ', zmin, zmax
259			zmin = 1E33
260			zmax = -1E33
261			DO k = 1, klev
262			DO i = 1, klon
263			zmax = max(zmax, frac_impa(i, k))
264			zmin = min(zmin, frac_impa(i, k))
265			END DO
266			END DO
267			PRINT *, 'facteur d impaction ', zmin, zmax
268			END IF
269
270			END SUBROUTINE phystokenc
271
272			end module phystokenc_m