1SUBROUTINE ZHPEVD_F95( A, W, UPLO, Z, INFO ) 2! 3! -- LAPACK95 interface driver routine (version 3.0) -- 4! UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK 5! September, 2000 6! 7! .. USE STATEMENTS .. 8 USE LA_PRECISION, ONLY: WP => DP 9 USE LA_AUXMOD, ONLY: ERINFO, LSAME 10 USE F77_LAPACK, ONLY: HPEVD_F77 => LA_HPEVD 11! .. IMPLICIT STATEMENT .. 12 IMPLICIT NONE 13! .. CHARACTER ARGUMENTS .. 14 CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO 15! .. SCALAR ARGUMENTS .. 16 INTEGER, INTENT(OUT), OPTIONAL :: INFO 17! .. ARRAY ARGUMENTS .. 18 COMPLEX(WP), INTENT(INOUT) :: A(:) 19 REAL(WP), INTENT(OUT) :: W(:) 20 COMPLEX(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:) 21!---------------------------------------------------------------------- 22! 23! Purpose 24! ======= 25! 26! LA_SPEV and LA_SPEVD compute all eigenvalues and, optionally, all 27! eigenvectors of a real symmetric matrix A in packed storage. 28! LA_HPEV and LA_HPEVD compute all eigenvalues and, optionally, all 29! eigenvectors of a complex Hermitian matrix A in packed storage. 30! LA_SPEVD and LA_HPEVD use a divide and conquer algorithm. If 31! eigenvectors are desired, they can be much faster than LA_SPEV and 32! LA_HPEV for large matrices but use more workspace. 33! 34! ========= 35! 36! SUBROUTINE LA_SPEV / LA_HPEV / LA_SPEVD / LA_HPEVD( AP, W, & 37! UPLO=uplo, Z=z, INFO=info ) 38! <type>(<wp>), INTENT(INOUT) :: AP(:) 39! REAL(<wp>), INTENT(OUT) :: W(:) 40! CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO 41! <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:) 42! INTEGER, INTENT(OUT), OPTIONAL :: INFO 43! where 44! <type> ::= REAL | COMPLEX 45! <wp> ::= KIND(1.0) | KIND(1.0D0) 46! 47! Arguments 48! ========= 49! 50! AP (input/output) REAL or COMPLEX array, shape (:) with size(AP)= 51! n*(n+1)/2, where n is the order of A. 52! On entry, the upper or lower triangle of matrix A in packed 53! storage. The elements are stored columnwise as follows: 54! if UPLO = 'U', AP(i+(j-1)*j/2)=A(i,j) for 1<=i<=j<=n; 55! if UPLO = 'L', AP(i+(j-1)*(2*n-j)/2)=A(i,j) for 1<=j<=i<=n. 56! On exit, AP is overwritten by values generated during the 57! reduction of A to a tridiagonal matrix T . If UPLO = 'U', the 58! diagonal and first superdiagonal of T overwrite the correspond- 59! ing diagonals of A. If UPLO = 'L', the diagonal and first 60! subdiagonal of T overwrite the corresponding diagonals of A. 61! W (output) REAL array, shape (:) with size(W) = n. 62! The eigenvalues in ascending order. 63! UPLO Optional (input) CHARACTER(LEN=1). 64! = 'U': Upper triangle of A is stored; 65! = 'L': Lower triangle of A is stored. 66! Default value: 'U'. 67! Z Optional (output) REAL or COMPLEX square array, shape (:,:) 68! with size(Z,1) = n. 69! The columns of Z contain the orthonormal eigenvectors of A in 70! the order of the eigenvalues. 71! INFO Optional (output) INTEGER. 72! = 0: successful exit. 73! < 0: if INFO = -i, the i-th argument had an illegal value 74! > 0: if INFO = i, then i off-diagonal elements of an 75! intermediate tridiagonal form did not converge to zero. 76! If INFO is not present and an error occurs, then the program is 77! terminated with an error message. 78!---------------------------------------------------------------------- 79! .. LOCAL PARAMETERS .. 80 CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_HPEVD' 81! .. LOCAL SCALARS .. 82 CHARACTER(LEN=1) :: LUPLO, LJOBZ 83 INTEGER :: N, NN, LINFO, LD, ISTAT, ISTAT1, S1Z, S2Z, LWORK, LRWORK, LIWORK, LGN 84 INTEGER, SAVE :: LWORKN = 0, LIWORKN = 0, LWORKV = 0, LIWORKV = 0, & 85 LRWORKN = 0, LRWORKV = 0 86 COMPLEX(WP) :: WW 87! .. LOCAL ARRAYS .. 88 COMPLEX(WP), TARGET :: LLZ(1,1) 89 INTEGER, POINTER :: IWORK(:) 90 COMPLEX(WP), POINTER :: WORK(:) 91 REAL(WP), POINTER :: RWORK(:) 92! .. INTRINSIC FUNCTIONS .. 93 INTRINSIC MAX, PRESENT 94! .. EXECUTABLE STATEMENTS .. 95 LINFO = 0; NN = SIZE(A) 96 WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW); LD = MAX(1,N) 97 IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF 98 IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2); LJOBZ = 'V' 99 ELSE; S1Z = 1; S2Z = 1; LJOBZ = 'N'; END IF 100! .. TEST THE ARGUMENTS 101 IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1 102 ELSE IF( SIZE( W ) /= N )THEN; LINFO = -2 103 ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3 104 ELSE IF( PRESENT(Z) .AND. ( S1Z /= LD .OR. S2Z /= N ) )THEN; LINFO = -4 105 ELSE IF( N > 0 )THEN 106! .. DETERMINE THE WORKSPACE 107 LGN = 1+INT( LOG(REAL(N,WP))/LOG(REAL(2,WP)) ) 108 IF( LSAME(LJOBZ,'N') )THEN 109 LWORK = MAX( 1, N, LWORKN ); LIWORK = MAX( 1, LIWORKN ) 110 LRWORK = MAX( 1, N, LRWORKN ) 111 ELSE 112 LWORK = MAX( 1, 2*N, LWORKV ) 113 LRWORK = MAX( 1+ 5*N+2*N**2, LWORKV ) 114 LIWORK = MAX( 3+5*N, LIWORKV ) 115 END IF 116 117 ALLOCATE(WORK(LWORK), RWORK(LRWORK), IWORK(LIWORK), STAT=ISTAT) 118 IF( ISTAT /= 0 ) THEN 119 DEALLOCATE( WORK, RWORK, IWORK, STAT=ISTAT1 ) 120 IF( LSAME(LJOBZ,'N') )THEN; LWORK = MAX( 1, 2*N ) 121 LRWORK = MAX(1, 2*N ); LIWORK = 1 122 ELSE; LWORK = MAX( 1, 2*N ); LIWORK = 2+5*N 123 LWORK = 1+ 4*N+2*N*LGN+3*N**2; END IF 124 ALLOCATE(WORK(LWORK), RWORK(LRWORK), IWORK(LIWORK), STAT=ISTAT) 125 IF( ISTAT == 0 ) CALL ERINFO( -200, SRNAME, LINFO ) 126 END IF 127 IF( ISTAT == 0 ) THEN 128 IF( PRESENT(Z) )THEN 129 CALL HPEVD_F77( LJOBZ, LUPLO, N, A, W, Z, S2Z, WORK, LWORK, & 130 RWORK, LRWORK, IWORK, LIWORK, LINFO ) 131 ELSE 132 CALL HPEVD_F77( LJOBZ, LUPLO, N, A, W, LLZ, S2Z, WORK, LWORK, & 133 RWORK, LRWORK, IWORK, LIWORK, LINFO ) 134 ENDIF 135 136 IF (LINFO == 0 ) THEN 137 IF (LSAME(LJOBZ,'N')) THEN; LWORKN = INT(WORK(1)+1) 138 LRWORKN = INT(RWORK(1)+1); LIWORKN = IWORK(1) 139 ELSE; LWORKV = INT(WORK(1)); LRWORKV = INT(RWORK(1)+1); 140 LIWORKV = IWORK(1); END IF 141 END IF 142 ELSE; LINFO = -100; ENDIF 143 DEALLOCATE(WORK, RWORK, IWORK, STAT=ISTAT1) 144 ENDIF 145 CALL ERINFO(LINFO,SRNAME,INFO,ISTAT) 146END SUBROUTINE ZHPEVD_F95 147