Context Navigation

addfi_p.F @ 7

Last change on this file since 7 was 7, checked in by emillour, 14 years ago
Mise a niveau de la dynamique par rapport a la version 1447 de LMDZ5 Voir les details dans chantiers/commit_v7.log
File size: 6.1 KB

Line
1	!
2	! $Id: addfi_p.F 1446 2010-10-22 09:27:25Z emillour $
3	!
4	SUBROUTINE addfi_p(pdt, leapf, forward,
5	S pucov, pvcov, pteta, pq , pps ,
6	S pdufi, pdvfi, pdhfi,pdqfi, pdpfi )
7	USE parallel
8	USE infotrac, ONLY : nqtot
9	USE control_mod, ONLY : planet_type
10	IMPLICIT NONE
11	c
12	c=======================================================================
13	c
14	c Addition of the physical tendencies
15	c
16	c Interface :
17	c -----------
18	c
19	c Input :
20	c -------
21	c pdt time step of integration
22	c leapf logical
23	c forward logical
24	c pucov(ip1jmp1,llm) first component of the covariant velocity
25	c pvcov(ip1ip1jm,llm) second component of the covariant velocity
26	c pteta(ip1jmp1,llm) potential temperature
27	c pts(ip1jmp1,llm) surface temperature
28	c pdufi(ip1jmp1,llm) \|
29	c pdvfi(ip1jm,llm) \| respective
30	c pdhfi(ip1jmp1) \| tendencies
31	c pdtsfi(ip1jmp1) \|
32	c
33	c Output :
34	c --------
35	c pucov
36	c pvcov
37	c ph
38	c pts
39	c
40	c
41	c=======================================================================
42	c
43	c-----------------------------------------------------------------------
44	c
45	c 0. Declarations :
46	c ------------------
47	c
48	#include "dimensions.h"
49	#include "paramet.h"
50	#include "comconst.h"
51	#include "comgeom.h"
52	#include "serre.h"
53	c
54	c Arguments :
55	c -----------
56	c
57	REAL pdt
58	c
59	REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
60	REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1)
61	c
62	REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
63	REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
64	c
65	LOGICAL leapf,forward
66	c
67	c
68	c Local variables :
69	c -----------------
70	c
71	REAL xpn(iim),xps(iim),tpn,tps
72	INTEGER j,k,iq,ij
73	REAL qtestw, qtestt
74	PARAMETER ( qtestw = 1.0e-15 )
75	PARAMETER ( qtestt = 1.0e-40 )
76
77	REAL SSUM
78	EXTERNAL SSUM
79
80	INTEGER :: ijb,ije
81	c
82	c-----------------------------------------------------------------------
83
84	ijb=ij_begin
85	ije=ij_end
86
87	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
88	DO k = 1,llm
89	DO j = ijb,ije
90	pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
91	ENDDO
92	ENDDO
93	c$OMP END DO NOWAIT
94
95	if (pole_nord) then
96	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
97	DO k = 1, llm
98	DO ij = 1, iim
99	xpn(ij) = aire( ij ) * pteta( ij ,k)
100	ENDDO
101	tpn = SSUM(iim,xpn,1)/ apoln
102
103	DO ij = 1, iip1
104	pteta( ij ,k) = tpn
105	ENDDO
106	ENDDO
107	c$OMP END DO NOWAIT
108	endif
109
110	if (pole_sud) then
111	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
112	DO k = 1, llm
113	DO ij = 1, iim
114	xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
115	ENDDO
116	tps = SSUM(iim,xps,1)/ apols
117
118	DO ij = 1, iip1
119	pteta(ij+ip1jm,k) = tps
120	ENDDO
121	ENDDO
122	c$OMP END DO NOWAIT
123	endif
124	c
125
126	ijb=ij_begin
127	ije=ij_end
128	if (pole_nord) ijb=ij_begin+iip1
129	if (pole_sud) ije=ij_end-iip1
130
131	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
132	DO k = 1,llm
133	DO j = ijb,ije
134	pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
135	ENDDO
136	ENDDO
137	c$OMP END DO NOWAIT
138
139	if (pole_nord) ijb=ij_begin
140
141	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
142	DO k = 1,llm
143	DO j = ijb,ije
144	pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
145	ENDDO
146	ENDDO
147	c$OMP END DO NOWAIT
148
149	c
150	if (pole_sud) ije=ij_end
151	c$OMP MASTER
152	DO j = ijb,ije
153	pps(j) = pps(j) + pdpfi(j) * pdt
154	ENDDO
155	c$OMP END MASTER
156
157	if (planet_type=="earth") then
158	! earth case, special treatment for first 2 tracers (water)
159	DO iq = 1, 2
160	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
161	DO k = 1,llm
162	DO j = ijb,ije
163	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
164	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
165	ENDDO
166	ENDDO
167	c$OMP END DO NOWAIT
168	ENDDO
169
170	DO iq = 3, nqtot
171	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
172	DO k = 1,llm
173	DO j = ijb,ije
174	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
175	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
176	ENDDO
177	ENDDO
178	c$OMP END DO NOWAIT
179	ENDDO
180	else
181	! general case, treat all tracers equally)
182	DO iq = 1, nqtot
183	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
184	DO k = 1,llm
185	DO j = ijb,ije
186	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
187	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
188	ENDDO
189	ENDDO
190	c$OMP END DO NOWAIT
191	ENDDO
192	endif ! of if (planet_type=="earth")
193
194	c$OMP MASTER
195	if (pole_nord) then
196
197	DO ij = 1, iim
198	xpn(ij) = aire( ij ) * pps( ij )
199	ENDDO
200
201	tpn = SSUM(iim,xpn,1)/apoln
202
203	DO ij = 1, iip1
204	pps ( ij ) = tpn
205	ENDDO
206
207	endif
208
209	if (pole_sud) then
210
211	DO ij = 1, iim
212	xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
213	ENDDO
214
215	tps = SSUM(iim,xps,1)/apols
216
217	DO ij = 1, iip1
218	pps ( ij+ip1jm ) = tps
219	ENDDO
220
221	endif
222	c$OMP END MASTER
223
224	if (pole_nord) then
225	DO iq = 1, nqtot
226	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
227	DO k = 1, llm
228	DO ij = 1, iim
229	xpn(ij) = aire( ij ) * pq( ij ,k,iq)
230	ENDDO
231	tpn = SSUM(iim,xpn,1)/apoln
232
233	DO ij = 1, iip1
234	pq ( ij ,k,iq) = tpn
235	ENDDO
236	ENDDO
237	c$OMP END DO NOWAIT
238	ENDDO
239	endif
240
241	if (pole_sud) then
242	DO iq = 1, nqtot
243	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
244	DO k = 1, llm
245	DO ij = 1, iim
246	xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
247	ENDDO
248	tps = SSUM(iim,xps,1)/apols
249
250	DO ij = 1, iip1
251	pq (ij+ip1jm,k,iq) = tps
252	ENDDO
253	ENDDO
254	c$OMP END DO NOWAIT
255	ENDDO
256	endif
257
258
259	RETURN
260	END

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

Download in other formats:

Original Format