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)

    ! 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 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) ! Temperature du sol (surf)(Kelvin)
    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)
    REAL, INTENT (IN):: dtime

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