Context Navigation

addfi_loc.F @ 5440

Last change on this file since 5440 was 1823, checked in by Ehouarn Millour, 11 years ago
Remplacement de parallel.F90 (en conflit avec orchidée) par parallel_lmdz.F90. UG ......................................... Renaming parallel.F90 (conflicting with orchidée) into parallel_lmdz.F90. UG
File size: 6.1 KB

Line
1	!
2	! $Id$
3	!
4	SUBROUTINE addfi_loc(pdt, leapf, forward,
5	S pucov, pvcov, pteta, pq , pps ,
6	S pdufi, pdvfi, pdhfi,pdqfi, pdpfi )
7	USE parallel_lmdz
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(ijb_v:ije_v,llm),pucov(ijb_u:ije_u,llm)
60	REAL pteta(ijb_u:ije_u,llm),pq(ijb_u:ije_u,llm,nqtot)
61	REAL pps(ijb_u:ije_u)
62	c
63	REAL pdvfi(ijb_v:ije_v,llm),pdufi(ijb_u:ije_u,llm)
64	REAL pdqfi(ijb_u:ije_u,llm,nqtot),pdhfi(ijb_u:ije_u,llm)
65	REAL pdpfi(ijb_u:ije_u)
66	c
67	LOGICAL leapf,forward
68	c
69	c
70	c Local variables :
71	c -----------------
72	c
73	REAL xpn(iim),xps(iim),tpn,tps
74	INTEGER j,k,iq,ij
75	REAL qtestw, qtestt
76	PARAMETER ( qtestw = 1.0e-15 )
77	PARAMETER ( qtestt = 1.0e-40 )
78
79	REAL SSUM
80	EXTERNAL SSUM
81
82	INTEGER :: ijb,ije
83	c
84	c-----------------------------------------------------------------------
85
86	ijb=ij_begin
87	ije=ij_end
88
89	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
90	DO k = 1,llm
91	DO j = ijb,ije
92	pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
93	ENDDO
94	ENDDO
95	c$OMP END DO NOWAIT
96
97	if (pole_nord) then
98	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
99	DO k = 1, llm
100	DO ij = 1, iim
101	xpn(ij) = aire( ij ) * pteta( ij ,k)
102	ENDDO
103	tpn = SSUM(iim,xpn,1)/ apoln
104
105	DO ij = 1, iip1
106	pteta( ij ,k) = tpn
107	ENDDO
108	ENDDO
109	c$OMP END DO NOWAIT
110	endif
111
112	if (pole_sud) then
113	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
114	DO k = 1, llm
115	DO ij = 1, iim
116	xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
117	ENDDO
118	tps = SSUM(iim,xps,1)/ apols
119
120	DO ij = 1, iip1
121	pteta(ij+ip1jm,k) = tps
122	ENDDO
123	ENDDO
124	c$OMP END DO NOWAIT
125	endif
126	c
127
128	ijb=ij_begin
129	ije=ij_end
130	if (pole_nord) ijb=ij_begin+iip1
131	if (pole_sud) ije=ij_end-iip1
132
133	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
134	DO k = 1,llm
135	DO j = ijb,ije
136	pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
137	ENDDO
138	ENDDO
139	c$OMP END DO NOWAIT
140
141	if (pole_nord) ijb=ij_begin
142
143	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
144	DO k = 1,llm
145	DO j = ijb,ije
146	pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
147	ENDDO
148	ENDDO
149	c$OMP END DO NOWAIT
150
151	c
152	if (pole_sud) ije=ij_end
153	c$OMP MASTER
154	DO j = ijb,ije
155	pps(j) = pps(j) + pdpfi(j) * pdt
156	ENDDO
157	c$OMP END MASTER
158
159	if (planet_type=="earth") then
160	! earth case, special treatment for first 2 tracers (water)
161	DO iq = 1, 2
162	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
163	DO k = 1,llm
164	DO j = ijb,ije
165	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
166	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
167	ENDDO
168	ENDDO
169	c$OMP END DO NOWAIT
170	ENDDO
171
172	DO iq = 3, nqtot
173	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
174	DO k = 1,llm
175	DO j = ijb,ije
176	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
177	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
178	ENDDO
179	ENDDO
180	c$OMP END DO NOWAIT
181	ENDDO
182	else
183	! general case, treat all tracers equally)
184	DO iq = 1, nqtot
185	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
186	DO k = 1,llm
187	DO j = ijb,ije
188	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
189	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
190	ENDDO
191	ENDDO
192	c$OMP END DO NOWAIT
193	ENDDO
194	endif ! of if (planet_type=="earth")
195
196	c$OMP MASTER
197	if (pole_nord) then
198
199	DO ij = 1, iim
200	xpn(ij) = aire( ij ) * pps( ij )
201	ENDDO
202
203	tpn = SSUM(iim,xpn,1)/apoln
204
205	DO ij = 1, iip1
206	pps ( ij ) = tpn
207	ENDDO
208
209	endif
210
211	if (pole_sud) then
212
213	DO ij = 1, iim
214	xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
215	ENDDO
216
217	tps = SSUM(iim,xps,1)/apols
218
219	DO ij = 1, iip1
220	pps ( ij+ip1jm ) = tps
221	ENDDO
222
223	endif
224	c$OMP END MASTER
225
226	if (pole_nord) then
227	DO iq = 1, nqtot
228	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
229	DO k = 1, llm
230	DO ij = 1, iim
231	xpn(ij) = aire( ij ) * pq( ij ,k,iq)
232	ENDDO
233	tpn = SSUM(iim,xpn,1)/apoln
234
235	DO ij = 1, iip1
236	pq ( ij ,k,iq) = tpn
237	ENDDO
238	ENDDO
239	c$OMP END DO NOWAIT
240	ENDDO
241	endif
242
243	if (pole_sud) then
244	DO iq = 1, nqtot
245	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
246	DO k = 1, llm
247	DO ij = 1, iim
248	xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
249	ENDDO
250	tps = SSUM(iim,xps,1)/apols
251
252	DO ij = 1, iip1
253	pq (ij+ip1jm,k,iq) = tps
254	ENDDO
255	ENDDO
256	c$OMP END DO NOWAIT
257	ENDDO
258	endif
259
260
261	RETURN
262	END

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

Download in other formats:

Original Format