1SUBROUTINE DSPEVD_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: SPEVD_F77 => LA_SPEVD 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 REAL(WP), INTENT(INOUT) :: A(:) 19 REAL(WP), INTENT(OUT) :: W(:) 20 REAL(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_SPEVD' 81! .. LOCAL SCALARS .. 82 CHARACTER(LEN=1) :: LUPLO, LJOBZ 83 INTEGER :: N, NN, LINFO, LD, ISTAT, ISTAT1, S1Z, S2Z, LWORK, LIWORK 84 INTEGER, SAVE :: LWORKN = 0, LIWORKN = 0, LWORKV = 0, LIWORKV = 0 85 COMPLEX(WP) :: WW 86! .. LOCAL ARRAYS .. 87 REAL(WP), TARGET :: LLZ(1,1) 88 INTEGER, POINTER :: IWORK(:) 89 REAL(WP), POINTER :: WORK(:) 90! .. INTRINSIC FUNCTIONS .. 91 INTRINSIC MAX, PRESENT 92! .. EXECUTABLE STATEMENTS .. 93 LINFO = 0; NN = SIZE(A) 94 WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW); LD = MAX(1,N) 95 IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF 96 IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2); LJOBZ = 'V' 97 ELSE; S1Z = 1; S2Z = 1; LJOBZ = 'N'; END IF 98! .. TEST THE ARGUMENTS 99 IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1 100 ELSE IF( SIZE( W ) /= N )THEN; LINFO = -2 101 ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3 102 ELSE IF( PRESENT(Z) .AND. ( S1Z /= LD .OR. S2Z /= N ) )THEN; LINFO = -4 103 ELSE IF( N > 0 )THEN 104! .. DETERMINE THE WORKSPACE 105 IF( LSAME(LJOBZ,'N') )THEN 106 LWORK = MAX( 1, 2*N, LWORKN ); LIWORK = MAX( 1, LIWORKN ) 107 ELSE 108 LWORK = MAX( 1+ 6*N+N**2, LWORKV ) 109 LIWORK = MAX( 3+5*N, LIWORKV ) 110 END IF 111 ALLOCATE(WORK(LWORK), IWORK(LIWORK), STAT=ISTAT) 112 IF( ISTAT /= 0 )THEN 113 DEALLOCATE( WORK, IWORK, STAT=ISTAT1 ) 114 IF( LSAME(LJOBZ,'N') )THEN; LWORK = MAX( 1, 2*N ); LIWORK = 1 115 ELSE 116 LWORK = 1+ 6*N+N**2 117 LIWORK = 3+5*N; END IF 118 ALLOCATE(WORK(LWORK), IWORK(LIWORK), STAT=ISTAT) 119 IF( ISTAT == 0 ) CALL ERINFO( -200, SRNAME, LINFO ) 120 END IF 121 IF( ISTAT == 0 ) THEN 122 IF( PRESENT(Z) )THEN 123 CALL SPEVD_F77( LJOBZ, LUPLO, N, A, W, Z, S2Z, WORK, LWORK, & 124 IWORK, LIWORK, LINFO ) 125 ELSE 126 CALL SPEVD_F77( LJOBZ, LUPLO, N, A, W, LLZ, S2Z, WORK, LWORK, & 127 IWORK, LIWORK, LINFO ) 128 ENDIF 129 IF (LINFO == 0 ) THEN 130 IF (LSAME(LJOBZ,'N')) THEN 131 LWORKN = INT(WORK(1)); LIWORKN = IWORK(1) 132 ELSE; LWORKV = INT(WORK(1)); LIWORKV = IWORK(1); END IF 133 END IF 134 ELSE; LINFO = -100; ENDIF 135 DEALLOCATE(WORK,IWORK,STAT=ISTAT1) 136 ENDIF 137 CALL ERINFO(LINFO,SRNAME,INFO,ISTAT) 138END SUBROUTINE DSPEVD_F95 139