- Timestamp:
- 2018-06-21T11:58:42+02:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_nemo2cice_prints/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r9816 r9817 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple' 26 27 !!---------------------------------------------------------------------- 27 28 … … 62 63 USE lbcnfd ! north fold treatment 63 64 USE in_out_manager ! I/O manager 65 USE wrk_nemo ! work arrays 64 66 65 67 IMPLICIT NONE … … 70 72 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 71 73 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 74 PUBLIC mpp_max_multiple 72 75 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 76 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 74 77 PUBLIC mppscatter, mppgather 75 78 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 81 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 79 82 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 83 PUBLIC mpprank 80 84 81 85 TYPE arrayptr 82 86 REAL , DIMENSION (:,:), POINTER :: pt2d 83 87 END TYPE arrayptr 88 PUBLIC arrayptr 84 89 85 90 !! * Interfaces … … 105 110 INTERFACE mpp_maxloc 106 111 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 112 END INTERFACE 113 114 INTERFACE mpp_max_multiple 115 MODULE PROCEDURE mppmax_real_multiple 107 116 END INTERFACE 108 117 … … 298 307 ENDIF 299 308 309 #if defined key_agrif 310 IF (Agrif_Root()) THEN 311 CALL Agrif_MPI_Init(mpi_comm_opa) 312 ELSE 313 CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 314 ENDIF 315 #endif 316 300 317 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 301 318 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) … … 724 741 ! ----------------------- 725 742 ! 726 DO ii = 1 , num_fields727 743 !First Array 728 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 729 ! 730 SELECT CASE ( jpni ) 731 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 732 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 733 END SELECT 734 ! 735 ENDIF 736 ! 737 END DO 744 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 745 ! 746 SELECT CASE ( jpni ) 747 CASE ( 1 ) ; 748 DO ii = 1 , num_fields 749 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 750 END DO 751 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 752 END SELECT 753 ! 754 ENDIF 755 ! 738 756 739 757 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) … … 1681 1699 END SUBROUTINE mppmax_real 1682 1700 1701 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 1702 !!---------------------------------------------------------------------- 1703 !! *** routine mppmax_real *** 1704 !! 1705 !! ** Purpose : Maximum 1706 !! 1707 !!---------------------------------------------------------------------- 1708 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 1709 INTEGER , INTENT(in ) :: NUM 1710 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 1711 !! 1712 INTEGER :: ierror, localcomm 1713 REAL(wp) , POINTER , DIMENSION(:) :: zwork 1714 !!---------------------------------------------------------------------- 1715 ! 1716 CALL wrk_alloc(NUM , zwork) 1717 localcomm = mpi_comm_opa 1718 IF( PRESENT(kcom) ) localcomm = kcom 1719 ! 1720 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 1721 ptab = zwork 1722 CALL wrk_dealloc(NUM , zwork) 1723 ! 1724 END SUBROUTINE mppmax_real_multiple 1725 1683 1726 1684 1727 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) … … 2006 2049 2007 2050 SUBROUTINE mppstop 2051 2052 #if defined key_oasis3 2053 USE mod_oasis ! coupling routines 2054 #endif 2055 2008 2056 !!---------------------------------------------------------------------- 2009 2057 !! *** routine mppstop *** … … 2015 2063 !!---------------------------------------------------------------------- 2016 2064 ! 2065 2066 #if defined key_oasis3 2067 ! If we're trying to shut down cleanly then we need to consider the fact 2068 ! that this could be part of an MPMD configuration - we don't want to 2069 ! leave other components deadlocked. 2070 2071 CALL oasis_abort(nproc,"mppstop","NEMO initiated abort") 2072 2073 2074 #else 2075 2017 2076 CALL mppsync 2018 2077 CALL mpi_finalize( info ) 2078 #endif 2079 2019 2080 ! 2020 2081 END SUBROUTINE mppstop … … 2575 2636 END SUBROUTINE mpp_lbc_north_2d 2576 2637 2638 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2639 !!--------------------------------------------------------------------- 2640 !! *** routine mpp_lbc_north_2d *** 2641 !! 2642 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2643 !! in mpp configuration in case of jpn1 > 1 2644 !! (for multiple 2d arrays ) 2645 !! 2646 !! ** Method : North fold condition and mpp with more than one proc 2647 !! in i-direction require a specific treatment. We gather 2648 !! the 4 northern lines of the global domain on 1 processor 2649 !! and apply lbc north-fold on this sub array. Then we 2650 !! scatter the north fold array back to the processors. 2651 !! 2652 !!---------------------------------------------------------------------- 2653 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2654 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2655 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2656 ! ! = T , U , V , F or W gridpoints 2657 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2658 !! ! = 1. , the sign is kept 2659 INTEGER :: ji, jj, jr, jk 2660 INTEGER :: ierr, itaille, ildi, ilei, iilb 2661 INTEGER :: ijpj, ijpjm1, ij, iproc 2662 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2663 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2664 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2665 ! ! Workspace for message transfers avoiding mpi_allgather 2666 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 2667 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2668 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2669 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2670 INTEGER :: istatus(mpi_status_size) 2671 INTEGER :: iflag 2672 !!---------------------------------------------------------------------- 2673 ! 2674 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), & 2675 & znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 2676 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2677 ! 2678 ijpj = 4 2679 ijpjm1 = 3 2680 ! 2681 2682 DO jk = 1, num_fields 2683 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 2684 ij = jj - nlcj + ijpj 2685 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 2686 END DO 2687 END DO 2688 ! ! Build in procs of ncomm_north the znorthgloio 2689 itaille = jpi * ijpj 2690 2691 IF ( l_north_nogather ) THEN 2692 ! 2693 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2694 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2695 ! 2696 ztabr(:,:,:) = 0 2697 ztabl(:,:,:) = 0 2698 2699 DO jk = 1, num_fields 2700 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2701 ij = jj - nlcj + ijpj 2702 DO ji = nfsloop, nfeloop 2703 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 2704 END DO 2705 END DO 2706 END DO 2707 2708 DO jr = 1,nsndto 2709 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2710 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 2711 ENDIF 2712 END DO 2713 DO jr = 1,nsndto 2714 iproc = nfipproc(isendto(jr),jpnj) 2715 IF(iproc .ne. -1) THEN 2716 ilei = nleit (iproc+1) 2717 ildi = nldit (iproc+1) 2718 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2719 ENDIF 2720 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2721 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 2722 DO jk = 1 , num_fields 2723 DO jj = 1, ijpj 2724 DO ji = ildi, ilei 2725 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D 2726 END DO 2727 END DO 2728 END DO 2729 ELSE IF (iproc .eq. (narea-1)) THEN 2730 DO jk = 1, num_fields 2731 DO jj = 1, ijpj 2732 DO ji = ildi, ilei 2733 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D 2734 END DO 2735 END DO 2736 END DO 2737 ENDIF 2738 END DO 2739 IF (l_isend) THEN 2740 DO jr = 1,nsndto 2741 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2742 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2743 ENDIF 2744 END DO 2745 ENDIF 2746 ! 2747 DO ji = 1, num_fields ! Loop to manage 3D variables 2748 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2749 END DO 2750 ! 2751 DO jk = 1, num_fields 2752 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2753 ij = jj - nlcj + ijpj 2754 DO ji = 1, nlci 2755 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D 2756 END DO 2757 END DO 2758 END DO 2759 2760 ! 2761 ELSE 2762 ! 2763 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & 2764 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2765 ! 2766 ztab(:,:,:) = 0.e0 2767 DO jk = 1, num_fields 2768 DO jr = 1, ndim_rank_north ! recover the global north array 2769 iproc = nrank_north(jr) + 1 2770 ildi = nldit (iproc) 2771 ilei = nleit (iproc) 2772 iilb = nimppt(iproc) 2773 DO jj = 1, ijpj 2774 DO ji = ildi, ilei 2775 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 2776 END DO 2777 END DO 2778 END DO 2779 END DO 2780 2781 DO ji = 1, num_fields 2782 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2783 END DO 2784 ! 2785 DO jk = 1, num_fields 2786 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2787 ij = jj - nlcj + ijpj 2788 DO ji = 1, nlci 2789 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 2790 END DO 2791 END DO 2792 END DO 2793 ! 2794 ! 2795 ENDIF 2796 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2797 DEALLOCATE( ztabl, ztabr ) 2798 ! 2799 END SUBROUTINE mpp_lbc_north_2d_multiple 2577 2800 2578 2801 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) … … 3680 3903 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) 3681 3904 ! 3905 IF( cd1 == 'MPPSTOP' ) THEN 3906 IF(lwp) WRITE(numout,*) 'E R R O R: Calling mppstop' 3907 CALL mppstop() 3908 ENDIF 3682 3909 IF( cd1 == 'STOP' ) THEN 3683 3910 IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' … … 3784 4011 WRITE(kout,*) 3785 4012 ENDIF 3786 STOP 'ctl_opn bad opening'4013 CALL ctl_stop ('STOP', 'NEMO abort ctl_opn bad opening') 3787 4014 ENDIF 3788 4015
Note: See TracChangeset
for help on using the changeset viewer.
