- Timestamp:
- 2013-03-12T15:55:32+01:00 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchmod.F90
r3432 r3837 11 11 ! Make some key parameters from mapcomm_mod available to all who 12 12 ! USE this module 13 USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE 13 USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE, & 14 jeub 14 15 IMPLICIT none 15 16 … … 63 64 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dim. ndim_rank_north, number 64 65 ! of the procs belonging to ncomm_north 66 LOGICAL, SAVE :: do_nfold ! Whether this PE contributes to N-fold exchange 67 ! - takes domain trimming into account. 65 68 INTEGER, PARAMETER :: num_nfold_rows = 4 ! No. of rows at the top of the 66 69 ! global domain to use in applying 67 70 ! the north-fold condition (no value 68 ! other than 4 currently supported) 71 ! other than 4 currently tested) 72 73 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nfold_npts ! How many points each 74 ! northern proc contrib 75 ! to nfold exchange 69 76 70 77 !FTRANS r3dptr :I :I :z … … 112 119 nrank_north, north_root, ndim_rank_north, & 113 120 ngrp_north, ngrp_world, ncomm_north, & 121 num_nfold_rows, do_nfold, nfold_npts, & 114 122 exchmod_alloc, add_exch, bound_exch_list, & 115 Iminus, Iplus, Jminus, Jplus, NONE, num_nfold_rows, & 116 lbc_exch3, lbc_exch2, & !lbc_exch3i, lbc_exch2i, & 117 MPI_COMM_WORLD, MPI_Wtime 123 Iminus, Iplus, Jminus, Jplus, NONE, & 124 lbc_exch3, lbc_exch2 125 126 #if defined key_mpp_mpi 127 PUBLIC MPI_COMM_WORLD, MPI_Wtime 128 #endif 118 129 119 130 ! MPI only … … 285 296 286 297 SUBROUTINE bound_exch_generic ( b2, ib2, b3, ib3, nhalo, nhexch, & 287 comm1, comm2, comm3, comm4, &288 cd_type, lfill, isgn, lzero )298 comm1, comm2, comm3, comm4, & 299 cd_type, lfill, pval, isgn, lzero ) 289 300 USE par_oce, ONLY: wp, jpreci, jprecj, jpim1 290 301 USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, & 291 nperio, nbondi, npolj302 nperio, nbondi, npolj, narea 292 303 USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc 304 USE mapcomm_mod, ONLY: trimmed, eidx, widx 293 305 IMPLICIT none 294 306 INTEGER, INTENT(in) :: nhalo,nhexch … … 302 314 CHARACTER(len=1), INTENT(in) :: cd_type 303 315 LOGICAL, OPTIONAL, INTENT(in) :: lfill 316 REAL(wp),OPTIONAL, INTENT(in) :: pval ! background value (used at closed boundaries) 304 317 INTEGER, OPTIONAL, INTENT(in) :: isgn 305 LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to zero halos on closed boundaries318 LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to set halo values on closed boundaries 306 319 ! Local arguments 307 320 INTEGER :: itag ! Communication handle … … 310 323 INTEGER :: ileft, iright ! First and last x-coord of internal points 311 324 INTEGER :: kdim1 325 INTEGER :: iland ! Land values - zero by default unless pval passed in. 326 REAL(wp) :: zland ! " " 312 327 LOGICAL :: lfillarg, lzeroarg 313 328 !!-------------------------------------------------------------------- … … 324 339 lfillarg = .FALSE. 325 340 isgnarg = 1 341 zland = 0.0_wp 326 342 327 343 IF( PRESENT(lfill) ) lfillarg = lfill 328 344 IF( PRESENT(isgn) ) isgnarg = isgn 329 345 IF( PRESENT(lzero) ) lzeroarg = lzero 346 IF( PRESENT(pval) ) zland = pval 347 iland=INT(zland) 330 348 331 349 ! Find out the size of 3rd dimension of the array … … 356 374 ! have cyclic E-W boundary conditions. 357 375 ileft = nldi 358 IF(ilbext .AND. cyclic_bc)ileft = ileft + 1 376 IF( (ilbext .AND. (.NOT. trimmed(widx,narea))) .AND. cyclic_bc) & 377 ileft = ileft + 1 359 378 360 379 iright = nlei 361 IF(iubext .AND. cyclic_bc)iright = iright - 1 380 IF( (iubext .AND. (.NOT. trimmed(eidx,narea))) .AND. cyclic_bc) & 381 iright = iright - 1 362 382 363 383 IF ( PRESENT(b2) ) THEN … … 527 547 END IF 528 548 529 ELSE ! lfillarg is .FALSE. 549 ELSE ! lfillarg is .FALSE. - standard closed or cyclic treatment 530 550 531 551 ! ! East-West boundaries 532 552 ! ! ==================== 553 ! nbondi == 2 when a single sub-domain spans the whole width 554 ! of the global domain 533 555 IF( nbondi == 2 .AND. & ! Cyclic east-west 534 556 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN … … 568 590 SELECT CASE ( cd_type ) 569 591 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 570 b2(1:jpreci , :) = 0._wp! Western halo571 b2(nlci-jpreci+1:jpi, :) = 0._wp! Eastern halo592 b2(1:jpreci , :) = zland ! Western halo 593 b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo 572 594 CASE ( 'F' ) 573 b2(nlci-jpreci+1:jpi, :) = 0._wp! Eastern halo595 b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo 574 596 END SELECT 575 597 ELSE IF ( PRESENT(ib2) ) THEN 576 598 SELECT CASE ( cd_type ) 577 599 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 578 ib2(1:jpreci , :) = 0! Western halo579 ib2(nlci-jpreci+1:jpi, :) = 0! Eastern halo600 ib2(1:jpreci , :) = iland ! Western halo 601 ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo 580 602 CASE ( 'F' ) 581 ib2(nlci-jpreci+1:jpi, :) = 0! Eastern halo603 ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo 582 604 END SELECT 583 605 ELSE IF ( PRESENT(b3) ) THEN … … 588 610 DO ji=1,jpreci,1 589 611 DO jk=1,jpk,1 590 b3(ji, jj, jk) = 0._wp612 b3(ji, jj, jk) = zland 591 613 END DO 592 614 END DO 593 615 DO ji=nlci-jpreci+1,jpi,1 594 616 DO jk=1,jpk,1 595 b3(ji, jj, jk) = 0._wp617 b3(ji, jj, jk) = zland 596 618 END DO 597 619 END DO 598 620 END DO 599 621 #else 600 b3(1:jpreci , :, :) = 0._wp601 b3(nlci-jpreci+1:jpi, :, :) = 0._wp622 b3(1:jpreci , :, :) = zland 623 b3(nlci-jpreci+1:jpi, :, :) = zland 602 624 #endif 603 625 CASE ( 'F' ) … … 606 628 DO ji = nlci-jpreci+1,jpi,1 607 629 DO jk = 1,jpk,1 608 b3(ji, jj, jk) = 0._wp630 b3(ji, jj, jk) = zland 609 631 END DO 610 632 END DO 611 633 END DO 612 634 #else 613 b3(nlci-jpreci+1:jpi, :, :) = 0._wp635 b3(nlci-jpreci+1:jpi, :, :) = zland 614 636 #endif 615 637 END SELECT … … 617 639 SELECT CASE ( cd_type ) 618 640 CASE ( 'T', 'U', 'V', 'W' ) 619 ib3(1:jpreci , :, :) = 0620 ib3(nlci-jpreci+1:jpi, :, :) = 0641 ib3(1:jpreci , :, :) = iland 642 ib3(nlci-jpreci+1:jpi, :, :) = iland 621 643 CASE ( 'F' ) 622 ib3(nlci-jpreci+1:jpi, :, :) = 0644 ib3(nlci-jpreci+1:jpi, :, :) = iland 623 645 END SELECT 624 646 END IF … … 630 652 IF( lzeroarg )THEN 631 653 632 ! ! North-South boundaries633 ! 654 ! ! North-South boundaries (always closed) 655 ! ! ====================== 634 656 IF ( PRESENT(b2) ) THEN 635 657 SELECT CASE ( cd_type ) 636 658 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 637 b2(:,1:nldj-1 ) = 0._wp 638 b2(:,nlcj-jprecj+1:jpj) = 0._wp 659 !b2(:,1:nldj-1 ) = zland 660 ! Below is what is done in original lib_mpp.F90 661 b2(:,1:jprecj ) = zland 662 b2(:,nlcj-jprecj+1:jpj) = zland 639 663 CASE ( 'F' ) 640 b2(:,nlcj-jprecj+1:jpj) = 0._wp664 b2(:,nlcj-jprecj+1:jpj) = zland 641 665 END SELECT 642 666 ELSE IF ( PRESENT(ib2) ) THEN 643 667 SELECT CASE ( cd_type ) 644 668 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 645 ib2(:,1:jprecj ) = 0646 ib2(:,nlcj-jprecj+1:jpj) = 0669 ib2(:,1:jprecj ) = iland 670 ib2(:,nlcj-jprecj+1:jpj) = iland 647 671 CASE ( 'F' ) 648 ib2(:,nlcj-jprecj+1:jpj) = 0672 ib2(:,nlcj-jprecj+1:jpj) = iland 649 673 END SELECT 650 674 ELSE IF ( PRESENT(b3) ) THEN … … 652 676 CASE ( 'T', 'U', 'V', 'W' ) 653 677 #if defined key_z_first 654 DO jj=1, nldj-1,1678 DO jj=1,jprecj,1 655 679 DO ji=1,jpi,1 656 680 DO jk = 1,jpk,1 657 b3(ji, jj, jk) = 0._wp681 b3(ji, jj, jk) = zland 658 682 END DO 659 683 END DO … … 662 686 DO ji=1,jpi,1 663 687 DO jk = 1,jpk,1 664 b3(ji, jj, jk) = 0._wp688 b3(ji, jj, jk) = zland 665 689 END DO 666 690 END DO 667 691 END DO 668 692 #else 669 b3(:, 1: nldj-1 , :) = 0._wp670 b3(:, nlcj-jprecj+1:jpj, :) = 0._wp693 b3(:, 1:jprecj , :) = zland 694 b3(:, nlcj-jprecj+1:jpj, :) = zland 671 695 #endif 672 696 CASE ( 'F' ) … … 675 699 DO ji=1,jpi,1 676 700 DO jk = 1,jpk,1 677 b3(ji, jj, jk) = 0._wp701 b3(ji, jj, jk) = zland 678 702 END DO 679 703 END DO 680 704 END DO 681 705 #else 682 b3(:, nlcj-jprecj+1:jpj, :) = 0._wp706 b3(:, nlcj-jprecj+1:jpj, :) = zland 683 707 #endif 684 708 END SELECT … … 686 710 SELECT CASE ( cd_type ) 687 711 CASE ( 'T', 'U', 'V', 'W' ) 688 ib3(:, 1:jprecj , :) = 0689 ib3(:, nlcj-jprecj+1:jpj, :) = 0712 ib3(:, 1:jprecj , :) = iland 713 ib3(:, nlcj-jprecj+1:jpj, :) = iland 690 714 CASE ( 'F' ) 691 ib3(:, nlcj-jprecj+1:jpj, :) = 0715 ib3(:, nlcj-jprecj+1:jpj, :) = iland 692 716 END SELECT 693 717 END IF … … 726 750 ! We only need to repeat the East and West halo swap if there 727 751 ! IS a north-fold in the configuration. 728 SELECT CASE (npolj) 729 730 CASE ( 3, 4, 5, 6 ) 731 732 ! Update East and West halos as required 752 !SELECT CASE (npolj) 753 754 !CASE ( 3, 4, 5, 6 ) 755 IF(ndim_rank_north > 0)THEN 756 757 ! Update East and West halos as required - no data sent north 758 ! as it's only the northern-most PEs that have been affected 759 ! by the north-fold condition. 733 760 ! ARPDBG - inefficient since all PEs do halo swap and only 734 761 ! those affected by the north fold actually need to - can 735 762 ! this be done within apply_north_fold? 736 763 CALL exchs_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, & 737 nhexch=nhexch, handle=itag, &738 comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE, &739 cd_type=cd_type, lfill=lfillarg)764 nhexch=nhexch, handle=itag, & 765 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 766 cd_type=cd_type, lfill=lfillarg) 740 767 741 768 !CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, & … … 743 770 ! comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE) 744 771 ! comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 ) 745 END SELECT ! npolj 772 END IF ! ndim_rank_north > 0 773 !END SELECT ! npolj 746 774 747 775 END IF … … 1160 1188 1161 1189 DO ifield = 1, nfields, 1 1162 IF( npolj /= 0 )THEN ! only for northern procs.1190 IF( npolj /= 0 .AND. do_nfold )THEN ! only for northern procs. 1163 1191 1164 1192 IF(ASSOCIATED(list(ifield)%r2dptr))THEN … … 1180 1208 END DO 1181 1209 1182 !!$ IF( npolj /= 0 ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs.1210 !!$ IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs. 1183 1211 1184 1212 END SELECT ! jpni … … 1943 1971 1944 1972 CASE DEFAULT ! more than 1 proc along I 1945 IF( npolj /= 0 )CALL mpp_lbc_north( b2, cd_type, psgn ) ! only for northern procs.1973 IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north( b2, cd_type, psgn ) ! only for northern procs. 1946 1974 1947 1975 END SELECT ! jpni … … 2074 2102 2075 2103 CASE DEFAULT ! more than 1 proc along I 2076 IF( npolj /= 0 )CALL mpp_lbc_north( ib2, cd_type, isgn ) ! only for northern procs.2104 IF( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north( ib2, cd_type, isgn ) ! only for northern procs. 2077 2105 2078 2106 END SELECT ! jpni … … 2285 2313 2286 2314 CASE DEFAULT ! more than 1 proc along I 2287 IF ( npolj /= 0 ) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs.2315 IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs. 2288 2316 2289 2317 END SELECT ! jpni … … 2493 2521 2494 2522 CASE DEFAULT ! more than 1 proc along I 2495 IF ( npolj /= 0 ) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs.2523 IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs. 2496 2524 2497 2525 END SELECT ! jpni … … 2557 2585 ELSE 2558 2586 ! This section is both for error checking and allows me to be lazy in the 2559 ! testing code - I don't have to check which arrays I've been passed. 2587 ! testing code - I don't have to check which arrays I've been passed 2588 ! before I call this routine. 2560 2589 WRITE (*,*) 'WARNING: add_exch called without a ptr to an array - will be ignored' 2561 2590 RETURN … … 2588 2617 SUBROUTINE bound_exch2 (b, nhalo, nhexch, & 2589 2618 comm1, comm2, comm3, comm4, & 2590 cd_type, lfill, isgn, lzero )2619 cd_type, lfill, pval, isgn, lzero ) 2591 2620 !!---------------------------------------------------------------------- 2592 2621 !!---------------------------------------------------------------------- … … 2600 2629 INTEGER, OPTIONAL, INTENT(in) :: isgn 2601 2630 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2631 REAL(wp),OPTIONAL, INTENT(in) :: pval 2602 2632 2603 2633 CALL bound_exch_generic( b2=b,nhalo=nhalo,nhexch=nhexch, & 2604 2634 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2605 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2635 cd_type=cd_type, lfill=lfill, pval=pval, & 2636 isgn=isgn, lzero=lzero ) 2606 2637 RETURN 2607 2638 END SUBROUTINE bound_exch2 … … 2609 2640 2610 2641 SUBROUTINE bound_exch2i (b, nhalo, nhexch, comm1, comm2, comm3, comm4, & 2611 cd_type, lfill, isgn, lzero )2642 cd_type, lfill, pval, isgn, lzero ) 2612 2643 !!---------------------------------------------------------------------- 2613 2644 !!---------------------------------------------------------------------- … … 2621 2652 INTEGER, OPTIONAL, INTENT(in) :: isgn 2622 2653 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2654 REAL(wp),OPTIONAL, INTENT(in) :: pval 2623 2655 2624 2656 CALL bound_exch_generic (ib2=b,nhalo=nhalo,nhexch=nhexch, & 2625 2657 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2626 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2658 cd_type=cd_type, lfill=lfill, pval=pval, & 2659 isgn=isgn, lzero=lzero ) 2627 2660 RETURN 2628 2661 END SUBROUTINE bound_exch2i … … 2630 2663 2631 2664 SUBROUTINE bound_exch3 (b, nhalo, nhexch, comm1, comm2, comm3, & 2632 comm4, cd_type, lfill, isgn, lzero)2665 comm4, cd_type, lfill, pval, isgn, lzero) 2633 2666 !!---------------------------------------------------------------------- 2634 2667 !!---------------------------------------------------------------------- … … 2642 2675 INTEGER, OPTIONAL, INTENT(in) :: isgn 2643 2676 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2677 REAL(wp),OPTIONAL, INTENT(in) :: pval 2644 2678 2645 2679 CALL bound_exch_generic ( b3=b,nhalo=nhalo,nhexch=nhexch,& 2646 2680 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2647 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2681 cd_type=cd_type, lfill=lfill, pval=pval, & 2682 isgn=isgn, lzero=lzero ) 2648 2683 RETURN 2649 2684 END SUBROUTINE bound_exch3 … … 2651 2686 2652 2687 SUBROUTINE bound_exch3i (b, nhalo, nhexch, comm1, comm2, comm3, & 2653 comm4, cd_type, lfill, isgn, lzero)2688 comm4, cd_type, lfill, pval, isgn, lzero) 2654 2689 !!---------------------------------------------------------------------- 2655 2690 !!---------------------------------------------------------------------- … … 2662 2697 INTEGER, OPTIONAL, INTENT(in) :: isgn 2663 2698 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2699 REAL(wp),OPTIONAL, INTENT(in) :: pval 2664 2700 2665 2701 CALL bound_exch_generic ( ib3=b,nhalo=nhalo,nhexch=nhexch, & 2666 2702 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2667 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2703 cd_type=cd_type, lfill=lfill, pval=pval, & 2704 isgn=isgn, lzero=lzero ) 2668 2705 2669 2706 END SUBROUTINE bound_exch3i … … 2695 2732 LOGICAL :: lfill 2696 2733 2697 ! ARPDBG - don't know whether pval currently maps into exchmod framework2698 IF(PRESENT(pval))THEN2699 CALL ctl_stop('STOP','lbc_exch2: got pval argument - NOT IMPLEMENTED')2700 RETURN2701 END IF2702 2703 2734 lfill = .FALSE. 2704 2735 IF(PRESENT(cd_mpp))THEN … … 2708 2739 CALL bound_exch_generic( b2=pt2d,nhalo=jpreci,nhexch=jpreci, & 2709 2740 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 2710 cd_type=cd_type, lfill=lfill, isgn=INT(psgn), lzero=lzero ) 2741 cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), & 2742 lzero=lzero ) 2711 2743 2712 2744 END SUBROUTINE lbc_exch2 … … 2731 2763 LOGICAL :: lfill 2732 2764 2733 ! ARPDBG - don't know whether pval currently maps into exchmod framework2734 IF(PRESENT(pval))THEN2735 CALL ctl_stop('STOP','lbc_exch3: got pval argument - NOT IMPLEMENTED')2736 RETURN2737 END IF2738 2739 2765 lfill = .FALSE. 2740 2766 IF(PRESENT(cd_mpp))THEN … … 2742 2768 END IF 2743 2769 2744 CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci,& 2745 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 2746 cd_type=cd_type, lfill=lfill, isgn=INT(psgn), lzero=lzero ) 2770 CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci, & 2771 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 2772 cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), & 2773 lzero=lzero ) 2747 2774 2748 2775 END SUBROUTINE lbc_exch3 … … 2773 2800 USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & 2774 2801 IminusJminus, IplusJminus, IminusJplus, & 2775 nsend, nxsend, nysend, nxsendp,nysendp,nsendp, & 2802 nsend, nxsend, nysend, nxsendp,nysendp,nzsendp, & 2803 nsendp, & 2776 2804 destination,dirsend, dirrecv, & 2777 2805 isrcsendp,jsrcsendp, idesrecvp, jdesrecvp, & 2778 nrecv, nxrecv,nyrecv,nxrecvp,nyrecvp,nrecvp, & 2806 nrecv, & 2807 nxrecvp,nyrecvp,nzrecvp, nrecvp, nrecvp2d, & 2779 2808 source, iesub, jesub, & 2780 2809 MaxCommDir, MaxComm, cyclic_bc, & 2781 2810 nrecvp, npatchsend, npatchrecv 2782 USE lib_mpp, ONLY: mpi_comm_opa, ctl_stop 2811 USE lib_mpp, ONLY: ctl_stop 2812 #if defined key_mpp_mpi 2813 USE lib_mpp, ONLY: mpi_comm_opa 2814 #endif 2783 2815 #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS 2784 2816 USE dom_oce, ONLY: narea … … 2793 2825 2794 2826 LOGICAL :: enabled(0:MaxCommDir, maxExchItems) 2795 INTEGER :: ides, ierr, irecv, isend, & 2796 isrc, jdes, jsrc, nxr, nyr, & 2797 nxs, nys, tag, tag_orig, & 2827 INTEGER :: ides, ierr, irecv, isend, & 2828 isrc, jdes, jsrc, tag, tag_orig, & 2798 2829 ibeg, iend, jbeg, jend 2799 2830 INTEGER :: i, j, k, ic, ifield, ipatch ! Loop counters … … 2801 2832 INTEGER :: npacked 2802 2833 INTEGER :: handle 2834 #if defined key_mpp_mpi 2803 2835 INTEGER :: status(MPI_status_size) 2804 2836 INTEGER :: astatus(MPI_status_size,MaxComm) 2837 #endif 2805 2838 INTEGER :: r2dcount, r3dcount, i2dcount, i3dcount 2806 2839 ! Indices into int and real copy buffers … … 2826 2859 #endif 2827 2860 2828 CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat)2861 !CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat) 2829 2862 2830 2863 ! Allocate a communications tag/handle and a flags array. … … 2841 2874 ! Check halo width is in range. 2842 2875 IF ( list(ifield)%halo_width.GT.jpreci ) THEN 2843 CALL ctl_stop('STOP','exchs: halo width greater than maximum') 2876 CALL ctl_stop('STOP', & 2877 'exchs_generic_list: halo width greater than maximum') 2844 2878 RETURN 2845 2879 ENDIF … … 2881 2915 IF( have_real_field )THEN 2882 2916 2883 ALLOCATE(recvBuff( jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)2917 ALLOCATE(recvBuff(maxrecvpts*nfields,nrecv),stat=ierr) 2884 2918 !WRITE(*,"('Allocated ',I7,' reals for recv buff')") & 2885 2919 ! jpkdta*maxrecvpts*nfields … … 2898 2932 IF( have_int_field .AND. (ierr == 0) )THEN 2899 2933 2900 ALLOCATE(recvIBuff( jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)2934 ALLOCATE(recvIBuff(maxrecvpts*nfields,nrecv),stat=ierr) 2901 2935 !WRITE(*,"('Allocated ',I7,' ints for recv buff')") & 2902 2936 ! jpkdta*maxrecvpts*nfields … … 2927 2961 i3dcount = 0 2928 2962 2929 IF(source(irecv).GE.0 .AND. nrecvp(irecv,1).GT.0 ) THEN 2963 IF( source(irecv).GE.0 .AND. & 2964 ( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN 2930 2965 2931 2966 ! This loop is to allow for different fields to have different … … 2935 2970 IF ( enabled(dirrecv(irecv), ifield) ) THEN 2936 2971 IF( ASSOCIATED(list(ifield)%r2dptr) )THEN 2937 r2dcount = r2dcount + 12972 r2dcount = r2dcount + nrecvp2d(irecv,1) 2938 2973 ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN 2939 i2dcount = i2dcount + 12974 i2dcount = i2dcount + nrecvp2d(irecv,1) 2940 2975 ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN 2941 2976 ! Allow for varying size of third dimension 2942 r3dcount = r3dcount + SIZE(list(ifield)%r3dptr, index_z)2977 r3dcount = r3dcount + nrecvp(irecv,1) 2943 2978 ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN 2944 2979 ! Allow for varying size of third dimension 2945 i3dcount = i3dcount + SIZE(list(ifield)%i3dptr, index_z)2980 i3dcount = i3dcount + nrecvp(irecv,1) 2946 2981 END IF 2947 2982 END IF … … 2957 2992 2958 2993 IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN 2959 CALL MPI_irecv (recvBuff(1,irecv),( (r2dcount+r3dcount)*nrecvp(irecv,1)), &2994 CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount), & 2960 2995 MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, & 2961 2996 exch_flags(handle,irecv,indexr), ierr) 2962 2997 END IF 2963 2998 IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN 2964 CALL MPI_irecv (recvIBuff(1,irecv),( (i2dcount+i3dcount)*nrecvp(irecv,1)), &2999 CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount), & 2965 3000 MPI_INTEGER, source(irecv),tag, mpi_comm_opa, & 2966 3001 exch_flags(handle,irecv,indexr),ierr) … … 2993 3028 2994 3029 ierr = 0 2995 newSize = jpkdta*maxsendpts*nfields3030 newSize = maxsendpts*nfields 2996 3031 IF( have_real_field .AND. newSize > sendBuffSize)THEN 2997 3032 sendBuffSize=newSize … … 3010 3045 3011 3046 IF (ierr .ne. 0) THEN 3012 WRITE(*,*) 'ARPDBG: failed to allocate send buf'3013 3047 CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff') 3014 3048 END IF … … 3111 3145 DO j=jbeg, jend, 1 3112 3146 DO i=ibeg, iend, 1 3113 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3114 #else 3115 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3147 !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3148 DO k=1, nzsendp(ipatch,isend,1), 1 3149 #else 3150 !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3151 DO k=1, nzsendp(ipatch,isend,1), 1 3116 3152 DO j=jbeg, jend, 1 3117 3153 DO i=ibeg, iend, 1 … … 3124 3160 3125 3161 npacked = nxsendp(ipatch,isend,1) * & 3126 nysendp(ipatch,isend,1) 3127 rstart = rstart + npacked*SIZE(list(ifield)%r3dptr, index_z) 3128 r3dcount = r3dcount + npacked*SIZE(list(ifield)%r3dptr, index_z) 3162 nysendp(ipatch,isend,1) * & 3163 nzsendp(ipatch,isend,1) 3164 rstart = rstart + npacked 3165 r3dcount = r3dcount + npacked 3166 3129 3167 END DO pack_patches3r 3130 3168 … … 3143 3181 DO j=jbeg, jend, 1 3144 3182 DO i=ibeg, iend, 1 3145 DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3146 #else 3147 DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3183 !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3184 DO k=1, nzsendp(ipatch,isend,1), 1 3185 #else 3186 !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3187 DO k=1, nzsendp(ipatch,isend,1), 1 3148 3188 DO j=jbeg, jend, 1 3149 3189 DO i=ibeg, iend, 1 … … 3155 3195 END DO 3156 3196 3157 istart = istart + nxs*nys*SIZE(list(ifield)%i3dptr, index_z) 3158 i3dcount = i3dcount + nxs*nys*SIZE(list(ifield)%i3dptr, index_z) 3197 npacked = nxsendp(ipatch,isend,1)* & 3198 nysendp(ipatch,isend,1)* & 3199 nzsendp(ipatch,isend,1) 3200 istart = istart + npacked 3201 i3dcount = i3dcount + npacked 3159 3202 END DO pack_patches3i 3160 3203 … … 3172 3215 ! Now do the send(s) for all fields 3173 3216 IF(r2dcount > 0 .OR. r3dcount > 0 )THEN 3174 CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount),MPI_DOUBLE_PRECISION, & 3175 destination(isend),tag,mpi_comm_opa, & 3217 CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), & 3218 MPI_DOUBLE_PRECISION, & 3219 destination(isend),tag,mpi_comm_opa, & 3176 3220 exch_flags(handle,isend,indexs),ierr) 3177 3221 END IF … … 3228 3272 3229 3273 ! Increment starting index for next field data in buffer 3230 rstart = rstart + nrecvp(irecv,1)3274 rstart = ic + 1 !rstart + nrecvp(irecv,1) 3231 3275 3232 3276 ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN … … 3250 3294 3251 3295 ! Increment starting index for next field data in buffer 3252 istart = i start + nrecvp(irecv,1)3296 istart = ic + 1 !istart + nrecvp(irecv,1) 3253 3297 3254 3298 ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN … … 3264 3308 DO j=jbeg, jend, 1 3265 3309 DO i=ibeg, iend, 1 3266 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 13267 #else 3268 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 13310 DO k=1, nzrecvp(ipatch,irecv,1), 1 3311 #else 3312 DO k=1, nzrecvp(ipatch,irecv,1), 1 3269 3313 DO j=jbeg, jend, 1 3270 3314 DO i=ibeg, iend, 1 … … 3278 3322 3279 3323 ! Increment starting index for next field data in buffer 3280 rstart = rstart + nrecvp(irecv,1)*SIZE(list(ifield)%r3dptr,index_z)3324 rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z) 3281 3325 3282 3326 ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN … … 3292 3336 DO j=jbeg, jend, 1 3293 3337 DO i=ibeg, iend, 1 3294 DO k=1, SIZE(list(ifield)%i3dptr,index_z),13295 #else 3296 DO k=1, SIZE(list(ifield)%i3dptr,index_z),13338 DO k=1,nzrecvp(ipatch,irecv,1),1 3339 #else 3340 DO k=1,nzrecvp(ipatch,irecv,1),1 3297 3341 DO j=jbeg, jend, 1 3298 3342 DO i=ibeg, iend, 1 … … 3306 3350 3307 3351 ! Increment starting index for next field data in buffer 3308 istart = i start + nrecvp(irecv,1)*SIZE(list(ifield)%i3dptr,index_z)3352 istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z) 3309 3353 3310 3354 END IF … … 3395 3439 CALL free_exch_handle(handle) 3396 3440 3397 CALL prof_region_end(ARPEXCHS_LIST, iprofStat)3441 !CALL prof_region_end(ARPEXCHS_LIST, iprofStat) 3398 3442 3399 3443 END SUBROUTINE exchs_generic_list … … 3431 3475 ! ******************************************************************* 3432 3476 USE par_oce, ONLY: wp, jpreci, jprecj, jpni, jpkdta 3433 USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & 3434 IminusJminus, IplusJminus, IminusJplus, & 3435 nrecv, nsend, nrecvp, nsendp, nxsend,nysend,& 3436 destination,dirsend, dirrecv, & 3437 isrcsend, jsrcsend, idesrecv, jdesrecv, & 3438 isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, & 3439 nxrecv,nyrecv,source, iesub, jesub, & 3440 MaxCommDir, MaxComm, idessend, jdessend, & 3441 nxsendp, nysendp, nxrecvp, nyrecvp, & 3442 npatchsend, npatchrecv, & 3443 cyclic_bc 3444 USE lib_mpp, ONLY: mpi_comm_opa, ctl_stop 3477 USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & 3478 IminusJminus, IplusJminus, IminusJplus, & 3479 nrecv, nsend, nrecvp, nsendp, & 3480 nrecvp2d, nsendp2d, nxsend, nysend, & 3481 destination,dirsend, dirrecv, & 3482 isrcsend, jsrcsend, idesrecv, jdesrecv, & 3483 isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, & 3484 nxrecv,source, iesub, jesub, & 3485 MaxCommDir, MaxComm, idessend, jdessend, & 3486 nxsendp, nysendp, nzsendp, & 3487 nxrecvp, nyrecvp, nzrecvp, & 3488 npatchsend, npatchrecv, cyclic_bc 3489 USE lib_mpp, ONLY: ctl_stop 3490 #if defined key_mpp_mpi 3491 USE lib_mpp, ONLY: mpi_comm_opa 3492 #endif 3445 3493 USE dom_oce, ONLY: narea 3446 3494 USE in_out_manager, ONLY: numout … … 3474 3522 INTEGER :: index ! To hold index returned from MPI_waitany 3475 3523 INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes 3524 #if defined key_mpp_mpi 3476 3525 INTEGER :: status(MPI_status_size) 3477 3526 INTEGER :: astatus(MPI_status_size,MaxComm) 3527 #endif 3478 3528 LOGICAL, SAVE :: first_time = .TRUE. 3479 3529 #if defined key_z_first … … 3489 3539 3490 3540 !CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat) 3491 !CALL timing_start('exchs_generic')3541 !CALL timing_start('exchs_generic') 3492 3542 3493 3543 ierr = 0 3494 3544 3495 ! Find out the sizes of the arrays.3496 3497 kdim1 = 13498 IF ( PRESENT(b3) ) THEN3499 kdim1 = SIZE(b3,dim=index_z)3500 ELSEIF ( PRESENT(ib3) ) THEN3501 kdim1 = SIZE(ib3,dim=index_z)3502 ELSEIF ( PRESENT(b2) ) THEN3503 kdim1 = SIZE(b2,dim=2)3504 ELSEIF ( PRESENT(ib2) ) THEN3505 kdim1 = SIZE(ib2,dim=2)3506 ENDIF3507 3508 3545 ! Check nhexch is in range. 3509 3546 3510 3547 IF ( nhexch.GT.jpreci ) THEN 3511 STOP 'exchs: halo width greater than maximum'3548 CALL ctl_stop('STOP','exchs: halo width greater than maximum') 3512 3549 ENDIF 3513 3550 … … 3544 3581 IF(.NOT. ALLOCATED(sendBuff))THEN 3545 3582 ! Only allocate the sendBuff once 3546 ALLOCATE(recvBuff( jpkdta*maxrecvpts,nrecv), &3547 sendBuff( jpkdta*maxsendpts,nsend),stat=ierr)3583 ALLOCATE(recvBuff(maxrecvpts,nrecv), & 3584 sendBuff(maxsendpts,nsend),stat=ierr) 3548 3585 ELSE 3549 ALLOCATE(recvBuff( jpkdta*maxrecvpts,nrecv),stat=ierr)3586 ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr) 3550 3587 END IF 3551 3588 ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN 3552 3589 IF(.NOT. ALLOCATED(sendIBuff))THEN 3553 ALLOCATE(recvIBuff( jpkdta*maxrecvpts,nrecv), &3554 sendIBuff( jpkdta*maxsendpts,nsend),stat=ierr)3590 ALLOCATE(recvIBuff(maxrecvpts,nrecv), & 3591 sendIBuff(maxsendpts,nsend),stat=ierr) 3555 3592 ELSE 3556 ALLOCATE(recvIBuff( jpkdta*maxrecvpts,nrecv),stat=ierr)3593 ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr) 3557 3594 END IF 3558 3595 END IF … … 3578 3615 ! that isn't used 3579 3616 IF ( PRESENT(b2) ) THEN 3580 CALL MPI_irecv (recvBuff(1,irecv),nrecvp (irecv,1),&3617 CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), & 3581 3618 MPI_DOUBLE_PRECISION, source(irecv), & 3582 3619 tag, mpi_comm_opa, & 3583 3620 exch_flags(handle,irecv,indexr), ierr) 3584 3621 ELSEIF ( PRESENT(ib2) ) THEN 3622 CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), & 3623 MPI_INTEGER, source(irecv), & 3624 tag, mpi_comm_opa, & 3625 exch_flags(handle,irecv,indexr),ierr) 3626 ELSEIF ( PRESENT(b3) ) THEN 3627 CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1), & 3628 MPI_DOUBLE_PRECISION, source(irecv), & 3629 tag, mpi_comm_opa, & 3630 exch_flags(handle,irecv,indexr),ierr) 3631 ELSEIF ( PRESENT(ib3) ) THEN 3585 3632 CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), & 3586 3633 MPI_INTEGER, source(irecv), & 3587 3634 tag, mpi_comm_opa, & 3588 3635 exch_flags(handle,irecv,indexr),ierr) 3589 ELSEIF ( PRESENT(b3) ) THEN3590 CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1)*kdim1, &3591 MPI_DOUBLE_PRECISION, source(irecv), &3592 tag, mpi_comm_opa, &3593 exch_flags(handle,irecv,indexr),ierr)3594 ELSEIF ( PRESENT(ib3) ) THEN3595 CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1)*kdim1, &3596 MPI_INTEGER, source(irecv), &3597 tag, mpi_comm_opa, &3598 exch_flags(handle,irecv,indexr),ierr)3599 3636 ENDIF 3600 IF ( ierr.NE.0 ) THEN 3601 WRITE (numout,*) 'ARPDBG - irecv hit error' 3602 CALL flush(numout) 3603 CALL MPI_abort(mpi_comm_opa,1,ierr) 3604 END IF 3637 ! No point checking for MPI errors because default MPI error handler 3638 ! aborts run without returning control to calling program. 3639 !IF ( ierr.NE.0 ) THEN 3640 ! WRITE (numout,*) 'ARPDBG - irecv hit error' 3641 ! CALL flush(numout) 3642 ! CALL MPI_abort(mpi_comm_opa,1,ierr) 3643 !END IF 3605 3644 3606 3645 #if defined DEBUG_COMMS 3607 3646 WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") & 3608 3647 narea-1,handle,dirrecv(irecv), & 3609 source(irecv), tag, nrecvp(irecv,1) *kdim13648 source(irecv), tag, nrecvp(irecv,1) 3610 3649 #endif 3611 3650 … … 3635 3674 3636 3675 IF ( enabled(dirsend(isend)) .AND. & 3637 destination(isend) .GE.0 .AND. nxsend(isend).GT.0 ) THEN3676 destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN 3638 3677 3639 3678 isrc = isrcsend(isend) … … 3647 3686 IF(PRESENT(b3))THEN 3648 3687 WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & 3649 narea-1, handle, tag, destination(isend),nsendp(isend,1) *kdim1,dirsend(isend)3688 narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend) 3650 3689 ELSE IF(PRESENT(b2))THEN 3651 3690 WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & 3652 narea-1, handle, tag, destination(isend),nsendp (isend,1),dirsend(isend)3691 narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend) 3653 3692 END IF 3654 3693 #endif … … 3673 3712 END DO 3674 3713 3714 !!$ ! For 'stupid' compiler that refuses to do a memcpy for above 3675 3715 !!$ CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), & 3676 3716 !!$ b2(istart,jstart), & … … 3709 3749 ELSEIF ( PRESENT(b3) )THEN 3710 3750 3711 !CALL timing_start('3dr_pack')3751 ! CALL timing_start('3dr_pack') 3712 3752 ic = 0 3713 3753 pack_patches3r: DO ipatch=1,npatchsend(isend,1) … … 3720 3760 DO j=jstart, jend, 1 3721 3761 DO i=istart, iend, 1 3722 DO k=1, kdim1,13723 #else 3724 DO k=1, kdim1,13762 DO k=1,nzsendp(ipatch,isend,1),1 3763 #else 3764 DO k=1,nzsendp(ipatch,isend,1),1 3725 3765 DO j=jstart, jend, 1 3726 3766 DO i=istart, iend, 1 … … 3732 3772 END DO 3733 3773 END DO pack_patches3r 3734 ! CALL timing_stop('3dr_pack') 3774 3775 ! CALL timing_stop('3dr_pack') 3735 3776 3736 3777 CALL MPI_Isend(sendBuff(1,isend),ic, & … … 3740 3781 3741 3782 #if defined DEBUG_COMMS 3742 WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &3783 WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") & 3743 3784 narea-1, npatchsend(isend,1),ic, & 3744 3785 destination(isend) … … 3756 3797 DO j=jstart, jend, 1 3757 3798 DO i=istart, iend, 1 3758 DO k=1, kdim1,13759 #else 3760 DO k=1, kdim1,13799 DO k=1,nzsendp(ipatch,isend,1),1 3800 #else 3801 DO k=1,nzsendp(ipatch,isend,1),1 3761 3802 DO j=jstart, jend, 1 3762 3803 DO i=istart, iend, 1 … … 3775 3816 ENDIF 3776 3817 3777 IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)3818 !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) 3778 3819 3779 3820 ELSE … … 3785 3826 ENDDO ! Loop over sends 3786 3827 3787 !CALL timing_stop('mpi_sends')3828 ! CALL timing_stop('mpi_sends') 3788 3829 3789 3830 #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS … … 3793 3834 ! Wait on the receives that were posted earlier 3794 3835 3795 !CALL timing_start('mpi_recvs')3836 ! CALL timing_start('mpi_recvs') 3796 3837 3797 3838 ! Copy just the set of flags we're interested in for passing … … 3814 3855 WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1 3815 3856 END IF 3816 CALL ctl_stop('STOP' )3857 CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error') 3817 3858 END IF 3818 3859 … … 3821 3862 IF ( PRESENT(b2) ) THEN 3822 3863 3823 !CALL timing_start('2dr_unpack')3864 ! CALL timing_start('2dr_unpack') 3824 3865 3825 3866 ! Copy received data back into array … … 3839 3880 END DO unpack_patches2r 3840 3881 3841 !CALL timing_stop('2dr_unpack')3882 ! CALL timing_stop('2dr_unpack') 3842 3883 3843 3884 ELSE IF ( PRESENT(ib2) ) THEN … … 3861 3902 ELSE IF (PRESENT(b3) ) THEN 3862 3903 3863 !CALL timing_start('3dr_unpack')3904 ! CALL timing_start('3dr_unpack') 3864 3905 ic = 0 3865 3906 unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch) … … 3872 3913 DO j=jstart, jend, 1 3873 3914 DO i=istart, iend, 1 3874 DO k=1, kdim1,13875 #else 3876 DO k=1, kdim1,13915 DO k=1,nzrecvp(ipatch,irecv,1),1 3916 #else 3917 DO k=1,nzrecvp(ipatch,irecv,1),1 3877 3918 DO j=jstart, jend, 1 3878 3919 DO i=istart, iend, 1 … … 3881 3922 b3(i,j,k) = recvBuff(ic,irecv) 3882 3923 END DO 3924 #if defined key_z_first 3925 ! ARPDBG - wipe anything below the ocean bottom 3926 DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1 3927 b3(i,j,k) = 0.0_wp 3928 END DO 3929 #endif 3883 3930 END DO 3884 3931 END DO 3932 3933 ! ARPDBG - wipe anything below the ocean bottom 3934 #if ! defined key_z_first 3935 DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1 3936 DO j=jstart, jend, 1 3937 DO i=istart, iend, 1 3938 b3(i,j,k) = 0.0_wp 3939 END DO 3940 END DO 3941 END DO 3942 #endif 3943 3885 3944 END DO unpack_patches3r 3886 3945 … … 3899 3958 DO j=jstart, jend, 1 3900 3959 DO i=istart, iend, 1 3901 DO k=1, kdim1,13902 #else 3903 DO k=1, kdim1,13960 DO k=1,nzrecvp(ipatch,irecv,1),1 3961 #else 3962 DO k=1,nzrecvp(ipatch,irecv,1),1 3904 3963 DO j=jstart, jend, 1 3905 3964 DO i=istart, iend, 1 … … 3915 3974 3916 3975 CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr) 3917 IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)3976 !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) 3918 3977 3919 3978 END DO ! while irecv != MPI_UNDEFINED 3920 3979 3921 !CALL timing_stop('mpi_recvs')3980 ! CALL timing_stop('mpi_recvs') 3922 3981 3923 3982 ! All receives done and unpacked so can deallocate the associated 3924 3983 ! buffers 3925 IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)3926 IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)3984 !IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff) 3985 !IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff) 3927 3986 3928 3987 #if defined DEBUG_COMMS … … 3940 3999 ! loop! 3941 4000 IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN 4001 4002 ! Find out the sizes of the arrays. 4003 kdim1 = 1 4004 IF ( PRESENT(b3) ) THEN 4005 kdim1 = SIZE(b3,dim=index_z) 4006 ELSEIF ( PRESENT(ib3) ) THEN 4007 kdim1 = SIZE(ib3,dim=index_z) 4008 ENDIF 4009 3942 4010 3943 4011 IF ( enabled(Iplus) ) THEN … … 3996 4064 ENDIF 3997 4065 3998 ENDIF 4066 ENDIF ! cyclic_bc .AND. jpni == 1 3999 4067 4000 4068 ! Copy just the set of flags we're interested in for passing to … … 4009 4077 IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff) 4010 4078 4011 !CALL timing_stop('exchs_generic')4079 ! CALL timing_stop('exchs_generic') 4012 4080 !CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat) 4013 4081 … … 4313 4381 CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat) 4314 4382 4383 #if defined key_mpp_mpi 4384 4315 4385 ! If we get into this routine it's because : North fold condition and mpp 4316 4386 ! with more than one PE across i : we deal only with the North condition 4317 4387 4318 4388 ! Set no. of rows from a module parameter that is also used in exchtestmod 4389 ! and mpp_ini_north 4319 4390 ijpj = num_nfold_rows 4320 4391 … … 5244 5315 CALL prof_region_end(NORTHLISTSCATTER, iprofStat) 5245 5316 5317 #endif /* key_mpp_mpi */ 5318 5246 5319 CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat) 5247 5320 … … 5255 5328 !! 5256 5329 !! ** Purpose : 5257 !! Ensure proper north fold horizontal bondary condition in mpp configuration5258 !! in case of jpn1 > 1 (for 2d array )5330 !! Ensure proper north fold horizontal bondary condition in mpp 5331 !! configuration in case of jpn1 > 1 (for 2d array ) 5259 5332 !! 5260 5333 !! ** Method : … … 5266 5339 !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north 5267 5340 !! from lbc routine 5268 !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk 5341 !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding 5342 !! rules of lbc_lnk 5269 5343 !!---------------------------------------------------------------------- 5270 5344 USE par_oce, ONLY : jpni, jpi, jpj … … 5273 5347 USE mapcomm_mod, ONLY : pielb, piesub 5274 5348 USE lib_mpp, ONLY : ctl_stop 5349 USE arpdebugging, ONLY: dump_array 5275 5350 IMPLICIT none 5276 5351 !! * Arguments … … 5287 5362 !! * Local declarations 5288 5363 5289 INTEGER , PARAMETER :: ijpj = 45364 INTEGER :: ijpj 5290 5365 INTEGER :: ji, jj, jr, jproc 5291 5366 INTEGER :: ierr … … 5303 5378 ! with more than one PE across i : we deal only with the North condition 5304 5379 5380 ! Set local from public PARAMETER 5381 ijpj = num_nfold_rows 5382 5305 5383 CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat) 5306 5384 5385 #if defined key_mpp_mpi 5386 5307 5387 IF(.not. ALLOCATED(ztab2))THEN 5308 5388 5309 ALLOCATE(ztab2(jpiglo, 4), &5310 znorthgloio2(nwidthmax, 4,jpni), &5311 znorthloc2(nwidthmax, 4), &5389 ALLOCATE(ztab2(jpiglo,ijpj), & 5390 znorthgloio2(nwidthmax,ijpj,ndim_rank_north), & 5391 znorthloc2(nwidthmax,ijpj), & 5312 5392 STAT=ierr) 5313 5393 IF(ierr .ne. 0)THEN … … 5321 5401 ijpjm1=ijpj-1 5322 5402 5323 ! put the last 4jlines of pt2d into znorthloc25403 ! put the last ijpj jlines of pt2d into znorthloc2 5324 5404 znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax 5325 DO ij = 1, ijpj, 1 5405 5406 ! jeub is the upper j limit of current domain in global coords 5407 ! 5408 ! |======================= jpjglo ^ 5409 ! <Trimmed> | /|\ 5410 ! |----------------------- jpjglo-1 | 5411 ! | | 5412 ! |---------jeub-------------------------------- 5413 ! | | j 5414 ! |-------------------------------------------- 5415 ! | | | 5416 ! |-------------------------------------------- | 5417 ! 5418 ! No. of trimmed rows = jpjglo - jeub 5419 ! No. of valid rows for n-fold = ijpj - <no. trimmed rows> 5420 ! = ijpj - jpjglo + jeub 5421 ! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub) 5422 ! distinct values so start point must be: 5423 ! ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1 5424 ! => if jeub == jpjglo then we recover a starting value of 1. 5425 ! if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations 5426 ! will be performed. 5427 5428 #if defined NO_NFOLD_GATHER 5429 ! Post receives for other PE's north-fold data 5430 DO iproc = 1, ndim_rank_north, 1 5431 5432 IF( iproc-1 == nrank_north(iproc) ) CYCLE ! Skip this PE 5433 5434 CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, & 5435 nrank_north(iproc), iproc, tag, ncomm_north, & 5436 nexch_flag(iproc) ) 5437 END DO 5438 #endif 5439 5440 DO ij = jpjglo - jeub + 1, ijpj, 1 5441 5326 5442 jj = nlcj - ijpj + ij 5327 5443 znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj) 5328 5444 END DO 5445 5446 ! CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.) 5329 5447 5330 5448 IF (npolj /= 0 ) THEN … … 5335 5453 znorthgloio2,itaille,MPI_DOUBLE_PRECISION, & 5336 5454 0, ncomm_north, ierr) 5455 5337 5456 ENDIF 5338 5457 5339 5458 IF (narea == north_root+1 ) THEN 5340 5459 ! recover the global north array 5460 ! ztab2 has full width of global domain 5341 5461 ztab2(:,:) = 0_wp 5342 5462 … … 5350 5470 END DO 5351 5471 5472 ! CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.) 5352 5473 5353 5474 ! 2. North-Fold boundary conditions … … 5495 5616 ENDIF 5496 5617 5497 ! put in the last ijpj jlines of pt2d znorthloc2 5498 DO ij = 1, ijpj, 1 5618 ! Put the last ijpj jlines of pt2d into znorthloc2 while allowing 5619 ! for any trimming of domain (see earlier comments and diagram) 5620 DO ij = jpjglo - jeub + 1, ijpj, 1 5499 5621 jj = nlcj - ijpj + ij 5500 5622 pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij) 5501 5623 END DO 5624 5625 #endif /* key_mpp_mpi */ 5502 5626 5503 5627 CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat) … … 5512 5636 !! 5513 5637 !! ** Purpose : 5514 !! Ensure proper north fold horizontal bondary condition in mpp configuration5515 !! in case of jpn1 > 1 (for 2d array )5638 !! Ensure proper north fold horizontal bondary condition in mpp 5639 !! configuration in case of jpn1 > 1 (for 2d array ) 5516 5640 !! 5517 5641 !! ** Method : … … 5545 5669 !! * Local declarations 5546 5670 5547 INTEGER , PARAMETER :: ijpj = 45671 INTEGER :: ijpj 5548 5672 INTEGER :: ji, jj, jr, jproc 5549 5673 INTEGER :: ierr … … 5561 5685 ! with more than one PE across i : we deal only with the North condition 5562 5686 5687 #if defined key_mpp_mpi 5688 5689 ijpj = num_nfold_rows 5690 ijpjm1=ijpj - 1 5691 5692 5563 5693 IF(.not. ALLOCATED(ztab2))THEN 5564 5694 5565 ALLOCATE(ztab2(jpiglo, 4), &5566 znorthgloio2(nwidthmax, 4,jpni), &5567 znorthloc2(nwidthmax, 4), &5695 ALLOCATE(ztab2(jpiglo,ijpj), & 5696 znorthgloio2(nwidthmax,ijpj,jpni), & 5697 znorthloc2(nwidthmax,ijpj), & 5568 5698 STAT=ierr) 5569 5699 IF(ierr .ne. 0)THEN … … 5575 5705 ! --------------- 5576 5706 5577 ijpjm1=ijpj - 15578 5579 ! put in znorthloc2 the last 4 jlines of ib25707 ! Put the last ijpj jlines of ib2 into znorthloc2 while allowing 5708 ! for any trimming of domain (see earlier comments and diagram in 5709 ! mpp_lbc_north_2d). 5580 5710 znorthloc2(:,:) = 0 ! because of padding for nwidthmax 5581 DO ij = 1, ijpj, 15711 DO ij = jpjglo - jeub + 1, ijpj, 1 5582 5712 jj = nlcj - ijpj + ij 5583 5713 znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj) … … 5602 5732 ilei=nleit (jproc) 5603 5733 iilb=pielb(jproc) 5604 WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',ildi, ilei, iilb, ijpj 5734 !WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',& 5735 ! ildi, ilei, iilb, ijpj 5605 5736 ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = & 5606 5737 znorthgloio2(ildi:ilei,1:ijpj,jr) … … 5740 5871 ilei=nleit (jproc) 5741 5872 iilb=pielb(jproc) 5742 znorthgloio2(ildi:ilei,1:ijpj,jr)=ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) 5873 znorthgloio2(ildi:ilei,1:ijpj,jr) = & 5874 ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) 5743 5875 END DO 5744 5876 … … 5752 5884 ENDIF 5753 5885 5754 ! put in the last ijpj jlines of ib2 znorthloc2 5755 DO ij = 1, ijpj, 1 5886 ! put in the last ijpj jlines of ib2 from znorthloc2 while allowing 5887 ! for any trimming of domain (see earlier comments and diagram in 5888 ! mpp_lbc_north_2d). 5889 DO ij = jpjglo - jeub + 1, ijpj, 1 5756 5890 jj = nlcj - ijpj + ij 5757 5891 ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij) 5758 5892 END DO 5759 5893 WRITE(*,*) 'ARPDBG: finished in mpp_lbc_north_i2d' 5894 5895 #endif /* key_mpp_mpi */ 5896 5760 5897 END SUBROUTINE mpp_lbc_north_i2d 5761 5898 … … 5797 5934 5798 5935 !! * Local declarations 5799 INTEGER , PARAMETER :: ijpj = 45936 INTEGER :: ijpj 5800 5937 INTEGER :: ji, jj, jk, jr, jproc 5801 5938 INTEGER :: ierr … … 5814 5951 ! mpp with more than one proc across i : we deal only with the North 5815 5952 ! condition 5953 #if defined key_mpp_mpi 5954 5955 ijpj = num_nfold_rows 5956 ijpjm1=ijpj - 1 5816 5957 5817 5958 IF(.not. ALLOCATED(ztab))THEN 5818 5959 5819 ALLOCATE(ztab(jpiglo, 4,jpk), &5820 znorthgloio(nwidthmax, 4,jpk,jpni), &5821 znorthloc(nwidthmax, 4,jpk), &5960 ALLOCATE(ztab(jpiglo,ijpj,jpk), & 5961 znorthgloio(nwidthmax,ijpj,jpk,jpni), & 5962 znorthloc(nwidthmax,ijpj,jpk), & 5822 5963 STAT=ierr) 5823 5964 IF(ierr .ne. 0)THEN … … 5835 5976 ! --------------- 5836 5977 5837 ijpjm1=ijpj - 1 5838 5839 ! Put the last ijpj jlines of pt3d into znorthloc 5840 !ARPDBG znorthloc(:,:,:) = 999_wp ! because of padding for nwidthmax - 999 is 5841 ! for debugging 5842 #if defined key_z_first 5843 DO ij = 1, ijpj, 1 5978 ! Put the last ijpj jlines of pt3d into znorthloc while allowing 5979 ! for any trimming of domain (see earlier comments and diagram in 5980 ! mpp_lbc_north_2d). 5981 ! Have to initialise all to zero in case chunks are missing due to domain 5982 ! trimming 5983 znorthloc(:,:,:) = 0.0_wp 5984 #if defined key_z_first 5985 DO ij = jpjglo - jeub + 1, ijpj, 1 5844 5986 jj = nlcj - ijpj + ij 5845 5987 DO jk = 1, jpk 5846 5988 #else 5847 5989 DO jk = 1, jpk 5848 DO ij = 1, ijpj, 15990 DO ij = jpjglo - jeub + 1, ijpj, 1 5849 5991 jj = nlcj - ijpj + ij 5850 5992 #endif … … 5856 5998 IF (npolj /= 0 ) THEN 5857 5999 ! Build in proc 0 of ncomm_north the znorthgloio 5858 !ARPDBG znorthgloio(:,:,:,:) = 0_wp5859 6000 5860 6001 #ifdef key_mpp_shmem … … 5875 6016 IF (narea == north_root+1 ) THEN 5876 6017 ! recover the global north array 5877 !ARPDBGztab(:,:,:) = 0_wp6018 ztab(:,:,:) = 0_wp 5878 6019 5879 6020 DO jr = 1, ndim_rank_north … … 5890 6031 ! =============== 5891 6032 #if defined key_z_first 5892 5893 6033 5894 6034 ! 2. North-Fold boundary conditions … … 6179 6319 #endif 6180 6320 6181 ! put in the last ijpj jlines of pt3d znorthloc 6182 #if defined key_z_first 6183 DO ij = 1, ijpj, 1 6321 ! put in the last ijpj jlines of pt3d znorthloc while allowing 6322 ! for any trimming of domain (see earlier comments and diagram in 6323 ! mpp_lbc_north_2d). 6324 #if defined key_z_first 6325 DO ij = jpjglo - jeub + 1, ijpj, 1 6184 6326 jj = nlcj - ijpj + ij 6185 6327 DO jk = 1 , jpk 6186 6328 #else 6187 6329 DO jk = 1 , jpk 6188 DO ij = 1, ijpj, 16330 DO ij = jpjglo - jeub + 1, ijpj, 1 6189 6331 jj = nlcj - ijpj + ij 6190 6332 #endif … … 6194 6336 6195 6337 CALL prof_region_end(NORTH3DSCATTER, iprofStat) 6338 6339 #endif /* key_mpp_mpi */ 6196 6340 6197 6341 END SUBROUTINE mpp_lbc_north_3d … … 6235 6379 6236 6380 !! * Local declarations 6237 INTEGER , PARAMETER :: ijpj = 46238 INTEGER , PARAMETER :: ijpjm1 = ijpj -16381 INTEGER :: ijpj 6382 INTEGER :: ijpjm1 6239 6383 INTEGER :: ii, ji, jj, jk, jr, jproc 6240 6384 INTEGER :: ierr … … 6254 6398 ! mpp with more than one proc across i : we deal only with the North 6255 6399 ! condition 6400 6401 ijpj = num_nfold_rows 6402 ijpjm1 = ijpj - 1 6256 6403 6257 6404 IF(.not. ALLOCATED(ztab))THEN … … 6269 6416 ! --------------- 6270 6417 6271 ! put in znorthloc the last ijpj jlines of pt3d 6272 znorthloc(:,:,:) = 0 ! because of padding for nwidthmax 6273 #if defined key_z_first 6274 DO ij = 1, ijpj, 1 6418 ! put in znorthloc the last ijpj jlines of pt3d while allowing 6419 ! for any trimming of domain (see earlier comments and diagram in 6420 ! mpp_lbc_north_2d). 6421 znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain 6422 ! trimming 6423 #if defined key_z_first 6424 DO ij = jpjglo - jeub + 1, ijpj, 1 6275 6425 jj = nlcj - ijpj + ij 6276 6426 DO jk = 1, jpk 6277 6427 #else 6278 6428 DO jk = 1, jpk 6279 DO ij = 1, ijpj, 16429 DO ij = jpjglo - jeub + 1, ijpj, 1 6280 6430 jj = nlcj - ijpj + ij 6281 6431 #endif … … 6608 6758 #endif 6609 6759 6610 ! put in the last ijpj jlines of pt3d znorthloc 6611 #if defined key_z_first 6612 DO ij = 1, ijpj, 1 6760 ! put in the last ijpj jlines of pt3d znorthloc while allowing 6761 ! for any trimming of domain (see earlier comments and diagram in 6762 ! mpp_lbc_north_2d). 6763 #if defined key_z_first 6764 DO ij = jpjglo - jeub + 1, ijpj, 1 6613 6765 jj = nlcj - ijpj + ij 6614 6766 DO ii = nldi, nlei, 1 … … 6616 6768 #else 6617 6769 DO jk = 1 , jpk 6618 DO ij = 1, ijpj, 16770 DO ij = jpjglo - jeub + 1, ijpj, 1 6619 6771 jj = nlcj - ijpj + ij 6620 6772 DO ii = nldi, nlei, 1
Note: See TracChangeset
for help on using the changeset viewer.