144
145
149
151# ifdef SOLVE3D
153# endif
154# ifdef DISTRIBUTE
156# ifdef SOLVE3D
158# endif
159# endif
160
161
162
163 integer, intent(in) :: ng, tile
164 integer, intent(in) :: LBi, UBi, LBj, UBj
165 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
166# ifdef SOLVE3D
167 integer, intent(in) :: kout, nout
168# else
169 integer, intent(in) :: kout
170# endif
171
172# ifdef ASSUMED_SHAPE
173# ifdef MASKING
174 real(r8), intent(in) :: pmask(LBi:,LBj:)
175 real(r8), intent(in) :: umask(LBi:,LBj:)
176 real(r8), intent(in) :: vmask(LBi:,LBj:)
177# endif
178 real(r8), intent(in) :: f(LBi:,LBj:)
179 real(r8), intent(in) :: h(LBi:,LBj:)
180 real(r8), intent(in) :: om_u(LBi:,LBj:)
181 real(r8), intent(in) :: on_v(LBi:,LBj:)
182 real(r8), intent(in) :: pm(LBi:,LBj:)
183 real(r8), intent(in) :: pn(LBi:,LBj:)
184# ifdef SOLVE3D
185 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
186 real(r8), intent(in) :: pden(LBi:,LBj:,:)
187 real(r8), intent(in) :: u(LBi:,LBj:,:,:)
188 real(r8), intent(in) :: v(LBi:,LBj:,:,:)
189# endif
190 real(r8), intent(in) :: ubar(LBi:,LBj:,:)
191 real(r8), intent(in) :: vbar(LBi:,LBj:,:)
192 real(r8), intent(in) :: zeta(LBi:,LBj:,:)
193
194 real(r8), intent(out) :: pvor_bar(LBi:,LBj:)
195 real(r8), intent(out) :: rvor_bar(LBi:,LBj:)
196# ifdef SOLVE3D
197 real(r8), intent(out) :: pvor(LBi:,LBj:,:)
198 real(r8), intent(out) :: rvor(LBi:,LBj:,:)
199# endif
200
201# else
202
203# ifdef MASKING
204 real(r8), intent(in) :: pmask(LBi:UBi,LBj:UBj)
205 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
206 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
207# endif
208 real(r8), intent(in) :: f(LBi:UBi,LBj:UBj)
209 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
210 real(r8), intent(in) :: om_u(LBi:UBi,LBj:UBj)
211 real(r8), intent(in) :: on_v(LBi:UBi,LBj:UBj)
212 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
213 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
214# ifdef SOLVE3D
215 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
216 real(r8), intent(in) :: pden(LBi:UBi,LBj:UBj,N(ng))
217 real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2)
218 real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2)
219# endif
220 real(r8), intent(in) :: ubar(LBi:UBi,LBj:UBj,:)
221 real(r8), intent(in) :: vbar(LBi:UBi,LBj:UBj,:)
222 real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,:)
223
224 real(r8), intent(out) :: pvor_bar(LBi:UBi,LBj:UBj)
225 real(r8), intent(out) :: rvor_bar(LBi:UBi,LBj:UBj)
226# ifdef SOLVE3D
227 real(r8), intent(out) :: pvor(LBi:UBi,LBj:UBj,N(ng))
228 real(r8), intent(out) :: rvor(LBi:UBi,LBj:UBj,N(ng))
229# endif
230# endif
231
232
233
234 integer :: i, j
235# ifdef SOLVE3D
236 integer :: k, k1, k2
237# endif
238 real(r8) :: cff
239 real(r8) :: dVdx_p, dUde_p, fomn_p
240# ifdef SOLVE3D
241 real(r8) :: dRde_pr, dRdx_pr, dRdz_pr, dUdz_pr, dVdz_pr
242 real(r8) :: orho0
243
244 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: dRde
245 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: dRdx
246 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: dUde
247 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: dVdx
248
249 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,2) :: dRdz
250 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,2) :: dUdz
251 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,2) :: dVdz
252# endif
253
254# include "set_bounds.h"
255
256# ifdef SOLVE3D
257
258
259
260
261
262
263
264
265
266
267
269
270 k2=1
271 k_loop :
DO k=0,
n(ng)
272 k1=k2
273 k2=3-k1
274 IF (k.gt.0) THEN
275 DO j=jstr-1,jendr
276 DO i=istr,iendr
277 cff=0.5_r8*(pm(i,j)+pm(i-1,j))
278# ifdef MASKING
279 cff=cff*umask(i,j)
280# endif
281 drdx(i,j)=cff*(pden(i ,j,k)- &
282 & pden(i-1,j,k))
283 END DO
284 END DO
285 DO j=jstr,jendr
286 DO i=istr-1,iendr
287 cff=0.5_r8*(pn(i,j)+pn(i,j-1))
288# ifdef MASKING
289 cff=cff*vmask(i,j)
290# endif
291 drde(i,j)=cff*(pden(i,j ,k)- &
292 & pden(i,j-1,k))
293 END DO
294 END DO
295 DO j=jstr,jendr
296 DO i=istr,iendr
297 dude(i,j)=om_u(i,j )*u(i,j ,k,nout)- &
298 & om_u(i,j-1)*u(i,j-1,k,nout)
299# ifdef MASKING
300 dude(i,j)=dude(i,j)*pmask(i,j)
301# endif
302 dvdx(i,j)=on_v(i ,j)*v(i ,j,k,nout)- &
303 & on_v(i-1,j)*v(i-1,j,k,nout)
304# ifdef MASKING
305 dvdx(i,j)=dvdx(i,j)*pmask(i,j)
306# endif
307 END DO
308 END DO
309 END IF
310 IF ((k.eq.0).or.(k.eq.
n(ng)))
THEN
311 DO j=jstr-1,jendr
312 DO i=istr-1,iendr
313 drdz(i,j,k2)=0.0_r8
314 END DO
315 END DO
316 DO j=jstr-1,jendr
317 DO i=istr,iendr
318 dudz(i,j,k2)=0.0_r8
319 END DO
320 END DO
321 DO j=jstr,jendr
322 DO i=istr-1,iendr
323 dvdz(i,j,k2)=0.0_r8
324 END DO
325 END DO
326 ELSE
327 DO j=jstr-1,jendr
328 DO i=istr-1,iendr
329 cff=1.0_r8/(z_r(i,j,k+1)-z_r(i,j,k))
330 drdz(i,j,k2)=cff*(pden(i,j,k+1)- &
331 & pden(i,j,k ))
332 END DO
333 END DO
334 DO j=jstr-1,jendr
335 DO i=istr,iendr
336 cff=1.0_r8/(0.5_r8*(z_r(i-1,j,k+1)-z_r(i-1,j,k)+ &
337 & z_r(i ,j,k+1)-z_r(i ,j,k)))
338 dudz(i,j,k2)=cff*(u(i,j,k+1,nout)- &
339 & u(i,j,k ,nout))
340 END DO
341 END DO
342 DO j=jstr,jendr
343 DO i=istr-1,iendr
344 cff=1.0_r8/(0.5_r8*(z_r(i,j-1,k+1)-z_r(i,j-1,k)+ &
345 & z_r(i,j ,k+1)-z_r(i,j ,k)))
346 dvdz(i,j,k2)=cff*(v(i,j,k+1,nout)- &
347 & v(i,j,k ,nout))
348 END DO
349 END DO
350 END IF
351
352
353
354
355 IF (k.gt.0) THEN
356 DO j=jstr,jendr
357 DO i=istr,iendr
358 cff=0.0625_r8* &
359 & (pm(i-1,j-1)+pm(i-1,j)+pm(i,j-1)+pm(i,j))* &
360 & (pn(i-1,j-1)+pn(i-1,j)+pn(i,j-1)+pn(i,j))
361 fomn_p=0.25_r8*(f(i-1,j-1)+f(i-1,j)+f(i,j-1)+f(i,j))/cff
362 drde_pr=drde(i-1,j )+drde(i,j)
363 drdx_pr=drdx(i ,j-1)+drdx(i,j)
364 drdz_pr=0.125_r8*(drdz(i-1,j-1,k1)+drdz(i-1,j-1,k2)+ &
365 & drdz(i ,j-1,k1)+drdz(i ,j-1,k2)+ &
366 & drdz(i-1,j ,k1)+drdz(i-1,j ,k2)+ &
367 & drdz(i ,j ,k1)+drdz(i ,j ,k2))
368 dudz_pr=dudz(i ,j-1,k1)+dudz(i ,j-1,k2)+ &
369 & dudz(i ,j ,k1)+dudz(i ,j ,k2)
370 dvdz_pr=dvdz(i-1,j ,k1)+dvdz(i-1,j ,k2)+ &
371 & dvdz(i ,j ,k1)+dvdz(i ,j ,k2)
372 rvor(i,j,k)=cff*(dvdx(i,j)-dude(i,j))
373 pvor(i,j,k)=orho0* &
374 & (cff*drdz_pr*(fomn_p+ &
375 & dvdx(i,j)-dude(i,j))+ &
376 & 0.125_r8*(dudz_pr*drde_pr-dvdz_pr*drdx_pr))
377 END DO
378 END DO
379 END IF
380 END DO k_loop
381
382
383
386 & lbi, ubi, lbj, ubj, 1,
n(ng), &
387 & pvor)
389 & lbi, ubi, lbj, ubj, 1,
n(ng), &
390 & rvor)
391 END IF
392
393# ifdef DISTRIBUTE
395 & lbi, ubi, lbj, ubj, 1,
n(ng), &
397 & pvor, &
398 & rvor)
399# endif
400# endif
401
402
403
404
405
406
407
408
409 DO j=jstr,jendr
410 DO i=istr,iendr
411 cff=0.0625_r8* &
412 & (pm(i-1,j-1)+pm(i-1,j)+pm(i,j-1)+pm(i,j))* &
413 & (pn(i-1,j-1)+pn(i-1,j)+pn(i,j-1)+pn(i,j))
414 fomn_p=0.25_r8*(f(i-1,j-1)+f(i-1,j)+f(i,j-1)+f(i,j))/cff
415 cff=pm(i,j)*pn(i,j)
416 dvdx_p=on_v(i ,j)*vbar(i ,j,kout)- &
417 & on_v(i-1,j)*vbar(i-1,j,kout)
418# ifdef MASKING
419 dvdx_p=dvdx_p*pmask(i,j)
420# endif
421 dude_p=om_u(i,j )*ubar(i,j ,kout)- &
422 & om_u(i,j-1)*ubar(i,j-1,kout)
423# ifdef MASKING
424 dude_p=dude_p*pmask(i,j)
425# endif
426 rvor_bar(i,j)=cff*(dvdx_p-dude_p)
427 pvor_bar(i,j)=cff*((fomn_p+dvdx_p-dude_p)/ &
428 & (h(i,j)+zeta(i,j,kout)))
429 END DO
430 END DO
431
432
433
436 & lbi, ubi, lbj, ubj, &
437 & pvor_bar)
439 & lbi, ubi, lbj, ubj, &
440 & rvor_bar)
441 END IF
442
443# ifdef DISTRIBUTE
445 & lbi, ubi, lbj, ubj, &
447 & pvor_bar, &
448 & rvor_bar)
449# endif
450
451 RETURN
subroutine exchange_p2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
subroutine exchange_p3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
integer, dimension(:), allocatable n
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
subroutine mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)
subroutine mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)