Context Navigation

addfi_p.F @ 1980

Last change on this file since 1980 was 1422, checked in by milmd, 10 years ago
In GENERIC, MARS and COMMON models replace some include files by modules (usefull for decoupling physics with dynamics).
File size: 6.7 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	USE comconst_mod, ONLY: kappa
11	IMPLICIT NONE
12	c
13	c=======================================================================
14	c
15	c Addition of the physical tendencies
16	c
17	c Interface :
18	c -----------
19	c
20	c Input :
21	c -------
22	c pdt time step of integration
23	c leapf logical
24	c forward logical
25	c pucov(ip1jmp1,llm) first component of the covariant velocity
26	c pvcov(ip1ip1jm,llm) second component of the covariant velocity
27	c pteta(ip1jmp1,llm) potential temperature
28	c pts(ip1jmp1,llm) surface temperature
29	c pdufi(ip1jmp1,llm) \|
30	c pdvfi(ip1jm,llm) \| respective
31	c pdhfi(ip1jmp1) \| tendencies (unit/s)
32	c pdtsfi(ip1jmp1) \|
33	c
34	c Output :
35	c --------
36	c pucov
37	c pvcov
38	c ph
39	c pts
40	c
41	c
42	c=======================================================================
43	c
44	c-----------------------------------------------------------------------
45	c
46	c 0. Declarations :
47	c ------------------
48	c
49	#include "dimensions.h"
50	#include "paramet.h"
51	#include "comgeom.h"
52	c
53	c Arguments :
54	c -----------
55	c
56	REAL,INTENT(IN) :: pdt ! time step for the integration (s)
57	c
58	REAL,INTENT(INOUT) :: pvcov(ip1jm,llm) ! covariant meridional wind
59	REAL,INTENT(INOUT) :: pucov(ip1jmp1,llm) ! covariant zonal wind
60	REAL,INTENT(INOUT) :: pteta(ip1jmp1,llm) ! potential temperature
61	REAL,INTENT(INOUT) :: pq(ip1jmp1,llm,nqtot) ! tracers
62	REAL,INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
63	c respective tendencies (.../s) to add
64	REAL,INTENT(IN) :: pdvfi(ip1jm,llm)
65	REAL,INTENT(IN) :: pdufi(ip1jmp1,llm)
66	REAL,INTENT(IN) :: pdqfi(ip1jmp1,llm,nqtot)
67	REAL,INTENT(IN) :: pdhfi(ip1jmp1,llm)
68	REAL,INTENT(IN) :: pdpfi(ip1jmp1)
69	c
70	LOGICAL,INTENT(IN) :: leapf,forward ! not used
71	c
72	c
73	c Local variables :
74	c -----------------
75	c
76	REAL xpn(iim),xps(iim),tpn,tps
77	INTEGER j,k,iq,ij
78	REAL,PARAMETER :: qtestw = 1.0e-15
79	REAL,PARAMETER :: qtestt = 1.0e-40
80
81	REAL SSUM
82	EXTERNAL SSUM
83
84	INTEGER :: ijb,ije
85	c
86	c-----------------------------------------------------------------------
87
88	ijb=ij_begin
89	ije=ij_end
90
91	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
92	DO k = 1,llm
93	DO j = ijb,ije
94	pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
95	ENDDO
96	ENDDO
97	c$OMP END DO
98
99	if (pole_nord) then
100	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
101	DO k = 1, llm
102	DO ij = 1, iim
103	xpn(ij) = aire( ij ) * pteta( ij ,k)
104	ENDDO
105	tpn = SSUM(iim,xpn,1)/ apoln
106
107	DO ij = 1, iip1
108	pteta( ij ,k) = tpn
109	ENDDO
110	ENDDO
111	c$OMP END DO
112	endif
113
114	if (pole_sud) then
115	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
116	DO k = 1, llm
117	DO ij = 1, iim
118	xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
119	ENDDO
120	tps = SSUM(iim,xps,1)/ apols
121
122	DO ij = 1, iip1
123	pteta(ij+ip1jm,k) = tps
124	ENDDO
125	ENDDO
126	c$OMP END DO
127	endif
128	c
129	!***********************
130	! Correction on teta due to surface pressure changes
131	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
132	DO k = 1,llm
133	DO j = ijb,ije
134	pteta(j,k)= pteta(j,k)(1+pdpfi(j)pdt/pps(j))**kappa
135	ENDDO
136	ENDDO
137	c$OMP END DO
138	!***********************
139
140	ijb=ij_begin
141	ije=ij_end
142	if (pole_nord) ijb=ij_begin+iip1
143	if (pole_sud) ije=ij_end-iip1
144
145	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
146	DO k = 1,llm
147	DO j = ijb,ije
148	pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
149	ENDDO
150	ENDDO
151	c$OMP END DO
152
153	if (pole_nord) ijb=ij_begin
154
155	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
156	DO k = 1,llm
157	DO j = ijb,ije
158	pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
159	ENDDO
160	ENDDO
161	c$OMP END DO
162
163	c
164	if (pole_sud) ije=ij_end
165	c$OMP MASTER
166	DO j = ijb,ije
167	pps(j) = pps(j) + pdpfi(j) * pdt
168	ENDDO
169	c$OMP END MASTER
170
171	if (planet_type=="earth") then
172	! earth case, special treatment for first 2 tracers (water)
173	DO iq = 1, 2
174	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
175	DO k = 1,llm
176	DO j = ijb,ije
177	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
178	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
179	ENDDO
180	ENDDO
181	c$OMP END DO
182	ENDDO
183
184	DO iq = 3, 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
193	ENDDO
194	else
195	! general case, treat all tracers equally)
196	DO iq = 1, nqtot
197	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
198	DO k = 1,llm
199	DO j = ijb,ije
200	pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
201	pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
202	ENDDO
203	ENDDO
204	c$OMP END DO
205	ENDDO
206	endif ! of if (planet_type=="earth")
207
208	c$OMP MASTER
209	if (pole_nord) then
210
211	DO ij = 1, iim
212	xpn(ij) = aire( ij ) * pps( ij )
213	ENDDO
214
215	tpn = SSUM(iim,xpn,1)/apoln
216
217	DO ij = 1, iip1
218	pps ( ij ) = tpn
219	ENDDO
220
221	endif
222
223	if (pole_sud) then
224
225	DO ij = 1, iim
226	xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
227	ENDDO
228
229	tps = SSUM(iim,xps,1)/apols
230
231	DO ij = 1, iip1
232	pps ( ij+ip1jm ) = tps
233	ENDDO
234
235	endif
236	c$OMP END MASTER
237
238	if (pole_nord) then
239	DO iq = 1, nqtot
240	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
241	DO k = 1, llm
242	DO ij = 1, iim
243	xpn(ij) = aire( ij ) * pq( ij ,k,iq)
244	ENDDO
245	tpn = SSUM(iim,xpn,1)/apoln
246
247	DO ij = 1, iip1
248	pq ( ij ,k,iq) = tpn
249	ENDDO
250	ENDDO
251	c$OMP END DO
252	ENDDO
253	endif
254
255	if (pole_sud) then
256	DO iq = 1, nqtot
257	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
258	DO k = 1, llm
259	DO ij = 1, iim
260	xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
261	ENDDO
262	tps = SSUM(iim,xps,1)/apols
263
264	DO ij = 1, iip1
265	pq (ij+ip1jm,k,iq) = tps
266	ENDDO
267	ENDDO
268	c$OMP END DO
269	ENDDO
270	endif
271
272
273	RETURN
274	END

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

Download in other formats:

Original Format