Context Navigation

addfi_p.F @ 1243

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

Mars GCM and common dynamics:

Common dynamics:

correction in inidissip (only matters in Martian case)
added correction in addfi on theta to account for surface pressure change.

Mars GCM:
Some fixes and updates:

addfi (dyn3d): Add correction on theta when surface pressure changes
vdif_cd (phymars): Correction for coefficients in stable nighttime case
jthermcalc (aeronomars): Fix for some pathological cases (further investigations on the origin of these is needed)

File size: 6.8 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	! Correction on teta due to surface pressure changes
132	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
133	DO k = 1,llm
134	DO j = ijb,ije
135	pteta(j,k)= pteta(j,k)(1+pdpfi(j)pdt/pps(j))**kappa
136	ENDDO
137	ENDDO
138	c$OMP END DO NOWAIT
139	!***********************
140
141	ijb=ij_begin
142	ije=ij_end
143	if (pole_nord) ijb=ij_begin+iip1
144	if (pole_sud) ije=ij_end-iip1
145
146	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
147	DO k = 1,llm
148	DO j = ijb,ije
149	pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
150	ENDDO
151	ENDDO
152	c$OMP END DO NOWAIT
153
154	if (pole_nord) ijb=ij_begin
155
156	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
157	DO k = 1,llm
158	DO j = ijb,ije
159	pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
160	ENDDO
161	ENDDO
162	c$OMP END DO NOWAIT
163
164	c
165	if (pole_sud) ije=ij_end
166	c$OMP MASTER
167	DO j = ijb,ije
168	pps(j) = pps(j) + pdpfi(j) * pdt
169	ENDDO
170	c$OMP END MASTER
171
172	if (planet_type=="earth") then
173	! earth case, special treatment for first 2 tracers (water)
174	DO iq = 1, 2
175	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
176	DO k = 1,llm
177	DO j = ijb,ije
178	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
179	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
180	ENDDO
181	ENDDO
182	c$OMP END DO NOWAIT
183	ENDDO
184
185	DO iq = 3, nqtot
186	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
187	DO k = 1,llm
188	DO j = ijb,ije
189	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
190	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
191	ENDDO
192	ENDDO
193	c$OMP END DO NOWAIT
194	ENDDO
195	else
196	! general case, treat all tracers equally)
197	DO iq = 1, nqtot
198	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
199	DO k = 1,llm
200	DO j = ijb,ije
201	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
202	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
203	ENDDO
204	ENDDO
205	c$OMP END DO NOWAIT
206	ENDDO
207	endif ! of if (planet_type=="earth")
208
209	c$OMP MASTER
210	if (pole_nord) then
211
212	DO ij = 1, iim
213	xpn(ij) = aire( ij ) * pps( ij )
214	ENDDO
215
216	tpn = SSUM(iim,xpn,1)/apoln
217
218	DO ij = 1, iip1
219	pps ( ij ) = tpn
220	ENDDO
221
222	endif
223
224	if (pole_sud) then
225
226	DO ij = 1, iim
227	xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
228	ENDDO
229
230	tps = SSUM(iim,xps,1)/apols
231
232	DO ij = 1, iip1
233	pps ( ij+ip1jm ) = tps
234	ENDDO
235
236	endif
237	c$OMP END MASTER
238
239	if (pole_nord) then
240	DO iq = 1, nqtot
241	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
242	DO k = 1, llm
243	DO ij = 1, iim
244	xpn(ij) = aire( ij ) * pq( ij ,k,iq)
245	ENDDO
246	tpn = SSUM(iim,xpn,1)/apoln
247
248	DO ij = 1, iip1
249	pq ( ij ,k,iq) = tpn
250	ENDDO
251	ENDDO
252	c$OMP END DO NOWAIT
253	ENDDO
254	endif
255
256	if (pole_sud) then
257	DO iq = 1, nqtot
258	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
259	DO k = 1, llm
260	DO ij = 1, iim
261	xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
262	ENDDO
263	tps = SSUM(iim,xps,1)/apols
264
265	DO ij = 1, iip1
266	pq (ij+ip1jm,k,iq) = tps
267	ENDDO
268	ENDDO
269	c$OMP END DO NOWAIT
270	ENDDO
271	endif
272
273
274	RETURN
275	END

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

Download in other formats:

Original Format