mp_diag.f90 10.9 KB
Newer Older
1
!
2

3 4 5 6 7 8 9 10 11 12
! Copyright (C) 2013 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!----------------------------------------------------------------------------
MODULE mp_diag
  !----------------------------------------------------------------------------
  !
13
  USE mp, ONLY : mp_size, mp_rank, mp_sum, mp_comm_free, mp_comm_split
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
  !
  USE parallel_include
  !
  IMPLICIT NONE 
  SAVE
  !
  ! ... linear-algebra group (also known as "ortho" or "diag" group). 
  ! ... Used for parallelization of dense-matrix diagonalization used in
  ! ... iterative diagonalization/orthonormalization, matrix-matrix products
  !
  INTEGER :: np_ortho(2) = 1  ! size of the processor grid used in ortho
  INTEGER :: me_ortho(2) = 0  ! coordinates of the processors
  INTEGER :: me_ortho1   = 0  ! task id for the ortho group
  INTEGER :: nproc_ortho = 1  ! size of the ortho group:
  INTEGER :: leg_ortho   = 1  ! the distance in the father communicator
                              ! of two neighbour processors in ortho_comm
  INTEGER :: ortho_comm  = 0  ! communicator for the ortho group
  INTEGER :: ortho_row_comm  = 0  ! communicator for the ortho row group
  INTEGER :: ortho_col_comm  = 0  ! communicator for the ortho col group
  INTEGER :: ortho_comm_id= 0 ! id of the ortho_comm
34
  INTEGER :: ortho_parent_comm  = 0  ! parent communicator from which ortho group has been created
35 36 37 38
  !
#if defined __SCALAPACK
  INTEGER :: me_blacs   =  0  ! BLACS processor index starting from 0
  INTEGER :: np_blacs   =  1  ! BLACS number of processor
39 40
#endif
  !
41 42 43
  INTEGER :: world_cntx = -1  ! BLACS context of all processor 
  INTEGER :: ortho_cntx = -1  ! BLACS context for ortho_comm
  !
degironc's avatar
degironc committed
44
  LOGICAL :: do_distr_diag_inside_bgrp = .true. ! whether the distributed diagoalization should be performed
45
                                                ! at the band group level (bgrp) or at its parent level
46 47 48
CONTAINS
  !
  !----------------------------------------------------------------------------
49
  SUBROUTINE mp_start_diag( ndiag_, my_world_comm, parent_comm, do_distr_diag_inside_bgrp_  )
50 51 52 53 54 55
    !---------------------------------------------------------------------------
    !
    ! ... Ortho/diag/linear algebra group initialization
    !
    IMPLICIT NONE
    !
56
    INTEGER, INTENT(INOUT) :: ndiag_  ! (IN) input number of procs in the diag group, (OUT) actual number
57
    INTEGER, INTENT(IN) :: my_world_comm ! parallel communicator of the "local" world
58 59
    INTEGER, INTENT(IN) :: parent_comm ! parallel communicator inside which the distributed linear algebra group
                                       ! communicators are created
60 61 62
    LOGICAL, INTENT(IN) :: do_distr_diag_inside_bgrp_  ! comme son nom l'indique
    !
    INTEGER :: mpime      =  0  ! the global MPI task index (used in clocks) can be set with a mp_rank call
63 64
    !
    INTEGER :: nproc_ortho_try
65 66 67 68
    INTEGER :: parent_nproc ! nproc of the parent group
    INTEGER :: world_nproc  ! nproc of the world group
    INTEGER :: my_parent_id ! id of the parent communicator 
    INTEGER :: nparent_comm ! mumber of parent communicators
69 70
    INTEGER :: ierr = 0
    !
71 72
    world_nproc  = mp_size( my_world_comm ) ! the global number of processors in world_comm
    mpime        = mp_rank( my_world_comm ) ! set the global MPI task index  (used in clocks)
73 74 75 76
    parent_nproc = mp_size( parent_comm )! the number of processors in the current parent communicator
    my_parent_id = mpime / parent_nproc  ! set the index of the current parent communicator
    nparent_comm = world_nproc/parent_nproc ! number of paren communicators

77 78 79
    ! save input value inside the module
    do_distr_diag_inside_bgrp = do_distr_diag_inside_bgrp_ 

80 81
    !
#if defined __SCALAPACK
82 83
    np_blacs     = mp_size( my_world_comm )
    me_blacs     = mp_rank( my_world_comm )
84
    !
