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