la_dsyevd.f

网络带宽测试工具

      Subroutine DSYEVD_F90( A, W, JOBZ, UPLO, INFO )
!  ** USE STATEMENTS **
!	Use LA_PRECISION, Only: l_ => l_
!	Use LA_AUXMOD, Only: ERINFO, LSAME
!   USE F77_LAPACK, ONLY: SYEVD_F77 => LA_SYEVD, ILAENV_F77 => ILAENV
!
!  -- LAPACK90 interface driver routine (version 1.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     May 31, 1997
!
!  ** IMPLICIT STATEMENTS **
      Use      numerics
      Implicit None
!  ** REPLACEMENTS FOR USE STATEMENTS **
      Integer :: Ilaenv
      Logical :: Lsame
!  ** CHARACTER ARGUMENTS **
      Character(LEN=1), Intent(IN), Optional :: Jobz, Uplo
!  ** SCALAR ARGUMENTS **
      Integer, Intent(OUT), Optional :: Info
!  ** ARRAY ARGUMENTS **
      Real(l_), Intent(INOUT) :: A(:,:)
      Real(l_), Intent(OUT) :: W(:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
! LA_SYEVD / LA_HEEVD computes all eigenvalues and, optionally, 
! eigenvectors of a real symmetric or Hermitian matrix A. 
! If eigenvectors are desired, it uses a divide and conquer algorithm.
!
! The divide and conquer algorithm makes very mild assumptions about
! floating point arithmetic. It will work on machines with a guard
! digit in add/subtract, or on those binary machines without guard
! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
! Cray-2. It could conceivably fail on hexadecimal or decimal machines
! without guard digits, but we know of none.
!
! =======
!
!    SUBROUTINE LA_SYEVD / LA_HEEVD( A, W, JOBZ, UPLO, INFO )
!       <type>(<wp>), INTENT(INOUT) :: A(:,:)
!       REAL(<wp>), INTENT(OUT) :: W(:)
!       CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
!       INTEGER, INTENT(OUT), OPTIONAL :: INFO
!    where
!       <type> ::= REAL | COMPLEX
!       <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Defaults
! ========
!
! 1. If JOBZ is not present then JOBZ = 'N' is assumed.
! 2. If UPLO is not present then UPLO = 'U' is assumed.
!
! Arguments
! =========
!
! A       (input/output) either REAL or COMPLEX square array, 
!         shape (:,:), size(A,1) == size(A,2) >= 0.
!         On entry, the symmetric (Hermitian) matrix A.  
!            If UPLO = 'U', the upper triangular part of A contains
!               the upper triangular part of the matrix A.  
!            If UPLO = 'L', the lower triangular part of A contains
!               the lower triangular part of the matrix A.
!         On exit: 
!            If JOBZ = 'V', then if INFO = 0, A contains the
!               orthonormal eigenvectors of the matrix A.
!            If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!               or the upper triangle (if UPLO='U') of A, including the
!               diagonal, is destroyed.
!
! W       (output) REAL array,  shape (:), size(W) == size(A,1) >= 0.
!         If INFO = 0, the eigenvalues in ascending order.
!
! JOBZ    Optional, (input) CHARACTER*1
!         If JOBZ is present then:
!            = 'N':  Compute eigenvalues only;
!            = 'V':  Compute eigenvalues and eigenvectors.
!         otherwise JOBZ = 'N' is assumed.
!
! UPLO    Optional, (input) CHARACTER*1
!         If UPLO is present then:
!            = 'U':  Upper triangle of A is stored;
!            = 'L':  Lower triangle of A is stored.
!         otherwise UPLO = 'U' is assumed.
!
! INFO    Optional, (output) INTEGER
!         If INFO is present:
!            = 0: successful exit
!            < 0: if INFO = -i, the i-th argument had an illegal value
!            > 0: if INFO = i, the algorithm failed to converge; i
!                 off-diagonal elements of an intermediate tridiagonal
!                 form did not converge to zero.
!         If INFO is not present and an error occurs, then the program
!            is terminated with an error message.
!
!--------------------------------------------------
!  ** LOCAL PARAMETERS **
      Character(LEN=8), Parameter :: SRname = 'LA_SYEVD'
      Character(LEN=6), Parameter :: BSname = 'DSYTRD'
!  ** LOCAL SCALARS **
      Character(LEN=1) :: Ljobz, Luplo
      Integer :: N, Linfo, LD, Istat, Istat1
      Integer :: Liwork, Lmwork, Lwork, NB
!  ** LOCAL ARRAYS **
      Real(l_), Pointer :: Work(:)
      Integer, Pointer :: Iwork(:)
!  ** INTRINSIC FUNCTIONS **
      Intrinsic Max, Present
!  ** EXECUTABLE STATEMENTS **
      N = Size( A, 1 ); Linfo = 0; LD = Max(1,N); Istat = 0
      If( Present(Jobz) ) Then
            Ljobz = Jobz
      Else
            Ljobz = 'N'
      End If
      If( Present(Uplo) ) Then
            Luplo = Uplo
      Else
            Luplo = 'U'
      End If
!  ** TEST THE ARGUMENTS **
      If( Size( A, 2 ) /= N .OR. N < 0 ) Then
            Linfo = -1
      Else If( Size( W ) /= N ) Then
            Linfo = -2
      Else If( .NOT.Lsame(Ljobz,'N') .AND. .NOT.Lsame(Ljobz,'V') )Then
            Linfo = -3
      Else If( .NOT.Lsame(Luplo,'U') .AND. .NOT.Lsame(Luplo,'L') )Then
            Linfo = -4
      Else If( N > 0 )Then
!  .. DETERMINE THE WORKSPACE
        If( Lsame(Ljobz,'V') )Then
          Lmwork = 1+(5+2*Ceiling(Log(Real(N,l_))/Log(2.0_l_))+10*N)*N
          Liwork = 2+10*N
        Else
          Lmwork = 2*N+1
          Liwork = 1
        End If
        NB = Ilaenv( 1, BSname, Luplo, N, -1, -1, -1 )
        If( NB <= 1 .OR. NB >= N )Then
          NB = 1
        End If
        Lwork = Max( Lmwork, (NB+2)*N )
        Allocate(Work(Lwork), Iwork(Liwork), STAT=Istat)
        If( Istat /= 0 )Then
          Deallocate(Work, Iwork, STAT=Istat1)
          Lwork = Lmwork
          Allocate(Work(Lwork), Iwork(Liwork), STAT=Istat)
          If( ISTAT /= 0 ) Then
             Linfo = - 100
          Else
             Call Erinfo( -200, SRname, Linfo )
          End If
        End If
!
        If( Linfo == 0 )Then
!        .. CALL LAPACK77 ROUTINE
          Call DSYEVD( Ljobz, Luplo, N, A, LD, W, Work, Lwork,
     &                   IWORK, LIWORK,  LINFO )
        End If
        Deallocate(Work, Iwork, STAT=Istat1)
      End If
      Call Erinfo(Linfo,SRname,Info,Istat)
      End Subroutine DSYEVD_F90