Context Navigation

addfi_p.F @ 1189

Last change on this file since 1189 was 1189, checked in by emillour, 11 years ago

Common dynamics: a couple of bug fixes:

Correctly account for the change in pressure, mass, etc. after modifying surface pressure following a call to the physics.
Corrected tracer advection, which is computed using values at the beginning of the time step, so it is done at Matsuno forward step.

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

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

Download in other formats:

Original Format