My Project
 All Classes Files Functions Variables Macros
advect_new_loc.F
Go to the documentation of this file.
1 !
2 ! $Header$
3 !
4  SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby,
5  & du,dv,dteta)
6  USE parallel
7  USE write_field_loc
8  USE advect_new_mod
9  IMPLICIT NONE
10 c=======================================================================
11 c
12 c Auteurs: P. Le Van , Fr. Hourdin .
13 c -------
14 c
15 c Objet:
16 c ------
17 c
18 c *************************************************************
19 c .... calcul des termes d'advection vertic.pour u,v,teta,q ...
20 c *************************************************************
21 c ces termes sont ajoutes a du,dv,dteta et dq .
22 c Modif F.Forget 03/94 : on retire q de advect
23 c
24 c=======================================================================
25 c-----------------------------------------------------------------------
26 c Declarations:
27 c -------------
28 
29 #include "dimensions.h"
30 #include "paramet.h"
31 #include "comconst.h"
32 #include "comvert.h"
33 #include "comgeom.h"
34 #include "logic.h"
35 #include "ener.h"
36 
37 c Arguments:
38 c ----------
39 
40  REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
41  REAL teta(ijb_u:ije_u,llm)
42  REAL massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
43  REAL w(ijb_u:ije_u,llm)
44  REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
45  REAL dteta(ijb_u:ije_u,llm)
46 c Local:
47 c ------
48 
49  REAL wsur2(ijb_u:ije_u)
50  REAL unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u)
51  REAL deuxjour, ww, gt, uu, vv
52 
53  INTEGER ij,l,ijb,ije
54  EXTERNAL ssum
55  REAL ssum
56 
57 
58 
59 c-----------------------------------------------------------------------
60 c 2. Calculs preliminaires:
61 c -------------------------
62 
63  IF (conser) THEN
64  deuxjour = 2. * daysec
65 
66  DO 1 ij = 1, ip1jmp1
67  unsaire2(ij) = unsaire(ij) * unsaire(ij)
68  1 CONTINUE
69  END IF
70 
71 
72 c------------------ -yy ----------------------------------------------
73 c . Calcul de u
74 
75 c$OMP MASTER
76  ijb=ij_begin
77  ije=ij_end
78  if (pole_nord) ijb=ijb+iip1
79  if (pole_sud) ije=ije-iip1
80 
81  DO ij=ijb,ije
82  du2(ij,1)=0.
83  du1(ij,llm)=0.
84  ENDDO
85 
86  ijb=ij_begin
87  ije=ij_end
88  if (pole_sud) ije=ij_end-iip1
89 
90  DO ij=ijb,ije
91  dv2(ij,1)=0.
92  dv1(ij,llm)=0.
93  ENDDO
94 
95  ijb=ij_begin
96  ije=ij_end
97 
98  DO ij=ijb,ije
99  dteta2(ij,1)=0.
100  dteta1(ij,llm)=0.
101  ENDDO
102 c$OMP END MASTER
103 c$OMP BARRIER
104 
105 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
106  DO l=1,llm
107 
108  ijb=ij_begin
109  ije=ij_end
110  if (pole_nord) ijb=ijb+iip1
111  if (pole_sud) ije=ije-iip1
112 
113 c DO ij = iip2, ip1jmp1
114 c uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
115 c ENDDO
116 
117 c DO ij = iip2, ip1jm
118 c uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
119 c ENDDO
120 
121  DO ij = ijb, ije
122 
123  uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
124  . +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
125  ENDDO
126 
127  if (pole_nord) then
128  DO ij = 1, iip1
129  uav(ij ,l) = 0.
130  ENDDO
131  endif
132 
133  if (pole_sud) then
134  DO ij = 1, iip1
135  uav(ip1jm+ij,l) = 0.
136  ENDDO
137  endif
138 
139  ENDDO
140 c$OMP END DO
141 c call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
142 
143 c------------------ -xx ----------------------------------------------
144 c . Calcul de v
145 
146  ijb=ij_begin
147  ije=ij_end
148  if (pole_sud) ije=ij_end-iip1
149 
150 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
151  DO l=1,llm
152 
153  DO ij = ijb+1, ije
154  vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
155  ENDDO
156 
157  DO ij = ijb,ije,iip1
158  vav(ij,l) = vav(ij+iim,l)
159  ENDDO
160 
161 
162  DO ij = ijb, ije-1
163  vav(ij,l) = vav(ij,l) + vav(ij+1,l)
164  ENDDO
165 
166  DO ij = ijb, ije, iip1
167  vav(ij+iim,l) = vav(ij,l)
168  ENDDO
169 
170  ENDDO
171 c$OMP END DO
172 c call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
173 
174 c-----------------------------------------------------------------------
175 c$OMP BARRIER
176 
177 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
178  DO 20 l = 1, llmm1
179 
180 
181 c ...... calcul de - w/2. au niveau l+1 .......
182  ijb=ij_begin
183  ije=ij_end+iip1
184  if (pole_sud) ije=ij_end
185 
186  DO 5 ij = ijb, ije
187  wsur2( ij ) = - 0.5 * w( ij,l+1 )
188  5 CONTINUE
189 
190 
191 c ..................... calcul pour du ..................
192 
193  ijb=ij_begin
194  ije=ij_end
195  if (pole_nord) ijb=ijb+iip1
196  if (pole_sud) ije=ije-iip1
197 
198  DO 6 ij = ijb ,ije-1
199  ww = wsur2( ij ) + wsur2( ij+1 )
200  uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
201  du1(ij,l) = ww * ( uu - uav(ij, l ) )/massebx(ij, l )
202  du2(ij,l+1)= ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
203  6 CONTINUE
204 
205 c ................. calcul pour dv .....................
206  ijb=ij_begin
207  ije=ij_end
208  if (pole_sud) ije=ij_end-iip1
209 
210  DO 8 ij = ijb, ije
211  ww = wsur2( ij+iip1 ) + wsur2( ij )
212  vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
213  dv1(ij,l) = ww * (vv - vav(ij, l ) )/masseby(ij, l )
214  dv2(ij,l+1)= ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
215  8 CONTINUE
216 
217 c
218 
219 c ............................................................
220 c ............... calcul pour dh ...................
221 c ............................................................
222 
223 c ---z
224 c calcul de - d( teta * w ) qu'on ajoute a dh
225 c ...............
226  ijb=ij_begin
227  ije=ij_end
228 
229  DO 15 ij = ijb, ije
230  ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
231  dteta1(ij, l ) = ww
232  dteta2(ij,l+1) = ww
233  15 CONTINUE
234 
235 c ym ---> conser a voir plus tard
236 
237 c IF( conser) THEN
238 c
239 c DO 17 ij = 1,ip1jmp1
240 c ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij)
241 c 17 CONTINUE
242 c gt = SSUM( ip1jmp1,ge,1 )
243 c gtot(l) = deuxjour * SQRT( gt/ip1jmp1 )
244 c END IF
245 
246  20 CONTINUE
247 c$OMP END DO
248 
249  ijb=ij_begin
250  ije=ij_end
251  if (pole_nord) ijb=ijb+iip1
252  if (pole_sud) ije=ije-iip1
253 #ifdef DEBUG_IO
254  CALL writefield_u('du_bis',du)
255 #endif
256 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
257  DO l=1,llm
258  DO ij=ijb,ije-1
259  du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
260  ENDDO
261 
262  DO ij = ijb+iip1-1, ije, iip1
263  du( ij, l ) = du( ij -iim, l )
264  ENDDO
265  ENDDO
266 c$OMP END DO NOWAIT
267 #ifdef DEBUG_IO
268  CALL writefield_u('du1',du1)
269  CALL writefield_u('du2',du2)
270  CALL writefield_u('du_bis',du)
271 #endif
272  ijb=ij_begin
273  ije=ij_end
274  if (pole_sud) ije=ij_end-iip1
275 
276 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
277  DO l=1,llm
278  DO ij=ijb,ije
279  dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
280  ENDDO
281  ENDDO
282 c$OMP END DO NOWAIT
283  ijb=ij_begin
284  ije=ij_end
285 
286 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
287  DO l=1,llm
288  DO ij=ijb,ije
289  dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
290  ENDDO
291  ENDDO
292 c$OMP END DO NOWAIT
293 
294  RETURN
295  END