check.f

网络带宽测试工具

      Subroutine check( N, A, W, ok )
! **********************************************************************
! *** This program belongs to the program mod2c which is part of     ***
! *** the EuroBen Benchmark.                                         ***
! ***                                                                ***
! *** Copyright: EuroBen Group p/o                                   ***
! ***            Utrecht University, Computational Physics Dept.     ***
! ***            P.O. Box 80195                                      ***
! ***            3508 TD Utrecht                                     ***
! ***            The Netherlands                                     ***
! ***                                                                ***
! *** Author of this program: Loes C.J. van Dam                      ***
! *** Contributed:            Spring 1999                            ***
! **********************************************************************
! --- Purpose of the routine
!     ----------------------
!     Routine 'check' calculates the eigenvalues & eigenvectors of real
!     symmetric matrices (this is done by the LAPACK routine DSYEVD).
!     After transforming back the result is compared with the original 
!     matrix.
! ----------------------------------------------------------------------
      Use      numerics
      Implicit None
! ----------------------------------------------------------------------
      Integer, parameter :: Nin = 1, Nout = 2
      Logical, Intent(OUT) :: ok
      Integer, Intent(IN) :: n
      Real(l_), Intent(IN) :: a(n,n), w(n)
      Real(l_) :: aa(n,n), q(n,n), c(n)
      Real(l_) :: eps, erroraa, errorw, norma, temp
      Integer :: i, j, k, linfo, stat
! --- External Functions and Subroutines -------------------------------

      Interface la_syevd

      Subroutine dsyevd_f90( a, w, jobz, uplo, info )
           Integer, Parameter :: l_ = Selected_Real_Kind(15,307)
           Character*1, Intent(in), Optional :: jobz, uplo
           Integer, Intent(out), Optional :: info
           Real(l_), Intent(inout) :: a(:,:)
           Real(l_), Intent(out) :: w(:)
      End Subroutine dsyevd_f90

      End Interface
! ----------------------------------------------------------------------
            aa = 0
            q = a
! --- Call routine ----------------------------------------------------- 
            Call la_syevd( q, c, 'v', 'l', linfo )
! --- Calculating back to the original matrix --------------------------
            Do k=1,n
               Do i=1,n
                  temp = q(i,k)*w(k)
                  Do j=1,i
                     aa(i,j) = aa(i,j) + temp*q(j,k)
                  End Do
               End Do
            End Do
! --- Check recalculated matrix ----------------------------------------
            ok = .TRUE.
            eps = Epsilon(1.0_l_)
            erroraa = (3*n - 1)*eps
            norma = Max( Abs( w(1) ), Abs( w(n) ) )
            errorw = 10*n*eps*norma
            Do i = 1, n
               Do j = 1, i
                   ok = ok .AND. ( Abs ( aa(i,j) - a(i,j) ) <= erroraa )
               End Do
               ok = ok .AND. ( Abs( c(i) - w(i) ) <= errorw )
            End Do
! ----------------------------------------------------------------------
      End Subroutine check