Changeset 7901 for branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2017-04-13T05:46:23+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r7897 r7901 147 147 ! variables used for zonal integration 148 148 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average 149 LOGICAL, PUBLIC :: l_znl_root ! 149 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row 150 150 INTEGER :: ngrp_znl ! group ID for the znl processors 151 151 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average … … 163 163 164 164 ! Type of send : standard, buffered, immediate 165 CHARACTER(len=1), PUBLIC :: cn_mpi_send 166 LOGICAL , PUBLIC :: l_isend = .FALSE. 167 INTEGER , PUBLIC :: nn_buffer 165 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 166 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I') 167 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend 168 168 169 169 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend … … 266 266 END SELECT 267 267 ! 268 ELSE 268 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 269 269 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 270 270 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 … … 336 336 !! ** Method : Use mppsend and mpprecv function for passing mask 337 337 !! between processors following neighboring subdomains. 338 !! domain parameters338 !! domain parameters 339 339 !! nlci : first dimension of the local subdomain 340 340 !! nlcj : second dimension of the local subdomain … … 446 446 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 447 447 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 448 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )448 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 449 449 END SELECT 450 450 ! … … 487 487 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 488 488 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 489 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )489 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 490 490 CASE ( 0 ) 491 491 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) … … 493 493 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 494 494 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 495 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )496 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )495 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 496 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 497 497 CASE ( 1 ) 498 498 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) … … 759 759 !!--------------------------------------------------------------------- 760 760 REAL(wp) , DIMENSION(:,:), TARGET, INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 761 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt abarray grid-points761 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points 762 762 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 763 763 TYPE(arrayptr) , DIMENSION(:) , INTENT(inout) :: pt2d_array ! … … 793 793 INTEGER :: kfld 794 794 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 795 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of pt abarray grid-points795 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of pt2d array grid-points 796 796 REAL(wp) , DIMENSION(9) :: psgn_array ! sign used across the north fold boundary 797 797 !!--------------------------------------------------------------------- … … 837 837 !!---------------------------------------------------------------------- 838 838 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 839 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt abarray grid-points839 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points 840 840 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 841 841 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only … … 1989 1989 !! 1990 1990 !!---------------------------------------------------------------------- 1991 INTEGER , INTENT(in ) :: kdim1992 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab1993 INTEGER , INTENT(in ), OPTIONAL:: kcom1991 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab 1992 INTEGER , INTENT(in ) :: kdim 1993 INTEGER , OPTIONAL , INTENT(in ) :: kcom 1994 1994 ! 1995 1995 INTEGER :: ierror, localcomm … … 2041 2041 !! 2042 2042 INTEGER :: ierror, localcomm 2043 REAL(wp), DIMENSION(kdim) :: zwork 2043 2044 !!---------------------------------------------------------------------- 2044 2045 ! … … 2046 2047 IF( PRESENT(kcom) ) localcomm = kcom 2047 2048 ! 2048 CALL mpi_allreduce( pt ab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )2049 pt ab(:) = zwork(:)2049 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 2050 pt1d(:) = zwork(:) 2050 2051 ! 2051 2052 END SUBROUTINE mppmax_real_multiple … … 2212 2213 REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask 2213 2214 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 2214 INTEGER , INTENT( out) :: ki, kj 2215 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 2215 2216 ! 2216 2217 INTEGER :: ierror … … 2716 2717 2717 2718 DO jr = 1,nsndto 2718 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN2719 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2719 2720 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 2720 2721 ENDIF … … 2727 2728 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2728 2729 ENDIF 2729 IF( (iproc /= (narea-1)) .and. (iproc /= -1)) THEN2730 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 2730 2731 CALL mpprecv(5, zfoldwk, itaille, iproc) 2731 2732 DO jk = 1, ipk … … 2748 2749 IF (l_isend) THEN 2749 2750 DO jr = 1,nsndto 2750 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN2751 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err)2751 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2752 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 2752 2753 ENDIF 2753 2754 END DO … … 2870 2871 2871 2872 DO jr = 1,nsndto 2872 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN2873 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))2873 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2874 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 2874 2875 ENDIF 2875 2876 END DO 2876 2877 DO jr = 1,nsndto 2877 2878 iproc = nfipproc(isendto(jr),jpnj) 2878 IF( iproc /= -1) THEN2879 IF( iproc /= -1 ) THEN 2879 2880 ilei = nleit (iproc+1) 2880 2881 ildi = nldit (iproc+1) … … 2888 2889 END DO 2889 2890 END DO 2890 ELSE 2891 ELSEIF( iproc == narea-1 ) THEN 2891 2892 DO jj = 1, ijpj 2892 2893 DO ji = ildi, ilei … … 2896 2897 ENDIF 2897 2898 END DO 2898 IF 2899 IF(l_isend) THEN 2899 2900 DO jr = 1,nsndto 2900 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN2901 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2901 2902 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2902 2903 ENDIF … … 3019 3020 DO jr = 1, nsndto 3020 3021 iproc = nfipproc(isendto(jr),jpnj) 3021 IF( iproc /= -1) THEN3022 IF( iproc /= -1 ) THEN 3022 3023 ilei = nleit (iproc+1) 3023 3024 ildi = nldit (iproc+1) … … 3562 3563 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3563 3564 CASE ( -1 ) 3564 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err)3565 CASE ( 0 ) 3566 IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err)3567 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err)3568 CASE ( 1 ) 3569 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err)3565 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 3566 CASE ( 0 ) 3567 IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err ) 3568 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err ) 3569 CASE ( 1 ) 3570 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 3570 3571 END SELECT 3571 3572 !
Note: See TracChangeset
for help on using the changeset viewer.
