Ignore:
Timestamp:
2015-07-09T18:07:16+02:00 (5 years ago)
Author:
mcastril
Message:

ticket #1539 Performance optimizations on NEMO 3.6 limhdf routine

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r5429 r5579  
    6262   USE lbcnfd         ! north fold treatment 
    6363   USE in_out_manager ! I/O manager 
     64   USE wrk_nemo       ! work arrays 
    6465 
    6566   IMPLICIT NONE 
     
    7071   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7172   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     73   PUBLIC   mpp_max_multiple 
    7274   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     75   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7476   PUBLIC   mppscatter, mppgather 
    7577   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    7880   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    7981   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     82   PUBLIC   mpprank 
    8083 
    8184   TYPE arrayptr 
    8285      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8386   END TYPE arrayptr 
     87   PUBLIC   arrayptr 
    8488    
    8589   !! * Interfaces 
     
    105109   INTERFACE mpp_maxloc 
    106110      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     111   END INTERFACE 
     112 
     113   INTERFACE mpp_max_multiple 
     114      MODULE PROCEDURE mppmax_real_multiple 
    107115   END INTERFACE 
    108116 
     
    724732      ! ----------------------- 
    725733      ! 
    726       DO ii = 1 , num_fields 
    727734         !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 
     735      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     736         ! 
     737         SELECT CASE ( jpni ) 
     738         CASE ( 1 )     ;    
     739             DO ii = 1 , num_fields   
     740                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     741             END DO 
     742         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     743         END SELECT 
     744         ! 
     745      ENDIF 
     746        ! 
    738747       
    739748      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     
    16811690   END SUBROUTINE mppmax_real 
    16821691 
     1692   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1693      !!---------------------------------------------------------------------- 
     1694      !!                  ***  routine mppmax_real  *** 
     1695      !! 
     1696      !! ** Purpose :   Maximum 
     1697      !! 
     1698      !!---------------------------------------------------------------------- 
     1699      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1700      INTEGER , INTENT(in   )           ::   NUM 
     1701      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1702      !! 
     1703      INTEGER  ::   ierror, localcomm 
     1704      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1705      !!---------------------------------------------------------------------- 
     1706      ! 
     1707      CALL wrk_alloc(NUM , zwork) 
     1708      localcomm = mpi_comm_opa 
     1709      IF( PRESENT(kcom) )   localcomm = kcom 
     1710      ! 
     1711      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1712      ptab = zwork 
     1713      CALL wrk_dealloc(NUM , zwork) 
     1714      ! 
     1715   END SUBROUTINE mppmax_real_multiple 
     1716 
    16831717 
    16841718   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     
    25752609   END SUBROUTINE mpp_lbc_north_2d 
    25762610 
     2611   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2612      !!--------------------------------------------------------------------- 
     2613      !!                   ***  routine mpp_lbc_north_2d  *** 
     2614      !! 
     2615      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2616      !!              in mpp configuration in case of jpn1 > 1 
     2617      !!              (for multiple 2d arrays ) 
     2618      !! 
     2619      !! ** Method  :   North fold condition and mpp with more than one proc 
     2620      !!              in i-direction require a specific treatment. We gather 
     2621      !!              the 4 northern lines of the global domain on 1 processor 
     2622      !!              and apply lbc north-fold on this sub array. Then we 
     2623      !!              scatter the north fold array back to the processors. 
     2624      !! 
     2625      !!---------------------------------------------------------------------- 
     2626      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2627      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2628      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2629      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2630      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2631      !!                                                             ! =  1. , the sign is kept 
     2632      INTEGER ::   ji, jj, jr, jk 
     2633      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2634      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2635      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2636      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2637      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2638      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2639      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2640      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2641      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2642      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2643      INTEGER :: istatus(mpi_status_size) 
     2644      INTEGER :: iflag 
     2645      !!---------------------------------------------------------------------- 
     2646      ! 
     2647      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2648      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2649      ! 
     2650      ijpj   = 4 
     2651      ijpjm1 = 3 
     2652      ! 
     2653       
     2654      DO jk = 1, num_fields 
     2655         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2656            ij = jj - nlcj + ijpj 
     2657            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2658         END DO 
     2659      END DO 
     2660      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2661      itaille = jpi * ijpj 
     2662                                                                   
     2663      IF ( l_north_nogather ) THEN 
     2664         ! 
     2665         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2666         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2667         ! 
     2668         ztabr(:,:,:) = 0 
     2669         ztabl(:,:,:) = 0 
     2670 
     2671         DO jk = 1, num_fields 
     2672            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2673               ij = jj - nlcj + ijpj 
     2674               DO ji = nfsloop, nfeloop 
     2675                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2676               END DO 
     2677            END DO 
     2678         END DO 
     2679 
     2680         DO jr = 1,nsndto 
     2681            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2682               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2683            ENDIF 
     2684         END DO 
     2685         DO jr = 1,nsndto 
     2686            iproc = nfipproc(isendto(jr),jpnj) 
     2687            IF(iproc .ne. -1) THEN 
     2688               ilei = nleit (iproc+1) 
     2689               ildi = nldit (iproc+1) 
     2690               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2691            ENDIF 
     2692            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2693              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2694              DO jk = 1 , num_fields 
     2695                 DO jj = 1, ijpj 
     2696                    DO ji = ildi, ilei 
     2697                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2698                    END DO 
     2699                 END DO 
     2700              END DO 
     2701            ELSE IF (iproc .eq. (narea-1)) THEN 
     2702              DO jk = 1, num_fields 
     2703                 DO jj = 1, ijpj 
     2704                    DO ji = ildi, ilei 
     2705                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2706                    END DO 
     2707                 END DO 
     2708              END DO 
     2709            ENDIF 
     2710         END DO 
     2711         IF (l_isend) THEN 
     2712            DO jr = 1,nsndto 
     2713               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2714                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2715               ENDIF 
     2716            END DO 
     2717         ENDIF 
     2718         ! 
     2719         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2720            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2721         END DO 
     2722         ! 
     2723         DO jk = 1, num_fields 
     2724            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2725               ij = jj - nlcj + ijpj 
     2726               DO ji = 1, nlci 
     2727                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2728               END DO 
     2729            END DO 
     2730         END DO 
     2731          
     2732         ! 
     2733      ELSE 
     2734         ! 
     2735         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2736            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2737         ! 
     2738         ztab(:,:,:) = 0.e0 
     2739         DO jk = 1, num_fields 
     2740            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2741               iproc = nrank_north(jr) + 1 
     2742               ildi = nldit (iproc) 
     2743               ilei = nleit (iproc) 
     2744               iilb = nimppt(iproc) 
     2745               DO jj = 1, ijpj 
     2746                  DO ji = ildi, ilei 
     2747                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2748                  END DO 
     2749               END DO 
     2750            END DO 
     2751         END DO 
     2752          
     2753         DO ji = 1, num_fields 
     2754            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2755         END DO 
     2756         ! 
     2757         DO jk = 1, num_fields 
     2758            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2759               ij = jj - nlcj + ijpj 
     2760               DO ji = 1, nlci 
     2761                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2762               END DO 
     2763            END DO 
     2764         END DO 
     2765         ! 
     2766         ! 
     2767      ENDIF 
     2768      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2769      DEALLOCATE( ztabl, ztabr ) 
     2770      ! 
     2771   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25772772 
    25782773   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
Note: See TracChangeset for help on using the changeset viewer.