My Project
 All Classes Files Functions Variables Macros
addfi_p.F
Go to the documentation of this file.
1 !
2 ! $Id: addfi_p.F 1454 2010-11-18 12:01:24Z fairhead $
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
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(ip1jm,llm),pucov(ip1jmp1,llm)
60  REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1)
61 c
62  REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
63  REAL pdqfi(ip1jmp1,llm,nqtot),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  if (planet_type=="earth") then
158  ! earth case, special treatment for first 2 tracers (water)
159  DO iq = 1, 2
160 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
161  DO k = 1,llm
162  DO j = ijb,ije
163  pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
164  pq(j,k,iq)= amax1( pq(j,k,iq), qtestw )
165  ENDDO
166  ENDDO
167 c$OMP END DO NOWAIT
168  ENDDO
169 
170  DO iq = 3, nqtot
171 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
172  DO k = 1,llm
173  DO j = ijb,ije
174  pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
175  pq(j,k,iq)= amax1( pq(j,k,iq), qtestt )
176  ENDDO
177  ENDDO
178 c$OMP END DO NOWAIT
179  ENDDO
180  else
181  ! general case, treat all tracers equally)
182  DO iq = 1, nqtot
183 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
184  DO k = 1,llm
185  DO j = ijb,ije
186  pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
187  pq(j,k,iq)= amax1( pq(j,k,iq), qtestt )
188  ENDDO
189  ENDDO
190 c$OMP END DO NOWAIT
191  ENDDO
192  endif ! of if (planet_type=="earth")
193 
194 c$OMP MASTER
195  if (pole_nord) then
196 
197  DO ij = 1, iim
198  xpn(ij) = aire( ij ) * pps( ij )
199  ENDDO
200 
201  tpn = ssum(iim,xpn,1)/apoln
202 
203  DO ij = 1, iip1
204  pps( ij ) = tpn
205  ENDDO
206 
207  endif
208 
209  if (pole_sud) then
210 
211  DO ij = 1, iim
212  xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
213  ENDDO
214 
215  tps = ssum(iim,xps,1)/apols
216 
217  DO ij = 1, iip1
218  pps( ij+ip1jm ) = tps
219  ENDDO
220 
221  endif
222 c$OMP END MASTER
223 
224  if (pole_nord) then
225  DO iq = 1, nqtot
226 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
227  DO k = 1, llm
228  DO ij = 1, iim
229  xpn(ij) = aire( ij ) * pq( ij ,k,iq)
230  ENDDO
231  tpn = ssum(iim,xpn,1)/apoln
232 
233  DO ij = 1, iip1
234  pq( ij ,k,iq) = tpn
235  ENDDO
236  ENDDO
237 c$OMP END DO NOWAIT
238  ENDDO
239  endif
240 
241  if (pole_sud) then
242  DO iq = 1, nqtot
243 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
244  DO k = 1, llm
245  DO ij = 1, iim
246  xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
247  ENDDO
248  tps = ssum(iim,xps,1)/apols
249 
250  DO ij = 1, iip1
251  pq(ij+ip1jm,k,iq) = tps
252  ENDDO
253  ENDDO
254 c$OMP END DO NOWAIT
255  ENDDO
256  endif
257 
258 
259  RETURN
260  END