85 86
    ! define a 1D grid containing all MPI tasks of the global communicator
    ! NOTE: world_cntx has the MPI communicator on entry and the BLACS context on exit
87
    !       BLACS_GRIDINIT() will create a copy of the communicator, which can be
88 89
    !       later retrieved using CALL BLACS_GET(world_cntx, 10, comm_copy)
    !
90
    world_cntx = my_world_comm 
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
    CALL BLACS_GRIDINIT( world_cntx, 'Row', 1, np_blacs )
    !
#endif
    !
    IF( ndiag_ > 0 ) THEN
       ! command-line argument -ndiag N or -northo N set to a value N
       ! use the command line value ensuring that it falls in the proper range
       nproc_ortho_try = MIN( ndiag_ , parent_nproc )
    ELSE 
       ! no command-line argument -ndiag N or -northo N is present
       ! insert here custom architecture specific default definitions
#if defined __SCALAPACK
       nproc_ortho_try = MAX( parent_nproc/2, 1 )
#else
       nproc_ortho_try = 1
#endif
    END IF
    !
    ! the ortho group for parallel linear algebra is a sub-group of the pool,
    ! then there are as many ortho groups as pools.
    !
112
    CALL init_ortho_group( nproc_ortho_try, my_world_comm, parent_comm, nparent_comm, my_parent_id )
113 114 115 116
    !
    ! set the number of processors in the diag group to the actual number used
    !
    ndiag_ = nproc_ortho
117 118 119 120 121 122
    !  
    RETURN
    !
  END SUBROUTINE mp_start_diag
  !
  !
123
  SUBROUTINE init_ortho_group( nproc_try_in, my_world_comm, comm_all, nparent_comm, my_parent_id )
124 125 126 127
    !
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nproc_try_in, comm_all
128
    INTEGER, INTENT(IN) :: my_world_comm ! parallel communicator of the "local" world
129 130
    INTEGER, INTENT(IN) :: nparent_comm
    INTEGER, INTENT(IN) :: my_parent_id ! id of the parent communicator 
131 132 133 134 135 136

    LOGICAL, SAVE :: first = .true.
    INTEGER :: ierr, color, key, me_all, nproc_all, nproc_try

#if defined __SCALAPACK
    INTEGER, ALLOCATABLE :: blacsmap(:,:)
137
    INTEGER, ALLOCATABLE :: ortho_cntx_pe(:)
138 139 140 141 142 143 144 145 146 147 148 149 150
    INTEGER :: nprow, npcol, myrow, mycol, i, j, k
    INTEGER, EXTERNAL :: BLACS_PNUM
#endif

#if defined __MPI

    me_all    = mp_rank( comm_all )
    !
    nproc_all = mp_size( comm_all )
    !
    nproc_try = MIN( nproc_try_in, nproc_all )
    nproc_try = MAX( nproc_try, 1 )

151
    IF( .NOT. first ) CALL clean_ortho_group ( ) 
152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197

    !  find the square closer (but lower) to nproc_try
    !
    CALL grid2d_dims( 'S', nproc_try, np_ortho(1), np_ortho(2) )
    !
    !  now, and only now, it is possible to define the number of tasks
    !  in the ortho group for parallel linear algebra
    !
    nproc_ortho = np_ortho(1) * np_ortho(2)
    !
    IF( nproc_all >= 4*nproc_ortho ) THEN
       !
       !  here we choose a processor every 4, in order not to stress memory BW
       !  on multi core procs, for which further performance enhancements are
       !  possible using OpenMP BLAS inside regter/cegter/rdiaghg/cdiaghg
       !  (to be implemented)
       !
       color = 0
       IF( me_all < 4*nproc_ortho .AND. MOD( me_all, 4 ) == 0 ) color = 1
       !
       leg_ortho = 4
       !
    ELSE IF( nproc_all >= 2*nproc_ortho ) THEN
       !
       !  here we choose a processor every 2, in order not to stress memory BW
       !
       color = 0
       IF( me_all < 2*nproc_ortho .AND. MOD( me_all, 2 ) == 0 ) color = 1
       !
       leg_ortho = 2
       !
    ELSE
       !
       !  here we choose the first processors
       !
       color = 0
       IF( me_all < nproc_ortho ) color = 1
       !
       leg_ortho = 1
       !
    END IF
    !
    key   = me_all
    !
    !  initialize the communicator for the new group by splitting the input communicator
    !
198
    CALL mp_comm_split ( comm_all, color, key, ortho_comm )
199
    !
