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