Context Navigation

lw.F @ 4192

Last change on this file since 4192 was 4183, checked in by dubos, 6 years ago
simple_physics : comcstfi.h => MODULE phys_const.F90
File size: 6.0 KB

Line
1	SUBROUTINE lw(ngrid,nlayer,coefir,emissiv,
2	$ pp,ps_rad,ptsurf,pt,
3	$ pfluxir,pdtlw,
4	$ lwrite)
5	USE phys_const
6	IMPLICIT NONE
7	c=======================================================================
8	c
9	c calcul de l'evolution de la temperature sous l'effet du rayonnement
10	c infra-rouge.
11	c Pour simplifier, les transmissions sont precalculees et ne
12	c dependent que de l'altitude.
13	c
14	c arguments:
15	c ----------
16	c
17	c entree:
18	c -------
19	c ngrid nombres de points de la grille horizontale
20	c nlayer nombre de couches
21	c ptsurf(ngrid) temperature de la surface
22	c pt(ngrid,nlayer) temperature des couches
23	c pp(ngrid,nlayer+1) pression entre les couches
24	c lwrite variable logique pour sorties
25	c
26	c sortie:
27	c -------
28	c pdtlw(ngrid,nlayer) taux de refroidissement
29	c pfluxir(ngrid) flux infrarouge sur le sol
30	c
31	c=======================================================================
32
33	c declarations:
34	c -------------
35
36	c arguments:
37	c ----------
38
39	INTEGER ngrid,nlayer
40	REAL coefir,emissiv(ngrid),ps_rad
41	REAL ptsurf(ngrid),pt(ngrid,nlayer),pp(ngrid,nlayer+1)
42	REAL pdtlw(ngrid,nlayer),pfluxir(ngrid)
43	LOGICAL lwrite
44
45	c variables locales:
46	c ------------------
47
48	INTEGER nlevel,ilev,ig,i,il
49	REAL zplanck(ngrid,nlayer+1),zcoef
50	REAL zfluxup(ngrid,nlayer+1),zfluxdn(ngrid,nlayer+1)
51	REAL zflux(ngrid,nlayer+1)
52	REAL zlwtr1(ngrid),zlwtr2(ngrid)
53	REAL zup(ngrid,nlayer+1),zdup(ngrid)
54	REAL stephan
55
56	LOGICAL lstrong
57	SAVE lstrong,stephan
58	DATA lstrong/.true./
59	!$OMP THREADPRIVATE(lstrong,stephan)
60
61	c-----------------------------------------------------------------------
62	c initialisations:
63	c ----------------
64
65	nlevel=nlayer+1
66	stephan=5.67e-08
67
68	c-----------------------------------------------------------------------
69	c 2. calcul des quantites d'absorbants:
70	c -------------------------------------
71
72	c absorption forte
73	IF(lstrong) THEN
74	DO ilev=1,nlevel
75	DO ig=1,ngrid
76	zup(ig,ilev)=pp(ig,ilev)pp(ig,ilev)/(2.g)
77	ENDDO
78	ENDDO
79	IF(lwrite) THEN
80	DO ilev=1,nlayer
81	PRINT*,' up(',ilev,') = ',zup(ngrid/2+1,ilev)
82	ENDDO
83	ENDIF
84	zcoef=-log(coefir)/sqrt(ps_radps_rad/(2.g))
85
86	c absorption faible
87	ELSE
88	DO ilev=1,nlevel
89	DO ig=1,ngrid
90	zup(ig,ilev)=pp(ig,ilev)
91	ENDDO
92	ENDDO
93	zcoef=-log(coefir)/ps_rad
94	ENDIF
95
96
97	c-----------------------------------------------------------------------
98	c 2. calcul de la fonction de corps noir:
99	c ---------------------------------------
100
101	DO ilev=1,nlayer
102	DO ig=1,ngrid
103	zplanck(ig,ilev)=pt(ig,ilev)*pt(ig,ilev)
104	zplanck(ig,ilev)=stephan*
105	$ zplanck(ig,ilev)*zplanck(ig,ilev)
106	ENDDO
107	ENDDO
108
109	c-----------------------------------------------------------------------
110	c 4. flux descendants:
111	c --------------------
112
113	DO ilev=1,nlayer
114	DO ig=1,ngrid
115	zfluxdn(ig,ilev)=0.
116	ENDDO
117	DO ig=1,ngrid
118	zdup(ig)=zup(ig,ilev)-zup(ig,nlevel)
119	ENDDO
120	CALL lwtr(ngrid,zcoef,lstrong,zdup,zlwtr1)
121
122	DO il=nlayer,ilev,-1
123	zlwtr2(:)=zlwtr1(:)
124	DO ig=1,ngrid
125	zdup(ig)=zup(ig,ilev)-zup(ig,il)
126	ENDDO
127	CALL lwtr(ngrid,zcoef,lstrong,zdup,zlwtr1)
128	DO ig=1,ngrid
129	zfluxdn(ig,ilev)=zfluxdn(ig,ilev)+
130	$ zplanck(ig,il)*(zlwtr1(ig)-zlwtr2(ig))
131	ENDDO
132	ENDDO
133	ENDDO
134
135	DO ig=1,ngrid
136	zfluxdn(ig,nlevel)=0.
137	pfluxir(ig)=emissiv(ig)*zfluxdn(ig,1)
138	ENDDO
139
140	DO ig=1,ngrid
141	zfluxup(ig,1)=ptsurf(ig)*ptsurf(ig)
142	zfluxup(ig,1)=emissiv(ig)stephanzfluxup(ig,1)*zfluxup(ig,1)
143	$ +(1.-emissiv(ig))*zfluxdn(ig,1)
144	ENDDO
145
146	c-----------------------------------------------------------------------
147	c 3. flux montants:
148	c ------------------
149
150	DO ilev=1,nlayer
151	DO ig=1,ngrid
152	zdup(ig)=zup(ig,1)-zup(ig,ilev+1)
153	ENDDO
154	CALL lwtr(ngrid,zcoef,lstrong,zdup,zlwtr1)
155	DO ig=1,ngrid
156	zfluxup(ig,ilev+1)=zfluxup(ig,1)*zlwtr1(ig)
157	ENDDO
158	DO il=1,ilev
159	zlwtr2(:)=zlwtr1(:)
160	DO ig=1,ngrid
161	zdup(ig)=zup(ig,il+1)-zup(ig,ilev+1)
162	ENDDO
163	CALL lwtr(ngrid,zcoef,lstrong,zdup,zlwtr1)
164	DO ig=1,ngrid
165	zfluxup(ig,ilev+1)=zfluxup(ig,ilev+1)+
166	$ zplanck(ig,il)*(zlwtr1(ig)-zlwtr2(ig))
167	ENDDO
168	ENDDO
169
170	ENDDO
171
172	c-----------------------------------------------------------------------
173	c 5. calcul des flux nets:
174	c ------------------------
175
176	DO ilev=1,nlevel
177	DO ig=1,ngrid
178	zflux(ig,ilev)=zfluxup(ig,ilev)-zfluxdn(ig,ilev)
179	ENDDO
180	ENDDO
181
182	c-----------------------------------------------------------------------
183	c 6. Calcul des taux de refroidissement:
184	c --------------------------------------
185
186	DO ilev=1,nlayer
187	DO ig=1,ngrid
188	pdtlw(ig,ilev)=(zflux(ig,ilev+1)-zflux(ig,ilev))*
189	$ g/(cpp*(pp(ig,ilev+1)-pp(ig,ilev)))
190	ENDDO
191	ENDDO
192
193	c-----------------------------------------------------------------------
194	c 10. sorties eventuelles:
195	c ------------------------
196
197	IF (lwrite) THEN
198
199	PRINT*
200	PRINT*,'Diagnostique rayonnement thermique'
201	PRINT*
202	PRINT*,'temperature ',
203	$ 'flux montant flux desc. taux de refroid.'
204	i=ngrid/2+1
205	WRITE(6,9000) ptsurf(i)
206	DO ilev=1,nlayer
207	WRITE(6,'(i4,4e18.4)') ilev,pt(i,ilev),
208	$ zfluxup(i,ilev),zfluxdn(i,ilev),pdtlw(i,ilev)
209	ENDDO
210	WRITE(6,9000) zfluxup(i,nlevel),zfluxdn(i,nlevel)
211
212	ENDIF
213
214	c-----------------------------------------------------------------------
215
216	RETURN
217	9000 FORMAT(4e18.4)
218	END

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format