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

Some cleanup. C.S. 

git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@2770 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
sbraccia 2006-02-04 18:48:38 +00:00
parent da4450417d
commit 35a0bfed6f
1 changed files with 59 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
Modules/ptoolkit.f90
View File

@ -763,12 +763,10 @@
!
comm = comm_in
!
#ifdef __MPI
ELSE
!
comm = MPI_COMM_WORLD
!
#endif
END IF
#endif
!
@ -793,50 +791,50 @@
!
DEALLOCATE( aloc )
!
ELSE
!
CALL ptredv( a, nrl, d, e, evloc, nrl, nrl, n, nproc, mpime, comm )
!
END IF
!
CALL ptqliv( d, e, n, evloc, nrl, nrl )
CALL peigsrtv( d, evloc, nrl, n, nrl )
!
IF ( iopt == 1 ) THEN
!
DO i = 1,n
DO j = 1,n
a(j,i) = 0.D0
END DO
DO jl = 1,nrl
a((jl-1)*nproc + mpime + 1,i) = evloc(jl,i)
END DO
END DO
!
ELSE
!
CALL ptredv( a, nrl, d, e, evloc, nrl, nrl, n, nproc, mpime, comm )
!
END IF
!
CALL ptqliv( d, e, n, evloc, nrl, nrl )
CALL peigsrtv( d, evloc, nrl, n, nrl )
!
IF ( iopt == 1 ) THEN
!
DO i = 1,n
DO j = 1,n
a(j,i) = 0.D0
END DO
DO jl = 1,nrl
a((jl-1)*nproc + mpime + 1,i) = evloc(jl,i)
END DO
END DO
!
#if defined (__PARA)
# if defined (__MPI)
CALL MPI_ALLREDUCE( a, ev, n*n, &
MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr )
CALL MPI_ALLREDUCE( a, ev, n*n, &
MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr )
# endif
#else
ev = a
ev = a
#endif
!
ELSE
!
DO i = 1, n
DO jl = 1, nrl
ev(jl,i) = evloc(jl,i)
END DO
END DO
!
END IF
!
DEALLOCATE( evloc )
DEALLOCATE( e )
!
RETURN
!
!
ELSE
!
DO i = 1, n
DO jl = 1, nrl
ev(jl,i) = evloc(jl,i)
END DO
END DO
!
END IF
!
DEALLOCATE( evloc )
DEALLOCATE( e )
!
RETURN
!
END SUBROUTINE diagonalize
!==----------------------------------------------==!
@ -854,10 +852,8 @@
#if defined (__PARA) && defined (__MPI)
IF ( PRESENT( comm_in ) ) THEN
comm = comm_in
#ifdef __MPI
ELSE
comm = MPI_COMM_WORLD
#endif
END IF
#endif
CALL ptredv(ap, lda, w, sd, z, ldz, nrl, n, nproc, mpime, comm)
@ -878,19 +874,15 @@
ALLOCATE( work( 3*n ) )
#if defined __AIX
IOPT = 0
IF((JOBZ .EQ. 'V') .OR. (JOBZ .EQ. 'v') ) iopt = iopt + 1
IF((UPLO .EQ. 'U') .OR. (UPLO .EQ. 'u') ) iopt = iopt + 20
CALL DSPEV(IOPT, ap, w, z, ldz, n, work, 3*n)
#else
CALL DSPEV(jobz, uplo, n, ap(1), w(1), z(1,1), ldz, work, INFO)
IF( info .NE. 0 ) THEN
CALL errore( ' dspev_drv ', ' diagonalization failed ',info )
END IF
#endif
DEALLOCATE( work )
@ -928,12 +920,10 @@
!
comm = comm_in
!
#ifdef __MPI
ELSE
!
comm = MPI_COMM_WORLD
!
#endif
END IF
#endif
!
@ -1164,7 +1154,6 @@
REAL(DP) RONE, RZERO
PARAMETER ( RONE = 1.0D+0, RZERO = 0.0D+0 )
INTEGER QI
INTEGER IL(N+1)
INTEGER OW(N+1)
@ -1206,7 +1195,6 @@
RETURN
END IF
DO I = 1,N+1
QI = (I-1)/NPROC
OW(I) = MOD((I-1),NPROC)
@ -1232,10 +1220,8 @@
ALPHA = AP( IL(I+1), I )
END IF
#if defined __PARA
# if defined __MPI
#if defined (__PARA) && defined (__MPI)
CALL MPI_BCAST(ALPHA,1,MPI_DOUBLE_COMPLEX,OW(I+1),comm,IERR)
# endif
#endif
IF( (N-I).LE.0 ) THEN
@ -1488,20 +1474,16 @@
IF(OW(I).EQ.ME) THEN
D( I ) = DBLE(AP( IL(I),I ))
END IF
#if defined __PARA
# if defined __MPI
#if defined __PARA && defined __MPI
CALL MPI_BCAST(D(I),1,MPI_DOUBLE_PRECISION,OW(I), comm,IERR)
# endif
#endif
TAU( I ) = TAUI
END DO
IF(OW(I).EQ.ME) THEN
D( N ) = DBLE(AP( IL(I),I ))
END IF
#if defined __PARA
# if defined __MPI
#if defined __PARA && defined __MPI
CALL MPI_BCAST(D(N),1,MPI_DOUBLE_PRECISION,OW(I), comm,IERR)
# endif
#endif
!
RETURN
@ -2324,25 +2306,20 @@
COMPLEX(DP), ALLOCATABLE :: ZWORK(:)
#if defined __AIX
IOPT = 0
IF((JOBZ .EQ. 'V') .OR. (JOBZ .EQ. 'v') ) iopt = iopt + 1
IF((UPLO .EQ. 'U') .OR. (UPLO .EQ. 'u') ) iopt = iopt + 20
ALLOCATE( rwork( 4*n ) )
CALL ZHPEV(IOPT, ap, w, z, ldz, n, rwork, 4*n)
DEALLOCATE( rwork )
#else
ALLOCATE( rwork( MAX(1, 3*n-2) ), zwork( MAX(1, 2*n-1)) )
CALL ZHPEV(jobz, uplo, n, ap, w, z, ldz, zwork, rwork, INFO)
DEALLOCATE( rwork, zwork )
IF( info .NE. 0 ) THEN
CALL errore( ' dspev_drv ', ' diagonalization failed ',info )
END IF
#endif
RETURN
END SUBROUTINE zhpev_drv
@ -2364,10 +2341,8 @@
#if defined (__PARA) && defined (__MPI)
IF ( PRESENT( comm_in ) ) THEN
comm = comm_in
#ifdef __MPI
ELSE
comm = MPI_COMM_WORLD
#endif
END IF
#endif
CALL pzhptrd( n, nrl, ap, lda, w, rwork, cwork, nproc, mpime, comm)
@ -2378,15 +2353,12 @@
RETURN
END SUBROUTINE pzhpev_drv
!==----------------------------------------------==!
!
! My parallel blas
!
!==----------------------------------------------==!
SUBROUTINE mattr_drv( m, k, a, lda, b, ldb, nb, dims, coor, comm )
!
! Compute B as the transpose of matrix A
@ -2403,13 +2375,10 @@ SUBROUTINE mattr_drv( m, k, a, lda, b, ldb, nb, dims, coor, comm )
!
INTEGER, INTENT(IN) :: m, k
INTEGER, INTENT(IN) :: lda, ldb
REAL*8 :: a(lda,*), b(ldb,*)
REAL(DP) :: a(lda,*), b(ldb,*)
INTEGER, INTENT(IN) :: nb, dims(2), coor(2), comm
!
#if defined __MPI
include 'mpif.h'
!
integer ierr
integer ndims, rowid, colid
@ -2425,7 +2394,7 @@ SUBROUTINE mattr_drv( m, k, a, lda, b, ldb, nb, dims, coor, comm )
integer :: itag
integer :: nmb, nkb
integer :: istatus( MPI_STATUS_SIZE )
real*8, allocatable :: abuf(:,:)
real(DP), allocatable :: abuf(:,:)
!
integer :: numroc
integer :: indxg2l
@ -2530,7 +2499,6 @@ SUBROUTINE mattr_drv( m, k, a, lda, b, ldb, nb, dims, coor, comm )
END SUBROUTINE mattr_drv
! ---------------------------------------------------------------------------------
SUBROUTINE matsplit_drv( m, k, ar, ldar, a, lda, nb, dims, coor, comm )
@ -2539,9 +2507,9 @@ SUBROUTINE matsplit_drv( m, k, ar, ldar, a, lda, nb, dims, coor, comm )
!
INTEGER, INTENT(IN) :: m, k
INTEGER, INTENT(IN) :: ldar
REAL*8 :: ar(ldar,*) ! matrix to be splitted, replicated on all proc
REAL(DP) :: ar(ldar,*) ! matrix to be splitted, replicated on all proc
INTEGER, INTENT(IN) :: lda
REAL*8 :: a(lda,*)
REAL(DP) :: a(lda,*)
INTEGER, INTENT(IN) :: nb, coor(2), dims(2), comm
!
INTEGER :: i, j, nra, nca, ii, jj
@ -2564,8 +2532,6 @@ SUBROUTINE matsplit_drv( m, k, ar, ldar, a, lda, nb, dims, coor, comm )
END SUBROUTINE matsplit_drv
! ---------------------------------------------------------------------------------
SUBROUTINE matmerge_drv( m, k, a, lda, ar, ldar, nb, dims, coor, comm )
@ -2574,16 +2540,14 @@ SUBROUTINE matmerge_drv( m, k, a, lda, ar, ldar, nb, dims, coor, comm )
!
INTEGER, INTENT(IN) :: m, k
INTEGER, INTENT(IN) :: ldar
REAL*8 :: ar(ldar,*) ! matrix to be merged, replicated on all proc
REAL(DP) :: ar(ldar,*) ! matrix to be merged, replicated on all proc
INTEGER, INTENT(IN) :: lda
REAL*8 :: a(lda,*)
REAL(DP) :: a(lda,*)
INTEGER, INTENT(IN) :: nb, coor(2), dims(2), comm
!
INTEGER :: i, j, ii, jj, ierr
#if defined __MPI
include 'mpif.h'
!
INTEGER :: jsrc, isrc, ipsrc, coosrc(2)
@ -2655,11 +2619,11 @@ SUBROUTINE matscal_drv( m, n, beta, c, ldc, nb, dims, coor, comm )
!
implicit none
!
INTEGER, INTENT(IN) :: m, n
REAL*8, INTENT(IN) :: beta
INTEGER, INTENT(IN) :: ldc
REAL*8 :: c(ldc,*)
INTEGER, INTENT(IN) :: nb, coor(2), dims(2), comm
INTEGER, INTENT(IN) :: m, n
REAL(DP), INTENT(IN) :: beta
INTEGER, INTENT(IN) :: ldc
REAL(DP) :: c(ldc,*)
INTEGER, INTENT(IN) :: nb, coor(2), dims(2), comm
!
INTEGER :: i, j, nr, nc, ierr
!
@ -2694,10 +2658,10 @@ SUBROUTINE matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C,
implicit none
!
CHARACTER(LEN=1), INTENT(IN) :: transa, transb
INTEGER, INTENT(IN) :: m, n, k
REAL*8, INTENT(IN) :: alpha, beta
INTEGER, INTENT(IN) :: lda, ldb, ldc
REAL*8 :: a(lda,*), b(ldb,*), c(ldc,*)
INTEGER, INTENT(IN) :: m, n, k
REAL(DP), INTENT(IN) :: alpha, beta
INTEGER, INTENT(IN) :: lda, ldb, ldc
REAL(DP) :: a(lda,*), b(ldb,*), c(ldc,*)
INTEGER, INTENT(IN) :: nb, dims(2), coor(2), comm
!
! DGEMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS
@ -2715,8 +2679,6 @@ SUBROUTINE matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C,
!
#if defined __MPI
include 'mpif.h'
!
integer ierr
integer ndims, rowid, colid
@ -2883,7 +2845,6 @@ SUBROUTINE matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C,
IF( ALLOCATED( at ) ) DEALLOCATE( at )
IF( ALLOCATED( bt ) ) DEALLOCATE( bt )
#else
! if we are not compiling with __MPI this is equivalent to a blas call
@ -2892,7 +2853,6 @@ SUBROUTINE matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C,
#endif
RETURN
END SUBROUTINE
@ -2914,9 +2874,9 @@ SUBROUTINE rep_matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA,
!
CHARACTER(LEN=1), INTENT(IN) :: transa, transb
INTEGER, INTENT(IN) :: m, n, k
REAL*8, INTENT(IN) :: alpha, beta
REAL(DP), INTENT(IN) :: alpha, beta
INTEGER, INTENT(IN) :: lda, ldb, ldc
REAL*8 :: a(lda,*), b(ldb,*), c(ldc,*)
REAL(DP) :: a(lda,*), b(ldb,*), c(ldc,*)
INTEGER, INTENT(IN) :: comm
!
! DGEMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS
@ -2935,7 +2895,6 @@ SUBROUTINE rep_matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA,
#if defined __MPI
include 'mpif.h'
!
INTEGER :: ME, I, II, J, JJ, IP, SOUR, DEST, INFO, IERR, ioff, ldx
@ -3054,7 +3013,6 @@ SUBROUTINE rep_matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA,
DEALLOCATE( auxa, auxc )
#else
! if we are not compiling with __MPI this is equivalent to a blas call
@ -3063,8 +3021,6 @@ SUBROUTINE rep_matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA,
#endif
RETURN
END SUBROUTINE rep_matmul_drv