200 201 202 203
    ! and remember where it comes from
    !
    ortho_parent_comm = comm_all
    !
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
    !  Computes coordinates of the processors, in row maior order
    !
    me_ortho1   = mp_rank( ortho_comm )
    !
    IF( me_all == 0 .AND. me_ortho1 /= 0 ) &
         CALL errore( " init_ortho_group ", " wrong root task in ortho group ", ierr )
    !
    if( color == 1 ) then
       ortho_comm_id = 1
       CALL GRID2D_COORDS( 'R', me_ortho1, np_ortho(1), np_ortho(2), me_ortho(1), me_ortho(2) )
       CALL GRID2D_RANK( 'R', np_ortho(1), np_ortho(2), me_ortho(1), me_ortho(2), ierr )
       IF( ierr /= me_ortho1 ) &
            CALL errore( " init_ortho_group ", " wrong task coordinates in ortho group ", ierr )
       IF( me_ortho1*leg_ortho /= me_all ) &
            CALL errore( " init_ortho_group ", " wrong rank assignment in ortho group ", ierr )

220 221
       CALL mp_comm_split( ortho_comm, me_ortho(2), me_ortho(1), ortho_col_comm)
       CALL mp_comm_split( ortho_comm, me_ortho(1), me_ortho(2), ortho_row_comm)
222 223 224 225 226 227 228 229 230

    else
       ortho_comm_id = 0
       me_ortho(1) = me_ortho1
       me_ortho(2) = me_ortho1
    endif
#if defined __SCALAPACK
    !
    !  This part is used to eliminate the image dependency from ortho groups
231
    !  SCALAPACK is now independent from whatever level of parallelization
232 233
    !  is present on top of pool parallelization
    !
234
    ALLOCATE( ortho_cntx_pe( nparent_comm ) )
235 236
    ALLOCATE( blacsmap( np_ortho(1), np_ortho(2) ) )

237
    DO j = 1, nparent_comm
238

239
         CALL BLACS_GET(world_cntx, 10, ortho_cntx_pe( j ) ) ! retrieve communicator of world context
240 241 242 243
         blacsmap = 0
         nprow = np_ortho(1)
         npcol = np_ortho(2)

244
         IF( ( j == ( my_parent_id + 1 ) ) .and. ( ortho_comm_id > 0 ) ) THEN
245 246 247 248 249

           blacsmap( me_ortho(1) + 1, me_ortho(2) + 1 ) = BLACS_PNUM( world_cntx, 0, me_blacs )

         END IF

250
         ! All MPI tasks defined in the global communicator take part in the definition of the BLACS grid
251

252
         CALL mp_sum( blacsmap, my_world_comm ) 
253

254
         CALL BLACS_GRIDMAP( ortho_cntx_pe( j ), blacsmap, nprow, nprow, npcol )
255

256
         CALL BLACS_GRIDINFO( ortho_cntx_pe( j ), nprow, npcol, myrow, mycol )
257

258
         IF( ( j == ( my_parent_id + 1 ) ) .and. ( ortho_comm_id > 0 ) ) THEN
259 260 261 262 263 264 265 266 267 268

            IF(  np_ortho(1) /= nprow ) &
               CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong no. of task rows ', 1 )
            IF(  np_ortho(2) /= npcol ) &
               CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong no. of task columns ', 1 )
            IF(  me_ortho(1) /= myrow ) &
               CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong task row ID ', 1 )
            IF(  me_ortho(2) /= mycol ) &
               CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong task columns ID ', 1 )

269
            ortho_cntx = ortho_cntx_pe( j )
270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291

         END IF

    END DO 

    DEALLOCATE( blacsmap )
    DEALLOCATE( ortho_cntx_pe )


#endif

#else

    ortho_comm_id = 1

#endif

    first = .false.

    RETURN
  END SUBROUTINE init_ortho_group
  !
292 293 294 295 296 297 298 299 300 301
  SUBROUTINE clean_ortho_group ( )
    !  
    !  free resources associated to the communicator
    !
    CALL mp_comm_free( ortho_comm )
    IF(  ortho_comm_id > 0  ) THEN
       CALL mp_comm_free( ortho_col_comm )
       CALL mp_comm_free( ortho_row_comm )
    ENDIF
#if defined __SCALAPACK
302
    IF(  ortho_cntx /= -1 ) CALL BLACS_GRIDEXIT( ortho_cntx )
303 304 305 306 307
    ortho_cntx = -1
#endif
    !
  END SUBROUTINE clean_ortho_group
  !
308
END MODULE mp_diag