quantum-espresso/Modules/descriptors.f90

653 lines
24 KiB
Fortran
Raw Normal View History

!
! Copyright (C) 2002 FPMD 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 descriptors_module
USE parallel_types
USE io_global, ONLY : stdout
IMPLICIT NONE
SAVE
INTERFACE desc_init
MODULE PROCEDURE desc_init_1d, desc_init_2d, desc_init_3d
END INTERFACE
INTERFACE global_index
MODULE PROCEDURE globalindex_desc, globalindex_shape
END INTERFACE
INTERFACE local_index
MODULE PROCEDURE localindex_desc, localindex_shape
END INTERFACE
INTERFACE local_dimension
MODULE PROCEDURE localdim_desc, localdim_shape
END INTERFACE
INTERFACE owner_of
MODULE PROCEDURE ownerof_desc, ownerof_shape
END INTERFACE
INTERFACE get_local_dims
MODULE PROCEDURE desc_ldims
END INTERFACE
INTERFACE get_global_dims
MODULE PROCEDURE desc_gdims
END INTERFACE
INTEGER NUMROC
EXTERNAL NUMROC
CONTAINS
!=----------------------------------------------------------------------------=!
! BEGIN manual
!
SUBROUTINE desc_init_1d(desc, matrix_type, rows, &
row_block, row_src_pe, grid, row_shape)
!
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor) :: desc
INTEGER, INTENT(IN) :: matrix_type
TYPE (processors_grid), INTENT(IN) :: grid
INTEGER, INTENT(IN) :: rows
INTEGER, INTENT(IN) :: row_block
INTEGER, INTENT(IN) :: row_src_pe
INTEGER, INTENT(IN) :: row_shape
desc%matrix_type = matrix_type
desc%grid = grid
CALL desc_init_x(desc%nx, desc%xshape, desc%nxl, &
desc%nxblk, desc%ixl, desc%ipexs, rows, row_shape, &
row_block, row_src_pe, grid%mex, grid%npx)
desc%ny = 1
desc%nyl = 1
desc%nyblk = 1
desc%ipeys = 0
desc%yshape = REPLICATED_DATA_SHAPE
desc%nz = 1
desc%nzl = 1
desc%nzblk = 1
desc%ipezs = 0
desc%zshape = REPLICATED_DATA_SHAPE
desc%ldx = 1
desc%ldy = 1
RETURN
END SUBROUTINE desc_init_1d
!=----------------------------------------------------------------------------=!
! BEGIN manual
SUBROUTINE desc_init_blacs(desc, matrix_type, rows, columns, &
row_block, column_block, row_src_pe, column_src_pe, grid, local_ld)
!
!
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor) :: desc
INTEGER, INTENT(IN) :: matrix_type
TYPE (processors_grid), INTENT(IN) :: grid
INTEGER, INTENT(IN) :: rows
INTEGER, INTENT(IN) :: columns
INTEGER, INTENT(IN) :: row_block
INTEGER, INTENT(IN) :: column_block
INTEGER, INTENT(IN) :: row_src_pe
INTEGER, INTENT(IN) :: column_src_pe
INTEGER, INTENT(IN), OPTIONAL :: local_ld
desc%matrix_type = matrix_type
desc%grid = grid
CALL desc_init_x(desc%nx, desc%xshape, desc%nxl, &
desc%nxblk, desc%ixl, desc%ipexs, rows, &
BLOCK_CYCLIC_SHAPE, row_block, row_src_pe, grid%mex, &
grid%npx)
CALL desc_init_x(desc%ny, desc%yshape, &
desc%nyl, desc%nyblk, desc%iyl, &
desc%ipeys, columns, BLOCK_CYCLIC_SHAPE, column_block, &
column_src_pe, grid%mey, grid%npy)
desc%nz = 1
desc%nzl = 1
desc%nzblk = 1
desc%ipezs = 0
desc%zshape = REPLICATED_DATA_SHAPE
IF(PRESENT(local_ld)) THEN
desc%ldx = local_ld
ELSE
desc%ldx = localdim_shape( rows, row_block, grid%mex, &
row_src_pe, grid%npx, desc%xshape)
END IF
desc%ldy = 1
RETURN
END SUBROUTINE desc_init_blacs
!=----------------------------------------------------------------------------=!
! BEGIN manual
SUBROUTINE desc_init_2d(desc, matrix_type, rows, columns, &
row_block, column_block, row_src_pe, &
column_src_pe, grid, row_shape, column_shape, local_ld)
!
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor) :: desc
INTEGER, INTENT(IN) :: matrix_type
TYPE (processors_grid), INTENT(IN) :: grid
INTEGER, INTENT(IN) :: rows
INTEGER, INTENT(IN) :: columns
INTEGER, INTENT(IN) :: row_block
INTEGER, INTENT(IN) :: column_block
INTEGER, INTENT(IN) :: row_src_pe
INTEGER, INTENT(IN) :: column_src_pe
INTEGER, INTENT(IN) :: row_shape
INTEGER, INTENT(IN) :: column_shape
INTEGER, INTENT(IN), OPTIONAL :: local_ld
LOGICAL :: debug = .FALSE.
desc%matrix_type = matrix_type
desc%grid = grid
CALL desc_init_x(desc%nx, desc%xshape, desc%nxl, &
desc%nxblk, desc%ixl, desc%ipexs, rows, row_shape, &
row_block, row_src_pe, grid%mex, grid%npx)
CALL desc_init_x(desc%ny, desc%yshape, &
desc%nyl, desc%nyblk, desc%iyl, &
desc%ipeys, columns, column_shape, column_block, &
column_src_pe, grid%mey, grid%npy)
IF( debug ) THEN
WRITE( stdout,fmt="(' desc%nx = ', I6 )") desc%nx
WRITE( stdout,fmt="(' desc%xshape = ', I6 )") desc%xshape
WRITE( stdout,fmt="(' desc%nxl = ', I6 )") desc%nxl
WRITE( stdout,fmt="(' desc%nxblk = ', I6 )") desc%nxblk
WRITE( stdout,fmt="(' desc%ixl = ', I6 )") desc%ixl
WRITE( stdout,fmt="(' desc%ipexs = ', I6 )") desc%ipexs
WRITE( stdout,fmt="(' desc%ny = ', I6 )") desc%ny
WRITE( stdout,fmt="(' desc%yshape = ', I6 )") desc%yshape
WRITE( stdout,fmt="(' desc%nyl = ', I6 )") desc%nyl
WRITE( stdout,fmt="(' desc%nyblk = ', I6 )") desc%nyblk
WRITE( stdout,fmt="(' desc%iyl = ', I6 )") desc%iyl
WRITE( stdout,fmt="(' desc%ipeys = ', I6 )") desc%ipeys
END IF
desc%nz = 1
desc%nzl = 1
desc%nzblk = 1
desc%ipezs = 0
desc%zshape = REPLICATED_DATA_SHAPE
IF(PRESENT(local_ld)) THEN
desc%ldx = local_ld
ELSE
desc%ldx = localdim_shape( rows, row_block, grid%mex, &
row_src_pe, grid%npx, desc%xshape)
END IF
desc%ldy = 1
RETURN
END SUBROUTINE desc_init_2d
!=----------------------------------------------------------------------------=!
! BEGIN manual
SUBROUTINE desc_init_3d(desc, matrix_type, rows, columns, &
planes, row_block, column_block, plane_block, row_src_pe, &
column_src_pe, plane_src_pe, grid, row_shape, column_shape, &
plane_shape, local_ld, local_sub_ld)
!
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor) :: desc
INTEGER, INTENT(IN) :: matrix_type
TYPE (processors_grid), INTENT(IN) :: grid
INTEGER, INTENT(IN) :: rows
INTEGER, INTENT(IN) :: columns
INTEGER, INTENT(IN) :: planes
INTEGER, INTENT(IN) :: row_block
INTEGER, INTENT(IN) :: column_block
INTEGER, INTENT(IN) :: plane_block
INTEGER, INTENT(IN) :: row_src_pe
INTEGER, INTENT(IN) :: column_src_pe
INTEGER, INTENT(IN) :: plane_src_pe
INTEGER, INTENT(IN) :: row_shape
INTEGER, INTENT(IN) :: column_shape
INTEGER, INTENT(IN) :: plane_shape
INTEGER, INTENT(IN), OPTIONAL :: local_ld
INTEGER, INTENT(IN), OPTIONAL :: local_sub_ld
desc%matrix_type = matrix_type
desc%grid = grid
CALL desc_init_x(desc%nx, desc%xshape, desc%nxl, &
desc%nxblk, desc%ixl, desc%ipexs, rows, row_shape, &
row_block, row_src_pe, grid%mex, grid%npx)
CALL desc_init_x(desc%ny, desc%yshape, &
desc%nyl, desc%nyblk, desc%iyl, &
desc%ipeys, columns, column_shape, column_block, &
column_src_pe, grid%mey, grid%npy)
CALL desc_init_x(desc%nz, desc%zshape, &
desc%nzl, desc%nzblk, desc%izl, &
desc%ipezs, planes, plane_shape, plane_block, &
plane_src_pe, grid%mez, grid%npz)
IF(PRESENT(local_ld)) THEN
desc%ldx = local_ld
ELSE
desc%ldx = localdim_shape( rows, row_block, grid%mex, &
row_src_pe, grid%npx, desc%xshape)
END IF
IF(PRESENT(local_sub_ld)) THEN
desc%ldy = local_sub_ld
ELSE
desc%ldy = localdim_shape( columns, column_block, &
grid%mey, column_src_pe, grid%npy, &
desc%yshape)
END IF
RETURN
END SUBROUTINE desc_init_3d
!=----------------------------------------------------------------------------=!
! BEGIN manual
SUBROUTINE desc_init_x(desc_nxs, desc_nx_shape, desc_local_nxs, &
desc_nx_block, desc_ix, desc_nx_src_pe, nxs, nx_shape, nx_block, &
nx_src_pe, mype, npes)
!
! END manual
!=----------------------------------------------------------------------------=!
IMPLICIT NONE
INTEGER, INTENT(OUT) :: desc_nxs
INTEGER, INTENT(OUT) :: desc_nx_shape
INTEGER, INTENT(OUT) :: desc_local_nxs
INTEGER, INTENT(OUT) :: desc_nx_block
INTEGER, INTENT(OUT) :: desc_ix
INTEGER, INTENT(OUT) :: desc_nx_src_pe
INTEGER, INTENT(IN) :: nxs
INTEGER, INTENT(IN) :: nx_shape
INTEGER, INTENT(IN) :: nx_block
INTEGER, INTENT(IN) :: nx_src_pe
INTEGER, INTENT(IN) :: mype
INTEGER, INTENT(IN) :: npes
desc_nxs = nxs
desc_nx_shape = nx_shape
desc_local_nxs = localdim_shape( nxs, nx_block, mype, nx_src_pe, npes, nx_shape)
desc_ix = localindex_shape( 1, nxs, nx_block, mype, npes, nx_shape)
SELECT CASE (nx_shape)
CASE ( BLOCK_CYCLIC_SHAPE )
desc_nx_block = nx_block
desc_nx_src_pe = nx_src_pe
CASE ( BLOCK_PARTITION_SHAPE )
desc_nx_block = desc_local_nxs
desc_nx_src_pe = 0
CASE ( CYCLIC_SHAPE )
desc_nx_block = 1
desc_nx_src_pe = 0
CASE ( REPLICATED_DATA_SHAPE )
desc_nx_block = nxs
desc_nx_src_pe = mype
END SELECT
RETURN
END SUBROUTINE
!=----------------------------------------------------------------------------=!
! BEGIN manual
SUBROUTINE pblas_descriptor(pb_desc, desc)
!
! END manual
!=----------------------------------------------------------------------------=!
INTEGER :: pb_desc(:)
TYPE (descriptor) :: desc
pb_desc(1) = desc%matrix_type
pb_desc(2) = desc%grid%context
pb_desc(3) = desc%nx
pb_desc(4) = desc%ny
pb_desc(5) = desc%nxblk
pb_desc(6) = desc%nyblk
pb_desc(7) = desc%ipexs
pb_desc(8) = desc%ipeys
pb_desc(9) = desc%ldx
RETURN
END SUBROUTINE pblas_descriptor
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION globalindex_shape( lind, n, nb, me, isrc, np, pshape )
! This function computes the global index of a distributed array entry
! pointed to by the local index lind of the process indicated by me.
! lind local index of the distributed matrix entry.
! N is the size of the global array.
! NB size of the blocks the distributed matrix is split into.
! me The coordinate of the process whose local array row or
! column is to be determined.
! isrc The coordinate of the process that possesses the first
! row/column of the distributed matrix.
! np The total number processes over which the distributed
! matrix is distributed.
!
! END manual
!=----------------------------------------------------------------------------=!
INTEGER, INTENT(IN) :: lind, n, nb, me, isrc, np, pshape
INTEGER r, q
IF( pshape .EQ. BLOCK_PARTITION_SHAPE ) THEN
q = INT(n/np)
r = MOD(n,np)
IF( me < r ) THEN
GLOBALINDEX_SHAPE = (Q+1)*me + lind
ELSE
GLOBALINDEX_SHAPE = Q*me + R + lind
END IF
ELSE IF ( pshape .EQ. BLOCK_CYCLIC_SHAPE ) THEN
GLOBALINDEX_SHAPE = np*NB*((lind-1)/NB) + &
MOD(lind-1,NB) + MOD(np+me-isrc, np)*NB + 1
ELSE IF ( pshape .EQ. CYCLIC_SHAPE ) THEN
GLOBALINDEX_SHAPE = (lind-1) * np + me + 1
ELSE
GLOBALINDEX_SHAPE = lind
END IF
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION globalindex_desc( lind, desc, what )
! END manual
!=----------------------------------------------------------------------------=!
INTEGER, INTENT(IN) :: lind
TYPE (descriptor) :: desc
CHARACTER(LEN=*) :: what
INTEGER N, nb, src_pe, my_pe, np, pshape
IF ( what(1:1) .EQ. 'R' .OR. what(1:1) .EQ. 'r' ) THEN
NB = desc%nxblk; N = desc%nx;
np = desc%grid%npx; src_pe = desc%ipexs;
my_pe = desc%grid%mex; pshape = desc%xshape
ELSE IF ( what(1:1) .EQ. 'C' .OR. what(1:1) .EQ. 'c' ) THEN
NB = desc%nyblk; N = desc%ny;
np = desc%grid%npy; src_pe = desc%ipeys;
my_pe = desc%grid%mey; pshape = desc%yshape
ELSE IF ( what(1:1) .EQ. 'P' .OR. what(1:1) .EQ. 'p' ) THEN
NB = desc%nzblk; N = desc%nz;
np = desc%grid%npz; src_pe = desc%ipezs;
my_pe = desc%grid%mez; pshape = desc%zshape
END IF
globalindex_desc = globalindex_shape(lind, n, nb, my_pe, src_pe, np, pshape )
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION localdim_shape( n, nb, me, isrc, np, pshape)
! N = Global dimension of the array
! NB = Size of the blocks ( meaningful only for BLOCK_CYCLIC_SHAPE )
! me = Index of the callig processor
! isrc = Index of the processor owning the first element of the array
! np = Number of processors among which the array is subdivided
! pshape = Shape of the distributed data
!
! This function return the number of array elements owned
! by the callig processor
!
! END manual
!=----------------------------------------------------------------------------=!
IMPLICIT NONE
INTEGER, INTENT(IN) :: n, nb, me, isrc, np, pshape
IF( pshape .EQ. BLOCK_PARTITION_SHAPE ) THEN
LOCALDIM_SHAPE = INT(N/np)
IF( me < MOD(N,np) ) LOCALDIM_SHAPE = LOCALDIM_SHAPE + 1
ELSE IF( pshape .EQ. BLOCK_CYCLIC_SHAPE ) THEN
LOCALDIM_SHAPE = NUMROC( N, NB, me, isrc, np )
ELSE IF( pshape .EQ. CYCLIC_SHAPE ) THEN
LOCALDIM_SHAPE = INT(N/np)
IF( me < MOD(N,np) ) LOCALDIM_SHAPE = LOCALDIM_SHAPE + 1
ELSE
LOCALDIM_SHAPE = n
END IF
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION localdim_desc( desc, what )
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor) :: desc
CHARACTER(LEN=*) :: what
INTEGER n, nb, src_pe, my_pe, np, pshape
IF ( what(1:1) .EQ. 'R' .OR. what(1:1) .EQ. 'r' ) THEN
NB = desc%nxblk; N = desc%nx;
np = desc%grid%npx; src_pe = desc%ipexs;
my_pe = desc%grid%mex; pshape = desc%xshape
ELSE IF ( what(1:1) .EQ. 'C' .OR. what(1:1) .EQ. 'c' ) THEN
NB = desc%nyblk; N = desc%ny;
np = desc%grid%npy; src_pe = desc%ipeys;
my_pe = desc%grid%mey; pshape = desc%yshape
ELSE IF ( what(1:1) .EQ. 'P' .OR. what(1:1) .EQ. 'p' ) THEN
NB = desc%nzblk; N = desc%nz;
np = desc%grid%npz; src_pe = desc%ipezs;
my_pe = desc%grid%mez; pshape = desc%zshape
END IF
localdim_desc = localdim_shape( N, NB, my_pe, src_pe, np, pshape)
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION localindex_shape(ig, n, nb, me, np, pshape)
! ig global index of the x dimension of array element
! n dimension of the global array
! nb dimension of the block the global array is split into.
! np number of processors onto which the array is distributed
!
! This function return the index of the element in the local block
!
! END manual
!=----------------------------------------------------------------------------=!
INTEGER ig, n, np, pshape, nb, me, q, r
IF( pshape .EQ. BLOCK_PARTITION_SHAPE ) THEN
q = INT(n/np)
r = MOD(n,np)
IF( me < r ) THEN
LOCALINDEX_SHAPE = ig - (q+1) * me
ELSE
LOCALINDEX_SHAPE = ig - (q+1) * r - q * (me - r)
END IF
ELSE IF ( pshape .EQ. BLOCK_CYCLIC_SHAPE ) THEN
LOCALINDEX_SHAPE = NB*((IG-1)/(NB*NP))+MOD(IG-1,NB)+1
ELSE IF ( pshape .EQ. CYCLIC_SHAPE ) THEN
LOCALINDEX_SHAPE = (ig-1)/np + 1
ELSE
LOCALINDEX_SHAPE = ig
END IF
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION localindex_desc(ig, desc, what )
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor) :: desc
CHARACTER(LEN=*) :: what
INTEGER ig, n, nb, np, pshape, me
IF ( what(1:1) .EQ. 'R' .OR. what(1:1) .EQ. 'r' ) THEN
NB = desc%nxblk; N = desc%nx;
np = desc%grid%npx; pshape = desc%xshape
me = desc%grid%mex
ELSE IF ( what(1:1) .EQ. 'C' .OR. what(1:1) .EQ. 'c' ) THEN
NB = desc%nyblk; N = desc%ny;
np = desc%grid%npy; pshape = desc%yshape
me = desc%grid%mey
ELSE IF ( what(1:1) .EQ. 'P' .OR. what(1:1) .EQ. 'p' ) THEN
NB = desc%nzblk; N = desc%nz;
np = desc%grid%npz; pshape = desc%zshape
me = desc%grid%mez
END IF
localindex_desc = localindex_shape(ig,n,nb,me,np,pshape)
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION ownerof_shape(ig,n,nb,src_pe,np,pshape)
!
! ig global index of the x dimension of array element
! n dimension of the global array
! nb dimension of the block
! src_pe index of the processor owning the first element of the array
! at the moment meaningfull only for pshape = BLOCK_CYCLIC_SHAPE
! np number of processors
!
! This function return the index of the processor owning the array element
! whose global index is "ig"
!
! END manual
!=----------------------------------------------------------------------------=!
IMPLICIT NONE
INTEGER ig, n, nb, np, pshape, src_pe, r, q
IF( pshape .EQ. BLOCK_PARTITION_SHAPE ) THEN
q = INT(n/np); r = MOD(n,np)
IF ( ig <= ((q+1)*r) ) THEN
ownerof_shape = INT((ig-1)/(q+1))
ELSE
ownerof_shape = INT((ig-1-r*(q+1))/q)+r
END IF
ELSE IF( pshape .EQ. BLOCK_CYCLIC_SHAPE ) THEN
ownerof_shape = MOD( src_pe + (ig - 1) / NB, NP )
ELSE IF( pshape .EQ. CYCLIC_SHAPE ) THEN
ownerof_shape = MOD( ig-1, np )
END IF
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
INTEGER FUNCTION ownerof_desc(ig, desc, what )
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor) :: desc
CHARACTER(LEN=*) :: what
INTEGER ig, n, nb, src_pe, np, pshape
IF ( what(1:1) .EQ. 'R' .OR. what(1:1) .EQ. 'r' ) THEN
NB = desc%nxblk; N = desc%nx;
np = desc%grid%npx; pshape = desc%xshape
src_pe = desc%ipexs
ELSE IF ( what(1:1) .EQ. 'C' .OR. what(1:1) .EQ. 'c' ) THEN
NB = desc%nyblk; N = desc%ny;
np = desc%grid%npy; pshape = desc%yshape
src_pe = desc%ipeys
ELSE IF ( what(1:1) .EQ. 'P' .OR. what(1:1) .EQ. 'p' ) THEN
NB = desc%nzblk; N = desc%nz;
np = desc%grid%npz; pshape = desc%zshape
src_pe = desc%ipezs
END IF
ownerof_desc = ownerof_shape(ig, n, nb, src_pe, np, pshape)
RETURN
END FUNCTION
!=----------------------------------------------------------------------------=!
! BEGIN manual
SUBROUTINE desc_gdims(d, nx, ny, nz )
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor), INTENT(IN) :: d
INTEGER, INTENT(OUT) :: nx, ny, nz
nx = d%nx
ny = d%ny
nz = d%nz
RETURN
END SUBROUTINE
!=----------------------------------------------------------------------------=!
! BEGIN manual
SUBROUTINE desc_ldims(d, nxl, nyl, nzl )
! END manual
!=----------------------------------------------------------------------------=!
TYPE (descriptor), INTENT(IN) :: d
INTEGER, INTENT(OUT) :: nxl
INTEGER, OPTIONAL, INTENT(OUT) :: nyl, nzl
nxl = d%nxl
IF( PRESENT( nyl ) ) nyl = d%nyl
IF( PRESENT( nzl ) ) nzl = d%nzl
RETURN
END SUBROUTINE
END MODULE descriptors_module