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)

    ! 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 indicesol, ONLY: nbsrf
    use initphysto_m, only: initphysto
    USE dimphy, ONLY: klev, klon
    use time_phylmdz, only: itap
    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, intent(in):: pfm_therm(klon, klev+1)
    REAL, intent(in):: pentr_therm(klon, klev)

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

    ! Arguments necessaires pour les sources et puits de traceur 

    REAL, intent(in):: ftsol(:, :) ! (klon, nbsrf) surface temperature (K)
    REAL, intent(in):: pctsrf(klon, nbsrf) ! Pourcentage de sol f(nature du sol)

    ! Coefficients de lessivage: 
    REAL, intent(in):: frac_impa(klon, klev) ! facteur d'impaction
    REAL, intent(in):: frac_nucl(klon, klev) ! facteur de nucleation

    REAL, INTENT(IN):: pphis(klon)
    real, intent(in):: paire(klon)

    ! Local:

    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

    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: 

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

    CALL histwrite(physid, 'phis', itap, gr_phy_write(pphis))
    CALL histwrite(physid, 'aire', itap, 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
             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))
       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))

       CALL histsync(physid)
    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	guez	221	frac_nucl, pphis, paire)
10	guez	3
11	guez	213	! 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			USE indicesol, ONLY: nbsrf
19	guez	155	use initphysto_m, only: initphysto
20	guez	78	USE dimphy, ONLY: klev, klon
21	guez	191	use time_phylmdz, only: itap
22	guez	78	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	201	REAL, intent(in):: pfm_therm(klon, klev+1)
45			REAL, intent(in):: pentr_therm(klon, klev)
46	guez	3
47	guez	78	! Couche limite:
48	guez	201	REAL, intent(in):: pcoefh(klon, klev) ! coeff melange Couche limite
49			REAL, intent(in):: yu1(klon)
50			REAL, intent(in):: yv1(klon)
51	guez	3
52	guez	78	! Arguments necessaires pour les sources et puits de traceur
53	guez	3
54	guez	222	REAL, intent(in):: ftsol(:, :) ! (klon, nbsrf) surface temperature (K)
55	guez	201	REAL, intent(in):: pctsrf(klon, nbsrf) ! Pourcentage de sol f(nature du sol)
56	guez	3
57	guez	201	! Coefficients de lessivage:
58			REAL, intent(in):: frac_impa(klon, klev) ! facteur d'impaction
59			REAL, intent(in):: frac_nucl(klon, klev) ! facteur de nucleation
60	guez	3
61	guez	78	REAL, INTENT(IN):: pphis(klon)
62	guez	201	real, intent(in):: paire(klon)
63	guez	78
64	guez	201	! Local:
65	guez	3
66	guez	32	real t(klon, klev)
67			INTEGER, SAVE:: physid
68	guez	3
69	guez	78	! Les Thermiques
70	guez	3
71	guez	32	REAL fm_therm1(klon, klev)
72			REAL entr_therm(klon, klev)
73			REAL fm_therm(klon, klev)
74	guez	3
75	guez	32	INTEGER i, k
76	guez	3
77	guez	62	REAL, save:: mfu(klon, klev) ! flux de masse dans le panache montant
78	guez	32	REAL mfd(klon, klev) ! flux de masse dans le panache descendant
79			REAL en_u(klon, klev) ! flux entraine dans le panache montant
80			REAL de_u(klon, klev) ! flux detraine dans le panache montant
81			REAL en_d(klon, klev) ! flux entraine dans le panache descendant
82			REAL de_d(klon, klev) ! flux detraine dans le panache descendant
83			REAL coefh(klon, klev) ! flux detraine dans le panache descendant
84	guez	3
85	guez	32	REAL pyu1(klon), pyv1(klon)
86			REAL pftsol(klon, nbsrf), ppsrf(klon, nbsrf)
87			REAL pftsol1(klon), pftsol2(klon), pftsol3(klon), pftsol4(klon)
88			REAL ppsrf1(klon), ppsrf2(klon), ppsrf3(klon), ppsrf4(klon)
89	guez	3
90	guez	32	REAL dtcum
91	guez	3
92	guez	62	INTEGER:: iadvtr = 0, irec = 1
93	guez	3
94	guez	62	SAVE t, mfd, en_u, de_u, en_d, de_d, coefh, dtcum
95	guez	32	SAVE fm_therm, entr_therm
96			SAVE pyu1, pyv1, pftsol, ppsrf
97	guez	3
98	guez	32	!------------------------------------------------------
99	guez	3
100	guez	78	! Couche limite:
101	guez	32
102	guez	221	IF (iadvtr==0) CALL initphysto('phystoke', pdtphys, pdtphys * istphy, &
103			pdtphys * istphy, physid)
104	guez	32
105	guez	191	CALL histwrite(physid, 'phis', itap, gr_phy_write(pphis))
106			CALL histwrite(physid, 'aire', itap, gr_phy_write(paire))
107	guez	32	iadvtr = iadvtr + 1
108
109	guez	62	IF (mod(iadvtr, istphy) == 1 .OR. istphy == 1) THEN
110			PRINT *, 'reinitialisation des champs cumules a iadvtr =', iadvtr
111	guez	32	DO k = 1, klev
112			DO i = 1, klon
113			mfu(i, k) = 0.
114			mfd(i, k) = 0.
115			en_u(i, k) = 0.
116			de_u(i, k) = 0.
117			en_d(i, k) = 0.
118			de_d(i, k) = 0.
119			coefh(i, k) = 0.
120			t(i, k) = 0.
121			fm_therm(i, k) = 0.
122			entr_therm(i, k) = 0.
123			END DO
124			END DO
125			DO i = 1, klon
126			pyv1(i) = 0.
127			pyu1(i) = 0.
128			END DO
129			DO k = 1, nbsrf
130			DO i = 1, klon
131			pftsol(i, k) = 0.
132			ppsrf(i, k) = 0.
133			END DO
134			END DO
135
136			dtcum = 0.
137			END IF
138
139			DO k = 1, klev
140			DO i = 1, klon
141	guez	201	mfu(i, k) = mfu(i, k) + pmfu(i, k) * pdtphys
142			mfd(i, k) = mfd(i, k) + pmfd(i, k) * pdtphys
143			en_u(i, k) = en_u(i, k) + pen_u(i, k) * pdtphys
144			de_u(i, k) = de_u(i, k) + pde_u(i, k) * pdtphys
145			en_d(i, k) = en_d(i, k) + pen_d(i, k) * pdtphys
146			de_d(i, k) = de_d(i, k) + pde_d(i, k) * pdtphys
147			coefh(i, k) = coefh(i, k) + pcoefh(i, k) * pdtphys
148			t(i, k) = t(i, k) + pt(i, k) * pdtphys
149			fm_therm(i, k) = fm_therm(i, k) + pfm_therm(i, k) * pdtphys
150			entr_therm(i, k) = entr_therm(i, k) + pentr_therm(i, k) * pdtphys
151	guez	32	END DO
152			END DO
153			DO i = 1, klon
154	guez	201	pyv1(i) = pyv1(i) + yv1(i) * pdtphys
155			pyu1(i) = pyu1(i) + yu1(i) * pdtphys
156	guez	32	END DO
157			DO k = 1, nbsrf
158			DO i = 1, klon
159	guez	201	pftsol(i, k) = pftsol(i, k) + ftsol(i, k) * pdtphys
160			ppsrf(i, k) = ppsrf(i, k) + pctsrf(i, k) * pdtphys
161	guez	32	END DO
162			END DO
163
164			dtcum = dtcum + pdtphys
165
166	guez	78	IF (mod(iadvtr, istphy) == 0) THEN
167			! normalisation par le temps cumule
168	guez	32	DO k = 1, klev
169			DO i = 1, klon
170			mfu(i, k) = mfu(i, k)/dtcum
171			mfd(i, k) = mfd(i, k)/dtcum
172			en_u(i, k) = en_u(i, k)/dtcum
173			de_u(i, k) = de_u(i, k)/dtcum
174			en_d(i, k) = en_d(i, k)/dtcum
175			de_d(i, k) = de_d(i, k)/dtcum
176			coefh(i, k) = coefh(i, k)/dtcum
177			t(i, k) = t(i, k)/dtcum
178			fm_therm(i, k) = fm_therm(i, k)/dtcum
179			entr_therm(i, k) = entr_therm(i, k)/dtcum
180			END DO
181			END DO
182			DO i = 1, klon
183			pyv1(i) = pyv1(i)/dtcum
184			pyu1(i) = pyu1(i)/dtcum
185			END DO
186			DO k = 1, nbsrf
187			DO i = 1, klon
188			pftsol(i, k) = pftsol(i, k)/dtcum
189			pftsol1(i) = pftsol(i, 1)
190			pftsol2(i) = pftsol(i, 2)
191			pftsol3(i) = pftsol(i, 3)
192			pftsol4(i) = pftsol(i, 4)
193
194			ppsrf(i, k) = ppsrf(i, k)/dtcum
195			ppsrf1(i) = ppsrf(i, 1)
196			ppsrf2(i) = ppsrf(i, 2)
197			ppsrf3(i) = ppsrf(i, 3)
198			ppsrf4(i) = ppsrf(i, 4)
199			END DO
200			END DO
201
202	guez	201	! \'Ecriture des champs
203	guez	32
204			irec = irec + 1
205
206	guez	190	CALL histwrite(physid, 't', itap, gr_phy_write(t))
207			CALL histwrite(physid, 'mfu', itap, gr_phy_write(mfu))
208			CALL histwrite(physid, 'mfd', itap, gr_phy_write(mfd))
209			CALL histwrite(physid, 'en_u', itap, gr_phy_write(en_u))
210			CALL histwrite(physid, 'de_u', itap, gr_phy_write(de_u))
211			CALL histwrite(physid, 'en_d', itap, gr_phy_write(en_d))
212			CALL histwrite(physid, 'de_d', itap, gr_phy_write(de_d))
213			CALL histwrite(physid, 'coefh', itap, gr_phy_write(coefh))
214	guez	32	DO k = 1, klev
215			DO i = 1, klon
216			fm_therm1(i, k) = fm_therm(i, k)
217			END DO
218			END DO
219
220	guez	190	CALL histwrite(physid, 'fm_th', itap, gr_phy_write(fm_therm1))
221			CALL histwrite(physid, 'en_th', itap, gr_phy_write(entr_therm))
222			CALL histwrite(physid, 'frac_impa', itap, gr_phy_write(frac_impa))
223			CALL histwrite(physid, 'frac_nucl', itap, gr_phy_write(frac_nucl))
224			CALL histwrite(physid, 'pyu1', itap, gr_phy_write(pyu1))
225			CALL histwrite(physid, 'pyv1', itap, gr_phy_write(pyv1))
226			CALL histwrite(physid, 'ftsol1', itap, gr_phy_write(pftsol1))
227			CALL histwrite(physid, 'ftsol2', itap, gr_phy_write(pftsol2))
228			CALL histwrite(physid, 'ftsol3', itap, gr_phy_write(pftsol3))
229			CALL histwrite(physid, 'ftsol4', itap, gr_phy_write(pftsol4))
230			CALL histwrite(physid, 'psrf1', itap, gr_phy_write(ppsrf1))
231			CALL histwrite(physid, 'psrf2', itap, gr_phy_write(ppsrf2))
232			CALL histwrite(physid, 'psrf3', itap, gr_phy_write(ppsrf3))
233			CALL histwrite(physid, 'psrf4', itap, gr_phy_write(ppsrf4))
234	guez	32
235	guez	201	CALL histsync(physid)
236	guez	32	END IF
237
238			END SUBROUTINE phystokenc
239
240			end module phystokenc_m