155
156
159
161# ifdef DISTRIBUTE
163# endif
164
165
166
167 integer, intent(in) :: ng, tile
168 integer, intent(in) :: LBi, UBi, LBj, UBj
169 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
170 integer, intent(in) :: nrhs
171
172# ifdef ASSUMED_SHAPE
173 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
174# if defined UV_LOGDRAG
175 real(r8), intent(in) :: ZoBot(LBi:,LBj:)
176# elif defined UV_LDRAG
177 real(r8), intent(in) :: rdrag(LBi:,LBj:)
178# elif defined UV_QDRAG
179 real(r8), intent(in) :: rdrag2(LBi:,LBj:)
180# endif
181# if !defined BBL_MODEL || defined ICESHELF
182 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
183 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
184# endif
185# if defined MASKING
186 real(r8), intent(in) :: rmask(LBi:,LBj:)
187# endif
188# ifdef WET_DRY
189 real(r8), intent(in) :: rmask_wet(LBi:,LBj:)
190# endif
191# if defined ICESHELF
192 real(r8), intent(in) :: zice(LBi:,LBj:)
193# endif
194 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
195# if !defined BBL_MODEL || defined ICESHELF
196 real(r8), intent(in) :: u(LBi:,LBj:,:,:)
197 real(r8), intent(in) :: v(LBi:,LBj:,:,:)
198# endif
199# ifdef QCORRECTION
200 real(r8), intent(in) :: dqdt(LBi:,LBj:)
201 real(r8), intent(in) :: sst(LBi:,LBj:)
202# endif
203# if defined SCORRECTION || defined SRELAXATION
204 real(r8), intent(in) :: sss(LBi:,LBj:)
205# endif
206 real(r8), intent(in) :: stflux(LBi:,LBj:,:)
207 real(r8), intent(in) :: btflux(LBi:,LBj:,:)
208# if defined ICESHELF
209# ifdef SHORTWAVE
210 real(r8), intent(inout) :: srflx(LBi:,LBj:)
211# endif
212 real(r8), intent(inout) :: sustr(LBi:,LBj:)
213 real(r8), intent(inout) :: svstr(LBi:,LBj:)
214# endif
215# ifndef BBL_MODEL
216 real(r8), intent(inout) :: bustr(LBi:,LBj:)
217 real(r8), intent(inout) :: bvstr(LBi:,LBj:)
218# endif
219 real(r8), intent(inout) :: stflx(LBi:,LBj:,:)
220 real(r8), intent(inout) :: btflx(LBi:,LBj:,:)
221# else
222 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
223# if defined UV_LOGDRAG
224 real(r8), intent(in) :: ZoBot(LBi:UBi,LBj:UBj)
225# elif defined UV_LDRAG
226 real(r8), intent(in) :: rdrag(LBi:UBi,LBj:UBj)
227# elif defined UV_QDRAG
228 real(r8), intent(in) :: rdrag2(LBi:UBi,LBj:UBj)
229# endif
230# if !defined BBL_MODEL || defined ICESHELF
231 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
232 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:N(ng))
233# endif
234# if defined MASKING
235 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
236# endif
237# ifdef WET_DRY
238 real(r8), intent(in) :: rmask_wet(LBi:UBi,LBj:UBj)
239# endif
240# if defined ICESHELF
241 real(r8), intent(in) :: zice(LBi:UBi,LBj:UBj)
242# endif
243 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
244# if !defined BBL_MODEL || defined ICESHELF
245 real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2)
246 real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2)
247# endif
248# ifdef QCORRECTION
249 real(r8), intent(in) :: dqdt(LBi:UBi,LBj:UBj)
250 real(r8), intent(in) :: sst(LBi:UBi,LBj:UBj)
251# endif
252# if defined SCORRECTION || defined SRELAXATION
253 real(r8), intent(in) :: sss(LBi:UBi,LBj:UBj)
254# endif
255 real(r8), intent(in) :: stflux(LBi:UBi,LBj:UBj,NT(ng))
256 real(r8), intent(in) :: btflux(LBi:UBi,LBj:UBj,NT(ng))
257# if defined ICESHELF
258# ifdef SHORTWAVE
259 real(r8), intent(inout) :: srflx(LBi:UBi,LBj:UBj)
260# endif
261 real(r8), intent(inout) :: sustr(LBi:UBi,LBj:UBj)
262 real(r8), intent(inout) :: svstr(LBi:UBi,LBj:UBj)
263# endif
264# ifndef BBL_MODEL
265 real(r8), intent(inout) :: bustr(LBi:UBi,LBj:UBj)
266 real(r8), intent(inout) :: bvstr(LBi:UBi,LBj:UBj)
267# endif
268 real(r8), intent(inout) :: stflx(LBi:UBi,LBj:UBj,NT(ng))
269 real(r8), intent(inout) :: btflx(LBi:UBi,LBj:UBj,NT(ng))
270# endif
271
272
273
274 integer :: i, j, itrc
275
276 real(r8) :: EmP
277# if !defined BBL_MODEL || defined ICESHELF || \
278 defined limit_stflx_cooling
279 real(r8) :: cff, cff1, cff2, cff3
280# endif
281
282# if (!defined BBL_MODEL || defined ICESHELF) && defined UV_LOGDRAG
283 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wrk
284# endif
285
286# include "set_bounds.h"
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302 DO j=jstrr,jendr
303 DO i=istrr,iendr
306# ifdef WET_DRY
307 stflx(i,j,
itemp)=stflx(i,j,
itemp)*rmask_wet(i,j)
308 btflx(i,j,
itemp)=btflx(i,j,
itemp)*rmask_wet(i,j)
309# endif
310 END DO
311 END DO
312
313# ifdef QCORRECTION
314
315
316
317
318
319
320
321 DO j=jstrr,jendr
322 DO i=istrr,iendr
324 & dqdt(i,j)*(t(i,j,
n(ng),nrhs,
itemp)-sst(i,j))
325# ifdef WET_DRY
326 stflx(i,j,
itemp)=stflx(i,j,
itemp)*rmask_wet(i,j)
327# endif
328 END DO
329 END DO
330# endif
331
332# ifdef LIMIT_STFLX_COOLING
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350 cff1=-2.0_r8
351 DO j=jstrr,jendr
352 DO i=istrr,iendr
353 cff2=stflx(i,j,
itemp)
354 cff3=0.5_r8*(1.0_r8+sign(1.0_r8,cff1-t(i,j,
n(ng),nrhs,
itemp)))
355 stflx(i,j,
itemp)=cff2-cff3*0.5_r8*(cff2-abs(cff2))
356# ifdef WET_DRY
357 stflx(i,j,
itemp)=stflx(i,j,
itemp)*rmask_wet(i,j)
358# endif
359 END DO
360 END DO
361# endif
362
363# ifdef SALINITY
364
365
366
367
368
369
370
371
372
373
374 DO j=jstrr,jendr
375 DO i=istrr,iendr
376 emp=stflux(i,j,
isalt)
377# if defined SCORRECTION
380 & (t(i,j,
n(ng),nrhs,
isalt)-sss(i,j))
381# ifdef WET_DRY
382 stflx(i,j,
isalt) = rmask_wet(i,j)*stflx(i,j,
isalt)
383# elif defined MASKING
384 stflx(i,j,
isalt) = rmask(i,j)*stflx(i,j,
isalt)
385# endif
386# elif defined SRELAXATION
388 & (t(i,j,
n(ng),nrhs,
isalt)-sss(i,j))
389# ifdef WET_DRY
390 stflx(i,j,
isalt) = rmask_wet(i,j)*stflx(i,j,
isalt)
391# elif defined MASKING
392 stflx(i,j,
isalt) = rmask(i,j)*stflx(i,j,
isalt)
393# endif
394# else
396# ifdef WET_DRY
397 stflx(i,j,
isalt) = rmask_wet(i,j)*stflx(i,j,
isalt)
398# elif defined MASKING
399 stflx(i,j,
isalt) = rmask(i,j)*stflx(i,j,
isalt)
400# endif
401# endif
403 END DO
404 END DO
405# endif
406
407# if defined BIOLOGY || defined SEDIMENT || defined T_PASSIVE
408
409
410
411
412
414 DO j=jstrr,jendr
415 DO i=istrr,iendr
416 stflx(i,j,itrc)=stflux(i,j,itrc)
417 btflx(i,j,itrc)=btflux(i,j,itrc)
418 END DO
419 END DO
420 END DO
421# endif
422
423# ifdef ICESHELF
424
425
426
427
428
429
431 DO j=jstrr,jendr
432 DO i=istrr,iendr
433 IF (zice(i,j).ne.0.0_r8) THEN
434 stflx(i,j,itrc)=0.0_r8
435 END IF
436 END DO
437 END DO
438 END DO
439# ifdef SHORTWAVE
440 DO j=jstrr,jendr
441 DO i=istrr,iendr
442 IF (zice(i,j).ne.0.0_r8) THEN
443 srflx(i,j)=0.0_r8
444 END IF
445 END DO
446 END DO
447# endif
448
449
450
451
452
453
454# if defined UV_LOGDRAG
455
456
457
458 DO j=jstrv-1,jend
459 DO i=istru-1,iend
460 cff1=1.0_r8/log((z_w(i,j,
n(ng))-z_r(i,j,
n(ng)))/zobot(i,j))
463 END DO
464 END DO
465 DO j=jstr,jend
466 DO i=istru,iend
467 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
468 cff1=0.25_r8*(v(i ,j ,
n(ng),nrhs)+ &
469 & v(i ,j+1,
n(ng),nrhs)+ &
470 & v(i-1,j ,
n(ng),nrhs)+ &
471 & v(i-1,j+1,
n(ng),nrhs))
472 cff2=sqrt(u(i,j,
n(ng),nrhs)*u(i,j,
n(ng),nrhs)+cff1*cff1)
473 sustr(i,j)=-0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
474 & u(i,j,
n(ng),nrhs)*cff2
475 END IF
476 END DO
477 END DO
478 DO j=jstrv,jend
479 DO i=istr,iend
480 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
481 cff1=0.25_r8*(u(i ,j ,
n(ng),nrhs)+ &
482 & u(i+1,j ,
n(ng),nrhs)+ &
483 & u(i ,j-1,
n(ng),nrhs)+ &
484 & u(i+1,j-1,
n(ng),nrhs))
485 cff2=sqrt(cff1*cff1+v(i,j,
n(ng),nrhs)*v(i,j,
n(ng),nrhs))
486 svstr(i,j)=-0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
487 & v(i,j,
n(ng),nrhs)*cff2
488 END IF
489 END DO
490 END DO
491# elif defined UV_QDRAG
492
493
494
495 DO j=jstr,jend
496 DO i=istru,iend
497 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
498 cff1=0.25_r8*(v(i ,j ,
n(ng),nrhs)+ &
499 & v(i ,j+1,
n(ng),nrhs)+ &
500 & v(i-1,j ,
n(ng),nrhs)+ &
501 & v(i-1,j+1,
n(ng),nrhs))
502 cff2=sqrt(u(i,j,
n(ng),nrhs)*u(i,j,
n(ng),nrhs)+cff1*cff1)
503 sustr(i,j)=-0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
504 & u(i,j,
n(ng),nrhs)*cff2
505 END IF
506 END DO
507 END DO
508 DO j=jstrv,jend
509 DO i=istr,iend
510 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
511 cff1=0.25_r8*(u(i ,j ,
n(ng),nrhs)+ &
512 & u(i+1,j ,
n(ng),nrhs)+ &
513 & u(i ,j-1,
n(ng),nrhs)+ &
514 & u(i+1,j-1,
n(ng),nrhs))
515 cff2=sqrt(cff1*cff1+v(i,j,
n(ng),nrhs)*v(i,j,
n(ng),nrhs))
516 svstr(i,j)=-0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
517 & v(i,j,
n(ng),nrhs)*cff2
518 END IF
519 END DO
520 END DO
521# elif defined UV_LDRAG
522
523
524
525 DO j=jstr,jend
526 DO i=istru,iend
527 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
528 sustr(i,j)=-0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
530 END IF
531 END DO
532 END DO
533 DO j=jstrv,jend
534 DO i=istr,iend
535 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
536 svstr(i,j)=-0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
538 END IF
539 END DO
540 END DO
541# else
542 DO j=jstr,jend
543 DO i=istru,iend
544 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
545 sustr(i,j)=0.0_r8
546 END IF
547 END DO
548 END DO
549 DO j=jstrv,jend
550 DO i=istr,iend
551 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
552 svstr(i,j)=0.0_r8
553 END IF
554 END DO
555 END DO
556# endif
557
558
559
560
562 & lbi, ubi, lbj, ubj, &
563 & sustr)
565 & lbi, ubi, lbj, ubj, &
566 & svstr)
567# ifdef DISTRIBUTE
569 & lbi, ubi, lbj, ubj, &
572 & sustr, svstr)
573# endif
574# endif
575
576# ifndef BBL_MODEL
577
578
579
580
581
582# ifdef LIMIT_BSTRESS
583
584
585
586
587
589# endif
590
591# if defined UV_LOGDRAG
592
593
594
595 DO j=jstrv-1,jend
596 DO i=istru-1,iend
597 cff1=1.0_r8/log((z_r(i,j,1)-z_w(i,j,0))/zobot(i,j))
600 END DO
601 END DO
602 DO j=jstr,jend
603 DO i=istru,iend
604 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
605 & v(i ,j+1,1,nrhs)+ &
606 & v(i-1,j ,1,nrhs)+ &
607 & v(i-1,j+1,1,nrhs))
608 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
609 bustr(i,j)=0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
610 & u(i,j,1,nrhs)*cff2
611# ifdef LIMIT_BSTRESS
612 cff3=cff*0.5_r8*(hz(i-1,j,1)+hz(i,j,1))
613 bustr(i,j)=sign(1.0_r8, bustr(i,j))* &
614 & min(abs(bustr(i,j)), &
615 & abs(u(i,j,1,nrhs))*cff3)
616# endif
617 END DO
618 END DO
619 DO j=jstrv,jend
620 DO i=istr,iend
621 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
622 & u(i+1,j ,1,nrhs)+ &
623 & u(i ,j-1,1,nrhs)+ &
624 & u(i+1,j-1,1,nrhs))
625 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
626 bvstr(i,j)=0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
627 & v(i,j,1,nrhs)*cff2
628# ifdef LIMIT_BSTRESS
629 cff3=cff*0.5_r8*(hz(i,j-1,1)+hz(i,j,1))
630 bvstr(i,j)=sign(1.0_r8, bvstr(i,j))* &
631 & min(abs(bvstr(i,j)), &
632 & abs(v(i,j,1,nrhs))*cff3)
633# endif
634 END DO
635 END DO
636# elif defined UV_QDRAG
637
638
639
640 DO j=jstr,jend
641 DO i=istru,iend
642 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
643 & v(i ,j+1,1,nrhs)+ &
644 & v(i-1,j ,1,nrhs)+ &
645 & v(i-1,j+1,1,nrhs))
646 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
647 bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
648 & u(i,j,1,nrhs)*cff2
649# ifdef LIMIT_BSTRESS
650 cff3=cff*0.5_r8*(hz(i-1,j,1)+hz(i,j,1))
651 bustr(i,j)=sign(1.0_r8, bustr(i,j))* &
652 & min(abs(bustr(i,j)), &
653 & abs(u(i,j,1,nrhs))*cff3)
654# endif
655 END DO
656 END DO
657 DO j=jstrv,jend
658 DO i=istr,iend
659 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
660 & u(i+1,j ,1,nrhs)+ &
661 & u(i ,j-1,1,nrhs)+ &
662 & u(i+1,j-1,1,nrhs))
663 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
664 bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
665 & v(i,j,1,nrhs)*cff2
666# ifdef LIMIT_BSTRESS
667 cff3=cff*0.5_r8*(hz(i,j-1,1)+hz(i,j,1))
668 bvstr(i,j)=sign(1.0_r8, bvstr(i,j))* &
669 & min(abs(bvstr(i,j)), &
670 & abs(v(i,j,1,nrhs))*cff3)
671# endif
672 END DO
673 END DO
674# elif defined UV_LDRAG
675
676
677
678 DO j=jstr,jend
679 DO i=istru,iend
680 bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
681 & u(i,j,1,nrhs)
682# ifdef LIMIT_BSTRESS
683 cff1=cff*0.5_r8*(hz(i-1,j,1)+hz(i,j,1))
684 bustr(i,j)=sign(1.0_r8, bustr(i,j))* &
685 & min(abs(bustr(i,j)), &
686 & abs(u(i,j,1,nrhs))*cff1)
687# endif
688 END DO
689 END DO
690 DO j=jstrv,jend
691 DO i=istr,iend
692 bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
693 & v(i,j,1,nrhs)
694# ifdef LIMIT_BSTRESS
695 cff1=cff*0.5_r8*(hz(i,j-1,1)+hz(i,j,1))
696 bvstr(i,j)=sign(1.0_r8, bvstr(i,j))* &
697 & min(abs(bvstr(i,j)), &
698 & abs(v(i,j,1,nrhs))*cff1)
699# endif
700 END DO
701 END DO
702# endif
703
704
705
707 & lbi, ubi, lbj, ubj, &
708 & bustr)
710 & lbi, ubi, lbj, ubj, &
711 & bvstr)
712# ifdef DISTRIBUTE
714 & lbi, ubi, lbj, ubj, &
717 & bustr, bvstr)
718# endif
719# endif
720
721 RETURN
subroutine bc_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
subroutine bc_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
integer, dimension(:), allocatable n
integer, dimension(:), allocatable nt
real(dp), dimension(:), allocatable dt
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
real(dp), dimension(:,:), allocatable tnudg
subroutine mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)