scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
quantum-espresso/Modules/mp.f90

2245 lines
71 KiB
Fortran
Raw Blame History

!
! Copyright (C) 2002-2009 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 .
!
#if defined __HPM
# include "/cineca/prod/hpm/include/f_hpm.h"
#endif
!------------------------------------------------------------------------------!
MODULE mp
!------------------------------------------------------------------------------!
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE parallel_include
!
IMPLICIT NONE
PUBLIC :: mp_start, mp_end, mp_env, &
mp_bcast, mp_sum, mp_max, mp_min, mp_rank, mp_size, &
mp_gather, mp_get, mp_put, mp_barrier, mp_report, mp_group_free, &
mp_root_sum, mp_comm_free, mp_comm_create, mp_comm_group, &
mp_group_create, mp_comm_split, mp_set_displs
!
INTERFACE mp_bcast
MODULE PROCEDURE mp_bcast_i1, mp_bcast_r1, mp_bcast_c1, &
mp_bcast_z, mp_bcast_zv, &
mp_bcast_iv, mp_bcast_rv, mp_bcast_cv, mp_bcast_l, mp_bcast_rm, &
mp_bcast_cm, mp_bcast_im, mp_bcast_it, mp_bcast_rt, mp_bcast_lv, &
mp_bcast_lm, mp_bcast_r4d, mp_bcast_r5d, mp_bcast_ct, mp_bcast_c4d
END INTERFACE
INTERFACE mp_sum
MODULE PROCEDURE mp_sum_i1, mp_sum_iv, mp_sum_im, mp_sum_it, &
mp_sum_r1, mp_sum_rv, mp_sum_rm, mp_sum_rt, mp_sum_r4d, &
mp_sum_c1, mp_sum_cv, mp_sum_cm, mp_sum_ct, mp_sum_c4d, &
mp_sum_c5d, mp_sum_c6d, mp_sum_rmm, mp_sum_cmm
END INTERFACE
INTERFACE mp_root_sum
MODULE PROCEDURE mp_root_sum_rm, mp_root_sum_cm
END INTERFACE
INTERFACE mp_get
MODULE PROCEDURE mp_get_rv, mp_get_cv, mp_get_i1, mp_get_iv, &
mp_get_rm
END INTERFACE
INTERFACE mp_put
MODULE PROCEDURE mp_put_rv, mp_put_cv, mp_put_i1, mp_put_iv, &
mp_put_rm
END INTERFACE
INTERFACE mp_max
MODULE PROCEDURE mp_max_i, mp_max_r, mp_max_rv, mp_max_iv
END INTERFACE
INTERFACE mp_min
MODULE PROCEDURE mp_min_i, mp_min_r, mp_min_rv, mp_min_iv
END INTERFACE
INTERFACE mp_gather
MODULE PROCEDURE mp_gather_iv, mp_gatherv_rv, mp_gatherv_iv, &
mp_gatherv_rm, mp_gatherv_im, mp_gatherv_cv
END INTERFACE
INTERFACE mp_alltoall
MODULE PROCEDURE mp_alltoall_c3d, mp_alltoall_i3d
END INTERFACE
INTEGER, ALLOCATABLE, PRIVATE, SAVE :: mp_call_count(:)
INTEGER, ALLOCATABLE, PRIVATE, SAVE :: mp_call_sizex(:)
CHARACTER(LEN=80), PRIVATE :: err_msg = ' '
!------------------------------------------------------------------------------!
!
CONTAINS
!
!------------------------------------------------------------------------------!
!
!------------------------------------------------------------------------------!
!..mp_gather_iv
!..Carlo Cavazzoni
SUBROUTINE mp_gather_iv(mydata, alldata, root, gid)
IMPLICIT NONE
INTEGER, INTENT(IN) :: mydata(:), root
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER, INTENT(OUT) :: alldata(:,:)
INTEGER :: msglen, ierr
#if defined (__MPI)
msglen = SIZE(mydata)
IF( msglen .NE. SIZE(alldata, 1) ) CALL mp_stop( 8000 )
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL MPI_GATHER(mydata, msglen, MPI_INTEGER, alldata, msglen, MPI_INTEGER, root, group, IERR)
IF (ierr/=0) CALL mp_stop( 8001 )
#else
msglen = SIZE(mydata)
IF( msglen .NE. SIZE(alldata, 1) ) CALL mp_stop( 8002 )
alldata(:,1) = mydata(:)
#endif
RETURN
END SUBROUTINE mp_gather_iv
!
!------------------------------------------------------------------------------!
!..mp_start
SUBROUTINE mp_start
! ...
IMPLICIT NONE
INTEGER :: ierr, taskid
! ...
ierr = 0
taskid = 0
ALLOCATE( mp_call_count( 1000 ) )
mp_call_count = 0
ALLOCATE( mp_call_sizex( 1000 ) )
mp_call_sizex = 0
# if defined(__MPI)
CALL MPI_INIT(ierr)
IF (ierr/=0) CALL mp_stop( 8003 )
# endif
#if defined __HPM
! initialize the IBM Harware performance monitor
# if defined(__MPI)
CALL mpi_comm_rank( mpi_comm_world, taskid, ierr)
# endif
CALL f_hpminit( taskid, 'profiling' )
#endif
! ...
END SUBROUTINE mp_start
!
!------------------------------------------------------------------------------!
!..mp_end
SUBROUTINE mp_end
IMPLICIT NONE
INTEGER :: ierr, taskid
ierr = 0
taskid = 0
IF ( ALLOCATED ( mp_call_count ) ) DEALLOCATE( mp_call_count )
IF ( ALLOCATED ( mp_call_sizex ) ) DEALLOCATE( mp_call_sizex )
#if defined __HPM
! terminate the IBM Harware performance monitor
#if defined(__MPI)
CALL mpi_comm_rank( mpi_comm_world, taskid, ierr)
#endif
CALL f_hpmterminate( taskid )
#endif
#if defined(__MPI)
CALL mpi_finalize(ierr)
IF (ierr/=0) CALL mp_stop( 8004 )
#endif
RETURN
END SUBROUTINE mp_end
!
!------------------------------------------------------------------------------!
!..mp_env
SUBROUTINE mp_env(numtask, taskid, groupid)
IMPLICIT NONE
INTEGER, INTENT (OUT) :: numtask, taskid, groupid
INTEGER :: ierr
ierr = 0
numtask = 1
taskid = 0
groupid = 0
#if defined(__MPI)
CALL mpi_comm_rank(mpi_comm_world,taskid,ierr)
IF (ierr/=0) CALL mp_stop( 8005 )
CALL mpi_comm_size(mpi_comm_world,numtask,ierr)
groupid = mpi_comm_world
IF (ierr/=0) CALL mp_stop( 8006 )
#endif
RETURN
END SUBROUTINE mp_env
!------------------------------------------------------------------------------!
!..mp_group
SUBROUTINE mp_comm_group( comm, group )
IMPLICIT NONE
INTEGER, INTENT (IN) :: comm
INTEGER, INTENT (OUT) :: group
INTEGER :: ierr
ierr = 0
#if defined(__MPI)
CALL mpi_comm_group( comm, group, ierr )
IF (ierr/=0) CALL mp_stop( 8007 )
#else
group = 0
#endif
END SUBROUTINE mp_comm_group
SUBROUTINE mp_comm_split( old_comm, color, key, new_comm )
IMPLICIT NONE
INTEGER, INTENT (IN) :: old_comm
INTEGER, INTENT (IN) :: color, key
INTEGER, INTENT (OUT) :: new_comm
INTEGER :: ierr
ierr = 0
#if defined(__MPI)
CALL MPI_COMM_SPLIT( old_comm, color, key, new_comm, ierr )
IF (ierr/=0) CALL mp_stop( 8008 )
#else
new_comm = old_comm
#endif
END SUBROUTINE mp_comm_split
SUBROUTINE mp_group_create( group_list, group_size, old_grp, new_grp )
IMPLICIT NONE
INTEGER, INTENT (IN) :: group_list(:), group_size, old_grp
INTEGER, INTENT (OUT) :: new_grp
INTEGER :: ierr
ierr = 0
new_grp = old_grp
#if defined(__MPI)
CALL mpi_group_incl( old_grp, group_size, group_list, new_grp, ierr )
IF (ierr/=0) CALL mp_stop( 8009 )
#endif
END SUBROUTINE mp_group_create
!------------------------------------------------------------------------------!
SUBROUTINE mp_comm_create( old_comm, new_grp, new_comm )
IMPLICIT NONE
INTEGER, INTENT (IN) :: old_comm
INTEGER, INTENT (IN) :: new_grp
INTEGER, INTENT (OUT) :: new_comm
INTEGER :: ierr
ierr = 0
new_comm = old_comm
#if defined(__MPI)
CALL mpi_comm_create( old_comm, new_grp, new_comm, ierr )
IF (ierr/=0) CALL mp_stop( 8010 )
#endif
END SUBROUTINE mp_comm_create
!------------------------------------------------------------------------------!
!..mp_group_free
SUBROUTINE mp_group_free( group )
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: group
INTEGER :: ierr
ierr = 0
#if defined(__MPI)
CALL mpi_group_free( group, ierr )
IF (ierr/=0) CALL mp_stop( 8011 )
#endif
END SUBROUTINE mp_group_free
!------------------------------------------------------------------------------!
SUBROUTINE mp_comm_free( comm )
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: comm
INTEGER :: ierr
ierr = 0
#if defined(__MPI)
IF( comm /= MPI_COMM_NULL ) THEN
CALL mpi_comm_free( comm, ierr )
IF (ierr/=0) CALL mp_stop( 8012 )
END IF
#endif
RETURN
END SUBROUTINE mp_comm_free
!------------------------------------------------------------------------------!
!..mp_bcast
SUBROUTINE mp_bcast_i1(msg,source,gid)
IMPLICIT NONE
INTEGER :: msg
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL BCAST_INTEGER( msg, msglen, source, group )
mp_call_count( 1 ) = mp_call_count( 1 ) + 1
mp_call_sizex( 1 ) = MAX( mp_call_sizex( 1 ), msglen )
#endif
END SUBROUTINE mp_bcast_i1
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_bcast_iv(msg,source,gid)
IMPLICIT NONE
INTEGER :: msg(:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL BCAST_INTEGER( msg, msglen, source, group )
mp_call_count( 2 ) = mp_call_count( 2 ) + 1
mp_call_sizex( 2 ) = MAX( mp_call_sizex( 2 ), msglen )
#endif
END SUBROUTINE mp_bcast_iv
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_bcast_im( msg, source, gid )
IMPLICIT NONE
INTEGER :: msg(:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL BCAST_INTEGER( msg, msglen, source, group )
mp_call_count( 3 ) = mp_call_count( 3 ) + 1
mp_call_sizex( 3 ) = MAX( mp_call_sizex( 3 ), msglen )
#endif
END SUBROUTINE mp_bcast_im
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_bcast_it(msg,source,gid)
IMPLICIT NONE
INTEGER :: msg(:,:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL BCAST_INTEGER( msg, msglen, source, group )
mp_call_count( 4 ) = mp_call_count( 4 ) + 1
mp_call_sizex( 4 ) = MAX( mp_call_sizex( 4 ), msglen )
#endif
END SUBROUTINE mp_bcast_it
!
!------------------------------------------------------------------------------!
!
SUBROUTINE mp_bcast_r1(msg,source,gid)
IMPLICIT NONE
REAL (DP) :: msg
INTEGER :: msglen, source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, msglen, source, group )
mp_call_count( 5 ) = mp_call_count( 5 ) + 1
mp_call_sizex( 5 ) = MAX( mp_call_sizex( 5 ), msglen )
#endif
END SUBROUTINE mp_bcast_r1
!
!------------------------------------------------------------------------------!
!
SUBROUTINE mp_bcast_rv(msg,source,gid)
IMPLICIT NONE
REAL (DP) :: msg(:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, msglen, source, group )
mp_call_count( 6 ) = mp_call_count( 6 ) + 1
mp_call_sizex( 6 ) = MAX( mp_call_sizex( 6 ), msglen )
#endif
END SUBROUTINE mp_bcast_rv
!
!------------------------------------------------------------------------------!
!
SUBROUTINE mp_bcast_rm(msg,source,gid)
IMPLICIT NONE
REAL (DP) :: msg(:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, msglen, source, group )
mp_call_count( 7 ) = mp_call_count( 7 ) + 1
mp_call_sizex( 7 ) = MAX( mp_call_sizex( 7 ), msglen )
#endif
END SUBROUTINE mp_bcast_rm
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_bcast_rt(msg,source,gid)
IMPLICIT NONE
REAL (DP) :: msg(:,:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, msglen, source, group )
mp_call_count( 8 ) = mp_call_count( 8 ) + 1
mp_call_sizex( 8 ) = MAX( mp_call_sizex( 8 ), msglen )
#endif
END SUBROUTINE mp_bcast_rt
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_bcast_r4d(msg, source, gid)
IMPLICIT NONE
REAL (DP) :: msg(:,:,:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, msglen, source, group )
mp_call_count( 9 ) = mp_call_count( 9 ) + 1
mp_call_sizex( 9 ) = MAX( mp_call_sizex( 9 ), msglen )
#endif
END SUBROUTINE mp_bcast_r4d
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_bcast_r5d(msg, source, gid)
IMPLICIT NONE
REAL (DP) :: msg(:,:,:,:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, msglen, source, group )
mp_call_count( 10 ) = mp_call_count( 10 ) + 1
mp_call_sizex( 10 ) = MAX( mp_call_sizex( 10 ), msglen )
#endif
END SUBROUTINE mp_bcast_r5d
!------------------------------------------------------------------------------!
!
SUBROUTINE mp_bcast_c1(msg,source,gid)
IMPLICIT NONE
COMPLEX (DP) :: msg
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, 2 * msglen, source, group )
mp_call_count( 11 ) = mp_call_count( 11 ) + 1
mp_call_sizex( 11 ) = MAX( mp_call_sizex( 11 ), msglen )
#endif
END SUBROUTINE mp_bcast_c1
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_bcast_cv(msg,source,gid)
IMPLICIT NONE
COMPLEX (DP) :: msg(:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, 2 * msglen, source, group )
mp_call_count( 12 ) = mp_call_count( 12 ) + 1
mp_call_sizex( 12 ) = MAX( mp_call_sizex( 12 ), msglen )
#endif
END SUBROUTINE mp_bcast_cv
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_bcast_cm(msg,source,gid)
IMPLICIT NONE
COMPLEX (DP) :: msg(:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, 2 * msglen, source, group )
mp_call_count( 13 ) = mp_call_count( 13 ) + 1
mp_call_sizex( 13 ) = MAX( mp_call_sizex( 13 ), msglen )
#endif
END SUBROUTINE mp_bcast_cm
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_bcast_ct(msg,source,gid)
IMPLICIT NONE
COMPLEX (DP) :: msg(:,:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, 2 * msglen, source, group )
mp_call_count( 14 ) = mp_call_count( 14 ) + 1
mp_call_sizex( 14 ) = MAX( mp_call_sizex( 14 ), msglen )
#endif
END SUBROUTINE mp_bcast_ct
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_bcast_c4d(msg,source,gid)
IMPLICIT NONE
COMPLEX (DP) :: msg(:,:,:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_real( msg, 2 * msglen, source, group )
mp_call_count( 15 ) = mp_call_count( 15 ) + 1
mp_call_sizex( 15 ) = MAX( mp_call_sizex( 15 ), msglen )
#endif
END SUBROUTINE mp_bcast_c4d
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_bcast_l(msg,source,gid)
IMPLICIT NONE
LOGICAL :: msg
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_logical( msg, msglen, source, group )
mp_call_count( 16 ) = mp_call_count( 16 ) + 1
mp_call_sizex( 16 ) = MAX( mp_call_sizex( 16 ), msglen )
#endif
END SUBROUTINE mp_bcast_l
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_bcast_lv(msg,source,gid)
IMPLICIT NONE
LOGICAL :: msg(:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_logical( msg, msglen, source, group )
mp_call_count( 17 ) = mp_call_count( 17 ) + 1
mp_call_sizex( 17 ) = MAX( mp_call_sizex( 17 ), msglen )
#endif
END SUBROUTINE mp_bcast_lv
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_bcast_lm(msg,source,gid)
IMPLICIT NONE
LOGICAL :: msg(:,:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL bcast_logical( msg, msglen, source, group )
mp_call_count( 18 ) = mp_call_count( 18 ) + 1
mp_call_sizex( 18 ) = MAX( mp_call_sizex( 18 ), msglen )
#endif
END SUBROUTINE mp_bcast_lm
!
!------------------------------------------------------------------------------!
!
SUBROUTINE mp_bcast_z(msg,source,gid)
IMPLICIT NONE
CHARACTER (len=*) :: msg
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen, ierr, i
INTEGER, ALLOCATABLE :: imsg(:)
#if defined(__MPI)
ierr = 0
msglen = len(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
IF (ierr/=0) CALL mp_stop( 8014 )
ALLOCATE (imsg(1:msglen), STAT=ierr)
IF (ierr/=0) CALL mp_stop( 8015 )
DO i = 1, msglen
imsg(i) = ichar(msg(i:i))
END DO
CALL bcast_integer( imsg, msglen, source, group )
DO i = 1, msglen
msg(i:i) = char(imsg(i))
END DO
DEALLOCATE (imsg, STAT=ierr)
IF (ierr/=0) CALL mp_stop( 8016 )
mp_call_count( 19 ) = mp_call_count( 19 ) + 1
mp_call_sizex( 19 ) = MAX( mp_call_sizex( 19 ), msglen )
#endif
END SUBROUTINE mp_bcast_z
!
!------------------------------------------------------------------------------!
!
!------------------------------------------------------------------------------!
!
SUBROUTINE mp_bcast_zv(msg,source,gid)
IMPLICIT NONE
CHARACTER (len=*) :: msg(:)
INTEGER :: source
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen, m1, m2, ierr, i, j
INTEGER, ALLOCATABLE :: imsg(:,:)
#if defined(__MPI)
ierr = 0
m1 = LEN(msg)
m2 = SIZE(msg)
msglen = LEN(msg)*SIZE(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
ALLOCATE (imsg(1:m1,1:m2), STAT=ierr)
IF (ierr/=0) CALL mp_stop( 8017 )
DO j = 1, m2
DO i = 1, m1
imsg(i,j) = ichar(msg(j)(i:i))
END DO
END DO
CALL bcast_integer( imsg, msglen, source, group )
DO j = 1, m2
DO i = 1, m1
msg(j)(i:i) = char(imsg(i,j))
END DO
END DO
DEALLOCATE (imsg, STAT=ierr)
IF (ierr/=0) CALL mp_stop( 8018 )
mp_call_count( 20 ) = mp_call_count( 20 ) + 1
mp_call_sizex( 20 ) = MAX( mp_call_sizex( 20 ), msglen )
#endif
END SUBROUTINE mp_bcast_zv
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_get_i1(msg_dest, msg_sour, mpime, dest, sour, ip, gid)
INTEGER :: msg_dest, msg_sour
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen = 1
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(dest .NE. sour) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
msglen=1
CALL MPI_SEND( msg_sour, msglen, MPI_INTEGER, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8019 )
ELSE IF(mpime .EQ. dest) THEN
msglen=1
CALL MPI_RECV( msg_dest, msglen, MPI_INTEGER, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8020 )
CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8021 )
END IF
#endif
ELSE
msg_dest = msg_sour
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8022 )
#endif
mp_call_count( 21 ) = mp_call_count( 21 ) + 1
mp_call_sizex( 21 ) = MAX( mp_call_sizex( 21 ), msglen )
RETURN
END SUBROUTINE mp_get_i1
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_get_iv(msg_dest, msg_sour, mpime, dest, sour, ip, gid)
INTEGER :: msg_dest(:), msg_sour(:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(sour .NE. dest) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
msglen = SIZE(msg_sour)
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_INTEGER, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8023 )
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_INTEGER, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8024 )
CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8025 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour)) = msg_sour(:)
msglen = SIZE(msg_sour)
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8026 )
#endif
mp_call_count( 22 ) = mp_call_count( 22 ) + 1
mp_call_sizex( 22 ) = MAX( mp_call_sizex( 22 ), msglen )
RETURN
END SUBROUTINE mp_get_iv
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_get_rv(msg_dest, msg_sour, mpime, dest, sour, ip, gid)
REAL (DP) :: msg_dest(:), msg_sour(:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(sour .NE. dest) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
msglen = SIZE(msg_sour)
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8027 )
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8028 )
CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8029 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour)) = msg_sour(:)
msglen = SIZE(msg_sour)
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8030 )
#endif
mp_call_count( 23 ) = mp_call_count( 23 ) + 1
mp_call_sizex( 23 ) = MAX( mp_call_sizex( 23 ), msglen )
RETURN
END SUBROUTINE mp_get_rv
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_get_rm(msg_dest, msg_sour, mpime, dest, sour, ip, gid)
REAL (DP) :: msg_dest(:,:), msg_sour(:,:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(sour .NE. dest) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8031 )
msglen = SIZE(msg_sour)
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8032 )
CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8033 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour,1), 1:SIZE(msg_sour,2)) = msg_sour(:,:)
msglen = SIZE( msg_sour )
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8034 )
#endif
mp_call_count( 24 ) = mp_call_count( 24 ) + 1
mp_call_sizex( 24 ) = MAX( mp_call_sizex( 24 ), msglen )
RETURN
END SUBROUTINE mp_get_rm
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_get_cv(msg_dest, msg_sour, mpime, dest, sour, ip, gid)
COMPLEX (DP) :: msg_dest(:), msg_sour(:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF( dest .NE. sour ) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_COMPLEX, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8035 )
msglen = SIZE(msg_sour)
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_COMPLEX, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8036 )
CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_COMPLEX, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8037 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour)) = msg_sour(:)
msglen = SIZE(msg_sour)
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8038 )
#endif
mp_call_count( 25 ) = mp_call_count( 25 ) + 1
mp_call_sizex( 25 ) = MAX( mp_call_sizex( 25 ), msglen )
RETURN
END SUBROUTINE mp_get_cv
!------------------------------------------------------------------------------!
!
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_put_i1(msg_dest, msg_sour, mpime, sour, dest, ip, gid)
INTEGER :: msg_dest, msg_sour
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(dest .NE. sour) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
CALL MPI_SEND( msg_sour, 1, MPI_INTEGER, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8039 )
msglen = 1
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, 1, MPI_INTEGER, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8040 )
CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8041 )
msglen = 1
END IF
#endif
ELSE
msg_dest = msg_sour
msglen = 1
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8042 )
#endif
mp_call_count( 26 ) = mp_call_count( 26 ) + 1
mp_call_sizex( 26 ) = MAX( mp_call_sizex( 26 ), msglen )
RETURN
END SUBROUTINE mp_put_i1
!------------------------------------------------------------------------------!
!
!
SUBROUTINE mp_put_iv(msg_dest, msg_sour, mpime, sour, dest, ip, gid)
INTEGER :: msg_dest(:), msg_sour(:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(sour .NE. dest) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_INTEGER, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8043 )
msglen = SIZE(msg_sour)
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_INTEGER, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8044 )
CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8045 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour)) = msg_sour(:)
msglen = SIZE(msg_sour)
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8046 )
#endif
mp_call_count( 27 ) = mp_call_count( 27 ) + 1
mp_call_sizex( 27 ) = MAX( mp_call_sizex( 27 ), msglen )
RETURN
END SUBROUTINE mp_put_iv
!------------------------------------------------------------------------------!
!
!
SUBROUTINE mp_put_rv(msg_dest, msg_sour, mpime, sour, dest, ip, gid)
REAL (DP) :: msg_dest(:), msg_sour(:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(sour .NE. dest) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8047 )
msglen = SIZE(msg_sour)
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8048 )
CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8049 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour)) = msg_sour(:)
msglen = SIZE(msg_sour)
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8050 )
#endif
mp_call_count( 28 ) = mp_call_count( 28 ) + 1
mp_call_sizex( 28 ) = MAX( mp_call_sizex( 28 ), msglen )
RETURN
END SUBROUTINE mp_put_rv
!------------------------------------------------------------------------------!
!
!
SUBROUTINE mp_put_rm(msg_dest, msg_sour, mpime, sour, dest, ip, gid)
REAL (DP) :: msg_dest(:,:), msg_sour(:,:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF(sour .NE. dest) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8051 )
msglen = SIZE(msg_sour)
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8052 )
CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8053 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour,1),1:SIZE(msg_sour,2)) = msg_sour(:,:)
msglen = SIZE(msg_sour)
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8054 )
#endif
mp_call_count( 29 ) = mp_call_count( 29 ) + 1
mp_call_sizex( 29 ) = MAX( mp_call_sizex( 29 ), msglen )
RETURN
END SUBROUTINE mp_put_rm
!------------------------------------------------------------------------------!
!
!
SUBROUTINE mp_put_cv(msg_dest, msg_sour, mpime, sour, dest, ip, gid)
COMPLEX (DP) :: msg_dest(:), msg_sour(:)
INTEGER, INTENT(IN) :: dest, sour, ip, mpime
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
#if defined(__MPI)
INTEGER :: istatus(MPI_STATUS_SIZE)
#endif
INTEGER :: ierr, nrcv
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
#endif
! processors not taking part in the communication have 0 length message
msglen = 0
IF( dest .NE. sour ) THEN
#if defined(__MPI)
IF(mpime .EQ. sour) THEN
CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_COMPLEX, dest, ip, group, ierr)
IF (ierr/=0) CALL mp_stop( 8055 )
msglen = SIZE(msg_sour)
ELSE IF(mpime .EQ. dest) THEN
CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_COMPLEX, sour, ip, group, istatus, IERR )
IF (ierr/=0) CALL mp_stop( 8056 )
CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_COMPLEX, nrcv, ierr)
IF (ierr/=0) CALL mp_stop( 8057 )
msglen = nrcv
END IF
#endif
ELSE
msg_dest(1:SIZE(msg_sour)) = msg_sour(:)
msglen = SIZE(msg_sour)
END IF
#if defined(__MPI)
CALL MPI_BARRIER(group, IERR)
IF (ierr/=0) CALL mp_stop( 8058 )
#endif
mp_call_count( 30 ) = mp_call_count( 30 ) + 1
mp_call_sizex( 30 ) = MAX( mp_call_sizex( 30 ), msglen )
RETURN
END SUBROUTINE mp_put_cv
!
!------------------------------------------------------------------------------!
!
!..mp_stop
!
SUBROUTINE mp_stop(code)
IMPLICIT NONE
INTEGER, INTENT (IN) :: code
WRITE( stdout, fmt='( "*** error in Message Passing (mp) module ***")' )
WRITE( stdout, fmt='( "*** error msg: ",A60)' ) TRIM( err_msg )
WRITE( stdout, fmt='( "*** error code: ",I5)' ) code
#if defined(__MPI)
CALL mpi_abort(mpi_comm_world,code)
#endif
STOP
END SUBROUTINE mp_stop
!------------------------------------------------------------------------------!
!
!..mp_sum
SUBROUTINE mp_sum_i1(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_integer( msglen, msg, group, -1 )
mp_call_count( 31 ) = mp_call_count( 31 ) + 1
mp_call_sizex( 31 ) = MAX( mp_call_sizex( 31 ), msglen )
#endif
END SUBROUTINE mp_sum_i1
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_iv(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg(:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = size(msg)
CALL reduce_base_integer( msglen, msg, group, -1 )
mp_call_count( 32 ) = mp_call_count( 32 ) + 1
mp_call_sizex( 32 ) = MAX( mp_call_sizex( 32 ), msglen )
#endif
END SUBROUTINE mp_sum_iv
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_im(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg(:,:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = size(msg)
CALL reduce_base_integer( msglen, msg, group, -1 )
mp_call_count( 33 ) = mp_call_count( 33 ) + 1
mp_call_sizex( 33 ) = MAX( mp_call_sizex( 33 ), msglen )
#endif
END SUBROUTINE mp_sum_im
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_it(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg(:,:,:)
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = size(msg)
CALL reduce_base_integer( msglen, msg, group, -1 )
mp_call_count( 34 ) = mp_call_count( 34 ) + 1
mp_call_sizex( 34 ) = MAX( mp_call_sizex( 34 ), msglen )
#endif
END SUBROUTINE mp_sum_it
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_r1(msg,gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( msglen, msg, group, -1 )
mp_call_count( 35 ) = mp_call_count( 35 ) + 1
mp_call_sizex( 35 ) = MAX( mp_call_sizex( 35 ), msglen )
#endif
END SUBROUTINE mp_sum_r1
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_rv(msg,gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg(:)
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( msglen, msg, group, -1 )
mp_call_count( 36 ) = mp_call_count( 36 ) + 1
mp_call_sizex( 36 ) = MAX( mp_call_sizex( 36 ), msglen )
#endif
END SUBROUTINE mp_sum_rv
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_rm(msg, gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg(:,:)
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( msglen, msg, group, -1 )
mp_call_count( 37 ) = mp_call_count( 37 ) + 1
mp_call_sizex( 37 ) = MAX( mp_call_sizex( 37 ), msglen )
#endif
END SUBROUTINE mp_sum_rm
SUBROUTINE mp_root_sum_rm( msg, res, root, gid )
IMPLICIT NONE
REAL (DP), INTENT (IN) :: msg(:,:)
REAL (DP), INTENT (OUT) :: res(:,:)
INTEGER, INTENT (IN) :: root
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen, ierr, taskid
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_rank( group, taskid, ierr)
IF( ierr /= 0 ) CALL mp_stop( 8059 )
!
IF( taskid == root ) THEN
IF( msglen > size(res) ) CALL mp_stop( 8060 )
END IF
CALL reduce_base_real_to( msglen, msg, res, group, root )
mp_call_count( 38 ) = mp_call_count( 38 ) + 1
mp_call_sizex( 38 ) = MAX( mp_call_sizex( 38 ), msglen )
#else
res = msg
#endif
END SUBROUTINE mp_root_sum_rm
SUBROUTINE mp_root_sum_cm( msg, res, root, gid )
IMPLICIT NONE
COMPLEX (DP), INTENT (IN) :: msg(:,:)
COMPLEX (DP), INTENT (OUT) :: res(:,:)
INTEGER, INTENT (IN) :: root
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen, ierr, taskid
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_rank( group, taskid, ierr)
IF( ierr /= 0 ) CALL mp_stop( 8061 )
IF( taskid == root ) THEN
IF( msglen > size(res) ) CALL mp_stop( 8062 )
END IF
CALL reduce_base_real_to( 2 * msglen, msg, res, group, root )
mp_call_count( 39 ) = mp_call_count( 39 ) + 1
mp_call_sizex( 39 ) = MAX( mp_call_sizex( 39 ), msglen )
#else
res = msg
#endif
END SUBROUTINE mp_root_sum_cm
!
!------------------------------------------------------------------------------!
!------------------------------------------------------------------------------!
!
SUBROUTINE mp_sum_rmm( msg, res, root, gid )
IMPLICIT NONE
REAL (DP), INTENT (IN) :: msg(:,:)
REAL (DP), INTENT (OUT) :: res(:,:)
INTEGER, OPTIONAL, INTENT (IN) :: root
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen
INTEGER :: taskid, ierr
msglen = size(msg)
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
IF( PRESENT( root ) ) THEN
!
CALL mpi_comm_rank( group, taskid, ierr)
IF( ierr /= 0 ) CALL mp_stop( 8063 )
IF( taskid == root ) THEN
IF( msglen > size(res) ) CALL mp_stop( 8064 )
END IF
!
CALL reduce_base_real_to( msglen, msg, res, group, root )
!
ELSE
!
IF( msglen > size(res) ) CALL mp_stop( 8065 )
!
CALL reduce_base_real_to( msglen, msg, res, group, -1 )
!
END IF
mp_call_count( 40 ) = mp_call_count( 40 ) + 1
mp_call_sizex( 40 ) = MAX( mp_call_sizex( 40 ), msglen )
#else
res = msg
#endif
END SUBROUTINE mp_sum_rmm
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_rt( msg, gid )
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg(:,:,:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( msglen, msg, group, -1 )
mp_call_count( 41 ) = mp_call_count( 41 ) + 1
mp_call_sizex( 41 ) = MAX( mp_call_sizex( 41 ), msglen )
#endif
END SUBROUTINE mp_sum_rt
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_sum_r4d(msg,gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg(:,:,:,:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( msglen, msg, group, -1 )
mp_call_count( 42 ) = mp_call_count( 42 ) + 1
mp_call_sizex( 42 ) = MAX( mp_call_sizex( 42 ), msglen )
#endif
END SUBROUTINE mp_sum_r4d
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_c1(msg,gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (INOUT) :: msg
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( 2 * msglen, msg, group, -1 )
mp_call_count( 43 ) = mp_call_count( 43 ) + 1
mp_call_sizex( 43 ) = MAX( mp_call_sizex( 43 ), msglen )
#endif
END SUBROUTINE mp_sum_c1
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_cv(msg,gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (INOUT) :: msg(:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( 2 * msglen, msg, group, -1 )
mp_call_count( 44 ) = mp_call_count( 44 ) + 1
mp_call_sizex( 44 ) = MAX( mp_call_sizex( 44 ), msglen )
#endif
END SUBROUTINE mp_sum_cv
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_cm(msg, gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (INOUT) :: msg(:,:)
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( 2 * msglen, msg, group, -1 )
mp_call_count( 45 ) = mp_call_count( 45 ) + 1
mp_call_sizex( 45 ) = MAX( mp_call_sizex( 45 ), msglen )
#endif
END SUBROUTINE mp_sum_cm
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_sum_cmm(msg, res, gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (IN) :: msg(:,:)
COMPLEX (DP), INTENT (OUT) :: res(:,:)
INTEGER, OPTIONAL, INTENT (IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real_to( 2 * msglen, msg, res, group, -1 )
mp_call_count( 46 ) = mp_call_count( 46 ) + 1
mp_call_sizex( 46 ) = MAX( mp_call_sizex( 46 ), msglen )
#else
res = msg
#endif
END SUBROUTINE mp_sum_cmm
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_sum_ct(msg,gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = SIZE(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( 2 * msglen, msg, group, -1 )
mp_call_count( 47 ) = mp_call_count( 47 ) + 1
mp_call_sizex( 47 ) = MAX( mp_call_sizex( 47 ), msglen )
#endif
END SUBROUTINE mp_sum_ct
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_sum_c4d(msg,gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:,:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( 2 * msglen, msg, group, -1 )
mp_call_count( 48 ) = mp_call_count( 48 ) + 1
mp_call_sizex( 48 ) = MAX( mp_call_sizex( 48 ), msglen )
#endif
END SUBROUTINE mp_sum_c4d
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_sum_c5d(msg,gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:,:,:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( 2 * msglen, msg, group, -1 )
mp_call_count( 49 ) = mp_call_count( 49 ) + 1
mp_call_sizex( 49 ) = MAX( mp_call_sizex( 49 ), msglen )
#endif
END SUBROUTINE mp_sum_c5d
!
!------------------------------------------------------------------------------!
!
! Carlo Cavazzoni
!
SUBROUTINE mp_sum_c6d(msg,gid)
IMPLICIT NONE
COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:,:,:,:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = size(msg)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL reduce_base_real( 2 * msglen, msg, group, -1 )
mp_call_count( 50 ) = mp_call_count( 50 ) + 1
mp_call_sizex( 50 ) = MAX( mp_call_sizex( 50 ), msglen )
#endif
END SUBROUTINE mp_sum_c6d
!------------------------------------------------------------------------------!
SUBROUTINE mp_max_i(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
msglen = 1
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL parallel_max_integer( msglen, msg, group, -1 )
mp_call_count( 51 ) = mp_call_count( 51 ) + 1
mp_call_sizex( 51 ) = MAX( mp_call_sizex( 51 ), msglen )
#endif
END SUBROUTINE mp_max_i
!
!------------------------------------------------------------------------------!
!
!..mp_max_iv
!..Carlo Cavazzoni
!
SUBROUTINE mp_max_iv(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg(:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = size(msg)
CALL parallel_max_integer( msglen, msg, group, -1 )
mp_call_count( 52 ) = mp_call_count( 52 ) + 1
mp_call_sizex( 52 ) = MAX( mp_call_sizex( 52 ), msglen )
#endif
END SUBROUTINE mp_max_iv
!
!----------------------------------------------------------------------
SUBROUTINE mp_max_r(msg,gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = 1
CALL parallel_max_real( msglen, msg, group, -1 )
mp_call_count( 53 ) = mp_call_count( 53 ) + 1
mp_call_sizex( 53 ) = MAX( mp_call_sizex( 53 ), msglen )
#endif
END SUBROUTINE mp_max_r
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_max_rv(msg,gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg(:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = size(msg)
CALL parallel_max_real( msglen, msg, group, -1 )
mp_call_count( 54 ) = mp_call_count( 54 ) + 1
mp_call_sizex( 54 ) = MAX( mp_call_sizex( 54 ), msglen )
#endif
END SUBROUTINE mp_max_rv
!------------------------------------------------------------------------------!
SUBROUTINE mp_min_i(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = 1
CALL parallel_min_integer( msglen, msg, group, -1 )
mp_call_count( 55 ) = mp_call_count( 55 ) + 1
mp_call_sizex( 55 ) = MAX( mp_call_sizex( 55 ), msglen )
#endif
END SUBROUTINE mp_min_i
!------------------------------------------------------------------------------!
SUBROUTINE mp_min_iv(msg,gid)
IMPLICIT NONE
INTEGER, INTENT (INOUT) :: msg(:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = SIZE(msg)
CALL parallel_min_integer( msglen, msg, group, -1 )
mp_call_count( 56 ) = mp_call_count( 56 ) + 1
mp_call_sizex( 56 ) = MAX( mp_call_sizex( 56 ), msglen )
#endif
END SUBROUTINE mp_min_iv
!------------------------------------------------------------------------------!
SUBROUTINE mp_min_r(msg,gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = 1
CALL parallel_min_real( msglen, msg, group, -1 )
mp_call_count( 57 ) = mp_call_count( 57 ) + 1
mp_call_sizex( 57 ) = MAX( mp_call_sizex( 57 ), msglen )
#endif
END SUBROUTINE mp_min_r
!
!------------------------------------------------------------------------------!
SUBROUTINE mp_min_rv(msg,gid)
IMPLICIT NONE
REAL (DP), INTENT (INOUT) :: msg(:)
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: msglen
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
msglen = size(msg)
CALL parallel_min_real( msglen, msg, group, -1 )
mp_call_count( 58 ) = mp_call_count( 58 ) + 1
mp_call_sizex( 58 ) = MAX( mp_call_sizex( 58 ), msglen )
#endif
END SUBROUTINE mp_min_rv
!------------------------------------------------------------------------------!
SUBROUTINE mp_barrier(gid)
IMPLICIT NONE
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: ierr
#if defined(__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL MPI_BARRIER(group,IERR)
IF (ierr/=0) CALL mp_stop( 8066 )
#endif
END SUBROUTINE mp_barrier
!------------------------------------------------------------------------------!
!.. Carlo Cavazzoni
!..mp_rank
FUNCTION mp_rank( comm )
IMPLICIT NONE
INTEGER :: mp_rank
INTEGER, OPTIONAL, INTENT(IN) :: comm
INTEGER :: ierr, taskid
ierr = 0
taskid = 0
#if defined(__MPI)
IF( PRESENT( comm ) ) THEN
CALL mpi_comm_rank(comm,taskid,ierr)
ELSE
CALL mpi_comm_rank(mpi_comm_world,taskid,ierr)
END IF
IF (ierr/=0) CALL mp_stop( 8067 )
#endif
mp_rank = taskid
END FUNCTION mp_rank
!------------------------------------------------------------------------------!
!.. Carlo Cavazzoni
!..mp_size
FUNCTION mp_size( comm )
IMPLICIT NONE
INTEGER :: mp_size
INTEGER, OPTIONAL, INTENT(IN) :: comm
INTEGER :: ierr, numtask
ierr = 0
numtask = 1
#if defined(__MPI)
IF( PRESENT( comm ) ) THEN
CALL mpi_comm_size(comm,numtask,ierr)
ELSE
CALL mpi_comm_size(mpi_comm_world,numtask,ierr)
END IF
IF (ierr/=0) CALL mp_stop( 8068 )
#endif
mp_size = numtask
END FUNCTION mp_size
SUBROUTINE mp_report
INTEGER :: i
WRITE( stdout, *)
#if defined(__MPI)
# if defined (__MP_STAT)
WRITE( stdout, 20 )
DO i = 1, SIZE( mp_call_count )
IF( mp_call_count( i ) > 0 ) THEN
WRITE( stdout, 30 ) i, mp_call_count( i ), mp_call_sizex( i )
END IF
END DO
# endif
10 FORMAT(3X,'Message Passing, maximum message size (bytes) : ',I15)
20 FORMAT(3X,'Sub. calls maxsize')
30 FORMAT(3X,I4,I8,I10)
#else
WRITE( stdout, *)
#endif
RETURN
END SUBROUTINE mp_report
!------------------------------------------------------------------------------!
!..mp_gatherv_rv
!..Carlo Cavazzoni
SUBROUTINE mp_gatherv_rv( mydata, alldata, recvcount, displs, root, gid)
IMPLICIT NONE
REAL(DP) :: mydata(:)
REAL(DP) :: alldata(:)
INTEGER, INTENT(IN) :: recvcount(:), displs(:), root
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: ierr, npe, myid
#if defined (__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_size( group, npe, ierr )
IF (ierr/=0) CALL mp_stop( 8069 )
CALL mpi_comm_rank( group, myid, ierr )
IF (ierr/=0) CALL mp_stop( 8070 )
!
IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 )
IF ( myid == root ) THEN
IF ( SIZE( alldata ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 )
END IF
IF ( SIZE( mydata ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 )
!
CALL MPI_GATHERV( mydata, recvcount( myid + 1 ), MPI_DOUBLE_PRECISION, &
alldata, recvcount, displs, MPI_DOUBLE_PRECISION, root, group, ierr )
IF (ierr/=0) CALL mp_stop( 8074 )
#else
IF ( SIZE( alldata ) < recvcount( 1 ) ) CALL mp_stop( 8075 )
IF ( SIZE( mydata ) < recvcount( 1 ) ) CALL mp_stop( 8076 )
!
alldata( 1:recvcount( 1 ) ) = mydata( 1:recvcount( 1 ) )
#endif
RETURN
END SUBROUTINE mp_gatherv_rv
!------------------------------------------------------------------------------!
!..mp_gatherv_cv
!..Carlo Cavazzoni
SUBROUTINE mp_gatherv_cv( mydata, alldata, recvcount, displs, root, gid)
IMPLICIT NONE
COMPLEX(DP) :: mydata(:)
COMPLEX(DP) :: alldata(:)
INTEGER, INTENT(IN) :: recvcount(:), displs(:), root
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: ierr, npe, myid
#if defined (__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_size( group, npe, ierr )
IF (ierr/=0) CALL mp_stop( 8069 )
CALL mpi_comm_rank( group, myid, ierr )
IF (ierr/=0) CALL mp_stop( 8070 )
!
IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 )
IF ( myid == root ) THEN
IF ( SIZE( alldata ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 )
END IF
IF ( SIZE( mydata ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 )
!
CALL MPI_GATHERV( mydata, recvcount( myid + 1 ), MPI_DOUBLE_COMPLEX, &
alldata, recvcount, displs, MPI_DOUBLE_COMPLEX, root, group, ierr )
IF (ierr/=0) CALL mp_stop( 8074 )
#else
IF ( SIZE( alldata ) < recvcount( 1 ) ) CALL mp_stop( 8075 )
IF ( SIZE( mydata ) < recvcount( 1 ) ) CALL mp_stop( 8076 )
!
alldata( 1:recvcount( 1 ) ) = mydata( 1:recvcount( 1 ) )
#endif
RETURN
END SUBROUTINE mp_gatherv_cv
!------------------------------------------------------------------------------!
!..mp_gatherv_rv
!..Carlo Cavazzoni
SUBROUTINE mp_gatherv_iv( mydata, alldata, recvcount, displs, root, gid)
IMPLICIT NONE
INTEGER :: mydata(:)
INTEGER :: alldata(:)
INTEGER, INTENT(IN) :: recvcount(:), displs(:), root
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: ierr, npe, myid
#if defined (__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_size( group, npe, ierr )
IF (ierr/=0) CALL mp_stop( 8069 )
CALL mpi_comm_rank( group, myid, ierr )
IF (ierr/=0) CALL mp_stop( 8070 )
!
IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 )
IF ( myid == root ) THEN
IF ( SIZE( alldata ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 )
END IF
IF ( SIZE( mydata ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 )
!
CALL MPI_GATHERV( mydata, recvcount( myid + 1 ), MPI_INTEGER, &
alldata, recvcount, displs, MPI_INTEGER, root, group, ierr )
IF (ierr/=0) CALL mp_stop( 8074 )
#else
IF ( SIZE( alldata ) < recvcount( 1 ) ) CALL mp_stop( 8075 )
IF ( SIZE( mydata ) < recvcount( 1 ) ) CALL mp_stop( 8076 )
!
alldata( 1:recvcount( 1 ) ) = mydata( 1:recvcount( 1 ) )
#endif
RETURN
END SUBROUTINE mp_gatherv_iv
!------------------------------------------------------------------------------!
!..mp_gatherv_rm
!..Carlo Cavazzoni
SUBROUTINE mp_gatherv_rm( mydata, alldata, recvcount, displs, root, gid)
IMPLICIT NONE
REAL(DP) :: mydata(:,:) ! Warning first dimension is supposed constant!
REAL(DP) :: alldata(:,:)
INTEGER, INTENT(IN) :: recvcount(:), displs(:), root
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: ierr, npe, myid, nsiz
INTEGER, ALLOCATABLE :: nrecv(:), ndisp(:)
#if defined (__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_size( group, npe, ierr )
IF (ierr/=0) CALL mp_stop( 8069 )
CALL mpi_comm_rank( group, myid, ierr )
IF (ierr/=0) CALL mp_stop( 8070 )
!
IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 )
IF ( myid == root ) THEN
IF ( SIZE( alldata, 2 ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 )
IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8072 )
END IF
IF ( SIZE( mydata, 2 ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 )
!
ALLOCATE( nrecv( npe ), ndisp( npe ) )
!
nrecv( 1:npe ) = recvcount( 1:npe ) * SIZE( mydata, 1 )
ndisp( 1:npe ) = displs( 1:npe ) * SIZE( mydata, 1 )
!
CALL MPI_GATHERV( mydata, nrecv( myid + 1 ), MPI_DOUBLE_PRECISION, &
alldata, nrecv, ndisp, MPI_DOUBLE_PRECISION, root, group, ierr )
IF (ierr/=0) CALL mp_stop( 8074 )
!
DEALLOCATE( nrecv, ndisp )
!
#else
IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8075 )
IF ( SIZE( alldata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8075 )
IF ( SIZE( mydata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8076 )
!
alldata( :, 1:recvcount( 1 ) ) = mydata( :, 1:recvcount( 1 ) )
#endif
RETURN
END SUBROUTINE mp_gatherv_rm
!------------------------------------------------------------------------------!
!..mp_gatherv_im
!..Carlo Cavazzoni
SUBROUTINE mp_gatherv_im( mydata, alldata, recvcount, displs, root, gid)
IMPLICIT NONE
INTEGER :: mydata(:,:) ! Warning first dimension is supposed constant!
INTEGER :: alldata(:,:)
INTEGER, INTENT(IN) :: recvcount(:), displs(:), root
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: group
INTEGER :: ierr, npe, myid, nsiz
INTEGER, ALLOCATABLE :: nrecv(:), ndisp(:)
#if defined (__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_size( group, npe, ierr )
IF (ierr/=0) CALL mp_stop( 8069 )
CALL mpi_comm_rank( group, myid, ierr )
IF (ierr/=0) CALL mp_stop( 8070 )
!
IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 )
IF ( myid == root ) THEN
IF ( SIZE( alldata, 2 ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 )
IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8072 )
END IF
IF ( SIZE( mydata, 2 ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 )
!
ALLOCATE( nrecv( npe ), ndisp( npe ) )
!
nrecv( 1:npe ) = recvcount( 1:npe ) * SIZE( mydata, 1 )
ndisp( 1:npe ) = displs( 1:npe ) * SIZE( mydata, 1 )
!
CALL MPI_GATHERV( mydata, nrecv( myid + 1 ), MPI_INTEGER, &
alldata, nrecv, ndisp, MPI_INTEGER, root, group, ierr )
IF (ierr/=0) CALL mp_stop( 8074 )
!
DEALLOCATE( nrecv, ndisp )
!
#else
IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8075 )
IF ( SIZE( alldata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8075 )
IF ( SIZE( mydata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8076 )
!
alldata( :, 1:recvcount( 1 ) ) = mydata( :, 1:recvcount( 1 ) )
#endif
RETURN
END SUBROUTINE mp_gatherv_im
!------------------------------------------------------------------------------!
SUBROUTINE mp_set_displs( recvcount, displs, ntot, nproc )
! Given the number of elements on each processor (recvcount), this subroutine
! sets the correct offsets (displs) to collect them on a single
! array with contiguous elemets
IMPLICIT NONE
INTEGER, INTENT(IN) :: recvcount(:) ! number of elements on each processor
INTEGER, INTENT(OUT) :: displs(:) ! offsets/displacements
INTEGER, INTENT(OUT) :: ntot
INTEGER, INTENT(IN) :: nproc
INTEGER :: i
displs( 1 ) = 0
!
#if defined (__MPI)
IF( nproc < 1 ) CALL mp_stop( 8090 )
DO i = 2, nproc
displs( i ) = displs( i - 1 ) + recvcount( i - 1 )
END DO
ntot = displs( nproc ) + recvcount( nproc )
#else
ntot = recvcount( 1 )
#endif
RETURN
END SUBROUTINE mp_set_displs
!------------------------------------------------------------------------------!
SUBROUTINE mp_alltoall_c3d( sndbuf, rcvbuf, gid )
IMPLICIT NONE
COMPLEX(DP) :: sndbuf( :, :, : )
COMPLEX(DP) :: rcvbuf( :, :, : )
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: nsiz, group, ierr, npe
#if defined (__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_size( group, npe, ierr )
IF (ierr/=0) CALL mp_stop( 8069 )
IF ( SIZE( sndbuf, 3 ) < npe ) CALL mp_stop( 8069 )
IF ( SIZE( rcvbuf, 3 ) < npe ) CALL mp_stop( 8069 )
nsiz = SIZE( sndbuf, 1 ) * SIZE( sndbuf, 2 )
CALL MPI_ALLTOALL( sndbuf, nsiz, MPI_DOUBLE_COMPLEX, &
rcvbuf, nsiz, MPI_DOUBLE_COMPLEX, group, ierr )
IF (ierr/=0) CALL mp_stop( 8074 )
#else
rcvbuf = sndbuf
#endif
RETURN
END SUBROUTINE mp_alltoall_c3d
!------------------------------------------------------------------------------!
SUBROUTINE mp_alltoall_i3d( sndbuf, rcvbuf, gid )
IMPLICIT NONE
INTEGER :: sndbuf( :, :, : )
INTEGER :: rcvbuf( :, :, : )
INTEGER, OPTIONAL, INTENT(IN) :: gid
INTEGER :: nsiz, group, ierr, npe
#if defined (__MPI)
group = mpi_comm_world
IF( PRESENT( gid ) ) group = gid
CALL mpi_comm_size( group, npe, ierr )
IF (ierr/=0) CALL mp_stop( 8069 )
IF ( SIZE( sndbuf, 3 ) < npe ) CALL mp_stop( 8069 )
IF ( SIZE( rcvbuf, 3 ) < npe ) CALL mp_stop( 8069 )
nsiz = SIZE( sndbuf, 1 ) * SIZE( sndbuf, 2 )
CALL MPI_ALLTOALL( sndbuf, nsiz, MPI_INTEGER, &
rcvbuf, nsiz, MPI_INTEGER, group, ierr )
IF (ierr/=0) CALL mp_stop( 8074 )
#else
rcvbuf = sndbuf
#endif
RETURN
END SUBROUTINE mp_alltoall_i3d
!------------------------------------------------------------------------------!
END MODULE mp
!------------------------------------------------------------------------------!
Reference in New Issue View Git Blame Copy Permalink