194
195
199
200# ifdef DISTRIBUTE
202# endif
203
204
205
206 logical, intent(in) :: Lweak
207
208 integer, intent(in) :: ng, tile
209 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
210 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
211 integer, intent(in) :: Linp
212
213# ifdef ASSUMED_SHAPE
214# ifdef ADJUST_BOUNDARY
215# ifdef SOLVE3D
216 real(r8), intent(in) :: t_obc_std(LBij:,:,:,:)
217 real(r8), intent(in) :: u_obc_std(LBij:,:,:)
218 real(r8), intent(in) :: v_obc_std(LBij:,:,:)
219# endif
220 real(r8), intent(in) :: ubar_obc_std(LBij:,:)
221 real(r8), intent(in) :: vbar_obc_std(LBij:,:)
222 real(r8), intent(in) :: zeta_obc_std(LBij:,:)
223# endif
224# ifdef ADJUST_WSTRESS
225 real(r8), intent(in) :: sustr_std(LBi:,LBj:)
226 real(r8), intent(in) :: svstr_std(LBi:,LBj:)
227# endif
228# if defined ADJUST_STFLUX && defined SOLVE3D
229 real(r8), intent(in) :: stflx_std(LBi:,LBj:,:)
230# endif
231# ifdef SOLVE3D
232 real(r8), intent(in) :: t_std(LBi:,LBj:,:,:,:)
233 real(r8), intent(in) :: u_std(LBi:,LBj:,:,:)
234 real(r8), intent(in) :: v_std(LBi:,LBj:,:,:)
235# if defined WEAK_CONSTRAINT && defined TIME_CONV
236 real(r8), intent(in) :: ubar_std(LBi:,LBj:,:)
237 real(r8), intent(in) :: vbar_std(LBi:,LBj:,:)
238# endif
239# else
240 real(r8), intent(in) :: ubar_std(LBi:,LBj:,:)
241 real(r8), intent(in) :: vbar_std(LBi:,LBj:,:)
242# endif
243 real(r8), intent(in) :: zeta_std(LBi:,LBj:,:)
244# ifdef ADJUST_BOUNDARY
245# ifdef SOLVE3D
246 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
247 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
248 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
249# endif
250 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
251 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
252 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
253# endif
254# ifdef ADJUST_WSTRESS
255 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
256 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
257# endif
258# if defined ADJUST_STFLUX && defined SOLVE3D
259 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
260# endif
261# ifdef SOLVE3D
262 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
263 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
264 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
265# if defined WEAK_CONSTRAINT && defined TIME_CONV
266 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
267 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
268# endif
269# else
270 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
271 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
272# endif
273 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
274
275# else
276
277# ifdef ADJUST_BOUNDARY
278# ifdef SOLVE3D
279 real(r8), intent(in) :: t_obc_std(LBij:UBij,N(ng),4,NT(ng))
280 real(r8), intent(in) :: u_obc_std(LBij:UBij,N(ng),4)
281 real(r8), intent(in) :: v_obc_std(LBij:UBij,N(ng),4)
282# endif
283 real(r8), intent(in) :: ubar_obc_std(LBij:UBij,4)
284 real(r8), intent(in) :: vbar_obc_std(LBij:UBij,4)
285 real(r8), intent(in) :: zeta_obc_std(LBij:UBij,4)
286# endif
287# ifdef ADJUST_WSTRESS
288 real(r8), intent(in) :: sustr_std(LBi:,LBj:)
289 real(r8), intent(in) :: svstr_std(LBi:,LBj:)
290# endif
291# if defined ADJUST_STFLUX && defined SOLVE3D
292 real(r8), intent(in) :: stflx_std(LBi:UBi,LBj:UBj,NT(ng))
293# endif
294# ifdef SOLVE3D
295 real(r8), intent(in) :: t_std(LBi:UBi,LBj:UBj,N(ng),NSA,NT(ng))
296 real(r8), intent(in) :: u_std(LBi:UBi,LBj:UBj,N(ng),NSA)
297 real(r8), intent(in) :: v_std(LBi:UBi,LBj:UBj,N(ng),NSA)
298# if defined WEAK_CONSTRAINT && defined TIME_CONV
299 real(r8), intent(in) :: ubar_std(LBi:UBi,LBj:UBj,NSA)
300 real(r8), intent(in) :: vbar_std(LBi:UBi,LBj:UBj,NSA)
301# endif
302# else
303 real(r8), intent(in) :: ubar_std(LBi:UBi,LBj:UBj,NSA)
304 real(r8), intent(in) :: vbar_std(LBi:UBi,LBj:UBj,NSA)
305# endif
306 real(r8), intent(in) :: zeta_std(LBi:UBi,LBj:UBj,NSA)
307# ifdef ADJUST_BOUNDARY
308# ifdef SOLVE3D
309 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
310 & Nbrec(ng),2,NT(ng))
311 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
312 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
313# endif
314 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
315 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
316 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
317# endif
318# ifdef ADJUST_WSTRESS
319 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
320 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
321# endif
322# if defined ADJUST_STFLUX && defined SOLVE3D
323 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
324 & Nfrec(ng),2,NT(ng))
325# endif
326# ifdef SOLVE3D
327 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
328 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
329 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
330# if defined WEAK_CONSTRAINT && defined TIME_CONV
331 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
332 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
333# endif
334# else
335 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
336 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
337# endif
338 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
339# endif
340
341
342
343 integer :: i, ib, ir, j, rec
344# ifdef SOLVE3D
345 integer :: it, k
346# endif
347
348# include "set_bounds.h"
349
350
351
352
353
354 IF (lweak) THEN
355 rec=2
356 ELSE
357 rec=1
358 END IF
359
360
361
362
363
364
365
366
367# ifdef DISTRIBUTE
369 & lbi, ubi, lbj, ubj, &
372 & ad_zeta(:,:,linp))
373# endif
374 DO j=jstrt,jendt
375 DO i=istrt,iendt
376 ad_zeta(i,j,linp)=ad_zeta(i,j,linp)*zeta_std(i,j,rec)
377 END DO
378 END DO
379# if !defined SOLVE3D || (defined WEAK_CONSTRAINT && defined TIME_CONV)
380
381
382
383# ifdef DISTRIBUTE
385 & lbi, ubi, lbj, ubj, &
388 & ad_ubar(:,:,linp), &
389 & ad_vbar(:,:,linp))
390# endif
391 DO j=jstrt,jendt
392 DO i=istrp,iendt
393 ad_ubar(i,j,linp)=ad_ubar(i,j,linp)*ubar_std(i,j,rec)
394 END DO
395 END DO
396 DO j=jstrp,jendt
397 DO i=istrt,iendt
398 ad_vbar(i,j,linp)=ad_vbar(i,j,linp)*vbar_std(i,j,rec)
399 END DO
400 END DO
401# endif
402# ifdef SOLVE3D
403
404
405
406# ifdef DISTRIBUTE
408 & lbi, ubi, lbj, ubj, 1,
n(ng), &
411 & ad_u(:,:,:,linp), &
412 & ad_v(:,:,:,linp))
413# endif
415 DO j=jstrt,jendt
416 DO i=istrp,iendt
417 ad_u(i,j,k,linp)=ad_u(i,j,k,linp)*u_std(i,j,k,rec)
418 END DO
419 END DO
420 DO j=jstrp,jendt
421 DO i=istrt,iendt
422 ad_v(i,j,k,linp)=ad_v(i,j,k,linp)*v_std(i,j,k,rec)
423 END DO
424 END DO
425 END DO
426
427
428
429# ifdef DISTRIBUTE
431 & lbi, ubi, lbj, ubj, 1,
n(ng), 1,
nt(ng), &
434 & ad_t(:,:,:,linp,:))
435# endif
438 DO j=jstrt,jendt
439 DO i=istrt,iendt
440 ad_t(i,j,k,linp,it)=ad_t(i,j,k,linp,it)* &
441 & t_std(i,j,k,rec,it)
442 END DO
443 END DO
444 END DO
445 END DO
446# endif
447
448# ifdef ADJUST_BOUNDARY
449
450
451
452
453
454
455
456
457 IF (.not.lweak.and.(any(
lobc(:,
isfsur,ng))))
THEN
459# ifdef DISTRIBUTE
460 DO ib=1,4
463 & lbij, ubij, &
466 & ad_zeta_obc(:,ib,ir,linp))
467 END IF
468 END DO
469# endif
471 &
domain(ng)%Western_Edge(tile))
THEN
473 DO j=jstr,jend
474 ad_zeta_obc(j,ib,ir,linp)=ad_zeta_obc(j,ib,ir,linp)* &
475 & zeta_obc_std(j,ib)
476 END DO
477 END IF
479 &
domain(ng)%Eastern_Edge(tile))
THEN
481 DO j=jstr,jend
482 ad_zeta_obc(j,ib,ir,linp)=ad_zeta_obc(j,ib,ir,linp)* &
483 & zeta_obc_std(j,ib)
484 END DO
485 END IF
487 &
domain(ng)%Southern_Edge(tile))
THEN
489 DO i=istr,iend
490 ad_zeta_obc(i,ib,ir,linp)=ad_zeta_obc(i,ib,ir,linp)* &
491 & zeta_obc_std(i,ib)
492 END DO
493 END IF
495 &
domain(ng)%Northern_Edge(tile))
THEN
497 DO i=istr,iend
498 ad_zeta_obc(i,ib,ir,linp)=ad_zeta_obc(i,ib,ir,linp)* &
499 & zeta_obc_std(i,ib)
500 END DO
501 END IF
502 END DO
503 END IF
504
505
506
507 IF (.not.lweak.and.(any(
lobc(:,
isubar,ng))))
THEN
509# ifdef DISTRIBUTE
510 DO ib=1,4
513 & lbij, ubij, &
516 & ad_ubar_obc(:,ib,ir,linp))
517 END IF
518 END DO
519# endif
521 &
domain(ng)%Western_Edge(tile))
THEN
523 DO j=jstr,jend
524 ad_ubar_obc(j,ib,ir,linp)=ad_ubar_obc(j,ib,ir,linp)* &
525 & ubar_obc_std(j,ib)
526 END DO
527 END IF
529 &
domain(ng)%Eastern_Edge(tile))
THEN
531 DO j=jstr,jend
532 ad_ubar_obc(j,ib,ir,linp)=ad_ubar_obc(j,ib,ir,linp)* &
533 & ubar_obc_std(j,ib)
534 END DO
535 END IF
537 &
domain(ng)%Southern_Edge(tile))
THEN
539 DO i=istru,iend
540 ad_ubar_obc(i,ib,ir,linp)=ad_ubar_obc(i,ib,ir,linp)* &
541 & ubar_obc_std(i,ib)
542 END DO
543 END IF
545 &
domain(ng)%Northern_Edge(tile))
THEN
547 DO i=istru,iend
548 ad_ubar_obc(i,ib,ir,linp)=ad_ubar_obc(i,ib,ir,linp)* &
549 & ubar_obc_std(i,ib)
550 END DO
551 END IF
552 END DO
553 END IF
554
555
556
557 IF (.not.lweak.and.(any(
lobc(:,
isvbar,ng))))
THEN
559# ifdef DISTRIBUTE
560 DO ib=1,4
563 & lbij, ubij, &
566 & ad_vbar_obc(:,ib,ir,linp))
567 END IF
568 END DO
569# endif
571 &
domain(ng)%Western_Edge(tile))
THEN
573 DO j=jstrv,jend
574 ad_vbar_obc(j,ib,ir,linp)=ad_vbar_obc(j,ib,ir,linp)* &
575 & vbar_obc_std(j,ib)
576 END DO
577 END IF
579 &
domain(ng)%Eastern_Edge(tile))
THEN
581 DO j=jstrv,jend
582 ad_vbar_obc(j,ib,ir,linp)=ad_vbar_obc(j,ib,ir,linp)* &
583 & vbar_obc_std(j,ib)
584 END DO
585 END IF
587 &
domain(ng)%Southern_Edge(tile))
THEN
589 DO i=istr,iend
590 ad_vbar_obc(i,ib,ir,linp)=ad_vbar_obc(i,ib,ir,linp)* &
591 & vbar_obc_std(i,ib)
592 END DO
593 END IF
595 &
domain(ng)%Northern_Edge(tile))
THEN
597 DO i=istr,iend
598 ad_vbar_obc(i,ib,ir,linp)=ad_vbar_obc(i,ib,ir,linp)* &
599 & vbar_obc_std(i,ib)
600 END DO
601 END IF
602 END DO
603 END IF
604
605# ifdef SOLVE3D
606
607
608
609 IF (.not.lweak.and.(any(
lobc(:,
isuvel,ng))))
THEN
611# ifdef DISTRIBUTE
612 DO ib=1,4
615 & lbij, ubij, 1,
n(ng), &
618 & ad_u_obc(:,:,ib,ir,linp))
619 END IF
620 END DO
621# endif
623 &
domain(ng)%Western_Edge(tile))
THEN
626 DO j=jstr,jend
627 ad_u_obc(j,k,ib,ir,linp)=ad_u_obc(j,k,ib,ir,linp)* &
628 & u_obc_std(j,k,ib)
629 END DO
630 END DO
631 END IF
633 &
domain(ng)%Eastern_Edge(tile))
THEN
636 DO j=jstr,jend
637 ad_u_obc(j,k,ib,ir,linp)=ad_u_obc(j,k,ib,ir,linp)* &
638 & u_obc_std(j,k,ib)
639 END DO
640 END DO
641 END IF
643 &
domain(ng)%Southern_Edge(tile))
THEN
646 DO i=istru,iend
647 ad_u_obc(i,k,ib,ir,linp)=ad_u_obc(i,k,ib,ir,linp)* &
648 & u_obc_std(i,k,ib)
649 END DO
650 END DO
651 END IF
653 &
domain(ng)%Northern_Edge(tile))
THEN
656 DO i=istru,iend
657 ad_u_obc(i,k,ib,ir,linp)=ad_u_obc(i,k,ib,ir,linp)* &
658 & u_obc_std(i,k,ib)
659 END DO
660 END DO
661 END IF
662 END DO
663 END IF
664
665
666
667 IF (.not.lweak.and.(any(
lobc(:,
isvvel,ng))))
THEN
669# ifdef DISTRIBUTE
670 DO ib=1,4
673 & lbij, ubij, 1,
n(ng), &
676 & ad_v_obc(:,:,ib,ir,linp))
677 END IF
678 END DO
679# endif
681 &
domain(ng)%Western_Edge(tile))
THEN
684 DO j=jstrv,jend
685 ad_v_obc(j,k,ib,ir,linp)=ad_v_obc(j,k,ib,ir,linp)* &
686 & v_obc_std(j,k,ib)
687 END DO
688 END DO
689 END IF
691 &
domain(ng)%Eastern_Edge(tile))
THEN
694 DO j=jstrv,jend
695 ad_v_obc(j,k,ib,ir,linp)=ad_v_obc(j,k,ib,ir,linp)* &
696 & v_obc_std(j,k,ib)
697 END DO
698 END DO
699 END IF
701 &
domain(ng)%Southern_Edge(tile))
THEN
704 DO i=istr,iend
705 ad_v_obc(i,k,ib,ir,linp)=ad_v_obc(i,k,ib,ir,linp)* &
706 & v_obc_std(i,k,ib)
707 END DO
708 END DO
709 END IF
711 &
domain(ng)%Northern_Edge(tile))
THEN
714 DO i=istr,iend
715 ad_v_obc(i,k,ib,ir,linp)=ad_v_obc(i,k,ib,ir,linp)* &
716 & v_obc_std(i,k,ib)
717 END DO
718 END DO
719 END IF
720 END DO
721 END IF
722
723
724
726 IF (.not.lweak.and.(any(
lobc(:,
istvar(it),ng))))
THEN
728# ifdef DISTRIBUTE
729 DO ib=1,4
732 & lbij, ubij, 1,
n(ng), &
736 & ad_t_obc(:,:,ib,ir,linp,it))
737 END IF
738 END DO
739# endif
741 &
domain(ng)%Western_Edge(tile))
THEN
744 DO j=jstr,jend
745 ad_t_obc(j,k,ib,ir,linp,it)= &
746 & ad_t_obc(j,k,ib,ir,linp,it)* &
747 & t_obc_std(j,k,ib,it)
748 END DO
749 END DO
750 END IF
752 &
domain(ng)%Eastern_Edge(tile))
THEN
755 DO j=jstr,jend
756 ad_t_obc(j,k,ib,ir,linp,it)= &
757 & ad_t_obc(j,k,ib,ir,linp,it)* &
758 & t_obc_std(j,k,ib,it)
759 END DO
760 END DO
761 END IF
763 &
domain(ng)%Southern_Edge(tile))
THEN
766 DO i=istr,iend
767 ad_t_obc(i,k,ib,ir,linp,it)= &
768 & ad_t_obc(i,k,ib,ir,linp,it)* &
769 & t_obc_std(i,k,ib,it)
770 END DO
771 END DO
772 END IF
774 &
domain(ng)%Northern_Edge(tile))
THEN
777 DO i=istr,iend
778 ad_t_obc(i,k,ib,ir,linp,it)= &
779 & ad_t_obc(i,k,ib,ir,linp,it)* &
780 & t_obc_std(i,k,ib,it)
781 END DO
782 END DO
783 END IF
784 END DO
785 END IF
786 END DO
787# endif
788# endif
789
790# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
791
792
793
794
795
796
797# ifdef ADJUST_WSTRESS
798
799
800
801 IF (.not.lweak) THEN
802# ifdef DISTRIBUTE
804 & lbi, ubi, lbj, ubj, 1,
nfrec(ng), &
807 & ad_ustr(:,:,:,linp), &
808 & ad_vstr(:,:,:,linp))
809# endif
811 DO j=jstrt,jendt
812 DO i=istrp,iendt
813 ad_ustr(i,j,ir,linp)=ad_ustr(i,j,ir,linp)*sustr_std(i,j)
814 END DO
815 END DO
816 DO j=jstrp,jendt
817 DO i=istrt,iendt
818 ad_vstr(i,j,ir,linp)=ad_vstr(i,j,ir,linp)*svstr_std(i,j)
819 END DO
820 END DO
821 END DO
822 END IF
823# endif
824# if defined ADJUST_STFLUX && defined SOLVE3D
825
826
827
828 IF (.not.lweak) THEN
831# ifdef DISTRIBUTE
833 & lbi, ubi, lbj, ubj, 1,
nfrec(ng), &
836 & ad_tflux(:,:,:,linp,it))
837# endif
839 DO j=jstrt,jendt
840 DO i=istrt,iendt
841 ad_tflux(i,j,ir,linp,it)=ad_tflux(i,j,ir,linp,it)* &
842 & stflx_std(i,j,it)
843 END DO
844 END DO
845 END DO
846 END IF
847 END DO
848 END IF
849# endif
850# endif
851
852 RETURN
integer, dimension(:), allocatable istvar
integer, dimension(:), allocatable n
type(t_domain), dimension(:), allocatable domain
integer, dimension(:), allocatable nt
logical, dimension(:,:,:), allocatable lobc
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
logical, dimension(:,:), allocatable lstflux
integer, dimension(:), allocatable nfrec
integer, parameter isouth
integer, parameter inorth
integer, dimension(:), allocatable nbrec
subroutine ad_mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
subroutine ad_mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c)
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
subroutine ad_mp_exchange3d_bry(ng, tile, model, nvar, boundary, lbij, ubij, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
subroutine ad_mp_exchange2d_bry(ng, tile, model, nvar, boundary, lbij, ubij, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)