Context Navigation

addfi_p.F @ 1098

Last change on this file since 1098 was 774, checked in by Laurent Fairhead, 17 years ago
Suite du merge entre la version et la HEAD: quelques modifications de Yann sur le LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 5.5 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE addfi_p(nq, pdt, leapf, forward,
5	S pucov, pvcov, pteta, pq , pps ,
6	S pdufi, pdvfi, pdhfi,pdqfi, pdpfi )
7	USE parallel
8	IMPLICIT NONE
9	c
10	c=======================================================================
11	c
12	c Addition of the physical tendencies
13	c
14	c Interface :
15	c -----------
16	c
17	c Input :
18	c -------
19	c pdt time step of integration
20	c leapf logical
21	c forward logical
22	c pucov(ip1jmp1,llm) first component of the covariant velocity
23	c pvcov(ip1ip1jm,llm) second component of the covariant velocity
24	c pteta(ip1jmp1,llm) potential temperature
25	c pts(ip1jmp1,llm) surface temperature
26	c pdufi(ip1jmp1,llm) \|
27	c pdvfi(ip1jm,llm) \| respective
28	c pdhfi(ip1jmp1) \| tendencies
29	c pdtsfi(ip1jmp1) \|
30	c
31	c Output :
32	c --------
33	c pucov
34	c pvcov
35	c ph
36	c pts
37	c
38	c
39	c=======================================================================
40	c
41	c-----------------------------------------------------------------------
42	c
43	c 0. Declarations :
44	c ------------------
45	c
46	#include "dimensions.h"
47	#include "paramet.h"
48	#include "comconst.h"
49	#include "comgeom.h"
50	#include "serre.h"
51	c
52	c Arguments :
53	c -----------
54	c
55	INTEGER nq
56
57	REAL pdt
58	c
59	REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
60	REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1)
61	c
62	REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
63	REAL pdqfi(ip1jmp1,llm,nq),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	DO iq = 1, 2
158	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
159	DO k = 1,llm
160	DO j = ijb,ije
161	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
162	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
163	ENDDO
164	ENDDO
165	c$OMP END DO NOWAIT
166	ENDDO
167
168	DO iq = 3, nq
169	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
170	DO k = 1,llm
171	DO j = ijb,ije
172	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
173	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
174	ENDDO
175	ENDDO
176	c$OMP END DO NOWAIT
177	ENDDO
178
179	c$OMP MASTER
180	if (pole_nord) then
181
182	DO ij = 1, iim
183	xpn(ij) = aire( ij ) * pps( ij )
184	ENDDO
185
186	tpn = SSUM(iim,xpn,1)/apoln
187
188	DO ij = 1, iip1
189	pps ( ij ) = tpn
190	ENDDO
191
192	endif
193
194	if (pole_sud) then
195
196	DO ij = 1, iim
197	xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
198	ENDDO
199
200	tps = SSUM(iim,xps,1)/apols
201
202	DO ij = 1, iip1
203	pps ( ij+ip1jm ) = tps
204	ENDDO
205
206	endif
207	c$OMP END MASTER
208
209	if (pole_nord) then
210	DO iq = 1, nq
211	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
212	DO k = 1, llm
213	DO ij = 1, iim
214	xpn(ij) = aire( ij ) * pq( ij ,k,iq)
215	ENDDO
216	tpn = SSUM(iim,xpn,1)/apoln
217
218	DO ij = 1, iip1
219	pq ( ij ,k,iq) = tpn
220	ENDDO
221	ENDDO
222	c$OMP END DO NOWAIT
223	ENDDO
224	endif
225
226	if (pole_sud) then
227	DO iq = 1, nq
228	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
229	DO k = 1, llm
230	DO ij = 1, iim
231	xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
232	ENDDO
233	tps = SSUM(iim,xps,1)/apols
234
235	DO ij = 1, iip1
236	pq (ij+ip1jm,k,iq) = tps
237	ENDDO
238	ENDDO
239	c$OMP END DO NOWAIT
240	ENDDO
241	endif
242
243
244	RETURN
245	END

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

Download in other formats:

Original Format