- Timestamp:
- 2013-11-18T12:57:11+01:00 (10 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4162 r4230 22 22 !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 23 23 !! the mppobc routine to optimize the BDY and OBC communications 24 !! 3.6 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 25 26 !!---------------------------------------------------------------------- 26 27 … … 151 152 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 152 153 153 ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 154 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 8 ! Assumed maximum number of active neighbours 155 INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges 156 INTEGER, PUBLIC, DIMENSION (jpmaxngh,jptyps) :: isendto 157 INTEGER, PUBLIC, DIMENSION (jptyps) :: nsndto 158 LOGICAL, PUBLIC :: ln_nnogather = .FALSE. ! namelist control of northfold comms 154 LOGICAL, PUBLIC :: ln_nnogather ! namelist control of northfold comms 159 155 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. ! internal control of northfold comms 160 156 INTEGER, PUBLIC :: ityp … … 2592 2588 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2593 2589 ! ! = T , U , V , F or W gridpoints 2594 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2590 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2595 2591 !! ! = 1. , the sign is kept 2596 INTEGER :: ji, jj, jr 2592 INTEGER :: ji, jj, jr, jk 2597 2593 INTEGER :: ierr, itaille, ildi, ilei, iilb 2598 2594 INTEGER :: ijpj, ijpjm1, ij, iproc 2599 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! 2595 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2600 2596 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2601 2597 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather … … 2604 2600 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2605 2601 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2606 2607 !!---------------------------------------------------------------------- 2608 ! 2609 ALLOCATE( ztab(jpiglo,4,jpk), znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 2602 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2603 2604 INTEGER :: istatus(mpi_status_size) 2605 INTEGER :: iflag 2606 !!---------------------------------------------------------------------- 2607 ! 2608 ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 2609 ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 2610 2610 2611 2611 ijpj = 4 2612 ityp = -12613 2612 ijpjm1 = 3 2614 ztab(:,:,:) = 0.e0 2615 ! 2616 DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d 2617 ij = jj - nlcj + ijpj 2618 znorthloc(:,ij,:) = pt3d(:,jj,:) 2613 ! 2614 DO jk = 1, jpk 2615 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d 2616 ij = jj - nlcj + ijpj 2617 znorthloc(:,ij,jk) = pt3d(:,jj,jk) 2618 END DO 2619 2619 END DO 2620 2620 ! 2621 2621 ! ! Build in procs of ncomm_north the znorthgloio 2622 2622 itaille = jpi * jpk * ijpj 2623 2624 2623 2625 IF ( l_north_nogather ) THEN 2624 2626 ! 2625 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2626 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2627 ! 2628 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2629 ij = jj - nlcj + ijpj 2630 DO ji = 1, nlci 2631 ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 2627 ztabr(:,:,:) = 0 2628 DO jk = 1, jpk 2629 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2630 ij = jj - nlcj + ijpj 2631 DO ji = 1, nlci 2632 ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 2633 END DO 2634 END DO 2635 END DO 2636 2637 DO jr = 1,nsndto 2638 IF (isendto(jr) .ne. narea) CALL mppsend( 5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr) ) 2639 END DO 2640 DO jr = 1,nsndto 2641 iproc = isendto(jr) 2642 ildi = nldit (iproc) 2643 ilei = nleit (iproc) 2644 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2645 IF(isendto(jr) .ne. narea) THEN 2646 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2647 DO jk = 1, jpk 2648 DO jj = 1, ijpj 2649 DO ji = 1, ilei 2650 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 2651 END DO 2652 END DO 2653 END DO 2654 ELSE 2655 DO jk = 1, jpk 2656 DO jj = 1, ijpj 2657 DO ji = 1, ilei 2658 ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 2659 END DO 2660 END DO 2661 END DO 2662 ENDIF 2663 END DO 2664 IF (l_isend) THEN 2665 DO jr = 1,nsndto 2666 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2632 2667 END DO 2633 END DO 2634 2635 ! 2636 ! Set the exchange type in order to access the correct list of active neighbours 2637 ! 2638 SELECT CASE ( cd_type ) 2639 CASE ( 'T' , 'W' ) 2640 ityp = 1 2641 CASE ( 'U' ) 2642 ityp = 2 2643 CASE ( 'V' ) 2644 ityp = 3 2645 CASE ( 'F' ) 2646 ityp = 4 2647 CASE ( 'I' ) 2648 ityp = 5 2649 CASE DEFAULT 2650 ityp = -1 ! Set a default value for unsupported types which 2651 ! will cause a fallback to the mpi_allgather method 2652 END SELECT 2653 IF ( ityp .gt. 0 ) THEN 2654 2655 DO jr = 1,nsndto(ityp) 2656 CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2657 END DO 2658 DO jr = 1,nsndto(ityp) 2659 CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 2660 iproc = isendto(jr,ityp) + 1 2661 ildi = nldit (iproc) 2662 ilei = nleit (iproc) 2663 iilb = nimppt(iproc) 2664 DO jj = 1, ijpj 2665 DO ji = ildi, ilei 2666 ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:) 2667 END DO 2668 ENDIF 2669 CALL mpp_lbc_nfd( ztabl, ztabr_3d, cd_type, psgn ) ! North fold boundary condition 2670 ! 2671 DO jk = 1, jpk 2672 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2673 ij = jj - nlcj + ijpj 2674 DO ji= 1, nlci 2675 pt3d(ji,jj,jk) = ztabl(ji,ij,jk) 2668 2676 END DO 2669 2677 END DO 2670 IF (l_isend) THEN 2671 DO jr = 1,nsndto(ityp) 2672 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2673 END DO 2674 ENDIF 2675 2676 ENDIF 2677 2678 ENDIF 2679 2680 IF ( ityp .lt. 0 ) THEN 2678 END DO 2679 ! 2680 2681 ELSE 2681 2682 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2682 2683 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2683 2684 ! 2685 ztab(:,:,:) = 0.e0 2684 2686 DO jr = 1, ndim_rank_north ! recover the global north array 2685 2687 iproc = nrank_north(jr) + 1 … … 2687 2689 ilei = nleit (iproc) 2688 2690 iilb = nimppt(iproc) 2689 DO jj = 1, ijpj 2690 DO ji = ildi, ilei 2691 ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 2691 DO jk = 1, jpk 2692 DO jj = 1, ijpj 2693 DO ji = ildi, ilei 2694 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 2695 END DO 2692 2696 END DO 2693 2697 END DO 2694 2698 END DO 2699 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2700 ! 2701 DO jk = 1, jpk 2702 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2703 ij = jj - nlcj + ijpj 2704 DO ji= 1, nlci 2705 pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 2706 END DO 2707 END DO 2708 END DO 2709 ! 2695 2710 ENDIF 2696 2711 ! … … 2704 2719 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2705 2720 ! 2706 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2707 ij = jj - nlcj + ijpj 2708 DO ji= 1, nlci 2709 pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:) 2710 END DO 2721 DO jk = 1, jpk 2722 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2723 ij = jj - nlcj + ijpj 2724 DO ji= 1, nlci 2725 pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 2726 END DO 2727 END DO 2711 2728 END DO 2712 2729 ! 2713 2730 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2731 DEALLOCATE( ztabl, ztabr ) 2714 2732 ! 2715 2733 END SUBROUTINE mpp_lbc_north_3d … … 2730 2748 !! 2731 2749 !!---------------------------------------------------------------------- 2732 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied2733 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt 3d grid-points2750 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied 2751 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points 2734 2752 ! ! = T , U , V , F or W gridpoints 2735 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2753 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2736 2754 !! ! = 1. , the sign is kept 2737 2755 INTEGER :: ji, jj, jr 2738 2756 INTEGER :: ierr, itaille, ildi, ilei, iilb 2739 2757 INTEGER :: ijpj, ijpjm1, ij, iproc 2740 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! 2758 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2741 2759 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2742 2760 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather … … 2745 2763 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2746 2764 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio 2765 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr 2766 INTEGER :: istatus(mpi_status_size) 2767 INTEGER :: iflag 2747 2768 !!---------------------------------------------------------------------- 2748 2769 ! 2749 2770 ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) ) 2771 ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 2750 2772 ! 2751 2773 ijpj = 4 2752 ityp = -12753 2774 ijpjm1 = 3 2754 ztab(:,:) = 0.e02755 2775 ! 2756 2776 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d … … 2763 2783 IF ( l_north_nogather ) THEN 2764 2784 ! 2765 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2785 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2766 2786 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2767 2787 ! 2788 ztabr(:,:) = 0 2768 2789 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2769 2790 ij = jj - nlcj + ijpj 2770 2791 DO ji = 1, nlci 2771 ztab (ji+nimpp-1,ij) = pt2d(ji,jj)2792 ztabl(ji,ij) = pt2d(ji,jj) 2772 2793 END DO 2773 2794 END DO 2774 2795 2775 ! 2776 ! Set the exchange type in order to access the correct list of active neighbours 2777 ! 2778 SELECT CASE ( cd_type ) 2779 CASE ( 'T' , 'W' ) 2780 ityp = 1 2781 CASE ( 'U' ) 2782 ityp = 2 2783 CASE ( 'V' ) 2784 ityp = 3 2785 CASE ( 'F' ) 2786 ityp = 4 2787 CASE ( 'I' ) 2788 ityp = 5 2789 CASE DEFAULT 2790 ityp = -1 ! Set a default value for unsupported types which 2791 ! will cause a fallback to the mpi_allgather method 2792 END SELECT 2793 2794 IF ( ityp .gt. 0 ) THEN 2795 2796 DO jr = 1,nsndto(ityp) 2797 CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2796 DO jr = 1,nsndto 2797 IF (isendto(jr) .ne. narea) CALL mppsend(5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr)) 2798 END DO 2799 DO jr = 1,nsndto 2800 iproc = isendto(jr) 2801 ildi = nldit (iproc) 2802 ilei = nleit (iproc) 2803 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2804 IF(isendto(jr) .ne. narea) THEN 2805 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2806 DO jj = 1, ijpj 2807 DO ji = 1, ilei 2808 ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 2809 END DO 2810 END DO 2811 ELSE 2812 DO jj = 1, ijpj 2813 DO ji = 1, ilei 2814 ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 2815 END DO 2816 END DO 2817 ENDIF 2818 END DO 2819 IF (l_isend) THEN 2820 DO jr = 1,nsndto 2821 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2798 2822 END DO 2799 DO jr = 1,nsndto(ityp) 2800 CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 2801 iproc = isendto(jr,ityp) + 1 2802 ildi = nldit (iproc) 2803 ilei = nleit (iproc) 2804 iilb = nimppt(iproc) 2805 DO jj = 1, ijpj 2806 DO ji = ildi, ilei 2807 ztab(ji+iilb-1,jj) = zfoldwk(ji,jj) 2808 END DO 2809 END DO 2823 ENDIF 2824 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition 2825 ! 2826 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2827 ij = jj - nlcj + ijpj 2828 DO ji = 1, nlci 2829 pt2d(ji,jj) = ztabl(ji,ij) 2810 2830 END DO 2811 IF (l_isend) THEN 2812 DO jr = 1,nsndto(ityp) 2813 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2814 END DO 2815 ENDIF 2816 2817 ENDIF 2818 2819 ENDIF 2820 2821 IF ( ityp .lt. 0 ) THEN 2831 END DO 2832 ! 2833 ELSE 2822 2834 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2823 2835 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2824 2836 ! 2837 ztab(:,:) = 0.e0 2825 2838 DO jr = 1, ndim_rank_north ! recover the global north array 2826 2839 iproc = nrank_north(jr) + 1 … … 2834 2847 END DO 2835 2848 END DO 2836 ENDIF 2837 ! 2838 ! The ztab array has been either: 2839 ! a. Fully populated by the mpi_allgather operation or 2840 ! b. Had the active points for this domain and northern neighbours populated 2841 ! by peer to peer exchanges 2842 ! Either way the array may be folded by lbc_nfd and the result for the span of 2843 ! this domain will be identical. 2844 ! 2845 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2846 ! 2847 ! 2848 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2849 ij = jj - nlcj + ijpj 2850 DO ji = 1, nlci 2851 pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 2852 END DO 2853 END DO 2854 ! 2849 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2850 ! 2851 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2852 ij = jj - nlcj + ijpj 2853 DO ji = 1, nlci 2854 pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 2855 END DO 2856 END DO 2857 ! 2858 ENDIF 2855 2859 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2860 DEALLOCATE( ztabl, ztabr ) 2856 2861 ! 2857 2862 END SUBROUTINE mpp_lbc_north_2d
Note: See TracChangeset
for help on using the changeset viewer.
